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 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
724 S_forget_pmop(pTHX_ PMOP *const o
730 HV * const pmstash = PmopSTASH(o);
732 PERL_ARGS_ASSERT_FORGET_PMOP;
734 if (pmstash && !SvIS_FREED(pmstash)) {
735 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
737 PMOP **const array = (PMOP**) mg->mg_ptr;
738 U32 count = mg->mg_len / sizeof(PMOP**);
743 /* Found it. Move the entry at the end to overwrite it. */
744 array[i] = array[--count];
745 mg->mg_len = count * sizeof(PMOP**);
746 /* Could realloc smaller at this point always, but probably
747 not worth it. Probably worth free()ing if we're the
750 Safefree(mg->mg_ptr);
767 S_find_and_forget_pmops(pTHX_ OP *o)
769 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
771 if (o->op_flags & OPf_KIDS) {
772 OP *kid = cUNOPo->op_first;
774 switch (kid->op_type) {
779 forget_pmop((PMOP*)kid, 0);
781 find_and_forget_pmops(kid);
782 kid = kid->op_sibling;
788 Perl_op_null(pTHX_ OP *o)
792 PERL_ARGS_ASSERT_OP_NULL;
794 if (o->op_type == OP_NULL)
798 o->op_targ = o->op_type;
799 o->op_type = OP_NULL;
800 o->op_ppaddr = PL_ppaddr[OP_NULL];
804 Perl_op_refcnt_lock(pTHX)
812 Perl_op_refcnt_unlock(pTHX)
819 /* Contextualizers */
822 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
824 Applies a syntactic context to an op tree representing an expression.
825 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
826 or C<G_VOID> to specify the context to apply. The modified op tree
833 Perl_op_contextualize(pTHX_ OP *o, I32 context)
835 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
837 case G_SCALAR: return scalar(o);
838 case G_ARRAY: return list(o);
839 case G_VOID: return scalarvoid(o);
841 Perl_croak(aTHX_ "panic: op_contextualize bad context");
847 =head1 Optree Manipulation Functions
849 =for apidoc Am|OP*|op_linklist|OP *o
850 This function is the implementation of the L</LINKLIST> macro. It should
851 not be called directly.
857 Perl_op_linklist(pTHX_ OP *o)
861 PERL_ARGS_ASSERT_OP_LINKLIST;
866 /* establish postfix order */
867 first = cUNOPo->op_first;
870 o->op_next = LINKLIST(first);
873 if (kid->op_sibling) {
874 kid->op_next = LINKLIST(kid->op_sibling);
875 kid = kid->op_sibling;
889 S_scalarkids(pTHX_ OP *o)
891 if (o && o->op_flags & OPf_KIDS) {
893 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
900 S_scalarboolean(pTHX_ OP *o)
904 PERL_ARGS_ASSERT_SCALARBOOLEAN;
906 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
907 if (ckWARN(WARN_SYNTAX)) {
908 const line_t oldline = CopLINE(PL_curcop);
910 if (PL_parser && PL_parser->copline != NOLINE)
911 CopLINE_set(PL_curcop, PL_parser->copline);
912 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
913 CopLINE_set(PL_curcop, oldline);
920 Perl_scalar(pTHX_ OP *o)
925 /* assumes no premature commitment */
926 if (!o || (PL_parser && PL_parser->error_count)
927 || (o->op_flags & OPf_WANT)
928 || o->op_type == OP_RETURN)
933 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
935 switch (o->op_type) {
937 scalar(cBINOPo->op_first);
942 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
952 if (o->op_flags & OPf_KIDS) {
953 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
959 kid = cLISTOPo->op_first;
961 kid = kid->op_sibling;
964 OP *sib = kid->op_sibling;
965 if (sib && kid->op_type != OP_LEAVEWHEN) {
966 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
976 PL_curcop = &PL_compiling;
981 kid = cLISTOPo->op_first;
984 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
991 Perl_scalarvoid(pTHX_ OP *o)
995 const char* useless = NULL;
999 PERL_ARGS_ASSERT_SCALARVOID;
1001 /* trailing mad null ops don't count as "there" for void processing */
1003 o->op_type != OP_NULL &&
1005 o->op_sibling->op_type == OP_NULL)
1008 for (sib = o->op_sibling;
1009 sib && sib->op_type == OP_NULL;
1010 sib = sib->op_sibling) ;
1016 if (o->op_type == OP_NEXTSTATE
1017 || o->op_type == OP_DBSTATE
1018 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1019 || o->op_targ == OP_DBSTATE)))
1020 PL_curcop = (COP*)o; /* for warning below */
1022 /* assumes no premature commitment */
1023 want = o->op_flags & OPf_WANT;
1024 if ((want && want != OPf_WANT_SCALAR)
1025 || (PL_parser && PL_parser->error_count)
1026 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1031 if ((o->op_private & OPpTARGET_MY)
1032 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1034 return scalar(o); /* As if inside SASSIGN */
1037 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1039 switch (o->op_type) {
1041 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1045 if (o->op_flags & OPf_STACKED)
1049 if (o->op_private == 4)
1092 case OP_GETSOCKNAME:
1093 case OP_GETPEERNAME:
1098 case OP_GETPRIORITY:
1122 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1123 /* Otherwise it's "Useless use of grep iterator" */
1124 useless = OP_DESC(o);
1128 kid = cLISTOPo->op_first;
1129 if (kid && kid->op_type == OP_PUSHRE
1131 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1133 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1135 useless = OP_DESC(o);
1139 kid = cUNOPo->op_first;
1140 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1141 kid->op_type != OP_TRANS) {
1144 useless = "negative pattern binding (!~)";
1148 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1149 useless = "Non-destructive substitution (s///r)";
1156 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1157 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1158 useless = "a variable";
1163 if (cSVOPo->op_private & OPpCONST_STRICT)
1164 no_bareword_allowed(o);
1166 if (ckWARN(WARN_VOID)) {
1168 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1169 "a constant (%"SVf")", sv));
1170 useless = SvPV_nolen(msv);
1173 useless = "a constant (undef)";
1174 if (o->op_private & OPpCONST_ARYBASE)
1176 /* don't warn on optimised away booleans, eg
1177 * use constant Foo, 5; Foo || print; */
1178 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1180 /* the constants 0 and 1 are permitted as they are
1181 conventionally used as dummies in constructs like
1182 1 while some_condition_with_side_effects; */
1183 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1185 else if (SvPOK(sv)) {
1186 /* perl4's way of mixing documentation and code
1187 (before the invention of POD) was based on a
1188 trick to mix nroff and perl code. The trick was
1189 built upon these three nroff macros being used in
1190 void context. The pink camel has the details in
1191 the script wrapman near page 319. */
1192 const char * const maybe_macro = SvPVX_const(sv);
1193 if (strnEQ(maybe_macro, "di", 2) ||
1194 strnEQ(maybe_macro, "ds", 2) ||
1195 strnEQ(maybe_macro, "ig", 2))
1200 op_null(o); /* don't execute or even remember it */
1204 o->op_type = OP_PREINC; /* pre-increment is faster */
1205 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1209 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1210 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1214 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1215 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1219 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1220 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1225 kid = cLOGOPo->op_first;
1226 if (kid->op_type == OP_NOT
1227 && (kid->op_flags & OPf_KIDS)
1229 if (o->op_type == OP_AND) {
1231 o->op_ppaddr = PL_ppaddr[OP_OR];
1233 o->op_type = OP_AND;
1234 o->op_ppaddr = PL_ppaddr[OP_AND];
1243 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1248 if (o->op_flags & OPf_STACKED)
1255 if (!(o->op_flags & OPf_KIDS))
1266 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1276 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1281 S_listkids(pTHX_ OP *o)
1283 if (o && o->op_flags & OPf_KIDS) {
1285 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1292 Perl_list(pTHX_ OP *o)
1297 /* assumes no premature commitment */
1298 if (!o || (o->op_flags & OPf_WANT)
1299 || (PL_parser && PL_parser->error_count)
1300 || o->op_type == OP_RETURN)
1305 if ((o->op_private & OPpTARGET_MY)
1306 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1308 return o; /* As if inside SASSIGN */
1311 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1313 switch (o->op_type) {
1316 list(cBINOPo->op_first);
1321 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1329 if (!(o->op_flags & OPf_KIDS))
1331 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1332 list(cBINOPo->op_first);
1333 return gen_constant_list(o);
1340 kid = cLISTOPo->op_first;
1342 kid = kid->op_sibling;
1345 OP *sib = kid->op_sibling;
1346 if (sib && kid->op_type != OP_LEAVEWHEN) {
1347 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1357 PL_curcop = &PL_compiling;
1361 kid = cLISTOPo->op_first;
1368 S_scalarseq(pTHX_ OP *o)
1372 const OPCODE type = o->op_type;
1374 if (type == OP_LINESEQ || type == OP_SCOPE ||
1375 type == OP_LEAVE || type == OP_LEAVETRY)
1378 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1379 if (kid->op_sibling) {
1383 PL_curcop = &PL_compiling;
1385 o->op_flags &= ~OPf_PARENS;
1386 if (PL_hints & HINT_BLOCK_SCOPE)
1387 o->op_flags |= OPf_PARENS;
1390 o = newOP(OP_STUB, 0);
1395 S_modkids(pTHX_ OP *o, I32 type)
1397 if (o && o->op_flags & OPf_KIDS) {
1399 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1405 /* Propagate lvalue ("modifiable") context to an op and its children.
1406 * 'type' represents the context type, roughly based on the type of op that
1407 * would do the modifying, although local() is represented by OP_NULL.
1408 * It's responsible for detecting things that can't be modified, flag
1409 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1410 * might have to vivify a reference in $x), and so on.
1412 * For example, "$a+1 = 2" would cause mod() to be called with o being
1413 * OP_ADD and type being OP_SASSIGN, and would output an error.
1417 Perl_mod(pTHX_ OP *o, I32 type)
1421 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1424 if (!o || (PL_parser && PL_parser->error_count))
1427 if ((o->op_private & OPpTARGET_MY)
1428 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1433 switch (o->op_type) {
1439 if (!(o->op_private & OPpCONST_ARYBASE))
1442 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1443 CopARYBASE_set(&PL_compiling,
1444 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1448 SAVECOPARYBASE(&PL_compiling);
1449 CopARYBASE_set(&PL_compiling, 0);
1451 else if (type == OP_REFGEN)
1454 Perl_croak(aTHX_ "That use of $[ is unsupported");
1457 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1461 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1462 !(o->op_flags & OPf_STACKED)) {
1463 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1464 /* The default is to set op_private to the number of children,
1465 which for a UNOP such as RV2CV is always 1. And w're using
1466 the bit for a flag in RV2CV, so we need it clear. */
1467 o->op_private &= ~1;
1468 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1469 assert(cUNOPo->op_first->op_type == OP_NULL);
1470 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1473 else if (o->op_private & OPpENTERSUB_NOMOD)
1475 else { /* lvalue subroutine call */
1476 o->op_private |= OPpLVAL_INTRO;
1477 PL_modcount = RETURN_UNLIMITED_NUMBER;
1478 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1479 /* Backward compatibility mode: */
1480 o->op_private |= OPpENTERSUB_INARGS;
1483 else { /* Compile-time error message: */
1484 OP *kid = cUNOPo->op_first;
1488 if (kid->op_type != OP_PUSHMARK) {
1489 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1491 "panic: unexpected lvalue entersub "
1492 "args: type/targ %ld:%"UVuf,
1493 (long)kid->op_type, (UV)kid->op_targ);
1494 kid = kLISTOP->op_first;
1496 while (kid->op_sibling)
1497 kid = kid->op_sibling;
1498 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1500 if (kid->op_type == OP_METHOD_NAMED
1501 || kid->op_type == OP_METHOD)
1505 NewOp(1101, newop, 1, UNOP);
1506 newop->op_type = OP_RV2CV;
1507 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1508 newop->op_first = NULL;
1509 newop->op_next = (OP*)newop;
1510 kid->op_sibling = (OP*)newop;
1511 newop->op_private |= OPpLVAL_INTRO;
1512 newop->op_private &= ~1;
1516 if (kid->op_type != OP_RV2CV)
1518 "panic: unexpected lvalue entersub "
1519 "entry via type/targ %ld:%"UVuf,
1520 (long)kid->op_type, (UV)kid->op_targ);
1521 kid->op_private |= OPpLVAL_INTRO;
1522 break; /* Postpone until runtime */
1526 kid = kUNOP->op_first;
1527 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1528 kid = kUNOP->op_first;
1529 if (kid->op_type == OP_NULL)
1531 "Unexpected constant lvalue entersub "
1532 "entry via type/targ %ld:%"UVuf,
1533 (long)kid->op_type, (UV)kid->op_targ);
1534 if (kid->op_type != OP_GV) {
1535 /* Restore RV2CV to check lvalueness */
1537 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1538 okid->op_next = kid->op_next;
1539 kid->op_next = okid;
1542 okid->op_next = NULL;
1543 okid->op_type = OP_RV2CV;
1545 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1546 okid->op_private |= OPpLVAL_INTRO;
1547 okid->op_private &= ~1;
1551 cv = GvCV(kGVOP_gv);
1561 /* grep, foreach, subcalls, refgen */
1562 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1564 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1565 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1567 : (o->op_type == OP_ENTERSUB
1568 ? "non-lvalue subroutine call"
1570 type ? PL_op_desc[type] : "local"));
1584 case OP_RIGHT_SHIFT:
1593 if (!(o->op_flags & OPf_STACKED))
1600 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1606 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1607 PL_modcount = RETURN_UNLIMITED_NUMBER;
1608 return o; /* Treat \(@foo) like ordinary list. */
1612 if (scalar_mod_type(o, type))
1614 ref(cUNOPo->op_first, o->op_type);
1618 if (type == OP_LEAVESUBLV)
1619 o->op_private |= OPpMAYBE_LVSUB;
1625 PL_modcount = RETURN_UNLIMITED_NUMBER;
1628 PL_hints |= HINT_BLOCK_SCOPE;
1629 if (type == OP_LEAVESUBLV)
1630 o->op_private |= OPpMAYBE_LVSUB;
1634 ref(cUNOPo->op_first, o->op_type);
1638 PL_hints |= HINT_BLOCK_SCOPE;
1653 PL_modcount = RETURN_UNLIMITED_NUMBER;
1654 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1655 return o; /* Treat \(@foo) like ordinary list. */
1656 if (scalar_mod_type(o, type))
1658 if (type == OP_LEAVESUBLV)
1659 o->op_private |= OPpMAYBE_LVSUB;
1663 if (!type) /* local() */
1664 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1665 PAD_COMPNAME_PV(o->op_targ));
1673 if (type != OP_SASSIGN)
1677 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1682 if (type == OP_LEAVESUBLV)
1683 o->op_private |= OPpMAYBE_LVSUB;
1685 pad_free(o->op_targ);
1686 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1687 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1688 if (o->op_flags & OPf_KIDS)
1689 mod(cBINOPo->op_first->op_sibling, type);
1694 ref(cBINOPo->op_first, o->op_type);
1695 if (type == OP_ENTERSUB &&
1696 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1697 o->op_private |= OPpLVAL_DEFER;
1698 if (type == OP_LEAVESUBLV)
1699 o->op_private |= OPpMAYBE_LVSUB;
1709 if (o->op_flags & OPf_KIDS)
1710 mod(cLISTOPo->op_last, type);
1715 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1717 else if (!(o->op_flags & OPf_KIDS))
1719 if (o->op_targ != OP_LIST) {
1720 mod(cBINOPo->op_first, type);
1726 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1731 if (type != OP_LEAVESUBLV)
1733 break; /* mod()ing was handled by ck_return() */
1736 /* [20011101.069] File test operators interpret OPf_REF to mean that
1737 their argument is a filehandle; thus \stat(".") should not set
1739 if (type == OP_REFGEN &&
1740 PL_check[o->op_type] == Perl_ck_ftst)
1743 if (type != OP_LEAVESUBLV)
1744 o->op_flags |= OPf_MOD;
1746 if (type == OP_AASSIGN || type == OP_SASSIGN)
1747 o->op_flags |= OPf_SPECIAL|OPf_REF;
1748 else if (!type) { /* local() */
1751 o->op_private |= OPpLVAL_INTRO;
1752 o->op_flags &= ~OPf_SPECIAL;
1753 PL_hints |= HINT_BLOCK_SCOPE;
1758 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1759 "Useless localization of %s", OP_DESC(o));
1762 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1763 && type != OP_LEAVESUBLV)
1764 o->op_flags |= OPf_REF;
1769 S_scalar_mod_type(const OP *o, I32 type)
1771 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1775 if (o->op_type == OP_RV2GV)
1799 case OP_RIGHT_SHIFT:
1819 S_is_handle_constructor(const OP *o, I32 numargs)
1821 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1823 switch (o->op_type) {
1831 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1844 S_refkids(pTHX_ OP *o, I32 type)
1846 if (o && o->op_flags & OPf_KIDS) {
1848 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1855 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1860 PERL_ARGS_ASSERT_DOREF;
1862 if (!o || (PL_parser && PL_parser->error_count))
1865 switch (o->op_type) {
1867 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1868 !(o->op_flags & OPf_STACKED)) {
1869 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1870 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1871 assert(cUNOPo->op_first->op_type == OP_NULL);
1872 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1873 o->op_flags |= OPf_SPECIAL;
1874 o->op_private &= ~1;
1879 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1880 doref(kid, type, set_op_ref);
1883 if (type == OP_DEFINED)
1884 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1885 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1888 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1889 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1890 : type == OP_RV2HV ? OPpDEREF_HV
1892 o->op_flags |= OPf_MOD;
1899 o->op_flags |= OPf_REF;
1902 if (type == OP_DEFINED)
1903 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1904 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1910 o->op_flags |= OPf_REF;
1915 if (!(o->op_flags & OPf_KIDS))
1917 doref(cBINOPo->op_first, type, set_op_ref);
1921 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1922 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1923 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1924 : type == OP_RV2HV ? OPpDEREF_HV
1926 o->op_flags |= OPf_MOD;
1936 if (!(o->op_flags & OPf_KIDS))
1938 doref(cLISTOPo->op_last, type, set_op_ref);
1948 S_dup_attrlist(pTHX_ OP *o)
1953 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1955 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1956 * where the first kid is OP_PUSHMARK and the remaining ones
1957 * are OP_CONST. We need to push the OP_CONST values.
1959 if (o->op_type == OP_CONST)
1960 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1962 else if (o->op_type == OP_NULL)
1966 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1968 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1969 if (o->op_type == OP_CONST)
1970 rop = op_append_elem(OP_LIST, rop,
1971 newSVOP(OP_CONST, o->op_flags,
1972 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1979 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1984 PERL_ARGS_ASSERT_APPLY_ATTRS;
1986 /* fake up C<use attributes $pkg,$rv,@attrs> */
1987 ENTER; /* need to protect against side-effects of 'use' */
1988 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1990 #define ATTRSMODULE "attributes"
1991 #define ATTRSMODULE_PM "attributes.pm"
1994 /* Don't force the C<use> if we don't need it. */
1995 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1996 if (svp && *svp != &PL_sv_undef)
1997 NOOP; /* already in %INC */
1999 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2000 newSVpvs(ATTRSMODULE), NULL);
2003 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2004 newSVpvs(ATTRSMODULE),
2006 op_prepend_elem(OP_LIST,
2007 newSVOP(OP_CONST, 0, stashsv),
2008 op_prepend_elem(OP_LIST,
2009 newSVOP(OP_CONST, 0,
2011 dup_attrlist(attrs))));
2017 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2020 OP *pack, *imop, *arg;
2023 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2028 assert(target->op_type == OP_PADSV ||
2029 target->op_type == OP_PADHV ||
2030 target->op_type == OP_PADAV);
2032 /* Ensure that attributes.pm is loaded. */
2033 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2035 /* Need package name for method call. */
2036 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2038 /* Build up the real arg-list. */
2039 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2041 arg = newOP(OP_PADSV, 0);
2042 arg->op_targ = target->op_targ;
2043 arg = op_prepend_elem(OP_LIST,
2044 newSVOP(OP_CONST, 0, stashsv),
2045 op_prepend_elem(OP_LIST,
2046 newUNOP(OP_REFGEN, 0,
2047 mod(arg, OP_REFGEN)),
2048 dup_attrlist(attrs)));
2050 /* Fake up a method call to import */
2051 meth = newSVpvs_share("import");
2052 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2053 op_append_elem(OP_LIST,
2054 op_prepend_elem(OP_LIST, pack, list(arg)),
2055 newSVOP(OP_METHOD_NAMED, 0, meth)));
2056 imop->op_private |= OPpENTERSUB_NOMOD;
2058 /* Combine the ops. */
2059 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2063 =notfor apidoc apply_attrs_string
2065 Attempts to apply a list of attributes specified by the C<attrstr> and
2066 C<len> arguments to the subroutine identified by the C<cv> argument which
2067 is expected to be associated with the package identified by the C<stashpv>
2068 argument (see L<attributes>). It gets this wrong, though, in that it
2069 does not correctly identify the boundaries of the individual attribute
2070 specifications within C<attrstr>. This is not really intended for the
2071 public API, but has to be listed here for systems such as AIX which
2072 need an explicit export list for symbols. (It's called from XS code
2073 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2074 to respect attribute syntax properly would be welcome.
2080 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2081 const char *attrstr, STRLEN len)
2085 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2088 len = strlen(attrstr);
2092 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2094 const char * const sstr = attrstr;
2095 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2096 attrs = op_append_elem(OP_LIST, attrs,
2097 newSVOP(OP_CONST, 0,
2098 newSVpvn(sstr, attrstr-sstr)));
2102 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2103 newSVpvs(ATTRSMODULE),
2104 NULL, op_prepend_elem(OP_LIST,
2105 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2106 op_prepend_elem(OP_LIST,
2107 newSVOP(OP_CONST, 0,
2108 newRV(MUTABLE_SV(cv))),
2113 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2118 PERL_ARGS_ASSERT_MY_KID;
2120 if (!o || (PL_parser && PL_parser->error_count))
2124 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2125 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2129 if (type == OP_LIST) {
2131 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2132 my_kid(kid, attrs, imopsp);
2133 } else if (type == OP_UNDEF
2139 } else if (type == OP_RV2SV || /* "our" declaration */
2141 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2142 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2143 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2145 PL_parser->in_my == KEY_our
2147 : PL_parser->in_my == KEY_state ? "state" : "my"));
2149 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2150 PL_parser->in_my = FALSE;
2151 PL_parser->in_my_stash = NULL;
2152 apply_attrs(GvSTASH(gv),
2153 (type == OP_RV2SV ? GvSV(gv) :
2154 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2155 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2158 o->op_private |= OPpOUR_INTRO;
2161 else if (type != OP_PADSV &&
2164 type != OP_PUSHMARK)
2166 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2168 PL_parser->in_my == KEY_our
2170 : PL_parser->in_my == KEY_state ? "state" : "my"));
2173 else if (attrs && type != OP_PUSHMARK) {
2176 PL_parser->in_my = FALSE;
2177 PL_parser->in_my_stash = NULL;
2179 /* check for C<my Dog $spot> when deciding package */
2180 stash = PAD_COMPNAME_TYPE(o->op_targ);
2182 stash = PL_curstash;
2183 apply_attrs_my(stash, o, attrs, imopsp);
2185 o->op_flags |= OPf_MOD;
2186 o->op_private |= OPpLVAL_INTRO;
2187 if (PL_parser->in_my == KEY_state)
2188 o->op_private |= OPpPAD_STATE;
2193 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2197 int maybe_scalar = 0;
2199 PERL_ARGS_ASSERT_MY_ATTRS;
2201 /* [perl #17376]: this appears to be premature, and results in code such as
2202 C< our(%x); > executing in list mode rather than void mode */
2204 if (o->op_flags & OPf_PARENS)
2214 o = my_kid(o, attrs, &rops);
2216 if (maybe_scalar && o->op_type == OP_PADSV) {
2217 o = scalar(op_append_list(OP_LIST, rops, o));
2218 o->op_private |= OPpLVAL_INTRO;
2221 o = op_append_list(OP_LIST, o, rops);
2223 PL_parser->in_my = FALSE;
2224 PL_parser->in_my_stash = NULL;
2229 Perl_sawparens(pTHX_ OP *o)
2231 PERL_UNUSED_CONTEXT;
2233 o->op_flags |= OPf_PARENS;
2238 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2242 const OPCODE ltype = left->op_type;
2243 const OPCODE rtype = right->op_type;
2245 PERL_ARGS_ASSERT_BIND_MATCH;
2247 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2248 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2250 const char * const desc
2251 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2252 ? (int)rtype : OP_MATCH];
2253 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2254 ? "@array" : "%hash");
2255 Perl_warner(aTHX_ packWARN(WARN_MISC),
2256 "Applying %s to %s will act on scalar(%s)",
2257 desc, sample, sample);
2260 if (rtype == OP_CONST &&
2261 cSVOPx(right)->op_private & OPpCONST_BARE &&
2262 cSVOPx(right)->op_private & OPpCONST_STRICT)
2264 no_bareword_allowed(right);
2267 /* !~ doesn't make sense with s///r, so error on it for now */
2268 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2270 yyerror("Using !~ with s///r doesn't make sense");
2272 ismatchop = (rtype == OP_MATCH ||
2273 rtype == OP_SUBST ||
2275 && !(right->op_flags & OPf_SPECIAL);
2276 if (ismatchop && right->op_private & OPpTARGET_MY) {
2278 right->op_private &= ~OPpTARGET_MY;
2280 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2283 right->op_flags |= OPf_STACKED;
2284 if (rtype != OP_MATCH &&
2285 ! (rtype == OP_TRANS &&
2286 right->op_private & OPpTRANS_IDENTICAL) &&
2287 ! (rtype == OP_SUBST &&
2288 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2289 newleft = mod(left, rtype);
2292 if (right->op_type == OP_TRANS)
2293 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2295 o = op_prepend_elem(rtype, scalar(newleft), right);
2297 return newUNOP(OP_NOT, 0, scalar(o));
2301 return bind_match(type, left,
2302 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2306 Perl_invert(pTHX_ OP *o)
2310 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2314 Perl_scope(pTHX_ OP *o)
2318 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2319 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2320 o->op_type = OP_LEAVE;
2321 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2323 else if (o->op_type == OP_LINESEQ) {
2325 o->op_type = OP_SCOPE;
2326 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2327 kid = ((LISTOP*)o)->op_first;
2328 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2331 /* The following deals with things like 'do {1 for 1}' */
2332 kid = kid->op_sibling;
2334 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2339 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2345 Perl_block_start(pTHX_ int full)
2348 const int retval = PL_savestack_ix;
2350 pad_block_start(full);
2352 PL_hints &= ~HINT_BLOCK_SCOPE;
2353 SAVECOMPILEWARNINGS();
2354 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2356 CALL_BLOCK_HOOKS(bhk_start, full);
2362 Perl_block_end(pTHX_ I32 floor, OP *seq)
2365 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2366 OP* retval = scalarseq(seq);
2368 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2371 CopHINTS_set(&PL_compiling, PL_hints);
2373 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2376 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2382 =head1 Compile-time scope hooks
2384 =for apidoc Ao||blockhook_register
2386 Register a set of hooks to be called when the Perl lexical scope changes
2387 at compile time. See L<perlguts/"Compile-time scope hooks">.
2393 Perl_blockhook_register(pTHX_ BHK *hk)
2395 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2397 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2404 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2405 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2406 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2409 OP * const o = newOP(OP_PADSV, 0);
2410 o->op_targ = offset;
2416 Perl_newPROG(pTHX_ OP *o)
2420 PERL_ARGS_ASSERT_NEWPROG;
2425 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2426 ((PL_in_eval & EVAL_KEEPERR)
2427 ? OPf_SPECIAL : 0), o);
2428 /* don't use LINKLIST, since PL_eval_root might indirect through
2429 * a rather expensive function call and LINKLIST evaluates its
2430 * argument more than once */
2431 PL_eval_start = op_linklist(PL_eval_root);
2432 PL_eval_root->op_private |= OPpREFCOUNTED;
2433 OpREFCNT_set(PL_eval_root, 1);
2434 PL_eval_root->op_next = 0;
2435 CALL_PEEP(PL_eval_start);
2438 if (o->op_type == OP_STUB) {
2439 PL_comppad_name = 0;
2441 S_op_destroy(aTHX_ o);
2444 PL_main_root = scope(sawparens(scalarvoid(o)));
2445 PL_curcop = &PL_compiling;
2446 PL_main_start = LINKLIST(PL_main_root);
2447 PL_main_root->op_private |= OPpREFCOUNTED;
2448 OpREFCNT_set(PL_main_root, 1);
2449 PL_main_root->op_next = 0;
2450 CALL_PEEP(PL_main_start);
2453 /* Register with debugger */
2455 CV * const cv = get_cvs("DB::postponed", 0);
2459 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2461 call_sv(MUTABLE_SV(cv), G_DISCARD);
2468 Perl_localize(pTHX_ OP *o, I32 lex)
2472 PERL_ARGS_ASSERT_LOCALIZE;
2474 if (o->op_flags & OPf_PARENS)
2475 /* [perl #17376]: this appears to be premature, and results in code such as
2476 C< our(%x); > executing in list mode rather than void mode */
2483 if ( PL_parser->bufptr > PL_parser->oldbufptr
2484 && PL_parser->bufptr[-1] == ','
2485 && ckWARN(WARN_PARENTHESIS))
2487 char *s = PL_parser->bufptr;
2490 /* some heuristics to detect a potential error */
2491 while (*s && (strchr(", \t\n", *s)))
2495 if (*s && strchr("@$%*", *s) && *++s
2496 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2499 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2501 while (*s && (strchr(", \t\n", *s)))
2507 if (sigil && (*s == ';' || *s == '=')) {
2508 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2509 "Parentheses missing around \"%s\" list",
2511 ? (PL_parser->in_my == KEY_our
2513 : PL_parser->in_my == KEY_state
2523 o = mod(o, OP_NULL); /* a bit kludgey */
2524 PL_parser->in_my = FALSE;
2525 PL_parser->in_my_stash = NULL;
2530 Perl_jmaybe(pTHX_ OP *o)
2532 PERL_ARGS_ASSERT_JMAYBE;
2534 if (o->op_type == OP_LIST) {
2536 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2537 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2543 S_fold_constants(pTHX_ register OP *o)
2546 register OP * VOL curop;
2548 VOL I32 type = o->op_type;
2553 SV * const oldwarnhook = PL_warnhook;
2554 SV * const olddiehook = PL_diehook;
2558 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2560 if (PL_opargs[type] & OA_RETSCALAR)
2562 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2563 o->op_targ = pad_alloc(type, SVs_PADTMP);
2565 /* integerize op, unless it happens to be C<-foo>.
2566 * XXX should pp_i_negate() do magic string negation instead? */
2567 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2568 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2569 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2571 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2574 if (!(PL_opargs[type] & OA_FOLDCONST))
2579 /* XXX might want a ck_negate() for this */
2580 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2591 /* XXX what about the numeric ops? */
2592 if (PL_hints & HINT_LOCALE)
2597 if (PL_parser && PL_parser->error_count)
2598 goto nope; /* Don't try to run w/ errors */
2600 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2601 const OPCODE type = curop->op_type;
2602 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2604 type != OP_SCALAR &&
2606 type != OP_PUSHMARK)
2612 curop = LINKLIST(o);
2613 old_next = o->op_next;
2617 oldscope = PL_scopestack_ix;
2618 create_eval_scope(G_FAKINGEVAL);
2620 /* Verify that we don't need to save it: */
2621 assert(PL_curcop == &PL_compiling);
2622 StructCopy(&PL_compiling, ¬_compiling, COP);
2623 PL_curcop = ¬_compiling;
2624 /* The above ensures that we run with all the correct hints of the
2625 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2626 assert(IN_PERL_RUNTIME);
2627 PL_warnhook = PERL_WARNHOOK_FATAL;
2634 sv = *(PL_stack_sp--);
2635 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2636 pad_swipe(o->op_targ, FALSE);
2637 else if (SvTEMP(sv)) { /* grab mortal temp? */
2638 SvREFCNT_inc_simple_void(sv);
2643 /* Something tried to die. Abandon constant folding. */
2644 /* Pretend the error never happened. */
2646 o->op_next = old_next;
2650 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2651 PL_warnhook = oldwarnhook;
2652 PL_diehook = olddiehook;
2653 /* XXX note that this croak may fail as we've already blown away
2654 * the stack - eg any nested evals */
2655 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2658 PL_warnhook = oldwarnhook;
2659 PL_diehook = olddiehook;
2660 PL_curcop = &PL_compiling;
2662 if (PL_scopestack_ix > oldscope)
2663 delete_eval_scope();
2672 if (type == OP_RV2GV)
2673 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2675 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2676 op_getmad(o,newop,'f');
2684 S_gen_constant_list(pTHX_ register OP *o)
2688 const I32 oldtmps_floor = PL_tmps_floor;
2691 if (PL_parser && PL_parser->error_count)
2692 return o; /* Don't attempt to run with errors */
2694 PL_op = curop = LINKLIST(o);
2700 assert (!(curop->op_flags & OPf_SPECIAL));
2701 assert(curop->op_type == OP_RANGE);
2703 PL_tmps_floor = oldtmps_floor;
2705 o->op_type = OP_RV2AV;
2706 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2707 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2708 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2709 o->op_opt = 0; /* needs to be revisited in rpeep() */
2710 curop = ((UNOP*)o)->op_first;
2711 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2713 op_getmad(curop,o,'O');
2722 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2725 if (!o || o->op_type != OP_LIST)
2726 o = newLISTOP(OP_LIST, 0, o, NULL);
2728 o->op_flags &= ~OPf_WANT;
2730 if (!(PL_opargs[type] & OA_MARK))
2731 op_null(cLISTOPo->op_first);
2733 o->op_type = (OPCODE)type;
2734 o->op_ppaddr = PL_ppaddr[type];
2735 o->op_flags |= flags;
2737 o = CHECKOP(type, o);
2738 if (o->op_type != (unsigned)type)
2741 return fold_constants(o);
2745 =head1 Optree Manipulation Functions
2748 /* List constructors */
2751 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2753 Append an item to the list of ops contained directly within a list-type
2754 op, returning the lengthened list. I<first> is the list-type op,
2755 and I<last> is the op to append to the list. I<optype> specifies the
2756 intended opcode for the list. If I<first> is not already a list of the
2757 right type, it will be upgraded into one. If either I<first> or I<last>
2758 is null, the other is returned unchanged.
2764 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2772 if (first->op_type != (unsigned)type
2773 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2775 return newLISTOP(type, 0, first, last);
2778 if (first->op_flags & OPf_KIDS)
2779 ((LISTOP*)first)->op_last->op_sibling = last;
2781 first->op_flags |= OPf_KIDS;
2782 ((LISTOP*)first)->op_first = last;
2784 ((LISTOP*)first)->op_last = last;
2789 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2791 Concatenate the lists of ops contained directly within two list-type ops,
2792 returning the combined list. I<first> and I<last> are the list-type ops
2793 to concatenate. I<optype> specifies the intended opcode for the list.
2794 If either I<first> or I<last> is not already a list of the right type,
2795 it will be upgraded into one. If either I<first> or I<last> is null,
2796 the other is returned unchanged.
2802 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2810 if (first->op_type != (unsigned)type)
2811 return op_prepend_elem(type, first, last);
2813 if (last->op_type != (unsigned)type)
2814 return op_append_elem(type, first, last);
2816 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2817 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2818 first->op_flags |= (last->op_flags & OPf_KIDS);
2821 if (((LISTOP*)last)->op_first && first->op_madprop) {
2822 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2824 while (mp->mad_next)
2826 mp->mad_next = first->op_madprop;
2829 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2832 first->op_madprop = last->op_madprop;
2833 last->op_madprop = 0;
2836 S_op_destroy(aTHX_ last);
2842 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2844 Prepend an item to the list of ops contained directly within a list-type
2845 op, returning the lengthened list. I<first> is the op to prepend to the
2846 list, and I<last> is the list-type op. I<optype> specifies the intended
2847 opcode for the list. If I<last> is not already a list of the right type,
2848 it will be upgraded into one. If either I<first> or I<last> is null,
2849 the other is returned unchanged.
2855 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2863 if (last->op_type == (unsigned)type) {
2864 if (type == OP_LIST) { /* already a PUSHMARK there */
2865 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2866 ((LISTOP*)last)->op_first->op_sibling = first;
2867 if (!(first->op_flags & OPf_PARENS))
2868 last->op_flags &= ~OPf_PARENS;
2871 if (!(last->op_flags & OPf_KIDS)) {
2872 ((LISTOP*)last)->op_last = first;
2873 last->op_flags |= OPf_KIDS;
2875 first->op_sibling = ((LISTOP*)last)->op_first;
2876 ((LISTOP*)last)->op_first = first;
2878 last->op_flags |= OPf_KIDS;
2882 return newLISTOP(type, 0, first, last);
2890 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2893 Newxz(tk, 1, TOKEN);
2894 tk->tk_type = (OPCODE)optype;
2895 tk->tk_type = 12345;
2897 tk->tk_mad = madprop;
2902 Perl_token_free(pTHX_ TOKEN* tk)
2904 PERL_ARGS_ASSERT_TOKEN_FREE;
2906 if (tk->tk_type != 12345)
2908 mad_free(tk->tk_mad);
2913 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2918 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2920 if (tk->tk_type != 12345) {
2921 Perl_warner(aTHX_ packWARN(WARN_MISC),
2922 "Invalid TOKEN object ignored");
2929 /* faked up qw list? */
2931 tm->mad_type == MAD_SV &&
2932 SvPVX((SV *)tm->mad_val)[0] == 'q')
2939 /* pretend constant fold didn't happen? */
2940 if (mp->mad_key == 'f' &&
2941 (o->op_type == OP_CONST ||
2942 o->op_type == OP_GV) )
2944 token_getmad(tk,(OP*)mp->mad_val,slot);
2958 if (mp->mad_key == 'X')
2959 mp->mad_key = slot; /* just change the first one */
2969 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2978 /* pretend constant fold didn't happen? */
2979 if (mp->mad_key == 'f' &&
2980 (o->op_type == OP_CONST ||
2981 o->op_type == OP_GV) )
2983 op_getmad(from,(OP*)mp->mad_val,slot);
2990 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2993 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2999 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3008 /* pretend constant fold didn't happen? */
3009 if (mp->mad_key == 'f' &&
3010 (o->op_type == OP_CONST ||
3011 o->op_type == OP_GV) )
3013 op_getmad(from,(OP*)mp->mad_val,slot);
3020 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3023 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3027 PerlIO_printf(PerlIO_stderr(),
3028 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3034 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3052 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3056 addmad(tm, &(o->op_madprop), slot);
3060 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3081 Perl_newMADsv(pTHX_ char key, SV* sv)
3083 PERL_ARGS_ASSERT_NEWMADSV;
3085 return newMADPROP(key, MAD_SV, sv, 0);
3089 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3092 Newxz(mp, 1, MADPROP);
3095 mp->mad_vlen = vlen;
3096 mp->mad_type = type;
3098 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3103 Perl_mad_free(pTHX_ MADPROP* mp)
3105 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3109 mad_free(mp->mad_next);
3110 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3111 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3112 switch (mp->mad_type) {
3116 Safefree((char*)mp->mad_val);
3119 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3120 op_free((OP*)mp->mad_val);
3123 sv_free(MUTABLE_SV(mp->mad_val));
3126 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3135 =head1 Optree construction
3137 =for apidoc Am|OP *|newNULLLIST
3139 Constructs, checks, and returns a new C<stub> op, which represents an
3140 empty list expression.
3146 Perl_newNULLLIST(pTHX)
3148 return newOP(OP_STUB, 0);
3152 S_force_list(pTHX_ OP *o)
3154 if (!o || o->op_type != OP_LIST)
3155 o = newLISTOP(OP_LIST, 0, o, NULL);
3161 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3163 Constructs, checks, and returns an op of any list type. I<type> is
3164 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3165 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3166 supply up to two ops to be direct children of the list op; they are
3167 consumed by this function and become part of the constructed op tree.
3173 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3178 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3180 NewOp(1101, listop, 1, LISTOP);
3182 listop->op_type = (OPCODE)type;
3183 listop->op_ppaddr = PL_ppaddr[type];
3186 listop->op_flags = (U8)flags;
3190 else if (!first && last)
3193 first->op_sibling = last;
3194 listop->op_first = first;
3195 listop->op_last = last;
3196 if (type == OP_LIST) {
3197 OP* const pushop = newOP(OP_PUSHMARK, 0);
3198 pushop->op_sibling = first;
3199 listop->op_first = pushop;
3200 listop->op_flags |= OPf_KIDS;
3202 listop->op_last = pushop;
3205 return CHECKOP(type, listop);
3209 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3211 Constructs, checks, and returns an op of any base type (any type that
3212 has no extra fields). I<type> is the opcode. I<flags> gives the
3213 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3220 Perl_newOP(pTHX_ I32 type, I32 flags)
3225 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3226 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3227 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3228 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3230 NewOp(1101, o, 1, OP);
3231 o->op_type = (OPCODE)type;
3232 o->op_ppaddr = PL_ppaddr[type];
3233 o->op_flags = (U8)flags;
3235 o->op_latefreed = 0;
3239 o->op_private = (U8)(0 | (flags >> 8));
3240 if (PL_opargs[type] & OA_RETSCALAR)
3242 if (PL_opargs[type] & OA_TARGET)
3243 o->op_targ = pad_alloc(type, SVs_PADTMP);
3244 return CHECKOP(type, o);
3248 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3250 Constructs, checks, and returns an op of any unary type. I<type> is
3251 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3252 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3253 bits, the eight bits of C<op_private>, except that the bit with value 1
3254 is automatically set. I<first> supplies an optional op to be the direct
3255 child of the unary op; it is consumed by this function and become part
3256 of the constructed op tree.
3262 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3267 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3268 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3269 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3270 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3271 || type == OP_SASSIGN
3272 || type == OP_ENTERTRY
3273 || type == OP_NULL );
3276 first = newOP(OP_STUB, 0);
3277 if (PL_opargs[type] & OA_MARK)
3278 first = force_list(first);
3280 NewOp(1101, unop, 1, UNOP);
3281 unop->op_type = (OPCODE)type;
3282 unop->op_ppaddr = PL_ppaddr[type];
3283 unop->op_first = first;
3284 unop->op_flags = (U8)(flags | OPf_KIDS);
3285 unop->op_private = (U8)(1 | (flags >> 8));
3286 unop = (UNOP*) CHECKOP(type, unop);
3290 return fold_constants((OP *) unop);
3294 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3296 Constructs, checks, and returns an op of any binary type. I<type>
3297 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3298 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3299 the eight bits of C<op_private>, except that the bit with value 1 or
3300 2 is automatically set as required. I<first> and I<last> supply up to
3301 two ops to be the direct children of the binary op; they are consumed
3302 by this function and become part of the constructed op tree.
3308 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3313 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3314 || type == OP_SASSIGN || type == OP_NULL );
3316 NewOp(1101, binop, 1, BINOP);
3319 first = newOP(OP_NULL, 0);
3321 binop->op_type = (OPCODE)type;
3322 binop->op_ppaddr = PL_ppaddr[type];
3323 binop->op_first = first;
3324 binop->op_flags = (U8)(flags | OPf_KIDS);
3327 binop->op_private = (U8)(1 | (flags >> 8));
3330 binop->op_private = (U8)(2 | (flags >> 8));
3331 first->op_sibling = last;
3334 binop = (BINOP*)CHECKOP(type, binop);
3335 if (binop->op_next || binop->op_type != (OPCODE)type)
3338 binop->op_last = binop->op_first->op_sibling;
3340 return fold_constants((OP *)binop);
3343 static int uvcompare(const void *a, const void *b)
3344 __attribute__nonnull__(1)
3345 __attribute__nonnull__(2)
3346 __attribute__pure__;
3347 static int uvcompare(const void *a, const void *b)
3349 if (*((const UV *)a) < (*(const UV *)b))
3351 if (*((const UV *)a) > (*(const UV *)b))
3353 if (*((const UV *)a+1) < (*(const UV *)b+1))
3355 if (*((const UV *)a+1) > (*(const UV *)b+1))
3361 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3364 SV * const tstr = ((SVOP*)expr)->op_sv;
3367 (repl->op_type == OP_NULL)
3368 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3370 ((SVOP*)repl)->op_sv;
3373 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3374 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3378 register short *tbl;
3380 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3381 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3382 I32 del = o->op_private & OPpTRANS_DELETE;
3385 PERL_ARGS_ASSERT_PMTRANS;
3387 PL_hints |= HINT_BLOCK_SCOPE;
3390 o->op_private |= OPpTRANS_FROM_UTF;
3393 o->op_private |= OPpTRANS_TO_UTF;
3395 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3396 SV* const listsv = newSVpvs("# comment\n");
3398 const U8* tend = t + tlen;
3399 const U8* rend = r + rlen;
3413 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3414 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3417 const U32 flags = UTF8_ALLOW_DEFAULT;
3421 t = tsave = bytes_to_utf8(t, &len);
3424 if (!to_utf && rlen) {
3426 r = rsave = bytes_to_utf8(r, &len);
3430 /* There are several snags with this code on EBCDIC:
3431 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3432 2. scan_const() in toke.c has encoded chars in native encoding which makes
3433 ranges at least in EBCDIC 0..255 range the bottom odd.
3437 U8 tmpbuf[UTF8_MAXBYTES+1];
3440 Newx(cp, 2*tlen, UV);
3442 transv = newSVpvs("");
3444 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3446 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3448 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3452 cp[2*i+1] = cp[2*i];
3456 qsort(cp, i, 2*sizeof(UV), uvcompare);
3457 for (j = 0; j < i; j++) {
3459 diff = val - nextmin;
3461 t = uvuni_to_utf8(tmpbuf,nextmin);
3462 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3464 U8 range_mark = UTF_TO_NATIVE(0xff);
3465 t = uvuni_to_utf8(tmpbuf, val - 1);
3466 sv_catpvn(transv, (char *)&range_mark, 1);
3467 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3474 t = uvuni_to_utf8(tmpbuf,nextmin);
3475 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3477 U8 range_mark = UTF_TO_NATIVE(0xff);
3478 sv_catpvn(transv, (char *)&range_mark, 1);
3480 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3481 UNICODE_ALLOW_SUPER);
3482 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3483 t = (const U8*)SvPVX_const(transv);
3484 tlen = SvCUR(transv);
3488 else if (!rlen && !del) {
3489 r = t; rlen = tlen; rend = tend;
3492 if ((!rlen && !del) || t == r ||
3493 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3495 o->op_private |= OPpTRANS_IDENTICAL;
3499 while (t < tend || tfirst <= tlast) {
3500 /* see if we need more "t" chars */
3501 if (tfirst > tlast) {
3502 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3504 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3506 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3513 /* now see if we need more "r" chars */
3514 if (rfirst > rlast) {
3516 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3518 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3520 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3529 rfirst = rlast = 0xffffffff;
3533 /* now see which range will peter our first, if either. */
3534 tdiff = tlast - tfirst;
3535 rdiff = rlast - rfirst;
3542 if (rfirst == 0xffffffff) {
3543 diff = tdiff; /* oops, pretend rdiff is infinite */
3545 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3546 (long)tfirst, (long)tlast);
3548 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3552 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3553 (long)tfirst, (long)(tfirst + diff),
3556 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3557 (long)tfirst, (long)rfirst);
3559 if (rfirst + diff > max)
3560 max = rfirst + diff;
3562 grows = (tfirst < rfirst &&
3563 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3575 else if (max > 0xff)
3580 PerlMemShared_free(cPVOPo->op_pv);
3581 cPVOPo->op_pv = NULL;
3583 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3585 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3586 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3587 PAD_SETSV(cPADOPo->op_padix, swash);
3589 SvREADONLY_on(swash);
3591 cSVOPo->op_sv = swash;
3593 SvREFCNT_dec(listsv);
3594 SvREFCNT_dec(transv);
3596 if (!del && havefinal && rlen)
3597 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3598 newSVuv((UV)final), 0);
3601 o->op_private |= OPpTRANS_GROWS;
3607 op_getmad(expr,o,'e');
3608 op_getmad(repl,o,'r');
3616 tbl = (short*)cPVOPo->op_pv;
3618 Zero(tbl, 256, short);
3619 for (i = 0; i < (I32)tlen; i++)
3621 for (i = 0, j = 0; i < 256; i++) {
3623 if (j >= (I32)rlen) {
3632 if (i < 128 && r[j] >= 128)
3642 o->op_private |= OPpTRANS_IDENTICAL;
3644 else if (j >= (I32)rlen)
3649 PerlMemShared_realloc(tbl,
3650 (0x101+rlen-j) * sizeof(short));
3651 cPVOPo->op_pv = (char*)tbl;
3653 tbl[0x100] = (short)(rlen - j);
3654 for (i=0; i < (I32)rlen - j; i++)
3655 tbl[0x101+i] = r[j+i];
3659 if (!rlen && !del) {
3662 o->op_private |= OPpTRANS_IDENTICAL;
3664 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3665 o->op_private |= OPpTRANS_IDENTICAL;
3667 for (i = 0; i < 256; i++)
3669 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3670 if (j >= (I32)rlen) {
3672 if (tbl[t[i]] == -1)
3678 if (tbl[t[i]] == -1) {
3679 if (t[i] < 128 && r[j] >= 128)
3686 if(del && rlen == tlen) {
3687 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3688 } else if(rlen > tlen) {
3689 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3693 o->op_private |= OPpTRANS_GROWS;
3695 op_getmad(expr,o,'e');
3696 op_getmad(repl,o,'r');
3706 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3708 Constructs, checks, and returns an op of any pattern matching type.
3709 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3710 and, shifted up eight bits, the eight bits of C<op_private>.
3716 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3721 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3723 NewOp(1101, pmop, 1, PMOP);
3724 pmop->op_type = (OPCODE)type;
3725 pmop->op_ppaddr = PL_ppaddr[type];
3726 pmop->op_flags = (U8)flags;
3727 pmop->op_private = (U8)(0 | (flags >> 8));
3729 if (PL_hints & HINT_RE_TAINT)
3730 pmop->op_pmflags |= PMf_RETAINT;
3731 if (PL_hints & HINT_LOCALE) {
3732 pmop->op_pmflags |= PMf_LOCALE;
3734 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3735 pmop->op_pmflags |= RXf_PMf_UNICODE;
3740 assert(SvPOK(PL_regex_pad[0]));
3741 if (SvCUR(PL_regex_pad[0])) {
3742 /* Pop off the "packed" IV from the end. */
3743 SV *const repointer_list = PL_regex_pad[0];
3744 const char *p = SvEND(repointer_list) - sizeof(IV);
3745 const IV offset = *((IV*)p);
3747 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3749 SvEND_set(repointer_list, p);
3751 pmop->op_pmoffset = offset;
3752 /* This slot should be free, so assert this: */
3753 assert(PL_regex_pad[offset] == &PL_sv_undef);
3755 SV * const repointer = &PL_sv_undef;
3756 av_push(PL_regex_padav, repointer);
3757 pmop->op_pmoffset = av_len(PL_regex_padav);
3758 PL_regex_pad = AvARRAY(PL_regex_padav);
3762 return CHECKOP(type, pmop);
3765 /* Given some sort of match op o, and an expression expr containing a
3766 * pattern, either compile expr into a regex and attach it to o (if it's
3767 * constant), or convert expr into a runtime regcomp op sequence (if it's
3770 * isreg indicates that the pattern is part of a regex construct, eg
3771 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3772 * split "pattern", which aren't. In the former case, expr will be a list
3773 * if the pattern contains more than one term (eg /a$b/) or if it contains
3774 * a replacement, ie s/// or tr///.
3778 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3783 I32 repl_has_vars = 0;
3787 PERL_ARGS_ASSERT_PMRUNTIME;
3789 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3790 /* last element in list is the replacement; pop it */
3792 repl = cLISTOPx(expr)->op_last;
3793 kid = cLISTOPx(expr)->op_first;
3794 while (kid->op_sibling != repl)
3795 kid = kid->op_sibling;
3796 kid->op_sibling = NULL;
3797 cLISTOPx(expr)->op_last = kid;
3800 if (isreg && expr->op_type == OP_LIST &&
3801 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3803 /* convert single element list to element */
3804 OP* const oe = expr;
3805 expr = cLISTOPx(oe)->op_first->op_sibling;
3806 cLISTOPx(oe)->op_first->op_sibling = NULL;
3807 cLISTOPx(oe)->op_last = NULL;
3811 if (o->op_type == OP_TRANS) {
3812 return pmtrans(o, expr, repl);
3815 reglist = isreg && expr->op_type == OP_LIST;
3819 PL_hints |= HINT_BLOCK_SCOPE;
3822 if (expr->op_type == OP_CONST) {
3823 SV *pat = ((SVOP*)expr)->op_sv;
3824 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3826 if (o->op_flags & OPf_SPECIAL)
3827 pm_flags |= RXf_SPLIT;
3830 assert (SvUTF8(pat));
3831 } else if (SvUTF8(pat)) {
3832 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3833 trapped in use 'bytes'? */
3834 /* Make a copy of the octet sequence, but without the flag on, as
3835 the compiler now honours the SvUTF8 flag on pat. */
3837 const char *const p = SvPV(pat, len);
3838 pat = newSVpvn_flags(p, len, SVs_TEMP);
3841 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3844 op_getmad(expr,(OP*)pm,'e');
3850 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3851 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3853 : OP_REGCMAYBE),0,expr);
3855 NewOp(1101, rcop, 1, LOGOP);
3856 rcop->op_type = OP_REGCOMP;
3857 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3858 rcop->op_first = scalar(expr);
3859 rcop->op_flags |= OPf_KIDS
3860 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3861 | (reglist ? OPf_STACKED : 0);
3862 rcop->op_private = 1;
3865 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3867 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3870 /* establish postfix order */
3871 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3873 rcop->op_next = expr;
3874 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3877 rcop->op_next = LINKLIST(expr);
3878 expr->op_next = (OP*)rcop;
3881 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3886 if (pm->op_pmflags & PMf_EVAL) {
3888 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3889 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3891 else if (repl->op_type == OP_CONST)
3895 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3896 if (curop->op_type == OP_SCOPE
3897 || curop->op_type == OP_LEAVE
3898 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3899 if (curop->op_type == OP_GV) {
3900 GV * const gv = cGVOPx_gv(curop);
3902 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3905 else if (curop->op_type == OP_RV2CV)
3907 else if (curop->op_type == OP_RV2SV ||
3908 curop->op_type == OP_RV2AV ||
3909 curop->op_type == OP_RV2HV ||
3910 curop->op_type == OP_RV2GV) {
3911 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3914 else if (curop->op_type == OP_PADSV ||
3915 curop->op_type == OP_PADAV ||
3916 curop->op_type == OP_PADHV ||
3917 curop->op_type == OP_PADANY)
3921 else if (curop->op_type == OP_PUSHRE)
3922 NOOP; /* Okay here, dangerous in newASSIGNOP */
3932 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3934 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3935 op_prepend_elem(o->op_type, scalar(repl), o);
3938 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3939 pm->op_pmflags |= PMf_MAYBE_CONST;
3941 NewOp(1101, rcop, 1, LOGOP);
3942 rcop->op_type = OP_SUBSTCONT;
3943 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3944 rcop->op_first = scalar(repl);
3945 rcop->op_flags |= OPf_KIDS;
3946 rcop->op_private = 1;
3949 /* establish postfix order */
3950 rcop->op_next = LINKLIST(repl);
3951 repl->op_next = (OP*)rcop;
3953 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3954 assert(!(pm->op_pmflags & PMf_ONCE));
3955 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3964 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
3966 Constructs, checks, and returns an op of any type that involves an
3967 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
3968 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
3969 takes ownership of one reference to it.
3975 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3980 PERL_ARGS_ASSERT_NEWSVOP;
3982 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3983 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3984 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3986 NewOp(1101, svop, 1, SVOP);
3987 svop->op_type = (OPCODE)type;
3988 svop->op_ppaddr = PL_ppaddr[type];
3990 svop->op_next = (OP*)svop;
3991 svop->op_flags = (U8)flags;
3992 if (PL_opargs[type] & OA_RETSCALAR)
3994 if (PL_opargs[type] & OA_TARGET)
3995 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3996 return CHECKOP(type, svop);
4002 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4004 Constructs, checks, and returns an op of any type that involves a
4005 reference to a pad element. I<type> is the opcode. I<flags> gives the
4006 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4007 is populated with I<sv>; this function takes ownership of one reference
4010 This function only exists if Perl has been compiled to use ithreads.
4016 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4021 PERL_ARGS_ASSERT_NEWPADOP;
4023 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4024 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4025 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4027 NewOp(1101, padop, 1, PADOP);
4028 padop->op_type = (OPCODE)type;
4029 padop->op_ppaddr = PL_ppaddr[type];
4030 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4031 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4032 PAD_SETSV(padop->op_padix, sv);
4035 padop->op_next = (OP*)padop;
4036 padop->op_flags = (U8)flags;
4037 if (PL_opargs[type] & OA_RETSCALAR)
4039 if (PL_opargs[type] & OA_TARGET)
4040 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4041 return CHECKOP(type, padop);
4044 #endif /* !USE_ITHREADS */
4047 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4049 Constructs, checks, and returns an op of any type that involves an
4050 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4051 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4052 reference; calling this function does not transfer ownership of any
4059 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4063 PERL_ARGS_ASSERT_NEWGVOP;
4067 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4069 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4074 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4076 Constructs, checks, and returns an op of any type that involves an
4077 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4078 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4079 must have been allocated using L</PerlMemShared_malloc>; the memory will
4080 be freed when the op is destroyed.
4086 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4091 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4092 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4094 NewOp(1101, pvop, 1, PVOP);
4095 pvop->op_type = (OPCODE)type;
4096 pvop->op_ppaddr = PL_ppaddr[type];
4098 pvop->op_next = (OP*)pvop;
4099 pvop->op_flags = (U8)flags;
4100 if (PL_opargs[type] & OA_RETSCALAR)
4102 if (PL_opargs[type] & OA_TARGET)
4103 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4104 return CHECKOP(type, pvop);
4112 Perl_package(pTHX_ OP *o)
4115 SV *const sv = cSVOPo->op_sv;
4120 PERL_ARGS_ASSERT_PACKAGE;
4122 save_hptr(&PL_curstash);
4123 save_item(PL_curstname);
4125 PL_curstash = gv_stashsv(sv, GV_ADD);
4127 sv_setsv(PL_curstname, sv);
4129 PL_hints |= HINT_BLOCK_SCOPE;
4130 PL_parser->copline = NOLINE;
4131 PL_parser->expect = XSTATE;
4136 if (!PL_madskills) {
4141 pegop = newOP(OP_NULL,0);
4142 op_getmad(o,pegop,'P');
4148 Perl_package_version( pTHX_ OP *v )
4151 U32 savehints = PL_hints;
4152 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4153 PL_hints &= ~HINT_STRICT_VARS;
4154 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4155 PL_hints = savehints;
4164 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4171 OP *pegop = newOP(OP_NULL,0);
4174 PERL_ARGS_ASSERT_UTILIZE;
4176 if (idop->op_type != OP_CONST)
4177 Perl_croak(aTHX_ "Module name must be constant");
4180 op_getmad(idop,pegop,'U');
4185 SV * const vesv = ((SVOP*)version)->op_sv;
4188 op_getmad(version,pegop,'V');
4189 if (!arg && !SvNIOKp(vesv)) {
4196 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4197 Perl_croak(aTHX_ "Version number must be a constant number");
4199 /* Make copy of idop so we don't free it twice */
4200 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4202 /* Fake up a method call to VERSION */
4203 meth = newSVpvs_share("VERSION");
4204 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4205 op_append_elem(OP_LIST,
4206 op_prepend_elem(OP_LIST, pack, list(version)),
4207 newSVOP(OP_METHOD_NAMED, 0, meth)));
4211 /* Fake up an import/unimport */
4212 if (arg && arg->op_type == OP_STUB) {
4214 op_getmad(arg,pegop,'S');
4215 imop = arg; /* no import on explicit () */
4217 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4218 imop = NULL; /* use 5.0; */
4220 idop->op_private |= OPpCONST_NOVER;
4226 op_getmad(arg,pegop,'A');
4228 /* Make copy of idop so we don't free it twice */
4229 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4231 /* Fake up a method call to import/unimport */
4233 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4234 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4235 op_append_elem(OP_LIST,
4236 op_prepend_elem(OP_LIST, pack, list(arg)),
4237 newSVOP(OP_METHOD_NAMED, 0, meth)));
4240 /* Fake up the BEGIN {}, which does its thing immediately. */
4242 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4245 op_append_elem(OP_LINESEQ,
4246 op_append_elem(OP_LINESEQ,
4247 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4248 newSTATEOP(0, NULL, veop)),
4249 newSTATEOP(0, NULL, imop) ));
4251 /* The "did you use incorrect case?" warning used to be here.
4252 * The problem is that on case-insensitive filesystems one
4253 * might get false positives for "use" (and "require"):
4254 * "use Strict" or "require CARP" will work. This causes
4255 * portability problems for the script: in case-strict
4256 * filesystems the script will stop working.
4258 * The "incorrect case" warning checked whether "use Foo"
4259 * imported "Foo" to your namespace, but that is wrong, too:
4260 * there is no requirement nor promise in the language that
4261 * a Foo.pm should or would contain anything in package "Foo".
4263 * There is very little Configure-wise that can be done, either:
4264 * the case-sensitivity of the build filesystem of Perl does not
4265 * help in guessing the case-sensitivity of the runtime environment.
4268 PL_hints |= HINT_BLOCK_SCOPE;
4269 PL_parser->copline = NOLINE;
4270 PL_parser->expect = XSTATE;
4271 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4274 if (!PL_madskills) {
4275 /* FIXME - don't allocate pegop if !PL_madskills */
4284 =head1 Embedding Functions
4286 =for apidoc load_module
4288 Loads the module whose name is pointed to by the string part of name.
4289 Note that the actual module name, not its filename, should be given.
4290 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4291 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4292 (or 0 for no flags). ver, if specified, provides version semantics
4293 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4294 arguments can be used to specify arguments to the module's import()
4295 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4296 terminated with a final NULL pointer. Note that this list can only
4297 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4298 Otherwise at least a single NULL pointer to designate the default
4299 import list is required.
4304 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4308 PERL_ARGS_ASSERT_LOAD_MODULE;
4310 va_start(args, ver);
4311 vload_module(flags, name, ver, &args);
4315 #ifdef PERL_IMPLICIT_CONTEXT
4317 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4321 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4322 va_start(args, ver);
4323 vload_module(flags, name, ver, &args);
4329 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4333 OP * const modname = newSVOP(OP_CONST, 0, name);
4335 PERL_ARGS_ASSERT_VLOAD_MODULE;
4337 modname->op_private |= OPpCONST_BARE;
4339 veop = newSVOP(OP_CONST, 0, ver);
4343 if (flags & PERL_LOADMOD_NOIMPORT) {
4344 imop = sawparens(newNULLLIST());
4346 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4347 imop = va_arg(*args, OP*);
4352 sv = va_arg(*args, SV*);
4354 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4355 sv = va_arg(*args, SV*);
4359 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4360 * that it has a PL_parser to play with while doing that, and also
4361 * that it doesn't mess with any existing parser, by creating a tmp
4362 * new parser with lex_start(). This won't actually be used for much,
4363 * since pp_require() will create another parser for the real work. */
4366 SAVEVPTR(PL_curcop);
4367 lex_start(NULL, NULL, FALSE);
4368 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4369 veop, modname, imop);
4374 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4380 PERL_ARGS_ASSERT_DOFILE;
4382 if (!force_builtin) {
4383 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4384 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4385 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4386 gv = gvp ? *gvp : NULL;
4390 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4391 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4392 op_append_elem(OP_LIST, term,
4393 scalar(newUNOP(OP_RV2CV, 0,
4394 newGVOP(OP_GV, 0, gv))))));
4397 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4403 =head1 Optree construction
4405 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4407 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4408 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4409 be set automatically, and, shifted up eight bits, the eight bits of
4410 C<op_private>, except that the bit with value 1 or 2 is automatically
4411 set as required. I<listval> and I<subscript> supply the parameters of
4412 the slice; they are consumed by this function and become part of the
4413 constructed op tree.
4419 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4421 return newBINOP(OP_LSLICE, flags,
4422 list(force_list(subscript)),
4423 list(force_list(listval)) );
4427 S_is_list_assignment(pTHX_ register const OP *o)
4435 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4436 o = cUNOPo->op_first;
4438 flags = o->op_flags;
4440 if (type == OP_COND_EXPR) {
4441 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4442 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4447 yyerror("Assignment to both a list and a scalar");
4451 if (type == OP_LIST &&
4452 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4453 o->op_private & OPpLVAL_INTRO)
4456 if (type == OP_LIST || flags & OPf_PARENS ||
4457 type == OP_RV2AV || type == OP_RV2HV ||
4458 type == OP_ASLICE || type == OP_HSLICE)
4461 if (type == OP_PADAV || type == OP_PADHV)
4464 if (type == OP_RV2SV)
4471 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4473 Constructs, checks, and returns an assignment op. I<left> and I<right>
4474 supply the parameters of the assignment; they are consumed by this
4475 function and become part of the constructed op tree.
4477 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4478 a suitable conditional optree is constructed. If I<optype> is the opcode
4479 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4480 performs the binary operation and assigns the result to the left argument.
4481 Either way, if I<optype> is non-zero then I<flags> has no effect.
4483 If I<optype> is zero, then a plain scalar or list assignment is
4484 constructed. Which type of assignment it is is automatically determined.
4485 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4486 will be set automatically, and, shifted up eight bits, the eight bits
4487 of C<op_private>, except that the bit with value 1 or 2 is automatically
4494 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4500 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4501 return newLOGOP(optype, 0,
4502 mod(scalar(left), optype),
4503 newUNOP(OP_SASSIGN, 0, scalar(right)));
4506 return newBINOP(optype, OPf_STACKED,
4507 mod(scalar(left), optype), scalar(right));
4511 if (is_list_assignment(left)) {
4512 static const char no_list_state[] = "Initialization of state variables"
4513 " in list context currently forbidden";
4515 bool maybe_common_vars = TRUE;
4518 /* Grandfathering $[ assignment here. Bletch.*/
4519 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4520 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4521 left = mod(left, OP_AASSIGN);
4524 else if (left->op_type == OP_CONST) {
4525 deprecate("assignment to $[");
4527 /* Result of assignment is always 1 (or we'd be dead already) */
4528 return newSVOP(OP_CONST, 0, newSViv(1));
4530 curop = list(force_list(left));
4531 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4532 o->op_private = (U8)(0 | (flags >> 8));
4534 if ((left->op_type == OP_LIST
4535 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4537 OP* lop = ((LISTOP*)left)->op_first;
4538 maybe_common_vars = FALSE;
4540 if (lop->op_type == OP_PADSV ||
4541 lop->op_type == OP_PADAV ||
4542 lop->op_type == OP_PADHV ||
4543 lop->op_type == OP_PADANY) {
4544 if (!(lop->op_private & OPpLVAL_INTRO))
4545 maybe_common_vars = TRUE;
4547 if (lop->op_private & OPpPAD_STATE) {
4548 if (left->op_private & OPpLVAL_INTRO) {
4549 /* Each variable in state($a, $b, $c) = ... */
4552 /* Each state variable in
4553 (state $a, my $b, our $c, $d, undef) = ... */
4555 yyerror(no_list_state);
4557 /* Each my variable in
4558 (state $a, my $b, our $c, $d, undef) = ... */
4560 } else if (lop->op_type == OP_UNDEF ||
4561 lop->op_type == OP_PUSHMARK) {
4562 /* undef may be interesting in
4563 (state $a, undef, state $c) */
4565 /* Other ops in the list. */
4566 maybe_common_vars = TRUE;
4568 lop = lop->op_sibling;
4571 else if ((left->op_private & OPpLVAL_INTRO)
4572 && ( left->op_type == OP_PADSV
4573 || left->op_type == OP_PADAV
4574 || left->op_type == OP_PADHV
4575 || left->op_type == OP_PADANY))
4577 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4578 if (left->op_private & OPpPAD_STATE) {
4579 /* All single variable list context state assignments, hence
4589 yyerror(no_list_state);
4593 /* PL_generation sorcery:
4594 * an assignment like ($a,$b) = ($c,$d) is easier than
4595 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4596 * To detect whether there are common vars, the global var
4597 * PL_generation is incremented for each assign op we compile.
4598 * Then, while compiling the assign op, we run through all the
4599 * variables on both sides of the assignment, setting a spare slot
4600 * in each of them to PL_generation. If any of them already have
4601 * that value, we know we've got commonality. We could use a
4602 * single bit marker, but then we'd have to make 2 passes, first
4603 * to clear the flag, then to test and set it. To find somewhere
4604 * to store these values, evil chicanery is done with SvUVX().
4607 if (maybe_common_vars) {
4610 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4611 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4612 if (curop->op_type == OP_GV) {
4613 GV *gv = cGVOPx_gv(curop);
4615 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4617 GvASSIGN_GENERATION_set(gv, PL_generation);
4619 else if (curop->op_type == OP_PADSV ||
4620 curop->op_type == OP_PADAV ||
4621 curop->op_type == OP_PADHV ||
4622 curop->op_type == OP_PADANY)
4624 if (PAD_COMPNAME_GEN(curop->op_targ)
4625 == (STRLEN)PL_generation)
4627 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4630 else if (curop->op_type == OP_RV2CV)
4632 else if (curop->op_type == OP_RV2SV ||
4633 curop->op_type == OP_RV2AV ||
4634 curop->op_type == OP_RV2HV ||
4635 curop->op_type == OP_RV2GV) {
4636 if (lastop->op_type != OP_GV) /* funny deref? */
4639 else if (curop->op_type == OP_PUSHRE) {
4641 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4642 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4644 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4646 GvASSIGN_GENERATION_set(gv, PL_generation);
4650 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4653 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4655 GvASSIGN_GENERATION_set(gv, PL_generation);
4665 o->op_private |= OPpASSIGN_COMMON;
4668 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4669 OP* tmpop = ((LISTOP*)right)->op_first;
4670 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4671 PMOP * const pm = (PMOP*)tmpop;
4672 if (left->op_type == OP_RV2AV &&
4673 !(left->op_private & OPpLVAL_INTRO) &&
4674 !(o->op_private & OPpASSIGN_COMMON) )
4676 tmpop = ((UNOP*)left)->op_first;
4677 if (tmpop->op_type == OP_GV
4679 && !pm->op_pmreplrootu.op_pmtargetoff
4681 && !pm->op_pmreplrootu.op_pmtargetgv
4685 pm->op_pmreplrootu.op_pmtargetoff
4686 = cPADOPx(tmpop)->op_padix;
4687 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4689 pm->op_pmreplrootu.op_pmtargetgv
4690 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4691 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4693 pm->op_pmflags |= PMf_ONCE;
4694 tmpop = cUNOPo->op_first; /* to list (nulled) */
4695 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4696 tmpop->op_sibling = NULL; /* don't free split */
4697 right->op_next = tmpop->op_next; /* fix starting loc */
4698 op_free(o); /* blow off assign */
4699 right->op_flags &= ~OPf_WANT;
4700 /* "I don't know and I don't care." */
4705 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4706 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4708 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4709 if (SvIOK(sv) && SvIVX(sv) == 0)
4710 sv_setiv(sv, PL_modcount+1);
4718 right = newOP(OP_UNDEF, 0);
4719 if (right->op_type == OP_READLINE) {
4720 right->op_flags |= OPf_STACKED;
4721 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4724 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4725 o = newBINOP(OP_SASSIGN, flags,
4726 scalar(right), mod(scalar(left), OP_SASSIGN) );
4730 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4731 deprecate("assignment to $[");
4733 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4734 o->op_private |= OPpCONST_ARYBASE;
4742 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4744 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4745 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4746 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4747 If I<label> is non-null, it supplies the name of a label to attach to
4748 the state op; this function takes ownership of the memory pointed at by
4749 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4752 If I<o> is null, the state op is returned. Otherwise the state op is
4753 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4754 is consumed by this function and becomes part of the returned op tree.
4760 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4763 const U32 seq = intro_my();
4766 NewOp(1101, cop, 1, COP);
4767 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4768 cop->op_type = OP_DBSTATE;
4769 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4772 cop->op_type = OP_NEXTSTATE;
4773 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4775 cop->op_flags = (U8)flags;
4776 CopHINTS_set(cop, PL_hints);
4778 cop->op_private |= NATIVE_HINTS;
4780 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4781 cop->op_next = (OP*)cop;
4784 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4785 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4787 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4788 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4789 if (cop->cop_hints_hash) {
4791 cop->cop_hints_hash->refcounted_he_refcnt++;
4792 HINTS_REFCNT_UNLOCK;
4795 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4797 PL_hints |= HINT_BLOCK_SCOPE;
4798 /* It seems that we need to defer freeing this pointer, as other parts
4799 of the grammar end up wanting to copy it after this op has been
4804 if (PL_parser && PL_parser->copline == NOLINE)
4805 CopLINE_set(cop, CopLINE(PL_curcop));
4807 CopLINE_set(cop, PL_parser->copline);
4809 PL_parser->copline = NOLINE;
4812 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4814 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4816 CopSTASH_set(cop, PL_curstash);
4818 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4819 /* this line can have a breakpoint - store the cop in IV */
4820 AV *av = CopFILEAVx(PL_curcop);
4822 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4823 if (svp && *svp != &PL_sv_undef ) {
4824 (void)SvIOK_on(*svp);
4825 SvIV_set(*svp, PTR2IV(cop));
4830 if (flags & OPf_SPECIAL)
4832 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4836 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4838 Constructs, checks, and returns a logical (flow control) op. I<type>
4839 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4840 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4841 the eight bits of C<op_private>, except that the bit with value 1 is
4842 automatically set. I<first> supplies the expression controlling the
4843 flow, and I<other> supplies the side (alternate) chain of ops; they are
4844 consumed by this function and become part of the constructed op tree.
4850 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4854 PERL_ARGS_ASSERT_NEWLOGOP;
4856 return new_logop(type, flags, &first, &other);
4860 S_search_const(pTHX_ OP *o)
4862 PERL_ARGS_ASSERT_SEARCH_CONST;
4864 switch (o->op_type) {
4868 if (o->op_flags & OPf_KIDS)
4869 return search_const(cUNOPo->op_first);
4876 if (!(o->op_flags & OPf_KIDS))
4878 kid = cLISTOPo->op_first;
4880 switch (kid->op_type) {
4884 kid = kid->op_sibling;
4887 if (kid != cLISTOPo->op_last)
4893 kid = cLISTOPo->op_last;
4895 return search_const(kid);
4903 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4911 int prepend_not = 0;
4913 PERL_ARGS_ASSERT_NEW_LOGOP;
4918 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4919 return newBINOP(type, flags, scalar(first), scalar(other));
4921 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4923 scalarboolean(first);
4924 /* optimize AND and OR ops that have NOTs as children */
4925 if (first->op_type == OP_NOT
4926 && (first->op_flags & OPf_KIDS)
4927 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4928 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4930 if (type == OP_AND || type == OP_OR) {
4936 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4938 prepend_not = 1; /* prepend a NOT op later */
4942 /* search for a constant op that could let us fold the test */
4943 if ((cstop = search_const(first))) {
4944 if (cstop->op_private & OPpCONST_STRICT)
4945 no_bareword_allowed(cstop);
4946 else if ((cstop->op_private & OPpCONST_BARE))
4947 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4948 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4949 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4950 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4952 if (other->op_type == OP_CONST)
4953 other->op_private |= OPpCONST_SHORTCIRCUIT;
4955 OP *newop = newUNOP(OP_NULL, 0, other);
4956 op_getmad(first, newop, '1');
4957 newop->op_targ = type; /* set "was" field */
4961 if (other->op_type == OP_LEAVE)
4962 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4963 else if (other->op_type == OP_MATCH
4964 || other->op_type == OP_SUBST
4965 || other->op_type == OP_TRANS)
4966 /* Mark the op as being unbindable with =~ */
4967 other->op_flags |= OPf_SPECIAL;
4971 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4972 const OP *o2 = other;
4973 if ( ! (o2->op_type == OP_LIST
4974 && (( o2 = cUNOPx(o2)->op_first))
4975 && o2->op_type == OP_PUSHMARK
4976 && (( o2 = o2->op_sibling)) )
4979 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4980 || o2->op_type == OP_PADHV)
4981 && o2->op_private & OPpLVAL_INTRO
4982 && !(o2->op_private & OPpPAD_STATE))
4984 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4985 "Deprecated use of my() in false conditional");
4989 if (first->op_type == OP_CONST)
4990 first->op_private |= OPpCONST_SHORTCIRCUIT;
4992 first = newUNOP(OP_NULL, 0, first);
4993 op_getmad(other, first, '2');
4994 first->op_targ = type; /* set "was" field */
5001 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5002 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5004 const OP * const k1 = ((UNOP*)first)->op_first;
5005 const OP * const k2 = k1->op_sibling;
5007 switch (first->op_type)
5010 if (k2 && k2->op_type == OP_READLINE
5011 && (k2->op_flags & OPf_STACKED)
5012 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5014 warnop = k2->op_type;
5019 if (k1->op_type == OP_READDIR
5020 || k1->op_type == OP_GLOB
5021 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5022 || k1->op_type == OP_EACH)
5024 warnop = ((k1->op_type == OP_NULL)
5025 ? (OPCODE)k1->op_targ : k1->op_type);
5030 const line_t oldline = CopLINE(PL_curcop);
5031 CopLINE_set(PL_curcop, PL_parser->copline);
5032 Perl_warner(aTHX_ packWARN(WARN_MISC),
5033 "Value of %s%s can be \"0\"; test with defined()",
5035 ((warnop == OP_READLINE || warnop == OP_GLOB)
5036 ? " construct" : "() operator"));
5037 CopLINE_set(PL_curcop, oldline);
5044 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5045 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5047 NewOp(1101, logop, 1, LOGOP);
5049 logop->op_type = (OPCODE)type;
5050 logop->op_ppaddr = PL_ppaddr[type];
5051 logop->op_first = first;
5052 logop->op_flags = (U8)(flags | OPf_KIDS);
5053 logop->op_other = LINKLIST(other);
5054 logop->op_private = (U8)(1 | (flags >> 8));
5056 /* establish postfix order */
5057 logop->op_next = LINKLIST(first);
5058 first->op_next = (OP*)logop;
5059 first->op_sibling = other;
5061 CHECKOP(type,logop);
5063 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5070 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5072 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5073 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5074 will be set automatically, and, shifted up eight bits, the eight bits of
5075 C<op_private>, except that the bit with value 1 is automatically set.
5076 I<first> supplies the expression selecting between the two branches,
5077 and I<trueop> and I<falseop> supply the branches; they are consumed by
5078 this function and become part of the constructed op tree.
5084 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5092 PERL_ARGS_ASSERT_NEWCONDOP;
5095 return newLOGOP(OP_AND, 0, first, trueop);
5097 return newLOGOP(OP_OR, 0, first, falseop);
5099 scalarboolean(first);
5100 if ((cstop = search_const(first))) {
5101 /* Left or right arm of the conditional? */
5102 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5103 OP *live = left ? trueop : falseop;
5104 OP *const dead = left ? falseop : trueop;
5105 if (cstop->op_private & OPpCONST_BARE &&
5106 cstop->op_private & OPpCONST_STRICT) {
5107 no_bareword_allowed(cstop);
5110 /* This is all dead code when PERL_MAD is not defined. */
5111 live = newUNOP(OP_NULL, 0, live);
5112 op_getmad(first, live, 'C');
5113 op_getmad(dead, live, left ? 'e' : 't');
5118 if (live->op_type == OP_LEAVE)
5119 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5120 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5121 || live->op_type == OP_TRANS)
5122 /* Mark the op as being unbindable with =~ */
5123 live->op_flags |= OPf_SPECIAL;
5126 NewOp(1101, logop, 1, LOGOP);
5127 logop->op_type = OP_COND_EXPR;
5128 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5129 logop->op_first = first;
5130 logop->op_flags = (U8)(flags | OPf_KIDS);
5131 logop->op_private = (U8)(1 | (flags >> 8));
5132 logop->op_other = LINKLIST(trueop);
5133 logop->op_next = LINKLIST(falseop);
5135 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5138 /* establish postfix order */
5139 start = LINKLIST(first);
5140 first->op_next = (OP*)logop;
5142 first->op_sibling = trueop;
5143 trueop->op_sibling = falseop;
5144 o = newUNOP(OP_NULL, 0, (OP*)logop);
5146 trueop->op_next = falseop->op_next = o;
5153 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5155 Constructs and returns a C<range> op, with subordinate C<flip> and
5156 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5157 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5158 for both the C<flip> and C<range> ops, except that the bit with value
5159 1 is automatically set. I<left> and I<right> supply the expressions
5160 controlling the endpoints of the range; they are consumed by this function
5161 and become part of the constructed op tree.
5167 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5176 PERL_ARGS_ASSERT_NEWRANGE;
5178 NewOp(1101, range, 1, LOGOP);
5180 range->op_type = OP_RANGE;
5181 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5182 range->op_first = left;
5183 range->op_flags = OPf_KIDS;
5184 leftstart = LINKLIST(left);
5185 range->op_other = LINKLIST(right);
5186 range->op_private = (U8)(1 | (flags >> 8));
5188 left->op_sibling = right;
5190 range->op_next = (OP*)range;
5191 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5192 flop = newUNOP(OP_FLOP, 0, flip);
5193 o = newUNOP(OP_NULL, 0, flop);
5195 range->op_next = leftstart;
5197 left->op_next = flip;
5198 right->op_next = flop;
5200 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5201 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5202 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5203 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5205 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5206 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5209 if (!flip->op_private || !flop->op_private)
5210 LINKLIST(o); /* blow off optimizer unless constant */
5216 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5218 Constructs, checks, and returns an op tree expressing a loop. This is
5219 only a loop in the control flow through the op tree; it does not have
5220 the heavyweight loop structure that allows exiting the loop by C<last>
5221 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5222 top-level op, except that some bits will be set automatically as required.
5223 I<expr> supplies the expression controlling loop iteration, and I<block>
5224 supplies the body of the loop; they are consumed by this function and
5225 become part of the constructed op tree. I<debuggable> is currently
5226 unused and should always be 1.
5232 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5237 const bool once = block && block->op_flags & OPf_SPECIAL &&
5238 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5240 PERL_UNUSED_ARG(debuggable);
5243 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5244 return block; /* do {} while 0 does once */
5245 if (expr->op_type == OP_READLINE
5246 || expr->op_type == OP_READDIR
5247 || expr->op_type == OP_GLOB
5248 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5249 expr = newUNOP(OP_DEFINED, 0,
5250 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5251 } else if (expr->op_flags & OPf_KIDS) {
5252 const OP * const k1 = ((UNOP*)expr)->op_first;
5253 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5254 switch (expr->op_type) {
5256 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5257 && (k2->op_flags & OPf_STACKED)
5258 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5259 expr = newUNOP(OP_DEFINED, 0, expr);
5263 if (k1 && (k1->op_type == OP_READDIR
5264 || k1->op_type == OP_GLOB
5265 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5266 || k1->op_type == OP_EACH))
5267 expr = newUNOP(OP_DEFINED, 0, expr);
5273 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5274 * op, in listop. This is wrong. [perl #27024] */
5276 block = newOP(OP_NULL, 0);
5277 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5278 o = new_logop(OP_AND, 0, &expr, &listop);
5281 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5283 if (once && o != listop)
5284 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5287 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5289 o->op_flags |= flags;
5291 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5296 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|I32 whileline|OP *expr|OP *block|OP *cont|I32 has_my
5298 Constructs, checks, and returns an op tree expressing a C<while> loop.
5299 This is a heavyweight loop, with structure that allows exiting the loop
5300 by C<last> and suchlike.
5302 I<loop> is an optional preconstructed C<enterloop> op to use in the
5303 loop; if it is null then a suitable op will be constructed automatically.
5304 I<expr> supplies the loop's controlling expression. I<block> supplies the
5305 main body of the loop, and I<cont> optionally supplies a C<continue> block
5306 that operates as a second half of the body. All of these optree inputs
5307 are consumed by this function and become part of the constructed op tree.
5309 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5310 op and, shifted up eight bits, the eight bits of C<op_private> for
5311 the C<leaveloop> op, except that (in both cases) some bits will be set
5312 automatically. I<debuggable> is currently unused and should always be 1.
5313 I<whileline> is the line number that should be attributed to the loop's
5314 controlling expression. I<has_my> can be supplied as true to force the
5315 loop body to be enclosed in its own scope.
5321 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
5322 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
5331 PERL_UNUSED_ARG(debuggable);
5334 if (expr->op_type == OP_READLINE
5335 || expr->op_type == OP_READDIR
5336 || expr->op_type == OP_GLOB
5337 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5338 expr = newUNOP(OP_DEFINED, 0,
5339 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5340 } else if (expr->op_flags & OPf_KIDS) {
5341 const OP * const k1 = ((UNOP*)expr)->op_first;
5342 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5343 switch (expr->op_type) {
5345 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5346 && (k2->op_flags & OPf_STACKED)
5347 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5348 expr = newUNOP(OP_DEFINED, 0, expr);
5352 if (k1 && (k1->op_type == OP_READDIR
5353 || k1->op_type == OP_GLOB
5354 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5355 || k1->op_type == OP_EACH))
5356 expr = newUNOP(OP_DEFINED, 0, expr);
5363 block = newOP(OP_NULL, 0);
5364 else if (cont || has_my) {
5365 block = scope(block);
5369 next = LINKLIST(cont);
5372 OP * const unstack = newOP(OP_UNSTACK, 0);
5375 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5379 listop = op_append_list(OP_LINESEQ, block, cont);
5381 redo = LINKLIST(listop);
5384 PL_parser->copline = (line_t)whileline;
5386 o = new_logop(OP_AND, 0, &expr, &listop);
5387 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5388 op_free(expr); /* oops, it's a while (0) */
5390 return NULL; /* listop already freed by new_logop */
5393 ((LISTOP*)listop)->op_last->op_next =
5394 (o == listop ? redo : LINKLIST(o));
5400 NewOp(1101,loop,1,LOOP);
5401 loop->op_type = OP_ENTERLOOP;
5402 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5403 loop->op_private = 0;
5404 loop->op_next = (OP*)loop;
5407 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5409 loop->op_redoop = redo;
5410 loop->op_lastop = o;
5411 o->op_private |= loopflags;
5414 loop->op_nextop = next;
5416 loop->op_nextop = o;
5418 o->op_flags |= flags;
5419 o->op_private |= (flags >> 8);
5424 =for apidoc Am|OP *|newFOROP|I32 flags|char *label|line_t forline|OP *sv|OP *expr|OP *block|OP *cont
5426 Constructs, checks, and returns an op tree expressing a C<foreach>
5427 loop (iteration through a list of values). This is a heavyweight loop,
5428 with structure that allows exiting the loop by C<last> and suchlike.
5430 I<sv> optionally supplies the variable that will be aliased to each
5431 item in turn; if null, it defaults to C<$_> (either lexical or global).
5432 I<expr> supplies the list of values to iterate over. I<block> supplies
5433 the main body of the loop, and I<cont> optionally supplies a C<continue>
5434 block that operates as a second half of the body. All of these optree
5435 inputs are consumed by this function and become part of the constructed
5438 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5439 op and, shifted up eight bits, the eight bits of C<op_private> for
5440 the C<leaveloop> op, except that (in both cases) some bits will be set
5441 automatically. I<forline> is the line number that should be attributed
5442 to the loop's list expression. If I<label> is non-null, it supplies
5443 the name of a label to attach to the state op at the start of the loop;
5444 this function takes ownership of the memory pointed at by I<label>,
5451 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
5456 PADOFFSET padoff = 0;
5461 PERL_ARGS_ASSERT_NEWFOROP;
5464 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5465 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5466 sv->op_type = OP_RV2GV;
5467 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5469 /* The op_type check is needed to prevent a possible segfault
5470 * if the loop variable is undeclared and 'strict vars' is in
5471 * effect. This is illegal but is nonetheless parsed, so we
5472 * may reach this point with an OP_CONST where we're expecting
5475 if (cUNOPx(sv)->op_first->op_type == OP_GV
5476 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5477 iterpflags |= OPpITER_DEF;
5479 else if (sv->op_type == OP_PADSV) { /* private variable */
5480 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5481 padoff = sv->op_targ;
5491 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5493 SV *const namesv = PAD_COMPNAME_SV(padoff);
5495 const char *const name = SvPV_const(namesv, len);
5497 if (len == 2 && name[0] == '$' && name[1] == '_')
5498 iterpflags |= OPpITER_DEF;
5502 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5503 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5504 sv = newGVOP(OP_GV, 0, PL_defgv);
5509 iterpflags |= OPpITER_DEF;
5511 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5512 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5513 iterflags |= OPf_STACKED;
5515 else if (expr->op_type == OP_NULL &&
5516 (expr->op_flags & OPf_KIDS) &&
5517 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5519 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5520 * set the STACKED flag to indicate that these values are to be
5521 * treated as min/max values by 'pp_iterinit'.
5523 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5524 LOGOP* const range = (LOGOP*) flip->op_first;
5525 OP* const left = range->op_first;
5526 OP* const right = left->op_sibling;
5529 range->op_flags &= ~OPf_KIDS;
5530 range->op_first = NULL;
5532 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5533 listop->op_first->op_next = range->op_next;
5534 left->op_next = range->op_other;
5535 right->op_next = (OP*)listop;
5536 listop->op_next = listop->op_first;
5539 op_getmad(expr,(OP*)listop,'O');
5543 expr = (OP*)(listop);
5545 iterflags |= OPf_STACKED;
5548 expr = mod(force_list(expr), OP_GREPSTART);
5551 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5552 op_append_elem(OP_LIST, expr, scalar(sv))));
5553 assert(!loop->op_next);
5554 /* for my $x () sets OPpLVAL_INTRO;
5555 * for our $x () sets OPpOUR_INTRO */
5556 loop->op_private = (U8)iterpflags;
5557 #ifdef PL_OP_SLAB_ALLOC
5560 NewOp(1234,tmp,1,LOOP);
5561 Copy(loop,tmp,1,LISTOP);
5562 S_op_destroy(aTHX_ (OP*)loop);
5566 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5568 loop->op_targ = padoff;
5569 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5571 op_getmad(madsv, (OP*)loop, 'v');
5572 PL_parser->copline = forline;
5573 return newSTATEOP(0, label, wop);
5577 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5579 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5580 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5581 determining the target of the op; it is consumed by this function and
5582 become part of the constructed op tree.
5588 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5593 PERL_ARGS_ASSERT_NEWLOOPEX;
5595 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5597 if (type != OP_GOTO || label->op_type == OP_CONST) {
5598 /* "last()" means "last" */
5599 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5600 o = newOP(type, OPf_SPECIAL);
5602 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5603 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5607 op_getmad(label,o,'L');
5613 /* Check whether it's going to be a goto &function */
5614 if (label->op_type == OP_ENTERSUB
5615 && !(label->op_flags & OPf_STACKED))
5616 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5617 o = newUNOP(type, OPf_STACKED, label);
5619 PL_hints |= HINT_BLOCK_SCOPE;
5623 /* if the condition is a literal array or hash
5624 (or @{ ... } etc), make a reference to it.
5627 S_ref_array_or_hash(pTHX_ OP *cond)
5630 && (cond->op_type == OP_RV2AV
5631 || cond->op_type == OP_PADAV
5632 || cond->op_type == OP_RV2HV
5633 || cond->op_type == OP_PADHV))
5635 return newUNOP(OP_REFGEN,
5636 0, mod(cond, OP_REFGEN));
5639 && (cond->op_type == OP_ASLICE
5640 || cond->op_type == OP_HSLICE)) {
5642 /* anonlist now needs a list from this op, was previously used in
5644 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5645 cond->op_flags |= OPf_WANT_LIST;
5647 return newANONLIST(mod(cond, OP_ANONLIST));
5654 /* These construct the optree fragments representing given()
5657 entergiven and enterwhen are LOGOPs; the op_other pointer
5658 points up to the associated leave op. We need this so we
5659 can put it in the context and make break/continue work.
5660 (Also, of course, pp_enterwhen will jump straight to
5661 op_other if the match fails.)
5665 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5666 I32 enter_opcode, I32 leave_opcode,
5667 PADOFFSET entertarg)
5673 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5675 NewOp(1101, enterop, 1, LOGOP);
5676 enterop->op_type = (Optype)enter_opcode;
5677 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5678 enterop->op_flags = (U8) OPf_KIDS;
5679 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5680 enterop->op_private = 0;
5682 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5685 enterop->op_first = scalar(cond);
5686 cond->op_sibling = block;
5688 o->op_next = LINKLIST(cond);
5689 cond->op_next = (OP *) enterop;
5692 /* This is a default {} block */
5693 enterop->op_first = block;
5694 enterop->op_flags |= OPf_SPECIAL;
5696 o->op_next = (OP *) enterop;
5699 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5700 entergiven and enterwhen both
5703 enterop->op_next = LINKLIST(block);
5704 block->op_next = enterop->op_other = o;
5709 /* Does this look like a boolean operation? For these purposes
5710 a boolean operation is:
5711 - a subroutine call [*]
5712 - a logical connective
5713 - a comparison operator
5714 - a filetest operator, with the exception of -s -M -A -C
5715 - defined(), exists() or eof()
5716 - /$re/ or $foo =~ /$re/
5718 [*] possibly surprising
5721 S_looks_like_bool(pTHX_ const OP *o)
5725 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5727 switch(o->op_type) {
5730 return looks_like_bool(cLOGOPo->op_first);
5734 looks_like_bool(cLOGOPo->op_first)
5735 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5740 o->op_flags & OPf_KIDS
5741 && looks_like_bool(cUNOPo->op_first));
5745 case OP_NOT: case OP_XOR:
5747 case OP_EQ: case OP_NE: case OP_LT:
5748 case OP_GT: case OP_LE: case OP_GE:
5750 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5751 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5753 case OP_SEQ: case OP_SNE: case OP_SLT:
5754 case OP_SGT: case OP_SLE: case OP_SGE:
5758 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5759 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5760 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5761 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5762 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5763 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5764 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5765 case OP_FTTEXT: case OP_FTBINARY:
5767 case OP_DEFINED: case OP_EXISTS:
5768 case OP_MATCH: case OP_EOF:
5775 /* Detect comparisons that have been optimized away */
5776 if (cSVOPo->op_sv == &PL_sv_yes
5777 || cSVOPo->op_sv == &PL_sv_no)
5790 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5792 Constructs, checks, and returns an op tree expressing a C<given> block.
5793 I<cond> supplies the expression that will be locally assigned to a lexical
5794 variable, and I<block> supplies the body of the C<given> construct; they
5795 are consumed by this function and become part of the constructed op tree.
5796 I<defsv_off> is the pad offset of the scalar lexical variable that will
5803 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5806 PERL_ARGS_ASSERT_NEWGIVENOP;
5807 return newGIVWHENOP(
5808 ref_array_or_hash(cond),
5810 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5815 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5817 Constructs, checks, and returns an op tree expressing a C<when> block.
5818 I<cond> supplies the test expression, and I<block> supplies the block
5819 that will be executed if the test evaluates to true; they are consumed
5820 by this function and become part of the constructed op tree. I<cond>
5821 will be interpreted DWIMically, often as a comparison against C<$_>,
5822 and may be null to generate a C<default> block.
5828 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5830 const bool cond_llb = (!cond || looks_like_bool(cond));
5833 PERL_ARGS_ASSERT_NEWWHENOP;
5838 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5840 scalar(ref_array_or_hash(cond)));
5843 return newGIVWHENOP(
5845 op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5846 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5850 =head1 Embedding Functions
5852 =for apidoc cv_undef
5854 Clear out all the active components of a CV. This can happen either
5855 by an explicit C<undef &foo>, or by the reference count going to zero.
5856 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5857 children can still follow the full lexical scope chain.
5863 Perl_cv_undef(pTHX_ CV *cv)
5867 PERL_ARGS_ASSERT_CV_UNDEF;
5869 DEBUG_X(PerlIO_printf(Perl_debug_log,
5870 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5871 PTR2UV(cv), PTR2UV(PL_comppad))
5875 if (CvFILE(cv) && !CvISXSUB(cv)) {
5876 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5877 Safefree(CvFILE(cv));
5882 if (!CvISXSUB(cv) && CvROOT(cv)) {
5883 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5884 Perl_croak(aTHX_ "Can't undef active subroutine");
5887 PAD_SAVE_SETNULLPAD();
5889 op_free(CvROOT(cv));
5894 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5899 /* remove CvOUTSIDE unless this is an undef rather than a free */
5900 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5901 if (!CvWEAKOUTSIDE(cv))
5902 SvREFCNT_dec(CvOUTSIDE(cv));
5903 CvOUTSIDE(cv) = NULL;
5906 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5909 if (CvISXSUB(cv) && CvXSUB(cv)) {
5912 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
5913 * ref status of CvOUTSIDE and CvGV */
5914 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
5918 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5921 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5923 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5924 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5925 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5926 || (p && (len != SvCUR(cv) /* Not the same length. */
5927 || memNE(p, SvPVX_const(cv), len))))
5928 && ckWARN_d(WARN_PROTOTYPE)) {
5929 SV* const msg = sv_newmortal();
5933 gv_efullname3(name = sv_newmortal(), gv, NULL);
5934 sv_setpvs(msg, "Prototype mismatch:");
5936 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5938 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5940 sv_catpvs(msg, ": none");
5941 sv_catpvs(msg, " vs ");
5943 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5945 sv_catpvs(msg, "none");
5946 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5950 static void const_sv_xsub(pTHX_ CV* cv);
5954 =head1 Optree Manipulation Functions
5956 =for apidoc cv_const_sv
5958 If C<cv> is a constant sub eligible for inlining. returns the constant
5959 value returned by the sub. Otherwise, returns NULL.
5961 Constant subs can be created with C<newCONSTSUB> or as described in
5962 L<perlsub/"Constant Functions">.
5967 Perl_cv_const_sv(pTHX_ const CV *const cv)
5969 PERL_UNUSED_CONTEXT;
5972 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5974 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5977 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5978 * Can be called in 3 ways:
5981 * look for a single OP_CONST with attached value: return the value
5983 * cv && CvCLONE(cv) && !CvCONST(cv)
5985 * examine the clone prototype, and if contains only a single
5986 * OP_CONST referencing a pad const, or a single PADSV referencing
5987 * an outer lexical, return a non-zero value to indicate the CV is
5988 * a candidate for "constizing" at clone time
5992 * We have just cloned an anon prototype that was marked as a const
5993 * candidiate. Try to grab the current value, and in the case of
5994 * PADSV, ignore it if it has multiple references. Return the value.
5998 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6009 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6010 o = cLISTOPo->op_first->op_sibling;
6012 for (; o; o = o->op_next) {
6013 const OPCODE type = o->op_type;
6015 if (sv && o->op_next == o)
6017 if (o->op_next != o) {
6018 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
6020 if (type == OP_DBSTATE)
6023 if (type == OP_LEAVESUB || type == OP_RETURN)
6027 if (type == OP_CONST && cSVOPo->op_sv)
6029 else if (cv && type == OP_CONST) {
6030 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6034 else if (cv && type == OP_PADSV) {
6035 if (CvCONST(cv)) { /* newly cloned anon */
6036 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6037 /* the candidate should have 1 ref from this pad and 1 ref
6038 * from the parent */
6039 if (!sv || SvREFCNT(sv) != 2)
6046 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6047 sv = &PL_sv_undef; /* an arbitrary non-null value */
6062 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6065 /* This would be the return value, but the return cannot be reached. */
6066 OP* pegop = newOP(OP_NULL, 0);
6069 PERL_UNUSED_ARG(floor);
6079 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6081 NORETURN_FUNCTION_END;
6086 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
6088 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
6092 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6097 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6098 register CV *cv = NULL;
6100 /* If the subroutine has no body, no attributes, and no builtin attributes
6101 then it's just a sub declaration, and we may be able to get away with
6102 storing with a placeholder scalar in the symbol table, rather than a
6103 full GV and CV. If anything is present then it will take a full CV to
6105 const I32 gv_fetch_flags
6106 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6108 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6109 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6113 assert(proto->op_type == OP_CONST);
6114 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6120 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6122 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6123 SV * const sv = sv_newmortal();
6124 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6125 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6126 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6127 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6129 } else if (PL_curstash) {
6130 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6133 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6137 if (!PL_madskills) {
6146 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6147 maximum a prototype before. */
6148 if (SvTYPE(gv) > SVt_NULL) {
6149 if (!SvPOK((const SV *)gv)
6150 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6152 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6154 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6157 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6159 sv_setiv(MUTABLE_SV(gv), -1);
6161 SvREFCNT_dec(PL_compcv);
6162 cv = PL_compcv = NULL;
6166 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6168 if (!block || !ps || *ps || attrs
6169 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6171 || block->op_type == OP_NULL
6176 const_sv = op_const_sv(block, NULL);
6179 const bool exists = CvROOT(cv) || CvXSUB(cv);
6181 /* if the subroutine doesn't exist and wasn't pre-declared
6182 * with a prototype, assume it will be AUTOLOADed,
6183 * skipping the prototype check
6185 if (exists || SvPOK(cv))
6186 cv_ckproto_len(cv, gv, ps, ps_len);
6187 /* already defined (or promised)? */
6188 if (exists || GvASSUMECV(gv)) {
6191 || block->op_type == OP_NULL
6194 if (CvFLAGS(PL_compcv)) {
6195 /* might have had built-in attrs applied */
6196 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6197 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6198 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6200 /* just a "sub foo;" when &foo is already defined */
6201 SAVEFREESV(PL_compcv);
6206 && block->op_type != OP_NULL
6209 if (ckWARN(WARN_REDEFINE)
6211 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6213 const line_t oldline = CopLINE(PL_curcop);
6214 if (PL_parser && PL_parser->copline != NOLINE)
6215 CopLINE_set(PL_curcop, PL_parser->copline);
6216 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6217 CvCONST(cv) ? "Constant subroutine %s redefined"
6218 : "Subroutine %s redefined", name);
6219 CopLINE_set(PL_curcop, oldline);
6222 if (!PL_minus_c) /* keep old one around for madskills */
6225 /* (PL_madskills unset in used file.) */
6233 SvREFCNT_inc_simple_void_NN(const_sv);
6235 assert(!CvROOT(cv) && !CvCONST(cv));
6236 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6237 CvXSUBANY(cv).any_ptr = const_sv;
6238 CvXSUB(cv) = const_sv_xsub;
6244 cv = newCONSTSUB(NULL, name, const_sv);
6246 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6247 (CvGV(cv) && GvSTASH(CvGV(cv)))
6256 SvREFCNT_dec(PL_compcv);
6260 if (cv) { /* must reuse cv if autoloaded */
6261 /* transfer PL_compcv to cv */
6264 && block->op_type != OP_NULL
6267 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6269 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6270 if (!CvWEAKOUTSIDE(cv))
6271 SvREFCNT_dec(CvOUTSIDE(cv));
6272 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6273 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6274 CvOUTSIDE(PL_compcv) = 0;
6275 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6276 CvPADLIST(PL_compcv) = 0;
6277 /* inner references to PL_compcv must be fixed up ... */
6278 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6279 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6280 ++PL_sub_generation;
6282 sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
6285 /* Might have had built-in attributes applied -- propagate them. */
6286 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6288 /* ... before we throw it away */
6289 SvREFCNT_dec(PL_compcv);
6297 if (strEQ(name, "import")) {
6298 PL_formfeed = MUTABLE_SV(cv);
6299 /* diag_listed_as: SKIPME */
6300 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6304 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6309 CvFILE_set_from_cop(cv, PL_curcop);
6310 CvSTASH(cv) = PL_curstash;
6312 Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
6315 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6316 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6317 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6321 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6323 if (PL_parser && PL_parser->error_count) {
6327 const char *s = strrchr(name, ':');
6329 if (strEQ(s, "BEGIN")) {
6330 const char not_safe[] =
6331 "BEGIN not safe after errors--compilation aborted";
6332 if (PL_in_eval & EVAL_KEEPERR)
6333 Perl_croak(aTHX_ not_safe);
6335 /* force display of errors found but not reported */
6336 sv_catpv(ERRSV, not_safe);
6337 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6346 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6347 the debugger could be able to set a breakpoint in, so signal to
6348 pp_entereval that it should not throw away any saved lines at scope
6351 PL_breakable_sub_gen++;
6353 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6354 mod(scalarseq(block), OP_LEAVESUBLV));
6355 block->op_attached = 1;
6358 /* This makes sub {}; work as expected. */
6359 if (block->op_type == OP_STUB) {
6360 OP* const newblock = newSTATEOP(0, NULL, 0);
6362 op_getmad(block,newblock,'B');
6369 block->op_attached = 1;
6370 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6372 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6373 OpREFCNT_set(CvROOT(cv), 1);
6374 CvSTART(cv) = LINKLIST(CvROOT(cv));
6375 CvROOT(cv)->op_next = 0;
6376 CALL_PEEP(CvSTART(cv));
6378 /* now that optimizer has done its work, adjust pad values */
6380 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6383 assert(!CvCONST(cv));
6384 if (ps && !*ps && op_const_sv(block, cv))
6389 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6390 SV * const tmpstr = sv_newmortal();
6391 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6392 GV_ADDMULTI, SVt_PVHV);
6394 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6397 (long)CopLINE(PL_curcop));
6398 gv_efullname3(tmpstr, gv, NULL);
6399 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6400 SvCUR(tmpstr), sv, 0);
6401 hv = GvHVn(db_postponed);
6402 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6403 CV * const pcv = GvCV(db_postponed);
6409 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6414 if (name && ! (PL_parser && PL_parser->error_count))
6415 process_special_blocks(name, gv, cv);
6420 PL_parser->copline = NOLINE;
6426 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6429 const char *const colon = strrchr(fullname,':');
6430 const char *const name = colon ? colon + 1 : fullname;
6432 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6435 if (strEQ(name, "BEGIN")) {
6436 const I32 oldscope = PL_scopestack_ix;
6438 SAVECOPFILE(&PL_compiling);
6439 SAVECOPLINE(&PL_compiling);
6441 DEBUG_x( dump_sub(gv) );
6442 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6443 GvCV(gv) = 0; /* cv has been hijacked */
6444 call_list(oldscope, PL_beginav);
6446 PL_curcop = &PL_compiling;
6447 CopHINTS_set(&PL_compiling, PL_hints);
6454 if strEQ(name, "END") {
6455 DEBUG_x( dump_sub(gv) );
6456 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6459 } else if (*name == 'U') {
6460 if (strEQ(name, "UNITCHECK")) {
6461 /* It's never too late to run a unitcheck block */
6462 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6466 } else if (*name == 'C') {
6467 if (strEQ(name, "CHECK")) {
6469 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6470 "Too late to run CHECK block");
6471 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6475 } else if (*name == 'I') {
6476 if (strEQ(name, "INIT")) {
6478 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6479 "Too late to run INIT block");
6480 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6486 DEBUG_x( dump_sub(gv) );
6487 GvCV(gv) = 0; /* cv has been hijacked */
6492 =for apidoc newCONSTSUB
6494 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6495 eligible for inlining at compile-time.
6497 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6498 which won't be called if used as a destructor, but will suppress the overhead
6499 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6506 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6511 const char *const file = CopFILE(PL_curcop);
6513 SV *const temp_sv = CopFILESV(PL_curcop);
6514 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6519 if (IN_PERL_RUNTIME) {
6520 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6521 * an op shared between threads. Use a non-shared COP for our
6523 SAVEVPTR(PL_curcop);
6524 PL_curcop = &PL_compiling;
6526 SAVECOPLINE(PL_curcop);
6527 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6530 PL_hints &= ~HINT_BLOCK_SCOPE;
6533 SAVESPTR(PL_curstash);
6534 SAVECOPSTASH(PL_curcop);
6535 PL_curstash = stash;
6536 CopSTASH_set(PL_curcop,stash);
6539 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6540 and so doesn't get free()d. (It's expected to be from the C pre-
6541 processor __FILE__ directive). But we need a dynamically allocated one,
6542 and we need it to get freed. */
6543 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6544 XS_DYNAMIC_FILENAME);
6545 CvXSUBANY(cv).any_ptr = sv;
6550 CopSTASH_free(PL_curcop);
6558 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6559 const char *const filename, const char *const proto,
6562 CV *cv = newXS(name, subaddr, filename);
6564 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6566 if (flags & XS_DYNAMIC_FILENAME) {
6567 /* We need to "make arrangements" (ie cheat) to ensure that the
6568 filename lasts as long as the PVCV we just created, but also doesn't
6570 STRLEN filename_len = strlen(filename);
6571 STRLEN proto_and_file_len = filename_len;
6572 char *proto_and_file;
6576 proto_len = strlen(proto);
6577 proto_and_file_len += proto_len;
6579 Newx(proto_and_file, proto_and_file_len + 1, char);
6580 Copy(proto, proto_and_file, proto_len, char);
6581 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6584 proto_and_file = savepvn(filename, filename_len);
6587 /* This gets free()d. :-) */
6588 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6589 SV_HAS_TRAILING_NUL);
6591 /* This gives us the correct prototype, rather than one with the
6592 file name appended. */
6593 SvCUR_set(cv, proto_len);
6597 CvFILE(cv) = proto_and_file + proto_len;
6599 sv_setpv(MUTABLE_SV(cv), proto);
6605 =for apidoc U||newXS
6607 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6608 static storage, as it is used directly as CvFILE(), without a copy being made.
6614 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6617 GV * const gv = gv_fetchpv(name ? name :
6618 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6619 GV_ADDMULTI, SVt_PVCV);
6622 PERL_ARGS_ASSERT_NEWXS;
6625 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6627 if ((cv = (name ? GvCV(gv) : NULL))) {
6629 /* just a cached method */
6633 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6634 /* already defined (or promised) */
6635 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6636 if (ckWARN(WARN_REDEFINE)) {
6637 GV * const gvcv = CvGV(cv);
6639 HV * const stash = GvSTASH(gvcv);
6641 const char *redefined_name = HvNAME_get(stash);
6642 if ( strEQ(redefined_name,"autouse") ) {
6643 const line_t oldline = CopLINE(PL_curcop);
6644 if (PL_parser && PL_parser->copline != NOLINE)
6645 CopLINE_set(PL_curcop, PL_parser->copline);
6646 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6647 CvCONST(cv) ? "Constant subroutine %s redefined"
6648 : "Subroutine %s redefined"
6650 CopLINE_set(PL_curcop, oldline);
6660 if (cv) /* must reuse cv if autoloaded */
6663 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6667 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6673 (void)gv_fetchfile(filename);
6674 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6675 an external constant string */
6677 CvXSUB(cv) = subaddr;
6680 process_special_blocks(name, gv, cv);
6690 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6695 OP* pegop = newOP(OP_NULL, 0);
6699 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6700 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6703 if ((cv = GvFORM(gv))) {
6704 if (ckWARN(WARN_REDEFINE)) {
6705 const line_t oldline = CopLINE(PL_curcop);
6706 if (PL_parser && PL_parser->copline != NOLINE)
6707 CopLINE_set(PL_curcop, PL_parser->copline);
6709 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6710 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6712 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6713 "Format STDOUT redefined");
6715 CopLINE_set(PL_curcop, oldline);
6722 CvFILE_set_from_cop(cv, PL_curcop);
6725 pad_tidy(padtidy_FORMAT);
6726 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6727 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6728 OpREFCNT_set(CvROOT(cv), 1);
6729 CvSTART(cv) = LINKLIST(CvROOT(cv));
6730 CvROOT(cv)->op_next = 0;
6731 CALL_PEEP(CvSTART(cv));
6733 op_getmad(o,pegop,'n');
6734 op_getmad_weak(block, pegop, 'b');
6739 PL_parser->copline = NOLINE;
6747 Perl_newANONLIST(pTHX_ OP *o)
6749 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6753 Perl_newANONHASH(pTHX_ OP *o)
6755 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6759 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6761 return newANONATTRSUB(floor, proto, NULL, block);
6765 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6767 return newUNOP(OP_REFGEN, 0,
6768 newSVOP(OP_ANONCODE, 0,
6769 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6773 Perl_oopsAV(pTHX_ OP *o)
6777 PERL_ARGS_ASSERT_OOPSAV;
6779 switch (o->op_type) {
6781 o->op_type = OP_PADAV;
6782 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6783 return ref(o, OP_RV2AV);
6786 o->op_type = OP_RV2AV;
6787 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6792 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6799 Perl_oopsHV(pTHX_ OP *o)
6803 PERL_ARGS_ASSERT_OOPSHV;
6805 switch (o->op_type) {
6808 o->op_type = OP_PADHV;
6809 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6810 return ref(o, OP_RV2HV);
6814 o->op_type = OP_RV2HV;
6815 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6820 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6827 Perl_newAVREF(pTHX_ OP *o)
6831 PERL_ARGS_ASSERT_NEWAVREF;
6833 if (o->op_type == OP_PADANY) {
6834 o->op_type = OP_PADAV;
6835 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6838 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6839 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6840 "Using an array as a reference is deprecated");
6842 return newUNOP(OP_RV2AV, 0, scalar(o));
6846 Perl_newGVREF(pTHX_ I32 type, OP *o)
6848 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6849 return newUNOP(OP_NULL, 0, o);
6850 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6854 Perl_newHVREF(pTHX_ OP *o)
6858 PERL_ARGS_ASSERT_NEWHVREF;
6860 if (o->op_type == OP_PADANY) {
6861 o->op_type = OP_PADHV;
6862 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6865 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6866 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6867 "Using a hash as a reference is deprecated");
6869 return newUNOP(OP_RV2HV, 0, scalar(o));
6873 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6875 return newUNOP(OP_RV2CV, flags, scalar(o));
6879 Perl_newSVREF(pTHX_ OP *o)
6883 PERL_ARGS_ASSERT_NEWSVREF;
6885 if (o->op_type == OP_PADANY) {
6886 o->op_type = OP_PADSV;
6887 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6890 return newUNOP(OP_RV2SV, 0, scalar(o));
6893 /* Check routines. See the comments at the top of this file for details
6894 * on when these are called */
6897 Perl_ck_anoncode(pTHX_ OP *o)
6899 PERL_ARGS_ASSERT_CK_ANONCODE;
6901 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6903 cSVOPo->op_sv = NULL;
6908 Perl_ck_bitop(pTHX_ OP *o)
6912 PERL_ARGS_ASSERT_CK_BITOP;
6914 #define OP_IS_NUMCOMPARE(op) \
6915 ((op) == OP_LT || (op) == OP_I_LT || \
6916 (op) == OP_GT || (op) == OP_I_GT || \
6917 (op) == OP_LE || (op) == OP_I_LE || \
6918 (op) == OP_GE || (op) == OP_I_GE || \
6919 (op) == OP_EQ || (op) == OP_I_EQ || \
6920 (op) == OP_NE || (op) == OP_I_NE || \
6921 (op) == OP_NCMP || (op) == OP_I_NCMP)
6922 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6923 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6924 && (o->op_type == OP_BIT_OR
6925 || o->op_type == OP_BIT_AND
6926 || o->op_type == OP_BIT_XOR))
6928 const OP * const left = cBINOPo->op_first;
6929 const OP * const right = left->op_sibling;
6930 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6931 (left->op_flags & OPf_PARENS) == 0) ||
6932 (OP_IS_NUMCOMPARE(right->op_type) &&
6933 (right->op_flags & OPf_PARENS) == 0))
6934 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6935 "Possible precedence problem on bitwise %c operator",
6936 o->op_type == OP_BIT_OR ? '|'
6937 : o->op_type == OP_BIT_AND ? '&' : '^'
6944 Perl_ck_concat(pTHX_ OP *o)
6946 const OP * const kid = cUNOPo->op_first;
6948 PERL_ARGS_ASSERT_CK_CONCAT;
6949 PERL_UNUSED_CONTEXT;
6951 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6952 !(kUNOP->op_first->op_flags & OPf_MOD))
6953 o->op_flags |= OPf_STACKED;
6958 Perl_ck_spair(pTHX_ OP *o)
6962 PERL_ARGS_ASSERT_CK_SPAIR;
6964 if (o->op_flags & OPf_KIDS) {
6967 const OPCODE type = o->op_type;
6968 o = modkids(ck_fun(o), type);
6969 kid = cUNOPo->op_first;
6970 newop = kUNOP->op_first->op_sibling;
6972 const OPCODE type = newop->op_type;
6973 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6974 type == OP_PADAV || type == OP_PADHV ||
6975 type == OP_RV2AV || type == OP_RV2HV)
6979 op_getmad(kUNOP->op_first,newop,'K');
6981 op_free(kUNOP->op_first);
6983 kUNOP->op_first = newop;
6985 o->op_ppaddr = PL_ppaddr[++o->op_type];
6990 Perl_ck_delete(pTHX_ OP *o)
6992 PERL_ARGS_ASSERT_CK_DELETE;
6996 if (o->op_flags & OPf_KIDS) {
6997 OP * const kid = cUNOPo->op_first;
6998 switch (kid->op_type) {
7000 o->op_flags |= OPf_SPECIAL;
7003 o->op_private |= OPpSLICE;
7006 o->op_flags |= OPf_SPECIAL;
7011 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7014 if (kid->op_private & OPpLVAL_INTRO)
7015 o->op_private |= OPpLVAL_INTRO;
7022 Perl_ck_die(pTHX_ OP *o)
7024 PERL_ARGS_ASSERT_CK_DIE;
7027 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7033 Perl_ck_eof(pTHX_ OP *o)
7037 PERL_ARGS_ASSERT_CK_EOF;
7039 if (o->op_flags & OPf_KIDS) {
7040 if (cLISTOPo->op_first->op_type == OP_STUB) {
7042 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7044 op_getmad(o,newop,'O');
7056 Perl_ck_eval(pTHX_ OP *o)
7060 PERL_ARGS_ASSERT_CK_EVAL;
7062 PL_hints |= HINT_BLOCK_SCOPE;
7063 if (o->op_flags & OPf_KIDS) {
7064 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7067 o->op_flags &= ~OPf_KIDS;
7070 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7076 cUNOPo->op_first = 0;
7081 NewOp(1101, enter, 1, LOGOP);
7082 enter->op_type = OP_ENTERTRY;
7083 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7084 enter->op_private = 0;
7086 /* establish postfix order */
7087 enter->op_next = (OP*)enter;
7089 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7090 o->op_type = OP_LEAVETRY;
7091 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7092 enter->op_other = o;
7093 op_getmad(oldo,o,'O');
7107 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7108 op_getmad(oldo,o,'O');
7110 o->op_targ = (PADOFFSET)PL_hints;
7111 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7112 /* Store a copy of %^H that pp_entereval can pick up. */
7113 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7114 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7115 cUNOPo->op_first->op_sibling = hhop;
7116 o->op_private |= OPpEVAL_HAS_HH;
7122 Perl_ck_exit(pTHX_ OP *o)
7124 PERL_ARGS_ASSERT_CK_EXIT;
7127 HV * const table = GvHV(PL_hintgv);
7129 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7130 if (svp && *svp && SvTRUE(*svp))
7131 o->op_private |= OPpEXIT_VMSISH;
7133 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7139 Perl_ck_exec(pTHX_ OP *o)
7141 PERL_ARGS_ASSERT_CK_EXEC;
7143 if (o->op_flags & OPf_STACKED) {
7146 kid = cUNOPo->op_first->op_sibling;
7147 if (kid->op_type == OP_RV2GV)
7156 Perl_ck_exists(pTHX_ OP *o)
7160 PERL_ARGS_ASSERT_CK_EXISTS;
7163 if (o->op_flags & OPf_KIDS) {
7164 OP * const kid = cUNOPo->op_first;
7165 if (kid->op_type == OP_ENTERSUB) {
7166 (void) ref(kid, o->op_type);
7167 if (kid->op_type != OP_RV2CV
7168 && !(PL_parser && PL_parser->error_count))
7169 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7171 o->op_private |= OPpEXISTS_SUB;
7173 else if (kid->op_type == OP_AELEM)
7174 o->op_flags |= OPf_SPECIAL;
7175 else if (kid->op_type != OP_HELEM)
7176 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7184 Perl_ck_rvconst(pTHX_ register OP *o)
7187 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7189 PERL_ARGS_ASSERT_CK_RVCONST;
7191 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7192 if (o->op_type == OP_RV2CV)
7193 o->op_private &= ~1;
7195 if (kid->op_type == OP_CONST) {
7198 SV * const kidsv = kid->op_sv;
7200 /* Is it a constant from cv_const_sv()? */
7201 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7202 SV * const rsv = SvRV(kidsv);
7203 const svtype type = SvTYPE(rsv);
7204 const char *badtype = NULL;
7206 switch (o->op_type) {
7208 if (type > SVt_PVMG)
7209 badtype = "a SCALAR";
7212 if (type != SVt_PVAV)
7213 badtype = "an ARRAY";
7216 if (type != SVt_PVHV)
7220 if (type != SVt_PVCV)
7225 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7228 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7229 const char *badthing;
7230 switch (o->op_type) {
7232 badthing = "a SCALAR";
7235 badthing = "an ARRAY";
7238 badthing = "a HASH";
7246 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7247 SVfARG(kidsv), badthing);
7250 * This is a little tricky. We only want to add the symbol if we
7251 * didn't add it in the lexer. Otherwise we get duplicate strict
7252 * warnings. But if we didn't add it in the lexer, we must at
7253 * least pretend like we wanted to add it even if it existed before,
7254 * or we get possible typo warnings. OPpCONST_ENTERED says
7255 * whether the lexer already added THIS instance of this symbol.
7257 iscv = (o->op_type == OP_RV2CV) * 2;
7259 gv = gv_fetchsv(kidsv,
7260 iscv | !(kid->op_private & OPpCONST_ENTERED),
7263 : o->op_type == OP_RV2SV
7265 : o->op_type == OP_RV2AV
7267 : o->op_type == OP_RV2HV
7270 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7272 kid->op_type = OP_GV;
7273 SvREFCNT_dec(kid->op_sv);
7275 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7276 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7277 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7279 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7281 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7283 kid->op_private = 0;
7284 kid->op_ppaddr = PL_ppaddr[OP_GV];
7291 Perl_ck_ftst(pTHX_ OP *o)
7294 const I32 type = o->op_type;
7296 PERL_ARGS_ASSERT_CK_FTST;
7298 if (o->op_flags & OPf_REF) {
7301 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7302 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7303 const OPCODE kidtype = kid->op_type;
7305 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7306 OP * const newop = newGVOP(type, OPf_REF,
7307 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7309 op_getmad(o,newop,'O');
7315 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7316 o->op_private |= OPpFT_ACCESS;
7317 if (PL_check[kidtype] == Perl_ck_ftst
7318 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7319 o->op_private |= OPpFT_STACKED;
7327 if (type == OP_FTTTY)
7328 o = newGVOP(type, OPf_REF, PL_stdingv);
7330 o = newUNOP(type, 0, newDEFSVOP());
7331 op_getmad(oldo,o,'O');
7337 Perl_ck_fun(pTHX_ OP *o)
7340 const int type = o->op_type;
7341 register I32 oa = PL_opargs[type] >> OASHIFT;
7343 PERL_ARGS_ASSERT_CK_FUN;
7345 if (o->op_flags & OPf_STACKED) {
7346 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7349 return no_fh_allowed(o);
7352 if (o->op_flags & OPf_KIDS) {
7353 OP **tokid = &cLISTOPo->op_first;
7354 register OP *kid = cLISTOPo->op_first;
7358 if (kid->op_type == OP_PUSHMARK ||
7359 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7361 tokid = &kid->op_sibling;
7362 kid = kid->op_sibling;
7364 if (!kid && PL_opargs[type] & OA_DEFGV)
7365 *tokid = kid = newDEFSVOP();
7369 sibl = kid->op_sibling;
7371 if (!sibl && kid->op_type == OP_STUB) {
7378 /* list seen where single (scalar) arg expected? */
7379 if (numargs == 1 && !(oa >> 4)
7380 && kid->op_type == OP_LIST && type != OP_SCALAR)
7382 return too_many_arguments(o,PL_op_desc[type]);
7395 if ((type == OP_PUSH || type == OP_UNSHIFT)
7396 && !kid->op_sibling)
7397 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7398 "Useless use of %s with no values",
7401 if (kid->op_type == OP_CONST &&
7402 (kid->op_private & OPpCONST_BARE))
7404 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7405 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7406 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7407 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7408 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7410 op_getmad(kid,newop,'K');
7415 kid->op_sibling = sibl;
7418 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
7419 bad_type(numargs, "array", PL_op_desc[type], kid);
7423 if (kid->op_type == OP_CONST &&
7424 (kid->op_private & OPpCONST_BARE))
7426 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7427 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7428 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7429 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7430 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7432 op_getmad(kid,newop,'K');
7437 kid->op_sibling = sibl;
7440 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7441 bad_type(numargs, "hash", PL_op_desc[type], kid);
7446 OP * const newop = newUNOP(OP_NULL, 0, kid);
7447 kid->op_sibling = 0;
7449 newop->op_next = newop;
7451 kid->op_sibling = sibl;
7456 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7457 if (kid->op_type == OP_CONST &&
7458 (kid->op_private & OPpCONST_BARE))
7460 OP * const newop = newGVOP(OP_GV, 0,
7461 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7462 if (!(o->op_private & 1) && /* if not unop */
7463 kid == cLISTOPo->op_last)
7464 cLISTOPo->op_last = newop;
7466 op_getmad(kid,newop,'K');
7472 else if (kid->op_type == OP_READLINE) {
7473 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7474 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7477 I32 flags = OPf_SPECIAL;
7481 /* is this op a FH constructor? */
7482 if (is_handle_constructor(o,numargs)) {
7483 const char *name = NULL;
7487 /* Set a flag to tell rv2gv to vivify
7488 * need to "prove" flag does not mean something
7489 * else already - NI-S 1999/05/07
7492 if (kid->op_type == OP_PADSV) {
7494 = PAD_COMPNAME_SV(kid->op_targ);
7495 name = SvPV_const(namesv, len);
7497 else if (kid->op_type == OP_RV2SV
7498 && kUNOP->op_first->op_type == OP_GV)
7500 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7502 len = GvNAMELEN(gv);
7504 else if (kid->op_type == OP_AELEM
7505 || kid->op_type == OP_HELEM)
7508 OP *op = ((BINOP*)kid)->op_first;
7512 const char * const a =
7513 kid->op_type == OP_AELEM ?
7515 if (((op->op_type == OP_RV2AV) ||
7516 (op->op_type == OP_RV2HV)) &&
7517 (firstop = ((UNOP*)op)->op_first) &&
7518 (firstop->op_type == OP_GV)) {
7519 /* packagevar $a[] or $h{} */
7520 GV * const gv = cGVOPx_gv(firstop);
7528 else if (op->op_type == OP_PADAV
7529 || op->op_type == OP_PADHV) {
7530 /* lexicalvar $a[] or $h{} */
7531 const char * const padname =
7532 PAD_COMPNAME_PV(op->op_targ);
7541 name = SvPV_const(tmpstr, len);
7546 name = "__ANONIO__";
7553 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7554 namesv = PAD_SVl(targ);
7555 SvUPGRADE(namesv, SVt_PV);
7557 sv_setpvs(namesv, "$");
7558 sv_catpvn(namesv, name, len);
7561 kid->op_sibling = 0;
7562 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7563 kid->op_targ = targ;
7564 kid->op_private |= priv;
7566 kid->op_sibling = sibl;
7572 mod(scalar(kid), type);
7576 tokid = &kid->op_sibling;
7577 kid = kid->op_sibling;
7580 if (kid && kid->op_type != OP_STUB)
7581 return too_many_arguments(o,OP_DESC(o));
7582 o->op_private |= numargs;
7584 /* FIXME - should the numargs move as for the PERL_MAD case? */
7585 o->op_private |= numargs;
7587 return too_many_arguments(o,OP_DESC(o));
7591 else if (PL_opargs[type] & OA_DEFGV) {
7593 OP *newop = newUNOP(type, 0, newDEFSVOP());
7594 op_getmad(o,newop,'O');
7597 /* Ordering of these two is important to keep f_map.t passing. */
7599 return newUNOP(type, 0, newDEFSVOP());
7604 while (oa & OA_OPTIONAL)
7606 if (oa && oa != OA_LIST)
7607 return too_few_arguments(o,OP_DESC(o));
7613 Perl_ck_glob(pTHX_ OP *o)
7618 PERL_ARGS_ASSERT_CK_GLOB;
7621 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7622 op_append_elem(OP_GLOB, o, newDEFSVOP());
7624 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7625 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7627 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7630 #if !defined(PERL_EXTERNAL_GLOB)
7631 /* XXX this can be tightened up and made more failsafe. */
7632 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7635 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7636 newSVpvs("File::Glob"), NULL, NULL, NULL);
7637 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7638 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7639 GvCV(gv) = GvCV(glob_gv);
7640 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7641 GvIMPORTED_CV_on(gv);
7645 #endif /* PERL_EXTERNAL_GLOB */
7647 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7648 op_append_elem(OP_GLOB, o,
7649 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7650 o->op_type = OP_LIST;
7651 o->op_ppaddr = PL_ppaddr[OP_LIST];
7652 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7653 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7654 cLISTOPo->op_first->op_targ = 0;
7655 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7656 op_append_elem(OP_LIST, o,
7657 scalar(newUNOP(OP_RV2CV, 0,
7658 newGVOP(OP_GV, 0, gv)))));
7659 o = newUNOP(OP_NULL, 0, ck_subr(o));
7660 o->op_targ = OP_GLOB; /* hint at what it used to be */
7663 gv = newGVgen("main");
7665 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7671 Perl_ck_grep(pTHX_ OP *o)
7676 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7679 PERL_ARGS_ASSERT_CK_GREP;
7681 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7682 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7684 if (o->op_flags & OPf_STACKED) {
7687 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7688 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7689 return no_fh_allowed(o);
7690 for (k = kid; k; k = k->op_next) {
7693 NewOp(1101, gwop, 1, LOGOP);
7694 kid->op_next = (OP*)gwop;
7695 o->op_flags &= ~OPf_STACKED;
7697 kid = cLISTOPo->op_first->op_sibling;
7698 if (type == OP_MAPWHILE)
7703 if (PL_parser && PL_parser->error_count)
7705 kid = cLISTOPo->op_first->op_sibling;
7706 if (kid->op_type != OP_NULL)
7707 Perl_croak(aTHX_ "panic: ck_grep");
7708 kid = kUNOP->op_first;
7711 NewOp(1101, gwop, 1, LOGOP);
7712 gwop->op_type = type;
7713 gwop->op_ppaddr = PL_ppaddr[type];
7714 gwop->op_first = listkids(o);
7715 gwop->op_flags |= OPf_KIDS;
7716 gwop->op_other = LINKLIST(kid);
7717 kid->op_next = (OP*)gwop;
7718 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7719 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7720 o->op_private = gwop->op_private = 0;
7721 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7724 o->op_private = gwop->op_private = OPpGREP_LEX;
7725 gwop->op_targ = o->op_targ = offset;
7728 kid = cLISTOPo->op_first->op_sibling;
7729 if (!kid || !kid->op_sibling)
7730 return too_few_arguments(o,OP_DESC(o));
7731 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7732 mod(kid, OP_GREPSTART);
7738 Perl_ck_index(pTHX_ OP *o)
7740 PERL_ARGS_ASSERT_CK_INDEX;
7742 if (o->op_flags & OPf_KIDS) {
7743 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7745 kid = kid->op_sibling; /* get past "big" */
7746 if (kid && kid->op_type == OP_CONST)
7747 fbm_compile(((SVOP*)kid)->op_sv, 0);
7753 Perl_ck_lfun(pTHX_ OP *o)
7755 const OPCODE type = o->op_type;
7757 PERL_ARGS_ASSERT_CK_LFUN;
7759 return modkids(ck_fun(o), type);
7763 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7765 PERL_ARGS_ASSERT_CK_DEFINED;
7767 if ((o->op_flags & OPf_KIDS)) {
7768 switch (cUNOPo->op_first->op_type) {
7770 /* This is needed for
7771 if (defined %stash::)
7772 to work. Do not break Tk.
7774 break; /* Globals via GV can be undef */
7776 case OP_AASSIGN: /* Is this a good idea? */
7777 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7778 "defined(@array) is deprecated");
7779 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7780 "\t(Maybe you should just omit the defined()?)\n");
7784 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7785 "defined(%%hash) is deprecated");
7786 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7787 "\t(Maybe you should just omit the defined()?)\n");
7798 Perl_ck_readline(pTHX_ OP *o)
7800 PERL_ARGS_ASSERT_CK_READLINE;
7802 if (!(o->op_flags & OPf_KIDS)) {
7804 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7806 op_getmad(o,newop,'O');
7816 Perl_ck_rfun(pTHX_ OP *o)
7818 const OPCODE type = o->op_type;
7820 PERL_ARGS_ASSERT_CK_RFUN;
7822 return refkids(ck_fun(o), type);
7826 Perl_ck_listiob(pTHX_ OP *o)
7830 PERL_ARGS_ASSERT_CK_LISTIOB;
7832 kid = cLISTOPo->op_first;
7835 kid = cLISTOPo->op_first;
7837 if (kid->op_type == OP_PUSHMARK)
7838 kid = kid->op_sibling;
7839 if (kid && o->op_flags & OPf_STACKED)
7840 kid = kid->op_sibling;
7841 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7842 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7843 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7844 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7845 cLISTOPo->op_first->op_sibling = kid;
7846 cLISTOPo->op_last = kid;
7847 kid = kid->op_sibling;
7852 op_append_elem(o->op_type, o, newDEFSVOP());
7858 Perl_ck_smartmatch(pTHX_ OP *o)
7861 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7862 if (0 == (o->op_flags & OPf_SPECIAL)) {
7863 OP *first = cBINOPo->op_first;
7864 OP *second = first->op_sibling;
7866 /* Implicitly take a reference to an array or hash */
7867 first->op_sibling = NULL;
7868 first = cBINOPo->op_first = ref_array_or_hash(first);
7869 second = first->op_sibling = ref_array_or_hash(second);
7871 /* Implicitly take a reference to a regular expression */
7872 if (first->op_type == OP_MATCH) {
7873 first->op_type = OP_QR;
7874 first->op_ppaddr = PL_ppaddr[OP_QR];
7876 if (second->op_type == OP_MATCH) {
7877 second->op_type = OP_QR;
7878 second->op_ppaddr = PL_ppaddr[OP_QR];
7887 Perl_ck_sassign(pTHX_ OP *o)
7890 OP * const kid = cLISTOPo->op_first;
7892 PERL_ARGS_ASSERT_CK_SASSIGN;
7894 /* has a disposable target? */
7895 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7896 && !(kid->op_flags & OPf_STACKED)
7897 /* Cannot steal the second time! */
7898 && !(kid->op_private & OPpTARGET_MY)
7899 /* Keep the full thing for madskills */
7903 OP * const kkid = kid->op_sibling;
7905 /* Can just relocate the target. */
7906 if (kkid && kkid->op_type == OP_PADSV
7907 && !(kkid->op_private & OPpLVAL_INTRO))
7909 kid->op_targ = kkid->op_targ;
7911 /* Now we do not need PADSV and SASSIGN. */
7912 kid->op_sibling = o->op_sibling; /* NULL */
7913 cLISTOPo->op_first = NULL;
7916 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7920 if (kid->op_sibling) {
7921 OP *kkid = kid->op_sibling;
7922 if (kkid->op_type == OP_PADSV
7923 && (kkid->op_private & OPpLVAL_INTRO)
7924 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7925 const PADOFFSET target = kkid->op_targ;
7926 OP *const other = newOP(OP_PADSV,
7928 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7929 OP *const first = newOP(OP_NULL, 0);
7930 OP *const nullop = newCONDOP(0, first, o, other);
7931 OP *const condop = first->op_next;
7932 /* hijacking PADSTALE for uninitialized state variables */
7933 SvPADSTALE_on(PAD_SVl(target));
7935 condop->op_type = OP_ONCE;
7936 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7937 condop->op_targ = target;
7938 other->op_targ = target;
7940 /* Because we change the type of the op here, we will skip the
7941 assinment binop->op_last = binop->op_first->op_sibling; at the
7942 end of Perl_newBINOP(). So need to do it here. */
7943 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7952 Perl_ck_match(pTHX_ OP *o)
7956 PERL_ARGS_ASSERT_CK_MATCH;
7958 if (o->op_type != OP_QR && PL_compcv) {
7959 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7960 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7961 o->op_targ = offset;
7962 o->op_private |= OPpTARGET_MY;
7965 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7966 o->op_private |= OPpRUNTIME;
7971 Perl_ck_method(pTHX_ OP *o)
7973 OP * const kid = cUNOPo->op_first;
7975 PERL_ARGS_ASSERT_CK_METHOD;
7977 if (kid->op_type == OP_CONST) {
7978 SV* sv = kSVOP->op_sv;
7979 const char * const method = SvPVX_const(sv);
7980 if (!(strchr(method, ':') || strchr(method, '\''))) {
7982 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7983 sv = newSVpvn_share(method, SvCUR(sv), 0);
7986 kSVOP->op_sv = NULL;
7988 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7990 op_getmad(o,cmop,'O');
8001 Perl_ck_null(pTHX_ OP *o)
8003 PERL_ARGS_ASSERT_CK_NULL;
8004 PERL_UNUSED_CONTEXT;
8009 Perl_ck_open(pTHX_ OP *o)
8012 HV * const table = GvHV(PL_hintgv);
8014 PERL_ARGS_ASSERT_CK_OPEN;
8017 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8020 const char *d = SvPV_const(*svp, len);
8021 const I32 mode = mode_from_discipline(d, len);
8022 if (mode & O_BINARY)
8023 o->op_private |= OPpOPEN_IN_RAW;
8024 else if (mode & O_TEXT)
8025 o->op_private |= OPpOPEN_IN_CRLF;
8028 svp = hv_fetchs(table, "open_OUT", FALSE);
8031 const char *d = SvPV_const(*svp, len);
8032 const I32 mode = mode_from_discipline(d, len);
8033 if (mode & O_BINARY)
8034 o->op_private |= OPpOPEN_OUT_RAW;
8035 else if (mode & O_TEXT)
8036 o->op_private |= OPpOPEN_OUT_CRLF;
8039 if (o->op_type == OP_BACKTICK) {
8040 if (!(o->op_flags & OPf_KIDS)) {
8041 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8043 op_getmad(o,newop,'O');
8052 /* In case of three-arg dup open remove strictness
8053 * from the last arg if it is a bareword. */
8054 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8055 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8059 if ((last->op_type == OP_CONST) && /* The bareword. */
8060 (last->op_private & OPpCONST_BARE) &&
8061 (last->op_private & OPpCONST_STRICT) &&
8062 (oa = first->op_sibling) && /* The fh. */
8063 (oa = oa->op_sibling) && /* The mode. */
8064 (oa->op_type == OP_CONST) &&
8065 SvPOK(((SVOP*)oa)->op_sv) &&
8066 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8067 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8068 (last == oa->op_sibling)) /* The bareword. */
8069 last->op_private &= ~OPpCONST_STRICT;
8075 Perl_ck_repeat(pTHX_ OP *o)
8077 PERL_ARGS_ASSERT_CK_REPEAT;
8079 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8080 o->op_private |= OPpREPEAT_DOLIST;
8081 cBINOPo->op_first = force_list(cBINOPo->op_first);
8089 Perl_ck_require(pTHX_ OP *o)
8094 PERL_ARGS_ASSERT_CK_REQUIRE;
8096 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8097 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8099 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8100 SV * const sv = kid->op_sv;
8101 U32 was_readonly = SvREADONLY(sv);
8108 sv_force_normal_flags(sv, 0);
8109 assert(!SvREADONLY(sv));
8119 for (; s < end; s++) {
8120 if (*s == ':' && s[1] == ':') {
8122 Move(s+2, s+1, end - s - 1, char);
8127 sv_catpvs(sv, ".pm");
8128 SvFLAGS(sv) |= was_readonly;
8132 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8133 /* handle override, if any */
8134 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8135 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8136 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8137 gv = gvp ? *gvp : NULL;
8141 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8142 OP * const kid = cUNOPo->op_first;
8145 cUNOPo->op_first = 0;
8149 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8150 op_append_elem(OP_LIST, kid,
8151 scalar(newUNOP(OP_RV2CV, 0,
8154 op_getmad(o,newop,'O');
8158 return scalar(ck_fun(o));
8162 Perl_ck_return(pTHX_ OP *o)
8167 PERL_ARGS_ASSERT_CK_RETURN;
8169 kid = cLISTOPo->op_first->op_sibling;
8170 if (CvLVALUE(PL_compcv)) {
8171 for (; kid; kid = kid->op_sibling)
8172 mod(kid, OP_LEAVESUBLV);
8174 for (; kid; kid = kid->op_sibling)
8175 if ((kid->op_type == OP_NULL)
8176 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8177 /* This is a do block */
8178 OP *op = kUNOP->op_first;
8179 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8180 op = cUNOPx(op)->op_first;
8181 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8182 /* Force the use of the caller's context */
8183 op->op_flags |= OPf_SPECIAL;
8192 Perl_ck_select(pTHX_ OP *o)
8197 PERL_ARGS_ASSERT_CK_SELECT;
8199 if (o->op_flags & OPf_KIDS) {
8200 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8201 if (kid && kid->op_sibling) {
8202 o->op_type = OP_SSELECT;
8203 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8205 return fold_constants(o);
8209 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8210 if (kid && kid->op_type == OP_RV2GV)
8211 kid->op_private &= ~HINT_STRICT_REFS;
8216 Perl_ck_shift(pTHX_ OP *o)
8219 const I32 type = o->op_type;
8221 PERL_ARGS_ASSERT_CK_SHIFT;
8223 if (!(o->op_flags & OPf_KIDS)) {
8226 if (!CvUNIQUE(PL_compcv)) {
8227 o->op_flags |= OPf_SPECIAL;
8231 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8234 OP * const oldo = o;
8235 o = newUNOP(type, 0, scalar(argop));
8236 op_getmad(oldo,o,'O');
8241 return newUNOP(type, 0, scalar(argop));
8244 return scalar(modkids(ck_fun(o), type));
8248 Perl_ck_sort(pTHX_ OP *o)
8253 PERL_ARGS_ASSERT_CK_SORT;
8255 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8256 HV * const hinthv = GvHV(PL_hintgv);
8258 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8260 const I32 sorthints = (I32)SvIV(*svp);
8261 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8262 o->op_private |= OPpSORT_QSORT;
8263 if ((sorthints & HINT_SORT_STABLE) != 0)
8264 o->op_private |= OPpSORT_STABLE;
8269 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8271 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8272 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8274 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8276 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8278 if (kid->op_type == OP_SCOPE) {
8282 else if (kid->op_type == OP_LEAVE) {
8283 if (o->op_type == OP_SORT) {
8284 op_null(kid); /* wipe out leave */
8287 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8288 if (k->op_next == kid)
8290 /* don't descend into loops */
8291 else if (k->op_type == OP_ENTERLOOP
8292 || k->op_type == OP_ENTERITER)
8294 k = cLOOPx(k)->op_lastop;
8299 kid->op_next = 0; /* just disconnect the leave */
8300 k = kLISTOP->op_first;
8305 if (o->op_type == OP_SORT) {
8306 /* provide scalar context for comparison function/block */
8312 o->op_flags |= OPf_SPECIAL;
8314 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8317 firstkid = firstkid->op_sibling;
8320 /* provide list context for arguments */
8321 if (o->op_type == OP_SORT)
8328 S_simplify_sort(pTHX_ OP *o)
8331 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8337 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8339 if (!(o->op_flags & OPf_STACKED))
8341 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8342 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8343 kid = kUNOP->op_first; /* get past null */
8344 if (kid->op_type != OP_SCOPE)
8346 kid = kLISTOP->op_last; /* get past scope */
8347 switch(kid->op_type) {
8355 k = kid; /* remember this node*/
8356 if (kBINOP->op_first->op_type != OP_RV2SV)
8358 kid = kBINOP->op_first; /* get past cmp */
8359 if (kUNOP->op_first->op_type != OP_GV)
8361 kid = kUNOP->op_first; /* get past rv2sv */
8363 if (GvSTASH(gv) != PL_curstash)
8365 gvname = GvNAME(gv);
8366 if (*gvname == 'a' && gvname[1] == '\0')
8368 else if (*gvname == 'b' && gvname[1] == '\0')
8373 kid = k; /* back to cmp */
8374 if (kBINOP->op_last->op_type != OP_RV2SV)
8376 kid = kBINOP->op_last; /* down to 2nd arg */
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);
8385 ? !(*gvname == 'a' && gvname[1] == '\0')
8386 : !(*gvname == 'b' && gvname[1] == '\0'))
8388 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8390 o->op_private |= OPpSORT_DESCEND;
8391 if (k->op_type == OP_NCMP)
8392 o->op_private |= OPpSORT_NUMERIC;
8393 if (k->op_type == OP_I_NCMP)
8394 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8395 kid = cLISTOPo->op_first->op_sibling;
8396 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8398 op_getmad(kid,o,'S'); /* then delete it */
8400 op_free(kid); /* then delete it */
8405 Perl_ck_split(pTHX_ OP *o)
8410 PERL_ARGS_ASSERT_CK_SPLIT;
8412 if (o->op_flags & OPf_STACKED)
8413 return no_fh_allowed(o);
8415 kid = cLISTOPo->op_first;
8416 if (kid->op_type != OP_NULL)
8417 Perl_croak(aTHX_ "panic: ck_split");
8418 kid = kid->op_sibling;
8419 op_free(cLISTOPo->op_first);
8420 cLISTOPo->op_first = kid;
8422 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8423 cLISTOPo->op_last = kid; /* There was only one element previously */
8426 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8427 OP * const sibl = kid->op_sibling;
8428 kid->op_sibling = 0;
8429 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8430 if (cLISTOPo->op_first == cLISTOPo->op_last)
8431 cLISTOPo->op_last = kid;
8432 cLISTOPo->op_first = kid;
8433 kid->op_sibling = sibl;
8436 kid->op_type = OP_PUSHRE;
8437 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8439 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8440 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8441 "Use of /g modifier is meaningless in split");
8444 if (!kid->op_sibling)
8445 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8447 kid = kid->op_sibling;
8450 if (!kid->op_sibling)
8451 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8452 assert(kid->op_sibling);
8454 kid = kid->op_sibling;
8457 if (kid->op_sibling)
8458 return too_many_arguments(o,OP_DESC(o));
8464 Perl_ck_join(pTHX_ OP *o)
8466 const OP * const kid = cLISTOPo->op_first->op_sibling;
8468 PERL_ARGS_ASSERT_CK_JOIN;
8470 if (kid && kid->op_type == OP_MATCH) {
8471 if (ckWARN(WARN_SYNTAX)) {
8472 const REGEXP *re = PM_GETRE(kPMOP);
8473 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8474 const STRLEN len = re ? RX_PRELEN(re) : 6;
8475 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8476 "/%.*s/ should probably be written as \"%.*s\"",
8477 (int)len, pmstr, (int)len, pmstr);
8484 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8486 Examines an op, which is expected to identify a subroutine at runtime,
8487 and attempts to determine at compile time which subroutine it identifies.
8488 This is normally used during Perl compilation to determine whether
8489 a prototype can be applied to a function call. I<cvop> is the op
8490 being considered, normally an C<rv2cv> op. A pointer to the identified
8491 subroutine is returned, if it could be determined statically, and a null
8492 pointer is returned if it was not possible to determine statically.
8494 Currently, the subroutine can be identified statically if the RV that the
8495 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8496 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8497 suitable if the constant value must be an RV pointing to a CV. Details of
8498 this process may change in future versions of Perl. If the C<rv2cv> op
8499 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8500 the subroutine statically: this flag is used to suppress compile-time
8501 magic on a subroutine call, forcing it to use default runtime behaviour.
8503 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8504 of a GV reference is modified. If a GV was examined and its CV slot was
8505 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8506 If the op is not optimised away, and the CV slot is later populated with
8507 a subroutine having a prototype, that flag eventually triggers the warning
8508 "called too early to check prototype".
8510 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8511 of returning a pointer to the subroutine it returns a pointer to the
8512 GV giving the most appropriate name for the subroutine in this context.
8513 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8514 (C<CvANON>) subroutine that is referenced through a GV it will be the
8515 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8516 A null pointer is returned as usual if there is no statically-determinable
8523 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8528 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8529 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8530 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8531 if (cvop->op_type != OP_RV2CV)
8533 if (cvop->op_private & OPpENTERSUB_AMPER)
8535 if (!(cvop->op_flags & OPf_KIDS))
8537 rvop = cUNOPx(cvop)->op_first;
8538 switch (rvop->op_type) {
8540 gv = cGVOPx_gv(rvop);
8543 if (flags & RV2CVOPCV_MARK_EARLY)
8544 rvop->op_private |= OPpEARLY_CV;
8549 SV *rv = cSVOPx_sv(rvop);
8559 if (SvTYPE((SV*)cv) != SVt_PVCV)
8561 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8562 if (!CvANON(cv) || !gv)
8571 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8573 Performs the default fixup of the arguments part of an C<entersub>
8574 op tree. This consists of applying list context to each of the
8575 argument ops. This is the standard treatment used on a call marked
8576 with C<&>, or a method call, or a call through a subroutine reference,
8577 or any other call where the callee can't be identified at compile time,
8578 or a call where the callee has no prototype.
8584 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8587 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8588 aop = cUNOPx(entersubop)->op_first;
8589 if (!aop->op_sibling)
8590 aop = cUNOPx(aop)->op_first;
8591 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8592 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8594 mod(aop, OP_ENTERSUB);
8601 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8603 Performs the fixup of the arguments part of an C<entersub> op tree
8604 based on a subroutine prototype. This makes various modifications to
8605 the argument ops, from applying context up to inserting C<refgen> ops,
8606 and checking the number and syntactic types of arguments, as directed by
8607 the prototype. This is the standard treatment used on a subroutine call,
8608 not marked with C<&>, where the callee can be identified at compile time
8609 and has a prototype.
8611 I<protosv> supplies the subroutine prototype to be applied to the call.
8612 It may be a normal defined scalar, of which the string value will be used.
8613 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8614 that has been cast to C<SV*>) which has a prototype. The prototype
8615 supplied, in whichever form, does not need to match the actual callee
8616 referenced by the op tree.
8618 If the argument ops disagree with the prototype, for example by having
8619 an unacceptable number of arguments, a valid op tree is returned anyway.
8620 The error is reflected in the parser state, normally resulting in a single
8621 exception at the top level of parsing which covers all the compilation
8622 errors that occurred. In the error message, the callee is referred to
8623 by the name defined by the I<namegv> parameter.
8629 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8632 const char *proto, *proto_end;
8633 OP *aop, *prev, *cvop;
8636 I32 contextclass = 0;
8637 const char *e = NULL;
8638 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8639 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8640 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8641 proto = SvPV(protosv, proto_len);
8642 proto_end = proto + proto_len;
8643 aop = cUNOPx(entersubop)->op_first;
8644 if (!aop->op_sibling)
8645 aop = cUNOPx(aop)->op_first;
8647 aop = aop->op_sibling;
8648 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8649 while (aop != cvop) {
8651 if (PL_madskills && aop->op_type == OP_STUB) {
8652 aop = aop->op_sibling;
8655 if (PL_madskills && aop->op_type == OP_NULL)
8656 o3 = ((UNOP*)aop)->op_first;
8660 if (proto >= proto_end)
8661 return too_many_arguments(entersubop, gv_ename(namegv));
8669 /* _ must be at the end */
8670 if (proto[1] && proto[1] != ';')
8685 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8687 arg == 1 ? "block or sub {}" : "sub {}",
8688 gv_ename(namegv), o3);
8691 /* '*' allows any scalar type, including bareword */
8694 if (o3->op_type == OP_RV2GV)
8695 goto wrapref; /* autoconvert GLOB -> GLOBref */
8696 else if (o3->op_type == OP_CONST)
8697 o3->op_private &= ~OPpCONST_STRICT;
8698 else if (o3->op_type == OP_ENTERSUB) {
8699 /* accidental subroutine, revert to bareword */
8700 OP *gvop = ((UNOP*)o3)->op_first;
8701 if (gvop && gvop->op_type == OP_NULL) {
8702 gvop = ((UNOP*)gvop)->op_first;
8704 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8707 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8708 (gvop = ((UNOP*)gvop)->op_first) &&
8709 gvop->op_type == OP_GV)
8711 GV * const gv = cGVOPx_gv(gvop);
8712 OP * const sibling = aop->op_sibling;
8713 SV * const n = newSVpvs("");
8715 OP * const oldaop = aop;
8719 gv_fullname4(n, gv, "", FALSE);
8720 aop = newSVOP(OP_CONST, 0, n);
8721 op_getmad(oldaop,aop,'O');
8722 prev->op_sibling = aop;
8723 aop->op_sibling = sibling;
8739 if (contextclass++ == 0) {
8740 e = strchr(proto, ']');
8741 if (!e || e == proto)
8750 const char *p = proto;
8751 const char *const end = proto;
8753 while (*--p != '[') {}
8754 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8756 gv_ename(namegv), o3);
8761 if (o3->op_type == OP_RV2GV)
8764 bad_type(arg, "symbol", gv_ename(namegv), o3);
8767 if (o3->op_type == OP_ENTERSUB)
8770 bad_type(arg, "subroutine entry", gv_ename(namegv),
8774 if (o3->op_type == OP_RV2SV ||
8775 o3->op_type == OP_PADSV ||
8776 o3->op_type == OP_HELEM ||
8777 o3->op_type == OP_AELEM)
8780 bad_type(arg, "scalar", gv_ename(namegv), o3);
8783 if (o3->op_type == OP_RV2AV ||
8784 o3->op_type == OP_PADAV)
8787 bad_type(arg, "array", gv_ename(namegv), o3);
8790 if (o3->op_type == OP_RV2HV ||
8791 o3->op_type == OP_PADHV)
8794 bad_type(arg, "hash", gv_ename(namegv), o3);
8798 OP* const kid = aop;
8799 OP* const sib = kid->op_sibling;
8800 kid->op_sibling = 0;
8801 aop = newUNOP(OP_REFGEN, 0, kid);
8802 aop->op_sibling = sib;
8803 prev->op_sibling = aop;
8805 if (contextclass && e) {
8820 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8821 gv_ename(namegv), SVfARG(protosv));
8824 mod(aop, OP_ENTERSUB);
8826 aop = aop->op_sibling;
8828 if (aop == cvop && *proto == '_') {
8829 /* generate an access to $_ */
8831 aop->op_sibling = prev->op_sibling;
8832 prev->op_sibling = aop; /* instead of cvop */
8834 if (!optional && proto_end > proto &&
8835 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8836 return too_few_arguments(entersubop, gv_ename(namegv));
8841 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8843 Performs the fixup of the arguments part of an C<entersub> op tree either
8844 based on a subroutine prototype or using default list-context processing.
8845 This is the standard treatment used on a subroutine call, not marked
8846 with C<&>, where the callee can be identified at compile time.
8848 I<protosv> supplies the subroutine prototype to be applied to the call,
8849 or indicates that there is no prototype. It may be a normal scalar,
8850 in which case if it is defined then the string value will be used
8851 as a prototype, and if it is undefined then there is no prototype.
8852 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8853 that has been cast to C<SV*>), of which the prototype will be used if it
8854 has one. The prototype (or lack thereof) supplied, in whichever form,
8855 does not need to match the actual callee referenced by the op tree.
8857 If the argument ops disagree with the prototype, for example by having
8858 an unacceptable number of arguments, a valid op tree is returned anyway.
8859 The error is reflected in the parser state, normally resulting in a single
8860 exception at the top level of parsing which covers all the compilation
8861 errors that occurred. In the error message, the callee is referred to
8862 by the name defined by the I<namegv> parameter.
8868 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8869 GV *namegv, SV *protosv)
8871 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8872 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8873 return ck_entersub_args_proto(entersubop, namegv, protosv);
8875 return ck_entersub_args_list(entersubop);
8879 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8881 Retrieves the function that will be used to fix up a call to I<cv>.
8882 Specifically, the function is applied to an C<entersub> op tree for a
8883 subroutine call, not marked with C<&>, where the callee can be identified
8884 at compile time as I<cv>.
8886 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8887 argument for it is returned in I<*ckobj_p>. The function is intended
8888 to be called in this manner:
8890 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8892 In this call, I<entersubop> is a pointer to the C<entersub> op,
8893 which may be replaced by the check function, and I<namegv> is a GV
8894 supplying the name that should be used by the check function to refer
8895 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8896 It is permitted to apply the check function in non-standard situations,
8897 such as to a call to a different subroutine or to a method call.
8899 By default, the function is
8900 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8901 and the SV parameter is I<cv> itself. This implements standard
8902 prototype processing. It can be changed, for a particular subroutine,
8903 by L</cv_set_call_checker>.
8909 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8912 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8913 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8915 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8916 *ckobj_p = callmg->mg_obj;
8918 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8924 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8926 Sets the function that will be used to fix up a call to I<cv>.
8927 Specifically, the function is applied to an C<entersub> op tree for a
8928 subroutine call, not marked with C<&>, where the callee can be identified
8929 at compile time as I<cv>.
8931 The C-level function pointer is supplied in I<ckfun>, and an SV argument
8932 for it is supplied in I<ckobj>. The function is intended to be called
8935 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
8937 In this call, I<entersubop> is a pointer to the C<entersub> op,
8938 which may be replaced by the check function, and I<namegv> is a GV
8939 supplying the name that should be used by the check function to refer
8940 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8941 It is permitted to apply the check function in non-standard situations,
8942 such as to a call to a different subroutine or to a method call.
8944 The current setting for a particular CV can be retrieved by
8945 L</cv_get_call_checker>.
8951 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
8953 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
8954 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
8955 if (SvMAGICAL((SV*)cv))
8956 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
8959 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
8960 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
8961 if (callmg->mg_flags & MGf_REFCOUNTED) {
8962 SvREFCNT_dec(callmg->mg_obj);
8963 callmg->mg_flags &= ~MGf_REFCOUNTED;
8965 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
8966 callmg->mg_obj = ckobj;
8967 if (ckobj != (SV*)cv) {
8968 SvREFCNT_inc_simple_void_NN(ckobj);
8969 callmg->mg_flags |= MGf_REFCOUNTED;
8975 Perl_ck_subr(pTHX_ OP *o)
8981 PERL_ARGS_ASSERT_CK_SUBR;
8983 aop = cUNOPx(o)->op_first;
8984 if (!aop->op_sibling)
8985 aop = cUNOPx(aop)->op_first;
8986 aop = aop->op_sibling;
8987 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8988 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
8989 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
8991 o->op_private |= OPpENTERSUB_HASTARG;
8992 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8993 if (PERLDB_SUB && PL_curstash != PL_debstash)
8994 o->op_private |= OPpENTERSUB_DB;
8995 if (cvop->op_type == OP_RV2CV) {
8996 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
8998 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8999 if (aop->op_type == OP_CONST)
9000 aop->op_private &= ~OPpCONST_STRICT;
9001 else if (aop->op_type == OP_LIST) {
9002 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9003 if (sib && sib->op_type == OP_CONST)
9004 sib->op_private &= ~OPpCONST_STRICT;
9009 return ck_entersub_args_list(o);
9011 Perl_call_checker ckfun;
9013 cv_get_call_checker(cv, &ckfun, &ckobj);
9014 return ckfun(aTHX_ o, namegv, ckobj);
9019 Perl_ck_svconst(pTHX_ OP *o)
9021 PERL_ARGS_ASSERT_CK_SVCONST;
9022 PERL_UNUSED_CONTEXT;
9023 SvREADONLY_on(cSVOPo->op_sv);
9028 Perl_ck_chdir(pTHX_ OP *o)
9030 PERL_ARGS_ASSERT_CK_CHDIR;
9031 if (o->op_flags & OPf_KIDS) {
9032 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9034 if (kid && kid->op_type == OP_CONST &&
9035 (kid->op_private & OPpCONST_BARE))
9037 o->op_flags |= OPf_SPECIAL;
9038 kid->op_private &= ~OPpCONST_STRICT;
9045 Perl_ck_trunc(pTHX_ OP *o)
9047 PERL_ARGS_ASSERT_CK_TRUNC;
9049 if (o->op_flags & OPf_KIDS) {
9050 SVOP *kid = (SVOP*)cUNOPo->op_first;
9052 if (kid->op_type == OP_NULL)
9053 kid = (SVOP*)kid->op_sibling;
9054 if (kid && kid->op_type == OP_CONST &&
9055 (kid->op_private & OPpCONST_BARE))
9057 o->op_flags |= OPf_SPECIAL;
9058 kid->op_private &= ~OPpCONST_STRICT;
9065 Perl_ck_unpack(pTHX_ OP *o)
9067 OP *kid = cLISTOPo->op_first;
9069 PERL_ARGS_ASSERT_CK_UNPACK;
9071 if (kid->op_sibling) {
9072 kid = kid->op_sibling;
9073 if (!kid->op_sibling)
9074 kid->op_sibling = newDEFSVOP();
9080 Perl_ck_substr(pTHX_ OP *o)
9082 PERL_ARGS_ASSERT_CK_SUBSTR;
9085 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9086 OP *kid = cLISTOPo->op_first;
9088 if (kid->op_type == OP_NULL)
9089 kid = kid->op_sibling;
9091 kid->op_flags |= OPf_MOD;
9098 Perl_ck_each(pTHX_ OP *o)
9101 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9103 PERL_ARGS_ASSERT_CK_EACH;
9106 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
9107 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
9108 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9109 o->op_type = new_type;
9110 o->op_ppaddr = PL_ppaddr[new_type];
9112 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
9113 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
9115 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
9122 /* caller is supposed to assign the return to the
9123 container of the rep_op var */
9125 S_opt_scalarhv(pTHX_ OP *rep_op) {
9129 PERL_ARGS_ASSERT_OPT_SCALARHV;
9131 NewOp(1101, unop, 1, UNOP);
9132 unop->op_type = (OPCODE)OP_BOOLKEYS;
9133 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9134 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9135 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9136 unop->op_first = rep_op;
9137 unop->op_next = rep_op->op_next;
9138 rep_op->op_next = (OP*)unop;
9139 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9140 unop->op_sibling = rep_op->op_sibling;
9141 rep_op->op_sibling = NULL;
9142 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9143 if (rep_op->op_type == OP_PADHV) {
9144 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9145 rep_op->op_flags |= OPf_WANT_LIST;
9150 /* Checks if o acts as an in-place operator on an array. oright points to the
9151 * beginning of the right-hand side. Returns the left-hand side of the
9152 * assignment if o acts in-place, or NULL otherwise. */
9155 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9159 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9162 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9163 || oright->op_next != o
9164 || (oright->op_private & OPpLVAL_INTRO)
9168 /* o2 follows the chain of op_nexts through the LHS of the
9169 * assign (if any) to the aassign op itself */
9171 if (!o2 || o2->op_type != OP_NULL)
9174 if (!o2 || o2->op_type != OP_PUSHMARK)
9177 if (o2 && o2->op_type == OP_GV)
9180 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9181 || (o2->op_private & OPpLVAL_INTRO)
9186 if (!o2 || o2->op_type != OP_NULL)
9189 if (!o2 || o2->op_type != OP_AASSIGN
9190 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9193 /* check that the sort is the first arg on RHS of assign */
9195 o2 = cUNOPx(o2)->op_first;
9196 if (!o2 || o2->op_type != OP_NULL)
9198 o2 = cUNOPx(o2)->op_first;
9199 if (!o2 || o2->op_type != OP_PUSHMARK)
9201 if (o2->op_sibling != o)
9204 /* check the array is the same on both sides */
9205 if (oleft->op_type == OP_RV2AV) {
9206 if (oright->op_type != OP_RV2AV
9207 || !cUNOPx(oright)->op_first
9208 || cUNOPx(oright)->op_first->op_type != OP_GV
9209 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9210 cGVOPx_gv(cUNOPx(oright)->op_first)
9214 else if (oright->op_type != OP_PADAV
9215 || oright->op_targ != oleft->op_targ
9222 /* A peephole optimizer. We visit the ops in the order they're to execute.
9223 * See the comments at the top of this file for more details about when
9224 * peep() is called */
9227 Perl_rpeep(pTHX_ register OP *o)
9230 register OP* oldop = NULL;
9232 if (!o || o->op_opt)
9236 SAVEVPTR(PL_curcop);
9237 for (; o; o = o->op_next) {
9240 /* By default, this op has now been optimised. A couple of cases below
9241 clear this again. */
9244 switch (o->op_type) {
9246 PL_curcop = ((COP*)o); /* for warnings */
9249 PL_curcop = ((COP*)o); /* for warnings */
9251 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9252 to carry two labels. For now, take the easier option, and skip
9253 this optimisation if the first NEXTSTATE has a label. */
9254 if (!CopLABEL((COP*)o)) {
9255 OP *nextop = o->op_next;
9256 while (nextop && nextop->op_type == OP_NULL)
9257 nextop = nextop->op_next;
9259 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9260 COP *firstcop = (COP *)o;
9261 COP *secondcop = (COP *)nextop;
9262 /* We want the COP pointed to by o (and anything else) to
9263 become the next COP down the line. */
9266 firstcop->op_next = secondcop->op_next;
9268 /* Now steal all its pointers, and duplicate the other
9270 firstcop->cop_line = secondcop->cop_line;
9272 firstcop->cop_stashpv = secondcop->cop_stashpv;
9273 firstcop->cop_file = secondcop->cop_file;
9275 firstcop->cop_stash = secondcop->cop_stash;
9276 firstcop->cop_filegv = secondcop->cop_filegv;
9278 firstcop->cop_hints = secondcop->cop_hints;
9279 firstcop->cop_seq = secondcop->cop_seq;
9280 firstcop->cop_warnings = secondcop->cop_warnings;
9281 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9284 secondcop->cop_stashpv = NULL;
9285 secondcop->cop_file = NULL;
9287 secondcop->cop_stash = NULL;
9288 secondcop->cop_filegv = NULL;
9290 secondcop->cop_warnings = NULL;
9291 secondcop->cop_hints_hash = NULL;
9293 /* If we use op_null(), and hence leave an ex-COP, some
9294 warnings are misreported. For example, the compile-time
9295 error in 'use strict; no strict refs;' */
9296 secondcop->op_type = OP_NULL;
9297 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9303 if (cSVOPo->op_private & OPpCONST_STRICT)
9304 no_bareword_allowed(o);
9307 case OP_METHOD_NAMED:
9308 /* Relocate sv to the pad for thread safety.
9309 * Despite being a "constant", the SV is written to,
9310 * for reference counts, sv_upgrade() etc. */
9312 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9313 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9314 /* If op_sv is already a PADTMP then it is being used by
9315 * some pad, so make a copy. */
9316 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9317 SvREADONLY_on(PAD_SVl(ix));
9318 SvREFCNT_dec(cSVOPo->op_sv);
9320 else if (o->op_type != OP_METHOD_NAMED
9321 && cSVOPo->op_sv == &PL_sv_undef) {
9322 /* PL_sv_undef is hack - it's unsafe to store it in the
9323 AV that is the pad, because av_fetch treats values of
9324 PL_sv_undef as a "free" AV entry and will merrily
9325 replace them with a new SV, causing pad_alloc to think
9326 that this pad slot is free. (When, clearly, it is not)
9328 SvOK_off(PAD_SVl(ix));
9329 SvPADTMP_on(PAD_SVl(ix));
9330 SvREADONLY_on(PAD_SVl(ix));
9333 SvREFCNT_dec(PAD_SVl(ix));
9334 SvPADTMP_on(cSVOPo->op_sv);
9335 PAD_SETSV(ix, cSVOPo->op_sv);
9336 /* XXX I don't know how this isn't readonly already. */
9337 SvREADONLY_on(PAD_SVl(ix));
9339 cSVOPo->op_sv = NULL;
9346 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9347 if (o->op_next->op_private & OPpTARGET_MY) {
9348 if (o->op_flags & OPf_STACKED) /* chained concats */
9349 break; /* ignore_optimization */
9351 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9352 o->op_targ = o->op_next->op_targ;
9353 o->op_next->op_targ = 0;
9354 o->op_private |= OPpTARGET_MY;
9357 op_null(o->op_next);
9361 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9362 break; /* Scalar stub must produce undef. List stub is noop */
9366 if (o->op_targ == OP_NEXTSTATE
9367 || o->op_targ == OP_DBSTATE)
9369 PL_curcop = ((COP*)o);
9371 /* XXX: We avoid setting op_seq here to prevent later calls
9372 to rpeep() from mistakenly concluding that optimisation
9373 has already occurred. This doesn't fix the real problem,
9374 though (See 20010220.007). AMS 20010719 */
9375 /* op_seq functionality is now replaced by op_opt */
9382 if (oldop && o->op_next) {
9383 oldop->op_next = o->op_next;
9391 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9392 OP* const pop = (o->op_type == OP_PADAV) ?
9393 o->op_next : o->op_next->op_next;
9395 if (pop && pop->op_type == OP_CONST &&
9396 ((PL_op = pop->op_next)) &&
9397 pop->op_next->op_type == OP_AELEM &&
9398 !(pop->op_next->op_private &
9399 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9400 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9405 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9406 no_bareword_allowed(pop);
9407 if (o->op_type == OP_GV)
9408 op_null(o->op_next);
9409 op_null(pop->op_next);
9411 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9412 o->op_next = pop->op_next->op_next;
9413 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9414 o->op_private = (U8)i;
9415 if (o->op_type == OP_GV) {
9420 o->op_flags |= OPf_SPECIAL;
9421 o->op_type = OP_AELEMFAST;
9426 if (o->op_next->op_type == OP_RV2SV) {
9427 if (!(o->op_next->op_private & OPpDEREF)) {
9428 op_null(o->op_next);
9429 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9431 o->op_next = o->op_next->op_next;
9432 o->op_type = OP_GVSV;
9433 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9436 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9437 GV * const gv = cGVOPo_gv;
9438 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9439 /* XXX could check prototype here instead of just carping */
9440 SV * const sv = sv_newmortal();
9441 gv_efullname3(sv, gv, NULL);
9442 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9443 "%"SVf"() called too early to check prototype",
9447 else if (o->op_next->op_type == OP_READLINE
9448 && o->op_next->op_next->op_type == OP_CONCAT
9449 && (o->op_next->op_next->op_flags & OPf_STACKED))
9451 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9452 o->op_type = OP_RCATLINE;
9453 o->op_flags |= OPf_STACKED;
9454 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9455 op_null(o->op_next->op_next);
9456 op_null(o->op_next);
9466 fop = cUNOP->op_first;
9474 fop = cLOGOP->op_first;
9475 sop = fop->op_sibling;
9476 while (cLOGOP->op_other->op_type == OP_NULL)
9477 cLOGOP->op_other = cLOGOP->op_other->op_next;
9478 CALL_RPEEP(cLOGOP->op_other);
9482 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9484 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9489 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9490 while (nop && nop->op_next) {
9491 switch (nop->op_next->op_type) {
9496 lop = nop = nop->op_next;
9507 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9508 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9509 cLOGOP->op_first = opt_scalarhv(fop);
9510 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9511 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9527 while (cLOGOP->op_other->op_type == OP_NULL)
9528 cLOGOP->op_other = cLOGOP->op_other->op_next;
9529 CALL_RPEEP(cLOGOP->op_other);
9534 while (cLOOP->op_redoop->op_type == OP_NULL)
9535 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9536 CALL_RPEEP(cLOOP->op_redoop);
9537 while (cLOOP->op_nextop->op_type == OP_NULL)
9538 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9539 CALL_RPEEP(cLOOP->op_nextop);
9540 while (cLOOP->op_lastop->op_type == OP_NULL)
9541 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9542 CALL_RPEEP(cLOOP->op_lastop);
9546 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9547 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9548 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9549 cPMOP->op_pmstashstartu.op_pmreplstart
9550 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9551 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9555 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9556 && ckWARN(WARN_SYNTAX))
9558 if (o->op_next->op_sibling) {
9559 const OPCODE type = o->op_next->op_sibling->op_type;
9560 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9561 const line_t oldline = CopLINE(PL_curcop);
9562 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9563 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9564 "Statement unlikely to be reached");
9565 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9566 "\t(Maybe you meant system() when you said exec()?)\n");
9567 CopLINE_set(PL_curcop, oldline);
9578 const char *key = NULL;
9581 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9584 /* Make the CONST have a shared SV */
9585 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9586 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
9587 key = SvPV_const(sv, keylen);
9588 lexname = newSVpvn_share(key,
9589 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9595 if ((o->op_private & (OPpLVAL_INTRO)))
9598 rop = (UNOP*)((BINOP*)o)->op_first;
9599 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9601 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9602 if (!SvPAD_TYPED(lexname))
9604 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9605 if (!fields || !GvHV(*fields))
9607 key = SvPV_const(*svp, keylen);
9608 if (!hv_fetch(GvHV(*fields), key,
9609 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9611 Perl_croak(aTHX_ "No such class field \"%s\" "
9612 "in variable %s of type %s",
9613 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9626 SVOP *first_key_op, *key_op;
9628 if ((o->op_private & (OPpLVAL_INTRO))
9629 /* I bet there's always a pushmark... */
9630 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9631 /* hmmm, no optimization if list contains only one key. */
9633 rop = (UNOP*)((LISTOP*)o)->op_last;
9634 if (rop->op_type != OP_RV2HV)
9636 if (rop->op_first->op_type == OP_PADSV)
9637 /* @$hash{qw(keys here)} */
9638 rop = (UNOP*)rop->op_first;
9640 /* @{$hash}{qw(keys here)} */
9641 if (rop->op_first->op_type == OP_SCOPE
9642 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9644 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9650 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9651 if (!SvPAD_TYPED(lexname))
9653 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9654 if (!fields || !GvHV(*fields))
9656 /* Again guessing that the pushmark can be jumped over.... */
9657 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9658 ->op_first->op_sibling;
9659 for (key_op = first_key_op; key_op;
9660 key_op = (SVOP*)key_op->op_sibling) {
9661 if (key_op->op_type != OP_CONST)
9663 svp = cSVOPx_svp(key_op);
9664 key = SvPV_const(*svp, keylen);
9665 if (!hv_fetch(GvHV(*fields), key,
9666 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9668 Perl_croak(aTHX_ "No such class field \"%s\" "
9669 "in variable %s of type %s",
9670 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9679 && ( oldop->op_type == OP_AELEM
9680 || oldop->op_type == OP_PADSV
9681 || oldop->op_type == OP_RV2SV
9682 || oldop->op_type == OP_RV2GV
9683 || oldop->op_type == OP_HELEM
9685 && (oldop->op_private & OPpDEREF)
9687 o->op_private |= OPpDEREFed;
9691 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9695 /* check that RHS of sort is a single plain array */
9696 OP *oright = cUNOPo->op_first;
9697 if (!oright || oright->op_type != OP_PUSHMARK)
9700 /* reverse sort ... can be optimised. */
9701 if (!cUNOPo->op_sibling) {
9702 /* Nothing follows us on the list. */
9703 OP * const reverse = o->op_next;
9705 if (reverse->op_type == OP_REVERSE &&
9706 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9707 OP * const pushmark = cUNOPx(reverse)->op_first;
9708 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9709 && (cUNOPx(pushmark)->op_sibling == o)) {
9710 /* reverse -> pushmark -> sort */
9711 o->op_private |= OPpSORT_REVERSE;
9713 pushmark->op_next = oright->op_next;
9719 /* make @a = sort @a act in-place */
9721 oright = cUNOPx(oright)->op_sibling;
9724 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9725 oright = cUNOPx(oright)->op_sibling;
9728 oleft = is_inplace_av(o, oright);
9732 /* transfer MODishness etc from LHS arg to RHS arg */
9733 oright->op_flags = oleft->op_flags;
9734 o->op_private |= OPpSORT_INPLACE;
9736 /* excise push->gv->rv2av->null->aassign */
9737 o2 = o->op_next->op_next;
9738 op_null(o2); /* PUSHMARK */
9740 if (o2->op_type == OP_GV) {
9741 op_null(o2); /* GV */
9744 op_null(o2); /* RV2AV or PADAV */
9745 o2 = o2->op_next->op_next;
9746 op_null(o2); /* AASSIGN */
9748 o->op_next = o2->op_next;
9754 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9757 LISTOP *enter, *exlist;
9759 /* @a = reverse @a */
9760 if ((oright = cLISTOPo->op_first)
9761 && (oright->op_type == OP_PUSHMARK)
9762 && (oright = oright->op_sibling)
9763 && (oleft = is_inplace_av(o, oright))) {
9766 /* transfer MODishness etc from LHS arg to RHS arg */
9767 oright->op_flags = oleft->op_flags;
9768 o->op_private |= OPpREVERSE_INPLACE;
9770 /* excise push->gv->rv2av->null->aassign */
9771 o2 = o->op_next->op_next;
9772 op_null(o2); /* PUSHMARK */
9774 if (o2->op_type == OP_GV) {
9775 op_null(o2); /* GV */
9778 op_null(o2); /* RV2AV or PADAV */
9779 o2 = o2->op_next->op_next;
9780 op_null(o2); /* AASSIGN */
9782 o->op_next = o2->op_next;
9786 enter = (LISTOP *) o->op_next;
9789 if (enter->op_type == OP_NULL) {
9790 enter = (LISTOP *) enter->op_next;
9794 /* for $a (...) will have OP_GV then OP_RV2GV here.
9795 for (...) just has an OP_GV. */
9796 if (enter->op_type == OP_GV) {
9797 gvop = (OP *) enter;
9798 enter = (LISTOP *) enter->op_next;
9801 if (enter->op_type == OP_RV2GV) {
9802 enter = (LISTOP *) enter->op_next;
9808 if (enter->op_type != OP_ENTERITER)
9811 iter = enter->op_next;
9812 if (!iter || iter->op_type != OP_ITER)
9815 expushmark = enter->op_first;
9816 if (!expushmark || expushmark->op_type != OP_NULL
9817 || expushmark->op_targ != OP_PUSHMARK)
9820 exlist = (LISTOP *) expushmark->op_sibling;
9821 if (!exlist || exlist->op_type != OP_NULL
9822 || exlist->op_targ != OP_LIST)
9825 if (exlist->op_last != o) {
9826 /* Mmm. Was expecting to point back to this op. */
9829 theirmark = exlist->op_first;
9830 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9833 if (theirmark->op_sibling != o) {
9834 /* There's something between the mark and the reverse, eg
9835 for (1, reverse (...))
9840 ourmark = ((LISTOP *)o)->op_first;
9841 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9844 ourlast = ((LISTOP *)o)->op_last;
9845 if (!ourlast || ourlast->op_next != o)
9848 rv2av = ourmark->op_sibling;
9849 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9850 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9851 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9852 /* We're just reversing a single array. */
9853 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9854 enter->op_flags |= OPf_STACKED;
9857 /* We don't have control over who points to theirmark, so sacrifice
9859 theirmark->op_next = ourmark->op_next;
9860 theirmark->op_flags = ourmark->op_flags;
9861 ourlast->op_next = gvop ? gvop : (OP *) enter;
9864 enter->op_private |= OPpITER_REVERSED;
9865 iter->op_private |= OPpITER_REVERSED;
9872 UNOP *refgen, *rv2cv;
9875 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9878 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9881 rv2gv = ((BINOP *)o)->op_last;
9882 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9885 refgen = (UNOP *)((BINOP *)o)->op_first;
9887 if (!refgen || refgen->op_type != OP_REFGEN)
9890 exlist = (LISTOP *)refgen->op_first;
9891 if (!exlist || exlist->op_type != OP_NULL
9892 || exlist->op_targ != OP_LIST)
9895 if (exlist->op_first->op_type != OP_PUSHMARK)
9898 rv2cv = (UNOP*)exlist->op_last;
9900 if (rv2cv->op_type != OP_RV2CV)
9903 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9904 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9905 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9907 o->op_private |= OPpASSIGN_CV_TO_GV;
9908 rv2gv->op_private |= OPpDONT_INIT_GV;
9909 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9917 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9918 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9928 Perl_peep(pTHX_ register OP *o)
9934 Perl_custom_op_name(pTHX_ const OP* o)
9937 const IV index = PTR2IV(o->op_ppaddr);
9941 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9943 if (!PL_custom_op_names) /* This probably shouldn't happen */
9944 return (char *)PL_op_name[OP_CUSTOM];
9946 keysv = sv_2mortal(newSViv(index));
9948 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9950 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9952 return SvPV_nolen(HeVAL(he));
9956 Perl_custom_op_desc(pTHX_ const OP* o)
9959 const IV index = PTR2IV(o->op_ppaddr);
9963 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9965 if (!PL_custom_op_descs)
9966 return (char *)PL_op_desc[OP_CUSTOM];
9968 keysv = sv_2mortal(newSViv(index));
9970 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9972 return (char *)PL_op_desc[OP_CUSTOM];
9974 return SvPV_nolen(HeVAL(he));
9979 /* Efficient sub that returns a constant scalar value. */
9981 const_sv_xsub(pTHX_ CV* cv)
9985 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9989 /* diag_listed_as: SKIPME */
9990 Perl_croak(aTHX_ "usage: %s::%s()",
9991 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10004 * c-indentation-style: bsd
10005 * c-basic-offset: 4
10006 * indent-tabs-mode: t
10009 * ex: set ts=8 sts=4 sw=4 noet: