4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
106 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
107 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
108 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
110 #if defined(PL_OP_SLAB_ALLOC)
112 #ifdef PERL_DEBUG_READONLY_OPS
113 # define PERL_SLAB_SIZE 4096
114 # include <sys/mman.h>
117 #ifndef PERL_SLAB_SIZE
118 #define PERL_SLAB_SIZE 2048
122 Perl_Slab_Alloc(pTHX_ size_t sz)
126 * To make incrementing use count easy PL_OpSlab is an I32 *
127 * To make inserting the link to slab PL_OpPtr is I32 **
128 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
129 * Add an overhead for pointer to slab and round up as a number of pointers
131 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
132 if ((PL_OpSpace -= sz) < 0) {
133 #ifdef PERL_DEBUG_READONLY_OPS
134 /* We need to allocate chunk by chunk so that we can control the VM
136 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
139 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
140 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
142 if(PL_OpPtr == MAP_FAILED) {
143 perror("mmap failed");
148 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
153 /* We reserve the 0'th I32 sized chunk as a use count */
154 PL_OpSlab = (I32 *) PL_OpPtr;
155 /* Reduce size by the use count word, and by the size we need.
156 * Latter is to mimic the '-=' in the if() above
158 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
159 /* Allocation pointer starts at the top.
160 Theory: because we build leaves before trunk allocating at end
161 means that at run time access is cache friendly upward
163 PL_OpPtr += PERL_SLAB_SIZE;
165 #ifdef PERL_DEBUG_READONLY_OPS
166 /* We remember this slab. */
167 /* This implementation isn't efficient, but it is simple. */
168 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
169 PL_slabs[PL_slab_count++] = PL_OpSlab;
170 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
173 assert( PL_OpSpace >= 0 );
174 /* Move the allocation pointer down */
176 assert( PL_OpPtr > (I32 **) PL_OpSlab );
177 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
178 (*PL_OpSlab)++; /* Increment use count of slab */
179 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
180 assert( *PL_OpSlab > 0 );
181 return (void *)(PL_OpPtr + 1);
184 #ifdef PERL_DEBUG_READONLY_OPS
186 Perl_pending_Slabs_to_ro(pTHX) {
187 /* Turn all the allocated op slabs read only. */
188 U32 count = PL_slab_count;
189 I32 **const slabs = PL_slabs;
191 /* Reset the array of pending OP slabs, as we're about to turn this lot
192 read only. Also, do it ahead of the loop in case the warn triggers,
193 and a warn handler has an eval */
198 /* Force a new slab for any further allocation. */
202 void *const start = slabs[count];
203 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
204 if(mprotect(start, size, PROT_READ)) {
205 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
206 start, (unsigned long) size, errno);
214 S_Slab_to_rw(pTHX_ void *op)
216 I32 * const * const ptr = (I32 **) op;
217 I32 * const slab = ptr[-1];
219 PERL_ARGS_ASSERT_SLAB_TO_RW;
221 assert( ptr-1 > (I32 **) slab );
222 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
224 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
225 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
226 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
231 Perl_op_refcnt_inc(pTHX_ OP *o)
242 Perl_op_refcnt_dec(pTHX_ OP *o)
244 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
249 # define Slab_to_rw(op)
253 Perl_Slab_Free(pTHX_ void *op)
255 I32 * const * const ptr = (I32 **) op;
256 I32 * const slab = ptr[-1];
257 PERL_ARGS_ASSERT_SLAB_FREE;
258 assert( ptr-1 > (I32 **) slab );
259 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
262 if (--(*slab) == 0) {
264 # define PerlMemShared PerlMem
267 #ifdef PERL_DEBUG_READONLY_OPS
268 U32 count = PL_slab_count;
269 /* Need to remove this slab from our list of slabs */
272 if (PL_slabs[count] == slab) {
274 /* Found it. Move the entry at the end to overwrite it. */
275 DEBUG_m(PerlIO_printf(Perl_debug_log,
276 "Deallocate %p by moving %p from %lu to %lu\n",
278 PL_slabs[PL_slab_count - 1],
279 PL_slab_count, count));
280 PL_slabs[count] = PL_slabs[--PL_slab_count];
281 /* Could realloc smaller at this point, but probably not
283 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
284 perror("munmap failed");
292 PerlMemShared_free(slab);
294 if (slab == PL_OpSlab) {
301 * In the following definition, the ", (OP*)0" is just to make the compiler
302 * think the expression is of the right type: croak actually does a Siglongjmp.
304 #define CHECKOP(type,o) \
305 ((PL_op_mask && PL_op_mask[type]) \
306 ? ( op_free((OP*)o), \
307 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
309 : PL_check[type](aTHX_ (OP*)o))
311 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
314 S_gv_ename(pTHX_ GV *gv)
316 SV* const tmpsv = sv_newmortal();
318 PERL_ARGS_ASSERT_GV_ENAME;
320 gv_efullname3(tmpsv, gv, NULL);
321 return SvPV_nolen_const(tmpsv);
325 S_no_fh_allowed(pTHX_ OP *o)
327 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
329 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
335 S_too_few_arguments(pTHX_ OP *o, const char *name)
337 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
339 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
344 S_too_many_arguments(pTHX_ OP *o, const char *name)
346 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
348 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
353 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
355 PERL_ARGS_ASSERT_BAD_TYPE;
357 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
358 (int)n, name, t, OP_DESC(kid)));
362 S_no_bareword_allowed(pTHX_ const OP *o)
364 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
367 return; /* various ok barewords are hidden in extra OP_NULL */
368 qerror(Perl_mess(aTHX_
369 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
373 /* "register" allocation */
376 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
380 const bool is_our = (PL_parser->in_my == KEY_our);
382 PERL_ARGS_ASSERT_ALLOCMY;
385 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
388 /* Until we're using the length for real, cross check that we're being
390 assert(strlen(name) == len);
392 /* complain about "my $<special_var>" etc etc */
396 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
397 (name[1] == '_' && (*name == '$' || len > 2))))
399 /* name[2] is true if strlen(name) > 2 */
400 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
401 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
402 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
403 PL_parser->in_my == KEY_state ? "state" : "my"));
405 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
406 PL_parser->in_my == KEY_state ? "state" : "my"));
410 /* allocate a spare slot and store the name in that slot */
412 off = pad_add_name(name, len,
413 is_our ? padadd_OUR :
414 PL_parser->in_my == KEY_state ? padadd_STATE : 0,
415 PL_parser->in_my_stash,
417 /* $_ is always in main::, even with our */
418 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
422 /* anon sub prototypes contains state vars should always be cloned,
423 * otherwise the state var would be shared between anon subs */
425 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
426 CvCLONE_on(PL_compcv);
431 /* free the body of an op without examining its contents.
432 * Always use this rather than FreeOp directly */
435 S_op_destroy(pTHX_ OP *o)
437 if (o->op_latefree) {
445 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
447 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
453 Perl_op_free(pTHX_ OP *o)
460 if (o->op_latefreed) {
467 if (o->op_private & OPpREFCOUNTED) {
478 refcnt = OpREFCNT_dec(o);
481 /* Need to find and remove any pattern match ops from the list
482 we maintain for reset(). */
483 find_and_forget_pmops(o);
493 /* Call the op_free hook if it has been set. Do it now so that it's called
494 * at the right time for refcounted ops, but still before all of the kids
498 if (o->op_flags & OPf_KIDS) {
499 register OP *kid, *nextkid;
500 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
501 nextkid = kid->op_sibling; /* Get before next freeing kid */
506 #ifdef PERL_DEBUG_READONLY_OPS
510 /* COP* is not cleared by op_clear() so that we may track line
511 * numbers etc even after null() */
512 if (type == OP_NEXTSTATE || type == OP_DBSTATE
513 || (type == OP_NULL /* the COP might have been null'ed */
514 && ((OPCODE)o->op_targ == OP_NEXTSTATE
515 || (OPCODE)o->op_targ == OP_DBSTATE))) {
520 type = (OPCODE)o->op_targ;
523 if (o->op_latefree) {
529 #ifdef DEBUG_LEAKING_SCALARS
536 Perl_op_clear(pTHX_ OP *o)
541 PERL_ARGS_ASSERT_OP_CLEAR;
544 /* if (o->op_madprop && o->op_madprop->mad_next)
546 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
547 "modification of a read only value" for a reason I can't fathom why.
548 It's the "" stringification of $_, where $_ was set to '' in a foreach
549 loop, but it defies simplification into a small test case.
550 However, commenting them out has caused ext/List/Util/t/weak.t to fail
553 mad_free(o->op_madprop);
559 switch (o->op_type) {
560 case OP_NULL: /* Was holding old type, if any. */
561 if (PL_madskills && o->op_targ != OP_NULL) {
562 o->op_type = (Optype)o->op_targ;
567 case OP_ENTEREVAL: /* Was holding hints. */
571 if (!(o->op_flags & OPf_REF)
572 || (PL_check[o->op_type] != Perl_ck_ftst))
578 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
579 /* not an OP_PADAV replacement */
580 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
585 /* It's possible during global destruction that the GV is freed
586 before the optree. Whilst the SvREFCNT_inc is happy to bump from
587 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
588 will trigger an assertion failure, because the entry to sv_clear
589 checks that the scalar is not already freed. A check of for
590 !SvIS_FREED(gv) turns out to be invalid, because during global
591 destruction the reference count can be forced down to zero
592 (with SVf_BREAK set). In which case raising to 1 and then
593 dropping to 0 triggers cleanup before it should happen. I
594 *think* that this might actually be a general, systematic,
595 weakness of the whole idea of SVf_BREAK, in that code *is*
596 allowed to raise and lower references during global destruction,
597 so any *valid* code that happens to do this during global
598 destruction might well trigger premature cleanup. */
599 bool still_valid = gv && SvREFCNT(gv);
602 SvREFCNT_inc_simple_void(gv);
604 if (cPADOPo->op_padix > 0) {
605 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
606 * may still exist on the pad */
607 pad_swipe(cPADOPo->op_padix, TRUE);
608 cPADOPo->op_padix = 0;
611 SvREFCNT_dec(cSVOPo->op_sv);
612 cSVOPo->op_sv = NULL;
615 int try_downgrade = SvREFCNT(gv) == 2;
618 gv_try_downgrade(gv);
622 case OP_METHOD_NAMED:
625 SvREFCNT_dec(cSVOPo->op_sv);
626 cSVOPo->op_sv = NULL;
629 Even if op_clear does a pad_free for the target of the op,
630 pad_free doesn't actually remove the sv that exists in the pad;
631 instead it lives on. This results in that it could be reused as
632 a target later on when the pad was reallocated.
635 pad_swipe(o->op_targ,1);
644 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
648 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
650 if (cPADOPo->op_padix > 0) {
651 pad_swipe(cPADOPo->op_padix, TRUE);
652 cPADOPo->op_padix = 0;
655 SvREFCNT_dec(cSVOPo->op_sv);
656 cSVOPo->op_sv = NULL;
660 PerlMemShared_free(cPVOPo->op_pv);
661 cPVOPo->op_pv = NULL;
665 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
669 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
670 /* No GvIN_PAD_off here, because other references may still
671 * exist on the pad */
672 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
675 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
681 forget_pmop(cPMOPo, 1);
682 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
683 /* we use the same protection as the "SAFE" version of the PM_ macros
684 * here since sv_clean_all might release some PMOPs
685 * after PL_regex_padav has been cleared
686 * and the clearing of PL_regex_padav needs to
687 * happen before sv_clean_all
690 if(PL_regex_pad) { /* We could be in destruction */
691 const IV offset = (cPMOPo)->op_pmoffset;
692 ReREFCNT_dec(PM_GETRE(cPMOPo));
693 PL_regex_pad[offset] = &PL_sv_undef;
694 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
698 ReREFCNT_dec(PM_GETRE(cPMOPo));
699 PM_SETRE(cPMOPo, NULL);
705 if (o->op_targ > 0) {
706 pad_free(o->op_targ);
712 S_cop_free(pTHX_ COP* cop)
714 PERL_ARGS_ASSERT_COP_FREE;
718 if (! specialWARN(cop->cop_warnings))
719 PerlMemShared_free(cop->cop_warnings);
720 cophh_free(CopHINTHASH_get(cop));
724 S_forget_pmop(pTHX_ PMOP *const o
730 HV * const pmstash = PmopSTASH(o);
732 PERL_ARGS_ASSERT_FORGET_PMOP;
734 if (pmstash && !SvIS_FREED(pmstash)) {
735 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
737 PMOP **const array = (PMOP**) mg->mg_ptr;
738 U32 count = mg->mg_len / sizeof(PMOP**);
743 /* Found it. Move the entry at the end to overwrite it. */
744 array[i] = array[--count];
745 mg->mg_len = count * sizeof(PMOP**);
746 /* Could realloc smaller at this point always, but probably
747 not worth it. Probably worth free()ing if we're the
750 Safefree(mg->mg_ptr);
767 S_find_and_forget_pmops(pTHX_ OP *o)
769 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
771 if (o->op_flags & OPf_KIDS) {
772 OP *kid = cUNOPo->op_first;
774 switch (kid->op_type) {
779 forget_pmop((PMOP*)kid, 0);
781 find_and_forget_pmops(kid);
782 kid = kid->op_sibling;
788 Perl_op_null(pTHX_ OP *o)
792 PERL_ARGS_ASSERT_OP_NULL;
794 if (o->op_type == OP_NULL)
798 o->op_targ = o->op_type;
799 o->op_type = OP_NULL;
800 o->op_ppaddr = PL_ppaddr[OP_NULL];
804 Perl_op_refcnt_lock(pTHX)
812 Perl_op_refcnt_unlock(pTHX)
819 /* Contextualizers */
822 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
824 Applies a syntactic context to an op tree representing an expression.
825 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
826 or C<G_VOID> to specify the context to apply. The modified op tree
833 Perl_op_contextualize(pTHX_ OP *o, I32 context)
835 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
837 case G_SCALAR: return scalar(o);
838 case G_ARRAY: return list(o);
839 case G_VOID: return scalarvoid(o);
841 Perl_croak(aTHX_ "panic: op_contextualize bad context");
847 =head1 Optree Manipulation Functions
849 =for apidoc Am|OP*|op_linklist|OP *o
850 This function is the implementation of the L</LINKLIST> macro. It should
851 not be called directly.
857 Perl_op_linklist(pTHX_ OP *o)
861 PERL_ARGS_ASSERT_OP_LINKLIST;
866 /* establish postfix order */
867 first = cUNOPo->op_first;
870 o->op_next = LINKLIST(first);
873 if (kid->op_sibling) {
874 kid->op_next = LINKLIST(kid->op_sibling);
875 kid = kid->op_sibling;
889 S_scalarkids(pTHX_ OP *o)
891 if (o && o->op_flags & OPf_KIDS) {
893 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
900 S_scalarboolean(pTHX_ OP *o)
904 PERL_ARGS_ASSERT_SCALARBOOLEAN;
906 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
907 if (ckWARN(WARN_SYNTAX)) {
908 const line_t oldline = CopLINE(PL_curcop);
910 if (PL_parser && PL_parser->copline != NOLINE)
911 CopLINE_set(PL_curcop, PL_parser->copline);
912 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
913 CopLINE_set(PL_curcop, oldline);
920 Perl_scalar(pTHX_ OP *o)
925 /* assumes no premature commitment */
926 if (!o || (PL_parser && PL_parser->error_count)
927 || (o->op_flags & OPf_WANT)
928 || o->op_type == OP_RETURN)
933 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
935 switch (o->op_type) {
937 scalar(cBINOPo->op_first);
942 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
952 if (o->op_flags & OPf_KIDS) {
953 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
959 kid = cLISTOPo->op_first;
961 kid = kid->op_sibling;
964 OP *sib = kid->op_sibling;
965 if (sib && kid->op_type != OP_LEAVEWHEN) {
966 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
976 PL_curcop = &PL_compiling;
981 kid = cLISTOPo->op_first;
984 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
991 Perl_scalarvoid(pTHX_ OP *o)
995 const char* useless = NULL;
999 PERL_ARGS_ASSERT_SCALARVOID;
1001 /* trailing mad null ops don't count as "there" for void processing */
1003 o->op_type != OP_NULL &&
1005 o->op_sibling->op_type == OP_NULL)
1008 for (sib = o->op_sibling;
1009 sib && sib->op_type == OP_NULL;
1010 sib = sib->op_sibling) ;
1016 if (o->op_type == OP_NEXTSTATE
1017 || o->op_type == OP_DBSTATE
1018 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1019 || o->op_targ == OP_DBSTATE)))
1020 PL_curcop = (COP*)o; /* for warning below */
1022 /* assumes no premature commitment */
1023 want = o->op_flags & OPf_WANT;
1024 if ((want && want != OPf_WANT_SCALAR)
1025 || (PL_parser && PL_parser->error_count)
1026 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1031 if ((o->op_private & OPpTARGET_MY)
1032 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1034 return scalar(o); /* As if inside SASSIGN */
1037 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1039 switch (o->op_type) {
1041 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1045 if (o->op_flags & OPf_STACKED)
1049 if (o->op_private == 4)
1092 case OP_GETSOCKNAME:
1093 case OP_GETPEERNAME:
1098 case OP_GETPRIORITY:
1122 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1123 /* Otherwise it's "Useless use of grep iterator" */
1124 useless = OP_DESC(o);
1128 kid = cLISTOPo->op_first;
1129 if (kid && kid->op_type == OP_PUSHRE
1131 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1133 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1135 useless = OP_DESC(o);
1139 kid = cUNOPo->op_first;
1140 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1141 kid->op_type != OP_TRANS) {
1144 useless = "negative pattern binding (!~)";
1148 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1149 useless = "Non-destructive substitution (s///r)";
1156 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1157 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1158 useless = "a variable";
1163 if (cSVOPo->op_private & OPpCONST_STRICT)
1164 no_bareword_allowed(o);
1166 if (ckWARN(WARN_VOID)) {
1168 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1169 "a constant (%"SVf")", sv));
1170 useless = SvPV_nolen(msv);
1173 useless = "a constant (undef)";
1174 if (o->op_private & OPpCONST_ARYBASE)
1176 /* don't warn on optimised away booleans, eg
1177 * use constant Foo, 5; Foo || print; */
1178 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1180 /* the constants 0 and 1 are permitted as they are
1181 conventionally used as dummies in constructs like
1182 1 while some_condition_with_side_effects; */
1183 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1185 else if (SvPOK(sv)) {
1186 /* perl4's way of mixing documentation and code
1187 (before the invention of POD) was based on a
1188 trick to mix nroff and perl code. The trick was
1189 built upon these three nroff macros being used in
1190 void context. The pink camel has the details in
1191 the script wrapman near page 319. */
1192 const char * const maybe_macro = SvPVX_const(sv);
1193 if (strnEQ(maybe_macro, "di", 2) ||
1194 strnEQ(maybe_macro, "ds", 2) ||
1195 strnEQ(maybe_macro, "ig", 2))
1200 op_null(o); /* don't execute or even remember it */
1204 o->op_type = OP_PREINC; /* pre-increment is faster */
1205 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1209 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1210 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1214 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1215 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1219 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1220 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1225 kid = cLOGOPo->op_first;
1226 if (kid->op_type == OP_NOT
1227 && (kid->op_flags & OPf_KIDS)
1229 if (o->op_type == OP_AND) {
1231 o->op_ppaddr = PL_ppaddr[OP_OR];
1233 o->op_type = OP_AND;
1234 o->op_ppaddr = PL_ppaddr[OP_AND];
1243 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1248 if (o->op_flags & OPf_STACKED)
1255 if (!(o->op_flags & OPf_KIDS))
1266 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1276 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1281 S_listkids(pTHX_ OP *o)
1283 if (o && o->op_flags & OPf_KIDS) {
1285 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1292 Perl_list(pTHX_ OP *o)
1297 /* assumes no premature commitment */
1298 if (!o || (o->op_flags & OPf_WANT)
1299 || (PL_parser && PL_parser->error_count)
1300 || o->op_type == OP_RETURN)
1305 if ((o->op_private & OPpTARGET_MY)
1306 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1308 return o; /* As if inside SASSIGN */
1311 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1313 switch (o->op_type) {
1316 list(cBINOPo->op_first);
1321 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1329 if (!(o->op_flags & OPf_KIDS))
1331 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1332 list(cBINOPo->op_first);
1333 return gen_constant_list(o);
1340 kid = cLISTOPo->op_first;
1342 kid = kid->op_sibling;
1345 OP *sib = kid->op_sibling;
1346 if (sib && kid->op_type != OP_LEAVEWHEN) {
1347 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1357 PL_curcop = &PL_compiling;
1361 kid = cLISTOPo->op_first;
1368 S_scalarseq(pTHX_ OP *o)
1372 const OPCODE type = o->op_type;
1374 if (type == OP_LINESEQ || type == OP_SCOPE ||
1375 type == OP_LEAVE || type == OP_LEAVETRY)
1378 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1379 if (kid->op_sibling) {
1383 PL_curcop = &PL_compiling;
1385 o->op_flags &= ~OPf_PARENS;
1386 if (PL_hints & HINT_BLOCK_SCOPE)
1387 o->op_flags |= OPf_PARENS;
1390 o = newOP(OP_STUB, 0);
1395 S_modkids(pTHX_ OP *o, I32 type)
1397 if (o && o->op_flags & OPf_KIDS) {
1399 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1400 op_lvalue(kid, type);
1406 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1408 Propagate lvalue ("modifiable") context to an op and its children.
1409 I<type> represents the context type, roughly based on the type of op that
1410 would do the modifying, although C<local()> is represented by OP_NULL,
1411 because it has no op type of its own (it is signalled by a flag on
1412 the lvalue op). This function detects things that can't be modified,
1413 such as C<$x+1>, and generates errors for them. It also flags things
1414 that need to behave specially in an lvalue context, such as C<$$x>
1415 which might have to vivify a reference in C<$x>.
1421 Perl_op_lvalue(pTHX_ OP *o, I32 type)
1425 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1428 if (!o || (PL_parser && PL_parser->error_count))
1431 if ((o->op_private & OPpTARGET_MY)
1432 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1437 switch (o->op_type) {
1443 if (!(o->op_private & OPpCONST_ARYBASE))
1446 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1447 CopARYBASE_set(&PL_compiling,
1448 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1452 SAVECOPARYBASE(&PL_compiling);
1453 CopARYBASE_set(&PL_compiling, 0);
1455 else if (type == OP_REFGEN)
1458 Perl_croak(aTHX_ "That use of $[ is unsupported");
1461 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1465 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1466 !(o->op_flags & OPf_STACKED)) {
1467 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1468 /* The default is to set op_private to the number of children,
1469 which for a UNOP such as RV2CV is always 1. And w're using
1470 the bit for a flag in RV2CV, so we need it clear. */
1471 o->op_private &= ~1;
1472 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1473 assert(cUNOPo->op_first->op_type == OP_NULL);
1474 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1477 else if (o->op_private & OPpENTERSUB_NOMOD)
1479 else { /* lvalue subroutine call */
1480 o->op_private |= OPpLVAL_INTRO;
1481 PL_modcount = RETURN_UNLIMITED_NUMBER;
1482 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1483 /* Backward compatibility mode: */
1484 o->op_private |= OPpENTERSUB_INARGS;
1487 else { /* Compile-time error message: */
1488 OP *kid = cUNOPo->op_first;
1492 if (kid->op_type != OP_PUSHMARK) {
1493 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1495 "panic: unexpected lvalue entersub "
1496 "args: type/targ %ld:%"UVuf,
1497 (long)kid->op_type, (UV)kid->op_targ);
1498 kid = kLISTOP->op_first;
1500 while (kid->op_sibling)
1501 kid = kid->op_sibling;
1502 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1504 if (kid->op_type == OP_METHOD_NAMED
1505 || kid->op_type == OP_METHOD)
1509 NewOp(1101, newop, 1, UNOP);
1510 newop->op_type = OP_RV2CV;
1511 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1512 newop->op_first = NULL;
1513 newop->op_next = (OP*)newop;
1514 kid->op_sibling = (OP*)newop;
1515 newop->op_private |= OPpLVAL_INTRO;
1516 newop->op_private &= ~1;
1520 if (kid->op_type != OP_RV2CV)
1522 "panic: unexpected lvalue entersub "
1523 "entry via type/targ %ld:%"UVuf,
1524 (long)kid->op_type, (UV)kid->op_targ);
1525 kid->op_private |= OPpLVAL_INTRO;
1526 break; /* Postpone until runtime */
1530 kid = kUNOP->op_first;
1531 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1532 kid = kUNOP->op_first;
1533 if (kid->op_type == OP_NULL)
1535 "Unexpected constant lvalue entersub "
1536 "entry via type/targ %ld:%"UVuf,
1537 (long)kid->op_type, (UV)kid->op_targ);
1538 if (kid->op_type != OP_GV) {
1539 /* Restore RV2CV to check lvalueness */
1541 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1542 okid->op_next = kid->op_next;
1543 kid->op_next = okid;
1546 okid->op_next = NULL;
1547 okid->op_type = OP_RV2CV;
1549 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1550 okid->op_private |= OPpLVAL_INTRO;
1551 okid->op_private &= ~1;
1555 cv = GvCV(kGVOP_gv);
1565 /* grep, foreach, subcalls, refgen */
1566 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1568 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1569 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1571 : (o->op_type == OP_ENTERSUB
1572 ? "non-lvalue subroutine call"
1574 type ? PL_op_desc[type] : "local"));
1588 case OP_RIGHT_SHIFT:
1597 if (!(o->op_flags & OPf_STACKED))
1604 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1605 op_lvalue(kid, type);
1610 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1611 PL_modcount = RETURN_UNLIMITED_NUMBER;
1612 return o; /* Treat \(@foo) like ordinary list. */
1616 if (scalar_mod_type(o, type))
1618 ref(cUNOPo->op_first, o->op_type);
1622 if (type == OP_LEAVESUBLV)
1623 o->op_private |= OPpMAYBE_LVSUB;
1629 PL_modcount = RETURN_UNLIMITED_NUMBER;
1632 PL_hints |= HINT_BLOCK_SCOPE;
1633 if (type == OP_LEAVESUBLV)
1634 o->op_private |= OPpMAYBE_LVSUB;
1638 ref(cUNOPo->op_first, o->op_type);
1642 PL_hints |= HINT_BLOCK_SCOPE;
1657 PL_modcount = RETURN_UNLIMITED_NUMBER;
1658 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1659 return o; /* Treat \(@foo) like ordinary list. */
1660 if (scalar_mod_type(o, type))
1662 if (type == OP_LEAVESUBLV)
1663 o->op_private |= OPpMAYBE_LVSUB;
1667 if (!type) /* local() */
1668 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1669 PAD_COMPNAME_PV(o->op_targ));
1677 if (type != OP_SASSIGN)
1681 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1686 if (type == OP_LEAVESUBLV)
1687 o->op_private |= OPpMAYBE_LVSUB;
1689 pad_free(o->op_targ);
1690 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1691 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1692 if (o->op_flags & OPf_KIDS)
1693 op_lvalue(cBINOPo->op_first->op_sibling, type);
1698 ref(cBINOPo->op_first, o->op_type);
1699 if (type == OP_ENTERSUB &&
1700 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1701 o->op_private |= OPpLVAL_DEFER;
1702 if (type == OP_LEAVESUBLV)
1703 o->op_private |= OPpMAYBE_LVSUB;
1713 if (o->op_flags & OPf_KIDS)
1714 op_lvalue(cLISTOPo->op_last, type);
1719 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1721 else if (!(o->op_flags & OPf_KIDS))
1723 if (o->op_targ != OP_LIST) {
1724 op_lvalue(cBINOPo->op_first, type);
1730 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1731 op_lvalue(kid, type);
1735 if (type != OP_LEAVESUBLV)
1737 break; /* op_lvalue()ing was handled by ck_return() */
1740 /* [20011101.069] File test operators interpret OPf_REF to mean that
1741 their argument is a filehandle; thus \stat(".") should not set
1743 if (type == OP_REFGEN &&
1744 PL_check[o->op_type] == Perl_ck_ftst)
1747 if (type != OP_LEAVESUBLV)
1748 o->op_flags |= OPf_MOD;
1750 if (type == OP_AASSIGN || type == OP_SASSIGN)
1751 o->op_flags |= OPf_SPECIAL|OPf_REF;
1752 else if (!type) { /* local() */
1755 o->op_private |= OPpLVAL_INTRO;
1756 o->op_flags &= ~OPf_SPECIAL;
1757 PL_hints |= HINT_BLOCK_SCOPE;
1762 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1763 "Useless localization of %s", OP_DESC(o));
1766 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1767 && type != OP_LEAVESUBLV)
1768 o->op_flags |= OPf_REF;
1773 S_scalar_mod_type(const OP *o, I32 type)
1775 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1779 if (o->op_type == OP_RV2GV)
1803 case OP_RIGHT_SHIFT:
1823 S_is_handle_constructor(const OP *o, I32 numargs)
1825 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1827 switch (o->op_type) {
1835 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1848 S_refkids(pTHX_ OP *o, I32 type)
1850 if (o && o->op_flags & OPf_KIDS) {
1852 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1859 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1864 PERL_ARGS_ASSERT_DOREF;
1866 if (!o || (PL_parser && PL_parser->error_count))
1869 switch (o->op_type) {
1871 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1872 !(o->op_flags & OPf_STACKED)) {
1873 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1874 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1875 assert(cUNOPo->op_first->op_type == OP_NULL);
1876 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1877 o->op_flags |= OPf_SPECIAL;
1878 o->op_private &= ~1;
1883 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1884 doref(kid, type, set_op_ref);
1887 if (type == OP_DEFINED)
1888 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1889 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1892 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1893 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1894 : type == OP_RV2HV ? OPpDEREF_HV
1896 o->op_flags |= OPf_MOD;
1903 o->op_flags |= OPf_REF;
1906 if (type == OP_DEFINED)
1907 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1908 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1914 o->op_flags |= OPf_REF;
1919 if (!(o->op_flags & OPf_KIDS))
1921 doref(cBINOPo->op_first, type, set_op_ref);
1925 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1926 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1927 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1928 : type == OP_RV2HV ? OPpDEREF_HV
1930 o->op_flags |= OPf_MOD;
1940 if (!(o->op_flags & OPf_KIDS))
1942 doref(cLISTOPo->op_last, type, set_op_ref);
1952 S_dup_attrlist(pTHX_ OP *o)
1957 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1959 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1960 * where the first kid is OP_PUSHMARK and the remaining ones
1961 * are OP_CONST. We need to push the OP_CONST values.
1963 if (o->op_type == OP_CONST)
1964 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1966 else if (o->op_type == OP_NULL)
1970 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1972 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1973 if (o->op_type == OP_CONST)
1974 rop = op_append_elem(OP_LIST, rop,
1975 newSVOP(OP_CONST, o->op_flags,
1976 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1983 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1988 PERL_ARGS_ASSERT_APPLY_ATTRS;
1990 /* fake up C<use attributes $pkg,$rv,@attrs> */
1991 ENTER; /* need to protect against side-effects of 'use' */
1992 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1994 #define ATTRSMODULE "attributes"
1995 #define ATTRSMODULE_PM "attributes.pm"
1998 /* Don't force the C<use> if we don't need it. */
1999 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2000 if (svp && *svp != &PL_sv_undef)
2001 NOOP; /* already in %INC */
2003 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2004 newSVpvs(ATTRSMODULE), NULL);
2007 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2008 newSVpvs(ATTRSMODULE),
2010 op_prepend_elem(OP_LIST,
2011 newSVOP(OP_CONST, 0, stashsv),
2012 op_prepend_elem(OP_LIST,
2013 newSVOP(OP_CONST, 0,
2015 dup_attrlist(attrs))));
2021 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2024 OP *pack, *imop, *arg;
2027 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2032 assert(target->op_type == OP_PADSV ||
2033 target->op_type == OP_PADHV ||
2034 target->op_type == OP_PADAV);
2036 /* Ensure that attributes.pm is loaded. */
2037 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2039 /* Need package name for method call. */
2040 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2042 /* Build up the real arg-list. */
2043 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2045 arg = newOP(OP_PADSV, 0);
2046 arg->op_targ = target->op_targ;
2047 arg = op_prepend_elem(OP_LIST,
2048 newSVOP(OP_CONST, 0, stashsv),
2049 op_prepend_elem(OP_LIST,
2050 newUNOP(OP_REFGEN, 0,
2051 op_lvalue(arg, OP_REFGEN)),
2052 dup_attrlist(attrs)));
2054 /* Fake up a method call to import */
2055 meth = newSVpvs_share("import");
2056 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2057 op_append_elem(OP_LIST,
2058 op_prepend_elem(OP_LIST, pack, list(arg)),
2059 newSVOP(OP_METHOD_NAMED, 0, meth)));
2060 imop->op_private |= OPpENTERSUB_NOMOD;
2062 /* Combine the ops. */
2063 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2067 =notfor apidoc apply_attrs_string
2069 Attempts to apply a list of attributes specified by the C<attrstr> and
2070 C<len> arguments to the subroutine identified by the C<cv> argument which
2071 is expected to be associated with the package identified by the C<stashpv>
2072 argument (see L<attributes>). It gets this wrong, though, in that it
2073 does not correctly identify the boundaries of the individual attribute
2074 specifications within C<attrstr>. This is not really intended for the
2075 public API, but has to be listed here for systems such as AIX which
2076 need an explicit export list for symbols. (It's called from XS code
2077 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2078 to respect attribute syntax properly would be welcome.
2084 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2085 const char *attrstr, STRLEN len)
2089 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2092 len = strlen(attrstr);
2096 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2098 const char * const sstr = attrstr;
2099 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2100 attrs = op_append_elem(OP_LIST, attrs,
2101 newSVOP(OP_CONST, 0,
2102 newSVpvn(sstr, attrstr-sstr)));
2106 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2107 newSVpvs(ATTRSMODULE),
2108 NULL, op_prepend_elem(OP_LIST,
2109 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2110 op_prepend_elem(OP_LIST,
2111 newSVOP(OP_CONST, 0,
2112 newRV(MUTABLE_SV(cv))),
2117 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2122 PERL_ARGS_ASSERT_MY_KID;
2124 if (!o || (PL_parser && PL_parser->error_count))
2128 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2129 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2133 if (type == OP_LIST) {
2135 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2136 my_kid(kid, attrs, imopsp);
2137 } else if (type == OP_UNDEF
2143 } else if (type == OP_RV2SV || /* "our" declaration */
2145 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2146 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2147 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2149 PL_parser->in_my == KEY_our
2151 : PL_parser->in_my == KEY_state ? "state" : "my"));
2153 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2154 PL_parser->in_my = FALSE;
2155 PL_parser->in_my_stash = NULL;
2156 apply_attrs(GvSTASH(gv),
2157 (type == OP_RV2SV ? GvSV(gv) :
2158 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2159 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2162 o->op_private |= OPpOUR_INTRO;
2165 else if (type != OP_PADSV &&
2168 type != OP_PUSHMARK)
2170 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2172 PL_parser->in_my == KEY_our
2174 : PL_parser->in_my == KEY_state ? "state" : "my"));
2177 else if (attrs && type != OP_PUSHMARK) {
2180 PL_parser->in_my = FALSE;
2181 PL_parser->in_my_stash = NULL;
2183 /* check for C<my Dog $spot> when deciding package */
2184 stash = PAD_COMPNAME_TYPE(o->op_targ);
2186 stash = PL_curstash;
2187 apply_attrs_my(stash, o, attrs, imopsp);
2189 o->op_flags |= OPf_MOD;
2190 o->op_private |= OPpLVAL_INTRO;
2191 if (PL_parser->in_my == KEY_state)
2192 o->op_private |= OPpPAD_STATE;
2197 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2201 int maybe_scalar = 0;
2203 PERL_ARGS_ASSERT_MY_ATTRS;
2205 /* [perl #17376]: this appears to be premature, and results in code such as
2206 C< our(%x); > executing in list mode rather than void mode */
2208 if (o->op_flags & OPf_PARENS)
2218 o = my_kid(o, attrs, &rops);
2220 if (maybe_scalar && o->op_type == OP_PADSV) {
2221 o = scalar(op_append_list(OP_LIST, rops, o));
2222 o->op_private |= OPpLVAL_INTRO;
2225 o = op_append_list(OP_LIST, o, rops);
2227 PL_parser->in_my = FALSE;
2228 PL_parser->in_my_stash = NULL;
2233 Perl_sawparens(pTHX_ OP *o)
2235 PERL_UNUSED_CONTEXT;
2237 o->op_flags |= OPf_PARENS;
2242 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2246 const OPCODE ltype = left->op_type;
2247 const OPCODE rtype = right->op_type;
2249 PERL_ARGS_ASSERT_BIND_MATCH;
2251 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2252 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2254 const char * const desc
2255 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2256 ? (int)rtype : OP_MATCH];
2257 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2258 ? "@array" : "%hash");
2259 Perl_warner(aTHX_ packWARN(WARN_MISC),
2260 "Applying %s to %s will act on scalar(%s)",
2261 desc, sample, sample);
2264 if (rtype == OP_CONST &&
2265 cSVOPx(right)->op_private & OPpCONST_BARE &&
2266 cSVOPx(right)->op_private & OPpCONST_STRICT)
2268 no_bareword_allowed(right);
2271 /* !~ doesn't make sense with s///r, so error on it for now */
2272 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2274 yyerror("Using !~ with s///r doesn't make sense");
2276 ismatchop = (rtype == OP_MATCH ||
2277 rtype == OP_SUBST ||
2279 && !(right->op_flags & OPf_SPECIAL);
2280 if (ismatchop && right->op_private & OPpTARGET_MY) {
2282 right->op_private &= ~OPpTARGET_MY;
2284 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2287 right->op_flags |= OPf_STACKED;
2288 if (rtype != OP_MATCH &&
2289 ! (rtype == OP_TRANS &&
2290 right->op_private & OPpTRANS_IDENTICAL) &&
2291 ! (rtype == OP_SUBST &&
2292 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2293 newleft = op_lvalue(left, rtype);
2296 if (right->op_type == OP_TRANS)
2297 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2299 o = op_prepend_elem(rtype, scalar(newleft), right);
2301 return newUNOP(OP_NOT, 0, scalar(o));
2305 return bind_match(type, left,
2306 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2310 Perl_invert(pTHX_ OP *o)
2314 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2318 =for apidoc Amx|OP *|op_scope|OP *o
2320 Wraps up an op tree with some additional ops so that at runtime a dynamic
2321 scope will be created. The original ops run in the new dynamic scope,
2322 and then, provided that they exit normally, the scope will be unwound.
2323 The additional ops used to create and unwind the dynamic scope will
2324 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2325 instead if the ops are simple enough to not need the full dynamic scope
2332 Perl_op_scope(pTHX_ OP *o)
2336 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2337 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2338 o->op_type = OP_LEAVE;
2339 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2341 else if (o->op_type == OP_LINESEQ) {
2343 o->op_type = OP_SCOPE;
2344 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2345 kid = ((LISTOP*)o)->op_first;
2346 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2349 /* The following deals with things like 'do {1 for 1}' */
2350 kid = kid->op_sibling;
2352 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2357 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2363 Perl_block_start(pTHX_ int full)
2366 const int retval = PL_savestack_ix;
2368 pad_block_start(full);
2370 PL_hints &= ~HINT_BLOCK_SCOPE;
2371 SAVECOMPILEWARNINGS();
2372 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2374 CALL_BLOCK_HOOKS(bhk_start, full);
2380 Perl_block_end(pTHX_ I32 floor, OP *seq)
2383 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2384 OP* retval = scalarseq(seq);
2386 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2389 CopHINTS_set(&PL_compiling, PL_hints);
2391 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2394 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2400 =head1 Compile-time scope hooks
2402 =for apidoc Ao||blockhook_register
2404 Register a set of hooks to be called when the Perl lexical scope changes
2405 at compile time. See L<perlguts/"Compile-time scope hooks">.
2411 Perl_blockhook_register(pTHX_ BHK *hk)
2413 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2415 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2422 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2423 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2424 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2427 OP * const o = newOP(OP_PADSV, 0);
2428 o->op_targ = offset;
2434 Perl_newPROG(pTHX_ OP *o)
2438 PERL_ARGS_ASSERT_NEWPROG;
2443 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2444 ((PL_in_eval & EVAL_KEEPERR)
2445 ? OPf_SPECIAL : 0), o);
2446 /* don't use LINKLIST, since PL_eval_root might indirect through
2447 * a rather expensive function call and LINKLIST evaluates its
2448 * argument more than once */
2449 PL_eval_start = op_linklist(PL_eval_root);
2450 PL_eval_root->op_private |= OPpREFCOUNTED;
2451 OpREFCNT_set(PL_eval_root, 1);
2452 PL_eval_root->op_next = 0;
2453 CALL_PEEP(PL_eval_start);
2456 if (o->op_type == OP_STUB) {
2457 PL_comppad_name = 0;
2459 S_op_destroy(aTHX_ o);
2462 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2463 PL_curcop = &PL_compiling;
2464 PL_main_start = LINKLIST(PL_main_root);
2465 PL_main_root->op_private |= OPpREFCOUNTED;
2466 OpREFCNT_set(PL_main_root, 1);
2467 PL_main_root->op_next = 0;
2468 CALL_PEEP(PL_main_start);
2471 /* Register with debugger */
2473 CV * const cv = get_cvs("DB::postponed", 0);
2477 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2479 call_sv(MUTABLE_SV(cv), G_DISCARD);
2486 Perl_localize(pTHX_ OP *o, I32 lex)
2490 PERL_ARGS_ASSERT_LOCALIZE;
2492 if (o->op_flags & OPf_PARENS)
2493 /* [perl #17376]: this appears to be premature, and results in code such as
2494 C< our(%x); > executing in list mode rather than void mode */
2501 if ( PL_parser->bufptr > PL_parser->oldbufptr
2502 && PL_parser->bufptr[-1] == ','
2503 && ckWARN(WARN_PARENTHESIS))
2505 char *s = PL_parser->bufptr;
2508 /* some heuristics to detect a potential error */
2509 while (*s && (strchr(", \t\n", *s)))
2513 if (*s && strchr("@$%*", *s) && *++s
2514 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2517 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2519 while (*s && (strchr(", \t\n", *s)))
2525 if (sigil && (*s == ';' || *s == '=')) {
2526 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2527 "Parentheses missing around \"%s\" list",
2529 ? (PL_parser->in_my == KEY_our
2531 : PL_parser->in_my == KEY_state
2541 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2542 PL_parser->in_my = FALSE;
2543 PL_parser->in_my_stash = NULL;
2548 Perl_jmaybe(pTHX_ OP *o)
2550 PERL_ARGS_ASSERT_JMAYBE;
2552 if (o->op_type == OP_LIST) {
2554 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2555 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2561 S_fold_constants(pTHX_ register OP *o)
2564 register OP * VOL curop;
2566 VOL I32 type = o->op_type;
2571 SV * const oldwarnhook = PL_warnhook;
2572 SV * const olddiehook = PL_diehook;
2576 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2578 if (PL_opargs[type] & OA_RETSCALAR)
2580 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2581 o->op_targ = pad_alloc(type, SVs_PADTMP);
2583 /* integerize op, unless it happens to be C<-foo>.
2584 * XXX should pp_i_negate() do magic string negation instead? */
2585 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2586 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2587 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2589 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2592 if (!(PL_opargs[type] & OA_FOLDCONST))
2597 /* XXX might want a ck_negate() for this */
2598 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2610 /* XXX what about the numeric ops? */
2611 if (PL_hints & HINT_LOCALE)
2616 if (PL_parser && PL_parser->error_count)
2617 goto nope; /* Don't try to run w/ errors */
2619 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2620 const OPCODE type = curop->op_type;
2621 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2623 type != OP_SCALAR &&
2625 type != OP_PUSHMARK)
2631 curop = LINKLIST(o);
2632 old_next = o->op_next;
2636 oldscope = PL_scopestack_ix;
2637 create_eval_scope(G_FAKINGEVAL);
2639 /* Verify that we don't need to save it: */
2640 assert(PL_curcop == &PL_compiling);
2641 StructCopy(&PL_compiling, ¬_compiling, COP);
2642 PL_curcop = ¬_compiling;
2643 /* The above ensures that we run with all the correct hints of the
2644 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2645 assert(IN_PERL_RUNTIME);
2646 PL_warnhook = PERL_WARNHOOK_FATAL;
2653 sv = *(PL_stack_sp--);
2654 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2655 pad_swipe(o->op_targ, FALSE);
2656 else if (SvTEMP(sv)) { /* grab mortal temp? */
2657 SvREFCNT_inc_simple_void(sv);
2662 /* Something tried to die. Abandon constant folding. */
2663 /* Pretend the error never happened. */
2665 o->op_next = old_next;
2669 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2670 PL_warnhook = oldwarnhook;
2671 PL_diehook = olddiehook;
2672 /* XXX note that this croak may fail as we've already blown away
2673 * the stack - eg any nested evals */
2674 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2677 PL_warnhook = oldwarnhook;
2678 PL_diehook = olddiehook;
2679 PL_curcop = &PL_compiling;
2681 if (PL_scopestack_ix > oldscope)
2682 delete_eval_scope();
2691 if (type == OP_RV2GV)
2692 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2694 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2695 op_getmad(o,newop,'f');
2703 S_gen_constant_list(pTHX_ register OP *o)
2707 const I32 oldtmps_floor = PL_tmps_floor;
2710 if (PL_parser && PL_parser->error_count)
2711 return o; /* Don't attempt to run with errors */
2713 PL_op = curop = LINKLIST(o);
2719 assert (!(curop->op_flags & OPf_SPECIAL));
2720 assert(curop->op_type == OP_RANGE);
2722 PL_tmps_floor = oldtmps_floor;
2724 o->op_type = OP_RV2AV;
2725 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2726 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2727 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2728 o->op_opt = 0; /* needs to be revisited in rpeep() */
2729 curop = ((UNOP*)o)->op_first;
2730 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2732 op_getmad(curop,o,'O');
2741 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2744 if (!o || o->op_type != OP_LIST)
2745 o = newLISTOP(OP_LIST, 0, o, NULL);
2747 o->op_flags &= ~OPf_WANT;
2749 if (!(PL_opargs[type] & OA_MARK))
2750 op_null(cLISTOPo->op_first);
2752 o->op_type = (OPCODE)type;
2753 o->op_ppaddr = PL_ppaddr[type];
2754 o->op_flags |= flags;
2756 o = CHECKOP(type, o);
2757 if (o->op_type != (unsigned)type)
2760 return fold_constants(o);
2764 =head1 Optree Manipulation Functions
2767 /* List constructors */
2770 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2772 Append an item to the list of ops contained directly within a list-type
2773 op, returning the lengthened list. I<first> is the list-type op,
2774 and I<last> is the op to append to the list. I<optype> specifies the
2775 intended opcode for the list. If I<first> is not already a list of the
2776 right type, it will be upgraded into one. If either I<first> or I<last>
2777 is null, the other is returned unchanged.
2783 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2791 if (first->op_type != (unsigned)type
2792 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2794 return newLISTOP(type, 0, first, last);
2797 if (first->op_flags & OPf_KIDS)
2798 ((LISTOP*)first)->op_last->op_sibling = last;
2800 first->op_flags |= OPf_KIDS;
2801 ((LISTOP*)first)->op_first = last;
2803 ((LISTOP*)first)->op_last = last;
2808 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2810 Concatenate the lists of ops contained directly within two list-type ops,
2811 returning the combined list. I<first> and I<last> are the list-type ops
2812 to concatenate. I<optype> specifies the intended opcode for the list.
2813 If either I<first> or I<last> is not already a list of the right type,
2814 it will be upgraded into one. If either I<first> or I<last> is null,
2815 the other is returned unchanged.
2821 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2829 if (first->op_type != (unsigned)type)
2830 return op_prepend_elem(type, first, last);
2832 if (last->op_type != (unsigned)type)
2833 return op_append_elem(type, first, last);
2835 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2836 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2837 first->op_flags |= (last->op_flags & OPf_KIDS);
2840 if (((LISTOP*)last)->op_first && first->op_madprop) {
2841 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2843 while (mp->mad_next)
2845 mp->mad_next = first->op_madprop;
2848 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2851 first->op_madprop = last->op_madprop;
2852 last->op_madprop = 0;
2855 S_op_destroy(aTHX_ last);
2861 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2863 Prepend an item to the list of ops contained directly within a list-type
2864 op, returning the lengthened list. I<first> is the op to prepend to the
2865 list, and I<last> is the list-type op. I<optype> specifies the intended
2866 opcode for the list. If I<last> is not already a list of the right type,
2867 it will be upgraded into one. If either I<first> or I<last> is null,
2868 the other is returned unchanged.
2874 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2882 if (last->op_type == (unsigned)type) {
2883 if (type == OP_LIST) { /* already a PUSHMARK there */
2884 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2885 ((LISTOP*)last)->op_first->op_sibling = first;
2886 if (!(first->op_flags & OPf_PARENS))
2887 last->op_flags &= ~OPf_PARENS;
2890 if (!(last->op_flags & OPf_KIDS)) {
2891 ((LISTOP*)last)->op_last = first;
2892 last->op_flags |= OPf_KIDS;
2894 first->op_sibling = ((LISTOP*)last)->op_first;
2895 ((LISTOP*)last)->op_first = first;
2897 last->op_flags |= OPf_KIDS;
2901 return newLISTOP(type, 0, first, last);
2909 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2912 Newxz(tk, 1, TOKEN);
2913 tk->tk_type = (OPCODE)optype;
2914 tk->tk_type = 12345;
2916 tk->tk_mad = madprop;
2921 Perl_token_free(pTHX_ TOKEN* tk)
2923 PERL_ARGS_ASSERT_TOKEN_FREE;
2925 if (tk->tk_type != 12345)
2927 mad_free(tk->tk_mad);
2932 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2937 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2939 if (tk->tk_type != 12345) {
2940 Perl_warner(aTHX_ packWARN(WARN_MISC),
2941 "Invalid TOKEN object ignored");
2948 /* faked up qw list? */
2950 tm->mad_type == MAD_SV &&
2951 SvPVX((SV *)tm->mad_val)[0] == 'q')
2958 /* pretend constant fold didn't happen? */
2959 if (mp->mad_key == 'f' &&
2960 (o->op_type == OP_CONST ||
2961 o->op_type == OP_GV) )
2963 token_getmad(tk,(OP*)mp->mad_val,slot);
2977 if (mp->mad_key == 'X')
2978 mp->mad_key = slot; /* just change the first one */
2988 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2997 /* pretend constant fold didn't happen? */
2998 if (mp->mad_key == 'f' &&
2999 (o->op_type == OP_CONST ||
3000 o->op_type == OP_GV) )
3002 op_getmad(from,(OP*)mp->mad_val,slot);
3009 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3012 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3018 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3027 /* pretend constant fold didn't happen? */
3028 if (mp->mad_key == 'f' &&
3029 (o->op_type == OP_CONST ||
3030 o->op_type == OP_GV) )
3032 op_getmad(from,(OP*)mp->mad_val,slot);
3039 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3042 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3046 PerlIO_printf(PerlIO_stderr(),
3047 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3053 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3071 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3075 addmad(tm, &(o->op_madprop), slot);
3079 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3100 Perl_newMADsv(pTHX_ char key, SV* sv)
3102 PERL_ARGS_ASSERT_NEWMADSV;
3104 return newMADPROP(key, MAD_SV, sv, 0);
3108 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3111 Newxz(mp, 1, MADPROP);
3114 mp->mad_vlen = vlen;
3115 mp->mad_type = type;
3117 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3122 Perl_mad_free(pTHX_ MADPROP* mp)
3124 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3128 mad_free(mp->mad_next);
3129 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3130 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3131 switch (mp->mad_type) {
3135 Safefree((char*)mp->mad_val);
3138 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3139 op_free((OP*)mp->mad_val);
3142 sv_free(MUTABLE_SV(mp->mad_val));
3145 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3154 =head1 Optree construction
3156 =for apidoc Am|OP *|newNULLLIST
3158 Constructs, checks, and returns a new C<stub> op, which represents an
3159 empty list expression.
3165 Perl_newNULLLIST(pTHX)
3167 return newOP(OP_STUB, 0);
3171 S_force_list(pTHX_ OP *o)
3173 if (!o || o->op_type != OP_LIST)
3174 o = newLISTOP(OP_LIST, 0, o, NULL);
3180 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3182 Constructs, checks, and returns an op of any list type. I<type> is
3183 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3184 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3185 supply up to two ops to be direct children of the list op; they are
3186 consumed by this function and become part of the constructed op tree.
3192 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3197 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3199 NewOp(1101, listop, 1, LISTOP);
3201 listop->op_type = (OPCODE)type;
3202 listop->op_ppaddr = PL_ppaddr[type];
3205 listop->op_flags = (U8)flags;
3209 else if (!first && last)
3212 first->op_sibling = last;
3213 listop->op_first = first;
3214 listop->op_last = last;
3215 if (type == OP_LIST) {
3216 OP* const pushop = newOP(OP_PUSHMARK, 0);
3217 pushop->op_sibling = first;
3218 listop->op_first = pushop;
3219 listop->op_flags |= OPf_KIDS;
3221 listop->op_last = pushop;
3224 return CHECKOP(type, listop);
3228 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3230 Constructs, checks, and returns an op of any base type (any type that
3231 has no extra fields). I<type> is the opcode. I<flags> gives the
3232 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3239 Perl_newOP(pTHX_ I32 type, I32 flags)
3244 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3245 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3246 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3247 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3249 NewOp(1101, o, 1, OP);
3250 o->op_type = (OPCODE)type;
3251 o->op_ppaddr = PL_ppaddr[type];
3252 o->op_flags = (U8)flags;
3254 o->op_latefreed = 0;
3258 o->op_private = (U8)(0 | (flags >> 8));
3259 if (PL_opargs[type] & OA_RETSCALAR)
3261 if (PL_opargs[type] & OA_TARGET)
3262 o->op_targ = pad_alloc(type, SVs_PADTMP);
3263 return CHECKOP(type, o);
3267 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3269 Constructs, checks, and returns an op of any unary type. I<type> is
3270 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3271 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3272 bits, the eight bits of C<op_private>, except that the bit with value 1
3273 is automatically set. I<first> supplies an optional op to be the direct
3274 child of the unary op; it is consumed by this function and become part
3275 of the constructed op tree.
3281 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3286 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3287 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3288 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3289 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3290 || type == OP_SASSIGN
3291 || type == OP_ENTERTRY
3292 || type == OP_NULL );
3295 first = newOP(OP_STUB, 0);
3296 if (PL_opargs[type] & OA_MARK)
3297 first = force_list(first);
3299 NewOp(1101, unop, 1, UNOP);
3300 unop->op_type = (OPCODE)type;
3301 unop->op_ppaddr = PL_ppaddr[type];
3302 unop->op_first = first;
3303 unop->op_flags = (U8)(flags | OPf_KIDS);
3304 unop->op_private = (U8)(1 | (flags >> 8));
3305 unop = (UNOP*) CHECKOP(type, unop);
3309 return fold_constants((OP *) unop);
3313 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3315 Constructs, checks, and returns an op of any binary type. I<type>
3316 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3317 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3318 the eight bits of C<op_private>, except that the bit with value 1 or
3319 2 is automatically set as required. I<first> and I<last> supply up to
3320 two ops to be the direct children of the binary op; they are consumed
3321 by this function and become part of the constructed op tree.
3327 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3332 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3333 || type == OP_SASSIGN || type == OP_NULL );
3335 NewOp(1101, binop, 1, BINOP);
3338 first = newOP(OP_NULL, 0);
3340 binop->op_type = (OPCODE)type;
3341 binop->op_ppaddr = PL_ppaddr[type];
3342 binop->op_first = first;
3343 binop->op_flags = (U8)(flags | OPf_KIDS);
3346 binop->op_private = (U8)(1 | (flags >> 8));
3349 binop->op_private = (U8)(2 | (flags >> 8));
3350 first->op_sibling = last;
3353 binop = (BINOP*)CHECKOP(type, binop);
3354 if (binop->op_next || binop->op_type != (OPCODE)type)
3357 binop->op_last = binop->op_first->op_sibling;
3359 return fold_constants((OP *)binop);
3362 static int uvcompare(const void *a, const void *b)
3363 __attribute__nonnull__(1)
3364 __attribute__nonnull__(2)
3365 __attribute__pure__;
3366 static int uvcompare(const void *a, const void *b)
3368 if (*((const UV *)a) < (*(const UV *)b))
3370 if (*((const UV *)a) > (*(const UV *)b))
3372 if (*((const UV *)a+1) < (*(const UV *)b+1))
3374 if (*((const UV *)a+1) > (*(const UV *)b+1))
3380 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3383 SV * const tstr = ((SVOP*)expr)->op_sv;
3386 (repl->op_type == OP_NULL)
3387 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3389 ((SVOP*)repl)->op_sv;
3392 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3393 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3397 register short *tbl;
3399 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3400 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3401 I32 del = o->op_private & OPpTRANS_DELETE;
3404 PERL_ARGS_ASSERT_PMTRANS;
3406 PL_hints |= HINT_BLOCK_SCOPE;
3409 o->op_private |= OPpTRANS_FROM_UTF;
3412 o->op_private |= OPpTRANS_TO_UTF;
3414 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3415 SV* const listsv = newSVpvs("# comment\n");
3417 const U8* tend = t + tlen;
3418 const U8* rend = r + rlen;
3432 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3433 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3436 const U32 flags = UTF8_ALLOW_DEFAULT;
3440 t = tsave = bytes_to_utf8(t, &len);
3443 if (!to_utf && rlen) {
3445 r = rsave = bytes_to_utf8(r, &len);
3449 /* There are several snags with this code on EBCDIC:
3450 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3451 2. scan_const() in toke.c has encoded chars in native encoding which makes
3452 ranges at least in EBCDIC 0..255 range the bottom odd.
3456 U8 tmpbuf[UTF8_MAXBYTES+1];
3459 Newx(cp, 2*tlen, UV);
3461 transv = newSVpvs("");
3463 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3465 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3467 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3471 cp[2*i+1] = cp[2*i];
3475 qsort(cp, i, 2*sizeof(UV), uvcompare);
3476 for (j = 0; j < i; j++) {
3478 diff = val - nextmin;
3480 t = uvuni_to_utf8(tmpbuf,nextmin);
3481 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3483 U8 range_mark = UTF_TO_NATIVE(0xff);
3484 t = uvuni_to_utf8(tmpbuf, val - 1);
3485 sv_catpvn(transv, (char *)&range_mark, 1);
3486 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3493 t = uvuni_to_utf8(tmpbuf,nextmin);
3494 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3496 U8 range_mark = UTF_TO_NATIVE(0xff);
3497 sv_catpvn(transv, (char *)&range_mark, 1);
3499 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3500 UNICODE_ALLOW_SUPER);
3501 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3502 t = (const U8*)SvPVX_const(transv);
3503 tlen = SvCUR(transv);
3507 else if (!rlen && !del) {
3508 r = t; rlen = tlen; rend = tend;
3511 if ((!rlen && !del) || t == r ||
3512 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3514 o->op_private |= OPpTRANS_IDENTICAL;
3518 while (t < tend || tfirst <= tlast) {
3519 /* see if we need more "t" chars */
3520 if (tfirst > tlast) {
3521 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3523 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3525 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3532 /* now see if we need more "r" chars */
3533 if (rfirst > rlast) {
3535 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3537 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3539 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3548 rfirst = rlast = 0xffffffff;
3552 /* now see which range will peter our first, if either. */
3553 tdiff = tlast - tfirst;
3554 rdiff = rlast - rfirst;
3561 if (rfirst == 0xffffffff) {
3562 diff = tdiff; /* oops, pretend rdiff is infinite */
3564 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3565 (long)tfirst, (long)tlast);
3567 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3571 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3572 (long)tfirst, (long)(tfirst + diff),
3575 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3576 (long)tfirst, (long)rfirst);
3578 if (rfirst + diff > max)
3579 max = rfirst + diff;
3581 grows = (tfirst < rfirst &&
3582 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3594 else if (max > 0xff)
3599 PerlMemShared_free(cPVOPo->op_pv);
3600 cPVOPo->op_pv = NULL;
3602 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3604 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3605 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3606 PAD_SETSV(cPADOPo->op_padix, swash);
3608 SvREADONLY_on(swash);
3610 cSVOPo->op_sv = swash;
3612 SvREFCNT_dec(listsv);
3613 SvREFCNT_dec(transv);
3615 if (!del && havefinal && rlen)
3616 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3617 newSVuv((UV)final), 0);
3620 o->op_private |= OPpTRANS_GROWS;
3626 op_getmad(expr,o,'e');
3627 op_getmad(repl,o,'r');
3635 tbl = (short*)cPVOPo->op_pv;
3637 Zero(tbl, 256, short);
3638 for (i = 0; i < (I32)tlen; i++)
3640 for (i = 0, j = 0; i < 256; i++) {
3642 if (j >= (I32)rlen) {
3651 if (i < 128 && r[j] >= 128)
3661 o->op_private |= OPpTRANS_IDENTICAL;
3663 else if (j >= (I32)rlen)
3668 PerlMemShared_realloc(tbl,
3669 (0x101+rlen-j) * sizeof(short));
3670 cPVOPo->op_pv = (char*)tbl;
3672 tbl[0x100] = (short)(rlen - j);
3673 for (i=0; i < (I32)rlen - j; i++)
3674 tbl[0x101+i] = r[j+i];
3678 if (!rlen && !del) {
3681 o->op_private |= OPpTRANS_IDENTICAL;
3683 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3684 o->op_private |= OPpTRANS_IDENTICAL;
3686 for (i = 0; i < 256; i++)
3688 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3689 if (j >= (I32)rlen) {
3691 if (tbl[t[i]] == -1)
3697 if (tbl[t[i]] == -1) {
3698 if (t[i] < 128 && r[j] >= 128)
3705 if(del && rlen == tlen) {
3706 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3707 } else if(rlen > tlen) {
3708 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3712 o->op_private |= OPpTRANS_GROWS;
3714 op_getmad(expr,o,'e');
3715 op_getmad(repl,o,'r');
3725 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3727 Constructs, checks, and returns an op of any pattern matching type.
3728 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3729 and, shifted up eight bits, the eight bits of C<op_private>.
3735 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3740 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3742 NewOp(1101, pmop, 1, PMOP);
3743 pmop->op_type = (OPCODE)type;
3744 pmop->op_ppaddr = PL_ppaddr[type];
3745 pmop->op_flags = (U8)flags;
3746 pmop->op_private = (U8)(0 | (flags >> 8));
3748 if (PL_hints & HINT_RE_TAINT)
3749 pmop->op_pmflags |= PMf_RETAINT;
3750 if (PL_hints & HINT_LOCALE) {
3751 pmop->op_pmflags |= PMf_LOCALE;
3753 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3754 pmop->op_pmflags |= RXf_PMf_UNICODE;
3756 if (PL_hints & HINT_RE_FLAGS) {
3757 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3758 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3760 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3761 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3762 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_dul"), 0, 0
3764 if (reflags && SvOK(reflags)) {
3765 pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
3766 pmop->op_pmflags |= SvIV(reflags);
3772 assert(SvPOK(PL_regex_pad[0]));
3773 if (SvCUR(PL_regex_pad[0])) {
3774 /* Pop off the "packed" IV from the end. */
3775 SV *const repointer_list = PL_regex_pad[0];
3776 const char *p = SvEND(repointer_list) - sizeof(IV);
3777 const IV offset = *((IV*)p);
3779 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3781 SvEND_set(repointer_list, p);
3783 pmop->op_pmoffset = offset;
3784 /* This slot should be free, so assert this: */
3785 assert(PL_regex_pad[offset] == &PL_sv_undef);
3787 SV * const repointer = &PL_sv_undef;
3788 av_push(PL_regex_padav, repointer);
3789 pmop->op_pmoffset = av_len(PL_regex_padav);
3790 PL_regex_pad = AvARRAY(PL_regex_padav);
3794 return CHECKOP(type, pmop);
3797 /* Given some sort of match op o, and an expression expr containing a
3798 * pattern, either compile expr into a regex and attach it to o (if it's
3799 * constant), or convert expr into a runtime regcomp op sequence (if it's
3802 * isreg indicates that the pattern is part of a regex construct, eg
3803 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3804 * split "pattern", which aren't. In the former case, expr will be a list
3805 * if the pattern contains more than one term (eg /a$b/) or if it contains
3806 * a replacement, ie s/// or tr///.
3810 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3815 I32 repl_has_vars = 0;
3819 PERL_ARGS_ASSERT_PMRUNTIME;
3821 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3822 /* last element in list is the replacement; pop it */
3824 repl = cLISTOPx(expr)->op_last;
3825 kid = cLISTOPx(expr)->op_first;
3826 while (kid->op_sibling != repl)
3827 kid = kid->op_sibling;
3828 kid->op_sibling = NULL;
3829 cLISTOPx(expr)->op_last = kid;
3832 if (isreg && expr->op_type == OP_LIST &&
3833 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3835 /* convert single element list to element */
3836 OP* const oe = expr;
3837 expr = cLISTOPx(oe)->op_first->op_sibling;
3838 cLISTOPx(oe)->op_first->op_sibling = NULL;
3839 cLISTOPx(oe)->op_last = NULL;
3843 if (o->op_type == OP_TRANS) {
3844 return pmtrans(o, expr, repl);
3847 reglist = isreg && expr->op_type == OP_LIST;
3851 PL_hints |= HINT_BLOCK_SCOPE;
3854 if (expr->op_type == OP_CONST) {
3855 SV *pat = ((SVOP*)expr)->op_sv;
3856 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3858 if (o->op_flags & OPf_SPECIAL)
3859 pm_flags |= RXf_SPLIT;
3862 assert (SvUTF8(pat));
3863 } else if (SvUTF8(pat)) {
3864 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3865 trapped in use 'bytes'? */
3866 /* Make a copy of the octet sequence, but without the flag on, as
3867 the compiler now honours the SvUTF8 flag on pat. */
3869 const char *const p = SvPV(pat, len);
3870 pat = newSVpvn_flags(p, len, SVs_TEMP);
3873 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3876 op_getmad(expr,(OP*)pm,'e');
3882 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3883 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3885 : OP_REGCMAYBE),0,expr);
3887 NewOp(1101, rcop, 1, LOGOP);
3888 rcop->op_type = OP_REGCOMP;
3889 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3890 rcop->op_first = scalar(expr);
3891 rcop->op_flags |= OPf_KIDS
3892 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3893 | (reglist ? OPf_STACKED : 0);
3894 rcop->op_private = 1;
3897 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3899 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3902 /* establish postfix order */
3903 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3905 rcop->op_next = expr;
3906 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3909 rcop->op_next = LINKLIST(expr);
3910 expr->op_next = (OP*)rcop;
3913 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3918 if (pm->op_pmflags & PMf_EVAL) {
3920 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3921 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3923 else if (repl->op_type == OP_CONST)
3927 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3928 if (curop->op_type == OP_SCOPE
3929 || curop->op_type == OP_LEAVE
3930 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3931 if (curop->op_type == OP_GV) {
3932 GV * const gv = cGVOPx_gv(curop);
3934 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3937 else if (curop->op_type == OP_RV2CV)
3939 else if (curop->op_type == OP_RV2SV ||
3940 curop->op_type == OP_RV2AV ||
3941 curop->op_type == OP_RV2HV ||
3942 curop->op_type == OP_RV2GV) {
3943 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3946 else if (curop->op_type == OP_PADSV ||
3947 curop->op_type == OP_PADAV ||
3948 curop->op_type == OP_PADHV ||
3949 curop->op_type == OP_PADANY)
3953 else if (curop->op_type == OP_PUSHRE)
3954 NOOP; /* Okay here, dangerous in newASSIGNOP */
3964 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3966 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3967 op_prepend_elem(o->op_type, scalar(repl), o);
3970 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3971 pm->op_pmflags |= PMf_MAYBE_CONST;
3973 NewOp(1101, rcop, 1, LOGOP);
3974 rcop->op_type = OP_SUBSTCONT;
3975 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3976 rcop->op_first = scalar(repl);
3977 rcop->op_flags |= OPf_KIDS;
3978 rcop->op_private = 1;
3981 /* establish postfix order */
3982 rcop->op_next = LINKLIST(repl);
3983 repl->op_next = (OP*)rcop;
3985 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3986 assert(!(pm->op_pmflags & PMf_ONCE));
3987 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3996 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
3998 Constructs, checks, and returns an op of any type that involves an
3999 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4000 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4001 takes ownership of one reference to it.
4007 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4012 PERL_ARGS_ASSERT_NEWSVOP;
4014 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4015 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4016 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4018 NewOp(1101, svop, 1, SVOP);
4019 svop->op_type = (OPCODE)type;
4020 svop->op_ppaddr = PL_ppaddr[type];
4022 svop->op_next = (OP*)svop;
4023 svop->op_flags = (U8)flags;
4024 if (PL_opargs[type] & OA_RETSCALAR)
4026 if (PL_opargs[type] & OA_TARGET)
4027 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4028 return CHECKOP(type, svop);
4034 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4036 Constructs, checks, and returns an op of any type that involves a
4037 reference to a pad element. I<type> is the opcode. I<flags> gives the
4038 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4039 is populated with I<sv>; this function takes ownership of one reference
4042 This function only exists if Perl has been compiled to use ithreads.
4048 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4053 PERL_ARGS_ASSERT_NEWPADOP;
4055 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4056 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4057 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4059 NewOp(1101, padop, 1, PADOP);
4060 padop->op_type = (OPCODE)type;
4061 padop->op_ppaddr = PL_ppaddr[type];
4062 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4063 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4064 PAD_SETSV(padop->op_padix, sv);
4067 padop->op_next = (OP*)padop;
4068 padop->op_flags = (U8)flags;
4069 if (PL_opargs[type] & OA_RETSCALAR)
4071 if (PL_opargs[type] & OA_TARGET)
4072 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4073 return CHECKOP(type, padop);
4076 #endif /* !USE_ITHREADS */
4079 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4081 Constructs, checks, and returns an op of any type that involves an
4082 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4083 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4084 reference; calling this function does not transfer ownership of any
4091 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4095 PERL_ARGS_ASSERT_NEWGVOP;
4099 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4101 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4106 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4108 Constructs, checks, and returns an op of any type that involves an
4109 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4110 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4111 must have been allocated using L</PerlMemShared_malloc>; the memory will
4112 be freed when the op is destroyed.
4118 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4123 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4124 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4126 NewOp(1101, pvop, 1, PVOP);
4127 pvop->op_type = (OPCODE)type;
4128 pvop->op_ppaddr = PL_ppaddr[type];
4130 pvop->op_next = (OP*)pvop;
4131 pvop->op_flags = (U8)flags;
4132 if (PL_opargs[type] & OA_RETSCALAR)
4134 if (PL_opargs[type] & OA_TARGET)
4135 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4136 return CHECKOP(type, pvop);
4144 Perl_package(pTHX_ OP *o)
4147 SV *const sv = cSVOPo->op_sv;
4152 PERL_ARGS_ASSERT_PACKAGE;
4154 save_hptr(&PL_curstash);
4155 save_item(PL_curstname);
4157 PL_curstash = gv_stashsv(sv, GV_ADD);
4159 sv_setsv(PL_curstname, sv);
4161 PL_hints |= HINT_BLOCK_SCOPE;
4162 PL_parser->copline = NOLINE;
4163 PL_parser->expect = XSTATE;
4168 if (!PL_madskills) {
4173 pegop = newOP(OP_NULL,0);
4174 op_getmad(o,pegop,'P');
4180 Perl_package_version( pTHX_ OP *v )
4183 U32 savehints = PL_hints;
4184 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4185 PL_hints &= ~HINT_STRICT_VARS;
4186 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4187 PL_hints = savehints;
4196 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4203 OP *pegop = newOP(OP_NULL,0);
4206 PERL_ARGS_ASSERT_UTILIZE;
4208 if (idop->op_type != OP_CONST)
4209 Perl_croak(aTHX_ "Module name must be constant");
4212 op_getmad(idop,pegop,'U');
4217 SV * const vesv = ((SVOP*)version)->op_sv;
4220 op_getmad(version,pegop,'V');
4221 if (!arg && !SvNIOKp(vesv)) {
4228 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4229 Perl_croak(aTHX_ "Version number must be a constant number");
4231 /* Make copy of idop so we don't free it twice */
4232 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4234 /* Fake up a method call to VERSION */
4235 meth = newSVpvs_share("VERSION");
4236 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4237 op_append_elem(OP_LIST,
4238 op_prepend_elem(OP_LIST, pack, list(version)),
4239 newSVOP(OP_METHOD_NAMED, 0, meth)));
4243 /* Fake up an import/unimport */
4244 if (arg && arg->op_type == OP_STUB) {
4246 op_getmad(arg,pegop,'S');
4247 imop = arg; /* no import on explicit () */
4249 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4250 imop = NULL; /* use 5.0; */
4252 idop->op_private |= OPpCONST_NOVER;
4258 op_getmad(arg,pegop,'A');
4260 /* Make copy of idop so we don't free it twice */
4261 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4263 /* Fake up a method call to import/unimport */
4265 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4266 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4267 op_append_elem(OP_LIST,
4268 op_prepend_elem(OP_LIST, pack, list(arg)),
4269 newSVOP(OP_METHOD_NAMED, 0, meth)));
4272 /* Fake up the BEGIN {}, which does its thing immediately. */
4274 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4277 op_append_elem(OP_LINESEQ,
4278 op_append_elem(OP_LINESEQ,
4279 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4280 newSTATEOP(0, NULL, veop)),
4281 newSTATEOP(0, NULL, imop) ));
4283 /* The "did you use incorrect case?" warning used to be here.
4284 * The problem is that on case-insensitive filesystems one
4285 * might get false positives for "use" (and "require"):
4286 * "use Strict" or "require CARP" will work. This causes
4287 * portability problems for the script: in case-strict
4288 * filesystems the script will stop working.
4290 * The "incorrect case" warning checked whether "use Foo"
4291 * imported "Foo" to your namespace, but that is wrong, too:
4292 * there is no requirement nor promise in the language that
4293 * a Foo.pm should or would contain anything in package "Foo".
4295 * There is very little Configure-wise that can be done, either:
4296 * the case-sensitivity of the build filesystem of Perl does not
4297 * help in guessing the case-sensitivity of the runtime environment.
4300 PL_hints |= HINT_BLOCK_SCOPE;
4301 PL_parser->copline = NOLINE;
4302 PL_parser->expect = XSTATE;
4303 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4306 if (!PL_madskills) {
4307 /* FIXME - don't allocate pegop if !PL_madskills */
4316 =head1 Embedding Functions
4318 =for apidoc load_module
4320 Loads the module whose name is pointed to by the string part of name.
4321 Note that the actual module name, not its filename, should be given.
4322 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4323 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4324 (or 0 for no flags). ver, if specified, provides version semantics
4325 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4326 arguments can be used to specify arguments to the module's import()
4327 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4328 terminated with a final NULL pointer. Note that this list can only
4329 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4330 Otherwise at least a single NULL pointer to designate the default
4331 import list is required.
4336 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4340 PERL_ARGS_ASSERT_LOAD_MODULE;
4342 va_start(args, ver);
4343 vload_module(flags, name, ver, &args);
4347 #ifdef PERL_IMPLICIT_CONTEXT
4349 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4353 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4354 va_start(args, ver);
4355 vload_module(flags, name, ver, &args);
4361 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4365 OP * const modname = newSVOP(OP_CONST, 0, name);
4367 PERL_ARGS_ASSERT_VLOAD_MODULE;
4369 modname->op_private |= OPpCONST_BARE;
4371 veop = newSVOP(OP_CONST, 0, ver);
4375 if (flags & PERL_LOADMOD_NOIMPORT) {
4376 imop = sawparens(newNULLLIST());
4378 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4379 imop = va_arg(*args, OP*);
4384 sv = va_arg(*args, SV*);
4386 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4387 sv = va_arg(*args, SV*);
4391 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4392 * that it has a PL_parser to play with while doing that, and also
4393 * that it doesn't mess with any existing parser, by creating a tmp
4394 * new parser with lex_start(). This won't actually be used for much,
4395 * since pp_require() will create another parser for the real work. */
4398 SAVEVPTR(PL_curcop);
4399 lex_start(NULL, NULL, 0);
4400 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4401 veop, modname, imop);
4406 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4412 PERL_ARGS_ASSERT_DOFILE;
4414 if (!force_builtin) {
4415 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4416 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4417 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4418 gv = gvp ? *gvp : NULL;
4422 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4423 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4424 op_append_elem(OP_LIST, term,
4425 scalar(newUNOP(OP_RV2CV, 0,
4426 newGVOP(OP_GV, 0, gv))))));
4429 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4435 =head1 Optree construction
4437 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4439 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4440 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4441 be set automatically, and, shifted up eight bits, the eight bits of
4442 C<op_private>, except that the bit with value 1 or 2 is automatically
4443 set as required. I<listval> and I<subscript> supply the parameters of
4444 the slice; they are consumed by this function and become part of the
4445 constructed op tree.
4451 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4453 return newBINOP(OP_LSLICE, flags,
4454 list(force_list(subscript)),
4455 list(force_list(listval)) );
4459 S_is_list_assignment(pTHX_ register const OP *o)
4467 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4468 o = cUNOPo->op_first;
4470 flags = o->op_flags;
4472 if (type == OP_COND_EXPR) {
4473 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4474 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4479 yyerror("Assignment to both a list and a scalar");
4483 if (type == OP_LIST &&
4484 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4485 o->op_private & OPpLVAL_INTRO)
4488 if (type == OP_LIST || flags & OPf_PARENS ||
4489 type == OP_RV2AV || type == OP_RV2HV ||
4490 type == OP_ASLICE || type == OP_HSLICE)
4493 if (type == OP_PADAV || type == OP_PADHV)
4496 if (type == OP_RV2SV)
4503 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4505 Constructs, checks, and returns an assignment op. I<left> and I<right>
4506 supply the parameters of the assignment; they are consumed by this
4507 function and become part of the constructed op tree.
4509 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4510 a suitable conditional optree is constructed. If I<optype> is the opcode
4511 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4512 performs the binary operation and assigns the result to the left argument.
4513 Either way, if I<optype> is non-zero then I<flags> has no effect.
4515 If I<optype> is zero, then a plain scalar or list assignment is
4516 constructed. Which type of assignment it is is automatically determined.
4517 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4518 will be set automatically, and, shifted up eight bits, the eight bits
4519 of C<op_private>, except that the bit with value 1 or 2 is automatically
4526 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4532 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4533 return newLOGOP(optype, 0,
4534 op_lvalue(scalar(left), optype),
4535 newUNOP(OP_SASSIGN, 0, scalar(right)));
4538 return newBINOP(optype, OPf_STACKED,
4539 op_lvalue(scalar(left), optype), scalar(right));
4543 if (is_list_assignment(left)) {
4544 static const char no_list_state[] = "Initialization of state variables"
4545 " in list context currently forbidden";
4547 bool maybe_common_vars = TRUE;
4550 /* Grandfathering $[ assignment here. Bletch.*/
4551 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4552 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4553 left = op_lvalue(left, OP_AASSIGN);
4556 else if (left->op_type == OP_CONST) {
4557 deprecate("assignment to $[");
4559 /* Result of assignment is always 1 (or we'd be dead already) */
4560 return newSVOP(OP_CONST, 0, newSViv(1));
4562 curop = list(force_list(left));
4563 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4564 o->op_private = (U8)(0 | (flags >> 8));
4566 if ((left->op_type == OP_LIST
4567 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4569 OP* lop = ((LISTOP*)left)->op_first;
4570 maybe_common_vars = FALSE;
4572 if (lop->op_type == OP_PADSV ||
4573 lop->op_type == OP_PADAV ||
4574 lop->op_type == OP_PADHV ||
4575 lop->op_type == OP_PADANY) {
4576 if (!(lop->op_private & OPpLVAL_INTRO))
4577 maybe_common_vars = TRUE;
4579 if (lop->op_private & OPpPAD_STATE) {
4580 if (left->op_private & OPpLVAL_INTRO) {
4581 /* Each variable in state($a, $b, $c) = ... */
4584 /* Each state variable in
4585 (state $a, my $b, our $c, $d, undef) = ... */
4587 yyerror(no_list_state);
4589 /* Each my variable in
4590 (state $a, my $b, our $c, $d, undef) = ... */
4592 } else if (lop->op_type == OP_UNDEF ||
4593 lop->op_type == OP_PUSHMARK) {
4594 /* undef may be interesting in
4595 (state $a, undef, state $c) */
4597 /* Other ops in the list. */
4598 maybe_common_vars = TRUE;
4600 lop = lop->op_sibling;
4603 else if ((left->op_private & OPpLVAL_INTRO)
4604 && ( left->op_type == OP_PADSV
4605 || left->op_type == OP_PADAV
4606 || left->op_type == OP_PADHV
4607 || left->op_type == OP_PADANY))
4609 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4610 if (left->op_private & OPpPAD_STATE) {
4611 /* All single variable list context state assignments, hence
4621 yyerror(no_list_state);
4625 /* PL_generation sorcery:
4626 * an assignment like ($a,$b) = ($c,$d) is easier than
4627 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4628 * To detect whether there are common vars, the global var
4629 * PL_generation is incremented for each assign op we compile.
4630 * Then, while compiling the assign op, we run through all the
4631 * variables on both sides of the assignment, setting a spare slot
4632 * in each of them to PL_generation. If any of them already have
4633 * that value, we know we've got commonality. We could use a
4634 * single bit marker, but then we'd have to make 2 passes, first
4635 * to clear the flag, then to test and set it. To find somewhere
4636 * to store these values, evil chicanery is done with SvUVX().
4639 if (maybe_common_vars) {
4642 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4643 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4644 if (curop->op_type == OP_GV) {
4645 GV *gv = cGVOPx_gv(curop);
4647 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4649 GvASSIGN_GENERATION_set(gv, PL_generation);
4651 else if (curop->op_type == OP_PADSV ||
4652 curop->op_type == OP_PADAV ||
4653 curop->op_type == OP_PADHV ||
4654 curop->op_type == OP_PADANY)
4656 if (PAD_COMPNAME_GEN(curop->op_targ)
4657 == (STRLEN)PL_generation)
4659 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4662 else if (curop->op_type == OP_RV2CV)
4664 else if (curop->op_type == OP_RV2SV ||
4665 curop->op_type == OP_RV2AV ||
4666 curop->op_type == OP_RV2HV ||
4667 curop->op_type == OP_RV2GV) {
4668 if (lastop->op_type != OP_GV) /* funny deref? */
4671 else if (curop->op_type == OP_PUSHRE) {
4673 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4674 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4676 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4678 GvASSIGN_GENERATION_set(gv, PL_generation);
4682 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4685 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4687 GvASSIGN_GENERATION_set(gv, PL_generation);
4697 o->op_private |= OPpASSIGN_COMMON;
4700 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4701 OP* tmpop = ((LISTOP*)right)->op_first;
4702 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4703 PMOP * const pm = (PMOP*)tmpop;
4704 if (left->op_type == OP_RV2AV &&
4705 !(left->op_private & OPpLVAL_INTRO) &&
4706 !(o->op_private & OPpASSIGN_COMMON) )
4708 tmpop = ((UNOP*)left)->op_first;
4709 if (tmpop->op_type == OP_GV
4711 && !pm->op_pmreplrootu.op_pmtargetoff
4713 && !pm->op_pmreplrootu.op_pmtargetgv
4717 pm->op_pmreplrootu.op_pmtargetoff
4718 = cPADOPx(tmpop)->op_padix;
4719 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4721 pm->op_pmreplrootu.op_pmtargetgv
4722 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4723 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4725 pm->op_pmflags |= PMf_ONCE;
4726 tmpop = cUNOPo->op_first; /* to list (nulled) */
4727 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4728 tmpop->op_sibling = NULL; /* don't free split */
4729 right->op_next = tmpop->op_next; /* fix starting loc */
4730 op_free(o); /* blow off assign */
4731 right->op_flags &= ~OPf_WANT;
4732 /* "I don't know and I don't care." */
4737 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4738 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4740 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4741 if (SvIOK(sv) && SvIVX(sv) == 0)
4742 sv_setiv(sv, PL_modcount+1);
4750 right = newOP(OP_UNDEF, 0);
4751 if (right->op_type == OP_READLINE) {
4752 right->op_flags |= OPf_STACKED;
4753 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
4757 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4758 o = newBINOP(OP_SASSIGN, flags,
4759 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
4763 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4764 deprecate("assignment to $[");
4766 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4767 o->op_private |= OPpCONST_ARYBASE;
4775 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4777 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4778 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4779 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4780 If I<label> is non-null, it supplies the name of a label to attach to
4781 the state op; this function takes ownership of the memory pointed at by
4782 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4785 If I<o> is null, the state op is returned. Otherwise the state op is
4786 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4787 is consumed by this function and becomes part of the returned op tree.
4793 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4796 const U32 seq = intro_my();
4799 NewOp(1101, cop, 1, COP);
4800 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4801 cop->op_type = OP_DBSTATE;
4802 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4805 cop->op_type = OP_NEXTSTATE;
4806 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4808 cop->op_flags = (U8)flags;
4809 CopHINTS_set(cop, PL_hints);
4811 cop->op_private |= NATIVE_HINTS;
4813 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4814 cop->op_next = (OP*)cop;
4817 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4818 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4820 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4821 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4823 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4825 PL_hints |= HINT_BLOCK_SCOPE;
4826 /* It seems that we need to defer freeing this pointer, as other parts
4827 of the grammar end up wanting to copy it after this op has been
4832 if (PL_parser && PL_parser->copline == NOLINE)
4833 CopLINE_set(cop, CopLINE(PL_curcop));
4835 CopLINE_set(cop, PL_parser->copline);
4837 PL_parser->copline = NOLINE;
4840 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4842 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4844 CopSTASH_set(cop, PL_curstash);
4846 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4847 /* this line can have a breakpoint - store the cop in IV */
4848 AV *av = CopFILEAVx(PL_curcop);
4850 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4851 if (svp && *svp != &PL_sv_undef ) {
4852 (void)SvIOK_on(*svp);
4853 SvIV_set(*svp, PTR2IV(cop));
4858 if (flags & OPf_SPECIAL)
4860 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4864 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4866 Constructs, checks, and returns a logical (flow control) op. I<type>
4867 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4868 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4869 the eight bits of C<op_private>, except that the bit with value 1 is
4870 automatically set. I<first> supplies the expression controlling the
4871 flow, and I<other> supplies the side (alternate) chain of ops; they are
4872 consumed by this function and become part of the constructed op tree.
4878 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4882 PERL_ARGS_ASSERT_NEWLOGOP;
4884 return new_logop(type, flags, &first, &other);
4888 S_search_const(pTHX_ OP *o)
4890 PERL_ARGS_ASSERT_SEARCH_CONST;
4892 switch (o->op_type) {
4896 if (o->op_flags & OPf_KIDS)
4897 return search_const(cUNOPo->op_first);
4904 if (!(o->op_flags & OPf_KIDS))
4906 kid = cLISTOPo->op_first;
4908 switch (kid->op_type) {
4912 kid = kid->op_sibling;
4915 if (kid != cLISTOPo->op_last)
4921 kid = cLISTOPo->op_last;
4923 return search_const(kid);
4931 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4939 int prepend_not = 0;
4941 PERL_ARGS_ASSERT_NEW_LOGOP;
4946 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4947 return newBINOP(type, flags, scalar(first), scalar(other));
4949 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4951 scalarboolean(first);
4952 /* optimize AND and OR ops that have NOTs as children */
4953 if (first->op_type == OP_NOT
4954 && (first->op_flags & OPf_KIDS)
4955 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4956 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4958 if (type == OP_AND || type == OP_OR) {
4964 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4966 prepend_not = 1; /* prepend a NOT op later */
4970 /* search for a constant op that could let us fold the test */
4971 if ((cstop = search_const(first))) {
4972 if (cstop->op_private & OPpCONST_STRICT)
4973 no_bareword_allowed(cstop);
4974 else if ((cstop->op_private & OPpCONST_BARE))
4975 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4976 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4977 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4978 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4980 if (other->op_type == OP_CONST)
4981 other->op_private |= OPpCONST_SHORTCIRCUIT;
4983 OP *newop = newUNOP(OP_NULL, 0, other);
4984 op_getmad(first, newop, '1');
4985 newop->op_targ = type; /* set "was" field */
4989 if (other->op_type == OP_LEAVE)
4990 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4991 else if (other->op_type == OP_MATCH
4992 || other->op_type == OP_SUBST
4993 || other->op_type == OP_TRANS)
4994 /* Mark the op as being unbindable with =~ */
4995 other->op_flags |= OPf_SPECIAL;
4999 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5000 const OP *o2 = other;
5001 if ( ! (o2->op_type == OP_LIST
5002 && (( o2 = cUNOPx(o2)->op_first))
5003 && o2->op_type == OP_PUSHMARK
5004 && (( o2 = o2->op_sibling)) )
5007 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5008 || o2->op_type == OP_PADHV)
5009 && o2->op_private & OPpLVAL_INTRO
5010 && !(o2->op_private & OPpPAD_STATE))
5012 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5013 "Deprecated use of my() in false conditional");
5017 if (first->op_type == OP_CONST)
5018 first->op_private |= OPpCONST_SHORTCIRCUIT;
5020 first = newUNOP(OP_NULL, 0, first);
5021 op_getmad(other, first, '2');
5022 first->op_targ = type; /* set "was" field */
5029 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5030 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5032 const OP * const k1 = ((UNOP*)first)->op_first;
5033 const OP * const k2 = k1->op_sibling;
5035 switch (first->op_type)
5038 if (k2 && k2->op_type == OP_READLINE
5039 && (k2->op_flags & OPf_STACKED)
5040 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5042 warnop = k2->op_type;
5047 if (k1->op_type == OP_READDIR
5048 || k1->op_type == OP_GLOB
5049 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5050 || k1->op_type == OP_EACH)
5052 warnop = ((k1->op_type == OP_NULL)
5053 ? (OPCODE)k1->op_targ : k1->op_type);
5058 const line_t oldline = CopLINE(PL_curcop);
5059 CopLINE_set(PL_curcop, PL_parser->copline);
5060 Perl_warner(aTHX_ packWARN(WARN_MISC),
5061 "Value of %s%s can be \"0\"; test with defined()",
5063 ((warnop == OP_READLINE || warnop == OP_GLOB)
5064 ? " construct" : "() operator"));
5065 CopLINE_set(PL_curcop, oldline);
5072 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5073 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5075 NewOp(1101, logop, 1, LOGOP);
5077 logop->op_type = (OPCODE)type;
5078 logop->op_ppaddr = PL_ppaddr[type];
5079 logop->op_first = first;
5080 logop->op_flags = (U8)(flags | OPf_KIDS);
5081 logop->op_other = LINKLIST(other);
5082 logop->op_private = (U8)(1 | (flags >> 8));
5084 /* establish postfix order */
5085 logop->op_next = LINKLIST(first);
5086 first->op_next = (OP*)logop;
5087 first->op_sibling = other;
5089 CHECKOP(type,logop);
5091 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5098 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5100 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5101 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5102 will be set automatically, and, shifted up eight bits, the eight bits of
5103 C<op_private>, except that the bit with value 1 is automatically set.
5104 I<first> supplies the expression selecting between the two branches,
5105 and I<trueop> and I<falseop> supply the branches; they are consumed by
5106 this function and become part of the constructed op tree.
5112 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5120 PERL_ARGS_ASSERT_NEWCONDOP;
5123 return newLOGOP(OP_AND, 0, first, trueop);
5125 return newLOGOP(OP_OR, 0, first, falseop);
5127 scalarboolean(first);
5128 if ((cstop = search_const(first))) {
5129 /* Left or right arm of the conditional? */
5130 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5131 OP *live = left ? trueop : falseop;
5132 OP *const dead = left ? falseop : trueop;
5133 if (cstop->op_private & OPpCONST_BARE &&
5134 cstop->op_private & OPpCONST_STRICT) {
5135 no_bareword_allowed(cstop);
5138 /* This is all dead code when PERL_MAD is not defined. */
5139 live = newUNOP(OP_NULL, 0, live);
5140 op_getmad(first, live, 'C');
5141 op_getmad(dead, live, left ? 'e' : 't');
5146 if (live->op_type == OP_LEAVE)
5147 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5148 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5149 || live->op_type == OP_TRANS)
5150 /* Mark the op as being unbindable with =~ */
5151 live->op_flags |= OPf_SPECIAL;
5154 NewOp(1101, logop, 1, LOGOP);
5155 logop->op_type = OP_COND_EXPR;
5156 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5157 logop->op_first = first;
5158 logop->op_flags = (U8)(flags | OPf_KIDS);
5159 logop->op_private = (U8)(1 | (flags >> 8));
5160 logop->op_other = LINKLIST(trueop);
5161 logop->op_next = LINKLIST(falseop);
5163 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5166 /* establish postfix order */
5167 start = LINKLIST(first);
5168 first->op_next = (OP*)logop;
5170 first->op_sibling = trueop;
5171 trueop->op_sibling = falseop;
5172 o = newUNOP(OP_NULL, 0, (OP*)logop);
5174 trueop->op_next = falseop->op_next = o;
5181 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5183 Constructs and returns a C<range> op, with subordinate C<flip> and
5184 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5185 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5186 for both the C<flip> and C<range> ops, except that the bit with value
5187 1 is automatically set. I<left> and I<right> supply the expressions
5188 controlling the endpoints of the range; they are consumed by this function
5189 and become part of the constructed op tree.
5195 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5204 PERL_ARGS_ASSERT_NEWRANGE;
5206 NewOp(1101, range, 1, LOGOP);
5208 range->op_type = OP_RANGE;
5209 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5210 range->op_first = left;
5211 range->op_flags = OPf_KIDS;
5212 leftstart = LINKLIST(left);
5213 range->op_other = LINKLIST(right);
5214 range->op_private = (U8)(1 | (flags >> 8));
5216 left->op_sibling = right;
5218 range->op_next = (OP*)range;
5219 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5220 flop = newUNOP(OP_FLOP, 0, flip);
5221 o = newUNOP(OP_NULL, 0, flop);
5223 range->op_next = leftstart;
5225 left->op_next = flip;
5226 right->op_next = flop;
5228 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5229 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5230 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5231 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5233 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5234 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5237 if (!flip->op_private || !flop->op_private)
5238 LINKLIST(o); /* blow off optimizer unless constant */
5244 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5246 Constructs, checks, and returns an op tree expressing a loop. This is
5247 only a loop in the control flow through the op tree; it does not have
5248 the heavyweight loop structure that allows exiting the loop by C<last>
5249 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5250 top-level op, except that some bits will be set automatically as required.
5251 I<expr> supplies the expression controlling loop iteration, and I<block>
5252 supplies the body of the loop; they are consumed by this function and
5253 become part of the constructed op tree. I<debuggable> is currently
5254 unused and should always be 1.
5260 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5265 const bool once = block && block->op_flags & OPf_SPECIAL &&
5266 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5268 PERL_UNUSED_ARG(debuggable);
5271 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5272 return block; /* do {} while 0 does once */
5273 if (expr->op_type == OP_READLINE
5274 || expr->op_type == OP_READDIR
5275 || expr->op_type == OP_GLOB
5276 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5277 expr = newUNOP(OP_DEFINED, 0,
5278 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5279 } else if (expr->op_flags & OPf_KIDS) {
5280 const OP * const k1 = ((UNOP*)expr)->op_first;
5281 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5282 switch (expr->op_type) {
5284 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5285 && (k2->op_flags & OPf_STACKED)
5286 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5287 expr = newUNOP(OP_DEFINED, 0, expr);
5291 if (k1 && (k1->op_type == OP_READDIR
5292 || k1->op_type == OP_GLOB
5293 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5294 || k1->op_type == OP_EACH))
5295 expr = newUNOP(OP_DEFINED, 0, expr);
5301 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5302 * op, in listop. This is wrong. [perl #27024] */
5304 block = newOP(OP_NULL, 0);
5305 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5306 o = new_logop(OP_AND, 0, &expr, &listop);
5309 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5311 if (once && o != listop)
5312 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5315 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5317 o->op_flags |= flags;
5319 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5324 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5326 Constructs, checks, and returns an op tree expressing a C<while> loop.
5327 This is a heavyweight loop, with structure that allows exiting the loop
5328 by C<last> and suchlike.
5330 I<loop> is an optional preconstructed C<enterloop> op to use in the
5331 loop; if it is null then a suitable op will be constructed automatically.
5332 I<expr> supplies the loop's controlling expression. I<block> supplies the
5333 main body of the loop, and I<cont> optionally supplies a C<continue> block
5334 that operates as a second half of the body. All of these optree inputs
5335 are consumed by this function and become part of the constructed op tree.
5337 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5338 op and, shifted up eight bits, the eight bits of C<op_private> for
5339 the C<leaveloop> op, except that (in both cases) some bits will be set
5340 automatically. I<debuggable> is currently unused and should always be 1.
5341 I<has_my> can be supplied as true to force the
5342 loop body to be enclosed in its own scope.
5348 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5349 OP *expr, OP *block, OP *cont, I32 has_my)
5358 PERL_UNUSED_ARG(debuggable);
5361 if (expr->op_type == OP_READLINE
5362 || expr->op_type == OP_READDIR
5363 || expr->op_type == OP_GLOB
5364 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5365 expr = newUNOP(OP_DEFINED, 0,
5366 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5367 } else if (expr->op_flags & OPf_KIDS) {
5368 const OP * const k1 = ((UNOP*)expr)->op_first;
5369 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5370 switch (expr->op_type) {
5372 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5373 && (k2->op_flags & OPf_STACKED)
5374 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5375 expr = newUNOP(OP_DEFINED, 0, expr);
5379 if (k1 && (k1->op_type == OP_READDIR
5380 || k1->op_type == OP_GLOB
5381 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5382 || k1->op_type == OP_EACH))
5383 expr = newUNOP(OP_DEFINED, 0, expr);
5390 block = newOP(OP_NULL, 0);
5391 else if (cont || has_my) {
5392 block = op_scope(block);
5396 next = LINKLIST(cont);
5399 OP * const unstack = newOP(OP_UNSTACK, 0);
5402 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5406 listop = op_append_list(OP_LINESEQ, block, cont);
5408 redo = LINKLIST(listop);
5412 o = new_logop(OP_AND, 0, &expr, &listop);
5413 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5414 op_free(expr); /* oops, it's a while (0) */
5416 return NULL; /* listop already freed by new_logop */
5419 ((LISTOP*)listop)->op_last->op_next =
5420 (o == listop ? redo : LINKLIST(o));
5426 NewOp(1101,loop,1,LOOP);
5427 loop->op_type = OP_ENTERLOOP;
5428 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5429 loop->op_private = 0;
5430 loop->op_next = (OP*)loop;
5433 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5435 loop->op_redoop = redo;
5436 loop->op_lastop = o;
5437 o->op_private |= loopflags;
5440 loop->op_nextop = next;
5442 loop->op_nextop = o;
5444 o->op_flags |= flags;
5445 o->op_private |= (flags >> 8);
5450 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5452 Constructs, checks, and returns an op tree expressing a C<foreach>
5453 loop (iteration through a list of values). This is a heavyweight loop,
5454 with structure that allows exiting the loop by C<last> and suchlike.
5456 I<sv> optionally supplies the variable that will be aliased to each
5457 item in turn; if null, it defaults to C<$_> (either lexical or global).
5458 I<expr> supplies the list of values to iterate over. I<block> supplies
5459 the main body of the loop, and I<cont> optionally supplies a C<continue>
5460 block that operates as a second half of the body. All of these optree
5461 inputs are consumed by this function and become part of the constructed
5464 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5465 op and, shifted up eight bits, the eight bits of C<op_private> for
5466 the C<leaveloop> op, except that (in both cases) some bits will be set
5473 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5478 PADOFFSET padoff = 0;
5483 PERL_ARGS_ASSERT_NEWFOROP;
5486 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5487 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5488 sv->op_type = OP_RV2GV;
5489 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5491 /* The op_type check is needed to prevent a possible segfault
5492 * if the loop variable is undeclared and 'strict vars' is in
5493 * effect. This is illegal but is nonetheless parsed, so we
5494 * may reach this point with an OP_CONST where we're expecting
5497 if (cUNOPx(sv)->op_first->op_type == OP_GV
5498 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5499 iterpflags |= OPpITER_DEF;
5501 else if (sv->op_type == OP_PADSV) { /* private variable */
5502 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5503 padoff = sv->op_targ;
5513 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5515 SV *const namesv = PAD_COMPNAME_SV(padoff);
5517 const char *const name = SvPV_const(namesv, len);
5519 if (len == 2 && name[0] == '$' && name[1] == '_')
5520 iterpflags |= OPpITER_DEF;
5524 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5525 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5526 sv = newGVOP(OP_GV, 0, PL_defgv);
5531 iterpflags |= OPpITER_DEF;
5533 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5534 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5535 iterflags |= OPf_STACKED;
5537 else if (expr->op_type == OP_NULL &&
5538 (expr->op_flags & OPf_KIDS) &&
5539 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5541 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5542 * set the STACKED flag to indicate that these values are to be
5543 * treated as min/max values by 'pp_iterinit'.
5545 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5546 LOGOP* const range = (LOGOP*) flip->op_first;
5547 OP* const left = range->op_first;
5548 OP* const right = left->op_sibling;
5551 range->op_flags &= ~OPf_KIDS;
5552 range->op_first = NULL;
5554 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5555 listop->op_first->op_next = range->op_next;
5556 left->op_next = range->op_other;
5557 right->op_next = (OP*)listop;
5558 listop->op_next = listop->op_first;
5561 op_getmad(expr,(OP*)listop,'O');
5565 expr = (OP*)(listop);
5567 iterflags |= OPf_STACKED;
5570 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5573 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5574 op_append_elem(OP_LIST, expr, scalar(sv))));
5575 assert(!loop->op_next);
5576 /* for my $x () sets OPpLVAL_INTRO;
5577 * for our $x () sets OPpOUR_INTRO */
5578 loop->op_private = (U8)iterpflags;
5579 #ifdef PL_OP_SLAB_ALLOC
5582 NewOp(1234,tmp,1,LOOP);
5583 Copy(loop,tmp,1,LISTOP);
5584 S_op_destroy(aTHX_ (OP*)loop);
5588 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5590 loop->op_targ = padoff;
5591 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5593 op_getmad(madsv, (OP*)loop, 'v');
5598 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5600 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5601 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5602 determining the target of the op; it is consumed by this function and
5603 become part of the constructed op tree.
5609 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5614 PERL_ARGS_ASSERT_NEWLOOPEX;
5616 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5618 if (type != OP_GOTO || label->op_type == OP_CONST) {
5619 /* "last()" means "last" */
5620 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5621 o = newOP(type, OPf_SPECIAL);
5623 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5624 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5628 op_getmad(label,o,'L');
5634 /* Check whether it's going to be a goto &function */
5635 if (label->op_type == OP_ENTERSUB
5636 && !(label->op_flags & OPf_STACKED))
5637 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
5638 o = newUNOP(type, OPf_STACKED, label);
5640 PL_hints |= HINT_BLOCK_SCOPE;
5644 /* if the condition is a literal array or hash
5645 (or @{ ... } etc), make a reference to it.
5648 S_ref_array_or_hash(pTHX_ OP *cond)
5651 && (cond->op_type == OP_RV2AV
5652 || cond->op_type == OP_PADAV
5653 || cond->op_type == OP_RV2HV
5654 || cond->op_type == OP_PADHV))
5656 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
5659 && (cond->op_type == OP_ASLICE
5660 || cond->op_type == OP_HSLICE)) {
5662 /* anonlist now needs a list from this op, was previously used in
5664 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5665 cond->op_flags |= OPf_WANT_LIST;
5667 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
5674 /* These construct the optree fragments representing given()
5677 entergiven and enterwhen are LOGOPs; the op_other pointer
5678 points up to the associated leave op. We need this so we
5679 can put it in the context and make break/continue work.
5680 (Also, of course, pp_enterwhen will jump straight to
5681 op_other if the match fails.)
5685 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5686 I32 enter_opcode, I32 leave_opcode,
5687 PADOFFSET entertarg)
5693 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5695 NewOp(1101, enterop, 1, LOGOP);
5696 enterop->op_type = (Optype)enter_opcode;
5697 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5698 enterop->op_flags = (U8) OPf_KIDS;
5699 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5700 enterop->op_private = 0;
5702 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5705 enterop->op_first = scalar(cond);
5706 cond->op_sibling = block;
5708 o->op_next = LINKLIST(cond);
5709 cond->op_next = (OP *) enterop;
5712 /* This is a default {} block */
5713 enterop->op_first = block;
5714 enterop->op_flags |= OPf_SPECIAL;
5716 o->op_next = (OP *) enterop;
5719 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5720 entergiven and enterwhen both
5723 enterop->op_next = LINKLIST(block);
5724 block->op_next = enterop->op_other = o;
5729 /* Does this look like a boolean operation? For these purposes
5730 a boolean operation is:
5731 - a subroutine call [*]
5732 - a logical connective
5733 - a comparison operator
5734 - a filetest operator, with the exception of -s -M -A -C
5735 - defined(), exists() or eof()
5736 - /$re/ or $foo =~ /$re/
5738 [*] possibly surprising
5741 S_looks_like_bool(pTHX_ const OP *o)
5745 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5747 switch(o->op_type) {
5750 return looks_like_bool(cLOGOPo->op_first);
5754 looks_like_bool(cLOGOPo->op_first)
5755 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5760 o->op_flags & OPf_KIDS
5761 && looks_like_bool(cUNOPo->op_first));
5765 case OP_NOT: case OP_XOR:
5767 case OP_EQ: case OP_NE: case OP_LT:
5768 case OP_GT: case OP_LE: case OP_GE:
5770 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5771 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5773 case OP_SEQ: case OP_SNE: case OP_SLT:
5774 case OP_SGT: case OP_SLE: case OP_SGE:
5778 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5779 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5780 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5781 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5782 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5783 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5784 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5785 case OP_FTTEXT: case OP_FTBINARY:
5787 case OP_DEFINED: case OP_EXISTS:
5788 case OP_MATCH: case OP_EOF:
5795 /* Detect comparisons that have been optimized away */
5796 if (cSVOPo->op_sv == &PL_sv_yes
5797 || cSVOPo->op_sv == &PL_sv_no)
5810 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5812 Constructs, checks, and returns an op tree expressing a C<given> block.
5813 I<cond> supplies the expression that will be locally assigned to a lexical
5814 variable, and I<block> supplies the body of the C<given> construct; they
5815 are consumed by this function and become part of the constructed op tree.
5816 I<defsv_off> is the pad offset of the scalar lexical variable that will
5823 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5826 PERL_ARGS_ASSERT_NEWGIVENOP;
5827 return newGIVWHENOP(
5828 ref_array_or_hash(cond),
5830 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5835 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5837 Constructs, checks, and returns an op tree expressing a C<when> block.
5838 I<cond> supplies the test expression, and I<block> supplies the block
5839 that will be executed if the test evaluates to true; they are consumed
5840 by this function and become part of the constructed op tree. I<cond>
5841 will be interpreted DWIMically, often as a comparison against C<$_>,
5842 and may be null to generate a C<default> block.
5848 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5850 const bool cond_llb = (!cond || looks_like_bool(cond));
5853 PERL_ARGS_ASSERT_NEWWHENOP;
5858 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5860 scalar(ref_array_or_hash(cond)));
5863 return newGIVWHENOP(
5865 op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5866 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5870 =head1 Embedding Functions
5872 =for apidoc cv_undef
5874 Clear out all the active components of a CV. This can happen either
5875 by an explicit C<undef &foo>, or by the reference count going to zero.
5876 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5877 children can still follow the full lexical scope chain.
5883 Perl_cv_undef(pTHX_ CV *cv)
5887 PERL_ARGS_ASSERT_CV_UNDEF;
5889 DEBUG_X(PerlIO_printf(Perl_debug_log,
5890 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5891 PTR2UV(cv), PTR2UV(PL_comppad))
5895 if (CvFILE(cv) && !CvISXSUB(cv)) {
5896 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5897 Safefree(CvFILE(cv));
5902 if (!CvISXSUB(cv) && CvROOT(cv)) {
5903 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5904 Perl_croak(aTHX_ "Can't undef active subroutine");
5907 PAD_SAVE_SETNULLPAD();
5909 op_free(CvROOT(cv));
5914 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5919 /* remove CvOUTSIDE unless this is an undef rather than a free */
5920 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5921 if (!CvWEAKOUTSIDE(cv))
5922 SvREFCNT_dec(CvOUTSIDE(cv));
5923 CvOUTSIDE(cv) = NULL;
5926 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5929 if (CvISXSUB(cv) && CvXSUB(cv)) {
5932 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
5933 * ref status of CvOUTSIDE and CvGV */
5934 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
5938 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5941 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5943 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5944 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5945 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5946 || (p && (len != SvCUR(cv) /* Not the same length. */
5947 || memNE(p, SvPVX_const(cv), len))))
5948 && ckWARN_d(WARN_PROTOTYPE)) {
5949 SV* const msg = sv_newmortal();
5953 gv_efullname3(name = sv_newmortal(), gv, NULL);
5954 sv_setpvs(msg, "Prototype mismatch:");
5956 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5958 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5960 sv_catpvs(msg, ": none");
5961 sv_catpvs(msg, " vs ");
5963 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5965 sv_catpvs(msg, "none");
5966 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5970 static void const_sv_xsub(pTHX_ CV* cv);
5974 =head1 Optree Manipulation Functions
5976 =for apidoc cv_const_sv
5978 If C<cv> is a constant sub eligible for inlining. returns the constant
5979 value returned by the sub. Otherwise, returns NULL.
5981 Constant subs can be created with C<newCONSTSUB> or as described in
5982 L<perlsub/"Constant Functions">.
5987 Perl_cv_const_sv(pTHX_ const CV *const cv)
5989 PERL_UNUSED_CONTEXT;
5992 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5994 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5997 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5998 * Can be called in 3 ways:
6001 * look for a single OP_CONST with attached value: return the value
6003 * cv && CvCLONE(cv) && !CvCONST(cv)
6005 * examine the clone prototype, and if contains only a single
6006 * OP_CONST referencing a pad const, or a single PADSV referencing
6007 * an outer lexical, return a non-zero value to indicate the CV is
6008 * a candidate for "constizing" at clone time
6012 * We have just cloned an anon prototype that was marked as a const
6013 * candidiate. Try to grab the current value, and in the case of
6014 * PADSV, ignore it if it has multiple references. Return the value.
6018 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6029 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6030 o = cLISTOPo->op_first->op_sibling;
6032 for (; o; o = o->op_next) {
6033 const OPCODE type = o->op_type;
6035 if (sv && o->op_next == o)
6037 if (o->op_next != o) {
6038 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
6040 if (type == OP_DBSTATE)
6043 if (type == OP_LEAVESUB || type == OP_RETURN)
6047 if (type == OP_CONST && cSVOPo->op_sv)
6049 else if (cv && type == OP_CONST) {
6050 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6054 else if (cv && type == OP_PADSV) {
6055 if (CvCONST(cv)) { /* newly cloned anon */
6056 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6057 /* the candidate should have 1 ref from this pad and 1 ref
6058 * from the parent */
6059 if (!sv || SvREFCNT(sv) != 2)
6066 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6067 sv = &PL_sv_undef; /* an arbitrary non-null value */
6082 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6085 /* This would be the return value, but the return cannot be reached. */
6086 OP* pegop = newOP(OP_NULL, 0);
6089 PERL_UNUSED_ARG(floor);
6099 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6101 NORETURN_FUNCTION_END;
6106 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
6108 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
6112 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6117 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6118 register CV *cv = NULL;
6120 /* If the subroutine has no body, no attributes, and no builtin attributes
6121 then it's just a sub declaration, and we may be able to get away with
6122 storing with a placeholder scalar in the symbol table, rather than a
6123 full GV and CV. If anything is present then it will take a full CV to
6125 const I32 gv_fetch_flags
6126 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6128 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6129 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6133 assert(proto->op_type == OP_CONST);
6134 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6140 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6142 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6143 SV * const sv = sv_newmortal();
6144 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6145 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6146 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6147 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6149 } else if (PL_curstash) {
6150 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6153 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6157 if (!PL_madskills) {
6166 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6167 maximum a prototype before. */
6168 if (SvTYPE(gv) > SVt_NULL) {
6169 if (!SvPOK((const SV *)gv)
6170 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6172 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6174 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6177 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6179 sv_setiv(MUTABLE_SV(gv), -1);
6181 SvREFCNT_dec(PL_compcv);
6182 cv = PL_compcv = NULL;
6186 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6188 if (!block || !ps || *ps || attrs
6189 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6191 || block->op_type == OP_NULL
6196 const_sv = op_const_sv(block, NULL);
6199 const bool exists = CvROOT(cv) || CvXSUB(cv);
6201 /* if the subroutine doesn't exist and wasn't pre-declared
6202 * with a prototype, assume it will be AUTOLOADed,
6203 * skipping the prototype check
6205 if (exists || SvPOK(cv))
6206 cv_ckproto_len(cv, gv, ps, ps_len);
6207 /* already defined (or promised)? */
6208 if (exists || GvASSUMECV(gv)) {
6211 || block->op_type == OP_NULL
6214 if (CvFLAGS(PL_compcv)) {
6215 /* might have had built-in attrs applied */
6216 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6217 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6218 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6220 /* just a "sub foo;" when &foo is already defined */
6221 SAVEFREESV(PL_compcv);
6226 && block->op_type != OP_NULL
6229 if (ckWARN(WARN_REDEFINE)
6231 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6233 const line_t oldline = CopLINE(PL_curcop);
6234 if (PL_parser && PL_parser->copline != NOLINE)
6235 CopLINE_set(PL_curcop, PL_parser->copline);
6236 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6237 CvCONST(cv) ? "Constant subroutine %s redefined"
6238 : "Subroutine %s redefined", name);
6239 CopLINE_set(PL_curcop, oldline);
6242 if (!PL_minus_c) /* keep old one around for madskills */
6245 /* (PL_madskills unset in used file.) */
6253 SvREFCNT_inc_simple_void_NN(const_sv);
6255 assert(!CvROOT(cv) && !CvCONST(cv));
6256 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6257 CvXSUBANY(cv).any_ptr = const_sv;
6258 CvXSUB(cv) = const_sv_xsub;
6264 cv = newCONSTSUB(NULL, name, const_sv);
6266 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6267 (CvGV(cv) && GvSTASH(CvGV(cv)))
6276 SvREFCNT_dec(PL_compcv);
6280 if (cv) { /* must reuse cv if autoloaded */
6281 /* transfer PL_compcv to cv */
6284 && block->op_type != OP_NULL
6287 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6289 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6290 if (!CvWEAKOUTSIDE(cv))
6291 SvREFCNT_dec(CvOUTSIDE(cv));
6292 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6293 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6294 CvOUTSIDE(PL_compcv) = 0;
6295 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6296 CvPADLIST(PL_compcv) = 0;
6297 /* inner references to PL_compcv must be fixed up ... */
6298 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6299 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6300 ++PL_sub_generation;
6303 /* Might have had built-in attributes applied -- propagate them. */
6304 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6306 /* ... before we throw it away */
6307 SvREFCNT_dec(PL_compcv);
6315 if (strEQ(name, "import")) {
6316 PL_formfeed = MUTABLE_SV(cv);
6317 /* diag_listed_as: SKIPME */
6318 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6322 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6327 CvFILE_set_from_cop(cv, PL_curcop);
6328 CvSTASH_set(cv, PL_curstash);
6331 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6332 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6333 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6337 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6339 if (PL_parser && PL_parser->error_count) {
6343 const char *s = strrchr(name, ':');
6345 if (strEQ(s, "BEGIN")) {
6346 const char not_safe[] =
6347 "BEGIN not safe after errors--compilation aborted";
6348 if (PL_in_eval & EVAL_KEEPERR)
6349 Perl_croak(aTHX_ not_safe);
6351 /* force display of errors found but not reported */
6352 sv_catpv(ERRSV, not_safe);
6353 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6362 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6363 the debugger could be able to set a breakpoint in, so signal to
6364 pp_entereval that it should not throw away any saved lines at scope
6367 PL_breakable_sub_gen++;
6369 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6370 op_lvalue(scalarseq(block), OP_LEAVESUBLV));
6371 block->op_attached = 1;
6374 /* This makes sub {}; work as expected. */
6375 if (block->op_type == OP_STUB) {
6376 OP* const newblock = newSTATEOP(0, NULL, 0);
6378 op_getmad(block,newblock,'B');
6385 block->op_attached = 1;
6386 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6388 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6389 OpREFCNT_set(CvROOT(cv), 1);
6390 CvSTART(cv) = LINKLIST(CvROOT(cv));
6391 CvROOT(cv)->op_next = 0;
6392 CALL_PEEP(CvSTART(cv));
6394 /* now that optimizer has done its work, adjust pad values */
6396 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6399 assert(!CvCONST(cv));
6400 if (ps && !*ps && op_const_sv(block, cv))
6405 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6406 SV * const tmpstr = sv_newmortal();
6407 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6408 GV_ADDMULTI, SVt_PVHV);
6410 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6413 (long)CopLINE(PL_curcop));
6414 gv_efullname3(tmpstr, gv, NULL);
6415 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6416 SvCUR(tmpstr), sv, 0);
6417 hv = GvHVn(db_postponed);
6418 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6419 CV * const pcv = GvCV(db_postponed);
6425 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6430 if (name && ! (PL_parser && PL_parser->error_count))
6431 process_special_blocks(name, gv, cv);
6436 PL_parser->copline = NOLINE;
6442 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6445 const char *const colon = strrchr(fullname,':');
6446 const char *const name = colon ? colon + 1 : fullname;
6448 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6451 if (strEQ(name, "BEGIN")) {
6452 const I32 oldscope = PL_scopestack_ix;
6454 SAVECOPFILE(&PL_compiling);
6455 SAVECOPLINE(&PL_compiling);
6457 DEBUG_x( dump_sub(gv) );
6458 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6459 GvCV(gv) = 0; /* cv has been hijacked */
6460 call_list(oldscope, PL_beginav);
6462 PL_curcop = &PL_compiling;
6463 CopHINTS_set(&PL_compiling, PL_hints);
6470 if strEQ(name, "END") {
6471 DEBUG_x( dump_sub(gv) );
6472 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6475 } else if (*name == 'U') {
6476 if (strEQ(name, "UNITCHECK")) {
6477 /* It's never too late to run a unitcheck block */
6478 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6482 } else if (*name == 'C') {
6483 if (strEQ(name, "CHECK")) {
6485 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6486 "Too late to run CHECK block");
6487 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6491 } else if (*name == 'I') {
6492 if (strEQ(name, "INIT")) {
6494 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6495 "Too late to run INIT block");
6496 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6502 DEBUG_x( dump_sub(gv) );
6503 GvCV(gv) = 0; /* cv has been hijacked */
6508 =for apidoc newCONSTSUB
6510 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6511 eligible for inlining at compile-time.
6513 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6514 which won't be called if used as a destructor, but will suppress the overhead
6515 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6522 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6527 const char *const file = CopFILE(PL_curcop);
6529 SV *const temp_sv = CopFILESV(PL_curcop);
6530 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6535 if (IN_PERL_RUNTIME) {
6536 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6537 * an op shared between threads. Use a non-shared COP for our
6539 SAVEVPTR(PL_curcop);
6540 PL_curcop = &PL_compiling;
6542 SAVECOPLINE(PL_curcop);
6543 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6546 PL_hints &= ~HINT_BLOCK_SCOPE;
6549 SAVESPTR(PL_curstash);
6550 SAVECOPSTASH(PL_curcop);
6551 PL_curstash = stash;
6552 CopSTASH_set(PL_curcop,stash);
6555 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6556 and so doesn't get free()d. (It's expected to be from the C pre-
6557 processor __FILE__ directive). But we need a dynamically allocated one,
6558 and we need it to get freed. */
6559 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6560 XS_DYNAMIC_FILENAME);
6561 CvXSUBANY(cv).any_ptr = sv;
6566 CopSTASH_free(PL_curcop);
6574 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6575 const char *const filename, const char *const proto,
6578 CV *cv = newXS(name, subaddr, filename);
6580 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6582 if (flags & XS_DYNAMIC_FILENAME) {
6583 /* We need to "make arrangements" (ie cheat) to ensure that the
6584 filename lasts as long as the PVCV we just created, but also doesn't
6586 STRLEN filename_len = strlen(filename);
6587 STRLEN proto_and_file_len = filename_len;
6588 char *proto_and_file;
6592 proto_len = strlen(proto);
6593 proto_and_file_len += proto_len;
6595 Newx(proto_and_file, proto_and_file_len + 1, char);
6596 Copy(proto, proto_and_file, proto_len, char);
6597 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6600 proto_and_file = savepvn(filename, filename_len);
6603 /* This gets free()d. :-) */
6604 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6605 SV_HAS_TRAILING_NUL);
6607 /* This gives us the correct prototype, rather than one with the
6608 file name appended. */
6609 SvCUR_set(cv, proto_len);
6613 CvFILE(cv) = proto_and_file + proto_len;
6615 sv_setpv(MUTABLE_SV(cv), proto);
6621 =for apidoc U||newXS
6623 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6624 static storage, as it is used directly as CvFILE(), without a copy being made.
6630 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6633 GV * const gv = gv_fetchpv(name ? name :
6634 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6635 GV_ADDMULTI, SVt_PVCV);
6638 PERL_ARGS_ASSERT_NEWXS;
6641 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6643 if ((cv = (name ? GvCV(gv) : NULL))) {
6645 /* just a cached method */
6649 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6650 /* already defined (or promised) */
6651 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6652 if (ckWARN(WARN_REDEFINE)) {
6653 GV * const gvcv = CvGV(cv);
6655 HV * const stash = GvSTASH(gvcv);
6657 const char *redefined_name = HvNAME_get(stash);
6658 if ( strEQ(redefined_name,"autouse") ) {
6659 const line_t oldline = CopLINE(PL_curcop);
6660 if (PL_parser && PL_parser->copline != NOLINE)
6661 CopLINE_set(PL_curcop, PL_parser->copline);
6662 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6663 CvCONST(cv) ? "Constant subroutine %s redefined"
6664 : "Subroutine %s redefined"
6666 CopLINE_set(PL_curcop, oldline);
6676 if (cv) /* must reuse cv if autoloaded */
6679 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6683 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6689 (void)gv_fetchfile(filename);
6690 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6691 an external constant string */
6693 CvXSUB(cv) = subaddr;
6696 process_special_blocks(name, gv, cv);
6706 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6711 OP* pegop = newOP(OP_NULL, 0);
6715 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6716 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6719 if ((cv = GvFORM(gv))) {
6720 if (ckWARN(WARN_REDEFINE)) {
6721 const line_t oldline = CopLINE(PL_curcop);
6722 if (PL_parser && PL_parser->copline != NOLINE)
6723 CopLINE_set(PL_curcop, PL_parser->copline);
6725 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6726 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6728 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6729 "Format STDOUT redefined");
6731 CopLINE_set(PL_curcop, oldline);
6738 CvFILE_set_from_cop(cv, PL_curcop);
6741 pad_tidy(padtidy_FORMAT);
6742 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6743 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6744 OpREFCNT_set(CvROOT(cv), 1);
6745 CvSTART(cv) = LINKLIST(CvROOT(cv));
6746 CvROOT(cv)->op_next = 0;
6747 CALL_PEEP(CvSTART(cv));
6749 op_getmad(o,pegop,'n');
6750 op_getmad_weak(block, pegop, 'b');
6755 PL_parser->copline = NOLINE;
6763 Perl_newANONLIST(pTHX_ OP *o)
6765 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6769 Perl_newANONHASH(pTHX_ OP *o)
6771 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6775 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6777 return newANONATTRSUB(floor, proto, NULL, block);
6781 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6783 return newUNOP(OP_REFGEN, 0,
6784 newSVOP(OP_ANONCODE, 0,
6785 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6789 Perl_oopsAV(pTHX_ OP *o)
6793 PERL_ARGS_ASSERT_OOPSAV;
6795 switch (o->op_type) {
6797 o->op_type = OP_PADAV;
6798 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6799 return ref(o, OP_RV2AV);
6802 o->op_type = OP_RV2AV;
6803 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6808 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6815 Perl_oopsHV(pTHX_ OP *o)
6819 PERL_ARGS_ASSERT_OOPSHV;
6821 switch (o->op_type) {
6824 o->op_type = OP_PADHV;
6825 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6826 return ref(o, OP_RV2HV);
6830 o->op_type = OP_RV2HV;
6831 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6836 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6843 Perl_newAVREF(pTHX_ OP *o)
6847 PERL_ARGS_ASSERT_NEWAVREF;
6849 if (o->op_type == OP_PADANY) {
6850 o->op_type = OP_PADAV;
6851 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6854 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6855 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6856 "Using an array as a reference is deprecated");
6858 return newUNOP(OP_RV2AV, 0, scalar(o));
6862 Perl_newGVREF(pTHX_ I32 type, OP *o)
6864 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6865 return newUNOP(OP_NULL, 0, o);
6866 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6870 Perl_newHVREF(pTHX_ OP *o)
6874 PERL_ARGS_ASSERT_NEWHVREF;
6876 if (o->op_type == OP_PADANY) {
6877 o->op_type = OP_PADHV;
6878 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6881 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6882 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6883 "Using a hash as a reference is deprecated");
6885 return newUNOP(OP_RV2HV, 0, scalar(o));
6889 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6891 return newUNOP(OP_RV2CV, flags, scalar(o));
6895 Perl_newSVREF(pTHX_ OP *o)
6899 PERL_ARGS_ASSERT_NEWSVREF;
6901 if (o->op_type == OP_PADANY) {
6902 o->op_type = OP_PADSV;
6903 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6906 return newUNOP(OP_RV2SV, 0, scalar(o));
6909 /* Check routines. See the comments at the top of this file for details
6910 * on when these are called */
6913 Perl_ck_anoncode(pTHX_ OP *o)
6915 PERL_ARGS_ASSERT_CK_ANONCODE;
6917 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6919 cSVOPo->op_sv = NULL;
6924 Perl_ck_bitop(pTHX_ OP *o)
6928 PERL_ARGS_ASSERT_CK_BITOP;
6930 #define OP_IS_NUMCOMPARE(op) \
6931 ((op) == OP_LT || (op) == OP_I_LT || \
6932 (op) == OP_GT || (op) == OP_I_GT || \
6933 (op) == OP_LE || (op) == OP_I_LE || \
6934 (op) == OP_GE || (op) == OP_I_GE || \
6935 (op) == OP_EQ || (op) == OP_I_EQ || \
6936 (op) == OP_NE || (op) == OP_I_NE || \
6937 (op) == OP_NCMP || (op) == OP_I_NCMP)
6938 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6939 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6940 && (o->op_type == OP_BIT_OR
6941 || o->op_type == OP_BIT_AND
6942 || o->op_type == OP_BIT_XOR))
6944 const OP * const left = cBINOPo->op_first;
6945 const OP * const right = left->op_sibling;
6946 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6947 (left->op_flags & OPf_PARENS) == 0) ||
6948 (OP_IS_NUMCOMPARE(right->op_type) &&
6949 (right->op_flags & OPf_PARENS) == 0))
6950 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6951 "Possible precedence problem on bitwise %c operator",
6952 o->op_type == OP_BIT_OR ? '|'
6953 : o->op_type == OP_BIT_AND ? '&' : '^'
6960 Perl_ck_concat(pTHX_ OP *o)
6962 const OP * const kid = cUNOPo->op_first;
6964 PERL_ARGS_ASSERT_CK_CONCAT;
6965 PERL_UNUSED_CONTEXT;
6967 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6968 !(kUNOP->op_first->op_flags & OPf_MOD))
6969 o->op_flags |= OPf_STACKED;
6974 Perl_ck_spair(pTHX_ OP *o)
6978 PERL_ARGS_ASSERT_CK_SPAIR;
6980 if (o->op_flags & OPf_KIDS) {
6983 const OPCODE type = o->op_type;
6984 o = modkids(ck_fun(o), type);
6985 kid = cUNOPo->op_first;
6986 newop = kUNOP->op_first->op_sibling;
6988 const OPCODE type = newop->op_type;
6989 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6990 type == OP_PADAV || type == OP_PADHV ||
6991 type == OP_RV2AV || type == OP_RV2HV)
6995 op_getmad(kUNOP->op_first,newop,'K');
6997 op_free(kUNOP->op_first);
6999 kUNOP->op_first = newop;
7001 o->op_ppaddr = PL_ppaddr[++o->op_type];
7006 Perl_ck_delete(pTHX_ OP *o)
7008 PERL_ARGS_ASSERT_CK_DELETE;
7012 if (o->op_flags & OPf_KIDS) {
7013 OP * const kid = cUNOPo->op_first;
7014 switch (kid->op_type) {
7016 o->op_flags |= OPf_SPECIAL;
7019 o->op_private |= OPpSLICE;
7022 o->op_flags |= OPf_SPECIAL;
7027 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7030 if (kid->op_private & OPpLVAL_INTRO)
7031 o->op_private |= OPpLVAL_INTRO;
7038 Perl_ck_die(pTHX_ OP *o)
7040 PERL_ARGS_ASSERT_CK_DIE;
7043 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7049 Perl_ck_eof(pTHX_ OP *o)
7053 PERL_ARGS_ASSERT_CK_EOF;
7055 if (o->op_flags & OPf_KIDS) {
7056 if (cLISTOPo->op_first->op_type == OP_STUB) {
7058 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7060 op_getmad(o,newop,'O');
7072 Perl_ck_eval(pTHX_ OP *o)
7076 PERL_ARGS_ASSERT_CK_EVAL;
7078 PL_hints |= HINT_BLOCK_SCOPE;
7079 if (o->op_flags & OPf_KIDS) {
7080 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7083 o->op_flags &= ~OPf_KIDS;
7086 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7092 cUNOPo->op_first = 0;
7097 NewOp(1101, enter, 1, LOGOP);
7098 enter->op_type = OP_ENTERTRY;
7099 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7100 enter->op_private = 0;
7102 /* establish postfix order */
7103 enter->op_next = (OP*)enter;
7105 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7106 o->op_type = OP_LEAVETRY;
7107 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7108 enter->op_other = o;
7109 op_getmad(oldo,o,'O');
7123 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7124 op_getmad(oldo,o,'O');
7126 o->op_targ = (PADOFFSET)PL_hints;
7127 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7128 /* Store a copy of %^H that pp_entereval can pick up. */
7129 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7130 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7131 cUNOPo->op_first->op_sibling = hhop;
7132 o->op_private |= OPpEVAL_HAS_HH;
7138 Perl_ck_exit(pTHX_ OP *o)
7140 PERL_ARGS_ASSERT_CK_EXIT;
7143 HV * const table = GvHV(PL_hintgv);
7145 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7146 if (svp && *svp && SvTRUE(*svp))
7147 o->op_private |= OPpEXIT_VMSISH;
7149 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7155 Perl_ck_exec(pTHX_ OP *o)
7157 PERL_ARGS_ASSERT_CK_EXEC;
7159 if (o->op_flags & OPf_STACKED) {
7162 kid = cUNOPo->op_first->op_sibling;
7163 if (kid->op_type == OP_RV2GV)
7172 Perl_ck_exists(pTHX_ OP *o)
7176 PERL_ARGS_ASSERT_CK_EXISTS;
7179 if (o->op_flags & OPf_KIDS) {
7180 OP * const kid = cUNOPo->op_first;
7181 if (kid->op_type == OP_ENTERSUB) {
7182 (void) ref(kid, o->op_type);
7183 if (kid->op_type != OP_RV2CV
7184 && !(PL_parser && PL_parser->error_count))
7185 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7187 o->op_private |= OPpEXISTS_SUB;
7189 else if (kid->op_type == OP_AELEM)
7190 o->op_flags |= OPf_SPECIAL;
7191 else if (kid->op_type != OP_HELEM)
7192 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7200 Perl_ck_rvconst(pTHX_ register OP *o)
7203 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7205 PERL_ARGS_ASSERT_CK_RVCONST;
7207 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7208 if (o->op_type == OP_RV2CV)
7209 o->op_private &= ~1;
7211 if (kid->op_type == OP_CONST) {
7214 SV * const kidsv = kid->op_sv;
7216 /* Is it a constant from cv_const_sv()? */
7217 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7218 SV * const rsv = SvRV(kidsv);
7219 const svtype type = SvTYPE(rsv);
7220 const char *badtype = NULL;
7222 switch (o->op_type) {
7224 if (type > SVt_PVMG)
7225 badtype = "a SCALAR";
7228 if (type != SVt_PVAV)
7229 badtype = "an ARRAY";
7232 if (type != SVt_PVHV)
7236 if (type != SVt_PVCV)
7241 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7244 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7245 const char *badthing;
7246 switch (o->op_type) {
7248 badthing = "a SCALAR";
7251 badthing = "an ARRAY";
7254 badthing = "a HASH";
7262 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7263 SVfARG(kidsv), badthing);
7266 * This is a little tricky. We only want to add the symbol if we
7267 * didn't add it in the lexer. Otherwise we get duplicate strict
7268 * warnings. But if we didn't add it in the lexer, we must at
7269 * least pretend like we wanted to add it even if it existed before,
7270 * or we get possible typo warnings. OPpCONST_ENTERED says
7271 * whether the lexer already added THIS instance of this symbol.
7273 iscv = (o->op_type == OP_RV2CV) * 2;
7275 gv = gv_fetchsv(kidsv,
7276 iscv | !(kid->op_private & OPpCONST_ENTERED),
7279 : o->op_type == OP_RV2SV
7281 : o->op_type == OP_RV2AV
7283 : o->op_type == OP_RV2HV
7286 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7288 kid->op_type = OP_GV;
7289 SvREFCNT_dec(kid->op_sv);
7291 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7292 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7293 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7295 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7297 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7299 kid->op_private = 0;
7300 kid->op_ppaddr = PL_ppaddr[OP_GV];
7301 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7309 Perl_ck_ftst(pTHX_ OP *o)
7312 const I32 type = o->op_type;
7314 PERL_ARGS_ASSERT_CK_FTST;
7316 if (o->op_flags & OPf_REF) {
7319 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7320 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7321 const OPCODE kidtype = kid->op_type;
7323 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7324 OP * const newop = newGVOP(type, OPf_REF,
7325 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7327 op_getmad(o,newop,'O');
7333 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7334 o->op_private |= OPpFT_ACCESS;
7335 if (PL_check[kidtype] == Perl_ck_ftst
7336 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7337 o->op_private |= OPpFT_STACKED;
7345 if (type == OP_FTTTY)
7346 o = newGVOP(type, OPf_REF, PL_stdingv);
7348 o = newUNOP(type, 0, newDEFSVOP());
7349 op_getmad(oldo,o,'O');
7355 Perl_ck_fun(pTHX_ OP *o)
7358 const int type = o->op_type;
7359 register I32 oa = PL_opargs[type] >> OASHIFT;
7361 PERL_ARGS_ASSERT_CK_FUN;
7363 if (o->op_flags & OPf_STACKED) {
7364 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7367 return no_fh_allowed(o);
7370 if (o->op_flags & OPf_KIDS) {
7371 OP **tokid = &cLISTOPo->op_first;
7372 register OP *kid = cLISTOPo->op_first;
7376 if (kid->op_type == OP_PUSHMARK ||
7377 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7379 tokid = &kid->op_sibling;
7380 kid = kid->op_sibling;
7382 if (!kid && PL_opargs[type] & OA_DEFGV)
7383 *tokid = kid = newDEFSVOP();
7387 sibl = kid->op_sibling;
7389 if (!sibl && kid->op_type == OP_STUB) {
7396 /* list seen where single (scalar) arg expected? */
7397 if (numargs == 1 && !(oa >> 4)
7398 && kid->op_type == OP_LIST && type != OP_SCALAR)
7400 return too_many_arguments(o,PL_op_desc[type]);
7413 if ((type == OP_PUSH || type == OP_UNSHIFT)
7414 && !kid->op_sibling)
7415 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7416 "Useless use of %s with no values",
7419 if (kid->op_type == OP_CONST &&
7420 (kid->op_private & OPpCONST_BARE))
7422 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7423 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7424 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7425 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7426 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7428 op_getmad(kid,newop,'K');
7433 kid->op_sibling = sibl;
7436 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
7437 bad_type(numargs, "array", PL_op_desc[type], kid);
7438 op_lvalue(kid, type);
7441 if (kid->op_type == OP_CONST &&
7442 (kid->op_private & OPpCONST_BARE))
7444 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7445 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7446 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7447 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7448 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7450 op_getmad(kid,newop,'K');
7455 kid->op_sibling = sibl;
7458 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7459 bad_type(numargs, "hash", PL_op_desc[type], kid);
7460 op_lvalue(kid, type);
7464 OP * const newop = newUNOP(OP_NULL, 0, kid);
7465 kid->op_sibling = 0;
7467 newop->op_next = newop;
7469 kid->op_sibling = sibl;
7474 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7475 if (kid->op_type == OP_CONST &&
7476 (kid->op_private & OPpCONST_BARE))
7478 OP * const newop = newGVOP(OP_GV, 0,
7479 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7480 if (!(o->op_private & 1) && /* if not unop */
7481 kid == cLISTOPo->op_last)
7482 cLISTOPo->op_last = newop;
7484 op_getmad(kid,newop,'K');
7490 else if (kid->op_type == OP_READLINE) {
7491 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7492 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7495 I32 flags = OPf_SPECIAL;
7499 /* is this op a FH constructor? */
7500 if (is_handle_constructor(o,numargs)) {
7501 const char *name = NULL;
7505 /* Set a flag to tell rv2gv to vivify
7506 * need to "prove" flag does not mean something
7507 * else already - NI-S 1999/05/07
7510 if (kid->op_type == OP_PADSV) {
7512 = PAD_COMPNAME_SV(kid->op_targ);
7513 name = SvPV_const(namesv, len);
7515 else if (kid->op_type == OP_RV2SV
7516 && kUNOP->op_first->op_type == OP_GV)
7518 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7520 len = GvNAMELEN(gv);
7522 else if (kid->op_type == OP_AELEM
7523 || kid->op_type == OP_HELEM)
7526 OP *op = ((BINOP*)kid)->op_first;
7530 const char * const a =
7531 kid->op_type == OP_AELEM ?
7533 if (((op->op_type == OP_RV2AV) ||
7534 (op->op_type == OP_RV2HV)) &&
7535 (firstop = ((UNOP*)op)->op_first) &&
7536 (firstop->op_type == OP_GV)) {
7537 /* packagevar $a[] or $h{} */
7538 GV * const gv = cGVOPx_gv(firstop);
7546 else if (op->op_type == OP_PADAV
7547 || op->op_type == OP_PADHV) {
7548 /* lexicalvar $a[] or $h{} */
7549 const char * const padname =
7550 PAD_COMPNAME_PV(op->op_targ);
7559 name = SvPV_const(tmpstr, len);
7564 name = "__ANONIO__";
7567 op_lvalue(kid, type);
7571 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7572 namesv = PAD_SVl(targ);
7573 SvUPGRADE(namesv, SVt_PV);
7575 sv_setpvs(namesv, "$");
7576 sv_catpvn(namesv, name, len);
7579 kid->op_sibling = 0;
7580 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7581 kid->op_targ = targ;
7582 kid->op_private |= priv;
7584 kid->op_sibling = sibl;
7590 op_lvalue(scalar(kid), type);
7594 tokid = &kid->op_sibling;
7595 kid = kid->op_sibling;
7598 if (kid && kid->op_type != OP_STUB)
7599 return too_many_arguments(o,OP_DESC(o));
7600 o->op_private |= numargs;
7602 /* FIXME - should the numargs move as for the PERL_MAD case? */
7603 o->op_private |= numargs;
7605 return too_many_arguments(o,OP_DESC(o));
7609 else if (PL_opargs[type] & OA_DEFGV) {
7611 OP *newop = newUNOP(type, 0, newDEFSVOP());
7612 op_getmad(o,newop,'O');
7615 /* Ordering of these two is important to keep f_map.t passing. */
7617 return newUNOP(type, 0, newDEFSVOP());
7622 while (oa & OA_OPTIONAL)
7624 if (oa && oa != OA_LIST)
7625 return too_few_arguments(o,OP_DESC(o));
7631 Perl_ck_glob(pTHX_ OP *o)
7636 PERL_ARGS_ASSERT_CK_GLOB;
7639 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7640 op_append_elem(OP_GLOB, o, newDEFSVOP());
7642 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7643 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7645 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7648 #if !defined(PERL_EXTERNAL_GLOB)
7649 /* XXX this can be tightened up and made more failsafe. */
7650 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7653 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7654 newSVpvs("File::Glob"), NULL, NULL, NULL);
7655 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7656 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7657 GvCV(gv) = GvCV(glob_gv);
7658 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7659 GvIMPORTED_CV_on(gv);
7663 #endif /* PERL_EXTERNAL_GLOB */
7665 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7666 op_append_elem(OP_GLOB, o,
7667 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7668 o->op_type = OP_LIST;
7669 o->op_ppaddr = PL_ppaddr[OP_LIST];
7670 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7671 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7672 cLISTOPo->op_first->op_targ = 0;
7673 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7674 op_append_elem(OP_LIST, o,
7675 scalar(newUNOP(OP_RV2CV, 0,
7676 newGVOP(OP_GV, 0, gv)))));
7677 o = newUNOP(OP_NULL, 0, ck_subr(o));
7678 o->op_targ = OP_GLOB; /* hint at what it used to be */
7681 gv = newGVgen("main");
7683 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7689 Perl_ck_grep(pTHX_ OP *o)
7694 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7697 PERL_ARGS_ASSERT_CK_GREP;
7699 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7700 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7702 if (o->op_flags & OPf_STACKED) {
7705 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7706 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7707 return no_fh_allowed(o);
7708 for (k = kid; k; k = k->op_next) {
7711 NewOp(1101, gwop, 1, LOGOP);
7712 kid->op_next = (OP*)gwop;
7713 o->op_flags &= ~OPf_STACKED;
7715 kid = cLISTOPo->op_first->op_sibling;
7716 if (type == OP_MAPWHILE)
7721 if (PL_parser && PL_parser->error_count)
7723 kid = cLISTOPo->op_first->op_sibling;
7724 if (kid->op_type != OP_NULL)
7725 Perl_croak(aTHX_ "panic: ck_grep");
7726 kid = kUNOP->op_first;
7729 NewOp(1101, gwop, 1, LOGOP);
7730 gwop->op_type = type;
7731 gwop->op_ppaddr = PL_ppaddr[type];
7732 gwop->op_first = listkids(o);
7733 gwop->op_flags |= OPf_KIDS;
7734 gwop->op_other = LINKLIST(kid);
7735 kid->op_next = (OP*)gwop;
7736 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7737 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7738 o->op_private = gwop->op_private = 0;
7739 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7742 o->op_private = gwop->op_private = OPpGREP_LEX;
7743 gwop->op_targ = o->op_targ = offset;
7746 kid = cLISTOPo->op_first->op_sibling;
7747 if (!kid || !kid->op_sibling)
7748 return too_few_arguments(o,OP_DESC(o));
7749 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7750 op_lvalue(kid, OP_GREPSTART);
7756 Perl_ck_index(pTHX_ OP *o)
7758 PERL_ARGS_ASSERT_CK_INDEX;
7760 if (o->op_flags & OPf_KIDS) {
7761 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7763 kid = kid->op_sibling; /* get past "big" */
7764 if (kid && kid->op_type == OP_CONST)
7765 fbm_compile(((SVOP*)kid)->op_sv, 0);
7771 Perl_ck_lfun(pTHX_ OP *o)
7773 const OPCODE type = o->op_type;
7775 PERL_ARGS_ASSERT_CK_LFUN;
7777 return modkids(ck_fun(o), type);
7781 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7783 PERL_ARGS_ASSERT_CK_DEFINED;
7785 if ((o->op_flags & OPf_KIDS)) {
7786 switch (cUNOPo->op_first->op_type) {
7788 /* This is needed for
7789 if (defined %stash::)
7790 to work. Do not break Tk.
7792 break; /* Globals via GV can be undef */
7794 case OP_AASSIGN: /* Is this a good idea? */
7795 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7796 "defined(@array) is deprecated");
7797 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7798 "\t(Maybe you should just omit the defined()?)\n");
7802 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7803 "defined(%%hash) is deprecated");
7804 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7805 "\t(Maybe you should just omit the defined()?)\n");
7816 Perl_ck_readline(pTHX_ OP *o)
7818 PERL_ARGS_ASSERT_CK_READLINE;
7820 if (!(o->op_flags & OPf_KIDS)) {
7822 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7824 op_getmad(o,newop,'O');
7834 Perl_ck_rfun(pTHX_ OP *o)
7836 const OPCODE type = o->op_type;
7838 PERL_ARGS_ASSERT_CK_RFUN;
7840 return refkids(ck_fun(o), type);
7844 Perl_ck_listiob(pTHX_ OP *o)
7848 PERL_ARGS_ASSERT_CK_LISTIOB;
7850 kid = cLISTOPo->op_first;
7853 kid = cLISTOPo->op_first;
7855 if (kid->op_type == OP_PUSHMARK)
7856 kid = kid->op_sibling;
7857 if (kid && o->op_flags & OPf_STACKED)
7858 kid = kid->op_sibling;
7859 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7860 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7861 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7862 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7863 cLISTOPo->op_first->op_sibling = kid;
7864 cLISTOPo->op_last = kid;
7865 kid = kid->op_sibling;
7870 op_append_elem(o->op_type, o, newDEFSVOP());
7876 Perl_ck_smartmatch(pTHX_ OP *o)
7879 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7880 if (0 == (o->op_flags & OPf_SPECIAL)) {
7881 OP *first = cBINOPo->op_first;
7882 OP *second = first->op_sibling;
7884 /* Implicitly take a reference to an array or hash */
7885 first->op_sibling = NULL;
7886 first = cBINOPo->op_first = ref_array_or_hash(first);
7887 second = first->op_sibling = ref_array_or_hash(second);
7889 /* Implicitly take a reference to a regular expression */
7890 if (first->op_type == OP_MATCH) {
7891 first->op_type = OP_QR;
7892 first->op_ppaddr = PL_ppaddr[OP_QR];
7894 if (second->op_type == OP_MATCH) {
7895 second->op_type = OP_QR;
7896 second->op_ppaddr = PL_ppaddr[OP_QR];
7905 Perl_ck_sassign(pTHX_ OP *o)
7908 OP * const kid = cLISTOPo->op_first;
7910 PERL_ARGS_ASSERT_CK_SASSIGN;
7912 /* has a disposable target? */
7913 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7914 && !(kid->op_flags & OPf_STACKED)
7915 /* Cannot steal the second time! */
7916 && !(kid->op_private & OPpTARGET_MY)
7917 /* Keep the full thing for madskills */
7921 OP * const kkid = kid->op_sibling;
7923 /* Can just relocate the target. */
7924 if (kkid && kkid->op_type == OP_PADSV
7925 && !(kkid->op_private & OPpLVAL_INTRO))
7927 kid->op_targ = kkid->op_targ;
7929 /* Now we do not need PADSV and SASSIGN. */
7930 kid->op_sibling = o->op_sibling; /* NULL */
7931 cLISTOPo->op_first = NULL;
7934 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7938 if (kid->op_sibling) {
7939 OP *kkid = kid->op_sibling;
7940 if (kkid->op_type == OP_PADSV
7941 && (kkid->op_private & OPpLVAL_INTRO)
7942 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7943 const PADOFFSET target = kkid->op_targ;
7944 OP *const other = newOP(OP_PADSV,
7946 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7947 OP *const first = newOP(OP_NULL, 0);
7948 OP *const nullop = newCONDOP(0, first, o, other);
7949 OP *const condop = first->op_next;
7950 /* hijacking PADSTALE for uninitialized state variables */
7951 SvPADSTALE_on(PAD_SVl(target));
7953 condop->op_type = OP_ONCE;
7954 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7955 condop->op_targ = target;
7956 other->op_targ = target;
7958 /* Because we change the type of the op here, we will skip the
7959 assinment binop->op_last = binop->op_first->op_sibling; at the
7960 end of Perl_newBINOP(). So need to do it here. */
7961 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7970 Perl_ck_match(pTHX_ OP *o)
7974 PERL_ARGS_ASSERT_CK_MATCH;
7976 if (o->op_type != OP_QR && PL_compcv) {
7977 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7978 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7979 o->op_targ = offset;
7980 o->op_private |= OPpTARGET_MY;
7983 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7984 o->op_private |= OPpRUNTIME;
7989 Perl_ck_method(pTHX_ OP *o)
7991 OP * const kid = cUNOPo->op_first;
7993 PERL_ARGS_ASSERT_CK_METHOD;
7995 if (kid->op_type == OP_CONST) {
7996 SV* sv = kSVOP->op_sv;
7997 const char * const method = SvPVX_const(sv);
7998 if (!(strchr(method, ':') || strchr(method, '\''))) {
8000 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8001 sv = newSVpvn_share(method, SvCUR(sv), 0);
8004 kSVOP->op_sv = NULL;
8006 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8008 op_getmad(o,cmop,'O');
8019 Perl_ck_null(pTHX_ OP *o)
8021 PERL_ARGS_ASSERT_CK_NULL;
8022 PERL_UNUSED_CONTEXT;
8027 Perl_ck_open(pTHX_ OP *o)
8030 HV * const table = GvHV(PL_hintgv);
8032 PERL_ARGS_ASSERT_CK_OPEN;
8035 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8038 const char *d = SvPV_const(*svp, len);
8039 const I32 mode = mode_from_discipline(d, len);
8040 if (mode & O_BINARY)
8041 o->op_private |= OPpOPEN_IN_RAW;
8042 else if (mode & O_TEXT)
8043 o->op_private |= OPpOPEN_IN_CRLF;
8046 svp = hv_fetchs(table, "open_OUT", FALSE);
8049 const char *d = SvPV_const(*svp, len);
8050 const I32 mode = mode_from_discipline(d, len);
8051 if (mode & O_BINARY)
8052 o->op_private |= OPpOPEN_OUT_RAW;
8053 else if (mode & O_TEXT)
8054 o->op_private |= OPpOPEN_OUT_CRLF;
8057 if (o->op_type == OP_BACKTICK) {
8058 if (!(o->op_flags & OPf_KIDS)) {
8059 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8061 op_getmad(o,newop,'O');
8070 /* In case of three-arg dup open remove strictness
8071 * from the last arg if it is a bareword. */
8072 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8073 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8077 if ((last->op_type == OP_CONST) && /* The bareword. */
8078 (last->op_private & OPpCONST_BARE) &&
8079 (last->op_private & OPpCONST_STRICT) &&
8080 (oa = first->op_sibling) && /* The fh. */
8081 (oa = oa->op_sibling) && /* The mode. */
8082 (oa->op_type == OP_CONST) &&
8083 SvPOK(((SVOP*)oa)->op_sv) &&
8084 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8085 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8086 (last == oa->op_sibling)) /* The bareword. */
8087 last->op_private &= ~OPpCONST_STRICT;
8093 Perl_ck_repeat(pTHX_ OP *o)
8095 PERL_ARGS_ASSERT_CK_REPEAT;
8097 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8098 o->op_private |= OPpREPEAT_DOLIST;
8099 cBINOPo->op_first = force_list(cBINOPo->op_first);
8107 Perl_ck_require(pTHX_ OP *o)
8112 PERL_ARGS_ASSERT_CK_REQUIRE;
8114 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8115 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8117 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8118 SV * const sv = kid->op_sv;
8119 U32 was_readonly = SvREADONLY(sv);
8126 sv_force_normal_flags(sv, 0);
8127 assert(!SvREADONLY(sv));
8137 for (; s < end; s++) {
8138 if (*s == ':' && s[1] == ':') {
8140 Move(s+2, s+1, end - s - 1, char);
8145 sv_catpvs(sv, ".pm");
8146 SvFLAGS(sv) |= was_readonly;
8150 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8151 /* handle override, if any */
8152 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8153 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8154 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8155 gv = gvp ? *gvp : NULL;
8159 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8160 OP * const kid = cUNOPo->op_first;
8163 cUNOPo->op_first = 0;
8167 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8168 op_append_elem(OP_LIST, kid,
8169 scalar(newUNOP(OP_RV2CV, 0,
8172 op_getmad(o,newop,'O');
8176 return scalar(ck_fun(o));
8180 Perl_ck_return(pTHX_ OP *o)
8185 PERL_ARGS_ASSERT_CK_RETURN;
8187 kid = cLISTOPo->op_first->op_sibling;
8188 if (CvLVALUE(PL_compcv)) {
8189 for (; kid; kid = kid->op_sibling)
8190 op_lvalue(kid, OP_LEAVESUBLV);
8192 for (; kid; kid = kid->op_sibling)
8193 if ((kid->op_type == OP_NULL)
8194 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8195 /* This is a do block */
8196 OP *op = kUNOP->op_first;
8197 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8198 op = cUNOPx(op)->op_first;
8199 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8200 /* Force the use of the caller's context */
8201 op->op_flags |= OPf_SPECIAL;
8210 Perl_ck_select(pTHX_ OP *o)
8215 PERL_ARGS_ASSERT_CK_SELECT;
8217 if (o->op_flags & OPf_KIDS) {
8218 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8219 if (kid && kid->op_sibling) {
8220 o->op_type = OP_SSELECT;
8221 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8223 return fold_constants(o);
8227 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8228 if (kid && kid->op_type == OP_RV2GV)
8229 kid->op_private &= ~HINT_STRICT_REFS;
8234 Perl_ck_shift(pTHX_ OP *o)
8237 const I32 type = o->op_type;
8239 PERL_ARGS_ASSERT_CK_SHIFT;
8241 if (!(o->op_flags & OPf_KIDS)) {
8244 if (!CvUNIQUE(PL_compcv)) {
8245 o->op_flags |= OPf_SPECIAL;
8249 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8252 OP * const oldo = o;
8253 o = newUNOP(type, 0, scalar(argop));
8254 op_getmad(oldo,o,'O');
8259 return newUNOP(type, 0, scalar(argop));
8262 return scalar(modkids(ck_fun(o), type));
8266 Perl_ck_sort(pTHX_ OP *o)
8271 PERL_ARGS_ASSERT_CK_SORT;
8273 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8274 HV * const hinthv = GvHV(PL_hintgv);
8276 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8278 const I32 sorthints = (I32)SvIV(*svp);
8279 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8280 o->op_private |= OPpSORT_QSORT;
8281 if ((sorthints & HINT_SORT_STABLE) != 0)
8282 o->op_private |= OPpSORT_STABLE;
8287 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8289 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8290 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8292 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8294 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8296 if (kid->op_type == OP_SCOPE) {
8300 else if (kid->op_type == OP_LEAVE) {
8301 if (o->op_type == OP_SORT) {
8302 op_null(kid); /* wipe out leave */
8305 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8306 if (k->op_next == kid)
8308 /* don't descend into loops */
8309 else if (k->op_type == OP_ENTERLOOP
8310 || k->op_type == OP_ENTERITER)
8312 k = cLOOPx(k)->op_lastop;
8317 kid->op_next = 0; /* just disconnect the leave */
8318 k = kLISTOP->op_first;
8323 if (o->op_type == OP_SORT) {
8324 /* provide scalar context for comparison function/block */
8330 o->op_flags |= OPf_SPECIAL;
8332 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8335 firstkid = firstkid->op_sibling;
8338 /* provide list context for arguments */
8339 if (o->op_type == OP_SORT)
8346 S_simplify_sort(pTHX_ OP *o)
8349 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8355 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8357 if (!(o->op_flags & OPf_STACKED))
8359 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8360 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8361 kid = kUNOP->op_first; /* get past null */
8362 if (kid->op_type != OP_SCOPE)
8364 kid = kLISTOP->op_last; /* get past scope */
8365 switch(kid->op_type) {
8373 k = kid; /* remember this node*/
8374 if (kBINOP->op_first->op_type != OP_RV2SV)
8376 kid = kBINOP->op_first; /* get past cmp */
8377 if (kUNOP->op_first->op_type != OP_GV)
8379 kid = kUNOP->op_first; /* get past rv2sv */
8381 if (GvSTASH(gv) != PL_curstash)
8383 gvname = GvNAME(gv);
8384 if (*gvname == 'a' && gvname[1] == '\0')
8386 else if (*gvname == 'b' && gvname[1] == '\0')
8391 kid = k; /* back to cmp */
8392 if (kBINOP->op_last->op_type != OP_RV2SV)
8394 kid = kBINOP->op_last; /* down to 2nd arg */
8395 if (kUNOP->op_first->op_type != OP_GV)
8397 kid = kUNOP->op_first; /* get past rv2sv */
8399 if (GvSTASH(gv) != PL_curstash)
8401 gvname = GvNAME(gv);
8403 ? !(*gvname == 'a' && gvname[1] == '\0')
8404 : !(*gvname == 'b' && gvname[1] == '\0'))
8406 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8408 o->op_private |= OPpSORT_DESCEND;
8409 if (k->op_type == OP_NCMP)
8410 o->op_private |= OPpSORT_NUMERIC;
8411 if (k->op_type == OP_I_NCMP)
8412 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8413 kid = cLISTOPo->op_first->op_sibling;
8414 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8416 op_getmad(kid,o,'S'); /* then delete it */
8418 op_free(kid); /* then delete it */
8423 Perl_ck_split(pTHX_ OP *o)
8428 PERL_ARGS_ASSERT_CK_SPLIT;
8430 if (o->op_flags & OPf_STACKED)
8431 return no_fh_allowed(o);
8433 kid = cLISTOPo->op_first;
8434 if (kid->op_type != OP_NULL)
8435 Perl_croak(aTHX_ "panic: ck_split");
8436 kid = kid->op_sibling;
8437 op_free(cLISTOPo->op_first);
8438 cLISTOPo->op_first = kid;
8440 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8441 cLISTOPo->op_last = kid; /* There was only one element previously */
8444 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8445 OP * const sibl = kid->op_sibling;
8446 kid->op_sibling = 0;
8447 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8448 if (cLISTOPo->op_first == cLISTOPo->op_last)
8449 cLISTOPo->op_last = kid;
8450 cLISTOPo->op_first = kid;
8451 kid->op_sibling = sibl;
8454 kid->op_type = OP_PUSHRE;
8455 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8457 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8458 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8459 "Use of /g modifier is meaningless in split");
8462 if (!kid->op_sibling)
8463 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8465 kid = kid->op_sibling;
8468 if (!kid->op_sibling)
8469 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8470 assert(kid->op_sibling);
8472 kid = kid->op_sibling;
8475 if (kid->op_sibling)
8476 return too_many_arguments(o,OP_DESC(o));
8482 Perl_ck_join(pTHX_ OP *o)
8484 const OP * const kid = cLISTOPo->op_first->op_sibling;
8486 PERL_ARGS_ASSERT_CK_JOIN;
8488 if (kid && kid->op_type == OP_MATCH) {
8489 if (ckWARN(WARN_SYNTAX)) {
8490 const REGEXP *re = PM_GETRE(kPMOP);
8491 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8492 const STRLEN len = re ? RX_PRELEN(re) : 6;
8493 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8494 "/%.*s/ should probably be written as \"%.*s\"",
8495 (int)len, pmstr, (int)len, pmstr);
8502 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8504 Examines an op, which is expected to identify a subroutine at runtime,
8505 and attempts to determine at compile time which subroutine it identifies.
8506 This is normally used during Perl compilation to determine whether
8507 a prototype can be applied to a function call. I<cvop> is the op
8508 being considered, normally an C<rv2cv> op. A pointer to the identified
8509 subroutine is returned, if it could be determined statically, and a null
8510 pointer is returned if it was not possible to determine statically.
8512 Currently, the subroutine can be identified statically if the RV that the
8513 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8514 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8515 suitable if the constant value must be an RV pointing to a CV. Details of
8516 this process may change in future versions of Perl. If the C<rv2cv> op
8517 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8518 the subroutine statically: this flag is used to suppress compile-time
8519 magic on a subroutine call, forcing it to use default runtime behaviour.
8521 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8522 of a GV reference is modified. If a GV was examined and its CV slot was
8523 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8524 If the op is not optimised away, and the CV slot is later populated with
8525 a subroutine having a prototype, that flag eventually triggers the warning
8526 "called too early to check prototype".
8528 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8529 of returning a pointer to the subroutine it returns a pointer to the
8530 GV giving the most appropriate name for the subroutine in this context.
8531 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8532 (C<CvANON>) subroutine that is referenced through a GV it will be the
8533 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8534 A null pointer is returned as usual if there is no statically-determinable
8541 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8546 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8547 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8548 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8549 if (cvop->op_type != OP_RV2CV)
8551 if (cvop->op_private & OPpENTERSUB_AMPER)
8553 if (!(cvop->op_flags & OPf_KIDS))
8555 rvop = cUNOPx(cvop)->op_first;
8556 switch (rvop->op_type) {
8558 gv = cGVOPx_gv(rvop);
8561 if (flags & RV2CVOPCV_MARK_EARLY)
8562 rvop->op_private |= OPpEARLY_CV;
8567 SV *rv = cSVOPx_sv(rvop);
8577 if (SvTYPE((SV*)cv) != SVt_PVCV)
8579 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8580 if (!CvANON(cv) || !gv)
8589 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8591 Performs the default fixup of the arguments part of an C<entersub>
8592 op tree. This consists of applying list context to each of the
8593 argument ops. This is the standard treatment used on a call marked
8594 with C<&>, or a method call, or a call through a subroutine reference,
8595 or any other call where the callee can't be identified at compile time,
8596 or a call where the callee has no prototype.
8602 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8605 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8606 aop = cUNOPx(entersubop)->op_first;
8607 if (!aop->op_sibling)
8608 aop = cUNOPx(aop)->op_first;
8609 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8610 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8612 op_lvalue(aop, OP_ENTERSUB);
8619 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8621 Performs the fixup of the arguments part of an C<entersub> op tree
8622 based on a subroutine prototype. This makes various modifications to
8623 the argument ops, from applying context up to inserting C<refgen> ops,
8624 and checking the number and syntactic types of arguments, as directed by
8625 the prototype. This is the standard treatment used on a subroutine call,
8626 not marked with C<&>, where the callee can be identified at compile time
8627 and has a prototype.
8629 I<protosv> supplies the subroutine prototype to be applied to the call.
8630 It may be a normal defined scalar, of which the string value will be used.
8631 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8632 that has been cast to C<SV*>) which has a prototype. The prototype
8633 supplied, in whichever form, does not need to match the actual callee
8634 referenced by the op tree.
8636 If the argument ops disagree with the prototype, for example by having
8637 an unacceptable number of arguments, a valid op tree is returned anyway.
8638 The error is reflected in the parser state, normally resulting in a single
8639 exception at the top level of parsing which covers all the compilation
8640 errors that occurred. In the error message, the callee is referred to
8641 by the name defined by the I<namegv> parameter.
8647 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8650 const char *proto, *proto_end;
8651 OP *aop, *prev, *cvop;
8654 I32 contextclass = 0;
8655 const char *e = NULL;
8656 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8657 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8658 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8659 proto = SvPV(protosv, proto_len);
8660 proto_end = proto + proto_len;
8661 aop = cUNOPx(entersubop)->op_first;
8662 if (!aop->op_sibling)
8663 aop = cUNOPx(aop)->op_first;
8665 aop = aop->op_sibling;
8666 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8667 while (aop != cvop) {
8669 if (PL_madskills && aop->op_type == OP_STUB) {
8670 aop = aop->op_sibling;
8673 if (PL_madskills && aop->op_type == OP_NULL)
8674 o3 = ((UNOP*)aop)->op_first;
8678 if (proto >= proto_end)
8679 return too_many_arguments(entersubop, gv_ename(namegv));
8687 /* _ must be at the end */
8688 if (proto[1] && proto[1] != ';')
8703 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8705 arg == 1 ? "block or sub {}" : "sub {}",
8706 gv_ename(namegv), o3);
8709 /* '*' allows any scalar type, including bareword */
8712 if (o3->op_type == OP_RV2GV)
8713 goto wrapref; /* autoconvert GLOB -> GLOBref */
8714 else if (o3->op_type == OP_CONST)
8715 o3->op_private &= ~OPpCONST_STRICT;
8716 else if (o3->op_type == OP_ENTERSUB) {
8717 /* accidental subroutine, revert to bareword */
8718 OP *gvop = ((UNOP*)o3)->op_first;
8719 if (gvop && gvop->op_type == OP_NULL) {
8720 gvop = ((UNOP*)gvop)->op_first;
8722 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8725 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8726 (gvop = ((UNOP*)gvop)->op_first) &&
8727 gvop->op_type == OP_GV)
8729 GV * const gv = cGVOPx_gv(gvop);
8730 OP * const sibling = aop->op_sibling;
8731 SV * const n = newSVpvs("");
8733 OP * const oldaop = aop;
8737 gv_fullname4(n, gv, "", FALSE);
8738 aop = newSVOP(OP_CONST, 0, n);
8739 op_getmad(oldaop,aop,'O');
8740 prev->op_sibling = aop;
8741 aop->op_sibling = sibling;
8751 if (o3->op_type == OP_RV2AV ||
8752 o3->op_type == OP_PADAV ||
8753 o3->op_type == OP_RV2HV ||
8754 o3->op_type == OP_PADHV
8769 if (contextclass++ == 0) {
8770 e = strchr(proto, ']');
8771 if (!e || e == proto)
8780 const char *p = proto;
8781 const char *const end = proto;
8783 while (*--p != '[') {}
8784 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8786 gv_ename(namegv), o3);
8791 if (o3->op_type == OP_RV2GV)
8794 bad_type(arg, "symbol", gv_ename(namegv), o3);
8797 if (o3->op_type == OP_ENTERSUB)
8800 bad_type(arg, "subroutine entry", gv_ename(namegv),
8804 if (o3->op_type == OP_RV2SV ||
8805 o3->op_type == OP_PADSV ||
8806 o3->op_type == OP_HELEM ||
8807 o3->op_type == OP_AELEM)
8810 bad_type(arg, "scalar", gv_ename(namegv), o3);
8813 if (o3->op_type == OP_RV2AV ||
8814 o3->op_type == OP_PADAV)
8817 bad_type(arg, "array", gv_ename(namegv), o3);
8820 if (o3->op_type == OP_RV2HV ||
8821 o3->op_type == OP_PADHV)
8824 bad_type(arg, "hash", gv_ename(namegv), o3);
8828 OP* const kid = aop;
8829 OP* const sib = kid->op_sibling;
8830 kid->op_sibling = 0;
8831 aop = newUNOP(OP_REFGEN, 0, kid);
8832 aop->op_sibling = sib;
8833 prev->op_sibling = aop;
8835 if (contextclass && e) {
8850 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8851 gv_ename(namegv), SVfARG(protosv));
8854 op_lvalue(aop, OP_ENTERSUB);
8856 aop = aop->op_sibling;
8858 if (aop == cvop && *proto == '_') {
8859 /* generate an access to $_ */
8861 aop->op_sibling = prev->op_sibling;
8862 prev->op_sibling = aop; /* instead of cvop */
8864 if (!optional && proto_end > proto &&
8865 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8866 return too_few_arguments(entersubop, gv_ename(namegv));
8871 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8873 Performs the fixup of the arguments part of an C<entersub> op tree either
8874 based on a subroutine prototype or using default list-context processing.
8875 This is the standard treatment used on a subroutine call, not marked
8876 with C<&>, where the callee can be identified at compile time.
8878 I<protosv> supplies the subroutine prototype to be applied to the call,
8879 or indicates that there is no prototype. It may be a normal scalar,
8880 in which case if it is defined then the string value will be used
8881 as a prototype, and if it is undefined then there is no prototype.
8882 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8883 that has been cast to C<SV*>), of which the prototype will be used if it
8884 has one. The prototype (or lack thereof) supplied, in whichever form,
8885 does not need to match the actual callee referenced by the op tree.
8887 If the argument ops disagree with the prototype, for example by having
8888 an unacceptable number of arguments, a valid op tree is returned anyway.
8889 The error is reflected in the parser state, normally resulting in a single
8890 exception at the top level of parsing which covers all the compilation
8891 errors that occurred. In the error message, the callee is referred to
8892 by the name defined by the I<namegv> parameter.
8898 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8899 GV *namegv, SV *protosv)
8901 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8902 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8903 return ck_entersub_args_proto(entersubop, namegv, protosv);
8905 return ck_entersub_args_list(entersubop);
8909 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8911 Retrieves the function that will be used to fix up a call to I<cv>.
8912 Specifically, the function is applied to an C<entersub> op tree for a
8913 subroutine call, not marked with C<&>, where the callee can be identified
8914 at compile time as I<cv>.
8916 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8917 argument for it is returned in I<*ckobj_p>. The function is intended
8918 to be called in this manner:
8920 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8922 In this call, I<entersubop> is a pointer to the C<entersub> op,
8923 which may be replaced by the check function, and I<namegv> is a GV
8924 supplying the name that should be used by the check function to refer
8925 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8926 It is permitted to apply the check function in non-standard situations,
8927 such as to a call to a different subroutine or to a method call.
8929 By default, the function is
8930 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8931 and the SV parameter is I<cv> itself. This implements standard
8932 prototype processing. It can be changed, for a particular subroutine,
8933 by L</cv_set_call_checker>.
8939 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8942 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8943 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8945 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8946 *ckobj_p = callmg->mg_obj;
8948 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8954 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8956 Sets the function that will be used to fix up a call to I<cv>.
8957 Specifically, the function is applied to an C<entersub> op tree for a
8958 subroutine call, not marked with C<&>, where the callee can be identified
8959 at compile time as I<cv>.
8961 The C-level function pointer is supplied in I<ckfun>, and an SV argument
8962 for it is supplied in I<ckobj>. The function is intended to be called
8965 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
8967 In this call, I<entersubop> is a pointer to the C<entersub> op,
8968 which may be replaced by the check function, and I<namegv> is a GV
8969 supplying the name that should be used by the check function to refer
8970 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8971 It is permitted to apply the check function in non-standard situations,
8972 such as to a call to a different subroutine or to a method call.
8974 The current setting for a particular CV can be retrieved by
8975 L</cv_get_call_checker>.
8981 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
8983 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
8984 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
8985 if (SvMAGICAL((SV*)cv))
8986 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
8989 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
8990 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
8991 if (callmg->mg_flags & MGf_REFCOUNTED) {
8992 SvREFCNT_dec(callmg->mg_obj);
8993 callmg->mg_flags &= ~MGf_REFCOUNTED;
8995 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
8996 callmg->mg_obj = ckobj;
8997 if (ckobj != (SV*)cv) {
8998 SvREFCNT_inc_simple_void_NN(ckobj);
8999 callmg->mg_flags |= MGf_REFCOUNTED;
9005 Perl_ck_subr(pTHX_ OP *o)
9011 PERL_ARGS_ASSERT_CK_SUBR;
9013 aop = cUNOPx(o)->op_first;
9014 if (!aop->op_sibling)
9015 aop = cUNOPx(aop)->op_first;
9016 aop = aop->op_sibling;
9017 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9018 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9019 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9021 o->op_private |= OPpENTERSUB_HASTARG;
9022 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9023 if (PERLDB_SUB && PL_curstash != PL_debstash)
9024 o->op_private |= OPpENTERSUB_DB;
9025 if (cvop->op_type == OP_RV2CV) {
9026 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9028 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9029 if (aop->op_type == OP_CONST)
9030 aop->op_private &= ~OPpCONST_STRICT;
9031 else if (aop->op_type == OP_LIST) {
9032 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9033 if (sib && sib->op_type == OP_CONST)
9034 sib->op_private &= ~OPpCONST_STRICT;
9039 return ck_entersub_args_list(o);
9041 Perl_call_checker ckfun;
9043 cv_get_call_checker(cv, &ckfun, &ckobj);
9044 return ckfun(aTHX_ o, namegv, ckobj);
9049 Perl_ck_svconst(pTHX_ OP *o)
9051 PERL_ARGS_ASSERT_CK_SVCONST;
9052 PERL_UNUSED_CONTEXT;
9053 SvREADONLY_on(cSVOPo->op_sv);
9058 Perl_ck_chdir(pTHX_ OP *o)
9060 PERL_ARGS_ASSERT_CK_CHDIR;
9061 if (o->op_flags & OPf_KIDS) {
9062 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9064 if (kid && kid->op_type == OP_CONST &&
9065 (kid->op_private & OPpCONST_BARE))
9067 o->op_flags |= OPf_SPECIAL;
9068 kid->op_private &= ~OPpCONST_STRICT;
9075 Perl_ck_trunc(pTHX_ OP *o)
9077 PERL_ARGS_ASSERT_CK_TRUNC;
9079 if (o->op_flags & OPf_KIDS) {
9080 SVOP *kid = (SVOP*)cUNOPo->op_first;
9082 if (kid->op_type == OP_NULL)
9083 kid = (SVOP*)kid->op_sibling;
9084 if (kid && kid->op_type == OP_CONST &&
9085 (kid->op_private & OPpCONST_BARE))
9087 o->op_flags |= OPf_SPECIAL;
9088 kid->op_private &= ~OPpCONST_STRICT;
9095 Perl_ck_unpack(pTHX_ OP *o)
9097 OP *kid = cLISTOPo->op_first;
9099 PERL_ARGS_ASSERT_CK_UNPACK;
9101 if (kid->op_sibling) {
9102 kid = kid->op_sibling;
9103 if (!kid->op_sibling)
9104 kid->op_sibling = newDEFSVOP();
9110 Perl_ck_substr(pTHX_ OP *o)
9112 PERL_ARGS_ASSERT_CK_SUBSTR;
9115 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9116 OP *kid = cLISTOPo->op_first;
9118 if (kid->op_type == OP_NULL)
9119 kid = kid->op_sibling;
9121 kid->op_flags |= OPf_MOD;
9128 Perl_ck_each(pTHX_ OP *o)
9131 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9133 PERL_ARGS_ASSERT_CK_EACH;
9136 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
9137 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
9138 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9139 o->op_type = new_type;
9140 o->op_ppaddr = PL_ppaddr[new_type];
9142 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
9143 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
9145 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
9152 /* caller is supposed to assign the return to the
9153 container of the rep_op var */
9155 S_opt_scalarhv(pTHX_ OP *rep_op) {
9159 PERL_ARGS_ASSERT_OPT_SCALARHV;
9161 NewOp(1101, unop, 1, UNOP);
9162 unop->op_type = (OPCODE)OP_BOOLKEYS;
9163 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9164 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9165 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9166 unop->op_first = rep_op;
9167 unop->op_next = rep_op->op_next;
9168 rep_op->op_next = (OP*)unop;
9169 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9170 unop->op_sibling = rep_op->op_sibling;
9171 rep_op->op_sibling = NULL;
9172 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9173 if (rep_op->op_type == OP_PADHV) {
9174 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9175 rep_op->op_flags |= OPf_WANT_LIST;
9180 /* Checks if o acts as an in-place operator on an array. oright points to the
9181 * beginning of the right-hand side. Returns the left-hand side of the
9182 * assignment if o acts in-place, or NULL otherwise. */
9185 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9189 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9192 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9193 || oright->op_next != o
9194 || (oright->op_private & OPpLVAL_INTRO)
9198 /* o2 follows the chain of op_nexts through the LHS of the
9199 * assign (if any) to the aassign op itself */
9201 if (!o2 || o2->op_type != OP_NULL)
9204 if (!o2 || o2->op_type != OP_PUSHMARK)
9207 if (o2 && o2->op_type == OP_GV)
9210 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9211 || (o2->op_private & OPpLVAL_INTRO)
9216 if (!o2 || o2->op_type != OP_NULL)
9219 if (!o2 || o2->op_type != OP_AASSIGN
9220 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9223 /* check that the sort is the first arg on RHS of assign */
9225 o2 = cUNOPx(o2)->op_first;
9226 if (!o2 || o2->op_type != OP_NULL)
9228 o2 = cUNOPx(o2)->op_first;
9229 if (!o2 || o2->op_type != OP_PUSHMARK)
9231 if (o2->op_sibling != o)
9234 /* check the array is the same on both sides */
9235 if (oleft->op_type == OP_RV2AV) {
9236 if (oright->op_type != OP_RV2AV
9237 || !cUNOPx(oright)->op_first
9238 || cUNOPx(oright)->op_first->op_type != OP_GV
9239 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9240 cGVOPx_gv(cUNOPx(oright)->op_first)
9244 else if (oright->op_type != OP_PADAV
9245 || oright->op_targ != oleft->op_targ
9252 /* A peephole optimizer. We visit the ops in the order they're to execute.
9253 * See the comments at the top of this file for more details about when
9254 * peep() is called */
9257 Perl_rpeep(pTHX_ register OP *o)
9260 register OP* oldop = NULL;
9262 if (!o || o->op_opt)
9266 SAVEVPTR(PL_curcop);
9267 for (; o; o = o->op_next) {
9270 /* By default, this op has now been optimised. A couple of cases below
9271 clear this again. */
9274 switch (o->op_type) {
9276 PL_curcop = ((COP*)o); /* for warnings */
9279 PL_curcop = ((COP*)o); /* for warnings */
9281 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9282 to carry two labels. For now, take the easier option, and skip
9283 this optimisation if the first NEXTSTATE has a label. */
9284 if (!CopLABEL((COP*)o)) {
9285 OP *nextop = o->op_next;
9286 while (nextop && nextop->op_type == OP_NULL)
9287 nextop = nextop->op_next;
9289 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9290 COP *firstcop = (COP *)o;
9291 COP *secondcop = (COP *)nextop;
9292 /* We want the COP pointed to by o (and anything else) to
9293 become the next COP down the line. */
9296 firstcop->op_next = secondcop->op_next;
9298 /* Now steal all its pointers, and duplicate the other
9300 firstcop->cop_line = secondcop->cop_line;
9302 firstcop->cop_stashpv = secondcop->cop_stashpv;
9303 firstcop->cop_file = secondcop->cop_file;
9305 firstcop->cop_stash = secondcop->cop_stash;
9306 firstcop->cop_filegv = secondcop->cop_filegv;
9308 firstcop->cop_hints = secondcop->cop_hints;
9309 firstcop->cop_seq = secondcop->cop_seq;
9310 firstcop->cop_warnings = secondcop->cop_warnings;
9311 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9314 secondcop->cop_stashpv = NULL;
9315 secondcop->cop_file = NULL;
9317 secondcop->cop_stash = NULL;
9318 secondcop->cop_filegv = NULL;
9320 secondcop->cop_warnings = NULL;
9321 secondcop->cop_hints_hash = NULL;
9323 /* If we use op_null(), and hence leave an ex-COP, some
9324 warnings are misreported. For example, the compile-time
9325 error in 'use strict; no strict refs;' */
9326 secondcop->op_type = OP_NULL;
9327 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9333 if (cSVOPo->op_private & OPpCONST_STRICT)
9334 no_bareword_allowed(o);
9337 case OP_METHOD_NAMED:
9338 /* Relocate sv to the pad for thread safety.
9339 * Despite being a "constant", the SV is written to,
9340 * for reference counts, sv_upgrade() etc. */
9342 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9343 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9344 /* If op_sv is already a PADTMP then it is being used by
9345 * some pad, so make a copy. */
9346 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9347 SvREADONLY_on(PAD_SVl(ix));
9348 SvREFCNT_dec(cSVOPo->op_sv);
9350 else if (o->op_type != OP_METHOD_NAMED
9351 && cSVOPo->op_sv == &PL_sv_undef) {
9352 /* PL_sv_undef is hack - it's unsafe to store it in the
9353 AV that is the pad, because av_fetch treats values of
9354 PL_sv_undef as a "free" AV entry and will merrily
9355 replace them with a new SV, causing pad_alloc to think
9356 that this pad slot is free. (When, clearly, it is not)
9358 SvOK_off(PAD_SVl(ix));
9359 SvPADTMP_on(PAD_SVl(ix));
9360 SvREADONLY_on(PAD_SVl(ix));
9363 SvREFCNT_dec(PAD_SVl(ix));
9364 SvPADTMP_on(cSVOPo->op_sv);
9365 PAD_SETSV(ix, cSVOPo->op_sv);
9366 /* XXX I don't know how this isn't readonly already. */
9367 SvREADONLY_on(PAD_SVl(ix));
9369 cSVOPo->op_sv = NULL;
9376 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9377 if (o->op_next->op_private & OPpTARGET_MY) {
9378 if (o->op_flags & OPf_STACKED) /* chained concats */
9379 break; /* ignore_optimization */
9381 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9382 o->op_targ = o->op_next->op_targ;
9383 o->op_next->op_targ = 0;
9384 o->op_private |= OPpTARGET_MY;
9387 op_null(o->op_next);
9391 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9392 break; /* Scalar stub must produce undef. List stub is noop */
9396 if (o->op_targ == OP_NEXTSTATE
9397 || o->op_targ == OP_DBSTATE)
9399 PL_curcop = ((COP*)o);
9401 /* XXX: We avoid setting op_seq here to prevent later calls
9402 to rpeep() from mistakenly concluding that optimisation
9403 has already occurred. This doesn't fix the real problem,
9404 though (See 20010220.007). AMS 20010719 */
9405 /* op_seq functionality is now replaced by op_opt */
9412 if (oldop && o->op_next) {
9413 oldop->op_next = o->op_next;
9421 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9422 OP* const pop = (o->op_type == OP_PADAV) ?
9423 o->op_next : o->op_next->op_next;
9425 if (pop && pop->op_type == OP_CONST &&
9426 ((PL_op = pop->op_next)) &&
9427 pop->op_next->op_type == OP_AELEM &&
9428 !(pop->op_next->op_private &
9429 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9430 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9435 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9436 no_bareword_allowed(pop);
9437 if (o->op_type == OP_GV)
9438 op_null(o->op_next);
9439 op_null(pop->op_next);
9441 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9442 o->op_next = pop->op_next->op_next;
9443 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9444 o->op_private = (U8)i;
9445 if (o->op_type == OP_GV) {
9450 o->op_flags |= OPf_SPECIAL;
9451 o->op_type = OP_AELEMFAST;
9456 if (o->op_next->op_type == OP_RV2SV) {
9457 if (!(o->op_next->op_private & OPpDEREF)) {
9458 op_null(o->op_next);
9459 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9461 o->op_next = o->op_next->op_next;
9462 o->op_type = OP_GVSV;
9463 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9466 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9467 GV * const gv = cGVOPo_gv;
9468 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9469 /* XXX could check prototype here instead of just carping */
9470 SV * const sv = sv_newmortal();
9471 gv_efullname3(sv, gv, NULL);
9472 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9473 "%"SVf"() called too early to check prototype",
9477 else if (o->op_next->op_type == OP_READLINE
9478 && o->op_next->op_next->op_type == OP_CONCAT
9479 && (o->op_next->op_next->op_flags & OPf_STACKED))
9481 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9482 o->op_type = OP_RCATLINE;
9483 o->op_flags |= OPf_STACKED;
9484 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9485 op_null(o->op_next->op_next);
9486 op_null(o->op_next);
9496 fop = cUNOP->op_first;
9504 fop = cLOGOP->op_first;
9505 sop = fop->op_sibling;
9506 while (cLOGOP->op_other->op_type == OP_NULL)
9507 cLOGOP->op_other = cLOGOP->op_other->op_next;
9508 CALL_RPEEP(cLOGOP->op_other);
9512 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9514 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9519 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9520 while (nop && nop->op_next) {
9521 switch (nop->op_next->op_type) {
9526 lop = nop = nop->op_next;
9537 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9538 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9539 cLOGOP->op_first = opt_scalarhv(fop);
9540 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9541 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9557 while (cLOGOP->op_other->op_type == OP_NULL)
9558 cLOGOP->op_other = cLOGOP->op_other->op_next;
9559 CALL_RPEEP(cLOGOP->op_other);
9564 while (cLOOP->op_redoop->op_type == OP_NULL)
9565 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9566 CALL_RPEEP(cLOOP->op_redoop);
9567 while (cLOOP->op_nextop->op_type == OP_NULL)
9568 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9569 CALL_RPEEP(cLOOP->op_nextop);
9570 while (cLOOP->op_lastop->op_type == OP_NULL)
9571 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9572 CALL_RPEEP(cLOOP->op_lastop);
9576 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9577 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9578 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9579 cPMOP->op_pmstashstartu.op_pmreplstart
9580 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9581 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9585 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9586 && ckWARN(WARN_SYNTAX))
9588 if (o->op_next->op_sibling) {
9589 const OPCODE type = o->op_next->op_sibling->op_type;
9590 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9591 const line_t oldline = CopLINE(PL_curcop);
9592 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9593 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9594 "Statement unlikely to be reached");
9595 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9596 "\t(Maybe you meant system() when you said exec()?)\n");
9597 CopLINE_set(PL_curcop, oldline);
9608 const char *key = NULL;
9611 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9614 /* Make the CONST have a shared SV */
9615 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9616 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
9617 key = SvPV_const(sv, keylen);
9618 lexname = newSVpvn_share(key,
9619 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9625 if ((o->op_private & (OPpLVAL_INTRO)))
9628 rop = (UNOP*)((BINOP*)o)->op_first;
9629 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9631 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9632 if (!SvPAD_TYPED(lexname))
9634 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9635 if (!fields || !GvHV(*fields))
9637 key = SvPV_const(*svp, keylen);
9638 if (!hv_fetch(GvHV(*fields), key,
9639 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9641 Perl_croak(aTHX_ "No such class field \"%s\" "
9642 "in variable %s of type %s",
9643 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9656 SVOP *first_key_op, *key_op;
9658 if ((o->op_private & (OPpLVAL_INTRO))
9659 /* I bet there's always a pushmark... */
9660 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9661 /* hmmm, no optimization if list contains only one key. */
9663 rop = (UNOP*)((LISTOP*)o)->op_last;
9664 if (rop->op_type != OP_RV2HV)
9666 if (rop->op_first->op_type == OP_PADSV)
9667 /* @$hash{qw(keys here)} */
9668 rop = (UNOP*)rop->op_first;
9670 /* @{$hash}{qw(keys here)} */
9671 if (rop->op_first->op_type == OP_SCOPE
9672 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9674 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9680 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9681 if (!SvPAD_TYPED(lexname))
9683 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9684 if (!fields || !GvHV(*fields))
9686 /* Again guessing that the pushmark can be jumped over.... */
9687 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9688 ->op_first->op_sibling;
9689 for (key_op = first_key_op; key_op;
9690 key_op = (SVOP*)key_op->op_sibling) {
9691 if (key_op->op_type != OP_CONST)
9693 svp = cSVOPx_svp(key_op);
9694 key = SvPV_const(*svp, keylen);
9695 if (!hv_fetch(GvHV(*fields), key,
9696 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9698 Perl_croak(aTHX_ "No such class field \"%s\" "
9699 "in variable %s of type %s",
9700 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9709 && ( oldop->op_type == OP_AELEM
9710 || oldop->op_type == OP_PADSV
9711 || oldop->op_type == OP_RV2SV
9712 || oldop->op_type == OP_RV2GV
9713 || oldop->op_type == OP_HELEM
9715 && (oldop->op_private & OPpDEREF)
9717 o->op_private |= OPpDEREFed;
9721 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9725 /* check that RHS of sort is a single plain array */
9726 OP *oright = cUNOPo->op_first;
9727 if (!oright || oright->op_type != OP_PUSHMARK)
9730 /* reverse sort ... can be optimised. */
9731 if (!cUNOPo->op_sibling) {
9732 /* Nothing follows us on the list. */
9733 OP * const reverse = o->op_next;
9735 if (reverse->op_type == OP_REVERSE &&
9736 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9737 OP * const pushmark = cUNOPx(reverse)->op_first;
9738 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9739 && (cUNOPx(pushmark)->op_sibling == o)) {
9740 /* reverse -> pushmark -> sort */
9741 o->op_private |= OPpSORT_REVERSE;
9743 pushmark->op_next = oright->op_next;
9749 /* make @a = sort @a act in-place */
9751 oright = cUNOPx(oright)->op_sibling;
9754 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9755 oright = cUNOPx(oright)->op_sibling;
9758 oleft = is_inplace_av(o, oright);
9762 /* transfer MODishness etc from LHS arg to RHS arg */
9763 oright->op_flags = oleft->op_flags;
9764 o->op_private |= OPpSORT_INPLACE;
9766 /* excise push->gv->rv2av->null->aassign */
9767 o2 = o->op_next->op_next;
9768 op_null(o2); /* PUSHMARK */
9770 if (o2->op_type == OP_GV) {
9771 op_null(o2); /* GV */
9774 op_null(o2); /* RV2AV or PADAV */
9775 o2 = o2->op_next->op_next;
9776 op_null(o2); /* AASSIGN */
9778 o->op_next = o2->op_next;
9784 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9787 LISTOP *enter, *exlist;
9789 /* @a = reverse @a */
9790 if ((oright = cLISTOPo->op_first)
9791 && (oright->op_type == OP_PUSHMARK)
9792 && (oright = oright->op_sibling)
9793 && (oleft = is_inplace_av(o, oright))) {
9796 /* transfer MODishness etc from LHS arg to RHS arg */
9797 oright->op_flags = oleft->op_flags;
9798 o->op_private |= OPpREVERSE_INPLACE;
9800 /* excise push->gv->rv2av->null->aassign */
9801 o2 = o->op_next->op_next;
9802 op_null(o2); /* PUSHMARK */
9804 if (o2->op_type == OP_GV) {
9805 op_null(o2); /* GV */
9808 op_null(o2); /* RV2AV or PADAV */
9809 o2 = o2->op_next->op_next;
9810 op_null(o2); /* AASSIGN */
9812 o->op_next = o2->op_next;
9816 enter = (LISTOP *) o->op_next;
9819 if (enter->op_type == OP_NULL) {
9820 enter = (LISTOP *) enter->op_next;
9824 /* for $a (...) will have OP_GV then OP_RV2GV here.
9825 for (...) just has an OP_GV. */
9826 if (enter->op_type == OP_GV) {
9827 gvop = (OP *) enter;
9828 enter = (LISTOP *) enter->op_next;
9831 if (enter->op_type == OP_RV2GV) {
9832 enter = (LISTOP *) enter->op_next;
9838 if (enter->op_type != OP_ENTERITER)
9841 iter = enter->op_next;
9842 if (!iter || iter->op_type != OP_ITER)
9845 expushmark = enter->op_first;
9846 if (!expushmark || expushmark->op_type != OP_NULL
9847 || expushmark->op_targ != OP_PUSHMARK)
9850 exlist = (LISTOP *) expushmark->op_sibling;
9851 if (!exlist || exlist->op_type != OP_NULL
9852 || exlist->op_targ != OP_LIST)
9855 if (exlist->op_last != o) {
9856 /* Mmm. Was expecting to point back to this op. */
9859 theirmark = exlist->op_first;
9860 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9863 if (theirmark->op_sibling != o) {
9864 /* There's something between the mark and the reverse, eg
9865 for (1, reverse (...))
9870 ourmark = ((LISTOP *)o)->op_first;
9871 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9874 ourlast = ((LISTOP *)o)->op_last;
9875 if (!ourlast || ourlast->op_next != o)
9878 rv2av = ourmark->op_sibling;
9879 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9880 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9881 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9882 /* We're just reversing a single array. */
9883 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9884 enter->op_flags |= OPf_STACKED;
9887 /* We don't have control over who points to theirmark, so sacrifice
9889 theirmark->op_next = ourmark->op_next;
9890 theirmark->op_flags = ourmark->op_flags;
9891 ourlast->op_next = gvop ? gvop : (OP *) enter;
9894 enter->op_private |= OPpITER_REVERSED;
9895 iter->op_private |= OPpITER_REVERSED;
9902 UNOP *refgen, *rv2cv;
9905 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9908 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9911 rv2gv = ((BINOP *)o)->op_last;
9912 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9915 refgen = (UNOP *)((BINOP *)o)->op_first;
9917 if (!refgen || refgen->op_type != OP_REFGEN)
9920 exlist = (LISTOP *)refgen->op_first;
9921 if (!exlist || exlist->op_type != OP_NULL
9922 || exlist->op_targ != OP_LIST)
9925 if (exlist->op_first->op_type != OP_PUSHMARK)
9928 rv2cv = (UNOP*)exlist->op_last;
9930 if (rv2cv->op_type != OP_RV2CV)
9933 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9934 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9935 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9937 o->op_private |= OPpASSIGN_CV_TO_GV;
9938 rv2gv->op_private |= OPpDONT_INIT_GV;
9939 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9947 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9948 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9958 Perl_peep(pTHX_ register OP *o)
9964 Perl_custom_op_name(pTHX_ const OP* o)
9967 const IV index = PTR2IV(o->op_ppaddr);
9971 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9973 if (!PL_custom_op_names) /* This probably shouldn't happen */
9974 return (char *)PL_op_name[OP_CUSTOM];
9976 keysv = sv_2mortal(newSViv(index));
9978 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9980 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9982 return SvPV_nolen(HeVAL(he));
9986 Perl_custom_op_desc(pTHX_ const OP* o)
9989 const IV index = PTR2IV(o->op_ppaddr);
9993 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9995 if (!PL_custom_op_descs)
9996 return (char *)PL_op_desc[OP_CUSTOM];
9998 keysv = sv_2mortal(newSViv(index));
10000 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
10002 return (char *)PL_op_desc[OP_CUSTOM];
10004 return SvPV_nolen(HeVAL(he));
10009 /* Efficient sub that returns a constant scalar value. */
10011 const_sv_xsub(pTHX_ CV* cv)
10015 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10019 /* diag_listed_as: SKIPME */
10020 Perl_croak(aTHX_ "usage: %s::%s()",
10021 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10034 * c-indentation-style: bsd
10035 * c-basic-offset: 4
10036 * indent-tabs-mode: t
10039 * ex: set ts=8 sts=4 sw=4 noet: