4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
106 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
107 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
108 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
110 #if defined(PL_OP_SLAB_ALLOC)
112 #ifdef PERL_DEBUG_READONLY_OPS
113 # define PERL_SLAB_SIZE 4096
114 # include <sys/mman.h>
117 #ifndef PERL_SLAB_SIZE
118 #define PERL_SLAB_SIZE 2048
122 Perl_Slab_Alloc(pTHX_ size_t sz)
126 * To make incrementing use count easy PL_OpSlab is an I32 *
127 * To make inserting the link to slab PL_OpPtr is I32 **
128 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
129 * Add an overhead for pointer to slab and round up as a number of pointers
131 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
132 if ((PL_OpSpace -= sz) < 0) {
133 #ifdef PERL_DEBUG_READONLY_OPS
134 /* We need to allocate chunk by chunk so that we can control the VM
136 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
139 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
140 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
142 if(PL_OpPtr == MAP_FAILED) {
143 perror("mmap failed");
148 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
153 /* We reserve the 0'th I32 sized chunk as a use count */
154 PL_OpSlab = (I32 *) PL_OpPtr;
155 /* Reduce size by the use count word, and by the size we need.
156 * Latter is to mimic the '-=' in the if() above
158 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
159 /* Allocation pointer starts at the top.
160 Theory: because we build leaves before trunk allocating at end
161 means that at run time access is cache friendly upward
163 PL_OpPtr += PERL_SLAB_SIZE;
165 #ifdef PERL_DEBUG_READONLY_OPS
166 /* We remember this slab. */
167 /* This implementation isn't efficient, but it is simple. */
168 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
169 PL_slabs[PL_slab_count++] = PL_OpSlab;
170 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
173 assert( PL_OpSpace >= 0 );
174 /* Move the allocation pointer down */
176 assert( PL_OpPtr > (I32 **) PL_OpSlab );
177 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
178 (*PL_OpSlab)++; /* Increment use count of slab */
179 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
180 assert( *PL_OpSlab > 0 );
181 return (void *)(PL_OpPtr + 1);
184 #ifdef PERL_DEBUG_READONLY_OPS
186 Perl_pending_Slabs_to_ro(pTHX) {
187 /* Turn all the allocated op slabs read only. */
188 U32 count = PL_slab_count;
189 I32 **const slabs = PL_slabs;
191 /* Reset the array of pending OP slabs, as we're about to turn this lot
192 read only. Also, do it ahead of the loop in case the warn triggers,
193 and a warn handler has an eval */
198 /* Force a new slab for any further allocation. */
202 void *const start = slabs[count];
203 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
204 if(mprotect(start, size, PROT_READ)) {
205 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
206 start, (unsigned long) size, errno);
214 S_Slab_to_rw(pTHX_ void *op)
216 I32 * const * const ptr = (I32 **) op;
217 I32 * const slab = ptr[-1];
219 PERL_ARGS_ASSERT_SLAB_TO_RW;
221 assert( ptr-1 > (I32 **) slab );
222 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
224 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
225 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
226 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
231 Perl_op_refcnt_inc(pTHX_ OP *o)
242 Perl_op_refcnt_dec(pTHX_ OP *o)
244 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
249 # define Slab_to_rw(op)
253 Perl_Slab_Free(pTHX_ void *op)
255 I32 * const * const ptr = (I32 **) op;
256 I32 * const slab = ptr[-1];
257 PERL_ARGS_ASSERT_SLAB_FREE;
258 assert( ptr-1 > (I32 **) slab );
259 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
262 if (--(*slab) == 0) {
264 # define PerlMemShared PerlMem
267 #ifdef PERL_DEBUG_READONLY_OPS
268 U32 count = PL_slab_count;
269 /* Need to remove this slab from our list of slabs */
272 if (PL_slabs[count] == slab) {
274 /* Found it. Move the entry at the end to overwrite it. */
275 DEBUG_m(PerlIO_printf(Perl_debug_log,
276 "Deallocate %p by moving %p from %lu to %lu\n",
278 PL_slabs[PL_slab_count - 1],
279 PL_slab_count, count));
280 PL_slabs[count] = PL_slabs[--PL_slab_count];
281 /* Could realloc smaller at this point, but probably not
283 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
284 perror("munmap failed");
292 PerlMemShared_free(slab);
294 if (slab == PL_OpSlab) {
301 * In the following definition, the ", (OP*)0" is just to make the compiler
302 * think the expression is of the right type: croak actually does a Siglongjmp.
304 #define CHECKOP(type,o) \
305 ((PL_op_mask && PL_op_mask[type]) \
306 ? ( op_free((OP*)o), \
307 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
309 : PL_check[type](aTHX_ (OP*)o))
311 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
314 S_gv_ename(pTHX_ GV *gv)
316 SV* const tmpsv = sv_newmortal();
318 PERL_ARGS_ASSERT_GV_ENAME;
320 gv_efullname3(tmpsv, gv, NULL);
321 return SvPV_nolen_const(tmpsv);
325 S_no_fh_allowed(pTHX_ OP *o)
327 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
329 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
335 S_too_few_arguments(pTHX_ OP *o, const char *name)
337 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
339 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
344 S_too_many_arguments(pTHX_ OP *o, const char *name)
346 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
348 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
353 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
355 PERL_ARGS_ASSERT_BAD_TYPE;
357 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
358 (int)n, name, t, OP_DESC(kid)));
362 S_no_bareword_allowed(pTHX_ const OP *o)
364 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
367 return; /* various ok barewords are hidden in extra OP_NULL */
368 qerror(Perl_mess(aTHX_
369 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
373 /* "register" allocation */
376 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
380 const bool is_our = (PL_parser->in_my == KEY_our);
382 PERL_ARGS_ASSERT_ALLOCMY;
385 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
388 /* Until we're using the length for real, cross check that we're being
390 assert(strlen(name) == len);
392 /* complain about "my $<special_var>" etc etc */
396 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
397 (name[1] == '_' && (*name == '$' || len > 2))))
399 /* name[2] is true if strlen(name) > 2 */
400 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
401 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
402 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
403 PL_parser->in_my == KEY_state ? "state" : "my"));
405 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
406 PL_parser->in_my == KEY_state ? "state" : "my"));
410 /* allocate a spare slot and store the name in that slot */
412 off = pad_add_name(name, len,
413 is_our ? padadd_OUR :
414 PL_parser->in_my == KEY_state ? padadd_STATE : 0,
415 PL_parser->in_my_stash,
417 /* $_ is always in main::, even with our */
418 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
422 /* anon sub prototypes contains state vars should always be cloned,
423 * otherwise the state var would be shared between anon subs */
425 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
426 CvCLONE_on(PL_compcv);
431 /* free the body of an op without examining its contents.
432 * Always use this rather than FreeOp directly */
435 S_op_destroy(pTHX_ OP *o)
437 if (o->op_latefree) {
445 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
447 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
453 Perl_op_free(pTHX_ OP *o)
460 if (o->op_latefreed) {
467 if (o->op_private & OPpREFCOUNTED) {
478 refcnt = OpREFCNT_dec(o);
481 /* Need to find and remove any pattern match ops from the list
482 we maintain for reset(). */
483 find_and_forget_pmops(o);
493 /* Call the op_free hook if it has been set. Do it now so that it's called
494 * at the right time for refcounted ops, but still before all of the kids
498 if (o->op_flags & OPf_KIDS) {
499 register OP *kid, *nextkid;
500 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
501 nextkid = kid->op_sibling; /* Get before next freeing kid */
506 #ifdef PERL_DEBUG_READONLY_OPS
510 /* COP* is not cleared by op_clear() so that we may track line
511 * numbers etc even after null() */
512 if (type == OP_NEXTSTATE || type == OP_DBSTATE
513 || (type == OP_NULL /* the COP might have been null'ed */
514 && ((OPCODE)o->op_targ == OP_NEXTSTATE
515 || (OPCODE)o->op_targ == OP_DBSTATE))) {
520 type = (OPCODE)o->op_targ;
523 if (o->op_latefree) {
529 #ifdef DEBUG_LEAKING_SCALARS
536 Perl_op_clear(pTHX_ OP *o)
541 PERL_ARGS_ASSERT_OP_CLEAR;
544 /* if (o->op_madprop && o->op_madprop->mad_next)
546 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
547 "modification of a read only value" for a reason I can't fathom why.
548 It's the "" stringification of $_, where $_ was set to '' in a foreach
549 loop, but it defies simplification into a small test case.
550 However, commenting them out has caused ext/List/Util/t/weak.t to fail
553 mad_free(o->op_madprop);
559 switch (o->op_type) {
560 case OP_NULL: /* Was holding old type, if any. */
561 if (PL_madskills && o->op_targ != OP_NULL) {
562 o->op_type = (Optype)o->op_targ;
567 case OP_ENTEREVAL: /* Was holding hints. */
571 if (!(o->op_flags & OPf_REF)
572 || (PL_check[o->op_type] != Perl_ck_ftst))
578 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
579 /* not an OP_PADAV replacement */
580 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
585 /* It's possible during global destruction that the GV is freed
586 before the optree. Whilst the SvREFCNT_inc is happy to bump from
587 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
588 will trigger an assertion failure, because the entry to sv_clear
589 checks that the scalar is not already freed. A check of for
590 !SvIS_FREED(gv) turns out to be invalid, because during global
591 destruction the reference count can be forced down to zero
592 (with SVf_BREAK set). In which case raising to 1 and then
593 dropping to 0 triggers cleanup before it should happen. I
594 *think* that this might actually be a general, systematic,
595 weakness of the whole idea of SVf_BREAK, in that code *is*
596 allowed to raise and lower references during global destruction,
597 so any *valid* code that happens to do this during global
598 destruction might well trigger premature cleanup. */
599 bool still_valid = gv && SvREFCNT(gv);
602 SvREFCNT_inc_simple_void(gv);
604 if (cPADOPo->op_padix > 0) {
605 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
606 * may still exist on the pad */
607 pad_swipe(cPADOPo->op_padix, TRUE);
608 cPADOPo->op_padix = 0;
611 SvREFCNT_dec(cSVOPo->op_sv);
612 cSVOPo->op_sv = NULL;
615 int try_downgrade = SvREFCNT(gv) == 2;
618 gv_try_downgrade(gv);
622 case OP_METHOD_NAMED:
625 SvREFCNT_dec(cSVOPo->op_sv);
626 cSVOPo->op_sv = NULL;
629 Even if op_clear does a pad_free for the target of the op,
630 pad_free doesn't actually remove the sv that exists in the pad;
631 instead it lives on. This results in that it could be reused as
632 a target later on when the pad was reallocated.
635 pad_swipe(o->op_targ,1);
644 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
648 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
650 if (cPADOPo->op_padix > 0) {
651 pad_swipe(cPADOPo->op_padix, TRUE);
652 cPADOPo->op_padix = 0;
655 SvREFCNT_dec(cSVOPo->op_sv);
656 cSVOPo->op_sv = NULL;
660 PerlMemShared_free(cPVOPo->op_pv);
661 cPVOPo->op_pv = NULL;
665 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
669 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
670 /* No GvIN_PAD_off here, because other references may still
671 * exist on the pad */
672 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
675 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
681 forget_pmop(cPMOPo, 1);
682 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
683 /* we use the same protection as the "SAFE" version of the PM_ macros
684 * here since sv_clean_all might release some PMOPs
685 * after PL_regex_padav has been cleared
686 * and the clearing of PL_regex_padav needs to
687 * happen before sv_clean_all
690 if(PL_regex_pad) { /* We could be in destruction */
691 const IV offset = (cPMOPo)->op_pmoffset;
692 ReREFCNT_dec(PM_GETRE(cPMOPo));
693 PL_regex_pad[offset] = &PL_sv_undef;
694 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
698 ReREFCNT_dec(PM_GETRE(cPMOPo));
699 PM_SETRE(cPMOPo, NULL);
705 if (o->op_targ > 0) {
706 pad_free(o->op_targ);
712 S_cop_free(pTHX_ COP* cop)
714 PERL_ARGS_ASSERT_COP_FREE;
718 if (! specialWARN(cop->cop_warnings))
719 PerlMemShared_free(cop->cop_warnings);
720 cophh_free(CopHINTHASH_get(cop));
724 S_forget_pmop(pTHX_ PMOP *const o
730 HV * const pmstash = PmopSTASH(o);
732 PERL_ARGS_ASSERT_FORGET_PMOP;
734 if (pmstash && !SvIS_FREED(pmstash)) {
735 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
737 PMOP **const array = (PMOP**) mg->mg_ptr;
738 U32 count = mg->mg_len / sizeof(PMOP**);
743 /* Found it. Move the entry at the end to overwrite it. */
744 array[i] = array[--count];
745 mg->mg_len = count * sizeof(PMOP**);
746 /* Could realloc smaller at this point always, but probably
747 not worth it. Probably worth free()ing if we're the
750 Safefree(mg->mg_ptr);
767 S_find_and_forget_pmops(pTHX_ OP *o)
769 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
771 if (o->op_flags & OPf_KIDS) {
772 OP *kid = cUNOPo->op_first;
774 switch (kid->op_type) {
779 forget_pmop((PMOP*)kid, 0);
781 find_and_forget_pmops(kid);
782 kid = kid->op_sibling;
788 Perl_op_null(pTHX_ OP *o)
792 PERL_ARGS_ASSERT_OP_NULL;
794 if (o->op_type == OP_NULL)
798 o->op_targ = o->op_type;
799 o->op_type = OP_NULL;
800 o->op_ppaddr = PL_ppaddr[OP_NULL];
804 Perl_op_refcnt_lock(pTHX)
812 Perl_op_refcnt_unlock(pTHX)
819 /* Contextualizers */
822 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
824 Applies a syntactic context to an op tree representing an expression.
825 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
826 or C<G_VOID> to specify the context to apply. The modified op tree
833 Perl_op_contextualize(pTHX_ OP *o, I32 context)
835 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
837 case G_SCALAR: return scalar(o);
838 case G_ARRAY: return list(o);
839 case G_VOID: return scalarvoid(o);
841 Perl_croak(aTHX_ "panic: op_contextualize bad context");
847 =head1 Optree Manipulation Functions
849 =for apidoc Am|OP*|op_linklist|OP *o
850 This function is the implementation of the L</LINKLIST> macro. It should
851 not be called directly.
857 Perl_op_linklist(pTHX_ OP *o)
861 PERL_ARGS_ASSERT_OP_LINKLIST;
866 /* establish postfix order */
867 first = cUNOPo->op_first;
870 o->op_next = LINKLIST(first);
873 if (kid->op_sibling) {
874 kid->op_next = LINKLIST(kid->op_sibling);
875 kid = kid->op_sibling;
889 S_scalarkids(pTHX_ OP *o)
891 if (o && o->op_flags & OPf_KIDS) {
893 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
900 S_scalarboolean(pTHX_ OP *o)
904 PERL_ARGS_ASSERT_SCALARBOOLEAN;
906 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
907 if (ckWARN(WARN_SYNTAX)) {
908 const line_t oldline = CopLINE(PL_curcop);
910 if (PL_parser && PL_parser->copline != NOLINE)
911 CopLINE_set(PL_curcop, PL_parser->copline);
912 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
913 CopLINE_set(PL_curcop, oldline);
920 Perl_scalar(pTHX_ OP *o)
925 /* assumes no premature commitment */
926 if (!o || (PL_parser && PL_parser->error_count)
927 || (o->op_flags & OPf_WANT)
928 || o->op_type == OP_RETURN)
933 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
935 switch (o->op_type) {
937 scalar(cBINOPo->op_first);
942 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
952 if (o->op_flags & OPf_KIDS) {
953 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
959 kid = cLISTOPo->op_first;
961 kid = kid->op_sibling;
964 OP *sib = kid->op_sibling;
965 if (sib && kid->op_type != OP_LEAVEWHEN) {
966 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
976 PL_curcop = &PL_compiling;
981 kid = cLISTOPo->op_first;
984 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
991 Perl_scalarvoid(pTHX_ OP *o)
995 const char* useless = NULL;
999 PERL_ARGS_ASSERT_SCALARVOID;
1001 /* trailing mad null ops don't count as "there" for void processing */
1003 o->op_type != OP_NULL &&
1005 o->op_sibling->op_type == OP_NULL)
1008 for (sib = o->op_sibling;
1009 sib && sib->op_type == OP_NULL;
1010 sib = sib->op_sibling) ;
1016 if (o->op_type == OP_NEXTSTATE
1017 || o->op_type == OP_DBSTATE
1018 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1019 || o->op_targ == OP_DBSTATE)))
1020 PL_curcop = (COP*)o; /* for warning below */
1022 /* assumes no premature commitment */
1023 want = o->op_flags & OPf_WANT;
1024 if ((want && want != OPf_WANT_SCALAR)
1025 || (PL_parser && PL_parser->error_count)
1026 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1031 if ((o->op_private & OPpTARGET_MY)
1032 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1034 return scalar(o); /* As if inside SASSIGN */
1037 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1039 switch (o->op_type) {
1041 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1045 if (o->op_flags & OPf_STACKED)
1049 if (o->op_private == 4)
1092 case OP_GETSOCKNAME:
1093 case OP_GETPEERNAME:
1098 case OP_GETPRIORITY:
1122 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1123 /* Otherwise it's "Useless use of grep iterator" */
1124 useless = OP_DESC(o);
1128 kid = cLISTOPo->op_first;
1129 if (kid && kid->op_type == OP_PUSHRE
1131 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1133 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1135 useless = OP_DESC(o);
1139 kid = cUNOPo->op_first;
1140 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1141 kid->op_type != OP_TRANS) {
1144 useless = "negative pattern binding (!~)";
1148 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1149 useless = "Non-destructive substitution (s///r)";
1156 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1157 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1158 useless = "a variable";
1163 if (cSVOPo->op_private & OPpCONST_STRICT)
1164 no_bareword_allowed(o);
1166 if (ckWARN(WARN_VOID)) {
1168 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1169 "a constant (%"SVf")", sv));
1170 useless = SvPV_nolen(msv);
1173 useless = "a constant (undef)";
1174 if (o->op_private & OPpCONST_ARYBASE)
1176 /* don't warn on optimised away booleans, eg
1177 * use constant Foo, 5; Foo || print; */
1178 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1180 /* the constants 0 and 1 are permitted as they are
1181 conventionally used as dummies in constructs like
1182 1 while some_condition_with_side_effects; */
1183 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1185 else if (SvPOK(sv)) {
1186 /* perl4's way of mixing documentation and code
1187 (before the invention of POD) was based on a
1188 trick to mix nroff and perl code. The trick was
1189 built upon these three nroff macros being used in
1190 void context. The pink camel has the details in
1191 the script wrapman near page 319. */
1192 const char * const maybe_macro = SvPVX_const(sv);
1193 if (strnEQ(maybe_macro, "di", 2) ||
1194 strnEQ(maybe_macro, "ds", 2) ||
1195 strnEQ(maybe_macro, "ig", 2))
1200 op_null(o); /* don't execute or even remember it */
1204 o->op_type = OP_PREINC; /* pre-increment is faster */
1205 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1209 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1210 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1214 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1215 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1219 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1220 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1225 kid = cLOGOPo->op_first;
1226 if (kid->op_type == OP_NOT
1227 && (kid->op_flags & OPf_KIDS)
1229 if (o->op_type == OP_AND) {
1231 o->op_ppaddr = PL_ppaddr[OP_OR];
1233 o->op_type = OP_AND;
1234 o->op_ppaddr = PL_ppaddr[OP_AND];
1243 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1248 if (o->op_flags & OPf_STACKED)
1255 if (!(o->op_flags & OPf_KIDS))
1266 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1276 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1281 S_listkids(pTHX_ OP *o)
1283 if (o && o->op_flags & OPf_KIDS) {
1285 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1292 Perl_list(pTHX_ OP *o)
1297 /* assumes no premature commitment */
1298 if (!o || (o->op_flags & OPf_WANT)
1299 || (PL_parser && PL_parser->error_count)
1300 || o->op_type == OP_RETURN)
1305 if ((o->op_private & OPpTARGET_MY)
1306 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1308 return o; /* As if inside SASSIGN */
1311 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1313 switch (o->op_type) {
1316 list(cBINOPo->op_first);
1321 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1329 if (!(o->op_flags & OPf_KIDS))
1331 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1332 list(cBINOPo->op_first);
1333 return gen_constant_list(o);
1340 kid = cLISTOPo->op_first;
1342 kid = kid->op_sibling;
1345 OP *sib = kid->op_sibling;
1346 if (sib && kid->op_type != OP_LEAVEWHEN) {
1347 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1357 PL_curcop = &PL_compiling;
1361 kid = cLISTOPo->op_first;
1368 S_scalarseq(pTHX_ OP *o)
1372 const OPCODE type = o->op_type;
1374 if (type == OP_LINESEQ || type == OP_SCOPE ||
1375 type == OP_LEAVE || type == OP_LEAVETRY)
1378 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1379 if (kid->op_sibling) {
1383 PL_curcop = &PL_compiling;
1385 o->op_flags &= ~OPf_PARENS;
1386 if (PL_hints & HINT_BLOCK_SCOPE)
1387 o->op_flags |= OPf_PARENS;
1390 o = newOP(OP_STUB, 0);
1395 S_modkids(pTHX_ OP *o, I32 type)
1397 if (o && o->op_flags & OPf_KIDS) {
1399 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1405 /* Propagate lvalue ("modifiable") context to an op and its children.
1406 * 'type' represents the context type, roughly based on the type of op that
1407 * would do the modifying, although local() is represented by OP_NULL.
1408 * It's responsible for detecting things that can't be modified, flag
1409 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1410 * might have to vivify a reference in $x), and so on.
1412 * For example, "$a+1 = 2" would cause mod() to be called with o being
1413 * OP_ADD and type being OP_SASSIGN, and would output an error.
1417 Perl_mod(pTHX_ OP *o, I32 type)
1421 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1424 if (!o || (PL_parser && PL_parser->error_count))
1427 if ((o->op_private & OPpTARGET_MY)
1428 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1433 switch (o->op_type) {
1439 if (!(o->op_private & OPpCONST_ARYBASE))
1442 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1443 CopARYBASE_set(&PL_compiling,
1444 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1448 SAVECOPARYBASE(&PL_compiling);
1449 CopARYBASE_set(&PL_compiling, 0);
1451 else if (type == OP_REFGEN)
1454 Perl_croak(aTHX_ "That use of $[ is unsupported");
1457 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1461 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1462 !(o->op_flags & OPf_STACKED)) {
1463 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1464 /* The default is to set op_private to the number of children,
1465 which for a UNOP such as RV2CV is always 1. And w're using
1466 the bit for a flag in RV2CV, so we need it clear. */
1467 o->op_private &= ~1;
1468 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1469 assert(cUNOPo->op_first->op_type == OP_NULL);
1470 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1473 else if (o->op_private & OPpENTERSUB_NOMOD)
1475 else { /* lvalue subroutine call */
1476 o->op_private |= OPpLVAL_INTRO;
1477 PL_modcount = RETURN_UNLIMITED_NUMBER;
1478 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1479 /* Backward compatibility mode: */
1480 o->op_private |= OPpENTERSUB_INARGS;
1483 else { /* Compile-time error message: */
1484 OP *kid = cUNOPo->op_first;
1488 if (kid->op_type != OP_PUSHMARK) {
1489 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1491 "panic: unexpected lvalue entersub "
1492 "args: type/targ %ld:%"UVuf,
1493 (long)kid->op_type, (UV)kid->op_targ);
1494 kid = kLISTOP->op_first;
1496 while (kid->op_sibling)
1497 kid = kid->op_sibling;
1498 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1500 if (kid->op_type == OP_METHOD_NAMED
1501 || kid->op_type == OP_METHOD)
1505 NewOp(1101, newop, 1, UNOP);
1506 newop->op_type = OP_RV2CV;
1507 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1508 newop->op_first = NULL;
1509 newop->op_next = (OP*)newop;
1510 kid->op_sibling = (OP*)newop;
1511 newop->op_private |= OPpLVAL_INTRO;
1512 newop->op_private &= ~1;
1516 if (kid->op_type != OP_RV2CV)
1518 "panic: unexpected lvalue entersub "
1519 "entry via type/targ %ld:%"UVuf,
1520 (long)kid->op_type, (UV)kid->op_targ);
1521 kid->op_private |= OPpLVAL_INTRO;
1522 break; /* Postpone until runtime */
1526 kid = kUNOP->op_first;
1527 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1528 kid = kUNOP->op_first;
1529 if (kid->op_type == OP_NULL)
1531 "Unexpected constant lvalue entersub "
1532 "entry via type/targ %ld:%"UVuf,
1533 (long)kid->op_type, (UV)kid->op_targ);
1534 if (kid->op_type != OP_GV) {
1535 /* Restore RV2CV to check lvalueness */
1537 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1538 okid->op_next = kid->op_next;
1539 kid->op_next = okid;
1542 okid->op_next = NULL;
1543 okid->op_type = OP_RV2CV;
1545 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1546 okid->op_private |= OPpLVAL_INTRO;
1547 okid->op_private &= ~1;
1551 cv = GvCV(kGVOP_gv);
1561 /* grep, foreach, subcalls, refgen */
1562 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1564 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1565 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1567 : (o->op_type == OP_ENTERSUB
1568 ? "non-lvalue subroutine call"
1570 type ? PL_op_desc[type] : "local"));
1584 case OP_RIGHT_SHIFT:
1593 if (!(o->op_flags & OPf_STACKED))
1600 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1606 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1607 PL_modcount = RETURN_UNLIMITED_NUMBER;
1608 return o; /* Treat \(@foo) like ordinary list. */
1612 if (scalar_mod_type(o, type))
1614 ref(cUNOPo->op_first, o->op_type);
1618 if (type == OP_LEAVESUBLV)
1619 o->op_private |= OPpMAYBE_LVSUB;
1625 PL_modcount = RETURN_UNLIMITED_NUMBER;
1628 PL_hints |= HINT_BLOCK_SCOPE;
1629 if (type == OP_LEAVESUBLV)
1630 o->op_private |= OPpMAYBE_LVSUB;
1634 ref(cUNOPo->op_first, o->op_type);
1638 PL_hints |= HINT_BLOCK_SCOPE;
1653 PL_modcount = RETURN_UNLIMITED_NUMBER;
1654 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1655 return o; /* Treat \(@foo) like ordinary list. */
1656 if (scalar_mod_type(o, type))
1658 if (type == OP_LEAVESUBLV)
1659 o->op_private |= OPpMAYBE_LVSUB;
1663 if (!type) /* local() */
1664 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1665 PAD_COMPNAME_PV(o->op_targ));
1673 if (type != OP_SASSIGN)
1677 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1682 if (type == OP_LEAVESUBLV)
1683 o->op_private |= OPpMAYBE_LVSUB;
1685 pad_free(o->op_targ);
1686 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1687 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1688 if (o->op_flags & OPf_KIDS)
1689 mod(cBINOPo->op_first->op_sibling, type);
1694 ref(cBINOPo->op_first, o->op_type);
1695 if (type == OP_ENTERSUB &&
1696 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1697 o->op_private |= OPpLVAL_DEFER;
1698 if (type == OP_LEAVESUBLV)
1699 o->op_private |= OPpMAYBE_LVSUB;
1709 if (o->op_flags & OPf_KIDS)
1710 mod(cLISTOPo->op_last, type);
1715 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1717 else if (!(o->op_flags & OPf_KIDS))
1719 if (o->op_targ != OP_LIST) {
1720 mod(cBINOPo->op_first, type);
1726 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1731 if (type != OP_LEAVESUBLV)
1733 break; /* mod()ing was handled by ck_return() */
1736 /* [20011101.069] File test operators interpret OPf_REF to mean that
1737 their argument is a filehandle; thus \stat(".") should not set
1739 if (type == OP_REFGEN &&
1740 PL_check[o->op_type] == Perl_ck_ftst)
1743 if (type != OP_LEAVESUBLV)
1744 o->op_flags |= OPf_MOD;
1746 if (type == OP_AASSIGN || type == OP_SASSIGN)
1747 o->op_flags |= OPf_SPECIAL|OPf_REF;
1748 else if (!type) { /* local() */
1751 o->op_private |= OPpLVAL_INTRO;
1752 o->op_flags &= ~OPf_SPECIAL;
1753 PL_hints |= HINT_BLOCK_SCOPE;
1758 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1759 "Useless localization of %s", OP_DESC(o));
1762 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1763 && type != OP_LEAVESUBLV)
1764 o->op_flags |= OPf_REF;
1769 S_scalar_mod_type(const OP *o, I32 type)
1771 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1775 if (o->op_type == OP_RV2GV)
1799 case OP_RIGHT_SHIFT:
1819 S_is_handle_constructor(const OP *o, I32 numargs)
1821 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1823 switch (o->op_type) {
1831 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1844 S_refkids(pTHX_ OP *o, I32 type)
1846 if (o && o->op_flags & OPf_KIDS) {
1848 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1855 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1860 PERL_ARGS_ASSERT_DOREF;
1862 if (!o || (PL_parser && PL_parser->error_count))
1865 switch (o->op_type) {
1867 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1868 !(o->op_flags & OPf_STACKED)) {
1869 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1870 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1871 assert(cUNOPo->op_first->op_type == OP_NULL);
1872 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1873 o->op_flags |= OPf_SPECIAL;
1874 o->op_private &= ~1;
1879 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1880 doref(kid, type, set_op_ref);
1883 if (type == OP_DEFINED)
1884 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1885 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1888 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1889 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1890 : type == OP_RV2HV ? OPpDEREF_HV
1892 o->op_flags |= OPf_MOD;
1899 o->op_flags |= OPf_REF;
1902 if (type == OP_DEFINED)
1903 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1904 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1910 o->op_flags |= OPf_REF;
1915 if (!(o->op_flags & OPf_KIDS))
1917 doref(cBINOPo->op_first, type, set_op_ref);
1921 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1922 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1923 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1924 : type == OP_RV2HV ? OPpDEREF_HV
1926 o->op_flags |= OPf_MOD;
1936 if (!(o->op_flags & OPf_KIDS))
1938 doref(cLISTOPo->op_last, type, set_op_ref);
1948 S_dup_attrlist(pTHX_ OP *o)
1953 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1955 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1956 * where the first kid is OP_PUSHMARK and the remaining ones
1957 * are OP_CONST. We need to push the OP_CONST values.
1959 if (o->op_type == OP_CONST)
1960 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1962 else if (o->op_type == OP_NULL)
1966 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1968 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1969 if (o->op_type == OP_CONST)
1970 rop = op_append_elem(OP_LIST, rop,
1971 newSVOP(OP_CONST, o->op_flags,
1972 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1979 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1984 PERL_ARGS_ASSERT_APPLY_ATTRS;
1986 /* fake up C<use attributes $pkg,$rv,@attrs> */
1987 ENTER; /* need to protect against side-effects of 'use' */
1988 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1990 #define ATTRSMODULE "attributes"
1991 #define ATTRSMODULE_PM "attributes.pm"
1994 /* Don't force the C<use> if we don't need it. */
1995 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1996 if (svp && *svp != &PL_sv_undef)
1997 NOOP; /* already in %INC */
1999 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2000 newSVpvs(ATTRSMODULE), NULL);
2003 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2004 newSVpvs(ATTRSMODULE),
2006 op_prepend_elem(OP_LIST,
2007 newSVOP(OP_CONST, 0, stashsv),
2008 op_prepend_elem(OP_LIST,
2009 newSVOP(OP_CONST, 0,
2011 dup_attrlist(attrs))));
2017 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2020 OP *pack, *imop, *arg;
2023 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2028 assert(target->op_type == OP_PADSV ||
2029 target->op_type == OP_PADHV ||
2030 target->op_type == OP_PADAV);
2032 /* Ensure that attributes.pm is loaded. */
2033 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2035 /* Need package name for method call. */
2036 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2038 /* Build up the real arg-list. */
2039 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2041 arg = newOP(OP_PADSV, 0);
2042 arg->op_targ = target->op_targ;
2043 arg = op_prepend_elem(OP_LIST,
2044 newSVOP(OP_CONST, 0, stashsv),
2045 op_prepend_elem(OP_LIST,
2046 newUNOP(OP_REFGEN, 0,
2047 mod(arg, OP_REFGEN)),
2048 dup_attrlist(attrs)));
2050 /* Fake up a method call to import */
2051 meth = newSVpvs_share("import");
2052 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2053 op_append_elem(OP_LIST,
2054 op_prepend_elem(OP_LIST, pack, list(arg)),
2055 newSVOP(OP_METHOD_NAMED, 0, meth)));
2056 imop->op_private |= OPpENTERSUB_NOMOD;
2058 /* Combine the ops. */
2059 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2063 =notfor apidoc apply_attrs_string
2065 Attempts to apply a list of attributes specified by the C<attrstr> and
2066 C<len> arguments to the subroutine identified by the C<cv> argument which
2067 is expected to be associated with the package identified by the C<stashpv>
2068 argument (see L<attributes>). It gets this wrong, though, in that it
2069 does not correctly identify the boundaries of the individual attribute
2070 specifications within C<attrstr>. This is not really intended for the
2071 public API, but has to be listed here for systems such as AIX which
2072 need an explicit export list for symbols. (It's called from XS code
2073 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2074 to respect attribute syntax properly would be welcome.
2080 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2081 const char *attrstr, STRLEN len)
2085 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2088 len = strlen(attrstr);
2092 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2094 const char * const sstr = attrstr;
2095 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2096 attrs = op_append_elem(OP_LIST, attrs,
2097 newSVOP(OP_CONST, 0,
2098 newSVpvn(sstr, attrstr-sstr)));
2102 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2103 newSVpvs(ATTRSMODULE),
2104 NULL, op_prepend_elem(OP_LIST,
2105 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2106 op_prepend_elem(OP_LIST,
2107 newSVOP(OP_CONST, 0,
2108 newRV(MUTABLE_SV(cv))),
2113 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2118 PERL_ARGS_ASSERT_MY_KID;
2120 if (!o || (PL_parser && PL_parser->error_count))
2124 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2125 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2129 if (type == OP_LIST) {
2131 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2132 my_kid(kid, attrs, imopsp);
2133 } else if (type == OP_UNDEF
2139 } else if (type == OP_RV2SV || /* "our" declaration */
2141 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2142 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2143 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2145 PL_parser->in_my == KEY_our
2147 : PL_parser->in_my == KEY_state ? "state" : "my"));
2149 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2150 PL_parser->in_my = FALSE;
2151 PL_parser->in_my_stash = NULL;
2152 apply_attrs(GvSTASH(gv),
2153 (type == OP_RV2SV ? GvSV(gv) :
2154 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2155 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2158 o->op_private |= OPpOUR_INTRO;
2161 else if (type != OP_PADSV &&
2164 type != OP_PUSHMARK)
2166 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2168 PL_parser->in_my == KEY_our
2170 : PL_parser->in_my == KEY_state ? "state" : "my"));
2173 else if (attrs && type != OP_PUSHMARK) {
2176 PL_parser->in_my = FALSE;
2177 PL_parser->in_my_stash = NULL;
2179 /* check for C<my Dog $spot> when deciding package */
2180 stash = PAD_COMPNAME_TYPE(o->op_targ);
2182 stash = PL_curstash;
2183 apply_attrs_my(stash, o, attrs, imopsp);
2185 o->op_flags |= OPf_MOD;
2186 o->op_private |= OPpLVAL_INTRO;
2187 if (PL_parser->in_my == KEY_state)
2188 o->op_private |= OPpPAD_STATE;
2193 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2197 int maybe_scalar = 0;
2199 PERL_ARGS_ASSERT_MY_ATTRS;
2201 /* [perl #17376]: this appears to be premature, and results in code such as
2202 C< our(%x); > executing in list mode rather than void mode */
2204 if (o->op_flags & OPf_PARENS)
2214 o = my_kid(o, attrs, &rops);
2216 if (maybe_scalar && o->op_type == OP_PADSV) {
2217 o = scalar(op_append_list(OP_LIST, rops, o));
2218 o->op_private |= OPpLVAL_INTRO;
2221 o = op_append_list(OP_LIST, o, rops);
2223 PL_parser->in_my = FALSE;
2224 PL_parser->in_my_stash = NULL;
2229 Perl_sawparens(pTHX_ OP *o)
2231 PERL_UNUSED_CONTEXT;
2233 o->op_flags |= OPf_PARENS;
2238 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2242 const OPCODE ltype = left->op_type;
2243 const OPCODE rtype = right->op_type;
2245 PERL_ARGS_ASSERT_BIND_MATCH;
2247 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2248 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2250 const char * const desc
2251 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2252 ? (int)rtype : OP_MATCH];
2253 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2254 ? "@array" : "%hash");
2255 Perl_warner(aTHX_ packWARN(WARN_MISC),
2256 "Applying %s to %s will act on scalar(%s)",
2257 desc, sample, sample);
2260 if (rtype == OP_CONST &&
2261 cSVOPx(right)->op_private & OPpCONST_BARE &&
2262 cSVOPx(right)->op_private & OPpCONST_STRICT)
2264 no_bareword_allowed(right);
2267 /* !~ doesn't make sense with s///r, so error on it for now */
2268 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2270 yyerror("Using !~ with s///r doesn't make sense");
2272 ismatchop = (rtype == OP_MATCH ||
2273 rtype == OP_SUBST ||
2275 && !(right->op_flags & OPf_SPECIAL);
2276 if (ismatchop && right->op_private & OPpTARGET_MY) {
2278 right->op_private &= ~OPpTARGET_MY;
2280 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2283 right->op_flags |= OPf_STACKED;
2284 if (rtype != OP_MATCH &&
2285 ! (rtype == OP_TRANS &&
2286 right->op_private & OPpTRANS_IDENTICAL) &&
2287 ! (rtype == OP_SUBST &&
2288 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2289 newleft = mod(left, rtype);
2292 if (right->op_type == OP_TRANS)
2293 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2295 o = op_prepend_elem(rtype, scalar(newleft), right);
2297 return newUNOP(OP_NOT, 0, scalar(o));
2301 return bind_match(type, left,
2302 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2306 Perl_invert(pTHX_ OP *o)
2310 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2314 Perl_scope(pTHX_ OP *o)
2318 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2319 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2320 o->op_type = OP_LEAVE;
2321 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2323 else if (o->op_type == OP_LINESEQ) {
2325 o->op_type = OP_SCOPE;
2326 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2327 kid = ((LISTOP*)o)->op_first;
2328 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2331 /* The following deals with things like 'do {1 for 1}' */
2332 kid = kid->op_sibling;
2334 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2339 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2345 Perl_block_start(pTHX_ int full)
2348 const int retval = PL_savestack_ix;
2350 pad_block_start(full);
2352 PL_hints &= ~HINT_BLOCK_SCOPE;
2353 SAVECOMPILEWARNINGS();
2354 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2356 CALL_BLOCK_HOOKS(bhk_start, full);
2362 Perl_block_end(pTHX_ I32 floor, OP *seq)
2365 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2366 OP* retval = scalarseq(seq);
2368 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2371 CopHINTS_set(&PL_compiling, PL_hints);
2373 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2376 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2382 =head1 Compile-time scope hooks
2384 =for apidoc Ao||blockhook_register
2386 Register a set of hooks to be called when the Perl lexical scope changes
2387 at compile time. See L<perlguts/"Compile-time scope hooks">.
2393 Perl_blockhook_register(pTHX_ BHK *hk)
2395 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2397 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2404 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2405 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2406 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2409 OP * const o = newOP(OP_PADSV, 0);
2410 o->op_targ = offset;
2416 Perl_newPROG(pTHX_ OP *o)
2420 PERL_ARGS_ASSERT_NEWPROG;
2425 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2426 ((PL_in_eval & EVAL_KEEPERR)
2427 ? OPf_SPECIAL : 0), o);
2428 /* don't use LINKLIST, since PL_eval_root might indirect through
2429 * a rather expensive function call and LINKLIST evaluates its
2430 * argument more than once */
2431 PL_eval_start = op_linklist(PL_eval_root);
2432 PL_eval_root->op_private |= OPpREFCOUNTED;
2433 OpREFCNT_set(PL_eval_root, 1);
2434 PL_eval_root->op_next = 0;
2435 CALL_PEEP(PL_eval_start);
2438 if (o->op_type == OP_STUB) {
2439 PL_comppad_name = 0;
2441 S_op_destroy(aTHX_ o);
2444 PL_main_root = scope(sawparens(scalarvoid(o)));
2445 PL_curcop = &PL_compiling;
2446 PL_main_start = LINKLIST(PL_main_root);
2447 PL_main_root->op_private |= OPpREFCOUNTED;
2448 OpREFCNT_set(PL_main_root, 1);
2449 PL_main_root->op_next = 0;
2450 CALL_PEEP(PL_main_start);
2453 /* Register with debugger */
2455 CV * const cv = get_cvs("DB::postponed", 0);
2459 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2461 call_sv(MUTABLE_SV(cv), G_DISCARD);
2468 Perl_localize(pTHX_ OP *o, I32 lex)
2472 PERL_ARGS_ASSERT_LOCALIZE;
2474 if (o->op_flags & OPf_PARENS)
2475 /* [perl #17376]: this appears to be premature, and results in code such as
2476 C< our(%x); > executing in list mode rather than void mode */
2483 if ( PL_parser->bufptr > PL_parser->oldbufptr
2484 && PL_parser->bufptr[-1] == ','
2485 && ckWARN(WARN_PARENTHESIS))
2487 char *s = PL_parser->bufptr;
2490 /* some heuristics to detect a potential error */
2491 while (*s && (strchr(", \t\n", *s)))
2495 if (*s && strchr("@$%*", *s) && *++s
2496 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2499 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2501 while (*s && (strchr(", \t\n", *s)))
2507 if (sigil && (*s == ';' || *s == '=')) {
2508 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2509 "Parentheses missing around \"%s\" list",
2511 ? (PL_parser->in_my == KEY_our
2513 : PL_parser->in_my == KEY_state
2523 o = mod(o, OP_NULL); /* a bit kludgey */
2524 PL_parser->in_my = FALSE;
2525 PL_parser->in_my_stash = NULL;
2530 Perl_jmaybe(pTHX_ OP *o)
2532 PERL_ARGS_ASSERT_JMAYBE;
2534 if (o->op_type == OP_LIST) {
2536 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2537 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2543 S_fold_constants(pTHX_ register OP *o)
2546 register OP * VOL curop;
2548 VOL I32 type = o->op_type;
2553 SV * const oldwarnhook = PL_warnhook;
2554 SV * const olddiehook = PL_diehook;
2558 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2560 if (PL_opargs[type] & OA_RETSCALAR)
2562 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2563 o->op_targ = pad_alloc(type, SVs_PADTMP);
2565 /* integerize op, unless it happens to be C<-foo>.
2566 * XXX should pp_i_negate() do magic string negation instead? */
2567 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2568 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2569 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2571 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2574 if (!(PL_opargs[type] & OA_FOLDCONST))
2579 /* XXX might want a ck_negate() for this */
2580 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2591 /* XXX what about the numeric ops? */
2592 if (PL_hints & HINT_LOCALE)
2597 if (PL_parser && PL_parser->error_count)
2598 goto nope; /* Don't try to run w/ errors */
2600 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2601 const OPCODE type = curop->op_type;
2602 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2604 type != OP_SCALAR &&
2606 type != OP_PUSHMARK)
2612 curop = LINKLIST(o);
2613 old_next = o->op_next;
2617 oldscope = PL_scopestack_ix;
2618 create_eval_scope(G_FAKINGEVAL);
2620 /* Verify that we don't need to save it: */
2621 assert(PL_curcop == &PL_compiling);
2622 StructCopy(&PL_compiling, ¬_compiling, COP);
2623 PL_curcop = ¬_compiling;
2624 /* The above ensures that we run with all the correct hints of the
2625 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2626 assert(IN_PERL_RUNTIME);
2627 PL_warnhook = PERL_WARNHOOK_FATAL;
2634 sv = *(PL_stack_sp--);
2635 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2636 pad_swipe(o->op_targ, FALSE);
2637 else if (SvTEMP(sv)) { /* grab mortal temp? */
2638 SvREFCNT_inc_simple_void(sv);
2643 /* Something tried to die. Abandon constant folding. */
2644 /* Pretend the error never happened. */
2646 o->op_next = old_next;
2650 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2651 PL_warnhook = oldwarnhook;
2652 PL_diehook = olddiehook;
2653 /* XXX note that this croak may fail as we've already blown away
2654 * the stack - eg any nested evals */
2655 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2658 PL_warnhook = oldwarnhook;
2659 PL_diehook = olddiehook;
2660 PL_curcop = &PL_compiling;
2662 if (PL_scopestack_ix > oldscope)
2663 delete_eval_scope();
2672 if (type == OP_RV2GV)
2673 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2675 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2676 op_getmad(o,newop,'f');
2684 S_gen_constant_list(pTHX_ register OP *o)
2688 const I32 oldtmps_floor = PL_tmps_floor;
2691 if (PL_parser && PL_parser->error_count)
2692 return o; /* Don't attempt to run with errors */
2694 PL_op = curop = LINKLIST(o);
2700 assert (!(curop->op_flags & OPf_SPECIAL));
2701 assert(curop->op_type == OP_RANGE);
2703 PL_tmps_floor = oldtmps_floor;
2705 o->op_type = OP_RV2AV;
2706 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2707 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2708 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2709 o->op_opt = 0; /* needs to be revisited in rpeep() */
2710 curop = ((UNOP*)o)->op_first;
2711 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2713 op_getmad(curop,o,'O');
2722 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2725 if (!o || o->op_type != OP_LIST)
2726 o = newLISTOP(OP_LIST, 0, o, NULL);
2728 o->op_flags &= ~OPf_WANT;
2730 if (!(PL_opargs[type] & OA_MARK))
2731 op_null(cLISTOPo->op_first);
2733 o->op_type = (OPCODE)type;
2734 o->op_ppaddr = PL_ppaddr[type];
2735 o->op_flags |= flags;
2737 o = CHECKOP(type, o);
2738 if (o->op_type != (unsigned)type)
2741 return fold_constants(o);
2745 =head1 Optree Manipulation Functions
2748 /* List constructors */
2751 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2753 Append an item to the list of ops contained directly within a list-type
2754 op, returning the lengthened list. I<first> is the list-type op,
2755 and I<last> is the op to append to the list. I<optype> specifies the
2756 intended opcode for the list. If I<first> is not already a list of the
2757 right type, it will be upgraded into one. If either I<first> or I<last>
2758 is null, the other is returned unchanged.
2764 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2772 if (first->op_type != (unsigned)type
2773 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2775 return newLISTOP(type, 0, first, last);
2778 if (first->op_flags & OPf_KIDS)
2779 ((LISTOP*)first)->op_last->op_sibling = last;
2781 first->op_flags |= OPf_KIDS;
2782 ((LISTOP*)first)->op_first = last;
2784 ((LISTOP*)first)->op_last = last;
2789 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2791 Concatenate the lists of ops contained directly within two list-type ops,
2792 returning the combined list. I<first> and I<last> are the list-type ops
2793 to concatenate. I<optype> specifies the intended opcode for the list.
2794 If either I<first> or I<last> is not already a list of the right type,
2795 it will be upgraded into one. If either I<first> or I<last> is null,
2796 the other is returned unchanged.
2802 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2810 if (first->op_type != (unsigned)type)
2811 return op_prepend_elem(type, first, last);
2813 if (last->op_type != (unsigned)type)
2814 return op_append_elem(type, first, last);
2816 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2817 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2818 first->op_flags |= (last->op_flags & OPf_KIDS);
2821 if (((LISTOP*)last)->op_first && first->op_madprop) {
2822 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2824 while (mp->mad_next)
2826 mp->mad_next = first->op_madprop;
2829 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2832 first->op_madprop = last->op_madprop;
2833 last->op_madprop = 0;
2836 S_op_destroy(aTHX_ last);
2842 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2844 Prepend an item to the list of ops contained directly within a list-type
2845 op, returning the lengthened list. I<first> is the op to prepend to the
2846 list, and I<last> is the list-type op. I<optype> specifies the intended
2847 opcode for the list. If I<last> is not already a list of the right type,
2848 it will be upgraded into one. If either I<first> or I<last> is null,
2849 the other is returned unchanged.
2855 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2863 if (last->op_type == (unsigned)type) {
2864 if (type == OP_LIST) { /* already a PUSHMARK there */
2865 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2866 ((LISTOP*)last)->op_first->op_sibling = first;
2867 if (!(first->op_flags & OPf_PARENS))
2868 last->op_flags &= ~OPf_PARENS;
2871 if (!(last->op_flags & OPf_KIDS)) {
2872 ((LISTOP*)last)->op_last = first;
2873 last->op_flags |= OPf_KIDS;
2875 first->op_sibling = ((LISTOP*)last)->op_first;
2876 ((LISTOP*)last)->op_first = first;
2878 last->op_flags |= OPf_KIDS;
2882 return newLISTOP(type, 0, first, last);
2890 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2893 Newxz(tk, 1, TOKEN);
2894 tk->tk_type = (OPCODE)optype;
2895 tk->tk_type = 12345;
2897 tk->tk_mad = madprop;
2902 Perl_token_free(pTHX_ TOKEN* tk)
2904 PERL_ARGS_ASSERT_TOKEN_FREE;
2906 if (tk->tk_type != 12345)
2908 mad_free(tk->tk_mad);
2913 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2918 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2920 if (tk->tk_type != 12345) {
2921 Perl_warner(aTHX_ packWARN(WARN_MISC),
2922 "Invalid TOKEN object ignored");
2929 /* faked up qw list? */
2931 tm->mad_type == MAD_SV &&
2932 SvPVX((SV *)tm->mad_val)[0] == 'q')
2939 /* pretend constant fold didn't happen? */
2940 if (mp->mad_key == 'f' &&
2941 (o->op_type == OP_CONST ||
2942 o->op_type == OP_GV) )
2944 token_getmad(tk,(OP*)mp->mad_val,slot);
2958 if (mp->mad_key == 'X')
2959 mp->mad_key = slot; /* just change the first one */
2969 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2978 /* pretend constant fold didn't happen? */
2979 if (mp->mad_key == 'f' &&
2980 (o->op_type == OP_CONST ||
2981 o->op_type == OP_GV) )
2983 op_getmad(from,(OP*)mp->mad_val,slot);
2990 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2993 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2999 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3008 /* pretend constant fold didn't happen? */
3009 if (mp->mad_key == 'f' &&
3010 (o->op_type == OP_CONST ||
3011 o->op_type == OP_GV) )
3013 op_getmad(from,(OP*)mp->mad_val,slot);
3020 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3023 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3027 PerlIO_printf(PerlIO_stderr(),
3028 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3034 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3052 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3056 addmad(tm, &(o->op_madprop), slot);
3060 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3081 Perl_newMADsv(pTHX_ char key, SV* sv)
3083 PERL_ARGS_ASSERT_NEWMADSV;
3085 return newMADPROP(key, MAD_SV, sv, 0);
3089 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3092 Newxz(mp, 1, MADPROP);
3095 mp->mad_vlen = vlen;
3096 mp->mad_type = type;
3098 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3103 Perl_mad_free(pTHX_ MADPROP* mp)
3105 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3109 mad_free(mp->mad_next);
3110 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3111 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3112 switch (mp->mad_type) {
3116 Safefree((char*)mp->mad_val);
3119 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3120 op_free((OP*)mp->mad_val);
3123 sv_free(MUTABLE_SV(mp->mad_val));
3126 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3135 =head1 Optree construction
3137 =for apidoc Am|OP *|newNULLLIST
3139 Constructs, checks, and returns a new C<stub> op, which represents an
3140 empty list expression.
3146 Perl_newNULLLIST(pTHX)
3148 return newOP(OP_STUB, 0);
3152 S_force_list(pTHX_ OP *o)
3154 if (!o || o->op_type != OP_LIST)
3155 o = newLISTOP(OP_LIST, 0, o, NULL);
3161 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3163 Constructs, checks, and returns an op of any list type. I<type> is
3164 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3165 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3166 supply up to two ops to be direct children of the list op; they are
3167 consumed by this function and become part of the constructed op tree.
3173 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3178 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3180 NewOp(1101, listop, 1, LISTOP);
3182 listop->op_type = (OPCODE)type;
3183 listop->op_ppaddr = PL_ppaddr[type];
3186 listop->op_flags = (U8)flags;
3190 else if (!first && last)
3193 first->op_sibling = last;
3194 listop->op_first = first;
3195 listop->op_last = last;
3196 if (type == OP_LIST) {
3197 OP* const pushop = newOP(OP_PUSHMARK, 0);
3198 pushop->op_sibling = first;
3199 listop->op_first = pushop;
3200 listop->op_flags |= OPf_KIDS;
3202 listop->op_last = pushop;
3205 return CHECKOP(type, listop);
3209 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3211 Constructs, checks, and returns an op of any base type (any type that
3212 has no extra fields). I<type> is the opcode. I<flags> gives the
3213 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3220 Perl_newOP(pTHX_ I32 type, I32 flags)
3225 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3226 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3227 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3228 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3230 NewOp(1101, o, 1, OP);
3231 o->op_type = (OPCODE)type;
3232 o->op_ppaddr = PL_ppaddr[type];
3233 o->op_flags = (U8)flags;
3235 o->op_latefreed = 0;
3239 o->op_private = (U8)(0 | (flags >> 8));
3240 if (PL_opargs[type] & OA_RETSCALAR)
3242 if (PL_opargs[type] & OA_TARGET)
3243 o->op_targ = pad_alloc(type, SVs_PADTMP);
3244 return CHECKOP(type, o);
3248 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3250 Constructs, checks, and returns an op of any unary type. I<type> is
3251 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3252 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3253 bits, the eight bits of C<op_private>, except that the bit with value 1
3254 is automatically set. I<first> supplies an optional op to be the direct
3255 child of the unary op; it is consumed by this function and become part
3256 of the constructed op tree.
3262 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3267 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3268 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3269 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3270 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3271 || type == OP_SASSIGN
3272 || type == OP_ENTERTRY
3273 || type == OP_NULL );
3276 first = newOP(OP_STUB, 0);
3277 if (PL_opargs[type] & OA_MARK)
3278 first = force_list(first);
3280 NewOp(1101, unop, 1, UNOP);
3281 unop->op_type = (OPCODE)type;
3282 unop->op_ppaddr = PL_ppaddr[type];
3283 unop->op_first = first;
3284 unop->op_flags = (U8)(flags | OPf_KIDS);
3285 unop->op_private = (U8)(1 | (flags >> 8));
3286 unop = (UNOP*) CHECKOP(type, unop);
3290 return fold_constants((OP *) unop);
3294 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3296 Constructs, checks, and returns an op of any binary type. I<type>
3297 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3298 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3299 the eight bits of C<op_private>, except that the bit with value 1 or
3300 2 is automatically set as required. I<first> and I<last> supply up to
3301 two ops to be the direct children of the binary op; they are consumed
3302 by this function and become part of the constructed op tree.
3308 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3313 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3314 || type == OP_SASSIGN || type == OP_NULL );
3316 NewOp(1101, binop, 1, BINOP);
3319 first = newOP(OP_NULL, 0);
3321 binop->op_type = (OPCODE)type;
3322 binop->op_ppaddr = PL_ppaddr[type];
3323 binop->op_first = first;
3324 binop->op_flags = (U8)(flags | OPf_KIDS);
3327 binop->op_private = (U8)(1 | (flags >> 8));
3330 binop->op_private = (U8)(2 | (flags >> 8));
3331 first->op_sibling = last;
3334 binop = (BINOP*)CHECKOP(type, binop);
3335 if (binop->op_next || binop->op_type != (OPCODE)type)
3338 binop->op_last = binop->op_first->op_sibling;
3340 return fold_constants((OP *)binop);
3343 static int uvcompare(const void *a, const void *b)
3344 __attribute__nonnull__(1)
3345 __attribute__nonnull__(2)
3346 __attribute__pure__;
3347 static int uvcompare(const void *a, const void *b)
3349 if (*((const UV *)a) < (*(const UV *)b))
3351 if (*((const UV *)a) > (*(const UV *)b))
3353 if (*((const UV *)a+1) < (*(const UV *)b+1))
3355 if (*((const UV *)a+1) > (*(const UV *)b+1))
3361 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3364 SV * const tstr = ((SVOP*)expr)->op_sv;
3367 (repl->op_type == OP_NULL)
3368 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3370 ((SVOP*)repl)->op_sv;
3373 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3374 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3378 register short *tbl;
3380 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3381 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3382 I32 del = o->op_private & OPpTRANS_DELETE;
3385 PERL_ARGS_ASSERT_PMTRANS;
3387 PL_hints |= HINT_BLOCK_SCOPE;
3390 o->op_private |= OPpTRANS_FROM_UTF;
3393 o->op_private |= OPpTRANS_TO_UTF;
3395 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3396 SV* const listsv = newSVpvs("# comment\n");
3398 const U8* tend = t + tlen;
3399 const U8* rend = r + rlen;
3413 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3414 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3417 const U32 flags = UTF8_ALLOW_DEFAULT;
3421 t = tsave = bytes_to_utf8(t, &len);
3424 if (!to_utf && rlen) {
3426 r = rsave = bytes_to_utf8(r, &len);
3430 /* There are several snags with this code on EBCDIC:
3431 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3432 2. scan_const() in toke.c has encoded chars in native encoding which makes
3433 ranges at least in EBCDIC 0..255 range the bottom odd.
3437 U8 tmpbuf[UTF8_MAXBYTES+1];
3440 Newx(cp, 2*tlen, UV);
3442 transv = newSVpvs("");
3444 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3446 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3448 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3452 cp[2*i+1] = cp[2*i];
3456 qsort(cp, i, 2*sizeof(UV), uvcompare);
3457 for (j = 0; j < i; j++) {
3459 diff = val - nextmin;
3461 t = uvuni_to_utf8(tmpbuf,nextmin);
3462 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3464 U8 range_mark = UTF_TO_NATIVE(0xff);
3465 t = uvuni_to_utf8(tmpbuf, val - 1);
3466 sv_catpvn(transv, (char *)&range_mark, 1);
3467 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3474 t = uvuni_to_utf8(tmpbuf,nextmin);
3475 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3477 U8 range_mark = UTF_TO_NATIVE(0xff);
3478 sv_catpvn(transv, (char *)&range_mark, 1);
3480 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3481 UNICODE_ALLOW_SUPER);
3482 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3483 t = (const U8*)SvPVX_const(transv);
3484 tlen = SvCUR(transv);
3488 else if (!rlen && !del) {
3489 r = t; rlen = tlen; rend = tend;
3492 if ((!rlen && !del) || t == r ||
3493 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3495 o->op_private |= OPpTRANS_IDENTICAL;
3499 while (t < tend || tfirst <= tlast) {
3500 /* see if we need more "t" chars */
3501 if (tfirst > tlast) {
3502 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3504 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3506 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3513 /* now see if we need more "r" chars */
3514 if (rfirst > rlast) {
3516 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3518 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3520 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3529 rfirst = rlast = 0xffffffff;
3533 /* now see which range will peter our first, if either. */
3534 tdiff = tlast - tfirst;
3535 rdiff = rlast - rfirst;
3542 if (rfirst == 0xffffffff) {
3543 diff = tdiff; /* oops, pretend rdiff is infinite */
3545 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3546 (long)tfirst, (long)tlast);
3548 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3552 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3553 (long)tfirst, (long)(tfirst + diff),
3556 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3557 (long)tfirst, (long)rfirst);
3559 if (rfirst + diff > max)
3560 max = rfirst + diff;
3562 grows = (tfirst < rfirst &&
3563 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3575 else if (max > 0xff)
3580 PerlMemShared_free(cPVOPo->op_pv);
3581 cPVOPo->op_pv = NULL;
3583 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3585 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3586 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3587 PAD_SETSV(cPADOPo->op_padix, swash);
3589 SvREADONLY_on(swash);
3591 cSVOPo->op_sv = swash;
3593 SvREFCNT_dec(listsv);
3594 SvREFCNT_dec(transv);
3596 if (!del && havefinal && rlen)
3597 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3598 newSVuv((UV)final), 0);
3601 o->op_private |= OPpTRANS_GROWS;
3607 op_getmad(expr,o,'e');
3608 op_getmad(repl,o,'r');
3616 tbl = (short*)cPVOPo->op_pv;
3618 Zero(tbl, 256, short);
3619 for (i = 0; i < (I32)tlen; i++)
3621 for (i = 0, j = 0; i < 256; i++) {
3623 if (j >= (I32)rlen) {
3632 if (i < 128 && r[j] >= 128)
3642 o->op_private |= OPpTRANS_IDENTICAL;
3644 else if (j >= (I32)rlen)
3649 PerlMemShared_realloc(tbl,
3650 (0x101+rlen-j) * sizeof(short));
3651 cPVOPo->op_pv = (char*)tbl;
3653 tbl[0x100] = (short)(rlen - j);
3654 for (i=0; i < (I32)rlen - j; i++)
3655 tbl[0x101+i] = r[j+i];
3659 if (!rlen && !del) {
3662 o->op_private |= OPpTRANS_IDENTICAL;
3664 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3665 o->op_private |= OPpTRANS_IDENTICAL;
3667 for (i = 0; i < 256; i++)
3669 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3670 if (j >= (I32)rlen) {
3672 if (tbl[t[i]] == -1)
3678 if (tbl[t[i]] == -1) {
3679 if (t[i] < 128 && r[j] >= 128)
3686 if(del && rlen == tlen) {
3687 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3688 } else if(rlen > tlen) {
3689 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3693 o->op_private |= OPpTRANS_GROWS;
3695 op_getmad(expr,o,'e');
3696 op_getmad(repl,o,'r');
3706 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3708 Constructs, checks, and returns an op of any pattern matching type.
3709 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3710 and, shifted up eight bits, the eight bits of C<op_private>.
3716 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3721 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3723 NewOp(1101, pmop, 1, PMOP);
3724 pmop->op_type = (OPCODE)type;
3725 pmop->op_ppaddr = PL_ppaddr[type];
3726 pmop->op_flags = (U8)flags;
3727 pmop->op_private = (U8)(0 | (flags >> 8));
3729 if (PL_hints & HINT_RE_TAINT)
3730 pmop->op_pmflags |= PMf_RETAINT;
3731 if (PL_hints & HINT_LOCALE) {
3732 pmop->op_pmflags |= PMf_LOCALE;
3734 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3735 pmop->op_pmflags |= RXf_PMf_UNICODE;
3737 if (PL_hints & HINT_RE_FLAGS) {
3738 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3739 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3741 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3742 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3743 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_dul"), 0, 0
3745 if (reflags && SvOK(reflags)) {
3746 pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
3747 pmop->op_pmflags |= SvIV(reflags);
3753 assert(SvPOK(PL_regex_pad[0]));
3754 if (SvCUR(PL_regex_pad[0])) {
3755 /* Pop off the "packed" IV from the end. */
3756 SV *const repointer_list = PL_regex_pad[0];
3757 const char *p = SvEND(repointer_list) - sizeof(IV);
3758 const IV offset = *((IV*)p);
3760 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3762 SvEND_set(repointer_list, p);
3764 pmop->op_pmoffset = offset;
3765 /* This slot should be free, so assert this: */
3766 assert(PL_regex_pad[offset] == &PL_sv_undef);
3768 SV * const repointer = &PL_sv_undef;
3769 av_push(PL_regex_padav, repointer);
3770 pmop->op_pmoffset = av_len(PL_regex_padav);
3771 PL_regex_pad = AvARRAY(PL_regex_padav);
3775 return CHECKOP(type, pmop);
3778 /* Given some sort of match op o, and an expression expr containing a
3779 * pattern, either compile expr into a regex and attach it to o (if it's
3780 * constant), or convert expr into a runtime regcomp op sequence (if it's
3783 * isreg indicates that the pattern is part of a regex construct, eg
3784 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3785 * split "pattern", which aren't. In the former case, expr will be a list
3786 * if the pattern contains more than one term (eg /a$b/) or if it contains
3787 * a replacement, ie s/// or tr///.
3791 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3796 I32 repl_has_vars = 0;
3800 PERL_ARGS_ASSERT_PMRUNTIME;
3802 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3803 /* last element in list is the replacement; pop it */
3805 repl = cLISTOPx(expr)->op_last;
3806 kid = cLISTOPx(expr)->op_first;
3807 while (kid->op_sibling != repl)
3808 kid = kid->op_sibling;
3809 kid->op_sibling = NULL;
3810 cLISTOPx(expr)->op_last = kid;
3813 if (isreg && expr->op_type == OP_LIST &&
3814 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3816 /* convert single element list to element */
3817 OP* const oe = expr;
3818 expr = cLISTOPx(oe)->op_first->op_sibling;
3819 cLISTOPx(oe)->op_first->op_sibling = NULL;
3820 cLISTOPx(oe)->op_last = NULL;
3824 if (o->op_type == OP_TRANS) {
3825 return pmtrans(o, expr, repl);
3828 reglist = isreg && expr->op_type == OP_LIST;
3832 PL_hints |= HINT_BLOCK_SCOPE;
3835 if (expr->op_type == OP_CONST) {
3836 SV *pat = ((SVOP*)expr)->op_sv;
3837 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3839 if (o->op_flags & OPf_SPECIAL)
3840 pm_flags |= RXf_SPLIT;
3843 assert (SvUTF8(pat));
3844 } else if (SvUTF8(pat)) {
3845 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3846 trapped in use 'bytes'? */
3847 /* Make a copy of the octet sequence, but without the flag on, as
3848 the compiler now honours the SvUTF8 flag on pat. */
3850 const char *const p = SvPV(pat, len);
3851 pat = newSVpvn_flags(p, len, SVs_TEMP);
3854 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3857 op_getmad(expr,(OP*)pm,'e');
3863 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3864 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3866 : OP_REGCMAYBE),0,expr);
3868 NewOp(1101, rcop, 1, LOGOP);
3869 rcop->op_type = OP_REGCOMP;
3870 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3871 rcop->op_first = scalar(expr);
3872 rcop->op_flags |= OPf_KIDS
3873 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3874 | (reglist ? OPf_STACKED : 0);
3875 rcop->op_private = 1;
3878 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3880 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3883 /* establish postfix order */
3884 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3886 rcop->op_next = expr;
3887 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3890 rcop->op_next = LINKLIST(expr);
3891 expr->op_next = (OP*)rcop;
3894 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3899 if (pm->op_pmflags & PMf_EVAL) {
3901 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3902 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3904 else if (repl->op_type == OP_CONST)
3908 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3909 if (curop->op_type == OP_SCOPE
3910 || curop->op_type == OP_LEAVE
3911 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3912 if (curop->op_type == OP_GV) {
3913 GV * const gv = cGVOPx_gv(curop);
3915 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3918 else if (curop->op_type == OP_RV2CV)
3920 else if (curop->op_type == OP_RV2SV ||
3921 curop->op_type == OP_RV2AV ||
3922 curop->op_type == OP_RV2HV ||
3923 curop->op_type == OP_RV2GV) {
3924 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3927 else if (curop->op_type == OP_PADSV ||
3928 curop->op_type == OP_PADAV ||
3929 curop->op_type == OP_PADHV ||
3930 curop->op_type == OP_PADANY)
3934 else if (curop->op_type == OP_PUSHRE)
3935 NOOP; /* Okay here, dangerous in newASSIGNOP */
3945 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3947 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3948 op_prepend_elem(o->op_type, scalar(repl), o);
3951 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3952 pm->op_pmflags |= PMf_MAYBE_CONST;
3954 NewOp(1101, rcop, 1, LOGOP);
3955 rcop->op_type = OP_SUBSTCONT;
3956 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3957 rcop->op_first = scalar(repl);
3958 rcop->op_flags |= OPf_KIDS;
3959 rcop->op_private = 1;
3962 /* establish postfix order */
3963 rcop->op_next = LINKLIST(repl);
3964 repl->op_next = (OP*)rcop;
3966 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3967 assert(!(pm->op_pmflags & PMf_ONCE));
3968 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3977 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
3979 Constructs, checks, and returns an op of any type that involves an
3980 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
3981 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
3982 takes ownership of one reference to it.
3988 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3993 PERL_ARGS_ASSERT_NEWSVOP;
3995 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3996 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3997 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3999 NewOp(1101, svop, 1, SVOP);
4000 svop->op_type = (OPCODE)type;
4001 svop->op_ppaddr = PL_ppaddr[type];
4003 svop->op_next = (OP*)svop;
4004 svop->op_flags = (U8)flags;
4005 if (PL_opargs[type] & OA_RETSCALAR)
4007 if (PL_opargs[type] & OA_TARGET)
4008 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4009 return CHECKOP(type, svop);
4015 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4017 Constructs, checks, and returns an op of any type that involves a
4018 reference to a pad element. I<type> is the opcode. I<flags> gives the
4019 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4020 is populated with I<sv>; this function takes ownership of one reference
4023 This function only exists if Perl has been compiled to use ithreads.
4029 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4034 PERL_ARGS_ASSERT_NEWPADOP;
4036 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4037 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4038 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4040 NewOp(1101, padop, 1, PADOP);
4041 padop->op_type = (OPCODE)type;
4042 padop->op_ppaddr = PL_ppaddr[type];
4043 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4044 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4045 PAD_SETSV(padop->op_padix, sv);
4048 padop->op_next = (OP*)padop;
4049 padop->op_flags = (U8)flags;
4050 if (PL_opargs[type] & OA_RETSCALAR)
4052 if (PL_opargs[type] & OA_TARGET)
4053 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4054 return CHECKOP(type, padop);
4057 #endif /* !USE_ITHREADS */
4060 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4062 Constructs, checks, and returns an op of any type that involves an
4063 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4064 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4065 reference; calling this function does not transfer ownership of any
4072 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4076 PERL_ARGS_ASSERT_NEWGVOP;
4080 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4082 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4087 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4089 Constructs, checks, and returns an op of any type that involves an
4090 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4091 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4092 must have been allocated using L</PerlMemShared_malloc>; the memory will
4093 be freed when the op is destroyed.
4099 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4104 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4105 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4107 NewOp(1101, pvop, 1, PVOP);
4108 pvop->op_type = (OPCODE)type;
4109 pvop->op_ppaddr = PL_ppaddr[type];
4111 pvop->op_next = (OP*)pvop;
4112 pvop->op_flags = (U8)flags;
4113 if (PL_opargs[type] & OA_RETSCALAR)
4115 if (PL_opargs[type] & OA_TARGET)
4116 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4117 return CHECKOP(type, pvop);
4125 Perl_package(pTHX_ OP *o)
4128 SV *const sv = cSVOPo->op_sv;
4133 PERL_ARGS_ASSERT_PACKAGE;
4135 save_hptr(&PL_curstash);
4136 save_item(PL_curstname);
4138 PL_curstash = gv_stashsv(sv, GV_ADD);
4140 sv_setsv(PL_curstname, sv);
4142 PL_hints |= HINT_BLOCK_SCOPE;
4143 PL_parser->copline = NOLINE;
4144 PL_parser->expect = XSTATE;
4149 if (!PL_madskills) {
4154 pegop = newOP(OP_NULL,0);
4155 op_getmad(o,pegop,'P');
4161 Perl_package_version( pTHX_ OP *v )
4164 U32 savehints = PL_hints;
4165 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4166 PL_hints &= ~HINT_STRICT_VARS;
4167 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4168 PL_hints = savehints;
4177 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4184 OP *pegop = newOP(OP_NULL,0);
4187 PERL_ARGS_ASSERT_UTILIZE;
4189 if (idop->op_type != OP_CONST)
4190 Perl_croak(aTHX_ "Module name must be constant");
4193 op_getmad(idop,pegop,'U');
4198 SV * const vesv = ((SVOP*)version)->op_sv;
4201 op_getmad(version,pegop,'V');
4202 if (!arg && !SvNIOKp(vesv)) {
4209 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4210 Perl_croak(aTHX_ "Version number must be a constant number");
4212 /* Make copy of idop so we don't free it twice */
4213 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4215 /* Fake up a method call to VERSION */
4216 meth = newSVpvs_share("VERSION");
4217 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4218 op_append_elem(OP_LIST,
4219 op_prepend_elem(OP_LIST, pack, list(version)),
4220 newSVOP(OP_METHOD_NAMED, 0, meth)));
4224 /* Fake up an import/unimport */
4225 if (arg && arg->op_type == OP_STUB) {
4227 op_getmad(arg,pegop,'S');
4228 imop = arg; /* no import on explicit () */
4230 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4231 imop = NULL; /* use 5.0; */
4233 idop->op_private |= OPpCONST_NOVER;
4239 op_getmad(arg,pegop,'A');
4241 /* Make copy of idop so we don't free it twice */
4242 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4244 /* Fake up a method call to import/unimport */
4246 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4247 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4248 op_append_elem(OP_LIST,
4249 op_prepend_elem(OP_LIST, pack, list(arg)),
4250 newSVOP(OP_METHOD_NAMED, 0, meth)));
4253 /* Fake up the BEGIN {}, which does its thing immediately. */
4255 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4258 op_append_elem(OP_LINESEQ,
4259 op_append_elem(OP_LINESEQ,
4260 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4261 newSTATEOP(0, NULL, veop)),
4262 newSTATEOP(0, NULL, imop) ));
4264 /* The "did you use incorrect case?" warning used to be here.
4265 * The problem is that on case-insensitive filesystems one
4266 * might get false positives for "use" (and "require"):
4267 * "use Strict" or "require CARP" will work. This causes
4268 * portability problems for the script: in case-strict
4269 * filesystems the script will stop working.
4271 * The "incorrect case" warning checked whether "use Foo"
4272 * imported "Foo" to your namespace, but that is wrong, too:
4273 * there is no requirement nor promise in the language that
4274 * a Foo.pm should or would contain anything in package "Foo".
4276 * There is very little Configure-wise that can be done, either:
4277 * the case-sensitivity of the build filesystem of Perl does not
4278 * help in guessing the case-sensitivity of the runtime environment.
4281 PL_hints |= HINT_BLOCK_SCOPE;
4282 PL_parser->copline = NOLINE;
4283 PL_parser->expect = XSTATE;
4284 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4287 if (!PL_madskills) {
4288 /* FIXME - don't allocate pegop if !PL_madskills */
4297 =head1 Embedding Functions
4299 =for apidoc load_module
4301 Loads the module whose name is pointed to by the string part of name.
4302 Note that the actual module name, not its filename, should be given.
4303 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4304 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4305 (or 0 for no flags). ver, if specified, provides version semantics
4306 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4307 arguments can be used to specify arguments to the module's import()
4308 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4309 terminated with a final NULL pointer. Note that this list can only
4310 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4311 Otherwise at least a single NULL pointer to designate the default
4312 import list is required.
4317 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4321 PERL_ARGS_ASSERT_LOAD_MODULE;
4323 va_start(args, ver);
4324 vload_module(flags, name, ver, &args);
4328 #ifdef PERL_IMPLICIT_CONTEXT
4330 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4334 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4335 va_start(args, ver);
4336 vload_module(flags, name, ver, &args);
4342 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4346 OP * const modname = newSVOP(OP_CONST, 0, name);
4348 PERL_ARGS_ASSERT_VLOAD_MODULE;
4350 modname->op_private |= OPpCONST_BARE;
4352 veop = newSVOP(OP_CONST, 0, ver);
4356 if (flags & PERL_LOADMOD_NOIMPORT) {
4357 imop = sawparens(newNULLLIST());
4359 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4360 imop = va_arg(*args, OP*);
4365 sv = va_arg(*args, SV*);
4367 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4368 sv = va_arg(*args, SV*);
4372 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4373 * that it has a PL_parser to play with while doing that, and also
4374 * that it doesn't mess with any existing parser, by creating a tmp
4375 * new parser with lex_start(). This won't actually be used for much,
4376 * since pp_require() will create another parser for the real work. */
4379 SAVEVPTR(PL_curcop);
4380 lex_start(NULL, NULL, 0);
4381 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4382 veop, modname, imop);
4387 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4393 PERL_ARGS_ASSERT_DOFILE;
4395 if (!force_builtin) {
4396 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4397 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4398 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4399 gv = gvp ? *gvp : NULL;
4403 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4404 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4405 op_append_elem(OP_LIST, term,
4406 scalar(newUNOP(OP_RV2CV, 0,
4407 newGVOP(OP_GV, 0, gv))))));
4410 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4416 =head1 Optree construction
4418 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4420 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4421 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4422 be set automatically, and, shifted up eight bits, the eight bits of
4423 C<op_private>, except that the bit with value 1 or 2 is automatically
4424 set as required. I<listval> and I<subscript> supply the parameters of
4425 the slice; they are consumed by this function and become part of the
4426 constructed op tree.
4432 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4434 return newBINOP(OP_LSLICE, flags,
4435 list(force_list(subscript)),
4436 list(force_list(listval)) );
4440 S_is_list_assignment(pTHX_ register const OP *o)
4448 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4449 o = cUNOPo->op_first;
4451 flags = o->op_flags;
4453 if (type == OP_COND_EXPR) {
4454 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4455 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4460 yyerror("Assignment to both a list and a scalar");
4464 if (type == OP_LIST &&
4465 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4466 o->op_private & OPpLVAL_INTRO)
4469 if (type == OP_LIST || flags & OPf_PARENS ||
4470 type == OP_RV2AV || type == OP_RV2HV ||
4471 type == OP_ASLICE || type == OP_HSLICE)
4474 if (type == OP_PADAV || type == OP_PADHV)
4477 if (type == OP_RV2SV)
4484 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4486 Constructs, checks, and returns an assignment op. I<left> and I<right>
4487 supply the parameters of the assignment; they are consumed by this
4488 function and become part of the constructed op tree.
4490 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4491 a suitable conditional optree is constructed. If I<optype> is the opcode
4492 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4493 performs the binary operation and assigns the result to the left argument.
4494 Either way, if I<optype> is non-zero then I<flags> has no effect.
4496 If I<optype> is zero, then a plain scalar or list assignment is
4497 constructed. Which type of assignment it is is automatically determined.
4498 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4499 will be set automatically, and, shifted up eight bits, the eight bits
4500 of C<op_private>, except that the bit with value 1 or 2 is automatically
4507 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4513 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4514 return newLOGOP(optype, 0,
4515 mod(scalar(left), optype),
4516 newUNOP(OP_SASSIGN, 0, scalar(right)));
4519 return newBINOP(optype, OPf_STACKED,
4520 mod(scalar(left), optype), scalar(right));
4524 if (is_list_assignment(left)) {
4525 static const char no_list_state[] = "Initialization of state variables"
4526 " in list context currently forbidden";
4528 bool maybe_common_vars = TRUE;
4531 /* Grandfathering $[ assignment here. Bletch.*/
4532 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4533 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4534 left = mod(left, OP_AASSIGN);
4537 else if (left->op_type == OP_CONST) {
4538 deprecate("assignment to $[");
4540 /* Result of assignment is always 1 (or we'd be dead already) */
4541 return newSVOP(OP_CONST, 0, newSViv(1));
4543 curop = list(force_list(left));
4544 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4545 o->op_private = (U8)(0 | (flags >> 8));
4547 if ((left->op_type == OP_LIST
4548 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4550 OP* lop = ((LISTOP*)left)->op_first;
4551 maybe_common_vars = FALSE;
4553 if (lop->op_type == OP_PADSV ||
4554 lop->op_type == OP_PADAV ||
4555 lop->op_type == OP_PADHV ||
4556 lop->op_type == OP_PADANY) {
4557 if (!(lop->op_private & OPpLVAL_INTRO))
4558 maybe_common_vars = TRUE;
4560 if (lop->op_private & OPpPAD_STATE) {
4561 if (left->op_private & OPpLVAL_INTRO) {
4562 /* Each variable in state($a, $b, $c) = ... */
4565 /* Each state variable in
4566 (state $a, my $b, our $c, $d, undef) = ... */
4568 yyerror(no_list_state);
4570 /* Each my variable in
4571 (state $a, my $b, our $c, $d, undef) = ... */
4573 } else if (lop->op_type == OP_UNDEF ||
4574 lop->op_type == OP_PUSHMARK) {
4575 /* undef may be interesting in
4576 (state $a, undef, state $c) */
4578 /* Other ops in the list. */
4579 maybe_common_vars = TRUE;
4581 lop = lop->op_sibling;
4584 else if ((left->op_private & OPpLVAL_INTRO)
4585 && ( left->op_type == OP_PADSV
4586 || left->op_type == OP_PADAV
4587 || left->op_type == OP_PADHV
4588 || left->op_type == OP_PADANY))
4590 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4591 if (left->op_private & OPpPAD_STATE) {
4592 /* All single variable list context state assignments, hence
4602 yyerror(no_list_state);
4606 /* PL_generation sorcery:
4607 * an assignment like ($a,$b) = ($c,$d) is easier than
4608 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4609 * To detect whether there are common vars, the global var
4610 * PL_generation is incremented for each assign op we compile.
4611 * Then, while compiling the assign op, we run through all the
4612 * variables on both sides of the assignment, setting a spare slot
4613 * in each of them to PL_generation. If any of them already have
4614 * that value, we know we've got commonality. We could use a
4615 * single bit marker, but then we'd have to make 2 passes, first
4616 * to clear the flag, then to test and set it. To find somewhere
4617 * to store these values, evil chicanery is done with SvUVX().
4620 if (maybe_common_vars) {
4623 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4624 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4625 if (curop->op_type == OP_GV) {
4626 GV *gv = cGVOPx_gv(curop);
4628 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4630 GvASSIGN_GENERATION_set(gv, PL_generation);
4632 else if (curop->op_type == OP_PADSV ||
4633 curop->op_type == OP_PADAV ||
4634 curop->op_type == OP_PADHV ||
4635 curop->op_type == OP_PADANY)
4637 if (PAD_COMPNAME_GEN(curop->op_targ)
4638 == (STRLEN)PL_generation)
4640 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4643 else if (curop->op_type == OP_RV2CV)
4645 else if (curop->op_type == OP_RV2SV ||
4646 curop->op_type == OP_RV2AV ||
4647 curop->op_type == OP_RV2HV ||
4648 curop->op_type == OP_RV2GV) {
4649 if (lastop->op_type != OP_GV) /* funny deref? */
4652 else if (curop->op_type == OP_PUSHRE) {
4654 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4655 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4657 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4659 GvASSIGN_GENERATION_set(gv, PL_generation);
4663 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4666 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4668 GvASSIGN_GENERATION_set(gv, PL_generation);
4678 o->op_private |= OPpASSIGN_COMMON;
4681 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4682 OP* tmpop = ((LISTOP*)right)->op_first;
4683 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4684 PMOP * const pm = (PMOP*)tmpop;
4685 if (left->op_type == OP_RV2AV &&
4686 !(left->op_private & OPpLVAL_INTRO) &&
4687 !(o->op_private & OPpASSIGN_COMMON) )
4689 tmpop = ((UNOP*)left)->op_first;
4690 if (tmpop->op_type == OP_GV
4692 && !pm->op_pmreplrootu.op_pmtargetoff
4694 && !pm->op_pmreplrootu.op_pmtargetgv
4698 pm->op_pmreplrootu.op_pmtargetoff
4699 = cPADOPx(tmpop)->op_padix;
4700 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4702 pm->op_pmreplrootu.op_pmtargetgv
4703 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4704 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4706 pm->op_pmflags |= PMf_ONCE;
4707 tmpop = cUNOPo->op_first; /* to list (nulled) */
4708 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4709 tmpop->op_sibling = NULL; /* don't free split */
4710 right->op_next = tmpop->op_next; /* fix starting loc */
4711 op_free(o); /* blow off assign */
4712 right->op_flags &= ~OPf_WANT;
4713 /* "I don't know and I don't care." */
4718 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4719 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4721 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4722 if (SvIOK(sv) && SvIVX(sv) == 0)
4723 sv_setiv(sv, PL_modcount+1);
4731 right = newOP(OP_UNDEF, 0);
4732 if (right->op_type == OP_READLINE) {
4733 right->op_flags |= OPf_STACKED;
4734 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4737 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4738 o = newBINOP(OP_SASSIGN, flags,
4739 scalar(right), mod(scalar(left), OP_SASSIGN) );
4743 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4744 deprecate("assignment to $[");
4746 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4747 o->op_private |= OPpCONST_ARYBASE;
4755 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4757 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4758 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4759 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4760 If I<label> is non-null, it supplies the name of a label to attach to
4761 the state op; this function takes ownership of the memory pointed at by
4762 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4765 If I<o> is null, the state op is returned. Otherwise the state op is
4766 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4767 is consumed by this function and becomes part of the returned op tree.
4773 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4776 const U32 seq = intro_my();
4779 NewOp(1101, cop, 1, COP);
4780 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4781 cop->op_type = OP_DBSTATE;
4782 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4785 cop->op_type = OP_NEXTSTATE;
4786 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4788 cop->op_flags = (U8)flags;
4789 CopHINTS_set(cop, PL_hints);
4791 cop->op_private |= NATIVE_HINTS;
4793 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4794 cop->op_next = (OP*)cop;
4797 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4798 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4800 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4801 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4803 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4805 PL_hints |= HINT_BLOCK_SCOPE;
4806 /* It seems that we need to defer freeing this pointer, as other parts
4807 of the grammar end up wanting to copy it after this op has been
4812 if (PL_parser && PL_parser->copline == NOLINE)
4813 CopLINE_set(cop, CopLINE(PL_curcop));
4815 CopLINE_set(cop, PL_parser->copline);
4817 PL_parser->copline = NOLINE;
4820 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4822 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4824 CopSTASH_set(cop, PL_curstash);
4826 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4827 /* this line can have a breakpoint - store the cop in IV */
4828 AV *av = CopFILEAVx(PL_curcop);
4830 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4831 if (svp && *svp != &PL_sv_undef ) {
4832 (void)SvIOK_on(*svp);
4833 SvIV_set(*svp, PTR2IV(cop));
4838 if (flags & OPf_SPECIAL)
4840 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4844 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4846 Constructs, checks, and returns a logical (flow control) op. I<type>
4847 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4848 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4849 the eight bits of C<op_private>, except that the bit with value 1 is
4850 automatically set. I<first> supplies the expression controlling the
4851 flow, and I<other> supplies the side (alternate) chain of ops; they are
4852 consumed by this function and become part of the constructed op tree.
4858 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4862 PERL_ARGS_ASSERT_NEWLOGOP;
4864 return new_logop(type, flags, &first, &other);
4868 S_search_const(pTHX_ OP *o)
4870 PERL_ARGS_ASSERT_SEARCH_CONST;
4872 switch (o->op_type) {
4876 if (o->op_flags & OPf_KIDS)
4877 return search_const(cUNOPo->op_first);
4884 if (!(o->op_flags & OPf_KIDS))
4886 kid = cLISTOPo->op_first;
4888 switch (kid->op_type) {
4892 kid = kid->op_sibling;
4895 if (kid != cLISTOPo->op_last)
4901 kid = cLISTOPo->op_last;
4903 return search_const(kid);
4911 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4919 int prepend_not = 0;
4921 PERL_ARGS_ASSERT_NEW_LOGOP;
4926 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4927 return newBINOP(type, flags, scalar(first), scalar(other));
4929 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4931 scalarboolean(first);
4932 /* optimize AND and OR ops that have NOTs as children */
4933 if (first->op_type == OP_NOT
4934 && (first->op_flags & OPf_KIDS)
4935 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4936 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4938 if (type == OP_AND || type == OP_OR) {
4944 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4946 prepend_not = 1; /* prepend a NOT op later */
4950 /* search for a constant op that could let us fold the test */
4951 if ((cstop = search_const(first))) {
4952 if (cstop->op_private & OPpCONST_STRICT)
4953 no_bareword_allowed(cstop);
4954 else if ((cstop->op_private & OPpCONST_BARE))
4955 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4956 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4957 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4958 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4960 if (other->op_type == OP_CONST)
4961 other->op_private |= OPpCONST_SHORTCIRCUIT;
4963 OP *newop = newUNOP(OP_NULL, 0, other);
4964 op_getmad(first, newop, '1');
4965 newop->op_targ = type; /* set "was" field */
4969 if (other->op_type == OP_LEAVE)
4970 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4971 else if (other->op_type == OP_MATCH
4972 || other->op_type == OP_SUBST
4973 || other->op_type == OP_TRANS)
4974 /* Mark the op as being unbindable with =~ */
4975 other->op_flags |= OPf_SPECIAL;
4979 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4980 const OP *o2 = other;
4981 if ( ! (o2->op_type == OP_LIST
4982 && (( o2 = cUNOPx(o2)->op_first))
4983 && o2->op_type == OP_PUSHMARK
4984 && (( o2 = o2->op_sibling)) )
4987 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4988 || o2->op_type == OP_PADHV)
4989 && o2->op_private & OPpLVAL_INTRO
4990 && !(o2->op_private & OPpPAD_STATE))
4992 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4993 "Deprecated use of my() in false conditional");
4997 if (first->op_type == OP_CONST)
4998 first->op_private |= OPpCONST_SHORTCIRCUIT;
5000 first = newUNOP(OP_NULL, 0, first);
5001 op_getmad(other, first, '2');
5002 first->op_targ = type; /* set "was" field */
5009 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5010 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5012 const OP * const k1 = ((UNOP*)first)->op_first;
5013 const OP * const k2 = k1->op_sibling;
5015 switch (first->op_type)
5018 if (k2 && k2->op_type == OP_READLINE
5019 && (k2->op_flags & OPf_STACKED)
5020 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5022 warnop = k2->op_type;
5027 if (k1->op_type == OP_READDIR
5028 || k1->op_type == OP_GLOB
5029 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5030 || k1->op_type == OP_EACH)
5032 warnop = ((k1->op_type == OP_NULL)
5033 ? (OPCODE)k1->op_targ : k1->op_type);
5038 const line_t oldline = CopLINE(PL_curcop);
5039 CopLINE_set(PL_curcop, PL_parser->copline);
5040 Perl_warner(aTHX_ packWARN(WARN_MISC),
5041 "Value of %s%s can be \"0\"; test with defined()",
5043 ((warnop == OP_READLINE || warnop == OP_GLOB)
5044 ? " construct" : "() operator"));
5045 CopLINE_set(PL_curcop, oldline);
5052 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5053 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5055 NewOp(1101, logop, 1, LOGOP);
5057 logop->op_type = (OPCODE)type;
5058 logop->op_ppaddr = PL_ppaddr[type];
5059 logop->op_first = first;
5060 logop->op_flags = (U8)(flags | OPf_KIDS);
5061 logop->op_other = LINKLIST(other);
5062 logop->op_private = (U8)(1 | (flags >> 8));
5064 /* establish postfix order */
5065 logop->op_next = LINKLIST(first);
5066 first->op_next = (OP*)logop;
5067 first->op_sibling = other;
5069 CHECKOP(type,logop);
5071 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5078 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5080 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5081 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5082 will be set automatically, and, shifted up eight bits, the eight bits of
5083 C<op_private>, except that the bit with value 1 is automatically set.
5084 I<first> supplies the expression selecting between the two branches,
5085 and I<trueop> and I<falseop> supply the branches; they are consumed by
5086 this function and become part of the constructed op tree.
5092 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5100 PERL_ARGS_ASSERT_NEWCONDOP;
5103 return newLOGOP(OP_AND, 0, first, trueop);
5105 return newLOGOP(OP_OR, 0, first, falseop);
5107 scalarboolean(first);
5108 if ((cstop = search_const(first))) {
5109 /* Left or right arm of the conditional? */
5110 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5111 OP *live = left ? trueop : falseop;
5112 OP *const dead = left ? falseop : trueop;
5113 if (cstop->op_private & OPpCONST_BARE &&
5114 cstop->op_private & OPpCONST_STRICT) {
5115 no_bareword_allowed(cstop);
5118 /* This is all dead code when PERL_MAD is not defined. */
5119 live = newUNOP(OP_NULL, 0, live);
5120 op_getmad(first, live, 'C');
5121 op_getmad(dead, live, left ? 'e' : 't');
5126 if (live->op_type == OP_LEAVE)
5127 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5128 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5129 || live->op_type == OP_TRANS)
5130 /* Mark the op as being unbindable with =~ */
5131 live->op_flags |= OPf_SPECIAL;
5134 NewOp(1101, logop, 1, LOGOP);
5135 logop->op_type = OP_COND_EXPR;
5136 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5137 logop->op_first = first;
5138 logop->op_flags = (U8)(flags | OPf_KIDS);
5139 logop->op_private = (U8)(1 | (flags >> 8));
5140 logop->op_other = LINKLIST(trueop);
5141 logop->op_next = LINKLIST(falseop);
5143 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5146 /* establish postfix order */
5147 start = LINKLIST(first);
5148 first->op_next = (OP*)logop;
5150 first->op_sibling = trueop;
5151 trueop->op_sibling = falseop;
5152 o = newUNOP(OP_NULL, 0, (OP*)logop);
5154 trueop->op_next = falseop->op_next = o;
5161 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5163 Constructs and returns a C<range> op, with subordinate C<flip> and
5164 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5165 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5166 for both the C<flip> and C<range> ops, except that the bit with value
5167 1 is automatically set. I<left> and I<right> supply the expressions
5168 controlling the endpoints of the range; they are consumed by this function
5169 and become part of the constructed op tree.
5175 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5184 PERL_ARGS_ASSERT_NEWRANGE;
5186 NewOp(1101, range, 1, LOGOP);
5188 range->op_type = OP_RANGE;
5189 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5190 range->op_first = left;
5191 range->op_flags = OPf_KIDS;
5192 leftstart = LINKLIST(left);
5193 range->op_other = LINKLIST(right);
5194 range->op_private = (U8)(1 | (flags >> 8));
5196 left->op_sibling = right;
5198 range->op_next = (OP*)range;
5199 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5200 flop = newUNOP(OP_FLOP, 0, flip);
5201 o = newUNOP(OP_NULL, 0, flop);
5203 range->op_next = leftstart;
5205 left->op_next = flip;
5206 right->op_next = flop;
5208 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5209 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5210 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5211 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5213 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5214 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5217 if (!flip->op_private || !flop->op_private)
5218 LINKLIST(o); /* blow off optimizer unless constant */
5224 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5226 Constructs, checks, and returns an op tree expressing a loop. This is
5227 only a loop in the control flow through the op tree; it does not have
5228 the heavyweight loop structure that allows exiting the loop by C<last>
5229 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5230 top-level op, except that some bits will be set automatically as required.
5231 I<expr> supplies the expression controlling loop iteration, and I<block>
5232 supplies the body of the loop; they are consumed by this function and
5233 become part of the constructed op tree. I<debuggable> is currently
5234 unused and should always be 1.
5240 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5245 const bool once = block && block->op_flags & OPf_SPECIAL &&
5246 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5248 PERL_UNUSED_ARG(debuggable);
5251 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5252 return block; /* do {} while 0 does once */
5253 if (expr->op_type == OP_READLINE
5254 || expr->op_type == OP_READDIR
5255 || expr->op_type == OP_GLOB
5256 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5257 expr = newUNOP(OP_DEFINED, 0,
5258 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5259 } else if (expr->op_flags & OPf_KIDS) {
5260 const OP * const k1 = ((UNOP*)expr)->op_first;
5261 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5262 switch (expr->op_type) {
5264 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5265 && (k2->op_flags & OPf_STACKED)
5266 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5267 expr = newUNOP(OP_DEFINED, 0, expr);
5271 if (k1 && (k1->op_type == OP_READDIR
5272 || k1->op_type == OP_GLOB
5273 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5274 || k1->op_type == OP_EACH))
5275 expr = newUNOP(OP_DEFINED, 0, expr);
5281 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5282 * op, in listop. This is wrong. [perl #27024] */
5284 block = newOP(OP_NULL, 0);
5285 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5286 o = new_logop(OP_AND, 0, &expr, &listop);
5289 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5291 if (once && o != listop)
5292 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5295 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5297 o->op_flags |= flags;
5299 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5304 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|I32 whileline|OP *expr|OP *block|OP *cont|I32 has_my
5306 Constructs, checks, and returns an op tree expressing a C<while> loop.
5307 This is a heavyweight loop, with structure that allows exiting the loop
5308 by C<last> and suchlike.
5310 I<loop> is an optional preconstructed C<enterloop> op to use in the
5311 loop; if it is null then a suitable op will be constructed automatically.
5312 I<expr> supplies the loop's controlling expression. I<block> supplies the
5313 main body of the loop, and I<cont> optionally supplies a C<continue> block
5314 that operates as a second half of the body. All of these optree inputs
5315 are consumed by this function and become part of the constructed op tree.
5317 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5318 op and, shifted up eight bits, the eight bits of C<op_private> for
5319 the C<leaveloop> op, except that (in both cases) some bits will be set
5320 automatically. I<debuggable> is currently unused and should always be 1.
5321 I<whileline> is the line number that should be attributed to the loop's
5322 controlling expression. I<has_my> can be supplied as true to force the
5323 loop body to be enclosed in its own scope.
5329 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
5330 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
5339 PERL_UNUSED_ARG(debuggable);
5342 if (expr->op_type == OP_READLINE
5343 || expr->op_type == OP_READDIR
5344 || expr->op_type == OP_GLOB
5345 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5346 expr = newUNOP(OP_DEFINED, 0,
5347 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5348 } else if (expr->op_flags & OPf_KIDS) {
5349 const OP * const k1 = ((UNOP*)expr)->op_first;
5350 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5351 switch (expr->op_type) {
5353 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5354 && (k2->op_flags & OPf_STACKED)
5355 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5356 expr = newUNOP(OP_DEFINED, 0, expr);
5360 if (k1 && (k1->op_type == OP_READDIR
5361 || k1->op_type == OP_GLOB
5362 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5363 || k1->op_type == OP_EACH))
5364 expr = newUNOP(OP_DEFINED, 0, expr);
5371 block = newOP(OP_NULL, 0);
5372 else if (cont || has_my) {
5373 block = scope(block);
5377 next = LINKLIST(cont);
5380 OP * const unstack = newOP(OP_UNSTACK, 0);
5383 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5387 listop = op_append_list(OP_LINESEQ, block, cont);
5389 redo = LINKLIST(listop);
5392 PL_parser->copline = (line_t)whileline;
5394 o = new_logop(OP_AND, 0, &expr, &listop);
5395 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5396 op_free(expr); /* oops, it's a while (0) */
5398 return NULL; /* listop already freed by new_logop */
5401 ((LISTOP*)listop)->op_last->op_next =
5402 (o == listop ? redo : LINKLIST(o));
5408 NewOp(1101,loop,1,LOOP);
5409 loop->op_type = OP_ENTERLOOP;
5410 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5411 loop->op_private = 0;
5412 loop->op_next = (OP*)loop;
5415 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5417 loop->op_redoop = redo;
5418 loop->op_lastop = o;
5419 o->op_private |= loopflags;
5422 loop->op_nextop = next;
5424 loop->op_nextop = o;
5426 o->op_flags |= flags;
5427 o->op_private |= (flags >> 8);
5432 =for apidoc Am|OP *|newFOROP|I32 flags|char *label|line_t forline|OP *sv|OP *expr|OP *block|OP *cont
5434 Constructs, checks, and returns an op tree expressing a C<foreach>
5435 loop (iteration through a list of values). This is a heavyweight loop,
5436 with structure that allows exiting the loop by C<last> and suchlike.
5438 I<sv> optionally supplies the variable that will be aliased to each
5439 item in turn; if null, it defaults to C<$_> (either lexical or global).
5440 I<expr> supplies the list of values to iterate over. I<block> supplies
5441 the main body of the loop, and I<cont> optionally supplies a C<continue>
5442 block that operates as a second half of the body. All of these optree
5443 inputs are consumed by this function and become part of the constructed
5446 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5447 op and, shifted up eight bits, the eight bits of C<op_private> for
5448 the C<leaveloop> op, except that (in both cases) some bits will be set
5449 automatically. I<forline> is the line number that should be attributed
5450 to the loop's list expression. If I<label> is non-null, it supplies
5451 the name of a label to attach to the state op at the start of the loop;
5452 this function takes ownership of the memory pointed at by I<label>,
5459 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
5464 PADOFFSET padoff = 0;
5469 PERL_ARGS_ASSERT_NEWFOROP;
5472 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5473 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5474 sv->op_type = OP_RV2GV;
5475 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5477 /* The op_type check is needed to prevent a possible segfault
5478 * if the loop variable is undeclared and 'strict vars' is in
5479 * effect. This is illegal but is nonetheless parsed, so we
5480 * may reach this point with an OP_CONST where we're expecting
5483 if (cUNOPx(sv)->op_first->op_type == OP_GV
5484 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5485 iterpflags |= OPpITER_DEF;
5487 else if (sv->op_type == OP_PADSV) { /* private variable */
5488 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5489 padoff = sv->op_targ;
5499 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5501 SV *const namesv = PAD_COMPNAME_SV(padoff);
5503 const char *const name = SvPV_const(namesv, len);
5505 if (len == 2 && name[0] == '$' && name[1] == '_')
5506 iterpflags |= OPpITER_DEF;
5510 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5511 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5512 sv = newGVOP(OP_GV, 0, PL_defgv);
5517 iterpflags |= OPpITER_DEF;
5519 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5520 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5521 iterflags |= OPf_STACKED;
5523 else if (expr->op_type == OP_NULL &&
5524 (expr->op_flags & OPf_KIDS) &&
5525 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5527 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5528 * set the STACKED flag to indicate that these values are to be
5529 * treated as min/max values by 'pp_iterinit'.
5531 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5532 LOGOP* const range = (LOGOP*) flip->op_first;
5533 OP* const left = range->op_first;
5534 OP* const right = left->op_sibling;
5537 range->op_flags &= ~OPf_KIDS;
5538 range->op_first = NULL;
5540 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5541 listop->op_first->op_next = range->op_next;
5542 left->op_next = range->op_other;
5543 right->op_next = (OP*)listop;
5544 listop->op_next = listop->op_first;
5547 op_getmad(expr,(OP*)listop,'O');
5551 expr = (OP*)(listop);
5553 iterflags |= OPf_STACKED;
5556 expr = mod(force_list(expr), OP_GREPSTART);
5559 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5560 op_append_elem(OP_LIST, expr, scalar(sv))));
5561 assert(!loop->op_next);
5562 /* for my $x () sets OPpLVAL_INTRO;
5563 * for our $x () sets OPpOUR_INTRO */
5564 loop->op_private = (U8)iterpflags;
5565 #ifdef PL_OP_SLAB_ALLOC
5568 NewOp(1234,tmp,1,LOOP);
5569 Copy(loop,tmp,1,LISTOP);
5570 S_op_destroy(aTHX_ (OP*)loop);
5574 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5576 loop->op_targ = padoff;
5577 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5579 op_getmad(madsv, (OP*)loop, 'v');
5580 PL_parser->copline = forline;
5581 return newSTATEOP(0, label, wop);
5585 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5587 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5588 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5589 determining the target of the op; it is consumed by this function and
5590 become part of the constructed op tree.
5596 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5601 PERL_ARGS_ASSERT_NEWLOOPEX;
5603 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5605 if (type != OP_GOTO || label->op_type == OP_CONST) {
5606 /* "last()" means "last" */
5607 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5608 o = newOP(type, OPf_SPECIAL);
5610 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5611 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5615 op_getmad(label,o,'L');
5621 /* Check whether it's going to be a goto &function */
5622 if (label->op_type == OP_ENTERSUB
5623 && !(label->op_flags & OPf_STACKED))
5624 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5625 o = newUNOP(type, OPf_STACKED, label);
5627 PL_hints |= HINT_BLOCK_SCOPE;
5631 /* if the condition is a literal array or hash
5632 (or @{ ... } etc), make a reference to it.
5635 S_ref_array_or_hash(pTHX_ OP *cond)
5638 && (cond->op_type == OP_RV2AV
5639 || cond->op_type == OP_PADAV
5640 || cond->op_type == OP_RV2HV
5641 || cond->op_type == OP_PADHV))
5643 return newUNOP(OP_REFGEN,
5644 0, mod(cond, OP_REFGEN));
5647 && (cond->op_type == OP_ASLICE
5648 || cond->op_type == OP_HSLICE)) {
5650 /* anonlist now needs a list from this op, was previously used in
5652 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5653 cond->op_flags |= OPf_WANT_LIST;
5655 return newANONLIST(mod(cond, OP_ANONLIST));
5662 /* These construct the optree fragments representing given()
5665 entergiven and enterwhen are LOGOPs; the op_other pointer
5666 points up to the associated leave op. We need this so we
5667 can put it in the context and make break/continue work.
5668 (Also, of course, pp_enterwhen will jump straight to
5669 op_other if the match fails.)
5673 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5674 I32 enter_opcode, I32 leave_opcode,
5675 PADOFFSET entertarg)
5681 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5683 NewOp(1101, enterop, 1, LOGOP);
5684 enterop->op_type = (Optype)enter_opcode;
5685 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5686 enterop->op_flags = (U8) OPf_KIDS;
5687 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5688 enterop->op_private = 0;
5690 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5693 enterop->op_first = scalar(cond);
5694 cond->op_sibling = block;
5696 o->op_next = LINKLIST(cond);
5697 cond->op_next = (OP *) enterop;
5700 /* This is a default {} block */
5701 enterop->op_first = block;
5702 enterop->op_flags |= OPf_SPECIAL;
5704 o->op_next = (OP *) enterop;
5707 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5708 entergiven and enterwhen both
5711 enterop->op_next = LINKLIST(block);
5712 block->op_next = enterop->op_other = o;
5717 /* Does this look like a boolean operation? For these purposes
5718 a boolean operation is:
5719 - a subroutine call [*]
5720 - a logical connective
5721 - a comparison operator
5722 - a filetest operator, with the exception of -s -M -A -C
5723 - defined(), exists() or eof()
5724 - /$re/ or $foo =~ /$re/
5726 [*] possibly surprising
5729 S_looks_like_bool(pTHX_ const OP *o)
5733 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5735 switch(o->op_type) {
5738 return looks_like_bool(cLOGOPo->op_first);
5742 looks_like_bool(cLOGOPo->op_first)
5743 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5748 o->op_flags & OPf_KIDS
5749 && looks_like_bool(cUNOPo->op_first));
5753 case OP_NOT: case OP_XOR:
5755 case OP_EQ: case OP_NE: case OP_LT:
5756 case OP_GT: case OP_LE: case OP_GE:
5758 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5759 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5761 case OP_SEQ: case OP_SNE: case OP_SLT:
5762 case OP_SGT: case OP_SLE: case OP_SGE:
5766 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5767 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5768 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5769 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5770 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5771 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5772 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5773 case OP_FTTEXT: case OP_FTBINARY:
5775 case OP_DEFINED: case OP_EXISTS:
5776 case OP_MATCH: case OP_EOF:
5783 /* Detect comparisons that have been optimized away */
5784 if (cSVOPo->op_sv == &PL_sv_yes
5785 || cSVOPo->op_sv == &PL_sv_no)
5798 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5800 Constructs, checks, and returns an op tree expressing a C<given> block.
5801 I<cond> supplies the expression that will be locally assigned to a lexical
5802 variable, and I<block> supplies the body of the C<given> construct; they
5803 are consumed by this function and become part of the constructed op tree.
5804 I<defsv_off> is the pad offset of the scalar lexical variable that will
5811 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5814 PERL_ARGS_ASSERT_NEWGIVENOP;
5815 return newGIVWHENOP(
5816 ref_array_or_hash(cond),
5818 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5823 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5825 Constructs, checks, and returns an op tree expressing a C<when> block.
5826 I<cond> supplies the test expression, and I<block> supplies the block
5827 that will be executed if the test evaluates to true; they are consumed
5828 by this function and become part of the constructed op tree. I<cond>
5829 will be interpreted DWIMically, often as a comparison against C<$_>,
5830 and may be null to generate a C<default> block.
5836 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5838 const bool cond_llb = (!cond || looks_like_bool(cond));
5841 PERL_ARGS_ASSERT_NEWWHENOP;
5846 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5848 scalar(ref_array_or_hash(cond)));
5851 return newGIVWHENOP(
5853 op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5854 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5858 =head1 Embedding Functions
5860 =for apidoc cv_undef
5862 Clear out all the active components of a CV. This can happen either
5863 by an explicit C<undef &foo>, or by the reference count going to zero.
5864 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5865 children can still follow the full lexical scope chain.
5871 Perl_cv_undef(pTHX_ CV *cv)
5875 PERL_ARGS_ASSERT_CV_UNDEF;
5877 DEBUG_X(PerlIO_printf(Perl_debug_log,
5878 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5879 PTR2UV(cv), PTR2UV(PL_comppad))
5883 if (CvFILE(cv) && !CvISXSUB(cv)) {
5884 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5885 Safefree(CvFILE(cv));
5890 if (!CvISXSUB(cv) && CvROOT(cv)) {
5891 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5892 Perl_croak(aTHX_ "Can't undef active subroutine");
5895 PAD_SAVE_SETNULLPAD();
5897 op_free(CvROOT(cv));
5902 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5907 /* remove CvOUTSIDE unless this is an undef rather than a free */
5908 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5909 if (!CvWEAKOUTSIDE(cv))
5910 SvREFCNT_dec(CvOUTSIDE(cv));
5911 CvOUTSIDE(cv) = NULL;
5914 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5917 if (CvISXSUB(cv) && CvXSUB(cv)) {
5920 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
5921 * ref status of CvOUTSIDE and CvGV */
5922 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
5926 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5929 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5931 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5932 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5933 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5934 || (p && (len != SvCUR(cv) /* Not the same length. */
5935 || memNE(p, SvPVX_const(cv), len))))
5936 && ckWARN_d(WARN_PROTOTYPE)) {
5937 SV* const msg = sv_newmortal();
5941 gv_efullname3(name = sv_newmortal(), gv, NULL);
5942 sv_setpvs(msg, "Prototype mismatch:");
5944 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5946 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5948 sv_catpvs(msg, ": none");
5949 sv_catpvs(msg, " vs ");
5951 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5953 sv_catpvs(msg, "none");
5954 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5958 static void const_sv_xsub(pTHX_ CV* cv);
5962 =head1 Optree Manipulation Functions
5964 =for apidoc cv_const_sv
5966 If C<cv> is a constant sub eligible for inlining. returns the constant
5967 value returned by the sub. Otherwise, returns NULL.
5969 Constant subs can be created with C<newCONSTSUB> or as described in
5970 L<perlsub/"Constant Functions">.
5975 Perl_cv_const_sv(pTHX_ const CV *const cv)
5977 PERL_UNUSED_CONTEXT;
5980 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5982 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5985 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5986 * Can be called in 3 ways:
5989 * look for a single OP_CONST with attached value: return the value
5991 * cv && CvCLONE(cv) && !CvCONST(cv)
5993 * examine the clone prototype, and if contains only a single
5994 * OP_CONST referencing a pad const, or a single PADSV referencing
5995 * an outer lexical, return a non-zero value to indicate the CV is
5996 * a candidate for "constizing" at clone time
6000 * We have just cloned an anon prototype that was marked as a const
6001 * candidiate. Try to grab the current value, and in the case of
6002 * PADSV, ignore it if it has multiple references. Return the value.
6006 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6017 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6018 o = cLISTOPo->op_first->op_sibling;
6020 for (; o; o = o->op_next) {
6021 const OPCODE type = o->op_type;
6023 if (sv && o->op_next == o)
6025 if (o->op_next != o) {
6026 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
6028 if (type == OP_DBSTATE)
6031 if (type == OP_LEAVESUB || type == OP_RETURN)
6035 if (type == OP_CONST && cSVOPo->op_sv)
6037 else if (cv && type == OP_CONST) {
6038 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6042 else if (cv && type == OP_PADSV) {
6043 if (CvCONST(cv)) { /* newly cloned anon */
6044 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6045 /* the candidate should have 1 ref from this pad and 1 ref
6046 * from the parent */
6047 if (!sv || SvREFCNT(sv) != 2)
6054 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6055 sv = &PL_sv_undef; /* an arbitrary non-null value */
6070 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6073 /* This would be the return value, but the return cannot be reached. */
6074 OP* pegop = newOP(OP_NULL, 0);
6077 PERL_UNUSED_ARG(floor);
6087 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6089 NORETURN_FUNCTION_END;
6094 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
6096 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
6100 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6105 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6106 register CV *cv = NULL;
6108 /* If the subroutine has no body, no attributes, and no builtin attributes
6109 then it's just a sub declaration, and we may be able to get away with
6110 storing with a placeholder scalar in the symbol table, rather than a
6111 full GV and CV. If anything is present then it will take a full CV to
6113 const I32 gv_fetch_flags
6114 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6116 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6117 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6121 assert(proto->op_type == OP_CONST);
6122 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6128 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6130 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6131 SV * const sv = sv_newmortal();
6132 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6133 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6134 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6135 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6137 } else if (PL_curstash) {
6138 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6141 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6145 if (!PL_madskills) {
6154 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6155 maximum a prototype before. */
6156 if (SvTYPE(gv) > SVt_NULL) {
6157 if (!SvPOK((const SV *)gv)
6158 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6160 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6162 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6165 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6167 sv_setiv(MUTABLE_SV(gv), -1);
6169 SvREFCNT_dec(PL_compcv);
6170 cv = PL_compcv = NULL;
6174 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6176 if (!block || !ps || *ps || attrs
6177 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6179 || block->op_type == OP_NULL
6184 const_sv = op_const_sv(block, NULL);
6187 const bool exists = CvROOT(cv) || CvXSUB(cv);
6189 /* if the subroutine doesn't exist and wasn't pre-declared
6190 * with a prototype, assume it will be AUTOLOADed,
6191 * skipping the prototype check
6193 if (exists || SvPOK(cv))
6194 cv_ckproto_len(cv, gv, ps, ps_len);
6195 /* already defined (or promised)? */
6196 if (exists || GvASSUMECV(gv)) {
6199 || block->op_type == OP_NULL
6202 if (CvFLAGS(PL_compcv)) {
6203 /* might have had built-in attrs applied */
6204 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6205 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6206 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6208 /* just a "sub foo;" when &foo is already defined */
6209 SAVEFREESV(PL_compcv);
6214 && block->op_type != OP_NULL
6217 if (ckWARN(WARN_REDEFINE)
6219 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6221 const line_t oldline = CopLINE(PL_curcop);
6222 if (PL_parser && PL_parser->copline != NOLINE)
6223 CopLINE_set(PL_curcop, PL_parser->copline);
6224 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6225 CvCONST(cv) ? "Constant subroutine %s redefined"
6226 : "Subroutine %s redefined", name);
6227 CopLINE_set(PL_curcop, oldline);
6230 if (!PL_minus_c) /* keep old one around for madskills */
6233 /* (PL_madskills unset in used file.) */
6241 SvREFCNT_inc_simple_void_NN(const_sv);
6243 assert(!CvROOT(cv) && !CvCONST(cv));
6244 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6245 CvXSUBANY(cv).any_ptr = const_sv;
6246 CvXSUB(cv) = const_sv_xsub;
6252 cv = newCONSTSUB(NULL, name, const_sv);
6254 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6255 (CvGV(cv) && GvSTASH(CvGV(cv)))
6264 SvREFCNT_dec(PL_compcv);
6268 if (cv) { /* must reuse cv if autoloaded */
6269 /* transfer PL_compcv to cv */
6272 && block->op_type != OP_NULL
6275 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6277 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6278 if (!CvWEAKOUTSIDE(cv))
6279 SvREFCNT_dec(CvOUTSIDE(cv));
6280 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6281 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6282 CvOUTSIDE(PL_compcv) = 0;
6283 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6284 CvPADLIST(PL_compcv) = 0;
6285 /* inner references to PL_compcv must be fixed up ... */
6286 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6287 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6288 ++PL_sub_generation;
6290 sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
6293 /* Might have had built-in attributes applied -- propagate them. */
6294 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6296 /* ... before we throw it away */
6297 SvREFCNT_dec(PL_compcv);
6305 if (strEQ(name, "import")) {
6306 PL_formfeed = MUTABLE_SV(cv);
6307 /* diag_listed_as: SKIPME */
6308 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6312 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6317 CvFILE_set_from_cop(cv, PL_curcop);
6318 CvSTASH(cv) = PL_curstash;
6320 Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
6323 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6324 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6325 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6329 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6331 if (PL_parser && PL_parser->error_count) {
6335 const char *s = strrchr(name, ':');
6337 if (strEQ(s, "BEGIN")) {
6338 const char not_safe[] =
6339 "BEGIN not safe after errors--compilation aborted";
6340 if (PL_in_eval & EVAL_KEEPERR)
6341 Perl_croak(aTHX_ not_safe);
6343 /* force display of errors found but not reported */
6344 sv_catpv(ERRSV, not_safe);
6345 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6354 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6355 the debugger could be able to set a breakpoint in, so signal to
6356 pp_entereval that it should not throw away any saved lines at scope
6359 PL_breakable_sub_gen++;
6361 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6362 mod(scalarseq(block), OP_LEAVESUBLV));
6363 block->op_attached = 1;
6366 /* This makes sub {}; work as expected. */
6367 if (block->op_type == OP_STUB) {
6368 OP* const newblock = newSTATEOP(0, NULL, 0);
6370 op_getmad(block,newblock,'B');
6377 block->op_attached = 1;
6378 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6380 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6381 OpREFCNT_set(CvROOT(cv), 1);
6382 CvSTART(cv) = LINKLIST(CvROOT(cv));
6383 CvROOT(cv)->op_next = 0;
6384 CALL_PEEP(CvSTART(cv));
6386 /* now that optimizer has done its work, adjust pad values */
6388 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6391 assert(!CvCONST(cv));
6392 if (ps && !*ps && op_const_sv(block, cv))
6397 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6398 SV * const tmpstr = sv_newmortal();
6399 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6400 GV_ADDMULTI, SVt_PVHV);
6402 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6405 (long)CopLINE(PL_curcop));
6406 gv_efullname3(tmpstr, gv, NULL);
6407 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6408 SvCUR(tmpstr), sv, 0);
6409 hv = GvHVn(db_postponed);
6410 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6411 CV * const pcv = GvCV(db_postponed);
6417 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6422 if (name && ! (PL_parser && PL_parser->error_count))
6423 process_special_blocks(name, gv, cv);
6428 PL_parser->copline = NOLINE;
6434 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6437 const char *const colon = strrchr(fullname,':');
6438 const char *const name = colon ? colon + 1 : fullname;
6440 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6443 if (strEQ(name, "BEGIN")) {
6444 const I32 oldscope = PL_scopestack_ix;
6446 SAVECOPFILE(&PL_compiling);
6447 SAVECOPLINE(&PL_compiling);
6449 DEBUG_x( dump_sub(gv) );
6450 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6451 GvCV(gv) = 0; /* cv has been hijacked */
6452 call_list(oldscope, PL_beginav);
6454 PL_curcop = &PL_compiling;
6455 CopHINTS_set(&PL_compiling, PL_hints);
6462 if strEQ(name, "END") {
6463 DEBUG_x( dump_sub(gv) );
6464 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6467 } else if (*name == 'U') {
6468 if (strEQ(name, "UNITCHECK")) {
6469 /* It's never too late to run a unitcheck block */
6470 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6474 } else if (*name == 'C') {
6475 if (strEQ(name, "CHECK")) {
6477 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6478 "Too late to run CHECK block");
6479 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6483 } else if (*name == 'I') {
6484 if (strEQ(name, "INIT")) {
6486 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6487 "Too late to run INIT block");
6488 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6494 DEBUG_x( dump_sub(gv) );
6495 GvCV(gv) = 0; /* cv has been hijacked */
6500 =for apidoc newCONSTSUB
6502 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6503 eligible for inlining at compile-time.
6505 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6506 which won't be called if used as a destructor, but will suppress the overhead
6507 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6514 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6519 const char *const file = CopFILE(PL_curcop);
6521 SV *const temp_sv = CopFILESV(PL_curcop);
6522 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6527 if (IN_PERL_RUNTIME) {
6528 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6529 * an op shared between threads. Use a non-shared COP for our
6531 SAVEVPTR(PL_curcop);
6532 PL_curcop = &PL_compiling;
6534 SAVECOPLINE(PL_curcop);
6535 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6538 PL_hints &= ~HINT_BLOCK_SCOPE;
6541 SAVESPTR(PL_curstash);
6542 SAVECOPSTASH(PL_curcop);
6543 PL_curstash = stash;
6544 CopSTASH_set(PL_curcop,stash);
6547 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6548 and so doesn't get free()d. (It's expected to be from the C pre-
6549 processor __FILE__ directive). But we need a dynamically allocated one,
6550 and we need it to get freed. */
6551 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6552 XS_DYNAMIC_FILENAME);
6553 CvXSUBANY(cv).any_ptr = sv;
6558 CopSTASH_free(PL_curcop);
6566 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6567 const char *const filename, const char *const proto,
6570 CV *cv = newXS(name, subaddr, filename);
6572 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6574 if (flags & XS_DYNAMIC_FILENAME) {
6575 /* We need to "make arrangements" (ie cheat) to ensure that the
6576 filename lasts as long as the PVCV we just created, but also doesn't
6578 STRLEN filename_len = strlen(filename);
6579 STRLEN proto_and_file_len = filename_len;
6580 char *proto_and_file;
6584 proto_len = strlen(proto);
6585 proto_and_file_len += proto_len;
6587 Newx(proto_and_file, proto_and_file_len + 1, char);
6588 Copy(proto, proto_and_file, proto_len, char);
6589 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6592 proto_and_file = savepvn(filename, filename_len);
6595 /* This gets free()d. :-) */
6596 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6597 SV_HAS_TRAILING_NUL);
6599 /* This gives us the correct prototype, rather than one with the
6600 file name appended. */
6601 SvCUR_set(cv, proto_len);
6605 CvFILE(cv) = proto_and_file + proto_len;
6607 sv_setpv(MUTABLE_SV(cv), proto);
6613 =for apidoc U||newXS
6615 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6616 static storage, as it is used directly as CvFILE(), without a copy being made.
6622 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6625 GV * const gv = gv_fetchpv(name ? name :
6626 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6627 GV_ADDMULTI, SVt_PVCV);
6630 PERL_ARGS_ASSERT_NEWXS;
6633 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6635 if ((cv = (name ? GvCV(gv) : NULL))) {
6637 /* just a cached method */
6641 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6642 /* already defined (or promised) */
6643 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6644 if (ckWARN(WARN_REDEFINE)) {
6645 GV * const gvcv = CvGV(cv);
6647 HV * const stash = GvSTASH(gvcv);
6649 const char *redefined_name = HvNAME_get(stash);
6650 if ( strEQ(redefined_name,"autouse") ) {
6651 const line_t oldline = CopLINE(PL_curcop);
6652 if (PL_parser && PL_parser->copline != NOLINE)
6653 CopLINE_set(PL_curcop, PL_parser->copline);
6654 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6655 CvCONST(cv) ? "Constant subroutine %s redefined"
6656 : "Subroutine %s redefined"
6658 CopLINE_set(PL_curcop, oldline);
6668 if (cv) /* must reuse cv if autoloaded */
6671 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6675 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6681 (void)gv_fetchfile(filename);
6682 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6683 an external constant string */
6685 CvXSUB(cv) = subaddr;
6688 process_special_blocks(name, gv, cv);
6698 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6703 OP* pegop = newOP(OP_NULL, 0);
6707 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6708 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6711 if ((cv = GvFORM(gv))) {
6712 if (ckWARN(WARN_REDEFINE)) {
6713 const line_t oldline = CopLINE(PL_curcop);
6714 if (PL_parser && PL_parser->copline != NOLINE)
6715 CopLINE_set(PL_curcop, PL_parser->copline);
6717 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6718 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6720 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6721 "Format STDOUT redefined");
6723 CopLINE_set(PL_curcop, oldline);
6730 CvFILE_set_from_cop(cv, PL_curcop);
6733 pad_tidy(padtidy_FORMAT);
6734 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6735 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6736 OpREFCNT_set(CvROOT(cv), 1);
6737 CvSTART(cv) = LINKLIST(CvROOT(cv));
6738 CvROOT(cv)->op_next = 0;
6739 CALL_PEEP(CvSTART(cv));
6741 op_getmad(o,pegop,'n');
6742 op_getmad_weak(block, pegop, 'b');
6747 PL_parser->copline = NOLINE;
6755 Perl_newANONLIST(pTHX_ OP *o)
6757 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6761 Perl_newANONHASH(pTHX_ OP *o)
6763 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6767 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6769 return newANONATTRSUB(floor, proto, NULL, block);
6773 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6775 return newUNOP(OP_REFGEN, 0,
6776 newSVOP(OP_ANONCODE, 0,
6777 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6781 Perl_oopsAV(pTHX_ OP *o)
6785 PERL_ARGS_ASSERT_OOPSAV;
6787 switch (o->op_type) {
6789 o->op_type = OP_PADAV;
6790 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6791 return ref(o, OP_RV2AV);
6794 o->op_type = OP_RV2AV;
6795 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6800 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6807 Perl_oopsHV(pTHX_ OP *o)
6811 PERL_ARGS_ASSERT_OOPSHV;
6813 switch (o->op_type) {
6816 o->op_type = OP_PADHV;
6817 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6818 return ref(o, OP_RV2HV);
6822 o->op_type = OP_RV2HV;
6823 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6828 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6835 Perl_newAVREF(pTHX_ OP *o)
6839 PERL_ARGS_ASSERT_NEWAVREF;
6841 if (o->op_type == OP_PADANY) {
6842 o->op_type = OP_PADAV;
6843 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6846 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6847 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6848 "Using an array as a reference is deprecated");
6850 return newUNOP(OP_RV2AV, 0, scalar(o));
6854 Perl_newGVREF(pTHX_ I32 type, OP *o)
6856 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6857 return newUNOP(OP_NULL, 0, o);
6858 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6862 Perl_newHVREF(pTHX_ OP *o)
6866 PERL_ARGS_ASSERT_NEWHVREF;
6868 if (o->op_type == OP_PADANY) {
6869 o->op_type = OP_PADHV;
6870 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6873 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6874 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6875 "Using a hash as a reference is deprecated");
6877 return newUNOP(OP_RV2HV, 0, scalar(o));
6881 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6883 return newUNOP(OP_RV2CV, flags, scalar(o));
6887 Perl_newSVREF(pTHX_ OP *o)
6891 PERL_ARGS_ASSERT_NEWSVREF;
6893 if (o->op_type == OP_PADANY) {
6894 o->op_type = OP_PADSV;
6895 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6898 return newUNOP(OP_RV2SV, 0, scalar(o));
6901 /* Check routines. See the comments at the top of this file for details
6902 * on when these are called */
6905 Perl_ck_anoncode(pTHX_ OP *o)
6907 PERL_ARGS_ASSERT_CK_ANONCODE;
6909 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6911 cSVOPo->op_sv = NULL;
6916 Perl_ck_bitop(pTHX_ OP *o)
6920 PERL_ARGS_ASSERT_CK_BITOP;
6922 #define OP_IS_NUMCOMPARE(op) \
6923 ((op) == OP_LT || (op) == OP_I_LT || \
6924 (op) == OP_GT || (op) == OP_I_GT || \
6925 (op) == OP_LE || (op) == OP_I_LE || \
6926 (op) == OP_GE || (op) == OP_I_GE || \
6927 (op) == OP_EQ || (op) == OP_I_EQ || \
6928 (op) == OP_NE || (op) == OP_I_NE || \
6929 (op) == OP_NCMP || (op) == OP_I_NCMP)
6930 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6931 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6932 && (o->op_type == OP_BIT_OR
6933 || o->op_type == OP_BIT_AND
6934 || o->op_type == OP_BIT_XOR))
6936 const OP * const left = cBINOPo->op_first;
6937 const OP * const right = left->op_sibling;
6938 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6939 (left->op_flags & OPf_PARENS) == 0) ||
6940 (OP_IS_NUMCOMPARE(right->op_type) &&
6941 (right->op_flags & OPf_PARENS) == 0))
6942 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6943 "Possible precedence problem on bitwise %c operator",
6944 o->op_type == OP_BIT_OR ? '|'
6945 : o->op_type == OP_BIT_AND ? '&' : '^'
6952 Perl_ck_concat(pTHX_ OP *o)
6954 const OP * const kid = cUNOPo->op_first;
6956 PERL_ARGS_ASSERT_CK_CONCAT;
6957 PERL_UNUSED_CONTEXT;
6959 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6960 !(kUNOP->op_first->op_flags & OPf_MOD))
6961 o->op_flags |= OPf_STACKED;
6966 Perl_ck_spair(pTHX_ OP *o)
6970 PERL_ARGS_ASSERT_CK_SPAIR;
6972 if (o->op_flags & OPf_KIDS) {
6975 const OPCODE type = o->op_type;
6976 o = modkids(ck_fun(o), type);
6977 kid = cUNOPo->op_first;
6978 newop = kUNOP->op_first->op_sibling;
6980 const OPCODE type = newop->op_type;
6981 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6982 type == OP_PADAV || type == OP_PADHV ||
6983 type == OP_RV2AV || type == OP_RV2HV)
6987 op_getmad(kUNOP->op_first,newop,'K');
6989 op_free(kUNOP->op_first);
6991 kUNOP->op_first = newop;
6993 o->op_ppaddr = PL_ppaddr[++o->op_type];
6998 Perl_ck_delete(pTHX_ OP *o)
7000 PERL_ARGS_ASSERT_CK_DELETE;
7004 if (o->op_flags & OPf_KIDS) {
7005 OP * const kid = cUNOPo->op_first;
7006 switch (kid->op_type) {
7008 o->op_flags |= OPf_SPECIAL;
7011 o->op_private |= OPpSLICE;
7014 o->op_flags |= OPf_SPECIAL;
7019 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7022 if (kid->op_private & OPpLVAL_INTRO)
7023 o->op_private |= OPpLVAL_INTRO;
7030 Perl_ck_die(pTHX_ OP *o)
7032 PERL_ARGS_ASSERT_CK_DIE;
7035 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7041 Perl_ck_eof(pTHX_ OP *o)
7045 PERL_ARGS_ASSERT_CK_EOF;
7047 if (o->op_flags & OPf_KIDS) {
7048 if (cLISTOPo->op_first->op_type == OP_STUB) {
7050 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7052 op_getmad(o,newop,'O');
7064 Perl_ck_eval(pTHX_ OP *o)
7068 PERL_ARGS_ASSERT_CK_EVAL;
7070 PL_hints |= HINT_BLOCK_SCOPE;
7071 if (o->op_flags & OPf_KIDS) {
7072 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7075 o->op_flags &= ~OPf_KIDS;
7078 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7084 cUNOPo->op_first = 0;
7089 NewOp(1101, enter, 1, LOGOP);
7090 enter->op_type = OP_ENTERTRY;
7091 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7092 enter->op_private = 0;
7094 /* establish postfix order */
7095 enter->op_next = (OP*)enter;
7097 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7098 o->op_type = OP_LEAVETRY;
7099 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7100 enter->op_other = o;
7101 op_getmad(oldo,o,'O');
7115 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7116 op_getmad(oldo,o,'O');
7118 o->op_targ = (PADOFFSET)PL_hints;
7119 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7120 /* Store a copy of %^H that pp_entereval can pick up. */
7121 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7122 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7123 cUNOPo->op_first->op_sibling = hhop;
7124 o->op_private |= OPpEVAL_HAS_HH;
7130 Perl_ck_exit(pTHX_ OP *o)
7132 PERL_ARGS_ASSERT_CK_EXIT;
7135 HV * const table = GvHV(PL_hintgv);
7137 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7138 if (svp && *svp && SvTRUE(*svp))
7139 o->op_private |= OPpEXIT_VMSISH;
7141 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7147 Perl_ck_exec(pTHX_ OP *o)
7149 PERL_ARGS_ASSERT_CK_EXEC;
7151 if (o->op_flags & OPf_STACKED) {
7154 kid = cUNOPo->op_first->op_sibling;
7155 if (kid->op_type == OP_RV2GV)
7164 Perl_ck_exists(pTHX_ OP *o)
7168 PERL_ARGS_ASSERT_CK_EXISTS;
7171 if (o->op_flags & OPf_KIDS) {
7172 OP * const kid = cUNOPo->op_first;
7173 if (kid->op_type == OP_ENTERSUB) {
7174 (void) ref(kid, o->op_type);
7175 if (kid->op_type != OP_RV2CV
7176 && !(PL_parser && PL_parser->error_count))
7177 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7179 o->op_private |= OPpEXISTS_SUB;
7181 else if (kid->op_type == OP_AELEM)
7182 o->op_flags |= OPf_SPECIAL;
7183 else if (kid->op_type != OP_HELEM)
7184 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7192 Perl_ck_rvconst(pTHX_ register OP *o)
7195 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7197 PERL_ARGS_ASSERT_CK_RVCONST;
7199 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7200 if (o->op_type == OP_RV2CV)
7201 o->op_private &= ~1;
7203 if (kid->op_type == OP_CONST) {
7206 SV * const kidsv = kid->op_sv;
7208 /* Is it a constant from cv_const_sv()? */
7209 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7210 SV * const rsv = SvRV(kidsv);
7211 const svtype type = SvTYPE(rsv);
7212 const char *badtype = NULL;
7214 switch (o->op_type) {
7216 if (type > SVt_PVMG)
7217 badtype = "a SCALAR";
7220 if (type != SVt_PVAV)
7221 badtype = "an ARRAY";
7224 if (type != SVt_PVHV)
7228 if (type != SVt_PVCV)
7233 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7236 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7237 const char *badthing;
7238 switch (o->op_type) {
7240 badthing = "a SCALAR";
7243 badthing = "an ARRAY";
7246 badthing = "a HASH";
7254 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7255 SVfARG(kidsv), badthing);
7258 * This is a little tricky. We only want to add the symbol if we
7259 * didn't add it in the lexer. Otherwise we get duplicate strict
7260 * warnings. But if we didn't add it in the lexer, we must at
7261 * least pretend like we wanted to add it even if it existed before,
7262 * or we get possible typo warnings. OPpCONST_ENTERED says
7263 * whether the lexer already added THIS instance of this symbol.
7265 iscv = (o->op_type == OP_RV2CV) * 2;
7267 gv = gv_fetchsv(kidsv,
7268 iscv | !(kid->op_private & OPpCONST_ENTERED),
7271 : o->op_type == OP_RV2SV
7273 : o->op_type == OP_RV2AV
7275 : o->op_type == OP_RV2HV
7278 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7280 kid->op_type = OP_GV;
7281 SvREFCNT_dec(kid->op_sv);
7283 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7284 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7285 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7287 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7289 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7291 kid->op_private = 0;
7292 kid->op_ppaddr = PL_ppaddr[OP_GV];
7293 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7301 Perl_ck_ftst(pTHX_ OP *o)
7304 const I32 type = o->op_type;
7306 PERL_ARGS_ASSERT_CK_FTST;
7308 if (o->op_flags & OPf_REF) {
7311 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7312 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7313 const OPCODE kidtype = kid->op_type;
7315 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7316 OP * const newop = newGVOP(type, OPf_REF,
7317 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7319 op_getmad(o,newop,'O');
7325 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7326 o->op_private |= OPpFT_ACCESS;
7327 if (PL_check[kidtype] == Perl_ck_ftst
7328 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7329 o->op_private |= OPpFT_STACKED;
7337 if (type == OP_FTTTY)
7338 o = newGVOP(type, OPf_REF, PL_stdingv);
7340 o = newUNOP(type, 0, newDEFSVOP());
7341 op_getmad(oldo,o,'O');
7347 Perl_ck_fun(pTHX_ OP *o)
7350 const int type = o->op_type;
7351 register I32 oa = PL_opargs[type] >> OASHIFT;
7353 PERL_ARGS_ASSERT_CK_FUN;
7355 if (o->op_flags & OPf_STACKED) {
7356 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7359 return no_fh_allowed(o);
7362 if (o->op_flags & OPf_KIDS) {
7363 OP **tokid = &cLISTOPo->op_first;
7364 register OP *kid = cLISTOPo->op_first;
7368 if (kid->op_type == OP_PUSHMARK ||
7369 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7371 tokid = &kid->op_sibling;
7372 kid = kid->op_sibling;
7374 if (!kid && PL_opargs[type] & OA_DEFGV)
7375 *tokid = kid = newDEFSVOP();
7379 sibl = kid->op_sibling;
7381 if (!sibl && kid->op_type == OP_STUB) {
7388 /* list seen where single (scalar) arg expected? */
7389 if (numargs == 1 && !(oa >> 4)
7390 && kid->op_type == OP_LIST && type != OP_SCALAR)
7392 return too_many_arguments(o,PL_op_desc[type]);
7405 if ((type == OP_PUSH || type == OP_UNSHIFT)
7406 && !kid->op_sibling)
7407 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7408 "Useless use of %s with no values",
7411 if (kid->op_type == OP_CONST &&
7412 (kid->op_private & OPpCONST_BARE))
7414 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7415 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7416 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7417 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7418 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7420 op_getmad(kid,newop,'K');
7425 kid->op_sibling = sibl;
7428 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
7429 bad_type(numargs, "array", PL_op_desc[type], kid);
7433 if (kid->op_type == OP_CONST &&
7434 (kid->op_private & OPpCONST_BARE))
7436 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7437 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7438 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7439 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7440 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7442 op_getmad(kid,newop,'K');
7447 kid->op_sibling = sibl;
7450 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7451 bad_type(numargs, "hash", PL_op_desc[type], kid);
7456 OP * const newop = newUNOP(OP_NULL, 0, kid);
7457 kid->op_sibling = 0;
7459 newop->op_next = newop;
7461 kid->op_sibling = sibl;
7466 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7467 if (kid->op_type == OP_CONST &&
7468 (kid->op_private & OPpCONST_BARE))
7470 OP * const newop = newGVOP(OP_GV, 0,
7471 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7472 if (!(o->op_private & 1) && /* if not unop */
7473 kid == cLISTOPo->op_last)
7474 cLISTOPo->op_last = newop;
7476 op_getmad(kid,newop,'K');
7482 else if (kid->op_type == OP_READLINE) {
7483 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7484 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7487 I32 flags = OPf_SPECIAL;
7491 /* is this op a FH constructor? */
7492 if (is_handle_constructor(o,numargs)) {
7493 const char *name = NULL;
7497 /* Set a flag to tell rv2gv to vivify
7498 * need to "prove" flag does not mean something
7499 * else already - NI-S 1999/05/07
7502 if (kid->op_type == OP_PADSV) {
7504 = PAD_COMPNAME_SV(kid->op_targ);
7505 name = SvPV_const(namesv, len);
7507 else if (kid->op_type == OP_RV2SV
7508 && kUNOP->op_first->op_type == OP_GV)
7510 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7512 len = GvNAMELEN(gv);
7514 else if (kid->op_type == OP_AELEM
7515 || kid->op_type == OP_HELEM)
7518 OP *op = ((BINOP*)kid)->op_first;
7522 const char * const a =
7523 kid->op_type == OP_AELEM ?
7525 if (((op->op_type == OP_RV2AV) ||
7526 (op->op_type == OP_RV2HV)) &&
7527 (firstop = ((UNOP*)op)->op_first) &&
7528 (firstop->op_type == OP_GV)) {
7529 /* packagevar $a[] or $h{} */
7530 GV * const gv = cGVOPx_gv(firstop);
7538 else if (op->op_type == OP_PADAV
7539 || op->op_type == OP_PADHV) {
7540 /* lexicalvar $a[] or $h{} */
7541 const char * const padname =
7542 PAD_COMPNAME_PV(op->op_targ);
7551 name = SvPV_const(tmpstr, len);
7556 name = "__ANONIO__";
7563 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7564 namesv = PAD_SVl(targ);
7565 SvUPGRADE(namesv, SVt_PV);
7567 sv_setpvs(namesv, "$");
7568 sv_catpvn(namesv, name, len);
7571 kid->op_sibling = 0;
7572 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7573 kid->op_targ = targ;
7574 kid->op_private |= priv;
7576 kid->op_sibling = sibl;
7582 mod(scalar(kid), type);
7586 tokid = &kid->op_sibling;
7587 kid = kid->op_sibling;
7590 if (kid && kid->op_type != OP_STUB)
7591 return too_many_arguments(o,OP_DESC(o));
7592 o->op_private |= numargs;
7594 /* FIXME - should the numargs move as for the PERL_MAD case? */
7595 o->op_private |= numargs;
7597 return too_many_arguments(o,OP_DESC(o));
7601 else if (PL_opargs[type] & OA_DEFGV) {
7603 OP *newop = newUNOP(type, 0, newDEFSVOP());
7604 op_getmad(o,newop,'O');
7607 /* Ordering of these two is important to keep f_map.t passing. */
7609 return newUNOP(type, 0, newDEFSVOP());
7614 while (oa & OA_OPTIONAL)
7616 if (oa && oa != OA_LIST)
7617 return too_few_arguments(o,OP_DESC(o));
7623 Perl_ck_glob(pTHX_ OP *o)
7628 PERL_ARGS_ASSERT_CK_GLOB;
7631 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7632 op_append_elem(OP_GLOB, o, newDEFSVOP());
7634 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7635 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7637 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7640 #if !defined(PERL_EXTERNAL_GLOB)
7641 /* XXX this can be tightened up and made more failsafe. */
7642 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7645 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7646 newSVpvs("File::Glob"), NULL, NULL, NULL);
7647 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7648 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7649 GvCV(gv) = GvCV(glob_gv);
7650 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7651 GvIMPORTED_CV_on(gv);
7655 #endif /* PERL_EXTERNAL_GLOB */
7657 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7658 op_append_elem(OP_GLOB, o,
7659 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7660 o->op_type = OP_LIST;
7661 o->op_ppaddr = PL_ppaddr[OP_LIST];
7662 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7663 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7664 cLISTOPo->op_first->op_targ = 0;
7665 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7666 op_append_elem(OP_LIST, o,
7667 scalar(newUNOP(OP_RV2CV, 0,
7668 newGVOP(OP_GV, 0, gv)))));
7669 o = newUNOP(OP_NULL, 0, ck_subr(o));
7670 o->op_targ = OP_GLOB; /* hint at what it used to be */
7673 gv = newGVgen("main");
7675 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7681 Perl_ck_grep(pTHX_ OP *o)
7686 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7689 PERL_ARGS_ASSERT_CK_GREP;
7691 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7692 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7694 if (o->op_flags & OPf_STACKED) {
7697 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7698 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7699 return no_fh_allowed(o);
7700 for (k = kid; k; k = k->op_next) {
7703 NewOp(1101, gwop, 1, LOGOP);
7704 kid->op_next = (OP*)gwop;
7705 o->op_flags &= ~OPf_STACKED;
7707 kid = cLISTOPo->op_first->op_sibling;
7708 if (type == OP_MAPWHILE)
7713 if (PL_parser && PL_parser->error_count)
7715 kid = cLISTOPo->op_first->op_sibling;
7716 if (kid->op_type != OP_NULL)
7717 Perl_croak(aTHX_ "panic: ck_grep");
7718 kid = kUNOP->op_first;
7721 NewOp(1101, gwop, 1, LOGOP);
7722 gwop->op_type = type;
7723 gwop->op_ppaddr = PL_ppaddr[type];
7724 gwop->op_first = listkids(o);
7725 gwop->op_flags |= OPf_KIDS;
7726 gwop->op_other = LINKLIST(kid);
7727 kid->op_next = (OP*)gwop;
7728 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7729 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7730 o->op_private = gwop->op_private = 0;
7731 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7734 o->op_private = gwop->op_private = OPpGREP_LEX;
7735 gwop->op_targ = o->op_targ = offset;
7738 kid = cLISTOPo->op_first->op_sibling;
7739 if (!kid || !kid->op_sibling)
7740 return too_few_arguments(o,OP_DESC(o));
7741 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7742 mod(kid, OP_GREPSTART);
7748 Perl_ck_index(pTHX_ OP *o)
7750 PERL_ARGS_ASSERT_CK_INDEX;
7752 if (o->op_flags & OPf_KIDS) {
7753 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7755 kid = kid->op_sibling; /* get past "big" */
7756 if (kid && kid->op_type == OP_CONST)
7757 fbm_compile(((SVOP*)kid)->op_sv, 0);
7763 Perl_ck_lfun(pTHX_ OP *o)
7765 const OPCODE type = o->op_type;
7767 PERL_ARGS_ASSERT_CK_LFUN;
7769 return modkids(ck_fun(o), type);
7773 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7775 PERL_ARGS_ASSERT_CK_DEFINED;
7777 if ((o->op_flags & OPf_KIDS)) {
7778 switch (cUNOPo->op_first->op_type) {
7780 /* This is needed for
7781 if (defined %stash::)
7782 to work. Do not break Tk.
7784 break; /* Globals via GV can be undef */
7786 case OP_AASSIGN: /* Is this a good idea? */
7787 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7788 "defined(@array) is deprecated");
7789 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7790 "\t(Maybe you should just omit the defined()?)\n");
7794 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7795 "defined(%%hash) is deprecated");
7796 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7797 "\t(Maybe you should just omit the defined()?)\n");
7808 Perl_ck_readline(pTHX_ OP *o)
7810 PERL_ARGS_ASSERT_CK_READLINE;
7812 if (!(o->op_flags & OPf_KIDS)) {
7814 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7816 op_getmad(o,newop,'O');
7826 Perl_ck_rfun(pTHX_ OP *o)
7828 const OPCODE type = o->op_type;
7830 PERL_ARGS_ASSERT_CK_RFUN;
7832 return refkids(ck_fun(o), type);
7836 Perl_ck_listiob(pTHX_ OP *o)
7840 PERL_ARGS_ASSERT_CK_LISTIOB;
7842 kid = cLISTOPo->op_first;
7845 kid = cLISTOPo->op_first;
7847 if (kid->op_type == OP_PUSHMARK)
7848 kid = kid->op_sibling;
7849 if (kid && o->op_flags & OPf_STACKED)
7850 kid = kid->op_sibling;
7851 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7852 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7853 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7854 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7855 cLISTOPo->op_first->op_sibling = kid;
7856 cLISTOPo->op_last = kid;
7857 kid = kid->op_sibling;
7862 op_append_elem(o->op_type, o, newDEFSVOP());
7868 Perl_ck_smartmatch(pTHX_ OP *o)
7871 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7872 if (0 == (o->op_flags & OPf_SPECIAL)) {
7873 OP *first = cBINOPo->op_first;
7874 OP *second = first->op_sibling;
7876 /* Implicitly take a reference to an array or hash */
7877 first->op_sibling = NULL;
7878 first = cBINOPo->op_first = ref_array_or_hash(first);
7879 second = first->op_sibling = ref_array_or_hash(second);
7881 /* Implicitly take a reference to a regular expression */
7882 if (first->op_type == OP_MATCH) {
7883 first->op_type = OP_QR;
7884 first->op_ppaddr = PL_ppaddr[OP_QR];
7886 if (second->op_type == OP_MATCH) {
7887 second->op_type = OP_QR;
7888 second->op_ppaddr = PL_ppaddr[OP_QR];
7897 Perl_ck_sassign(pTHX_ OP *o)
7900 OP * const kid = cLISTOPo->op_first;
7902 PERL_ARGS_ASSERT_CK_SASSIGN;
7904 /* has a disposable target? */
7905 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7906 && !(kid->op_flags & OPf_STACKED)
7907 /* Cannot steal the second time! */
7908 && !(kid->op_private & OPpTARGET_MY)
7909 /* Keep the full thing for madskills */
7913 OP * const kkid = kid->op_sibling;
7915 /* Can just relocate the target. */
7916 if (kkid && kkid->op_type == OP_PADSV
7917 && !(kkid->op_private & OPpLVAL_INTRO))
7919 kid->op_targ = kkid->op_targ;
7921 /* Now we do not need PADSV and SASSIGN. */
7922 kid->op_sibling = o->op_sibling; /* NULL */
7923 cLISTOPo->op_first = NULL;
7926 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7930 if (kid->op_sibling) {
7931 OP *kkid = kid->op_sibling;
7932 if (kkid->op_type == OP_PADSV
7933 && (kkid->op_private & OPpLVAL_INTRO)
7934 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7935 const PADOFFSET target = kkid->op_targ;
7936 OP *const other = newOP(OP_PADSV,
7938 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7939 OP *const first = newOP(OP_NULL, 0);
7940 OP *const nullop = newCONDOP(0, first, o, other);
7941 OP *const condop = first->op_next;
7942 /* hijacking PADSTALE for uninitialized state variables */
7943 SvPADSTALE_on(PAD_SVl(target));
7945 condop->op_type = OP_ONCE;
7946 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7947 condop->op_targ = target;
7948 other->op_targ = target;
7950 /* Because we change the type of the op here, we will skip the
7951 assinment binop->op_last = binop->op_first->op_sibling; at the
7952 end of Perl_newBINOP(). So need to do it here. */
7953 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7962 Perl_ck_match(pTHX_ OP *o)
7966 PERL_ARGS_ASSERT_CK_MATCH;
7968 if (o->op_type != OP_QR && PL_compcv) {
7969 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7970 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7971 o->op_targ = offset;
7972 o->op_private |= OPpTARGET_MY;
7975 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7976 o->op_private |= OPpRUNTIME;
7981 Perl_ck_method(pTHX_ OP *o)
7983 OP * const kid = cUNOPo->op_first;
7985 PERL_ARGS_ASSERT_CK_METHOD;
7987 if (kid->op_type == OP_CONST) {
7988 SV* sv = kSVOP->op_sv;
7989 const char * const method = SvPVX_const(sv);
7990 if (!(strchr(method, ':') || strchr(method, '\''))) {
7992 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7993 sv = newSVpvn_share(method, SvCUR(sv), 0);
7996 kSVOP->op_sv = NULL;
7998 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8000 op_getmad(o,cmop,'O');
8011 Perl_ck_null(pTHX_ OP *o)
8013 PERL_ARGS_ASSERT_CK_NULL;
8014 PERL_UNUSED_CONTEXT;
8019 Perl_ck_open(pTHX_ OP *o)
8022 HV * const table = GvHV(PL_hintgv);
8024 PERL_ARGS_ASSERT_CK_OPEN;
8027 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8030 const char *d = SvPV_const(*svp, len);
8031 const I32 mode = mode_from_discipline(d, len);
8032 if (mode & O_BINARY)
8033 o->op_private |= OPpOPEN_IN_RAW;
8034 else if (mode & O_TEXT)
8035 o->op_private |= OPpOPEN_IN_CRLF;
8038 svp = hv_fetchs(table, "open_OUT", FALSE);
8041 const char *d = SvPV_const(*svp, len);
8042 const I32 mode = mode_from_discipline(d, len);
8043 if (mode & O_BINARY)
8044 o->op_private |= OPpOPEN_OUT_RAW;
8045 else if (mode & O_TEXT)
8046 o->op_private |= OPpOPEN_OUT_CRLF;
8049 if (o->op_type == OP_BACKTICK) {
8050 if (!(o->op_flags & OPf_KIDS)) {
8051 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8053 op_getmad(o,newop,'O');
8062 /* In case of three-arg dup open remove strictness
8063 * from the last arg if it is a bareword. */
8064 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8065 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8069 if ((last->op_type == OP_CONST) && /* The bareword. */
8070 (last->op_private & OPpCONST_BARE) &&
8071 (last->op_private & OPpCONST_STRICT) &&
8072 (oa = first->op_sibling) && /* The fh. */
8073 (oa = oa->op_sibling) && /* The mode. */
8074 (oa->op_type == OP_CONST) &&
8075 SvPOK(((SVOP*)oa)->op_sv) &&
8076 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8077 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8078 (last == oa->op_sibling)) /* The bareword. */
8079 last->op_private &= ~OPpCONST_STRICT;
8085 Perl_ck_repeat(pTHX_ OP *o)
8087 PERL_ARGS_ASSERT_CK_REPEAT;
8089 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8090 o->op_private |= OPpREPEAT_DOLIST;
8091 cBINOPo->op_first = force_list(cBINOPo->op_first);
8099 Perl_ck_require(pTHX_ OP *o)
8104 PERL_ARGS_ASSERT_CK_REQUIRE;
8106 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8107 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8109 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8110 SV * const sv = kid->op_sv;
8111 U32 was_readonly = SvREADONLY(sv);
8118 sv_force_normal_flags(sv, 0);
8119 assert(!SvREADONLY(sv));
8129 for (; s < end; s++) {
8130 if (*s == ':' && s[1] == ':') {
8132 Move(s+2, s+1, end - s - 1, char);
8137 sv_catpvs(sv, ".pm");
8138 SvFLAGS(sv) |= was_readonly;
8142 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8143 /* handle override, if any */
8144 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8145 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8146 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8147 gv = gvp ? *gvp : NULL;
8151 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8152 OP * const kid = cUNOPo->op_first;
8155 cUNOPo->op_first = 0;
8159 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8160 op_append_elem(OP_LIST, kid,
8161 scalar(newUNOP(OP_RV2CV, 0,
8164 op_getmad(o,newop,'O');
8168 return scalar(ck_fun(o));
8172 Perl_ck_return(pTHX_ OP *o)
8177 PERL_ARGS_ASSERT_CK_RETURN;
8179 kid = cLISTOPo->op_first->op_sibling;
8180 if (CvLVALUE(PL_compcv)) {
8181 for (; kid; kid = kid->op_sibling)
8182 mod(kid, OP_LEAVESUBLV);
8184 for (; kid; kid = kid->op_sibling)
8185 if ((kid->op_type == OP_NULL)
8186 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8187 /* This is a do block */
8188 OP *op = kUNOP->op_first;
8189 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8190 op = cUNOPx(op)->op_first;
8191 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8192 /* Force the use of the caller's context */
8193 op->op_flags |= OPf_SPECIAL;
8202 Perl_ck_select(pTHX_ OP *o)
8207 PERL_ARGS_ASSERT_CK_SELECT;
8209 if (o->op_flags & OPf_KIDS) {
8210 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8211 if (kid && kid->op_sibling) {
8212 o->op_type = OP_SSELECT;
8213 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8215 return fold_constants(o);
8219 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8220 if (kid && kid->op_type == OP_RV2GV)
8221 kid->op_private &= ~HINT_STRICT_REFS;
8226 Perl_ck_shift(pTHX_ OP *o)
8229 const I32 type = o->op_type;
8231 PERL_ARGS_ASSERT_CK_SHIFT;
8233 if (!(o->op_flags & OPf_KIDS)) {
8236 if (!CvUNIQUE(PL_compcv)) {
8237 o->op_flags |= OPf_SPECIAL;
8241 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8244 OP * const oldo = o;
8245 o = newUNOP(type, 0, scalar(argop));
8246 op_getmad(oldo,o,'O');
8251 return newUNOP(type, 0, scalar(argop));
8254 return scalar(modkids(ck_fun(o), type));
8258 Perl_ck_sort(pTHX_ OP *o)
8263 PERL_ARGS_ASSERT_CK_SORT;
8265 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8266 HV * const hinthv = GvHV(PL_hintgv);
8268 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8270 const I32 sorthints = (I32)SvIV(*svp);
8271 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8272 o->op_private |= OPpSORT_QSORT;
8273 if ((sorthints & HINT_SORT_STABLE) != 0)
8274 o->op_private |= OPpSORT_STABLE;
8279 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8281 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8282 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8284 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8286 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8288 if (kid->op_type == OP_SCOPE) {
8292 else if (kid->op_type == OP_LEAVE) {
8293 if (o->op_type == OP_SORT) {
8294 op_null(kid); /* wipe out leave */
8297 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8298 if (k->op_next == kid)
8300 /* don't descend into loops */
8301 else if (k->op_type == OP_ENTERLOOP
8302 || k->op_type == OP_ENTERITER)
8304 k = cLOOPx(k)->op_lastop;
8309 kid->op_next = 0; /* just disconnect the leave */
8310 k = kLISTOP->op_first;
8315 if (o->op_type == OP_SORT) {
8316 /* provide scalar context for comparison function/block */
8322 o->op_flags |= OPf_SPECIAL;
8324 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8327 firstkid = firstkid->op_sibling;
8330 /* provide list context for arguments */
8331 if (o->op_type == OP_SORT)
8338 S_simplify_sort(pTHX_ OP *o)
8341 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8347 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8349 if (!(o->op_flags & OPf_STACKED))
8351 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8352 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8353 kid = kUNOP->op_first; /* get past null */
8354 if (kid->op_type != OP_SCOPE)
8356 kid = kLISTOP->op_last; /* get past scope */
8357 switch(kid->op_type) {
8365 k = kid; /* remember this node*/
8366 if (kBINOP->op_first->op_type != OP_RV2SV)
8368 kid = kBINOP->op_first; /* get past cmp */
8369 if (kUNOP->op_first->op_type != OP_GV)
8371 kid = kUNOP->op_first; /* get past rv2sv */
8373 if (GvSTASH(gv) != PL_curstash)
8375 gvname = GvNAME(gv);
8376 if (*gvname == 'a' && gvname[1] == '\0')
8378 else if (*gvname == 'b' && gvname[1] == '\0')
8383 kid = k; /* back to cmp */
8384 if (kBINOP->op_last->op_type != OP_RV2SV)
8386 kid = kBINOP->op_last; /* down to 2nd arg */
8387 if (kUNOP->op_first->op_type != OP_GV)
8389 kid = kUNOP->op_first; /* get past rv2sv */
8391 if (GvSTASH(gv) != PL_curstash)
8393 gvname = GvNAME(gv);
8395 ? !(*gvname == 'a' && gvname[1] == '\0')
8396 : !(*gvname == 'b' && gvname[1] == '\0'))
8398 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8400 o->op_private |= OPpSORT_DESCEND;
8401 if (k->op_type == OP_NCMP)
8402 o->op_private |= OPpSORT_NUMERIC;
8403 if (k->op_type == OP_I_NCMP)
8404 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8405 kid = cLISTOPo->op_first->op_sibling;
8406 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8408 op_getmad(kid,o,'S'); /* then delete it */
8410 op_free(kid); /* then delete it */
8415 Perl_ck_split(pTHX_ OP *o)
8420 PERL_ARGS_ASSERT_CK_SPLIT;
8422 if (o->op_flags & OPf_STACKED)
8423 return no_fh_allowed(o);
8425 kid = cLISTOPo->op_first;
8426 if (kid->op_type != OP_NULL)
8427 Perl_croak(aTHX_ "panic: ck_split");
8428 kid = kid->op_sibling;
8429 op_free(cLISTOPo->op_first);
8430 cLISTOPo->op_first = kid;
8432 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8433 cLISTOPo->op_last = kid; /* There was only one element previously */
8436 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8437 OP * const sibl = kid->op_sibling;
8438 kid->op_sibling = 0;
8439 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8440 if (cLISTOPo->op_first == cLISTOPo->op_last)
8441 cLISTOPo->op_last = kid;
8442 cLISTOPo->op_first = kid;
8443 kid->op_sibling = sibl;
8446 kid->op_type = OP_PUSHRE;
8447 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8449 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8450 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8451 "Use of /g modifier is meaningless in split");
8454 if (!kid->op_sibling)
8455 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8457 kid = kid->op_sibling;
8460 if (!kid->op_sibling)
8461 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8462 assert(kid->op_sibling);
8464 kid = kid->op_sibling;
8467 if (kid->op_sibling)
8468 return too_many_arguments(o,OP_DESC(o));
8474 Perl_ck_join(pTHX_ OP *o)
8476 const OP * const kid = cLISTOPo->op_first->op_sibling;
8478 PERL_ARGS_ASSERT_CK_JOIN;
8480 if (kid && kid->op_type == OP_MATCH) {
8481 if (ckWARN(WARN_SYNTAX)) {
8482 const REGEXP *re = PM_GETRE(kPMOP);
8483 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8484 const STRLEN len = re ? RX_PRELEN(re) : 6;
8485 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8486 "/%.*s/ should probably be written as \"%.*s\"",
8487 (int)len, pmstr, (int)len, pmstr);
8494 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8496 Examines an op, which is expected to identify a subroutine at runtime,
8497 and attempts to determine at compile time which subroutine it identifies.
8498 This is normally used during Perl compilation to determine whether
8499 a prototype can be applied to a function call. I<cvop> is the op
8500 being considered, normally an C<rv2cv> op. A pointer to the identified
8501 subroutine is returned, if it could be determined statically, and a null
8502 pointer is returned if it was not possible to determine statically.
8504 Currently, the subroutine can be identified statically if the RV that the
8505 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8506 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8507 suitable if the constant value must be an RV pointing to a CV. Details of
8508 this process may change in future versions of Perl. If the C<rv2cv> op
8509 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8510 the subroutine statically: this flag is used to suppress compile-time
8511 magic on a subroutine call, forcing it to use default runtime behaviour.
8513 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8514 of a GV reference is modified. If a GV was examined and its CV slot was
8515 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8516 If the op is not optimised away, and the CV slot is later populated with
8517 a subroutine having a prototype, that flag eventually triggers the warning
8518 "called too early to check prototype".
8520 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8521 of returning a pointer to the subroutine it returns a pointer to the
8522 GV giving the most appropriate name for the subroutine in this context.
8523 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8524 (C<CvANON>) subroutine that is referenced through a GV it will be the
8525 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8526 A null pointer is returned as usual if there is no statically-determinable
8533 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8538 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8539 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8540 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8541 if (cvop->op_type != OP_RV2CV)
8543 if (cvop->op_private & OPpENTERSUB_AMPER)
8545 if (!(cvop->op_flags & OPf_KIDS))
8547 rvop = cUNOPx(cvop)->op_first;
8548 switch (rvop->op_type) {
8550 gv = cGVOPx_gv(rvop);
8553 if (flags & RV2CVOPCV_MARK_EARLY)
8554 rvop->op_private |= OPpEARLY_CV;
8559 SV *rv = cSVOPx_sv(rvop);
8569 if (SvTYPE((SV*)cv) != SVt_PVCV)
8571 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8572 if (!CvANON(cv) || !gv)
8581 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8583 Performs the default fixup of the arguments part of an C<entersub>
8584 op tree. This consists of applying list context to each of the
8585 argument ops. This is the standard treatment used on a call marked
8586 with C<&>, or a method call, or a call through a subroutine reference,
8587 or any other call where the callee can't be identified at compile time,
8588 or a call where the callee has no prototype.
8594 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8597 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8598 aop = cUNOPx(entersubop)->op_first;
8599 if (!aop->op_sibling)
8600 aop = cUNOPx(aop)->op_first;
8601 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8602 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8604 mod(aop, OP_ENTERSUB);
8611 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8613 Performs the fixup of the arguments part of an C<entersub> op tree
8614 based on a subroutine prototype. This makes various modifications to
8615 the argument ops, from applying context up to inserting C<refgen> ops,
8616 and checking the number and syntactic types of arguments, as directed by
8617 the prototype. This is the standard treatment used on a subroutine call,
8618 not marked with C<&>, where the callee can be identified at compile time
8619 and has a prototype.
8621 I<protosv> supplies the subroutine prototype to be applied to the call.
8622 It may be a normal defined scalar, of which the string value will be used.
8623 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8624 that has been cast to C<SV*>) which has a prototype. The prototype
8625 supplied, in whichever form, does not need to match the actual callee
8626 referenced by the op tree.
8628 If the argument ops disagree with the prototype, for example by having
8629 an unacceptable number of arguments, a valid op tree is returned anyway.
8630 The error is reflected in the parser state, normally resulting in a single
8631 exception at the top level of parsing which covers all the compilation
8632 errors that occurred. In the error message, the callee is referred to
8633 by the name defined by the I<namegv> parameter.
8639 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8642 const char *proto, *proto_end;
8643 OP *aop, *prev, *cvop;
8646 I32 contextclass = 0;
8647 const char *e = NULL;
8648 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8649 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8650 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8651 proto = SvPV(protosv, proto_len);
8652 proto_end = proto + proto_len;
8653 aop = cUNOPx(entersubop)->op_first;
8654 if (!aop->op_sibling)
8655 aop = cUNOPx(aop)->op_first;
8657 aop = aop->op_sibling;
8658 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8659 while (aop != cvop) {
8661 if (PL_madskills && aop->op_type == OP_STUB) {
8662 aop = aop->op_sibling;
8665 if (PL_madskills && aop->op_type == OP_NULL)
8666 o3 = ((UNOP*)aop)->op_first;
8670 if (proto >= proto_end)
8671 return too_many_arguments(entersubop, gv_ename(namegv));
8679 /* _ must be at the end */
8680 if (proto[1] && proto[1] != ';')
8695 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8697 arg == 1 ? "block or sub {}" : "sub {}",
8698 gv_ename(namegv), o3);
8701 /* '*' allows any scalar type, including bareword */
8704 if (o3->op_type == OP_RV2GV)
8705 goto wrapref; /* autoconvert GLOB -> GLOBref */
8706 else if (o3->op_type == OP_CONST)
8707 o3->op_private &= ~OPpCONST_STRICT;
8708 else if (o3->op_type == OP_ENTERSUB) {
8709 /* accidental subroutine, revert to bareword */
8710 OP *gvop = ((UNOP*)o3)->op_first;
8711 if (gvop && gvop->op_type == OP_NULL) {
8712 gvop = ((UNOP*)gvop)->op_first;
8714 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8717 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8718 (gvop = ((UNOP*)gvop)->op_first) &&
8719 gvop->op_type == OP_GV)
8721 GV * const gv = cGVOPx_gv(gvop);
8722 OP * const sibling = aop->op_sibling;
8723 SV * const n = newSVpvs("");
8725 OP * const oldaop = aop;
8729 gv_fullname4(n, gv, "", FALSE);
8730 aop = newSVOP(OP_CONST, 0, n);
8731 op_getmad(oldaop,aop,'O');
8732 prev->op_sibling = aop;
8733 aop->op_sibling = sibling;
8743 if (o3->op_type == OP_RV2AV ||
8744 o3->op_type == OP_PADAV ||
8745 o3->op_type == OP_RV2HV ||
8746 o3->op_type == OP_PADHV
8761 if (contextclass++ == 0) {
8762 e = strchr(proto, ']');
8763 if (!e || e == proto)
8772 const char *p = proto;
8773 const char *const end = proto;
8775 while (*--p != '[') {}
8776 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8778 gv_ename(namegv), o3);
8783 if (o3->op_type == OP_RV2GV)
8786 bad_type(arg, "symbol", gv_ename(namegv), o3);
8789 if (o3->op_type == OP_ENTERSUB)
8792 bad_type(arg, "subroutine entry", gv_ename(namegv),
8796 if (o3->op_type == OP_RV2SV ||
8797 o3->op_type == OP_PADSV ||
8798 o3->op_type == OP_HELEM ||
8799 o3->op_type == OP_AELEM)
8802 bad_type(arg, "scalar", gv_ename(namegv), o3);
8805 if (o3->op_type == OP_RV2AV ||
8806 o3->op_type == OP_PADAV)
8809 bad_type(arg, "array", gv_ename(namegv), o3);
8812 if (o3->op_type == OP_RV2HV ||
8813 o3->op_type == OP_PADHV)
8816 bad_type(arg, "hash", gv_ename(namegv), o3);
8820 OP* const kid = aop;
8821 OP* const sib = kid->op_sibling;
8822 kid->op_sibling = 0;
8823 aop = newUNOP(OP_REFGEN, 0, kid);
8824 aop->op_sibling = sib;
8825 prev->op_sibling = aop;
8827 if (contextclass && e) {
8842 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8843 gv_ename(namegv), SVfARG(protosv));
8846 mod(aop, OP_ENTERSUB);
8848 aop = aop->op_sibling;
8850 if (aop == cvop && *proto == '_') {
8851 /* generate an access to $_ */
8853 aop->op_sibling = prev->op_sibling;
8854 prev->op_sibling = aop; /* instead of cvop */
8856 if (!optional && proto_end > proto &&
8857 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8858 return too_few_arguments(entersubop, gv_ename(namegv));
8863 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8865 Performs the fixup of the arguments part of an C<entersub> op tree either
8866 based on a subroutine prototype or using default list-context processing.
8867 This is the standard treatment used on a subroutine call, not marked
8868 with C<&>, where the callee can be identified at compile time.
8870 I<protosv> supplies the subroutine prototype to be applied to the call,
8871 or indicates that there is no prototype. It may be a normal scalar,
8872 in which case if it is defined then the string value will be used
8873 as a prototype, and if it is undefined then there is no prototype.
8874 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8875 that has been cast to C<SV*>), of which the prototype will be used if it
8876 has one. The prototype (or lack thereof) supplied, in whichever form,
8877 does not need to match the actual callee referenced by the op tree.
8879 If the argument ops disagree with the prototype, for example by having
8880 an unacceptable number of arguments, a valid op tree is returned anyway.
8881 The error is reflected in the parser state, normally resulting in a single
8882 exception at the top level of parsing which covers all the compilation
8883 errors that occurred. In the error message, the callee is referred to
8884 by the name defined by the I<namegv> parameter.
8890 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8891 GV *namegv, SV *protosv)
8893 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8894 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8895 return ck_entersub_args_proto(entersubop, namegv, protosv);
8897 return ck_entersub_args_list(entersubop);
8901 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8903 Retrieves the function that will be used to fix up a call to I<cv>.
8904 Specifically, the function is applied to an C<entersub> op tree for a
8905 subroutine call, not marked with C<&>, where the callee can be identified
8906 at compile time as I<cv>.
8908 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8909 argument for it is returned in I<*ckobj_p>. The function is intended
8910 to be called in this manner:
8912 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8914 In this call, I<entersubop> is a pointer to the C<entersub> op,
8915 which may be replaced by the check function, and I<namegv> is a GV
8916 supplying the name that should be used by the check function to refer
8917 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8918 It is permitted to apply the check function in non-standard situations,
8919 such as to a call to a different subroutine or to a method call.
8921 By default, the function is
8922 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8923 and the SV parameter is I<cv> itself. This implements standard
8924 prototype processing. It can be changed, for a particular subroutine,
8925 by L</cv_set_call_checker>.
8931 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8934 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8935 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8937 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8938 *ckobj_p = callmg->mg_obj;
8940 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8946 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8948 Sets the function that will be used to fix up a call to I<cv>.
8949 Specifically, the function is applied to an C<entersub> op tree for a
8950 subroutine call, not marked with C<&>, where the callee can be identified
8951 at compile time as I<cv>.
8953 The C-level function pointer is supplied in I<ckfun>, and an SV argument
8954 for it is supplied in I<ckobj>. The function is intended to be called
8957 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
8959 In this call, I<entersubop> is a pointer to the C<entersub> op,
8960 which may be replaced by the check function, and I<namegv> is a GV
8961 supplying the name that should be used by the check function to refer
8962 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8963 It is permitted to apply the check function in non-standard situations,
8964 such as to a call to a different subroutine or to a method call.
8966 The current setting for a particular CV can be retrieved by
8967 L</cv_get_call_checker>.
8973 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
8975 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
8976 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
8977 if (SvMAGICAL((SV*)cv))
8978 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
8981 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
8982 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
8983 if (callmg->mg_flags & MGf_REFCOUNTED) {
8984 SvREFCNT_dec(callmg->mg_obj);
8985 callmg->mg_flags &= ~MGf_REFCOUNTED;
8987 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
8988 callmg->mg_obj = ckobj;
8989 if (ckobj != (SV*)cv) {
8990 SvREFCNT_inc_simple_void_NN(ckobj);
8991 callmg->mg_flags |= MGf_REFCOUNTED;
8997 Perl_ck_subr(pTHX_ OP *o)
9003 PERL_ARGS_ASSERT_CK_SUBR;
9005 aop = cUNOPx(o)->op_first;
9006 if (!aop->op_sibling)
9007 aop = cUNOPx(aop)->op_first;
9008 aop = aop->op_sibling;
9009 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9010 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9011 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9013 o->op_private |= OPpENTERSUB_HASTARG;
9014 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9015 if (PERLDB_SUB && PL_curstash != PL_debstash)
9016 o->op_private |= OPpENTERSUB_DB;
9017 if (cvop->op_type == OP_RV2CV) {
9018 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9020 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9021 if (aop->op_type == OP_CONST)
9022 aop->op_private &= ~OPpCONST_STRICT;
9023 else if (aop->op_type == OP_LIST) {
9024 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9025 if (sib && sib->op_type == OP_CONST)
9026 sib->op_private &= ~OPpCONST_STRICT;
9031 return ck_entersub_args_list(o);
9033 Perl_call_checker ckfun;
9035 cv_get_call_checker(cv, &ckfun, &ckobj);
9036 return ckfun(aTHX_ o, namegv, ckobj);
9041 Perl_ck_svconst(pTHX_ OP *o)
9043 PERL_ARGS_ASSERT_CK_SVCONST;
9044 PERL_UNUSED_CONTEXT;
9045 SvREADONLY_on(cSVOPo->op_sv);
9050 Perl_ck_chdir(pTHX_ OP *o)
9052 PERL_ARGS_ASSERT_CK_CHDIR;
9053 if (o->op_flags & OPf_KIDS) {
9054 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9056 if (kid && kid->op_type == OP_CONST &&
9057 (kid->op_private & OPpCONST_BARE))
9059 o->op_flags |= OPf_SPECIAL;
9060 kid->op_private &= ~OPpCONST_STRICT;
9067 Perl_ck_trunc(pTHX_ OP *o)
9069 PERL_ARGS_ASSERT_CK_TRUNC;
9071 if (o->op_flags & OPf_KIDS) {
9072 SVOP *kid = (SVOP*)cUNOPo->op_first;
9074 if (kid->op_type == OP_NULL)
9075 kid = (SVOP*)kid->op_sibling;
9076 if (kid && kid->op_type == OP_CONST &&
9077 (kid->op_private & OPpCONST_BARE))
9079 o->op_flags |= OPf_SPECIAL;
9080 kid->op_private &= ~OPpCONST_STRICT;
9087 Perl_ck_unpack(pTHX_ OP *o)
9089 OP *kid = cLISTOPo->op_first;
9091 PERL_ARGS_ASSERT_CK_UNPACK;
9093 if (kid->op_sibling) {
9094 kid = kid->op_sibling;
9095 if (!kid->op_sibling)
9096 kid->op_sibling = newDEFSVOP();
9102 Perl_ck_substr(pTHX_ OP *o)
9104 PERL_ARGS_ASSERT_CK_SUBSTR;
9107 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9108 OP *kid = cLISTOPo->op_first;
9110 if (kid->op_type == OP_NULL)
9111 kid = kid->op_sibling;
9113 kid->op_flags |= OPf_MOD;
9120 Perl_ck_each(pTHX_ OP *o)
9123 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9125 PERL_ARGS_ASSERT_CK_EACH;
9128 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
9129 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
9130 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9131 o->op_type = new_type;
9132 o->op_ppaddr = PL_ppaddr[new_type];
9134 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
9135 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
9137 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
9144 /* caller is supposed to assign the return to the
9145 container of the rep_op var */
9147 S_opt_scalarhv(pTHX_ OP *rep_op) {
9151 PERL_ARGS_ASSERT_OPT_SCALARHV;
9153 NewOp(1101, unop, 1, UNOP);
9154 unop->op_type = (OPCODE)OP_BOOLKEYS;
9155 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9156 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9157 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9158 unop->op_first = rep_op;
9159 unop->op_next = rep_op->op_next;
9160 rep_op->op_next = (OP*)unop;
9161 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9162 unop->op_sibling = rep_op->op_sibling;
9163 rep_op->op_sibling = NULL;
9164 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9165 if (rep_op->op_type == OP_PADHV) {
9166 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9167 rep_op->op_flags |= OPf_WANT_LIST;
9172 /* Checks if o acts as an in-place operator on an array. oright points to the
9173 * beginning of the right-hand side. Returns the left-hand side of the
9174 * assignment if o acts in-place, or NULL otherwise. */
9177 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9181 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9184 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9185 || oright->op_next != o
9186 || (oright->op_private & OPpLVAL_INTRO)
9190 /* o2 follows the chain of op_nexts through the LHS of the
9191 * assign (if any) to the aassign op itself */
9193 if (!o2 || o2->op_type != OP_NULL)
9196 if (!o2 || o2->op_type != OP_PUSHMARK)
9199 if (o2 && o2->op_type == OP_GV)
9202 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9203 || (o2->op_private & OPpLVAL_INTRO)
9208 if (!o2 || o2->op_type != OP_NULL)
9211 if (!o2 || o2->op_type != OP_AASSIGN
9212 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9215 /* check that the sort is the first arg on RHS of assign */
9217 o2 = cUNOPx(o2)->op_first;
9218 if (!o2 || o2->op_type != OP_NULL)
9220 o2 = cUNOPx(o2)->op_first;
9221 if (!o2 || o2->op_type != OP_PUSHMARK)
9223 if (o2->op_sibling != o)
9226 /* check the array is the same on both sides */
9227 if (oleft->op_type == OP_RV2AV) {
9228 if (oright->op_type != OP_RV2AV
9229 || !cUNOPx(oright)->op_first
9230 || cUNOPx(oright)->op_first->op_type != OP_GV
9231 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9232 cGVOPx_gv(cUNOPx(oright)->op_first)
9236 else if (oright->op_type != OP_PADAV
9237 || oright->op_targ != oleft->op_targ
9244 /* A peephole optimizer. We visit the ops in the order they're to execute.
9245 * See the comments at the top of this file for more details about when
9246 * peep() is called */
9249 Perl_rpeep(pTHX_ register OP *o)
9252 register OP* oldop = NULL;
9254 if (!o || o->op_opt)
9258 SAVEVPTR(PL_curcop);
9259 for (; o; o = o->op_next) {
9262 /* By default, this op has now been optimised. A couple of cases below
9263 clear this again. */
9266 switch (o->op_type) {
9268 PL_curcop = ((COP*)o); /* for warnings */
9271 PL_curcop = ((COP*)o); /* for warnings */
9273 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9274 to carry two labels. For now, take the easier option, and skip
9275 this optimisation if the first NEXTSTATE has a label. */
9276 if (!CopLABEL((COP*)o)) {
9277 OP *nextop = o->op_next;
9278 while (nextop && nextop->op_type == OP_NULL)
9279 nextop = nextop->op_next;
9281 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9282 COP *firstcop = (COP *)o;
9283 COP *secondcop = (COP *)nextop;
9284 /* We want the COP pointed to by o (and anything else) to
9285 become the next COP down the line. */
9288 firstcop->op_next = secondcop->op_next;
9290 /* Now steal all its pointers, and duplicate the other
9292 firstcop->cop_line = secondcop->cop_line;
9294 firstcop->cop_stashpv = secondcop->cop_stashpv;
9295 firstcop->cop_file = secondcop->cop_file;
9297 firstcop->cop_stash = secondcop->cop_stash;
9298 firstcop->cop_filegv = secondcop->cop_filegv;
9300 firstcop->cop_hints = secondcop->cop_hints;
9301 firstcop->cop_seq = secondcop->cop_seq;
9302 firstcop->cop_warnings = secondcop->cop_warnings;
9303 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9306 secondcop->cop_stashpv = NULL;
9307 secondcop->cop_file = NULL;
9309 secondcop->cop_stash = NULL;
9310 secondcop->cop_filegv = NULL;
9312 secondcop->cop_warnings = NULL;
9313 secondcop->cop_hints_hash = NULL;
9315 /* If we use op_null(), and hence leave an ex-COP, some
9316 warnings are misreported. For example, the compile-time
9317 error in 'use strict; no strict refs;' */
9318 secondcop->op_type = OP_NULL;
9319 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9325 if (cSVOPo->op_private & OPpCONST_STRICT)
9326 no_bareword_allowed(o);
9329 case OP_METHOD_NAMED:
9330 /* Relocate sv to the pad for thread safety.
9331 * Despite being a "constant", the SV is written to,
9332 * for reference counts, sv_upgrade() etc. */
9334 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9335 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9336 /* If op_sv is already a PADTMP then it is being used by
9337 * some pad, so make a copy. */
9338 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9339 SvREADONLY_on(PAD_SVl(ix));
9340 SvREFCNT_dec(cSVOPo->op_sv);
9342 else if (o->op_type != OP_METHOD_NAMED
9343 && cSVOPo->op_sv == &PL_sv_undef) {
9344 /* PL_sv_undef is hack - it's unsafe to store it in the
9345 AV that is the pad, because av_fetch treats values of
9346 PL_sv_undef as a "free" AV entry and will merrily
9347 replace them with a new SV, causing pad_alloc to think
9348 that this pad slot is free. (When, clearly, it is not)
9350 SvOK_off(PAD_SVl(ix));
9351 SvPADTMP_on(PAD_SVl(ix));
9352 SvREADONLY_on(PAD_SVl(ix));
9355 SvREFCNT_dec(PAD_SVl(ix));
9356 SvPADTMP_on(cSVOPo->op_sv);
9357 PAD_SETSV(ix, cSVOPo->op_sv);
9358 /* XXX I don't know how this isn't readonly already. */
9359 SvREADONLY_on(PAD_SVl(ix));
9361 cSVOPo->op_sv = NULL;
9368 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9369 if (o->op_next->op_private & OPpTARGET_MY) {
9370 if (o->op_flags & OPf_STACKED) /* chained concats */
9371 break; /* ignore_optimization */
9373 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9374 o->op_targ = o->op_next->op_targ;
9375 o->op_next->op_targ = 0;
9376 o->op_private |= OPpTARGET_MY;
9379 op_null(o->op_next);
9383 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9384 break; /* Scalar stub must produce undef. List stub is noop */
9388 if (o->op_targ == OP_NEXTSTATE
9389 || o->op_targ == OP_DBSTATE)
9391 PL_curcop = ((COP*)o);
9393 /* XXX: We avoid setting op_seq here to prevent later calls
9394 to rpeep() from mistakenly concluding that optimisation
9395 has already occurred. This doesn't fix the real problem,
9396 though (See 20010220.007). AMS 20010719 */
9397 /* op_seq functionality is now replaced by op_opt */
9404 if (oldop && o->op_next) {
9405 oldop->op_next = o->op_next;
9413 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9414 OP* const pop = (o->op_type == OP_PADAV) ?
9415 o->op_next : o->op_next->op_next;
9417 if (pop && pop->op_type == OP_CONST &&
9418 ((PL_op = pop->op_next)) &&
9419 pop->op_next->op_type == OP_AELEM &&
9420 !(pop->op_next->op_private &
9421 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9422 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9427 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9428 no_bareword_allowed(pop);
9429 if (o->op_type == OP_GV)
9430 op_null(o->op_next);
9431 op_null(pop->op_next);
9433 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9434 o->op_next = pop->op_next->op_next;
9435 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9436 o->op_private = (U8)i;
9437 if (o->op_type == OP_GV) {
9442 o->op_flags |= OPf_SPECIAL;
9443 o->op_type = OP_AELEMFAST;
9448 if (o->op_next->op_type == OP_RV2SV) {
9449 if (!(o->op_next->op_private & OPpDEREF)) {
9450 op_null(o->op_next);
9451 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9453 o->op_next = o->op_next->op_next;
9454 o->op_type = OP_GVSV;
9455 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9458 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9459 GV * const gv = cGVOPo_gv;
9460 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9461 /* XXX could check prototype here instead of just carping */
9462 SV * const sv = sv_newmortal();
9463 gv_efullname3(sv, gv, NULL);
9464 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9465 "%"SVf"() called too early to check prototype",
9469 else if (o->op_next->op_type == OP_READLINE
9470 && o->op_next->op_next->op_type == OP_CONCAT
9471 && (o->op_next->op_next->op_flags & OPf_STACKED))
9473 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9474 o->op_type = OP_RCATLINE;
9475 o->op_flags |= OPf_STACKED;
9476 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9477 op_null(o->op_next->op_next);
9478 op_null(o->op_next);
9488 fop = cUNOP->op_first;
9496 fop = cLOGOP->op_first;
9497 sop = fop->op_sibling;
9498 while (cLOGOP->op_other->op_type == OP_NULL)
9499 cLOGOP->op_other = cLOGOP->op_other->op_next;
9500 CALL_RPEEP(cLOGOP->op_other);
9504 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9506 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9511 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9512 while (nop && nop->op_next) {
9513 switch (nop->op_next->op_type) {
9518 lop = nop = nop->op_next;
9529 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9530 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9531 cLOGOP->op_first = opt_scalarhv(fop);
9532 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9533 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9549 while (cLOGOP->op_other->op_type == OP_NULL)
9550 cLOGOP->op_other = cLOGOP->op_other->op_next;
9551 CALL_RPEEP(cLOGOP->op_other);
9556 while (cLOOP->op_redoop->op_type == OP_NULL)
9557 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9558 CALL_RPEEP(cLOOP->op_redoop);
9559 while (cLOOP->op_nextop->op_type == OP_NULL)
9560 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9561 CALL_RPEEP(cLOOP->op_nextop);
9562 while (cLOOP->op_lastop->op_type == OP_NULL)
9563 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9564 CALL_RPEEP(cLOOP->op_lastop);
9568 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9569 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9570 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9571 cPMOP->op_pmstashstartu.op_pmreplstart
9572 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9573 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9577 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9578 && ckWARN(WARN_SYNTAX))
9580 if (o->op_next->op_sibling) {
9581 const OPCODE type = o->op_next->op_sibling->op_type;
9582 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9583 const line_t oldline = CopLINE(PL_curcop);
9584 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9585 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9586 "Statement unlikely to be reached");
9587 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9588 "\t(Maybe you meant system() when you said exec()?)\n");
9589 CopLINE_set(PL_curcop, oldline);
9600 const char *key = NULL;
9603 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9606 /* Make the CONST have a shared SV */
9607 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9608 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
9609 key = SvPV_const(sv, keylen);
9610 lexname = newSVpvn_share(key,
9611 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9617 if ((o->op_private & (OPpLVAL_INTRO)))
9620 rop = (UNOP*)((BINOP*)o)->op_first;
9621 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9623 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9624 if (!SvPAD_TYPED(lexname))
9626 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9627 if (!fields || !GvHV(*fields))
9629 key = SvPV_const(*svp, keylen);
9630 if (!hv_fetch(GvHV(*fields), key,
9631 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9633 Perl_croak(aTHX_ "No such class field \"%s\" "
9634 "in variable %s of type %s",
9635 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9648 SVOP *first_key_op, *key_op;
9650 if ((o->op_private & (OPpLVAL_INTRO))
9651 /* I bet there's always a pushmark... */
9652 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9653 /* hmmm, no optimization if list contains only one key. */
9655 rop = (UNOP*)((LISTOP*)o)->op_last;
9656 if (rop->op_type != OP_RV2HV)
9658 if (rop->op_first->op_type == OP_PADSV)
9659 /* @$hash{qw(keys here)} */
9660 rop = (UNOP*)rop->op_first;
9662 /* @{$hash}{qw(keys here)} */
9663 if (rop->op_first->op_type == OP_SCOPE
9664 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9666 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9672 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9673 if (!SvPAD_TYPED(lexname))
9675 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9676 if (!fields || !GvHV(*fields))
9678 /* Again guessing that the pushmark can be jumped over.... */
9679 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9680 ->op_first->op_sibling;
9681 for (key_op = first_key_op; key_op;
9682 key_op = (SVOP*)key_op->op_sibling) {
9683 if (key_op->op_type != OP_CONST)
9685 svp = cSVOPx_svp(key_op);
9686 key = SvPV_const(*svp, keylen);
9687 if (!hv_fetch(GvHV(*fields), key,
9688 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9690 Perl_croak(aTHX_ "No such class field \"%s\" "
9691 "in variable %s of type %s",
9692 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9701 && ( oldop->op_type == OP_AELEM
9702 || oldop->op_type == OP_PADSV
9703 || oldop->op_type == OP_RV2SV
9704 || oldop->op_type == OP_RV2GV
9705 || oldop->op_type == OP_HELEM
9707 && (oldop->op_private & OPpDEREF)
9709 o->op_private |= OPpDEREFed;
9713 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9717 /* check that RHS of sort is a single plain array */
9718 OP *oright = cUNOPo->op_first;
9719 if (!oright || oright->op_type != OP_PUSHMARK)
9722 /* reverse sort ... can be optimised. */
9723 if (!cUNOPo->op_sibling) {
9724 /* Nothing follows us on the list. */
9725 OP * const reverse = o->op_next;
9727 if (reverse->op_type == OP_REVERSE &&
9728 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9729 OP * const pushmark = cUNOPx(reverse)->op_first;
9730 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9731 && (cUNOPx(pushmark)->op_sibling == o)) {
9732 /* reverse -> pushmark -> sort */
9733 o->op_private |= OPpSORT_REVERSE;
9735 pushmark->op_next = oright->op_next;
9741 /* make @a = sort @a act in-place */
9743 oright = cUNOPx(oright)->op_sibling;
9746 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9747 oright = cUNOPx(oright)->op_sibling;
9750 oleft = is_inplace_av(o, oright);
9754 /* transfer MODishness etc from LHS arg to RHS arg */
9755 oright->op_flags = oleft->op_flags;
9756 o->op_private |= OPpSORT_INPLACE;
9758 /* excise push->gv->rv2av->null->aassign */
9759 o2 = o->op_next->op_next;
9760 op_null(o2); /* PUSHMARK */
9762 if (o2->op_type == OP_GV) {
9763 op_null(o2); /* GV */
9766 op_null(o2); /* RV2AV or PADAV */
9767 o2 = o2->op_next->op_next;
9768 op_null(o2); /* AASSIGN */
9770 o->op_next = o2->op_next;
9776 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9779 LISTOP *enter, *exlist;
9781 /* @a = reverse @a */
9782 if ((oright = cLISTOPo->op_first)
9783 && (oright->op_type == OP_PUSHMARK)
9784 && (oright = oright->op_sibling)
9785 && (oleft = is_inplace_av(o, oright))) {
9788 /* transfer MODishness etc from LHS arg to RHS arg */
9789 oright->op_flags = oleft->op_flags;
9790 o->op_private |= OPpREVERSE_INPLACE;
9792 /* excise push->gv->rv2av->null->aassign */
9793 o2 = o->op_next->op_next;
9794 op_null(o2); /* PUSHMARK */
9796 if (o2->op_type == OP_GV) {
9797 op_null(o2); /* GV */
9800 op_null(o2); /* RV2AV or PADAV */
9801 o2 = o2->op_next->op_next;
9802 op_null(o2); /* AASSIGN */
9804 o->op_next = o2->op_next;
9808 enter = (LISTOP *) o->op_next;
9811 if (enter->op_type == OP_NULL) {
9812 enter = (LISTOP *) enter->op_next;
9816 /* for $a (...) will have OP_GV then OP_RV2GV here.
9817 for (...) just has an OP_GV. */
9818 if (enter->op_type == OP_GV) {
9819 gvop = (OP *) enter;
9820 enter = (LISTOP *) enter->op_next;
9823 if (enter->op_type == OP_RV2GV) {
9824 enter = (LISTOP *) enter->op_next;
9830 if (enter->op_type != OP_ENTERITER)
9833 iter = enter->op_next;
9834 if (!iter || iter->op_type != OP_ITER)
9837 expushmark = enter->op_first;
9838 if (!expushmark || expushmark->op_type != OP_NULL
9839 || expushmark->op_targ != OP_PUSHMARK)
9842 exlist = (LISTOP *) expushmark->op_sibling;
9843 if (!exlist || exlist->op_type != OP_NULL
9844 || exlist->op_targ != OP_LIST)
9847 if (exlist->op_last != o) {
9848 /* Mmm. Was expecting to point back to this op. */
9851 theirmark = exlist->op_first;
9852 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9855 if (theirmark->op_sibling != o) {
9856 /* There's something between the mark and the reverse, eg
9857 for (1, reverse (...))
9862 ourmark = ((LISTOP *)o)->op_first;
9863 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9866 ourlast = ((LISTOP *)o)->op_last;
9867 if (!ourlast || ourlast->op_next != o)
9870 rv2av = ourmark->op_sibling;
9871 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9872 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9873 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9874 /* We're just reversing a single array. */
9875 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9876 enter->op_flags |= OPf_STACKED;
9879 /* We don't have control over who points to theirmark, so sacrifice
9881 theirmark->op_next = ourmark->op_next;
9882 theirmark->op_flags = ourmark->op_flags;
9883 ourlast->op_next = gvop ? gvop : (OP *) enter;
9886 enter->op_private |= OPpITER_REVERSED;
9887 iter->op_private |= OPpITER_REVERSED;
9894 UNOP *refgen, *rv2cv;
9897 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9900 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9903 rv2gv = ((BINOP *)o)->op_last;
9904 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9907 refgen = (UNOP *)((BINOP *)o)->op_first;
9909 if (!refgen || refgen->op_type != OP_REFGEN)
9912 exlist = (LISTOP *)refgen->op_first;
9913 if (!exlist || exlist->op_type != OP_NULL
9914 || exlist->op_targ != OP_LIST)
9917 if (exlist->op_first->op_type != OP_PUSHMARK)
9920 rv2cv = (UNOP*)exlist->op_last;
9922 if (rv2cv->op_type != OP_RV2CV)
9925 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9926 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9927 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9929 o->op_private |= OPpASSIGN_CV_TO_GV;
9930 rv2gv->op_private |= OPpDONT_INIT_GV;
9931 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9939 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9940 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9950 Perl_peep(pTHX_ register OP *o)
9956 Perl_custom_op_name(pTHX_ const OP* o)
9959 const IV index = PTR2IV(o->op_ppaddr);
9963 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9965 if (!PL_custom_op_names) /* This probably shouldn't happen */
9966 return (char *)PL_op_name[OP_CUSTOM];
9968 keysv = sv_2mortal(newSViv(index));
9970 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9972 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9974 return SvPV_nolen(HeVAL(he));
9978 Perl_custom_op_desc(pTHX_ const OP* o)
9981 const IV index = PTR2IV(o->op_ppaddr);
9985 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9987 if (!PL_custom_op_descs)
9988 return (char *)PL_op_desc[OP_CUSTOM];
9990 keysv = sv_2mortal(newSViv(index));
9992 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9994 return (char *)PL_op_desc[OP_CUSTOM];
9996 return SvPV_nolen(HeVAL(he));
10001 /* Efficient sub that returns a constant scalar value. */
10003 const_sv_xsub(pTHX_ CV* cv)
10007 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10011 /* diag_listed_as: SKIPME */
10012 Perl_croak(aTHX_ "usage: %s::%s()",
10013 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10026 * c-indentation-style: bsd
10027 * c-basic-offset: 4
10028 * indent-tabs-mode: t
10031 * ex: set ts=8 sts=4 sw=4 noet: