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)
313 #define CHANGE_TYPE(o,type) \
315 o->op_type = (OPCODE)type; \
316 o->op_ppaddr = PL_ppaddr[type]; \
320 S_gv_ename(pTHX_ GV *gv)
322 SV* const tmpsv = sv_newmortal();
324 PERL_ARGS_ASSERT_GV_ENAME;
326 gv_efullname3(tmpsv, gv, NULL);
327 return SvPV_nolen_const(tmpsv);
331 S_no_fh_allowed(pTHX_ OP *o)
333 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
335 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
341 S_too_few_arguments(pTHX_ OP *o, const char *name)
343 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
345 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
350 S_too_many_arguments(pTHX_ OP *o, const char *name)
352 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
354 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
359 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
361 PERL_ARGS_ASSERT_BAD_TYPE;
363 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
364 (int)n, name, t, OP_DESC(kid)));
368 S_no_bareword_allowed(pTHX_ const OP *o)
370 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
373 return; /* various ok barewords are hidden in extra OP_NULL */
374 qerror(Perl_mess(aTHX_
375 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
379 /* "register" allocation */
382 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
386 const bool is_our = (PL_parser->in_my == KEY_our);
388 PERL_ARGS_ASSERT_ALLOCMY;
391 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
394 /* Until we're using the length for real, cross check that we're being
396 assert(strlen(name) == len);
398 /* complain about "my $<special_var>" etc etc */
402 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
403 (name[1] == '_' && (*name == '$' || len > 2))))
405 /* name[2] is true if strlen(name) > 2 */
406 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
407 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
408 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
409 PL_parser->in_my == KEY_state ? "state" : "my"));
411 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
412 PL_parser->in_my == KEY_state ? "state" : "my"));
416 /* allocate a spare slot and store the name in that slot */
418 off = pad_add_name(name, len,
419 is_our ? padadd_OUR :
420 PL_parser->in_my == KEY_state ? padadd_STATE : 0,
421 PL_parser->in_my_stash,
423 /* $_ is always in main::, even with our */
424 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
428 /* anon sub prototypes contains state vars should always be cloned,
429 * otherwise the state var would be shared between anon subs */
431 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
432 CvCLONE_on(PL_compcv);
437 /* free the body of an op without examining its contents.
438 * Always use this rather than FreeOp directly */
441 S_op_destroy(pTHX_ OP *o)
443 if (o->op_latefree) {
451 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
453 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
459 Perl_op_free(pTHX_ OP *o)
466 if (o->op_latefreed) {
473 if (o->op_private & OPpREFCOUNTED) {
484 refcnt = OpREFCNT_dec(o);
487 /* Need to find and remove any pattern match ops from the list
488 we maintain for reset(). */
489 find_and_forget_pmops(o);
499 /* Call the op_free hook if it has been set. Do it now so that it's called
500 * at the right time for refcounted ops, but still before all of the kids
504 if (o->op_flags & OPf_KIDS) {
505 register OP *kid, *nextkid;
506 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
507 nextkid = kid->op_sibling; /* Get before next freeing kid */
512 #ifdef PERL_DEBUG_READONLY_OPS
516 /* COP* is not cleared by op_clear() so that we may track line
517 * numbers etc even after null() */
518 if (type == OP_NEXTSTATE || type == OP_DBSTATE
519 || (type == OP_NULL /* the COP might have been null'ed */
520 && ((OPCODE)o->op_targ == OP_NEXTSTATE
521 || (OPCODE)o->op_targ == OP_DBSTATE))) {
526 type = (OPCODE)o->op_targ;
529 if (o->op_latefree) {
535 #ifdef DEBUG_LEAKING_SCALARS
542 Perl_op_clear(pTHX_ OP *o)
547 PERL_ARGS_ASSERT_OP_CLEAR;
550 mad_free(o->op_madprop);
555 switch (o->op_type) {
556 case OP_NULL: /* Was holding old type, if any. */
557 if (PL_madskills && o->op_targ != OP_NULL) {
558 o->op_type = (Optype)o->op_targ;
563 case OP_ENTEREVAL: /* Was holding hints. */
567 if (!(o->op_flags & OPf_REF)
568 || (PL_check[o->op_type] != Perl_ck_ftst))
575 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
580 /* It's possible during global destruction that the GV is freed
581 before the optree. Whilst the SvREFCNT_inc is happy to bump from
582 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
583 will trigger an assertion failure, because the entry to sv_clear
584 checks that the scalar is not already freed. A check of for
585 !SvIS_FREED(gv) turns out to be invalid, because during global
586 destruction the reference count can be forced down to zero
587 (with SVf_BREAK set). In which case raising to 1 and then
588 dropping to 0 triggers cleanup before it should happen. I
589 *think* that this might actually be a general, systematic,
590 weakness of the whole idea of SVf_BREAK, in that code *is*
591 allowed to raise and lower references during global destruction,
592 so any *valid* code that happens to do this during global
593 destruction might well trigger premature cleanup. */
594 bool still_valid = gv && SvREFCNT(gv);
597 SvREFCNT_inc_simple_void(gv);
599 if (cPADOPo->op_padix > 0) {
600 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
601 * may still exist on the pad */
602 pad_swipe(cPADOPo->op_padix, TRUE);
603 cPADOPo->op_padix = 0;
606 SvREFCNT_dec(cSVOPo->op_sv);
607 cSVOPo->op_sv = NULL;
610 int try_downgrade = SvREFCNT(gv) == 2;
613 gv_try_downgrade(gv);
617 case OP_METHOD_NAMED:
620 SvREFCNT_dec(cSVOPo->op_sv);
621 cSVOPo->op_sv = NULL;
624 Even if op_clear does a pad_free for the target of the op,
625 pad_free doesn't actually remove the sv that exists in the pad;
626 instead it lives on. This results in that it could be reused as
627 a target later on when the pad was reallocated.
630 pad_swipe(o->op_targ,1);
639 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
644 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
646 if (cPADOPo->op_padix > 0) {
647 pad_swipe(cPADOPo->op_padix, TRUE);
648 cPADOPo->op_padix = 0;
651 SvREFCNT_dec(cSVOPo->op_sv);
652 cSVOPo->op_sv = NULL;
656 PerlMemShared_free(cPVOPo->op_pv);
657 cPVOPo->op_pv = NULL;
661 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
665 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
666 /* No GvIN_PAD_off here, because other references may still
667 * exist on the pad */
668 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
671 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
677 forget_pmop(cPMOPo, 1);
678 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
679 /* we use the same protection as the "SAFE" version of the PM_ macros
680 * here since sv_clean_all might release some PMOPs
681 * after PL_regex_padav has been cleared
682 * and the clearing of PL_regex_padav needs to
683 * happen before sv_clean_all
686 if(PL_regex_pad) { /* We could be in destruction */
687 const IV offset = (cPMOPo)->op_pmoffset;
688 ReREFCNT_dec(PM_GETRE(cPMOPo));
689 PL_regex_pad[offset] = &PL_sv_undef;
690 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
694 ReREFCNT_dec(PM_GETRE(cPMOPo));
695 PM_SETRE(cPMOPo, NULL);
701 if (o->op_targ > 0) {
702 pad_free(o->op_targ);
708 S_cop_free(pTHX_ COP* cop)
710 PERL_ARGS_ASSERT_COP_FREE;
714 if (! specialWARN(cop->cop_warnings))
715 PerlMemShared_free(cop->cop_warnings);
716 cophh_free(CopHINTHASH_get(cop));
720 S_forget_pmop(pTHX_ PMOP *const o
726 HV * const pmstash = PmopSTASH(o);
728 PERL_ARGS_ASSERT_FORGET_PMOP;
730 if (pmstash && !SvIS_FREED(pmstash)) {
731 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
733 PMOP **const array = (PMOP**) mg->mg_ptr;
734 U32 count = mg->mg_len / sizeof(PMOP**);
739 /* Found it. Move the entry at the end to overwrite it. */
740 array[i] = array[--count];
741 mg->mg_len = count * sizeof(PMOP**);
742 /* Could realloc smaller at this point always, but probably
743 not worth it. Probably worth free()ing if we're the
746 Safefree(mg->mg_ptr);
763 S_find_and_forget_pmops(pTHX_ OP *o)
765 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
767 if (o->op_flags & OPf_KIDS) {
768 OP *kid = cUNOPo->op_first;
770 switch (kid->op_type) {
775 forget_pmop((PMOP*)kid, 0);
777 find_and_forget_pmops(kid);
778 kid = kid->op_sibling;
784 Perl_op_null(pTHX_ OP *o)
788 PERL_ARGS_ASSERT_OP_NULL;
790 if (o->op_type == OP_NULL)
794 o->op_targ = o->op_type;
795 o->op_type = OP_NULL;
796 o->op_ppaddr = PL_ppaddr[OP_NULL];
800 Perl_op_refcnt_lock(pTHX)
808 Perl_op_refcnt_unlock(pTHX)
815 /* Contextualizers */
818 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
820 Applies a syntactic context to an op tree representing an expression.
821 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
822 or C<G_VOID> to specify the context to apply. The modified op tree
829 Perl_op_contextualize(pTHX_ OP *o, I32 context)
831 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
833 case G_SCALAR: return scalar(o);
834 case G_ARRAY: return list(o);
835 case G_VOID: return scalarvoid(o);
837 Perl_croak(aTHX_ "panic: op_contextualize bad context");
843 =head1 Optree Manipulation Functions
845 =for apidoc Am|OP*|op_linklist|OP *o
846 This function is the implementation of the L</LINKLIST> macro. It should
847 not be called directly.
853 Perl_op_linklist(pTHX_ OP *o)
857 PERL_ARGS_ASSERT_OP_LINKLIST;
862 /* establish postfix order */
863 first = cUNOPo->op_first;
866 o->op_next = LINKLIST(first);
869 if (kid->op_sibling) {
870 kid->op_next = LINKLIST(kid->op_sibling);
871 kid = kid->op_sibling;
885 S_scalarkids(pTHX_ OP *o)
887 if (o && o->op_flags & OPf_KIDS) {
889 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
896 S_scalarboolean(pTHX_ OP *o)
900 PERL_ARGS_ASSERT_SCALARBOOLEAN;
902 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
903 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
904 if (ckWARN(WARN_SYNTAX)) {
905 const line_t oldline = CopLINE(PL_curcop);
907 if (PL_parser && PL_parser->copline != NOLINE)
908 CopLINE_set(PL_curcop, PL_parser->copline);
909 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
910 CopLINE_set(PL_curcop, oldline);
917 Perl_scalar(pTHX_ OP *o)
922 /* assumes no premature commitment */
923 if (!o || (PL_parser && PL_parser->error_count)
924 || (o->op_flags & OPf_WANT)
925 || o->op_type == OP_RETURN)
930 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
932 switch (o->op_type) {
934 scalar(cBINOPo->op_first);
939 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
949 if (o->op_flags & OPf_KIDS) {
950 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
956 kid = cLISTOPo->op_first;
958 kid = kid->op_sibling;
961 OP *sib = kid->op_sibling;
962 if (sib && kid->op_type != OP_LEAVEWHEN)
968 PL_curcop = &PL_compiling;
973 kid = cLISTOPo->op_first;
976 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
983 Perl_scalarvoid(pTHX_ OP *o)
987 const char* useless = NULL;
991 PERL_ARGS_ASSERT_SCALARVOID;
993 /* trailing mad null ops don't count as "there" for void processing */
995 o->op_type != OP_NULL &&
997 o->op_sibling->op_type == OP_NULL)
1000 for (sib = o->op_sibling;
1001 sib && sib->op_type == OP_NULL;
1002 sib = sib->op_sibling) ;
1008 if (o->op_type == OP_NEXTSTATE
1009 || o->op_type == OP_DBSTATE
1010 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1011 || o->op_targ == OP_DBSTATE)))
1012 PL_curcop = (COP*)o; /* for warning below */
1014 /* assumes no premature commitment */
1015 want = o->op_flags & OPf_WANT;
1016 if ((want && want != OPf_WANT_SCALAR)
1017 || (PL_parser && PL_parser->error_count)
1018 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1023 if ((o->op_private & OPpTARGET_MY)
1024 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1026 return scalar(o); /* As if inside SASSIGN */
1029 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1031 switch (o->op_type) {
1033 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1037 if (o->op_flags & OPf_STACKED)
1041 if (o->op_private == 4)
1066 case OP_AELEMFAST_LEX:
1085 case OP_GETSOCKNAME:
1086 case OP_GETPEERNAME:
1091 case OP_GETPRIORITY:
1115 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1116 /* Otherwise it's "Useless use of grep iterator" */
1117 useless = OP_DESC(o);
1121 kid = cLISTOPo->op_first;
1122 if (kid && kid->op_type == OP_PUSHRE
1124 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1126 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1128 useless = OP_DESC(o);
1132 kid = cUNOPo->op_first;
1133 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1134 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1137 useless = "negative pattern binding (!~)";
1141 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1142 useless = "non-destructive substitution (s///r)";
1146 useless = "non-destructive transliteration (tr///r)";
1153 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1154 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1155 useless = "a variable";
1160 if (cSVOPo->op_private & OPpCONST_STRICT)
1161 no_bareword_allowed(o);
1163 if (ckWARN(WARN_VOID)) {
1165 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1166 "a constant (%"SVf")", sv));
1167 useless = SvPV_nolen(msv);
1170 useless = "a constant (undef)";
1171 if (o->op_private & OPpCONST_ARYBASE)
1173 /* don't warn on optimised away booleans, eg
1174 * use constant Foo, 5; Foo || print; */
1175 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1177 /* the constants 0 and 1 are permitted as they are
1178 conventionally used as dummies in constructs like
1179 1 while some_condition_with_side_effects; */
1180 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1182 else if (SvPOK(sv)) {
1183 /* perl4's way of mixing documentation and code
1184 (before the invention of POD) was based on a
1185 trick to mix nroff and perl code. The trick was
1186 built upon these three nroff macros being used in
1187 void context. The pink camel has the details in
1188 the script wrapman near page 319. */
1189 const char * const maybe_macro = SvPVX_const(sv);
1190 if (strnEQ(maybe_macro, "di", 2) ||
1191 strnEQ(maybe_macro, "ds", 2) ||
1192 strnEQ(maybe_macro, "ig", 2))
1197 op_null(o); /* don't execute or even remember it */
1201 o->op_type = OP_PREINC; /* pre-increment is faster */
1202 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1206 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1207 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1211 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1212 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1216 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1217 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1222 kid = cLOGOPo->op_first;
1223 if (kid->op_type == OP_NOT
1224 && (kid->op_flags & OPf_KIDS)
1226 if (o->op_type == OP_AND) {
1228 o->op_ppaddr = PL_ppaddr[OP_OR];
1230 o->op_type = OP_AND;
1231 o->op_ppaddr = PL_ppaddr[OP_AND];
1240 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1245 if (o->op_flags & OPf_STACKED)
1252 if (!(o->op_flags & OPf_KIDS))
1263 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1273 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1278 S_listkids(pTHX_ OP *o)
1280 if (o && o->op_flags & OPf_KIDS) {
1282 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1289 Perl_list(pTHX_ OP *o)
1294 /* assumes no premature commitment */
1295 if (!o || (o->op_flags & OPf_WANT)
1296 || (PL_parser && PL_parser->error_count)
1297 || o->op_type == OP_RETURN)
1302 if ((o->op_private & OPpTARGET_MY)
1303 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1305 return o; /* As if inside SASSIGN */
1308 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1310 switch (o->op_type) {
1313 list(cBINOPo->op_first);
1318 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1326 if (!(o->op_flags & OPf_KIDS))
1328 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1329 list(cBINOPo->op_first);
1330 return gen_constant_list(o);
1337 kid = cLISTOPo->op_first;
1339 kid = kid->op_sibling;
1342 OP *sib = kid->op_sibling;
1343 if (sib && kid->op_type != OP_LEAVEWHEN)
1349 PL_curcop = &PL_compiling;
1353 kid = cLISTOPo->op_first;
1360 S_scalarseq(pTHX_ OP *o)
1364 const OPCODE type = o->op_type;
1366 if (type == OP_LINESEQ || type == OP_SCOPE ||
1367 type == OP_LEAVE || type == OP_LEAVETRY)
1370 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1371 if (kid->op_sibling) {
1375 PL_curcop = &PL_compiling;
1377 o->op_flags &= ~OPf_PARENS;
1378 if (PL_hints & HINT_BLOCK_SCOPE)
1379 o->op_flags |= OPf_PARENS;
1382 o = newOP(OP_STUB, 0);
1387 S_modkids(pTHX_ OP *o, I32 type)
1389 if (o && o->op_flags & OPf_KIDS) {
1391 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1392 op_lvalue(kid, type);
1398 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1400 Propagate lvalue ("modifiable") context to an op and its children.
1401 I<type> represents the context type, roughly based on the type of op that
1402 would do the modifying, although C<local()> is represented by OP_NULL,
1403 because it has no op type of its own (it is signalled by a flag on
1406 This function detects things that can't be modified, such as C<$x+1>, and
1407 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1408 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1410 It also flags things that need to behave specially in an lvalue context,
1411 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1417 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
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 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1465 poses, so we need it clear. */
1466 o->op_private &= ~1;
1467 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1468 assert(cUNOPo->op_first->op_type == OP_NULL);
1469 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1472 else if (o->op_private & OPpENTERSUB_NOMOD)
1474 else { /* lvalue subroutine call */
1475 o->op_private |= OPpLVAL_INTRO
1476 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
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 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1562 /* grep, foreach, subcalls, refgen */
1563 if (type == OP_GREPSTART || type == OP_ENTERSUB
1564 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1566 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1567 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1569 : (o->op_type == OP_ENTERSUB
1570 ? "non-lvalue subroutine call"
1572 type ? PL_op_desc[type] : "local"));
1586 case OP_RIGHT_SHIFT:
1595 if (!(o->op_flags & OPf_STACKED))
1602 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1603 op_lvalue(kid, type);
1608 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1609 PL_modcount = RETURN_UNLIMITED_NUMBER;
1610 return o; /* Treat \(@foo) like ordinary list. */
1614 if (scalar_mod_type(o, type))
1616 ref(cUNOPo->op_first, o->op_type);
1620 if (type == OP_LEAVESUBLV)
1621 o->op_private |= OPpMAYBE_LVSUB;
1627 PL_modcount = RETURN_UNLIMITED_NUMBER;
1630 PL_hints |= HINT_BLOCK_SCOPE;
1631 if (type == OP_LEAVESUBLV)
1632 o->op_private |= OPpMAYBE_LVSUB;
1636 ref(cUNOPo->op_first, o->op_type);
1640 PL_hints |= HINT_BLOCK_SCOPE;
1649 case OP_AELEMFAST_LEX:
1656 PL_modcount = RETURN_UNLIMITED_NUMBER;
1657 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1658 return o; /* Treat \(@foo) like ordinary list. */
1659 if (scalar_mod_type(o, type))
1661 if (type == OP_LEAVESUBLV)
1662 o->op_private |= OPpMAYBE_LVSUB;
1666 if (!type) /* local() */
1667 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1668 PAD_COMPNAME_PV(o->op_targ));
1677 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1681 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1687 if (type == OP_LEAVESUBLV)
1688 o->op_private |= OPpMAYBE_LVSUB;
1689 pad_free(o->op_targ);
1690 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1691 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1692 if (o->op_flags & OPf_KIDS)
1693 op_lvalue(cBINOPo->op_first->op_sibling, type);
1698 ref(cBINOPo->op_first, o->op_type);
1699 if (type == OP_ENTERSUB &&
1700 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1701 o->op_private |= OPpLVAL_DEFER;
1702 if (type == OP_LEAVESUBLV)
1703 o->op_private |= OPpMAYBE_LVSUB;
1713 if (o->op_flags & OPf_KIDS)
1714 op_lvalue(cLISTOPo->op_last, type);
1719 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1721 else if (!(o->op_flags & OPf_KIDS))
1723 if (o->op_targ != OP_LIST) {
1724 op_lvalue(cBINOPo->op_first, type);
1730 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1731 op_lvalue(kid, type);
1735 if (type != OP_LEAVESUBLV)
1737 break; /* op_lvalue()ing was handled by ck_return() */
1740 /* [20011101.069] File test operators interpret OPf_REF to mean that
1741 their argument is a filehandle; thus \stat(".") should not set
1743 if (type == OP_REFGEN &&
1744 PL_check[o->op_type] == Perl_ck_ftst)
1747 if (type != OP_LEAVESUBLV)
1748 o->op_flags |= OPf_MOD;
1750 if (type == OP_AASSIGN || type == OP_SASSIGN)
1751 o->op_flags |= OPf_SPECIAL|OPf_REF;
1752 else if (!type) { /* local() */
1755 o->op_private |= OPpLVAL_INTRO;
1756 o->op_flags &= ~OPf_SPECIAL;
1757 PL_hints |= HINT_BLOCK_SCOPE;
1762 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1763 "Useless localization of %s", OP_DESC(o));
1766 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1767 && type != OP_LEAVESUBLV)
1768 o->op_flags |= OPf_REF;
1772 /* Do not use this. It will be removed after 5.14. */
1774 Perl_mod(pTHX_ OP *o, I32 type)
1776 return op_lvalue(o,type);
1781 S_scalar_mod_type(const OP *o, I32 type)
1783 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1787 if (o->op_type == OP_RV2GV)
1811 case OP_RIGHT_SHIFT:
1832 S_is_handle_constructor(const OP *o, I32 numargs)
1834 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1836 switch (o->op_type) {
1844 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1857 S_refkids(pTHX_ OP *o, I32 type)
1859 if (o && o->op_flags & OPf_KIDS) {
1861 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1868 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1873 PERL_ARGS_ASSERT_DOREF;
1875 if (!o || (PL_parser && PL_parser->error_count))
1878 switch (o->op_type) {
1880 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1881 !(o->op_flags & OPf_STACKED)) {
1882 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1883 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1884 assert(cUNOPo->op_first->op_type == OP_NULL);
1885 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1886 o->op_flags |= OPf_SPECIAL;
1887 o->op_private &= ~1;
1889 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
1890 o->op_private |= OPpENTERSUB_DEREF;
1891 o->op_flags |= OPf_MOD;
1897 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1898 doref(kid, type, set_op_ref);
1901 if (type == OP_DEFINED)
1902 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1903 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1906 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1907 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1908 : type == OP_RV2HV ? OPpDEREF_HV
1910 o->op_flags |= OPf_MOD;
1917 o->op_flags |= OPf_REF;
1920 if (type == OP_DEFINED)
1921 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1922 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1928 o->op_flags |= OPf_REF;
1933 if (!(o->op_flags & OPf_KIDS))
1935 doref(cBINOPo->op_first, type, set_op_ref);
1939 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1940 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1941 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1942 : type == OP_RV2HV ? OPpDEREF_HV
1944 o->op_flags |= OPf_MOD;
1954 if (!(o->op_flags & OPf_KIDS))
1956 doref(cLISTOPo->op_last, type, set_op_ref);
1966 S_dup_attrlist(pTHX_ OP *o)
1971 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1973 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1974 * where the first kid is OP_PUSHMARK and the remaining ones
1975 * are OP_CONST. We need to push the OP_CONST values.
1977 if (o->op_type == OP_CONST)
1978 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1980 else if (o->op_type == OP_NULL)
1984 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1986 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1987 if (o->op_type == OP_CONST)
1988 rop = op_append_elem(OP_LIST, rop,
1989 newSVOP(OP_CONST, o->op_flags,
1990 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1997 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2002 PERL_ARGS_ASSERT_APPLY_ATTRS;
2004 /* fake up C<use attributes $pkg,$rv,@attrs> */
2005 ENTER; /* need to protect against side-effects of 'use' */
2006 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2008 #define ATTRSMODULE "attributes"
2009 #define ATTRSMODULE_PM "attributes.pm"
2012 /* Don't force the C<use> if we don't need it. */
2013 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2014 if (svp && *svp != &PL_sv_undef)
2015 NOOP; /* already in %INC */
2017 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2018 newSVpvs(ATTRSMODULE), NULL);
2021 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2022 newSVpvs(ATTRSMODULE),
2024 op_prepend_elem(OP_LIST,
2025 newSVOP(OP_CONST, 0, stashsv),
2026 op_prepend_elem(OP_LIST,
2027 newSVOP(OP_CONST, 0,
2029 dup_attrlist(attrs))));
2035 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2038 OP *pack, *imop, *arg;
2041 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2046 assert(target->op_type == OP_PADSV ||
2047 target->op_type == OP_PADHV ||
2048 target->op_type == OP_PADAV);
2050 /* Ensure that attributes.pm is loaded. */
2051 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2053 /* Need package name for method call. */
2054 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2056 /* Build up the real arg-list. */
2057 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2059 arg = newOP(OP_PADSV, 0);
2060 arg->op_targ = target->op_targ;
2061 arg = op_prepend_elem(OP_LIST,
2062 newSVOP(OP_CONST, 0, stashsv),
2063 op_prepend_elem(OP_LIST,
2064 newUNOP(OP_REFGEN, 0,
2065 op_lvalue(arg, OP_REFGEN)),
2066 dup_attrlist(attrs)));
2068 /* Fake up a method call to import */
2069 meth = newSVpvs_share("import");
2070 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2071 op_append_elem(OP_LIST,
2072 op_prepend_elem(OP_LIST, pack, list(arg)),
2073 newSVOP(OP_METHOD_NAMED, 0, meth)));
2074 imop->op_private |= OPpENTERSUB_NOMOD;
2076 /* Combine the ops. */
2077 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2081 =notfor apidoc apply_attrs_string
2083 Attempts to apply a list of attributes specified by the C<attrstr> and
2084 C<len> arguments to the subroutine identified by the C<cv> argument which
2085 is expected to be associated with the package identified by the C<stashpv>
2086 argument (see L<attributes>). It gets this wrong, though, in that it
2087 does not correctly identify the boundaries of the individual attribute
2088 specifications within C<attrstr>. This is not really intended for the
2089 public API, but has to be listed here for systems such as AIX which
2090 need an explicit export list for symbols. (It's called from XS code
2091 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2092 to respect attribute syntax properly would be welcome.
2098 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2099 const char *attrstr, STRLEN len)
2103 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2106 len = strlen(attrstr);
2110 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2112 const char * const sstr = attrstr;
2113 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2114 attrs = op_append_elem(OP_LIST, attrs,
2115 newSVOP(OP_CONST, 0,
2116 newSVpvn(sstr, attrstr-sstr)));
2120 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2121 newSVpvs(ATTRSMODULE),
2122 NULL, op_prepend_elem(OP_LIST,
2123 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2124 op_prepend_elem(OP_LIST,
2125 newSVOP(OP_CONST, 0,
2126 newRV(MUTABLE_SV(cv))),
2131 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2135 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2137 PERL_ARGS_ASSERT_MY_KID;
2139 if (!o || (PL_parser && PL_parser->error_count))
2143 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2144 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2148 if (type == OP_LIST) {
2150 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2151 my_kid(kid, attrs, imopsp);
2152 } else if (type == OP_UNDEF
2158 } else if (type == OP_RV2SV || /* "our" declaration */
2160 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2161 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2162 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2164 PL_parser->in_my == KEY_our
2166 : PL_parser->in_my == KEY_state ? "state" : "my"));
2168 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2169 PL_parser->in_my = FALSE;
2170 PL_parser->in_my_stash = NULL;
2171 apply_attrs(GvSTASH(gv),
2172 (type == OP_RV2SV ? GvSV(gv) :
2173 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2174 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2177 o->op_private |= OPpOUR_INTRO;
2180 else if (type != OP_PADSV &&
2183 type != OP_PUSHMARK)
2185 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2187 PL_parser->in_my == KEY_our
2189 : PL_parser->in_my == KEY_state ? "state" : "my"));
2192 else if (attrs && type != OP_PUSHMARK) {
2195 PL_parser->in_my = FALSE;
2196 PL_parser->in_my_stash = NULL;
2198 /* check for C<my Dog $spot> when deciding package */
2199 stash = PAD_COMPNAME_TYPE(o->op_targ);
2201 stash = PL_curstash;
2202 apply_attrs_my(stash, o, attrs, imopsp);
2204 o->op_flags |= OPf_MOD;
2205 o->op_private |= OPpLVAL_INTRO;
2207 o->op_private |= OPpPAD_STATE;
2212 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2216 int maybe_scalar = 0;
2218 PERL_ARGS_ASSERT_MY_ATTRS;
2220 /* [perl #17376]: this appears to be premature, and results in code such as
2221 C< our(%x); > executing in list mode rather than void mode */
2223 if (o->op_flags & OPf_PARENS)
2233 o = my_kid(o, attrs, &rops);
2235 if (maybe_scalar && o->op_type == OP_PADSV) {
2236 o = scalar(op_append_list(OP_LIST, rops, o));
2237 o->op_private |= OPpLVAL_INTRO;
2240 /* The listop in rops might have a pushmark at the beginning,
2241 which will mess up list assignment. */
2242 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2243 if (rops->op_type == OP_LIST &&
2244 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2246 OP * const pushmark = lrops->op_first;
2247 lrops->op_first = pushmark->op_sibling;
2250 o = op_append_list(OP_LIST, o, rops);
2253 PL_parser->in_my = FALSE;
2254 PL_parser->in_my_stash = NULL;
2259 Perl_sawparens(pTHX_ OP *o)
2261 PERL_UNUSED_CONTEXT;
2263 o->op_flags |= OPf_PARENS;
2268 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2272 const OPCODE ltype = left->op_type;
2273 const OPCODE rtype = right->op_type;
2275 PERL_ARGS_ASSERT_BIND_MATCH;
2277 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2278 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2280 const char * const desc
2282 rtype == OP_SUBST || rtype == OP_TRANS
2283 || rtype == OP_TRANSR
2285 ? (int)rtype : OP_MATCH];
2286 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2287 ? "@array" : "%hash");
2288 Perl_warner(aTHX_ packWARN(WARN_MISC),
2289 "Applying %s to %s will act on scalar(%s)",
2290 desc, sample, sample);
2293 if (rtype == OP_CONST &&
2294 cSVOPx(right)->op_private & OPpCONST_BARE &&
2295 cSVOPx(right)->op_private & OPpCONST_STRICT)
2297 no_bareword_allowed(right);
2300 /* !~ doesn't make sense with /r, so error on it for now */
2301 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2303 yyerror("Using !~ with s///r doesn't make sense");
2304 if (rtype == OP_TRANSR && type == OP_NOT)
2305 yyerror("Using !~ with tr///r doesn't make sense");
2307 ismatchop = (rtype == OP_MATCH ||
2308 rtype == OP_SUBST ||
2309 rtype == OP_TRANS || rtype == OP_TRANSR)
2310 && !(right->op_flags & OPf_SPECIAL);
2311 if (ismatchop && right->op_private & OPpTARGET_MY) {
2313 right->op_private &= ~OPpTARGET_MY;
2315 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2318 right->op_flags |= OPf_STACKED;
2319 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2320 ! (rtype == OP_TRANS &&
2321 right->op_private & OPpTRANS_IDENTICAL) &&
2322 ! (rtype == OP_SUBST &&
2323 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2324 newleft = op_lvalue(left, rtype);
2327 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2328 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2330 o = op_prepend_elem(rtype, scalar(newleft), right);
2332 return newUNOP(OP_NOT, 0, scalar(o));
2336 return bind_match(type, left,
2337 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2341 Perl_invert(pTHX_ OP *o)
2345 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2349 =for apidoc Amx|OP *|op_scope|OP *o
2351 Wraps up an op tree with some additional ops so that at runtime a dynamic
2352 scope will be created. The original ops run in the new dynamic scope,
2353 and then, provided that they exit normally, the scope will be unwound.
2354 The additional ops used to create and unwind the dynamic scope will
2355 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2356 instead if the ops are simple enough to not need the full dynamic scope
2363 Perl_op_scope(pTHX_ OP *o)
2367 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2368 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2369 o->op_type = OP_LEAVE;
2370 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2372 else if (o->op_type == OP_LINESEQ) {
2374 o->op_type = OP_SCOPE;
2375 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2376 kid = ((LISTOP*)o)->op_first;
2377 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2380 /* The following deals with things like 'do {1 for 1}' */
2381 kid = kid->op_sibling;
2383 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2388 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2394 Perl_block_start(pTHX_ int full)
2397 const int retval = PL_savestack_ix;
2399 pad_block_start(full);
2401 PL_hints &= ~HINT_BLOCK_SCOPE;
2402 SAVECOMPILEWARNINGS();
2403 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2405 CALL_BLOCK_HOOKS(bhk_start, full);
2411 Perl_block_end(pTHX_ I32 floor, OP *seq)
2414 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2415 OP* retval = scalarseq(seq);
2417 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2420 CopHINTS_set(&PL_compiling, PL_hints);
2422 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2425 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2431 =head1 Compile-time scope hooks
2433 =for apidoc Aox||blockhook_register
2435 Register a set of hooks to be called when the Perl lexical scope changes
2436 at compile time. See L<perlguts/"Compile-time scope hooks">.
2442 Perl_blockhook_register(pTHX_ BHK *hk)
2444 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2446 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2453 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2454 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2455 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2458 OP * const o = newOP(OP_PADSV, 0);
2459 o->op_targ = offset;
2465 Perl_newPROG(pTHX_ OP *o)
2469 PERL_ARGS_ASSERT_NEWPROG;
2474 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2475 ((PL_in_eval & EVAL_KEEPERR)
2476 ? OPf_SPECIAL : 0), o);
2477 /* don't use LINKLIST, since PL_eval_root might indirect through
2478 * a rather expensive function call and LINKLIST evaluates its
2479 * argument more than once */
2480 PL_eval_start = op_linklist(PL_eval_root);
2481 PL_eval_root->op_private |= OPpREFCOUNTED;
2482 OpREFCNT_set(PL_eval_root, 1);
2483 PL_eval_root->op_next = 0;
2484 CALL_PEEP(PL_eval_start);
2487 if (o->op_type == OP_STUB) {
2488 PL_comppad_name = 0;
2490 S_op_destroy(aTHX_ o);
2493 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2494 PL_curcop = &PL_compiling;
2495 PL_main_start = LINKLIST(PL_main_root);
2496 PL_main_root->op_private |= OPpREFCOUNTED;
2497 OpREFCNT_set(PL_main_root, 1);
2498 PL_main_root->op_next = 0;
2499 CALL_PEEP(PL_main_start);
2502 /* Register with debugger */
2504 CV * const cv = get_cvs("DB::postponed", 0);
2508 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2510 call_sv(MUTABLE_SV(cv), G_DISCARD);
2517 Perl_localize(pTHX_ OP *o, I32 lex)
2521 PERL_ARGS_ASSERT_LOCALIZE;
2523 if (o->op_flags & OPf_PARENS)
2524 /* [perl #17376]: this appears to be premature, and results in code such as
2525 C< our(%x); > executing in list mode rather than void mode */
2532 if ( PL_parser->bufptr > PL_parser->oldbufptr
2533 && PL_parser->bufptr[-1] == ','
2534 && ckWARN(WARN_PARENTHESIS))
2536 char *s = PL_parser->bufptr;
2539 /* some heuristics to detect a potential error */
2540 while (*s && (strchr(", \t\n", *s)))
2544 if (*s && strchr("@$%*", *s) && *++s
2545 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2548 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2550 while (*s && (strchr(", \t\n", *s)))
2556 if (sigil && (*s == ';' || *s == '=')) {
2557 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2558 "Parentheses missing around \"%s\" list",
2560 ? (PL_parser->in_my == KEY_our
2562 : PL_parser->in_my == KEY_state
2572 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2573 PL_parser->in_my = FALSE;
2574 PL_parser->in_my_stash = NULL;
2579 Perl_jmaybe(pTHX_ OP *o)
2581 PERL_ARGS_ASSERT_JMAYBE;
2583 if (o->op_type == OP_LIST) {
2585 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2586 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2592 S_fold_constants(pTHX_ register OP *o)
2595 register OP * VOL curop;
2597 VOL I32 type = o->op_type;
2602 SV * const oldwarnhook = PL_warnhook;
2603 SV * const olddiehook = PL_diehook;
2607 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2609 if (PL_opargs[type] & OA_RETSCALAR)
2611 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2612 o->op_targ = pad_alloc(type, SVs_PADTMP);
2614 /* integerize op, unless it happens to be C<-foo>.
2615 * XXX should pp_i_negate() do magic string negation instead? */
2616 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2617 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2618 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2620 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2623 if (!(PL_opargs[type] & OA_FOLDCONST))
2628 /* XXX might want a ck_negate() for this */
2629 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2641 /* XXX what about the numeric ops? */
2642 if (PL_hints & HINT_LOCALE)
2647 if (PL_parser && PL_parser->error_count)
2648 goto nope; /* Don't try to run w/ errors */
2650 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2651 const OPCODE type = curop->op_type;
2652 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2654 type != OP_SCALAR &&
2656 type != OP_PUSHMARK)
2662 curop = LINKLIST(o);
2663 old_next = o->op_next;
2667 oldscope = PL_scopestack_ix;
2668 create_eval_scope(G_FAKINGEVAL);
2670 /* Verify that we don't need to save it: */
2671 assert(PL_curcop == &PL_compiling);
2672 StructCopy(&PL_compiling, ¬_compiling, COP);
2673 PL_curcop = ¬_compiling;
2674 /* The above ensures that we run with all the correct hints of the
2675 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2676 assert(IN_PERL_RUNTIME);
2677 PL_warnhook = PERL_WARNHOOK_FATAL;
2684 sv = *(PL_stack_sp--);
2685 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2687 /* Can't simply swipe the SV from the pad, because that relies on
2688 the op being freed "real soon now". Under MAD, this doesn't
2689 happen (see the #ifdef below). */
2692 pad_swipe(o->op_targ, FALSE);
2695 else if (SvTEMP(sv)) { /* grab mortal temp? */
2696 SvREFCNT_inc_simple_void(sv);
2701 /* Something tried to die. Abandon constant folding. */
2702 /* Pretend the error never happened. */
2704 o->op_next = old_next;
2708 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2709 PL_warnhook = oldwarnhook;
2710 PL_diehook = olddiehook;
2711 /* XXX note that this croak may fail as we've already blown away
2712 * the stack - eg any nested evals */
2713 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2716 PL_warnhook = oldwarnhook;
2717 PL_diehook = olddiehook;
2718 PL_curcop = &PL_compiling;
2720 if (PL_scopestack_ix > oldscope)
2721 delete_eval_scope();
2730 if (type == OP_RV2GV)
2731 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2733 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2734 op_getmad(o,newop,'f');
2742 S_gen_constant_list(pTHX_ register OP *o)
2746 const I32 oldtmps_floor = PL_tmps_floor;
2749 if (PL_parser && PL_parser->error_count)
2750 return o; /* Don't attempt to run with errors */
2752 PL_op = curop = LINKLIST(o);
2755 Perl_pp_pushmark(aTHX);
2758 assert (!(curop->op_flags & OPf_SPECIAL));
2759 assert(curop->op_type == OP_RANGE);
2760 Perl_pp_anonlist(aTHX);
2761 PL_tmps_floor = oldtmps_floor;
2763 o->op_type = OP_RV2AV;
2764 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2765 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2766 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2767 o->op_opt = 0; /* needs to be revisited in rpeep() */
2768 curop = ((UNOP*)o)->op_first;
2769 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2771 op_getmad(curop,o,'O');
2780 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2783 if (!o || o->op_type != OP_LIST)
2784 o = newLISTOP(OP_LIST, 0, o, NULL);
2786 o->op_flags &= ~OPf_WANT;
2788 if (!(PL_opargs[type] & OA_MARK))
2789 op_null(cLISTOPo->op_first);
2791 o->op_type = (OPCODE)type;
2792 o->op_ppaddr = PL_ppaddr[type];
2793 o->op_flags |= flags;
2795 o = CHECKOP(type, o);
2796 if (o->op_type != (unsigned)type)
2799 return fold_constants(o);
2803 =head1 Optree Manipulation Functions
2806 /* List constructors */
2809 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2811 Append an item to the list of ops contained directly within a list-type
2812 op, returning the lengthened list. I<first> is the list-type op,
2813 and I<last> is the op to append to the list. I<optype> specifies the
2814 intended opcode for the list. If I<first> is not already a list of the
2815 right type, it will be upgraded into one. If either I<first> or I<last>
2816 is null, the other is returned unchanged.
2822 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2830 if (first->op_type != (unsigned)type
2831 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2833 return newLISTOP(type, 0, first, last);
2836 if (first->op_flags & OPf_KIDS)
2837 ((LISTOP*)first)->op_last->op_sibling = last;
2839 first->op_flags |= OPf_KIDS;
2840 ((LISTOP*)first)->op_first = last;
2842 ((LISTOP*)first)->op_last = last;
2847 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2849 Concatenate the lists of ops contained directly within two list-type ops,
2850 returning the combined list. I<first> and I<last> are the list-type ops
2851 to concatenate. I<optype> specifies the intended opcode for the list.
2852 If either I<first> or I<last> is not already a list of the right type,
2853 it will be upgraded into one. If either I<first> or I<last> is null,
2854 the other is returned unchanged.
2860 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2868 if (first->op_type != (unsigned)type)
2869 return op_prepend_elem(type, first, last);
2871 if (last->op_type != (unsigned)type)
2872 return op_append_elem(type, first, last);
2874 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2875 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2876 first->op_flags |= (last->op_flags & OPf_KIDS);
2879 if (((LISTOP*)last)->op_first && first->op_madprop) {
2880 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2882 while (mp->mad_next)
2884 mp->mad_next = first->op_madprop;
2887 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2890 first->op_madprop = last->op_madprop;
2891 last->op_madprop = 0;
2894 S_op_destroy(aTHX_ last);
2900 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2902 Prepend an item to the list of ops contained directly within a list-type
2903 op, returning the lengthened list. I<first> is the op to prepend to the
2904 list, and I<last> is the list-type op. I<optype> specifies the intended
2905 opcode for the list. If I<last> is not already a list of the right type,
2906 it will be upgraded into one. If either I<first> or I<last> is null,
2907 the other is returned unchanged.
2913 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2921 if (last->op_type == (unsigned)type) {
2922 if (type == OP_LIST) { /* already a PUSHMARK there */
2923 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2924 ((LISTOP*)last)->op_first->op_sibling = first;
2925 if (!(first->op_flags & OPf_PARENS))
2926 last->op_flags &= ~OPf_PARENS;
2929 if (!(last->op_flags & OPf_KIDS)) {
2930 ((LISTOP*)last)->op_last = first;
2931 last->op_flags |= OPf_KIDS;
2933 first->op_sibling = ((LISTOP*)last)->op_first;
2934 ((LISTOP*)last)->op_first = first;
2936 last->op_flags |= OPf_KIDS;
2940 return newLISTOP(type, 0, first, last);
2948 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2951 Newxz(tk, 1, TOKEN);
2952 tk->tk_type = (OPCODE)optype;
2953 tk->tk_type = 12345;
2955 tk->tk_mad = madprop;
2960 Perl_token_free(pTHX_ TOKEN* tk)
2962 PERL_ARGS_ASSERT_TOKEN_FREE;
2964 if (tk->tk_type != 12345)
2966 mad_free(tk->tk_mad);
2971 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2976 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2978 if (tk->tk_type != 12345) {
2979 Perl_warner(aTHX_ packWARN(WARN_MISC),
2980 "Invalid TOKEN object ignored");
2987 /* faked up qw list? */
2989 tm->mad_type == MAD_SV &&
2990 SvPVX((SV *)tm->mad_val)[0] == 'q')
2997 /* pretend constant fold didn't happen? */
2998 if (mp->mad_key == 'f' &&
2999 (o->op_type == OP_CONST ||
3000 o->op_type == OP_GV) )
3002 token_getmad(tk,(OP*)mp->mad_val,slot);
3016 if (mp->mad_key == 'X')
3017 mp->mad_key = slot; /* just change the first one */
3027 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3036 /* pretend constant fold didn't happen? */
3037 if (mp->mad_key == 'f' &&
3038 (o->op_type == OP_CONST ||
3039 o->op_type == OP_GV) )
3041 op_getmad(from,(OP*)mp->mad_val,slot);
3048 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3051 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3057 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3066 /* pretend constant fold didn't happen? */
3067 if (mp->mad_key == 'f' &&
3068 (o->op_type == OP_CONST ||
3069 o->op_type == OP_GV) )
3071 op_getmad(from,(OP*)mp->mad_val,slot);
3078 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3081 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3085 PerlIO_printf(PerlIO_stderr(),
3086 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3092 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3110 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3114 addmad(tm, &(o->op_madprop), slot);
3118 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3139 Perl_newMADsv(pTHX_ char key, SV* sv)
3141 PERL_ARGS_ASSERT_NEWMADSV;
3143 return newMADPROP(key, MAD_SV, sv, 0);
3147 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3149 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3152 mp->mad_vlen = vlen;
3153 mp->mad_type = type;
3155 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3160 Perl_mad_free(pTHX_ MADPROP* mp)
3162 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3166 mad_free(mp->mad_next);
3167 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3168 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3169 switch (mp->mad_type) {
3173 Safefree((char*)mp->mad_val);
3176 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3177 op_free((OP*)mp->mad_val);
3180 sv_free(MUTABLE_SV(mp->mad_val));
3183 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3186 PerlMemShared_free(mp);
3192 =head1 Optree construction
3194 =for apidoc Am|OP *|newNULLLIST
3196 Constructs, checks, and returns a new C<stub> op, which represents an
3197 empty list expression.
3203 Perl_newNULLLIST(pTHX)
3205 return newOP(OP_STUB, 0);
3209 S_force_list(pTHX_ OP *o)
3211 if (!o || o->op_type != OP_LIST)
3212 o = newLISTOP(OP_LIST, 0, o, NULL);
3218 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3220 Constructs, checks, and returns an op of any list type. I<type> is
3221 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3222 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3223 supply up to two ops to be direct children of the list op; they are
3224 consumed by this function and become part of the constructed op tree.
3230 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3235 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3237 NewOp(1101, listop, 1, LISTOP);
3239 listop->op_type = (OPCODE)type;
3240 listop->op_ppaddr = PL_ppaddr[type];
3243 listop->op_flags = (U8)flags;
3247 else if (!first && last)
3250 first->op_sibling = last;
3251 listop->op_first = first;
3252 listop->op_last = last;
3253 if (type == OP_LIST) {
3254 OP* const pushop = newOP(OP_PUSHMARK, 0);
3255 pushop->op_sibling = first;
3256 listop->op_first = pushop;
3257 listop->op_flags |= OPf_KIDS;
3259 listop->op_last = pushop;
3262 return CHECKOP(type, listop);
3266 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3268 Constructs, checks, and returns an op of any base type (any type that
3269 has no extra fields). I<type> is the opcode. I<flags> gives the
3270 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3277 Perl_newOP(pTHX_ I32 type, I32 flags)
3282 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3283 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3284 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3285 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3287 NewOp(1101, o, 1, OP);
3288 o->op_type = (OPCODE)type;
3289 o->op_ppaddr = PL_ppaddr[type];
3290 o->op_flags = (U8)flags;
3292 o->op_latefreed = 0;
3296 o->op_private = (U8)(0 | (flags >> 8));
3297 if (PL_opargs[type] & OA_RETSCALAR)
3299 if (PL_opargs[type] & OA_TARGET)
3300 o->op_targ = pad_alloc(type, SVs_PADTMP);
3301 return CHECKOP(type, o);
3305 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3307 Constructs, checks, and returns an op of any unary type. I<type> is
3308 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3309 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3310 bits, the eight bits of C<op_private>, except that the bit with value 1
3311 is automatically set. I<first> supplies an optional op to be the direct
3312 child of the unary op; it is consumed by this function and become part
3313 of the constructed op tree.
3319 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3324 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3325 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3326 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3327 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3328 || type == OP_SASSIGN
3329 || type == OP_ENTERTRY
3330 || type == OP_NULL );
3333 first = newOP(OP_STUB, 0);
3334 if (PL_opargs[type] & OA_MARK)
3335 first = force_list(first);
3337 NewOp(1101, unop, 1, UNOP);
3338 unop->op_type = (OPCODE)type;
3339 unop->op_ppaddr = PL_ppaddr[type];
3340 unop->op_first = first;
3341 unop->op_flags = (U8)(flags | OPf_KIDS);
3342 unop->op_private = (U8)(1 | (flags >> 8));
3343 unop = (UNOP*) CHECKOP(type, unop);
3347 return fold_constants((OP *) unop);
3351 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3353 Constructs, checks, and returns an op of any binary type. I<type>
3354 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3355 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3356 the eight bits of C<op_private>, except that the bit with value 1 or
3357 2 is automatically set as required. I<first> and I<last> supply up to
3358 two ops to be the direct children of the binary op; they are consumed
3359 by this function and become part of the constructed op tree.
3365 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3370 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3371 || type == OP_SASSIGN || type == OP_NULL );
3373 NewOp(1101, binop, 1, BINOP);
3376 first = newOP(OP_NULL, 0);
3378 binop->op_type = (OPCODE)type;
3379 binop->op_ppaddr = PL_ppaddr[type];
3380 binop->op_first = first;
3381 binop->op_flags = (U8)(flags | OPf_KIDS);
3384 binop->op_private = (U8)(1 | (flags >> 8));
3387 binop->op_private = (U8)(2 | (flags >> 8));
3388 first->op_sibling = last;
3391 binop = (BINOP*)CHECKOP(type, binop);
3392 if (binop->op_next || binop->op_type != (OPCODE)type)
3395 binop->op_last = binop->op_first->op_sibling;
3397 return fold_constants((OP *)binop);
3400 static int uvcompare(const void *a, const void *b)
3401 __attribute__nonnull__(1)
3402 __attribute__nonnull__(2)
3403 __attribute__pure__;
3404 static int uvcompare(const void *a, const void *b)
3406 if (*((const UV *)a) < (*(const UV *)b))
3408 if (*((const UV *)a) > (*(const UV *)b))
3410 if (*((const UV *)a+1) < (*(const UV *)b+1))
3412 if (*((const UV *)a+1) > (*(const UV *)b+1))
3418 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3421 SV * const tstr = ((SVOP*)expr)->op_sv;
3424 (repl->op_type == OP_NULL)
3425 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3427 ((SVOP*)repl)->op_sv;
3430 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3431 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3435 register short *tbl;
3437 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3438 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3439 I32 del = o->op_private & OPpTRANS_DELETE;
3442 PERL_ARGS_ASSERT_PMTRANS;
3444 PL_hints |= HINT_BLOCK_SCOPE;
3447 o->op_private |= OPpTRANS_FROM_UTF;
3450 o->op_private |= OPpTRANS_TO_UTF;
3452 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3453 SV* const listsv = newSVpvs("# comment\n");
3455 const U8* tend = t + tlen;
3456 const U8* rend = r + rlen;
3470 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3471 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3474 const U32 flags = UTF8_ALLOW_DEFAULT;
3478 t = tsave = bytes_to_utf8(t, &len);
3481 if (!to_utf && rlen) {
3483 r = rsave = bytes_to_utf8(r, &len);
3487 /* There are several snags with this code on EBCDIC:
3488 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3489 2. scan_const() in toke.c has encoded chars in native encoding which makes
3490 ranges at least in EBCDIC 0..255 range the bottom odd.
3494 U8 tmpbuf[UTF8_MAXBYTES+1];
3497 Newx(cp, 2*tlen, UV);
3499 transv = newSVpvs("");
3501 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3503 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3505 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3509 cp[2*i+1] = cp[2*i];
3513 qsort(cp, i, 2*sizeof(UV), uvcompare);
3514 for (j = 0; j < i; j++) {
3516 diff = val - nextmin;
3518 t = uvuni_to_utf8(tmpbuf,nextmin);
3519 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3521 U8 range_mark = UTF_TO_NATIVE(0xff);
3522 t = uvuni_to_utf8(tmpbuf, val - 1);
3523 sv_catpvn(transv, (char *)&range_mark, 1);
3524 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3531 t = uvuni_to_utf8(tmpbuf,nextmin);
3532 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3534 U8 range_mark = UTF_TO_NATIVE(0xff);
3535 sv_catpvn(transv, (char *)&range_mark, 1);
3537 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3538 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3539 t = (const U8*)SvPVX_const(transv);
3540 tlen = SvCUR(transv);
3544 else if (!rlen && !del) {
3545 r = t; rlen = tlen; rend = tend;
3548 if ((!rlen && !del) || t == r ||
3549 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3551 o->op_private |= OPpTRANS_IDENTICAL;
3555 while (t < tend || tfirst <= tlast) {
3556 /* see if we need more "t" chars */
3557 if (tfirst > tlast) {
3558 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3560 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3562 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3569 /* now see if we need more "r" chars */
3570 if (rfirst > rlast) {
3572 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3574 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3576 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3585 rfirst = rlast = 0xffffffff;
3589 /* now see which range will peter our first, if either. */
3590 tdiff = tlast - tfirst;
3591 rdiff = rlast - rfirst;
3598 if (rfirst == 0xffffffff) {
3599 diff = tdiff; /* oops, pretend rdiff is infinite */
3601 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3602 (long)tfirst, (long)tlast);
3604 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3608 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3609 (long)tfirst, (long)(tfirst + diff),
3612 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3613 (long)tfirst, (long)rfirst);
3615 if (rfirst + diff > max)
3616 max = rfirst + diff;
3618 grows = (tfirst < rfirst &&
3619 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3631 else if (max > 0xff)
3636 PerlMemShared_free(cPVOPo->op_pv);
3637 cPVOPo->op_pv = NULL;
3639 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3641 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3642 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3643 PAD_SETSV(cPADOPo->op_padix, swash);
3645 SvREADONLY_on(swash);
3647 cSVOPo->op_sv = swash;
3649 SvREFCNT_dec(listsv);
3650 SvREFCNT_dec(transv);
3652 if (!del && havefinal && rlen)
3653 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3654 newSVuv((UV)final), 0);
3657 o->op_private |= OPpTRANS_GROWS;
3663 op_getmad(expr,o,'e');
3664 op_getmad(repl,o,'r');
3672 tbl = (short*)cPVOPo->op_pv;
3674 Zero(tbl, 256, short);
3675 for (i = 0; i < (I32)tlen; i++)
3677 for (i = 0, j = 0; i < 256; i++) {
3679 if (j >= (I32)rlen) {
3688 if (i < 128 && r[j] >= 128)
3698 o->op_private |= OPpTRANS_IDENTICAL;
3700 else if (j >= (I32)rlen)
3705 PerlMemShared_realloc(tbl,
3706 (0x101+rlen-j) * sizeof(short));
3707 cPVOPo->op_pv = (char*)tbl;
3709 tbl[0x100] = (short)(rlen - j);
3710 for (i=0; i < (I32)rlen - j; i++)
3711 tbl[0x101+i] = r[j+i];
3715 if (!rlen && !del) {
3718 o->op_private |= OPpTRANS_IDENTICAL;
3720 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3721 o->op_private |= OPpTRANS_IDENTICAL;
3723 for (i = 0; i < 256; i++)
3725 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3726 if (j >= (I32)rlen) {
3728 if (tbl[t[i]] == -1)
3734 if (tbl[t[i]] == -1) {
3735 if (t[i] < 128 && r[j] >= 128)
3742 if(del && rlen == tlen) {
3743 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3744 } else if(rlen > tlen) {
3745 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3749 o->op_private |= OPpTRANS_GROWS;
3751 op_getmad(expr,o,'e');
3752 op_getmad(repl,o,'r');
3762 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3764 Constructs, checks, and returns an op of any pattern matching type.
3765 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3766 and, shifted up eight bits, the eight bits of C<op_private>.
3772 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3777 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3779 NewOp(1101, pmop, 1, PMOP);
3780 pmop->op_type = (OPCODE)type;
3781 pmop->op_ppaddr = PL_ppaddr[type];
3782 pmop->op_flags = (U8)flags;
3783 pmop->op_private = (U8)(0 | (flags >> 8));
3785 if (PL_hints & HINT_RE_TAINT)
3786 pmop->op_pmflags |= PMf_RETAINT;
3787 if (PL_hints & HINT_LOCALE) {
3788 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
3790 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3791 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
3793 if (PL_hints & HINT_RE_FLAGS) {
3794 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3795 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3797 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3798 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3799 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
3801 if (reflags && SvOK(reflags)) {
3802 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
3808 assert(SvPOK(PL_regex_pad[0]));
3809 if (SvCUR(PL_regex_pad[0])) {
3810 /* Pop off the "packed" IV from the end. */
3811 SV *const repointer_list = PL_regex_pad[0];
3812 const char *p = SvEND(repointer_list) - sizeof(IV);
3813 const IV offset = *((IV*)p);
3815 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3817 SvEND_set(repointer_list, p);
3819 pmop->op_pmoffset = offset;
3820 /* This slot should be free, so assert this: */
3821 assert(PL_regex_pad[offset] == &PL_sv_undef);
3823 SV * const repointer = &PL_sv_undef;
3824 av_push(PL_regex_padav, repointer);
3825 pmop->op_pmoffset = av_len(PL_regex_padav);
3826 PL_regex_pad = AvARRAY(PL_regex_padav);
3830 return CHECKOP(type, pmop);
3833 /* Given some sort of match op o, and an expression expr containing a
3834 * pattern, either compile expr into a regex and attach it to o (if it's
3835 * constant), or convert expr into a runtime regcomp op sequence (if it's
3838 * isreg indicates that the pattern is part of a regex construct, eg
3839 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3840 * split "pattern", which aren't. In the former case, expr will be a list
3841 * if the pattern contains more than one term (eg /a$b/) or if it contains
3842 * a replacement, ie s/// or tr///.
3846 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3851 I32 repl_has_vars = 0;
3855 PERL_ARGS_ASSERT_PMRUNTIME;
3858 o->op_type == OP_SUBST
3859 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
3861 /* last element in list is the replacement; pop it */
3863 repl = cLISTOPx(expr)->op_last;
3864 kid = cLISTOPx(expr)->op_first;
3865 while (kid->op_sibling != repl)
3866 kid = kid->op_sibling;
3867 kid->op_sibling = NULL;
3868 cLISTOPx(expr)->op_last = kid;
3871 if (isreg && expr->op_type == OP_LIST &&
3872 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3874 /* convert single element list to element */
3875 OP* const oe = expr;
3876 expr = cLISTOPx(oe)->op_first->op_sibling;
3877 cLISTOPx(oe)->op_first->op_sibling = NULL;
3878 cLISTOPx(oe)->op_last = NULL;
3882 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
3883 return pmtrans(o, expr, repl);
3886 reglist = isreg && expr->op_type == OP_LIST;
3890 PL_hints |= HINT_BLOCK_SCOPE;
3893 if (expr->op_type == OP_CONST) {
3894 SV *pat = ((SVOP*)expr)->op_sv;
3895 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
3897 if (o->op_flags & OPf_SPECIAL)
3898 pm_flags |= RXf_SPLIT;
3901 assert (SvUTF8(pat));
3902 } else if (SvUTF8(pat)) {
3903 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3904 trapped in use 'bytes'? */
3905 /* Make a copy of the octet sequence, but without the flag on, as
3906 the compiler now honours the SvUTF8 flag on pat. */
3908 const char *const p = SvPV(pat, len);
3909 pat = newSVpvn_flags(p, len, SVs_TEMP);
3912 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3915 op_getmad(expr,(OP*)pm,'e');
3921 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3922 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3924 : OP_REGCMAYBE),0,expr);
3926 NewOp(1101, rcop, 1, LOGOP);
3927 rcop->op_type = OP_REGCOMP;
3928 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3929 rcop->op_first = scalar(expr);
3930 rcop->op_flags |= OPf_KIDS
3931 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3932 | (reglist ? OPf_STACKED : 0);
3933 rcop->op_private = 1;
3936 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3938 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3939 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
3941 /* establish postfix order */
3942 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3944 rcop->op_next = expr;
3945 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3948 rcop->op_next = LINKLIST(expr);
3949 expr->op_next = (OP*)rcop;
3952 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3957 if (pm->op_pmflags & PMf_EVAL) {
3959 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3960 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3962 else if (repl->op_type == OP_CONST)
3966 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3967 if (curop->op_type == OP_SCOPE
3968 || curop->op_type == OP_LEAVE
3969 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3970 if (curop->op_type == OP_GV) {
3971 GV * const gv = cGVOPx_gv(curop);
3973 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3976 else if (curop->op_type == OP_RV2CV)
3978 else if (curop->op_type == OP_RV2SV ||
3979 curop->op_type == OP_RV2AV ||
3980 curop->op_type == OP_RV2HV ||
3981 curop->op_type == OP_RV2GV) {
3982 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3985 else if (curop->op_type == OP_PADSV ||
3986 curop->op_type == OP_PADAV ||
3987 curop->op_type == OP_PADHV ||
3988 curop->op_type == OP_PADANY)
3992 else if (curop->op_type == OP_PUSHRE)
3993 NOOP; /* Okay here, dangerous in newASSIGNOP */
4003 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4005 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4006 op_prepend_elem(o->op_type, scalar(repl), o);
4009 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4010 pm->op_pmflags |= PMf_MAYBE_CONST;
4012 NewOp(1101, rcop, 1, LOGOP);
4013 rcop->op_type = OP_SUBSTCONT;
4014 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4015 rcop->op_first = scalar(repl);
4016 rcop->op_flags |= OPf_KIDS;
4017 rcop->op_private = 1;
4020 /* establish postfix order */
4021 rcop->op_next = LINKLIST(repl);
4022 repl->op_next = (OP*)rcop;
4024 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4025 assert(!(pm->op_pmflags & PMf_ONCE));
4026 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4035 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4037 Constructs, checks, and returns an op of any type that involves an
4038 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4039 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4040 takes ownership of one reference to it.
4046 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4051 PERL_ARGS_ASSERT_NEWSVOP;
4053 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4054 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4055 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4057 NewOp(1101, svop, 1, SVOP);
4058 svop->op_type = (OPCODE)type;
4059 svop->op_ppaddr = PL_ppaddr[type];
4061 svop->op_next = (OP*)svop;
4062 svop->op_flags = (U8)flags;
4063 if (PL_opargs[type] & OA_RETSCALAR)
4065 if (PL_opargs[type] & OA_TARGET)
4066 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4067 return CHECKOP(type, svop);
4073 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4075 Constructs, checks, and returns an op of any type that involves a
4076 reference to a pad element. I<type> is the opcode. I<flags> gives the
4077 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4078 is populated with I<sv>; this function takes ownership of one reference
4081 This function only exists if Perl has been compiled to use ithreads.
4087 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4092 PERL_ARGS_ASSERT_NEWPADOP;
4094 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4095 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4096 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4098 NewOp(1101, padop, 1, PADOP);
4099 padop->op_type = (OPCODE)type;
4100 padop->op_ppaddr = PL_ppaddr[type];
4101 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4102 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4103 PAD_SETSV(padop->op_padix, sv);
4106 padop->op_next = (OP*)padop;
4107 padop->op_flags = (U8)flags;
4108 if (PL_opargs[type] & OA_RETSCALAR)
4110 if (PL_opargs[type] & OA_TARGET)
4111 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4112 return CHECKOP(type, padop);
4115 #endif /* !USE_ITHREADS */
4118 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4120 Constructs, checks, and returns an op of any type that involves an
4121 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4122 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4123 reference; calling this function does not transfer ownership of any
4130 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4134 PERL_ARGS_ASSERT_NEWGVOP;
4138 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4140 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4145 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4147 Constructs, checks, and returns an op of any type that involves an
4148 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4149 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4150 must have been allocated using L</PerlMemShared_malloc>; the memory will
4151 be freed when the op is destroyed.
4157 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4162 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4163 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4165 NewOp(1101, pvop, 1, PVOP);
4166 pvop->op_type = (OPCODE)type;
4167 pvop->op_ppaddr = PL_ppaddr[type];
4169 pvop->op_next = (OP*)pvop;
4170 pvop->op_flags = (U8)flags;
4171 if (PL_opargs[type] & OA_RETSCALAR)
4173 if (PL_opargs[type] & OA_TARGET)
4174 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4175 return CHECKOP(type, pvop);
4183 Perl_package(pTHX_ OP *o)
4186 SV *const sv = cSVOPo->op_sv;
4191 PERL_ARGS_ASSERT_PACKAGE;
4193 save_hptr(&PL_curstash);
4194 save_item(PL_curstname);
4196 PL_curstash = gv_stashsv(sv, GV_ADD);
4198 sv_setsv(PL_curstname, sv);
4200 PL_hints |= HINT_BLOCK_SCOPE;
4201 PL_parser->copline = NOLINE;
4202 PL_parser->expect = XSTATE;
4207 if (!PL_madskills) {
4212 pegop = newOP(OP_NULL,0);
4213 op_getmad(o,pegop,'P');
4219 Perl_package_version( pTHX_ OP *v )
4222 U32 savehints = PL_hints;
4223 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4224 PL_hints &= ~HINT_STRICT_VARS;
4225 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4226 PL_hints = savehints;
4235 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4242 OP *pegop = newOP(OP_NULL,0);
4244 SV *use_version = NULL;
4246 PERL_ARGS_ASSERT_UTILIZE;
4248 if (idop->op_type != OP_CONST)
4249 Perl_croak(aTHX_ "Module name must be constant");
4252 op_getmad(idop,pegop,'U');
4257 SV * const vesv = ((SVOP*)version)->op_sv;
4260 op_getmad(version,pegop,'V');
4261 if (!arg && !SvNIOKp(vesv)) {
4268 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4269 Perl_croak(aTHX_ "Version number must be a constant number");
4271 /* Make copy of idop so we don't free it twice */
4272 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4274 /* Fake up a method call to VERSION */
4275 meth = newSVpvs_share("VERSION");
4276 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4277 op_append_elem(OP_LIST,
4278 op_prepend_elem(OP_LIST, pack, list(version)),
4279 newSVOP(OP_METHOD_NAMED, 0, meth)));
4283 /* Fake up an import/unimport */
4284 if (arg && arg->op_type == OP_STUB) {
4286 op_getmad(arg,pegop,'S');
4287 imop = arg; /* no import on explicit () */
4289 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4290 imop = NULL; /* use 5.0; */
4292 use_version = ((SVOP*)idop)->op_sv;
4294 idop->op_private |= OPpCONST_NOVER;
4300 op_getmad(arg,pegop,'A');
4302 /* Make copy of idop so we don't free it twice */
4303 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4305 /* Fake up a method call to import/unimport */
4307 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4308 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4309 op_append_elem(OP_LIST,
4310 op_prepend_elem(OP_LIST, pack, list(arg)),
4311 newSVOP(OP_METHOD_NAMED, 0, meth)));
4314 /* Fake up the BEGIN {}, which does its thing immediately. */
4316 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4319 op_append_elem(OP_LINESEQ,
4320 op_append_elem(OP_LINESEQ,
4321 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4322 newSTATEOP(0, NULL, veop)),
4323 newSTATEOP(0, NULL, imop) ));
4326 /* If we request a version >= 5.9.5, load feature.pm with the
4327 * feature bundle that corresponds to the required version. */
4328 use_version = sv_2mortal(new_version(use_version));
4330 if (vcmp(use_version,
4331 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4332 SV *const importsv = vnormal(use_version);
4333 *SvPVX_mutable(importsv) = ':';
4334 ENTER_with_name("load_feature");
4335 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4336 LEAVE_with_name("load_feature");
4338 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4339 if (vcmp(use_version,
4340 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4341 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4345 /* The "did you use incorrect case?" warning used to be here.
4346 * The problem is that on case-insensitive filesystems one
4347 * might get false positives for "use" (and "require"):
4348 * "use Strict" or "require CARP" will work. This causes
4349 * portability problems for the script: in case-strict
4350 * filesystems the script will stop working.
4352 * The "incorrect case" warning checked whether "use Foo"
4353 * imported "Foo" to your namespace, but that is wrong, too:
4354 * there is no requirement nor promise in the language that
4355 * a Foo.pm should or would contain anything in package "Foo".
4357 * There is very little Configure-wise that can be done, either:
4358 * the case-sensitivity of the build filesystem of Perl does not
4359 * help in guessing the case-sensitivity of the runtime environment.
4362 PL_hints |= HINT_BLOCK_SCOPE;
4363 PL_parser->copline = NOLINE;
4364 PL_parser->expect = XSTATE;
4365 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4366 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4370 if (!PL_madskills) {
4371 /* FIXME - don't allocate pegop if !PL_madskills */
4380 =head1 Embedding Functions
4382 =for apidoc load_module
4384 Loads the module whose name is pointed to by the string part of name.
4385 Note that the actual module name, not its filename, should be given.
4386 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4387 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4388 (or 0 for no flags). ver, if specified, provides version semantics
4389 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4390 arguments can be used to specify arguments to the module's import()
4391 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4392 terminated with a final NULL pointer. Note that this list can only
4393 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4394 Otherwise at least a single NULL pointer to designate the default
4395 import list is required.
4400 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4404 PERL_ARGS_ASSERT_LOAD_MODULE;
4406 va_start(args, ver);
4407 vload_module(flags, name, ver, &args);
4411 #ifdef PERL_IMPLICIT_CONTEXT
4413 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4417 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4418 va_start(args, ver);
4419 vload_module(flags, name, ver, &args);
4425 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4429 OP * const modname = newSVOP(OP_CONST, 0, name);
4431 PERL_ARGS_ASSERT_VLOAD_MODULE;
4433 modname->op_private |= OPpCONST_BARE;
4435 veop = newSVOP(OP_CONST, 0, ver);
4439 if (flags & PERL_LOADMOD_NOIMPORT) {
4440 imop = sawparens(newNULLLIST());
4442 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4443 imop = va_arg(*args, OP*);
4448 sv = va_arg(*args, SV*);
4450 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4451 sv = va_arg(*args, SV*);
4455 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4456 * that it has a PL_parser to play with while doing that, and also
4457 * that it doesn't mess with any existing parser, by creating a tmp
4458 * new parser with lex_start(). This won't actually be used for much,
4459 * since pp_require() will create another parser for the real work. */
4462 SAVEVPTR(PL_curcop);
4463 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4464 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4465 veop, modname, imop);
4470 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4476 PERL_ARGS_ASSERT_DOFILE;
4478 if (!force_builtin) {
4479 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4480 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4481 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4482 gv = gvp ? *gvp : NULL;
4486 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4487 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4488 op_append_elem(OP_LIST, term,
4489 scalar(newUNOP(OP_RV2CV, 0,
4490 newGVOP(OP_GV, 0, gv))))));
4493 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4499 =head1 Optree construction
4501 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4503 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4504 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4505 be set automatically, and, shifted up eight bits, the eight bits of
4506 C<op_private>, except that the bit with value 1 or 2 is automatically
4507 set as required. I<listval> and I<subscript> supply the parameters of
4508 the slice; they are consumed by this function and become part of the
4509 constructed op tree.
4515 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4517 return newBINOP(OP_LSLICE, flags,
4518 list(force_list(subscript)),
4519 list(force_list(listval)) );
4523 S_is_list_assignment(pTHX_ register const OP *o)
4531 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4532 o = cUNOPo->op_first;
4534 flags = o->op_flags;
4536 if (type == OP_COND_EXPR) {
4537 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4538 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4543 yyerror("Assignment to both a list and a scalar");
4547 if (type == OP_LIST &&
4548 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4549 o->op_private & OPpLVAL_INTRO)
4552 if (type == OP_LIST || flags & OPf_PARENS ||
4553 type == OP_RV2AV || type == OP_RV2HV ||
4554 type == OP_ASLICE || type == OP_HSLICE)
4557 if (type == OP_PADAV || type == OP_PADHV)
4560 if (type == OP_RV2SV)
4567 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4569 Constructs, checks, and returns an assignment op. I<left> and I<right>
4570 supply the parameters of the assignment; they are consumed by this
4571 function and become part of the constructed op tree.
4573 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4574 a suitable conditional optree is constructed. If I<optype> is the opcode
4575 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4576 performs the binary operation and assigns the result to the left argument.
4577 Either way, if I<optype> is non-zero then I<flags> has no effect.
4579 If I<optype> is zero, then a plain scalar or list assignment is
4580 constructed. Which type of assignment it is is automatically determined.
4581 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4582 will be set automatically, and, shifted up eight bits, the eight bits
4583 of C<op_private>, except that the bit with value 1 or 2 is automatically
4590 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4596 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4597 return newLOGOP(optype, 0,
4598 op_lvalue(scalar(left), optype),
4599 newUNOP(OP_SASSIGN, 0, scalar(right)));
4602 return newBINOP(optype, OPf_STACKED,
4603 op_lvalue(scalar(left), optype), scalar(right));
4607 if (is_list_assignment(left)) {
4608 static const char no_list_state[] = "Initialization of state variables"
4609 " in list context currently forbidden";
4611 bool maybe_common_vars = TRUE;
4614 /* Grandfathering $[ assignment here. Bletch.*/
4615 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4616 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4617 left = op_lvalue(left, OP_AASSIGN);
4620 else if (left->op_type == OP_CONST) {
4621 deprecate("assignment to $[");
4623 /* Result of assignment is always 1 (or we'd be dead already) */
4624 return newSVOP(OP_CONST, 0, newSViv(1));
4626 curop = list(force_list(left));
4627 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4628 o->op_private = (U8)(0 | (flags >> 8));
4630 if ((left->op_type == OP_LIST
4631 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4633 OP* lop = ((LISTOP*)left)->op_first;
4634 maybe_common_vars = FALSE;
4636 if (lop->op_type == OP_PADSV ||
4637 lop->op_type == OP_PADAV ||
4638 lop->op_type == OP_PADHV ||
4639 lop->op_type == OP_PADANY) {
4640 if (!(lop->op_private & OPpLVAL_INTRO))
4641 maybe_common_vars = TRUE;
4643 if (lop->op_private & OPpPAD_STATE) {
4644 if (left->op_private & OPpLVAL_INTRO) {
4645 /* Each variable in state($a, $b, $c) = ... */
4648 /* Each state variable in
4649 (state $a, my $b, our $c, $d, undef) = ... */
4651 yyerror(no_list_state);
4653 /* Each my variable in
4654 (state $a, my $b, our $c, $d, undef) = ... */
4656 } else if (lop->op_type == OP_UNDEF ||
4657 lop->op_type == OP_PUSHMARK) {
4658 /* undef may be interesting in
4659 (state $a, undef, state $c) */
4661 /* Other ops in the list. */
4662 maybe_common_vars = TRUE;
4664 lop = lop->op_sibling;
4667 else if ((left->op_private & OPpLVAL_INTRO)
4668 && ( left->op_type == OP_PADSV
4669 || left->op_type == OP_PADAV
4670 || left->op_type == OP_PADHV
4671 || left->op_type == OP_PADANY))
4673 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4674 if (left->op_private & OPpPAD_STATE) {
4675 /* All single variable list context state assignments, hence
4685 yyerror(no_list_state);
4689 /* PL_generation sorcery:
4690 * an assignment like ($a,$b) = ($c,$d) is easier than
4691 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4692 * To detect whether there are common vars, the global var
4693 * PL_generation is incremented for each assign op we compile.
4694 * Then, while compiling the assign op, we run through all the
4695 * variables on both sides of the assignment, setting a spare slot
4696 * in each of them to PL_generation. If any of them already have
4697 * that value, we know we've got commonality. We could use a
4698 * single bit marker, but then we'd have to make 2 passes, first
4699 * to clear the flag, then to test and set it. To find somewhere
4700 * to store these values, evil chicanery is done with SvUVX().
4703 if (maybe_common_vars) {
4706 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4707 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4708 if (curop->op_type == OP_GV) {
4709 GV *gv = cGVOPx_gv(curop);
4711 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4713 GvASSIGN_GENERATION_set(gv, PL_generation);
4715 else if (curop->op_type == OP_PADSV ||
4716 curop->op_type == OP_PADAV ||
4717 curop->op_type == OP_PADHV ||
4718 curop->op_type == OP_PADANY)
4720 if (PAD_COMPNAME_GEN(curop->op_targ)
4721 == (STRLEN)PL_generation)
4723 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4726 else if (curop->op_type == OP_RV2CV)
4728 else if (curop->op_type == OP_RV2SV ||
4729 curop->op_type == OP_RV2AV ||
4730 curop->op_type == OP_RV2HV ||
4731 curop->op_type == OP_RV2GV) {
4732 if (lastop->op_type != OP_GV) /* funny deref? */
4735 else if (curop->op_type == OP_PUSHRE) {
4737 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4738 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4740 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4742 GvASSIGN_GENERATION_set(gv, PL_generation);
4746 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4749 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4751 GvASSIGN_GENERATION_set(gv, PL_generation);
4761 o->op_private |= OPpASSIGN_COMMON;
4764 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4765 OP* tmpop = ((LISTOP*)right)->op_first;
4766 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4767 PMOP * const pm = (PMOP*)tmpop;
4768 if (left->op_type == OP_RV2AV &&
4769 !(left->op_private & OPpLVAL_INTRO) &&
4770 !(o->op_private & OPpASSIGN_COMMON) )
4772 tmpop = ((UNOP*)left)->op_first;
4773 if (tmpop->op_type == OP_GV
4775 && !pm->op_pmreplrootu.op_pmtargetoff
4777 && !pm->op_pmreplrootu.op_pmtargetgv
4781 pm->op_pmreplrootu.op_pmtargetoff
4782 = cPADOPx(tmpop)->op_padix;
4783 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4785 pm->op_pmreplrootu.op_pmtargetgv
4786 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4787 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4789 pm->op_pmflags |= PMf_ONCE;
4790 tmpop = cUNOPo->op_first; /* to list (nulled) */
4791 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4792 tmpop->op_sibling = NULL; /* don't free split */
4793 right->op_next = tmpop->op_next; /* fix starting loc */
4794 op_free(o); /* blow off assign */
4795 right->op_flags &= ~OPf_WANT;
4796 /* "I don't know and I don't care." */
4801 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4802 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4804 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4805 if (SvIOK(sv) && SvIVX(sv) == 0)
4806 sv_setiv(sv, PL_modcount+1);
4814 right = newOP(OP_UNDEF, 0);
4815 if (right->op_type == OP_READLINE) {
4816 right->op_flags |= OPf_STACKED;
4817 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
4821 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4822 o = newBINOP(OP_SASSIGN, flags,
4823 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
4827 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4828 deprecate("assignment to $[");
4830 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4831 o->op_private |= OPpCONST_ARYBASE;
4839 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4841 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4842 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4843 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4844 If I<label> is non-null, it supplies the name of a label to attach to
4845 the state op; this function takes ownership of the memory pointed at by
4846 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4849 If I<o> is null, the state op is returned. Otherwise the state op is
4850 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4851 is consumed by this function and becomes part of the returned op tree.
4857 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4860 const U32 seq = intro_my();
4863 NewOp(1101, cop, 1, COP);
4864 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4865 cop->op_type = OP_DBSTATE;
4866 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4869 cop->op_type = OP_NEXTSTATE;
4870 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4872 cop->op_flags = (U8)flags;
4873 CopHINTS_set(cop, PL_hints);
4875 cop->op_private |= NATIVE_HINTS;
4877 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4878 cop->op_next = (OP*)cop;
4881 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4882 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4884 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4885 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4887 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4889 PL_hints |= HINT_BLOCK_SCOPE;
4890 /* It seems that we need to defer freeing this pointer, as other parts
4891 of the grammar end up wanting to copy it after this op has been
4896 if (PL_parser && PL_parser->copline == NOLINE)
4897 CopLINE_set(cop, CopLINE(PL_curcop));
4899 CopLINE_set(cop, PL_parser->copline);
4901 PL_parser->copline = NOLINE;
4904 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4906 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4908 CopSTASH_set(cop, PL_curstash);
4910 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4911 /* this line can have a breakpoint - store the cop in IV */
4912 AV *av = CopFILEAVx(PL_curcop);
4914 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4915 if (svp && *svp != &PL_sv_undef ) {
4916 (void)SvIOK_on(*svp);
4917 SvIV_set(*svp, PTR2IV(cop));
4922 if (flags & OPf_SPECIAL)
4924 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4928 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4930 Constructs, checks, and returns a logical (flow control) op. I<type>
4931 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4932 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4933 the eight bits of C<op_private>, except that the bit with value 1 is
4934 automatically set. I<first> supplies the expression controlling the
4935 flow, and I<other> supplies the side (alternate) chain of ops; they are
4936 consumed by this function and become part of the constructed op tree.
4942 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4946 PERL_ARGS_ASSERT_NEWLOGOP;
4948 return new_logop(type, flags, &first, &other);
4952 S_search_const(pTHX_ OP *o)
4954 PERL_ARGS_ASSERT_SEARCH_CONST;
4956 switch (o->op_type) {
4960 if (o->op_flags & OPf_KIDS)
4961 return search_const(cUNOPo->op_first);
4968 if (!(o->op_flags & OPf_KIDS))
4970 kid = cLISTOPo->op_first;
4972 switch (kid->op_type) {
4976 kid = kid->op_sibling;
4979 if (kid != cLISTOPo->op_last)
4985 kid = cLISTOPo->op_last;
4987 return search_const(kid);
4995 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5003 int prepend_not = 0;
5005 PERL_ARGS_ASSERT_NEW_LOGOP;
5010 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5011 return newBINOP(type, flags, scalar(first), scalar(other));
5013 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5015 scalarboolean(first);
5016 /* optimize AND and OR ops that have NOTs as children */
5017 if (first->op_type == OP_NOT
5018 && (first->op_flags & OPf_KIDS)
5019 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5020 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5022 if (type == OP_AND || type == OP_OR) {
5028 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5030 prepend_not = 1; /* prepend a NOT op later */
5034 /* search for a constant op that could let us fold the test */
5035 if ((cstop = search_const(first))) {
5036 if (cstop->op_private & OPpCONST_STRICT)
5037 no_bareword_allowed(cstop);
5038 else if ((cstop->op_private & OPpCONST_BARE))
5039 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5040 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5041 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5042 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5044 if (other->op_type == OP_CONST)
5045 other->op_private |= OPpCONST_SHORTCIRCUIT;
5047 OP *newop = newUNOP(OP_NULL, 0, other);
5048 op_getmad(first, newop, '1');
5049 newop->op_targ = type; /* set "was" field */
5053 if (other->op_type == OP_LEAVE)
5054 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5055 else if (other->op_type == OP_MATCH
5056 || other->op_type == OP_SUBST
5057 || other->op_type == OP_TRANSR
5058 || other->op_type == OP_TRANS)
5059 /* Mark the op as being unbindable with =~ */
5060 other->op_flags |= OPf_SPECIAL;
5064 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5065 const OP *o2 = other;
5066 if ( ! (o2->op_type == OP_LIST
5067 && (( o2 = cUNOPx(o2)->op_first))
5068 && o2->op_type == OP_PUSHMARK
5069 && (( o2 = o2->op_sibling)) )
5072 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5073 || o2->op_type == OP_PADHV)
5074 && o2->op_private & OPpLVAL_INTRO
5075 && !(o2->op_private & OPpPAD_STATE))
5077 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5078 "Deprecated use of my() in false conditional");
5082 if (first->op_type == OP_CONST)
5083 first->op_private |= OPpCONST_SHORTCIRCUIT;
5085 first = newUNOP(OP_NULL, 0, first);
5086 op_getmad(other, first, '2');
5087 first->op_targ = type; /* set "was" field */
5094 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5095 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5097 const OP * const k1 = ((UNOP*)first)->op_first;
5098 const OP * const k2 = k1->op_sibling;
5100 switch (first->op_type)
5103 if (k2 && k2->op_type == OP_READLINE
5104 && (k2->op_flags & OPf_STACKED)
5105 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5107 warnop = k2->op_type;
5112 if (k1->op_type == OP_READDIR
5113 || k1->op_type == OP_GLOB
5114 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5115 || k1->op_type == OP_EACH
5116 || k1->op_type == OP_AEACH)
5118 warnop = ((k1->op_type == OP_NULL)
5119 ? (OPCODE)k1->op_targ : k1->op_type);
5124 const line_t oldline = CopLINE(PL_curcop);
5125 CopLINE_set(PL_curcop, PL_parser->copline);
5126 Perl_warner(aTHX_ packWARN(WARN_MISC),
5127 "Value of %s%s can be \"0\"; test with defined()",
5129 ((warnop == OP_READLINE || warnop == OP_GLOB)
5130 ? " construct" : "() operator"));
5131 CopLINE_set(PL_curcop, oldline);
5138 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5139 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5141 NewOp(1101, logop, 1, LOGOP);
5143 logop->op_type = (OPCODE)type;
5144 logop->op_ppaddr = PL_ppaddr[type];
5145 logop->op_first = first;
5146 logop->op_flags = (U8)(flags | OPf_KIDS);
5147 logop->op_other = LINKLIST(other);
5148 logop->op_private = (U8)(1 | (flags >> 8));
5150 /* establish postfix order */
5151 logop->op_next = LINKLIST(first);
5152 first->op_next = (OP*)logop;
5153 first->op_sibling = other;
5155 CHECKOP(type,logop);
5157 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5164 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5166 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5167 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5168 will be set automatically, and, shifted up eight bits, the eight bits of
5169 C<op_private>, except that the bit with value 1 is automatically set.
5170 I<first> supplies the expression selecting between the two branches,
5171 and I<trueop> and I<falseop> supply the branches; they are consumed by
5172 this function and become part of the constructed op tree.
5178 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5186 PERL_ARGS_ASSERT_NEWCONDOP;
5189 return newLOGOP(OP_AND, 0, first, trueop);
5191 return newLOGOP(OP_OR, 0, first, falseop);
5193 scalarboolean(first);
5194 if ((cstop = search_const(first))) {
5195 /* Left or right arm of the conditional? */
5196 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5197 OP *live = left ? trueop : falseop;
5198 OP *const dead = left ? falseop : trueop;
5199 if (cstop->op_private & OPpCONST_BARE &&
5200 cstop->op_private & OPpCONST_STRICT) {
5201 no_bareword_allowed(cstop);
5204 /* This is all dead code when PERL_MAD is not defined. */
5205 live = newUNOP(OP_NULL, 0, live);
5206 op_getmad(first, live, 'C');
5207 op_getmad(dead, live, left ? 'e' : 't');
5212 if (live->op_type == OP_LEAVE)
5213 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5214 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5215 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5216 /* Mark the op as being unbindable with =~ */
5217 live->op_flags |= OPf_SPECIAL;
5220 NewOp(1101, logop, 1, LOGOP);
5221 logop->op_type = OP_COND_EXPR;
5222 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5223 logop->op_first = first;
5224 logop->op_flags = (U8)(flags | OPf_KIDS);
5225 logop->op_private = (U8)(1 | (flags >> 8));
5226 logop->op_other = LINKLIST(trueop);
5227 logop->op_next = LINKLIST(falseop);
5229 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5232 /* establish postfix order */
5233 start = LINKLIST(first);
5234 first->op_next = (OP*)logop;
5236 first->op_sibling = trueop;
5237 trueop->op_sibling = falseop;
5238 o = newUNOP(OP_NULL, 0, (OP*)logop);
5240 trueop->op_next = falseop->op_next = o;
5247 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5249 Constructs and returns a C<range> op, with subordinate C<flip> and
5250 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5251 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5252 for both the C<flip> and C<range> ops, except that the bit with value
5253 1 is automatically set. I<left> and I<right> supply the expressions
5254 controlling the endpoints of the range; they are consumed by this function
5255 and become part of the constructed op tree.
5261 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5270 PERL_ARGS_ASSERT_NEWRANGE;
5272 NewOp(1101, range, 1, LOGOP);
5274 range->op_type = OP_RANGE;
5275 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5276 range->op_first = left;
5277 range->op_flags = OPf_KIDS;
5278 leftstart = LINKLIST(left);
5279 range->op_other = LINKLIST(right);
5280 range->op_private = (U8)(1 | (flags >> 8));
5282 left->op_sibling = right;
5284 range->op_next = (OP*)range;
5285 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5286 flop = newUNOP(OP_FLOP, 0, flip);
5287 o = newUNOP(OP_NULL, 0, flop);
5289 range->op_next = leftstart;
5291 left->op_next = flip;
5292 right->op_next = flop;
5294 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5295 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5296 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5297 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5299 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5300 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5303 if (!flip->op_private || !flop->op_private)
5304 LINKLIST(o); /* blow off optimizer unless constant */
5310 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5312 Constructs, checks, and returns an op tree expressing a loop. This is
5313 only a loop in the control flow through the op tree; it does not have
5314 the heavyweight loop structure that allows exiting the loop by C<last>
5315 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5316 top-level op, except that some bits will be set automatically as required.
5317 I<expr> supplies the expression controlling loop iteration, and I<block>
5318 supplies the body of the loop; they are consumed by this function and
5319 become part of the constructed op tree. I<debuggable> is currently
5320 unused and should always be 1.
5326 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5331 const bool once = block && block->op_flags & OPf_SPECIAL &&
5332 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5334 PERL_UNUSED_ARG(debuggable);
5337 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5338 return block; /* do {} while 0 does once */
5339 if (expr->op_type == OP_READLINE
5340 || expr->op_type == OP_READDIR
5341 || expr->op_type == OP_GLOB
5342 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5343 expr = newUNOP(OP_DEFINED, 0,
5344 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5345 } else if (expr->op_flags & OPf_KIDS) {
5346 const OP * const k1 = ((UNOP*)expr)->op_first;
5347 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5348 switch (expr->op_type) {
5350 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5351 && (k2->op_flags & OPf_STACKED)
5352 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5353 expr = newUNOP(OP_DEFINED, 0, expr);
5357 if (k1 && (k1->op_type == OP_READDIR
5358 || k1->op_type == OP_GLOB
5359 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5360 || k1->op_type == OP_EACH
5361 || k1->op_type == OP_AEACH))
5362 expr = newUNOP(OP_DEFINED, 0, expr);
5368 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5369 * op, in listop. This is wrong. [perl #27024] */
5371 block = newOP(OP_NULL, 0);
5372 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5373 o = new_logop(OP_AND, 0, &expr, &listop);
5376 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5378 if (once && o != listop)
5379 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5382 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5384 o->op_flags |= flags;
5386 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5391 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5393 Constructs, checks, and returns an op tree expressing a C<while> loop.
5394 This is a heavyweight loop, with structure that allows exiting the loop
5395 by C<last> and suchlike.
5397 I<loop> is an optional preconstructed C<enterloop> op to use in the
5398 loop; if it is null then a suitable op will be constructed automatically.
5399 I<expr> supplies the loop's controlling expression. I<block> supplies the
5400 main body of the loop, and I<cont> optionally supplies a C<continue> block
5401 that operates as a second half of the body. All of these optree inputs
5402 are consumed by this function and become part of the constructed op tree.
5404 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5405 op and, shifted up eight bits, the eight bits of C<op_private> for
5406 the C<leaveloop> op, except that (in both cases) some bits will be set
5407 automatically. I<debuggable> is currently unused and should always be 1.
5408 I<has_my> can be supplied as true to force the
5409 loop body to be enclosed in its own scope.
5415 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5416 OP *expr, OP *block, OP *cont, I32 has_my)
5425 PERL_UNUSED_ARG(debuggable);
5428 if (expr->op_type == OP_READLINE
5429 || expr->op_type == OP_READDIR
5430 || expr->op_type == OP_GLOB
5431 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5432 expr = newUNOP(OP_DEFINED, 0,
5433 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5434 } else if (expr->op_flags & OPf_KIDS) {
5435 const OP * const k1 = ((UNOP*)expr)->op_first;
5436 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5437 switch (expr->op_type) {
5439 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5440 && (k2->op_flags & OPf_STACKED)
5441 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5442 expr = newUNOP(OP_DEFINED, 0, expr);
5446 if (k1 && (k1->op_type == OP_READDIR
5447 || k1->op_type == OP_GLOB
5448 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5449 || k1->op_type == OP_EACH
5450 || k1->op_type == OP_AEACH))
5451 expr = newUNOP(OP_DEFINED, 0, expr);
5458 block = newOP(OP_NULL, 0);
5459 else if (cont || has_my) {
5460 block = op_scope(block);
5464 next = LINKLIST(cont);
5467 OP * const unstack = newOP(OP_UNSTACK, 0);
5470 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5474 listop = op_append_list(OP_LINESEQ, block, cont);
5476 redo = LINKLIST(listop);
5480 o = new_logop(OP_AND, 0, &expr, &listop);
5481 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5482 op_free(expr); /* oops, it's a while (0) */
5484 return NULL; /* listop already freed by new_logop */
5487 ((LISTOP*)listop)->op_last->op_next =
5488 (o == listop ? redo : LINKLIST(o));
5494 NewOp(1101,loop,1,LOOP);
5495 loop->op_type = OP_ENTERLOOP;
5496 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5497 loop->op_private = 0;
5498 loop->op_next = (OP*)loop;
5501 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5503 loop->op_redoop = redo;
5504 loop->op_lastop = o;
5505 o->op_private |= loopflags;
5508 loop->op_nextop = next;
5510 loop->op_nextop = o;
5512 o->op_flags |= flags;
5513 o->op_private |= (flags >> 8);
5518 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5520 Constructs, checks, and returns an op tree expressing a C<foreach>
5521 loop (iteration through a list of values). This is a heavyweight loop,
5522 with structure that allows exiting the loop by C<last> and suchlike.
5524 I<sv> optionally supplies the variable that will be aliased to each
5525 item in turn; if null, it defaults to C<$_> (either lexical or global).
5526 I<expr> supplies the list of values to iterate over. I<block> supplies
5527 the main body of the loop, and I<cont> optionally supplies a C<continue>
5528 block that operates as a second half of the body. All of these optree
5529 inputs are consumed by this function and become part of the constructed
5532 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5533 op and, shifted up eight bits, the eight bits of C<op_private> for
5534 the C<leaveloop> op, except that (in both cases) some bits will be set
5541 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5546 PADOFFSET padoff = 0;
5551 PERL_ARGS_ASSERT_NEWFOROP;
5554 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5555 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5556 sv->op_type = OP_RV2GV;
5557 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5559 /* The op_type check is needed to prevent a possible segfault
5560 * if the loop variable is undeclared and 'strict vars' is in
5561 * effect. This is illegal but is nonetheless parsed, so we
5562 * may reach this point with an OP_CONST where we're expecting
5565 if (cUNOPx(sv)->op_first->op_type == OP_GV
5566 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5567 iterpflags |= OPpITER_DEF;
5569 else if (sv->op_type == OP_PADSV) { /* private variable */
5570 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5571 padoff = sv->op_targ;
5581 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5583 SV *const namesv = PAD_COMPNAME_SV(padoff);
5585 const char *const name = SvPV_const(namesv, len);
5587 if (len == 2 && name[0] == '$' && name[1] == '_')
5588 iterpflags |= OPpITER_DEF;
5592 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5593 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5594 sv = newGVOP(OP_GV, 0, PL_defgv);
5599 iterpflags |= OPpITER_DEF;
5601 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5602 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5603 iterflags |= OPf_STACKED;
5605 else if (expr->op_type == OP_NULL &&
5606 (expr->op_flags & OPf_KIDS) &&
5607 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5609 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5610 * set the STACKED flag to indicate that these values are to be
5611 * treated as min/max values by 'pp_iterinit'.
5613 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5614 LOGOP* const range = (LOGOP*) flip->op_first;
5615 OP* const left = range->op_first;
5616 OP* const right = left->op_sibling;
5619 range->op_flags &= ~OPf_KIDS;
5620 range->op_first = NULL;
5622 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5623 listop->op_first->op_next = range->op_next;
5624 left->op_next = range->op_other;
5625 right->op_next = (OP*)listop;
5626 listop->op_next = listop->op_first;
5629 op_getmad(expr,(OP*)listop,'O');
5633 expr = (OP*)(listop);
5635 iterflags |= OPf_STACKED;
5638 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5641 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5642 op_append_elem(OP_LIST, expr, scalar(sv))));
5643 assert(!loop->op_next);
5644 /* for my $x () sets OPpLVAL_INTRO;
5645 * for our $x () sets OPpOUR_INTRO */
5646 loop->op_private = (U8)iterpflags;
5647 #ifdef PL_OP_SLAB_ALLOC
5650 NewOp(1234,tmp,1,LOOP);
5651 Copy(loop,tmp,1,LISTOP);
5652 S_op_destroy(aTHX_ (OP*)loop);
5656 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5658 loop->op_targ = padoff;
5659 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5661 op_getmad(madsv, (OP*)loop, 'v');
5666 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5668 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5669 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5670 determining the target of the op; it is consumed by this function and
5671 become part of the constructed op tree.
5677 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5682 PERL_ARGS_ASSERT_NEWLOOPEX;
5684 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5686 if (type != OP_GOTO || label->op_type == OP_CONST) {
5687 /* "last()" means "last" */
5688 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5689 o = newOP(type, OPf_SPECIAL);
5691 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5692 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5696 op_getmad(label,o,'L');
5702 /* Check whether it's going to be a goto &function */
5703 if (label->op_type == OP_ENTERSUB
5704 && !(label->op_flags & OPf_STACKED))
5705 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
5706 o = newUNOP(type, OPf_STACKED, label);
5708 PL_hints |= HINT_BLOCK_SCOPE;
5712 /* if the condition is a literal array or hash
5713 (or @{ ... } etc), make a reference to it.
5716 S_ref_array_or_hash(pTHX_ OP *cond)
5719 && (cond->op_type == OP_RV2AV
5720 || cond->op_type == OP_PADAV
5721 || cond->op_type == OP_RV2HV
5722 || cond->op_type == OP_PADHV))
5724 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
5727 && (cond->op_type == OP_ASLICE
5728 || cond->op_type == OP_HSLICE)) {
5730 /* anonlist now needs a list from this op, was previously used in
5732 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5733 cond->op_flags |= OPf_WANT_LIST;
5735 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
5742 /* These construct the optree fragments representing given()
5745 entergiven and enterwhen are LOGOPs; the op_other pointer
5746 points up to the associated leave op. We need this so we
5747 can put it in the context and make break/continue work.
5748 (Also, of course, pp_enterwhen will jump straight to
5749 op_other if the match fails.)
5753 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5754 I32 enter_opcode, I32 leave_opcode,
5755 PADOFFSET entertarg)
5761 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5763 NewOp(1101, enterop, 1, LOGOP);
5764 enterop->op_type = (Optype)enter_opcode;
5765 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5766 enterop->op_flags = (U8) OPf_KIDS;
5767 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5768 enterop->op_private = 0;
5770 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5773 enterop->op_first = scalar(cond);
5774 cond->op_sibling = block;
5776 o->op_next = LINKLIST(cond);
5777 cond->op_next = (OP *) enterop;
5780 /* This is a default {} block */
5781 enterop->op_first = block;
5782 enterop->op_flags |= OPf_SPECIAL;
5784 o->op_next = (OP *) enterop;
5787 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5788 entergiven and enterwhen both
5791 enterop->op_next = LINKLIST(block);
5792 block->op_next = enterop->op_other = o;
5797 /* Does this look like a boolean operation? For these purposes
5798 a boolean operation is:
5799 - a subroutine call [*]
5800 - a logical connective
5801 - a comparison operator
5802 - a filetest operator, with the exception of -s -M -A -C
5803 - defined(), exists() or eof()
5804 - /$re/ or $foo =~ /$re/
5806 [*] possibly surprising
5809 S_looks_like_bool(pTHX_ const OP *o)
5813 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5815 switch(o->op_type) {
5818 return looks_like_bool(cLOGOPo->op_first);
5822 looks_like_bool(cLOGOPo->op_first)
5823 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5828 o->op_flags & OPf_KIDS
5829 && looks_like_bool(cUNOPo->op_first));
5833 case OP_NOT: case OP_XOR:
5835 case OP_EQ: case OP_NE: case OP_LT:
5836 case OP_GT: case OP_LE: case OP_GE:
5838 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5839 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5841 case OP_SEQ: case OP_SNE: case OP_SLT:
5842 case OP_SGT: case OP_SLE: case OP_SGE:
5846 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5847 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5848 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5849 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5850 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5851 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5852 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5853 case OP_FTTEXT: case OP_FTBINARY:
5855 case OP_DEFINED: case OP_EXISTS:
5856 case OP_MATCH: case OP_EOF:
5863 /* Detect comparisons that have been optimized away */
5864 if (cSVOPo->op_sv == &PL_sv_yes
5865 || cSVOPo->op_sv == &PL_sv_no)
5878 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5880 Constructs, checks, and returns an op tree expressing a C<given> block.
5881 I<cond> supplies the expression that will be locally assigned to a lexical
5882 variable, and I<block> supplies the body of the C<given> construct; they
5883 are consumed by this function and become part of the constructed op tree.
5884 I<defsv_off> is the pad offset of the scalar lexical variable that will
5891 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5894 PERL_ARGS_ASSERT_NEWGIVENOP;
5895 return newGIVWHENOP(
5896 ref_array_or_hash(cond),
5898 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5903 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5905 Constructs, checks, and returns an op tree expressing a C<when> block.
5906 I<cond> supplies the test expression, and I<block> supplies the block
5907 that will be executed if the test evaluates to true; they are consumed
5908 by this function and become part of the constructed op tree. I<cond>
5909 will be interpreted DWIMically, often as a comparison against C<$_>,
5910 and may be null to generate a C<default> block.
5916 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5918 const bool cond_llb = (!cond || looks_like_bool(cond));
5921 PERL_ARGS_ASSERT_NEWWHENOP;
5926 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5928 scalar(ref_array_or_hash(cond)));
5931 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5935 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5938 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5940 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5941 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5942 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5943 || (p && (len != SvCUR(cv) /* Not the same length. */
5944 || memNE(p, SvPVX_const(cv), len))))
5945 && ckWARN_d(WARN_PROTOTYPE)) {
5946 SV* const msg = sv_newmortal();
5950 gv_efullname3(name = sv_newmortal(), gv, NULL);
5951 sv_setpvs(msg, "Prototype mismatch:");
5953 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5955 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5957 sv_catpvs(msg, ": none");
5958 sv_catpvs(msg, " vs ");
5960 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5962 sv_catpvs(msg, "none");
5963 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5967 static void const_sv_xsub(pTHX_ CV* cv);
5971 =head1 Optree Manipulation Functions
5973 =for apidoc cv_const_sv
5975 If C<cv> is a constant sub eligible for inlining. returns the constant
5976 value returned by the sub. Otherwise, returns NULL.
5978 Constant subs can be created with C<newCONSTSUB> or as described in
5979 L<perlsub/"Constant Functions">.
5984 Perl_cv_const_sv(pTHX_ const CV *const cv)
5986 PERL_UNUSED_CONTEXT;
5989 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5991 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5994 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5995 * Can be called in 3 ways:
5998 * look for a single OP_CONST with attached value: return the value
6000 * cv && CvCLONE(cv) && !CvCONST(cv)
6002 * examine the clone prototype, and if contains only a single
6003 * OP_CONST referencing a pad const, or a single PADSV referencing
6004 * an outer lexical, return a non-zero value to indicate the CV is
6005 * a candidate for "constizing" at clone time
6009 * We have just cloned an anon prototype that was marked as a const
6010 * candidate. Try to grab the current value, and in the case of
6011 * PADSV, ignore it if it has multiple references. Return the value.
6015 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6026 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6027 o = cLISTOPo->op_first->op_sibling;
6029 for (; o; o = o->op_next) {
6030 const OPCODE type = o->op_type;
6032 if (sv && o->op_next == o)
6034 if (o->op_next != o) {
6035 if (type == OP_NEXTSTATE
6036 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6037 || type == OP_PUSHMARK)
6039 if (type == OP_DBSTATE)
6042 if (type == OP_LEAVESUB || type == OP_RETURN)
6046 if (type == OP_CONST && cSVOPo->op_sv)
6048 else if (cv && type == OP_CONST) {
6049 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6053 else if (cv && type == OP_PADSV) {
6054 if (CvCONST(cv)) { /* newly cloned anon */
6055 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6056 /* the candidate should have 1 ref from this pad and 1 ref
6057 * from the parent */
6058 if (!sv || SvREFCNT(sv) != 2)
6065 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6066 sv = &PL_sv_undef; /* an arbitrary non-null value */
6081 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6084 /* This would be the return value, but the return cannot be reached. */
6085 OP* pegop = newOP(OP_NULL, 0);
6088 PERL_UNUSED_ARG(floor);
6098 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6100 NORETURN_FUNCTION_END;
6105 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6110 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6111 register CV *cv = NULL;
6113 /* If the subroutine has no body, no attributes, and no builtin attributes
6114 then it's just a sub declaration, and we may be able to get away with
6115 storing with a placeholder scalar in the symbol table, rather than a
6116 full GV and CV. If anything is present then it will take a full CV to
6118 const I32 gv_fetch_flags
6119 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6121 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6122 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6126 assert(proto->op_type == OP_CONST);
6127 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6133 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6135 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6136 SV * const sv = sv_newmortal();
6137 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6138 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6139 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6140 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6142 } else if (PL_curstash) {
6143 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6146 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6150 if (!PL_madskills) {
6159 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6160 maximum a prototype before. */
6161 if (SvTYPE(gv) > SVt_NULL) {
6162 if (!SvPOK((const SV *)gv)
6163 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6165 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6167 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6170 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6172 sv_setiv(MUTABLE_SV(gv), -1);
6174 SvREFCNT_dec(PL_compcv);
6175 cv = PL_compcv = NULL;
6179 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6181 if (!block || !ps || *ps || attrs
6182 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6184 || block->op_type == OP_NULL
6189 const_sv = op_const_sv(block, NULL);
6192 const bool exists = CvROOT(cv) || CvXSUB(cv);
6194 /* if the subroutine doesn't exist and wasn't pre-declared
6195 * with a prototype, assume it will be AUTOLOADed,
6196 * skipping the prototype check
6198 if (exists || SvPOK(cv))
6199 cv_ckproto_len(cv, gv, ps, ps_len);
6200 /* already defined (or promised)? */
6201 if (exists || GvASSUMECV(gv)) {
6204 || block->op_type == OP_NULL
6207 if (CvFLAGS(PL_compcv)) {
6208 /* might have had built-in attrs applied */
6209 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6210 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6211 && ckWARN(WARN_MISC))
6212 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6214 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6215 & ~(CVf_LVALUE * pureperl));
6217 if (attrs) goto attrs;
6218 /* just a "sub foo;" when &foo is already defined */
6219 SAVEFREESV(PL_compcv);
6224 && block->op_type != OP_NULL
6227 if (ckWARN(WARN_REDEFINE)
6229 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6231 const line_t oldline = CopLINE(PL_curcop);
6232 if (PL_parser && PL_parser->copline != NOLINE)
6233 CopLINE_set(PL_curcop, PL_parser->copline);
6234 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6235 CvCONST(cv) ? "Constant subroutine %s redefined"
6236 : "Subroutine %s redefined", name);
6237 CopLINE_set(PL_curcop, oldline);
6240 if (!PL_minus_c) /* keep old one around for madskills */
6243 /* (PL_madskills unset in used file.) */
6251 SvREFCNT_inc_simple_void_NN(const_sv);
6253 assert(!CvROOT(cv) && !CvCONST(cv));
6254 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6255 CvXSUBANY(cv).any_ptr = const_sv;
6256 CvXSUB(cv) = const_sv_xsub;
6262 cv = newCONSTSUB(NULL, name, const_sv);
6264 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6265 (CvGV(cv) && GvSTASH(CvGV(cv)))
6274 SvREFCNT_dec(PL_compcv);
6278 if (cv) { /* must reuse cv if autoloaded */
6279 /* transfer PL_compcv to cv */
6282 && block->op_type != OP_NULL
6285 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6286 AV *const temp_av = CvPADLIST(cv);
6287 CV *const temp_cv = CvOUTSIDE(cv);
6289 assert(!CvWEAKOUTSIDE(cv));
6290 assert(!CvCVGV_RC(cv));
6291 assert(CvGV(cv) == gv);
6294 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6295 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6296 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6297 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6298 CvOUTSIDE(PL_compcv) = temp_cv;
6299 CvPADLIST(PL_compcv) = temp_av;
6302 if (CvFILE(cv) && !CvISXSUB(cv)) {
6303 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
6304 Safefree(CvFILE(cv));
6307 CvFILE_set_from_cop(cv, PL_curcop);
6308 CvSTASH_set(cv, PL_curstash);
6310 /* inner references to PL_compcv must be fixed up ... */
6311 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6312 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6313 ++PL_sub_generation;
6316 /* Might have had built-in attributes applied -- propagate them. */
6317 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6319 /* ... before we throw it away */
6320 SvREFCNT_dec(PL_compcv);
6328 if (strEQ(name, "import")) {
6329 PL_formfeed = MUTABLE_SV(cv);
6330 /* diag_listed_as: SKIPME */
6331 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6335 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6340 CvFILE_set_from_cop(cv, PL_curcop);
6341 CvSTASH_set(cv, PL_curstash);
6345 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6346 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6347 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6351 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6353 if (PL_parser && PL_parser->error_count) {
6357 const char *s = strrchr(name, ':');
6359 if (strEQ(s, "BEGIN")) {
6360 const char not_safe[] =
6361 "BEGIN not safe after errors--compilation aborted";
6362 if (PL_in_eval & EVAL_KEEPERR)
6363 Perl_croak(aTHX_ not_safe);
6365 /* force display of errors found but not reported */
6366 sv_catpv(ERRSV, not_safe);
6367 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6376 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6377 the debugger could be able to set a breakpoint in, so signal to
6378 pp_entereval that it should not throw away any saved lines at scope
6381 PL_breakable_sub_gen++;
6382 /* This makes sub {}; work as expected. */
6383 if (block->op_type == OP_STUB) {
6384 OP* const newblock = newSTATEOP(0, NULL, 0);
6386 op_getmad(block,newblock,'B');
6392 else block->op_attached = 1;
6393 CvROOT(cv) = CvLVALUE(cv)
6394 ? newUNOP(OP_LEAVESUBLV, 0,
6395 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6396 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6397 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6398 OpREFCNT_set(CvROOT(cv), 1);
6399 CvSTART(cv) = LINKLIST(CvROOT(cv));
6400 CvROOT(cv)->op_next = 0;
6401 CALL_PEEP(CvSTART(cv));
6403 /* now that optimizer has done its work, adjust pad values */
6405 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6408 assert(!CvCONST(cv));
6409 if (ps && !*ps && op_const_sv(block, cv))
6414 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6415 SV * const tmpstr = sv_newmortal();
6416 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6417 GV_ADDMULTI, SVt_PVHV);
6419 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6422 (long)CopLINE(PL_curcop));
6423 gv_efullname3(tmpstr, gv, NULL);
6424 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6425 SvCUR(tmpstr), sv, 0);
6426 hv = GvHVn(db_postponed);
6427 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6428 CV * const pcv = GvCV(db_postponed);
6434 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6439 if (name && ! (PL_parser && PL_parser->error_count))
6440 process_special_blocks(name, gv, cv);
6445 PL_parser->copline = NOLINE;
6451 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6454 const char *const colon = strrchr(fullname,':');
6455 const char *const name = colon ? colon + 1 : fullname;
6457 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6460 if (strEQ(name, "BEGIN")) {
6461 const I32 oldscope = PL_scopestack_ix;
6463 SAVECOPFILE(&PL_compiling);
6464 SAVECOPLINE(&PL_compiling);
6466 DEBUG_x( dump_sub(gv) );
6467 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6468 GvCV_set(gv,0); /* cv has been hijacked */
6469 call_list(oldscope, PL_beginav);
6471 PL_curcop = &PL_compiling;
6472 CopHINTS_set(&PL_compiling, PL_hints);
6479 if strEQ(name, "END") {
6480 DEBUG_x( dump_sub(gv) );
6481 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6484 } else if (*name == 'U') {
6485 if (strEQ(name, "UNITCHECK")) {
6486 /* It's never too late to run a unitcheck block */
6487 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6491 } else if (*name == 'C') {
6492 if (strEQ(name, "CHECK")) {
6494 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6495 "Too late to run CHECK block");
6496 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6500 } else if (*name == 'I') {
6501 if (strEQ(name, "INIT")) {
6503 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6504 "Too late to run INIT block");
6505 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6511 DEBUG_x( dump_sub(gv) );
6512 GvCV_set(gv,0); /* cv has been hijacked */
6517 =for apidoc newCONSTSUB
6519 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6520 eligible for inlining at compile-time.
6522 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6523 which won't be called if used as a destructor, but will suppress the overhead
6524 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6531 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6536 const char *const file = CopFILE(PL_curcop);
6538 SV *const temp_sv = CopFILESV(PL_curcop);
6539 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6544 if (IN_PERL_RUNTIME) {
6545 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6546 * an op shared between threads. Use a non-shared COP for our
6548 SAVEVPTR(PL_curcop);
6549 PL_curcop = &PL_compiling;
6551 SAVECOPLINE(PL_curcop);
6552 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6555 PL_hints &= ~HINT_BLOCK_SCOPE;
6558 SAVESPTR(PL_curstash);
6559 SAVECOPSTASH(PL_curcop);
6560 PL_curstash = stash;
6561 CopSTASH_set(PL_curcop,stash);
6564 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6565 and so doesn't get free()d. (It's expected to be from the C pre-
6566 processor __FILE__ directive). But we need a dynamically allocated one,
6567 and we need it to get freed. */
6568 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6569 XS_DYNAMIC_FILENAME);
6570 CvXSUBANY(cv).any_ptr = sv;
6575 CopSTASH_free(PL_curcop);
6583 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6584 const char *const filename, const char *const proto,
6587 CV *cv = newXS(name, subaddr, filename);
6589 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6591 if (flags & XS_DYNAMIC_FILENAME) {
6592 /* We need to "make arrangements" (ie cheat) to ensure that the
6593 filename lasts as long as the PVCV we just created, but also doesn't
6595 STRLEN filename_len = strlen(filename);
6596 STRLEN proto_and_file_len = filename_len;
6597 char *proto_and_file;
6601 proto_len = strlen(proto);
6602 proto_and_file_len += proto_len;
6604 Newx(proto_and_file, proto_and_file_len + 1, char);
6605 Copy(proto, proto_and_file, proto_len, char);
6606 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6609 proto_and_file = savepvn(filename, filename_len);
6612 /* This gets free()d. :-) */
6613 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6614 SV_HAS_TRAILING_NUL);
6616 /* This gives us the correct prototype, rather than one with the
6617 file name appended. */
6618 SvCUR_set(cv, proto_len);
6622 CvFILE(cv) = proto_and_file + proto_len;
6624 sv_setpv(MUTABLE_SV(cv), proto);
6630 =for apidoc U||newXS
6632 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6633 static storage, as it is used directly as CvFILE(), without a copy being made.
6639 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6642 GV * const gv = gv_fetchpv(name ? name :
6643 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6644 GV_ADDMULTI, SVt_PVCV);
6647 PERL_ARGS_ASSERT_NEWXS;
6650 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6652 if ((cv = (name ? GvCV(gv) : NULL))) {
6654 /* just a cached method */
6658 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6659 /* already defined (or promised) */
6660 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6661 if (ckWARN(WARN_REDEFINE)) {
6662 GV * const gvcv = CvGV(cv);
6664 HV * const stash = GvSTASH(gvcv);
6666 const char *redefined_name = HvNAME_get(stash);
6667 if ( strEQ(redefined_name,"autouse") ) {
6668 const line_t oldline = CopLINE(PL_curcop);
6669 if (PL_parser && PL_parser->copline != NOLINE)
6670 CopLINE_set(PL_curcop, PL_parser->copline);
6671 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6672 CvCONST(cv) ? "Constant subroutine %s redefined"
6673 : "Subroutine %s redefined"
6675 CopLINE_set(PL_curcop, oldline);
6685 if (cv) /* must reuse cv if autoloaded */
6688 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6692 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6698 (void)gv_fetchfile(filename);
6699 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6700 an external constant string */
6702 CvXSUB(cv) = subaddr;
6705 process_special_blocks(name, gv, cv);
6715 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6720 OP* pegop = newOP(OP_NULL, 0);
6724 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6725 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6728 if ((cv = GvFORM(gv))) {
6729 if (ckWARN(WARN_REDEFINE)) {
6730 const line_t oldline = CopLINE(PL_curcop);
6731 if (PL_parser && PL_parser->copline != NOLINE)
6732 CopLINE_set(PL_curcop, PL_parser->copline);
6734 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6735 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6737 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6738 "Format STDOUT redefined");
6740 CopLINE_set(PL_curcop, oldline);
6747 CvFILE_set_from_cop(cv, PL_curcop);
6750 pad_tidy(padtidy_FORMAT);
6751 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6752 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6753 OpREFCNT_set(CvROOT(cv), 1);
6754 CvSTART(cv) = LINKLIST(CvROOT(cv));
6755 CvROOT(cv)->op_next = 0;
6756 CALL_PEEP(CvSTART(cv));
6758 op_getmad(o,pegop,'n');
6759 op_getmad_weak(block, pegop, 'b');
6764 PL_parser->copline = NOLINE;
6772 Perl_newANONLIST(pTHX_ OP *o)
6774 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6778 Perl_newANONHASH(pTHX_ OP *o)
6780 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6784 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6786 return newANONATTRSUB(floor, proto, NULL, block);
6790 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6792 return newUNOP(OP_REFGEN, 0,
6793 newSVOP(OP_ANONCODE, 0,
6794 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6798 Perl_oopsAV(pTHX_ OP *o)
6802 PERL_ARGS_ASSERT_OOPSAV;
6804 switch (o->op_type) {
6806 o->op_type = OP_PADAV;
6807 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6808 return ref(o, OP_RV2AV);
6811 o->op_type = OP_RV2AV;
6812 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6817 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6824 Perl_oopsHV(pTHX_ OP *o)
6828 PERL_ARGS_ASSERT_OOPSHV;
6830 switch (o->op_type) {
6833 o->op_type = OP_PADHV;
6834 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6835 return ref(o, OP_RV2HV);
6839 o->op_type = OP_RV2HV;
6840 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6845 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6852 Perl_newAVREF(pTHX_ OP *o)
6856 PERL_ARGS_ASSERT_NEWAVREF;
6858 if (o->op_type == OP_PADANY) {
6859 o->op_type = OP_PADAV;
6860 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6863 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6864 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6865 "Using an array as a reference is deprecated");
6867 return newUNOP(OP_RV2AV, 0, scalar(o));
6871 Perl_newGVREF(pTHX_ I32 type, OP *o)
6873 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6874 return newUNOP(OP_NULL, 0, o);
6875 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6879 Perl_newHVREF(pTHX_ OP *o)
6883 PERL_ARGS_ASSERT_NEWHVREF;
6885 if (o->op_type == OP_PADANY) {
6886 o->op_type = OP_PADHV;
6887 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6890 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6891 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6892 "Using a hash as a reference is deprecated");
6894 return newUNOP(OP_RV2HV, 0, scalar(o));
6898 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6900 return newUNOP(OP_RV2CV, flags, scalar(o));
6904 Perl_newSVREF(pTHX_ OP *o)
6908 PERL_ARGS_ASSERT_NEWSVREF;
6910 if (o->op_type == OP_PADANY) {
6911 o->op_type = OP_PADSV;
6912 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6915 return newUNOP(OP_RV2SV, 0, scalar(o));
6918 /* Check routines. See the comments at the top of this file for details
6919 * on when these are called */
6922 Perl_ck_anoncode(pTHX_ OP *o)
6924 PERL_ARGS_ASSERT_CK_ANONCODE;
6926 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6928 cSVOPo->op_sv = NULL;
6933 Perl_ck_bitop(pTHX_ OP *o)
6937 PERL_ARGS_ASSERT_CK_BITOP;
6939 #define OP_IS_NUMCOMPARE(op) \
6940 ((op) == OP_LT || (op) == OP_I_LT || \
6941 (op) == OP_GT || (op) == OP_I_GT || \
6942 (op) == OP_LE || (op) == OP_I_LE || \
6943 (op) == OP_GE || (op) == OP_I_GE || \
6944 (op) == OP_EQ || (op) == OP_I_EQ || \
6945 (op) == OP_NE || (op) == OP_I_NE || \
6946 (op) == OP_NCMP || (op) == OP_I_NCMP)
6947 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6948 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6949 && (o->op_type == OP_BIT_OR
6950 || o->op_type == OP_BIT_AND
6951 || o->op_type == OP_BIT_XOR))
6953 const OP * const left = cBINOPo->op_first;
6954 const OP * const right = left->op_sibling;
6955 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6956 (left->op_flags & OPf_PARENS) == 0) ||
6957 (OP_IS_NUMCOMPARE(right->op_type) &&
6958 (right->op_flags & OPf_PARENS) == 0))
6959 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6960 "Possible precedence problem on bitwise %c operator",
6961 o->op_type == OP_BIT_OR ? '|'
6962 : o->op_type == OP_BIT_AND ? '&' : '^'
6969 Perl_ck_concat(pTHX_ OP *o)
6971 const OP * const kid = cUNOPo->op_first;
6973 PERL_ARGS_ASSERT_CK_CONCAT;
6974 PERL_UNUSED_CONTEXT;
6976 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6977 !(kUNOP->op_first->op_flags & OPf_MOD))
6978 o->op_flags |= OPf_STACKED;
6983 Perl_ck_spair(pTHX_ OP *o)
6987 PERL_ARGS_ASSERT_CK_SPAIR;
6989 if (o->op_flags & OPf_KIDS) {
6992 const OPCODE type = o->op_type;
6993 o = modkids(ck_fun(o), type);
6994 kid = cUNOPo->op_first;
6995 newop = kUNOP->op_first->op_sibling;
6997 const OPCODE type = newop->op_type;
6998 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6999 type == OP_PADAV || type == OP_PADHV ||
7000 type == OP_RV2AV || type == OP_RV2HV)
7004 op_getmad(kUNOP->op_first,newop,'K');
7006 op_free(kUNOP->op_first);
7008 kUNOP->op_first = newop;
7010 o->op_ppaddr = PL_ppaddr[++o->op_type];
7015 Perl_ck_delete(pTHX_ OP *o)
7017 PERL_ARGS_ASSERT_CK_DELETE;
7021 if (o->op_flags & OPf_KIDS) {
7022 OP * const kid = cUNOPo->op_first;
7023 switch (kid->op_type) {
7025 o->op_flags |= OPf_SPECIAL;
7028 o->op_private |= OPpSLICE;
7031 o->op_flags |= OPf_SPECIAL;
7036 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7039 if (kid->op_private & OPpLVAL_INTRO)
7040 o->op_private |= OPpLVAL_INTRO;
7047 Perl_ck_die(pTHX_ OP *o)
7049 PERL_ARGS_ASSERT_CK_DIE;
7052 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7058 Perl_ck_eof(pTHX_ OP *o)
7062 PERL_ARGS_ASSERT_CK_EOF;
7064 if (o->op_flags & OPf_KIDS) {
7065 if (cLISTOPo->op_first->op_type == OP_STUB) {
7067 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7069 op_getmad(o,newop,'O');
7081 Perl_ck_eval(pTHX_ OP *o)
7085 PERL_ARGS_ASSERT_CK_EVAL;
7087 PL_hints |= HINT_BLOCK_SCOPE;
7088 if (o->op_flags & OPf_KIDS) {
7089 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7092 o->op_flags &= ~OPf_KIDS;
7095 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7101 cUNOPo->op_first = 0;
7106 NewOp(1101, enter, 1, LOGOP);
7107 enter->op_type = OP_ENTERTRY;
7108 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7109 enter->op_private = 0;
7111 /* establish postfix order */
7112 enter->op_next = (OP*)enter;
7114 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7115 o->op_type = OP_LEAVETRY;
7116 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7117 enter->op_other = o;
7118 op_getmad(oldo,o,'O');
7132 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7133 op_getmad(oldo,o,'O');
7135 o->op_targ = (PADOFFSET)PL_hints;
7136 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7137 /* Store a copy of %^H that pp_entereval can pick up. */
7138 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7139 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7140 cUNOPo->op_first->op_sibling = hhop;
7141 o->op_private |= OPpEVAL_HAS_HH;
7147 Perl_ck_exit(pTHX_ OP *o)
7149 PERL_ARGS_ASSERT_CK_EXIT;
7152 HV * const table = GvHV(PL_hintgv);
7154 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7155 if (svp && *svp && SvTRUE(*svp))
7156 o->op_private |= OPpEXIT_VMSISH;
7158 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7164 Perl_ck_exec(pTHX_ OP *o)
7166 PERL_ARGS_ASSERT_CK_EXEC;
7168 if (o->op_flags & OPf_STACKED) {
7171 kid = cUNOPo->op_first->op_sibling;
7172 if (kid->op_type == OP_RV2GV)
7181 Perl_ck_exists(pTHX_ OP *o)
7185 PERL_ARGS_ASSERT_CK_EXISTS;
7188 if (o->op_flags & OPf_KIDS) {
7189 OP * const kid = cUNOPo->op_first;
7190 if (kid->op_type == OP_ENTERSUB) {
7191 (void) ref(kid, o->op_type);
7192 if (kid->op_type != OP_RV2CV
7193 && !(PL_parser && PL_parser->error_count))
7194 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7196 o->op_private |= OPpEXISTS_SUB;
7198 else if (kid->op_type == OP_AELEM)
7199 o->op_flags |= OPf_SPECIAL;
7200 else if (kid->op_type != OP_HELEM)
7201 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7209 Perl_ck_rvconst(pTHX_ register OP *o)
7212 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7214 PERL_ARGS_ASSERT_CK_RVCONST;
7216 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7217 if (o->op_type == OP_RV2CV)
7218 o->op_private &= ~1;
7220 if (kid->op_type == OP_CONST) {
7223 SV * const kidsv = kid->op_sv;
7225 /* Is it a constant from cv_const_sv()? */
7226 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7227 SV * const rsv = SvRV(kidsv);
7228 const svtype type = SvTYPE(rsv);
7229 const char *badtype = NULL;
7231 switch (o->op_type) {
7233 if (type > SVt_PVMG)
7234 badtype = "a SCALAR";
7237 if (type != SVt_PVAV)
7238 badtype = "an ARRAY";
7241 if (type != SVt_PVHV)
7245 if (type != SVt_PVCV)
7250 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7253 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7254 const char *badthing;
7255 switch (o->op_type) {
7257 badthing = "a SCALAR";
7260 badthing = "an ARRAY";
7263 badthing = "a HASH";
7271 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7272 SVfARG(kidsv), badthing);
7275 * This is a little tricky. We only want to add the symbol if we
7276 * didn't add it in the lexer. Otherwise we get duplicate strict
7277 * warnings. But if we didn't add it in the lexer, we must at
7278 * least pretend like we wanted to add it even if it existed before,
7279 * or we get possible typo warnings. OPpCONST_ENTERED says
7280 * whether the lexer already added THIS instance of this symbol.
7282 iscv = (o->op_type == OP_RV2CV) * 2;
7284 gv = gv_fetchsv(kidsv,
7285 iscv | !(kid->op_private & OPpCONST_ENTERED),
7288 : o->op_type == OP_RV2SV
7290 : o->op_type == OP_RV2AV
7292 : o->op_type == OP_RV2HV
7295 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7297 kid->op_type = OP_GV;
7298 SvREFCNT_dec(kid->op_sv);
7300 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7301 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7302 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7304 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7306 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7308 kid->op_private = 0;
7309 kid->op_ppaddr = PL_ppaddr[OP_GV];
7310 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7318 Perl_ck_ftst(pTHX_ OP *o)
7321 const I32 type = o->op_type;
7323 PERL_ARGS_ASSERT_CK_FTST;
7325 if (o->op_flags & OPf_REF) {
7328 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7329 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7330 const OPCODE kidtype = kid->op_type;
7332 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7333 OP * const newop = newGVOP(type, OPf_REF,
7334 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7336 op_getmad(o,newop,'O');
7342 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7343 o->op_private |= OPpFT_ACCESS;
7344 if (PL_check[kidtype] == Perl_ck_ftst
7345 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7346 o->op_private |= OPpFT_STACKED;
7347 kid->op_private |= OPpFT_STACKING;
7356 if (type == OP_FTTTY)
7357 o = newGVOP(type, OPf_REF, PL_stdingv);
7359 o = newUNOP(type, 0, newDEFSVOP());
7360 op_getmad(oldo,o,'O');
7366 Perl_ck_fun(pTHX_ OP *o)
7369 const int type = o->op_type;
7370 register I32 oa = PL_opargs[type] >> OASHIFT;
7372 PERL_ARGS_ASSERT_CK_FUN;
7374 if (o->op_flags & OPf_STACKED) {
7375 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7378 return no_fh_allowed(o);
7381 if (o->op_flags & OPf_KIDS) {
7382 OP **tokid = &cLISTOPo->op_first;
7383 register OP *kid = cLISTOPo->op_first;
7387 if (kid->op_type == OP_PUSHMARK ||
7388 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7390 tokid = &kid->op_sibling;
7391 kid = kid->op_sibling;
7393 if (!kid && PL_opargs[type] & OA_DEFGV)
7394 *tokid = kid = newDEFSVOP();
7398 sibl = kid->op_sibling;
7400 if (!sibl && kid->op_type == OP_STUB) {
7407 /* list seen where single (scalar) arg expected? */
7408 if (numargs == 1 && !(oa >> 4)
7409 && kid->op_type == OP_LIST && type != OP_SCALAR)
7411 return too_many_arguments(o,PL_op_desc[type]);
7424 if ((type == OP_PUSH || type == OP_UNSHIFT)
7425 && !kid->op_sibling)
7426 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7427 "Useless use of %s with no values",
7430 if (kid->op_type == OP_CONST &&
7431 (kid->op_private & OPpCONST_BARE))
7433 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7434 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7435 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7436 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7437 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7439 op_getmad(kid,newop,'K');
7444 kid->op_sibling = sibl;
7447 else if (kid->op_type == OP_CONST
7448 && ( !SvROK(cSVOPx_sv(kid))
7449 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7451 bad_type(numargs, "array", PL_op_desc[type], kid);
7452 /* Defer checks to run-time if we have a scalar arg */
7453 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7454 op_lvalue(kid, type);
7458 if (kid->op_type == OP_CONST &&
7459 (kid->op_private & OPpCONST_BARE))
7461 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7462 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7463 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7464 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7465 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7467 op_getmad(kid,newop,'K');
7472 kid->op_sibling = sibl;
7475 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7476 bad_type(numargs, "hash", PL_op_desc[type], kid);
7477 op_lvalue(kid, type);
7481 OP * const newop = newUNOP(OP_NULL, 0, kid);
7482 kid->op_sibling = 0;
7484 newop->op_next = newop;
7486 kid->op_sibling = sibl;
7491 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7492 if (kid->op_type == OP_CONST &&
7493 (kid->op_private & OPpCONST_BARE))
7495 OP * const newop = newGVOP(OP_GV, 0,
7496 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7497 if (!(o->op_private & 1) && /* if not unop */
7498 kid == cLISTOPo->op_last)
7499 cLISTOPo->op_last = newop;
7501 op_getmad(kid,newop,'K');
7507 else if (kid->op_type == OP_READLINE) {
7508 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7509 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7512 I32 flags = OPf_SPECIAL;
7516 /* is this op a FH constructor? */
7517 if (is_handle_constructor(o,numargs)) {
7518 const char *name = NULL;
7522 /* Set a flag to tell rv2gv to vivify
7523 * need to "prove" flag does not mean something
7524 * else already - NI-S 1999/05/07
7527 if (kid->op_type == OP_PADSV) {
7529 = PAD_COMPNAME_SV(kid->op_targ);
7530 name = SvPV_const(namesv, len);
7532 else if (kid->op_type == OP_RV2SV
7533 && kUNOP->op_first->op_type == OP_GV)
7535 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7537 len = GvNAMELEN(gv);
7539 else if (kid->op_type == OP_AELEM
7540 || kid->op_type == OP_HELEM)
7543 OP *op = ((BINOP*)kid)->op_first;
7547 const char * const a =
7548 kid->op_type == OP_AELEM ?
7550 if (((op->op_type == OP_RV2AV) ||
7551 (op->op_type == OP_RV2HV)) &&
7552 (firstop = ((UNOP*)op)->op_first) &&
7553 (firstop->op_type == OP_GV)) {
7554 /* packagevar $a[] or $h{} */
7555 GV * const gv = cGVOPx_gv(firstop);
7563 else if (op->op_type == OP_PADAV
7564 || op->op_type == OP_PADHV) {
7565 /* lexicalvar $a[] or $h{} */
7566 const char * const padname =
7567 PAD_COMPNAME_PV(op->op_targ);
7576 name = SvPV_const(tmpstr, len);
7581 name = "__ANONIO__";
7584 op_lvalue(kid, type);
7588 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7589 namesv = PAD_SVl(targ);
7590 SvUPGRADE(namesv, SVt_PV);
7592 sv_setpvs(namesv, "$");
7593 sv_catpvn(namesv, name, len);
7596 kid->op_sibling = 0;
7597 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7598 kid->op_targ = targ;
7599 kid->op_private |= priv;
7601 kid->op_sibling = sibl;
7607 op_lvalue(scalar(kid), type);
7611 tokid = &kid->op_sibling;
7612 kid = kid->op_sibling;
7615 if (kid && kid->op_type != OP_STUB)
7616 return too_many_arguments(o,OP_DESC(o));
7617 o->op_private |= numargs;
7619 /* FIXME - should the numargs move as for the PERL_MAD case? */
7620 o->op_private |= numargs;
7622 return too_many_arguments(o,OP_DESC(o));
7626 else if (PL_opargs[type] & OA_DEFGV) {
7628 OP *newop = newUNOP(type, 0, newDEFSVOP());
7629 op_getmad(o,newop,'O');
7632 /* Ordering of these two is important to keep f_map.t passing. */
7634 return newUNOP(type, 0, newDEFSVOP());
7639 while (oa & OA_OPTIONAL)
7641 if (oa && oa != OA_LIST)
7642 return too_few_arguments(o,OP_DESC(o));
7648 Perl_ck_glob(pTHX_ OP *o)
7653 PERL_ARGS_ASSERT_CK_GLOB;
7656 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7657 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
7659 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7660 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7662 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7665 #if !defined(PERL_EXTERNAL_GLOB)
7666 /* XXX this can be tightened up and made more failsafe. */
7667 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7670 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7671 newSVpvs("File::Glob"), NULL, NULL, NULL);
7672 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7673 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7674 GvCV_set(gv, GvCV(glob_gv));
7675 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7676 GvIMPORTED_CV_on(gv);
7680 #endif /* PERL_EXTERNAL_GLOB */
7682 assert(!(o->op_flags & OPf_SPECIAL));
7683 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7686 * \ null - const(wildcard)
7691 * \ mark - glob - rv2cv
7692 * | \ gv(CORE::GLOBAL::glob)
7694 * \ null - const(wildcard) - const(ix)
7696 o->op_flags |= OPf_SPECIAL;
7697 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
7698 op_append_elem(OP_GLOB, o,
7699 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7700 o = newLISTOP(OP_LIST, 0, o, NULL);
7701 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7702 op_append_elem(OP_LIST, o,
7703 scalar(newUNOP(OP_RV2CV, 0,
7704 newGVOP(OP_GV, 0, gv)))));
7705 o = newUNOP(OP_NULL, 0, ck_subr(o));
7706 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
7709 gv = newGVgen("main");
7711 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7717 Perl_ck_grep(pTHX_ OP *o)
7722 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7725 PERL_ARGS_ASSERT_CK_GREP;
7727 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7728 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7730 if (o->op_flags & OPf_STACKED) {
7733 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7734 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7735 return no_fh_allowed(o);
7736 for (k = kid; k; k = k->op_next) {
7739 NewOp(1101, gwop, 1, LOGOP);
7740 kid->op_next = (OP*)gwop;
7741 o->op_flags &= ~OPf_STACKED;
7743 kid = cLISTOPo->op_first->op_sibling;
7744 if (type == OP_MAPWHILE)
7749 if (PL_parser && PL_parser->error_count)
7751 kid = cLISTOPo->op_first->op_sibling;
7752 if (kid->op_type != OP_NULL)
7753 Perl_croak(aTHX_ "panic: ck_grep");
7754 kid = kUNOP->op_first;
7757 NewOp(1101, gwop, 1, LOGOP);
7758 gwop->op_type = type;
7759 gwop->op_ppaddr = PL_ppaddr[type];
7760 gwop->op_first = listkids(o);
7761 gwop->op_flags |= OPf_KIDS;
7762 gwop->op_other = LINKLIST(kid);
7763 kid->op_next = (OP*)gwop;
7764 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7765 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7766 o->op_private = gwop->op_private = 0;
7767 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7770 o->op_private = gwop->op_private = OPpGREP_LEX;
7771 gwop->op_targ = o->op_targ = offset;
7774 kid = cLISTOPo->op_first->op_sibling;
7775 if (!kid || !kid->op_sibling)
7776 return too_few_arguments(o,OP_DESC(o));
7777 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7778 op_lvalue(kid, OP_GREPSTART);
7784 Perl_ck_index(pTHX_ OP *o)
7786 PERL_ARGS_ASSERT_CK_INDEX;
7788 if (o->op_flags & OPf_KIDS) {
7789 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7791 kid = kid->op_sibling; /* get past "big" */
7792 if (kid && kid->op_type == OP_CONST) {
7793 const bool save_taint = PL_tainted;
7794 fbm_compile(((SVOP*)kid)->op_sv, 0);
7795 PL_tainted = save_taint;
7802 Perl_ck_lfun(pTHX_ OP *o)
7804 const OPCODE type = o->op_type;
7806 PERL_ARGS_ASSERT_CK_LFUN;
7808 return modkids(ck_fun(o), type);
7812 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7814 PERL_ARGS_ASSERT_CK_DEFINED;
7816 if ((o->op_flags & OPf_KIDS)) {
7817 switch (cUNOPo->op_first->op_type) {
7819 /* This is needed for
7820 if (defined %stash::)
7821 to work. Do not break Tk.
7823 break; /* Globals via GV can be undef */
7825 case OP_AASSIGN: /* Is this a good idea? */
7826 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7827 "defined(@array) is deprecated");
7828 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7829 "\t(Maybe you should just omit the defined()?)\n");
7833 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7834 "defined(%%hash) is deprecated");
7835 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7836 "\t(Maybe you should just omit the defined()?)\n");
7847 Perl_ck_readline(pTHX_ OP *o)
7849 PERL_ARGS_ASSERT_CK_READLINE;
7851 if (!(o->op_flags & OPf_KIDS)) {
7853 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7855 op_getmad(o,newop,'O');
7865 Perl_ck_rfun(pTHX_ OP *o)
7867 const OPCODE type = o->op_type;
7869 PERL_ARGS_ASSERT_CK_RFUN;
7871 return refkids(ck_fun(o), type);
7875 Perl_ck_listiob(pTHX_ OP *o)
7879 PERL_ARGS_ASSERT_CK_LISTIOB;
7881 kid = cLISTOPo->op_first;
7884 kid = cLISTOPo->op_first;
7886 if (kid->op_type == OP_PUSHMARK)
7887 kid = kid->op_sibling;
7888 if (kid && o->op_flags & OPf_STACKED)
7889 kid = kid->op_sibling;
7890 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7891 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7892 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7893 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7894 cLISTOPo->op_first->op_sibling = kid;
7895 cLISTOPo->op_last = kid;
7896 kid = kid->op_sibling;
7901 op_append_elem(o->op_type, o, newDEFSVOP());
7907 Perl_ck_smartmatch(pTHX_ OP *o)
7910 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7911 if (0 == (o->op_flags & OPf_SPECIAL)) {
7912 OP *first = cBINOPo->op_first;
7913 OP *second = first->op_sibling;
7915 /* Implicitly take a reference to an array or hash */
7916 first->op_sibling = NULL;
7917 first = cBINOPo->op_first = ref_array_or_hash(first);
7918 second = first->op_sibling = ref_array_or_hash(second);
7920 /* Implicitly take a reference to a regular expression */
7921 if (first->op_type == OP_MATCH) {
7922 first->op_type = OP_QR;
7923 first->op_ppaddr = PL_ppaddr[OP_QR];
7925 if (second->op_type == OP_MATCH) {
7926 second->op_type = OP_QR;
7927 second->op_ppaddr = PL_ppaddr[OP_QR];
7936 Perl_ck_sassign(pTHX_ OP *o)
7939 OP * const kid = cLISTOPo->op_first;
7941 PERL_ARGS_ASSERT_CK_SASSIGN;
7943 /* has a disposable target? */
7944 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7945 && !(kid->op_flags & OPf_STACKED)
7946 /* Cannot steal the second time! */
7947 && !(kid->op_private & OPpTARGET_MY)
7948 /* Keep the full thing for madskills */
7952 OP * const kkid = kid->op_sibling;
7954 /* Can just relocate the target. */
7955 if (kkid && kkid->op_type == OP_PADSV
7956 && !(kkid->op_private & OPpLVAL_INTRO))
7958 kid->op_targ = kkid->op_targ;
7960 /* Now we do not need PADSV and SASSIGN. */
7961 kid->op_sibling = o->op_sibling; /* NULL */
7962 cLISTOPo->op_first = NULL;
7965 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7969 if (kid->op_sibling) {
7970 OP *kkid = kid->op_sibling;
7971 /* For state variable assignment, kkid is a list op whose op_last
7973 if ((kkid->op_type == OP_PADSV ||
7974 (kkid->op_type == OP_LIST &&
7975 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
7978 && (kkid->op_private & OPpLVAL_INTRO)
7979 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7980 const PADOFFSET target = kkid->op_targ;
7981 OP *const other = newOP(OP_PADSV,
7983 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7984 OP *const first = newOP(OP_NULL, 0);
7985 OP *const nullop = newCONDOP(0, first, o, other);
7986 OP *const condop = first->op_next;
7987 /* hijacking PADSTALE for uninitialized state variables */
7988 SvPADSTALE_on(PAD_SVl(target));
7990 condop->op_type = OP_ONCE;
7991 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7992 condop->op_targ = target;
7993 other->op_targ = target;
7995 /* Because we change the type of the op here, we will skip the
7996 assignment binop->op_last = binop->op_first->op_sibling; at the
7997 end of Perl_newBINOP(). So need to do it here. */
7998 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8007 Perl_ck_match(pTHX_ OP *o)
8011 PERL_ARGS_ASSERT_CK_MATCH;
8013 if (o->op_type != OP_QR && PL_compcv) {
8014 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
8015 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8016 o->op_targ = offset;
8017 o->op_private |= OPpTARGET_MY;
8020 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8021 o->op_private |= OPpRUNTIME;
8026 Perl_ck_method(pTHX_ OP *o)
8028 OP * const kid = cUNOPo->op_first;
8030 PERL_ARGS_ASSERT_CK_METHOD;
8032 if (kid->op_type == OP_CONST) {
8033 SV* sv = kSVOP->op_sv;
8034 const char * const method = SvPVX_const(sv);
8035 if (!(strchr(method, ':') || strchr(method, '\''))) {
8037 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8038 sv = newSVpvn_share(method, SvCUR(sv), 0);
8041 kSVOP->op_sv = NULL;
8043 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8045 op_getmad(o,cmop,'O');
8056 Perl_ck_null(pTHX_ OP *o)
8058 PERL_ARGS_ASSERT_CK_NULL;
8059 PERL_UNUSED_CONTEXT;
8064 Perl_ck_open(pTHX_ OP *o)
8067 HV * const table = GvHV(PL_hintgv);
8069 PERL_ARGS_ASSERT_CK_OPEN;
8072 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8075 const char *d = SvPV_const(*svp, len);
8076 const I32 mode = mode_from_discipline(d, len);
8077 if (mode & O_BINARY)
8078 o->op_private |= OPpOPEN_IN_RAW;
8079 else if (mode & O_TEXT)
8080 o->op_private |= OPpOPEN_IN_CRLF;
8083 svp = hv_fetchs(table, "open_OUT", FALSE);
8086 const char *d = SvPV_const(*svp, len);
8087 const I32 mode = mode_from_discipline(d, len);
8088 if (mode & O_BINARY)
8089 o->op_private |= OPpOPEN_OUT_RAW;
8090 else if (mode & O_TEXT)
8091 o->op_private |= OPpOPEN_OUT_CRLF;
8094 if (o->op_type == OP_BACKTICK) {
8095 if (!(o->op_flags & OPf_KIDS)) {
8096 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8098 op_getmad(o,newop,'O');
8107 /* In case of three-arg dup open remove strictness
8108 * from the last arg if it is a bareword. */
8109 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8110 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8114 if ((last->op_type == OP_CONST) && /* The bareword. */
8115 (last->op_private & OPpCONST_BARE) &&
8116 (last->op_private & OPpCONST_STRICT) &&
8117 (oa = first->op_sibling) && /* The fh. */
8118 (oa = oa->op_sibling) && /* The mode. */
8119 (oa->op_type == OP_CONST) &&
8120 SvPOK(((SVOP*)oa)->op_sv) &&
8121 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8122 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8123 (last == oa->op_sibling)) /* The bareword. */
8124 last->op_private &= ~OPpCONST_STRICT;
8130 Perl_ck_repeat(pTHX_ OP *o)
8132 PERL_ARGS_ASSERT_CK_REPEAT;
8134 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8135 o->op_private |= OPpREPEAT_DOLIST;
8136 cBINOPo->op_first = force_list(cBINOPo->op_first);
8144 Perl_ck_require(pTHX_ OP *o)
8149 PERL_ARGS_ASSERT_CK_REQUIRE;
8151 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8152 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8154 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8155 SV * const sv = kid->op_sv;
8156 U32 was_readonly = SvREADONLY(sv);
8163 sv_force_normal_flags(sv, 0);
8164 assert(!SvREADONLY(sv));
8174 for (; s < end; s++) {
8175 if (*s == ':' && s[1] == ':') {
8177 Move(s+2, s+1, end - s - 1, char);
8182 sv_catpvs(sv, ".pm");
8183 SvFLAGS(sv) |= was_readonly;
8187 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8188 /* handle override, if any */
8189 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8190 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8191 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8192 gv = gvp ? *gvp : NULL;
8196 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8197 OP * const kid = cUNOPo->op_first;
8200 cUNOPo->op_first = 0;
8204 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8205 op_append_elem(OP_LIST, kid,
8206 scalar(newUNOP(OP_RV2CV, 0,
8209 op_getmad(o,newop,'O');
8213 return scalar(ck_fun(o));
8217 Perl_ck_return(pTHX_ OP *o)
8222 PERL_ARGS_ASSERT_CK_RETURN;
8224 kid = cLISTOPo->op_first->op_sibling;
8225 if (CvLVALUE(PL_compcv)) {
8226 for (; kid; kid = kid->op_sibling)
8227 op_lvalue(kid, OP_LEAVESUBLV);
8234 Perl_ck_select(pTHX_ OP *o)
8239 PERL_ARGS_ASSERT_CK_SELECT;
8241 if (o->op_flags & OPf_KIDS) {
8242 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8243 if (kid && kid->op_sibling) {
8244 o->op_type = OP_SSELECT;
8245 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8247 return fold_constants(o);
8251 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8252 if (kid && kid->op_type == OP_RV2GV)
8253 kid->op_private &= ~HINT_STRICT_REFS;
8258 Perl_ck_shift(pTHX_ OP *o)
8261 const I32 type = o->op_type;
8263 PERL_ARGS_ASSERT_CK_SHIFT;
8265 if (!(o->op_flags & OPf_KIDS)) {
8268 if (!CvUNIQUE(PL_compcv)) {
8269 o->op_flags |= OPf_SPECIAL;
8273 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8276 OP * const oldo = o;
8277 o = newUNOP(type, 0, scalar(argop));
8278 op_getmad(oldo,o,'O');
8283 return newUNOP(type, 0, scalar(argop));
8286 return scalar(ck_fun(o));
8290 Perl_ck_sort(pTHX_ OP *o)
8295 PERL_ARGS_ASSERT_CK_SORT;
8297 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8298 HV * const hinthv = GvHV(PL_hintgv);
8300 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8302 const I32 sorthints = (I32)SvIV(*svp);
8303 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8304 o->op_private |= OPpSORT_QSORT;
8305 if ((sorthints & HINT_SORT_STABLE) != 0)
8306 o->op_private |= OPpSORT_STABLE;
8311 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8313 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8314 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8316 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8318 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8320 if (kid->op_type == OP_SCOPE) {
8324 else if (kid->op_type == OP_LEAVE) {
8325 if (o->op_type == OP_SORT) {
8326 op_null(kid); /* wipe out leave */
8329 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8330 if (k->op_next == kid)
8332 /* don't descend into loops */
8333 else if (k->op_type == OP_ENTERLOOP
8334 || k->op_type == OP_ENTERITER)
8336 k = cLOOPx(k)->op_lastop;
8341 kid->op_next = 0; /* just disconnect the leave */
8342 k = kLISTOP->op_first;
8347 if (o->op_type == OP_SORT) {
8348 /* provide scalar context for comparison function/block */
8354 o->op_flags |= OPf_SPECIAL;
8356 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8359 firstkid = firstkid->op_sibling;
8362 /* provide list context for arguments */
8363 if (o->op_type == OP_SORT)
8370 S_simplify_sort(pTHX_ OP *o)
8373 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8379 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8381 if (!(o->op_flags & OPf_STACKED))
8383 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8384 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8385 kid = kUNOP->op_first; /* get past null */
8386 if (kid->op_type != OP_SCOPE)
8388 kid = kLISTOP->op_last; /* get past scope */
8389 switch(kid->op_type) {
8397 k = kid; /* remember this node*/
8398 if (kBINOP->op_first->op_type != OP_RV2SV)
8400 kid = kBINOP->op_first; /* get past cmp */
8401 if (kUNOP->op_first->op_type != OP_GV)
8403 kid = kUNOP->op_first; /* get past rv2sv */
8405 if (GvSTASH(gv) != PL_curstash)
8407 gvname = GvNAME(gv);
8408 if (*gvname == 'a' && gvname[1] == '\0')
8410 else if (*gvname == 'b' && gvname[1] == '\0')
8415 kid = k; /* back to cmp */
8416 if (kBINOP->op_last->op_type != OP_RV2SV)
8418 kid = kBINOP->op_last; /* down to 2nd arg */
8419 if (kUNOP->op_first->op_type != OP_GV)
8421 kid = kUNOP->op_first; /* get past rv2sv */
8423 if (GvSTASH(gv) != PL_curstash)
8425 gvname = GvNAME(gv);
8427 ? !(*gvname == 'a' && gvname[1] == '\0')
8428 : !(*gvname == 'b' && gvname[1] == '\0'))
8430 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8432 o->op_private |= OPpSORT_DESCEND;
8433 if (k->op_type == OP_NCMP)
8434 o->op_private |= OPpSORT_NUMERIC;
8435 if (k->op_type == OP_I_NCMP)
8436 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8437 kid = cLISTOPo->op_first->op_sibling;
8438 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8440 op_getmad(kid,o,'S'); /* then delete it */
8442 op_free(kid); /* then delete it */
8447 Perl_ck_split(pTHX_ OP *o)
8452 PERL_ARGS_ASSERT_CK_SPLIT;
8454 if (o->op_flags & OPf_STACKED)
8455 return no_fh_allowed(o);
8457 kid = cLISTOPo->op_first;
8458 if (kid->op_type != OP_NULL)
8459 Perl_croak(aTHX_ "panic: ck_split");
8460 kid = kid->op_sibling;
8461 op_free(cLISTOPo->op_first);
8463 cLISTOPo->op_first = kid;
8465 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8466 cLISTOPo->op_last = kid; /* There was only one element previously */
8469 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8470 OP * const sibl = kid->op_sibling;
8471 kid->op_sibling = 0;
8472 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8473 if (cLISTOPo->op_first == cLISTOPo->op_last)
8474 cLISTOPo->op_last = kid;
8475 cLISTOPo->op_first = kid;
8476 kid->op_sibling = sibl;
8479 kid->op_type = OP_PUSHRE;
8480 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8482 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8483 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8484 "Use of /g modifier is meaningless in split");
8487 if (!kid->op_sibling)
8488 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8490 kid = kid->op_sibling;
8493 if (!kid->op_sibling)
8494 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8495 assert(kid->op_sibling);
8497 kid = kid->op_sibling;
8500 if (kid->op_sibling)
8501 return too_many_arguments(o,OP_DESC(o));
8507 Perl_ck_join(pTHX_ OP *o)
8509 const OP * const kid = cLISTOPo->op_first->op_sibling;
8511 PERL_ARGS_ASSERT_CK_JOIN;
8513 if (kid && kid->op_type == OP_MATCH) {
8514 if (ckWARN(WARN_SYNTAX)) {
8515 const REGEXP *re = PM_GETRE(kPMOP);
8516 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8517 const STRLEN len = re ? RX_PRELEN(re) : 6;
8518 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8519 "/%.*s/ should probably be written as \"%.*s\"",
8520 (int)len, pmstr, (int)len, pmstr);
8527 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8529 Examines an op, which is expected to identify a subroutine at runtime,
8530 and attempts to determine at compile time which subroutine it identifies.
8531 This is normally used during Perl compilation to determine whether
8532 a prototype can be applied to a function call. I<cvop> is the op
8533 being considered, normally an C<rv2cv> op. A pointer to the identified
8534 subroutine is returned, if it could be determined statically, and a null
8535 pointer is returned if it was not possible to determine statically.
8537 Currently, the subroutine can be identified statically if the RV that the
8538 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8539 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8540 suitable if the constant value must be an RV pointing to a CV. Details of
8541 this process may change in future versions of Perl. If the C<rv2cv> op
8542 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8543 the subroutine statically: this flag is used to suppress compile-time
8544 magic on a subroutine call, forcing it to use default runtime behaviour.
8546 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8547 of a GV reference is modified. If a GV was examined and its CV slot was
8548 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8549 If the op is not optimised away, and the CV slot is later populated with
8550 a subroutine having a prototype, that flag eventually triggers the warning
8551 "called too early to check prototype".
8553 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8554 of returning a pointer to the subroutine it returns a pointer to the
8555 GV giving the most appropriate name for the subroutine in this context.
8556 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8557 (C<CvANON>) subroutine that is referenced through a GV it will be the
8558 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8559 A null pointer is returned as usual if there is no statically-determinable
8566 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8571 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8572 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8573 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8574 if (cvop->op_type != OP_RV2CV)
8576 if (cvop->op_private & OPpENTERSUB_AMPER)
8578 if (!(cvop->op_flags & OPf_KIDS))
8580 rvop = cUNOPx(cvop)->op_first;
8581 switch (rvop->op_type) {
8583 gv = cGVOPx_gv(rvop);
8586 if (flags & RV2CVOPCV_MARK_EARLY)
8587 rvop->op_private |= OPpEARLY_CV;
8592 SV *rv = cSVOPx_sv(rvop);
8602 if (SvTYPE((SV*)cv) != SVt_PVCV)
8604 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8605 if (!CvANON(cv) || !gv)
8614 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8616 Performs the default fixup of the arguments part of an C<entersub>
8617 op tree. This consists of applying list context to each of the
8618 argument ops. This is the standard treatment used on a call marked
8619 with C<&>, or a method call, or a call through a subroutine reference,
8620 or any other call where the callee can't be identified at compile time,
8621 or a call where the callee has no prototype.
8627 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8630 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8631 aop = cUNOPx(entersubop)->op_first;
8632 if (!aop->op_sibling)
8633 aop = cUNOPx(aop)->op_first;
8634 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8635 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8637 op_lvalue(aop, OP_ENTERSUB);
8644 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8646 Performs the fixup of the arguments part of an C<entersub> op tree
8647 based on a subroutine prototype. This makes various modifications to
8648 the argument ops, from applying context up to inserting C<refgen> ops,
8649 and checking the number and syntactic types of arguments, as directed by
8650 the prototype. This is the standard treatment used on a subroutine call,
8651 not marked with C<&>, where the callee can be identified at compile time
8652 and has a prototype.
8654 I<protosv> supplies the subroutine prototype to be applied to the call.
8655 It may be a normal defined scalar, of which the string value will be used.
8656 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8657 that has been cast to C<SV*>) which has a prototype. The prototype
8658 supplied, in whichever form, does not need to match the actual callee
8659 referenced by the op tree.
8661 If the argument ops disagree with the prototype, for example by having
8662 an unacceptable number of arguments, a valid op tree is returned anyway.
8663 The error is reflected in the parser state, normally resulting in a single
8664 exception at the top level of parsing which covers all the compilation
8665 errors that occurred. In the error message, the callee is referred to
8666 by the name defined by the I<namegv> parameter.
8672 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8675 const char *proto, *proto_end;
8676 OP *aop, *prev, *cvop;
8679 I32 contextclass = 0;
8680 const char *e = NULL;
8681 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8682 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8683 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8684 proto = SvPV(protosv, proto_len);
8685 proto_end = proto + proto_len;
8686 aop = cUNOPx(entersubop)->op_first;
8687 if (!aop->op_sibling)
8688 aop = cUNOPx(aop)->op_first;
8690 aop = aop->op_sibling;
8691 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8692 while (aop != cvop) {
8694 if (PL_madskills && aop->op_type == OP_STUB) {
8695 aop = aop->op_sibling;
8698 if (PL_madskills && aop->op_type == OP_NULL)
8699 o3 = ((UNOP*)aop)->op_first;
8703 if (proto >= proto_end)
8704 return too_many_arguments(entersubop, gv_ename(namegv));
8712 /* _ must be at the end */
8713 if (proto[1] && proto[1] != ';')
8728 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8730 arg == 1 ? "block or sub {}" : "sub {}",
8731 gv_ename(namegv), o3);
8734 /* '*' allows any scalar type, including bareword */
8737 if (o3->op_type == OP_RV2GV)
8738 goto wrapref; /* autoconvert GLOB -> GLOBref */
8739 else if (o3->op_type == OP_CONST)
8740 o3->op_private &= ~OPpCONST_STRICT;
8741 else if (o3->op_type == OP_ENTERSUB) {
8742 /* accidental subroutine, revert to bareword */
8743 OP *gvop = ((UNOP*)o3)->op_first;
8744 if (gvop && gvop->op_type == OP_NULL) {
8745 gvop = ((UNOP*)gvop)->op_first;
8747 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8750 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8751 (gvop = ((UNOP*)gvop)->op_first) &&
8752 gvop->op_type == OP_GV)
8754 GV * const gv = cGVOPx_gv(gvop);
8755 OP * const sibling = aop->op_sibling;
8756 SV * const n = newSVpvs("");
8758 OP * const oldaop = aop;
8762 gv_fullname4(n, gv, "", FALSE);
8763 aop = newSVOP(OP_CONST, 0, n);
8764 op_getmad(oldaop,aop,'O');
8765 prev->op_sibling = aop;
8766 aop->op_sibling = sibling;
8776 if (o3->op_type == OP_RV2AV ||
8777 o3->op_type == OP_PADAV ||
8778 o3->op_type == OP_RV2HV ||
8779 o3->op_type == OP_PADHV
8794 if (contextclass++ == 0) {
8795 e = strchr(proto, ']');
8796 if (!e || e == proto)
8805 const char *p = proto;
8806 const char *const end = proto;
8809 /* \[$] accepts any scalar lvalue */
8811 && Perl_op_lvalue_flags(aTHX_
8813 OP_READ, /* not entersub */
8816 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8818 gv_ename(namegv), o3);
8823 if (o3->op_type == OP_RV2GV)
8826 bad_type(arg, "symbol", gv_ename(namegv), o3);
8829 if (o3->op_type == OP_ENTERSUB)
8832 bad_type(arg, "subroutine entry", gv_ename(namegv),
8836 if (o3->op_type == OP_RV2SV ||
8837 o3->op_type == OP_PADSV ||
8838 o3->op_type == OP_HELEM ||
8839 o3->op_type == OP_AELEM)
8841 if (!contextclass) {
8842 /* \$ accepts any scalar lvalue */
8843 if (Perl_op_lvalue_flags(aTHX_
8845 OP_READ, /* not entersub */
8848 bad_type(arg, "scalar", gv_ename(namegv), o3);
8852 if (o3->op_type == OP_RV2AV ||
8853 o3->op_type == OP_PADAV)
8856 bad_type(arg, "array", gv_ename(namegv), o3);
8859 if (o3->op_type == OP_RV2HV ||
8860 o3->op_type == OP_PADHV)
8863 bad_type(arg, "hash", gv_ename(namegv), o3);
8867 OP* const kid = aop;
8868 OP* const sib = kid->op_sibling;
8869 kid->op_sibling = 0;
8870 aop = newUNOP(OP_REFGEN, 0, kid);
8871 aop->op_sibling = sib;
8872 prev->op_sibling = aop;
8874 if (contextclass && e) {
8889 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8890 gv_ename(namegv), SVfARG(protosv));
8893 op_lvalue(aop, OP_ENTERSUB);
8895 aop = aop->op_sibling;
8897 if (aop == cvop && *proto == '_') {
8898 /* generate an access to $_ */
8900 aop->op_sibling = prev->op_sibling;
8901 prev->op_sibling = aop; /* instead of cvop */
8903 if (!optional && proto_end > proto &&
8904 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8905 return too_few_arguments(entersubop, gv_ename(namegv));
8910 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8912 Performs the fixup of the arguments part of an C<entersub> op tree either
8913 based on a subroutine prototype or using default list-context processing.
8914 This is the standard treatment used on a subroutine call, not marked
8915 with C<&>, where the callee can be identified at compile time.
8917 I<protosv> supplies the subroutine prototype to be applied to the call,
8918 or indicates that there is no prototype. It may be a normal scalar,
8919 in which case if it is defined then the string value will be used
8920 as a prototype, and if it is undefined then there is no prototype.
8921 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8922 that has been cast to C<SV*>), of which the prototype will be used if it
8923 has one. The prototype (or lack thereof) supplied, in whichever form,
8924 does not need to match the actual callee referenced by the op tree.
8926 If the argument ops disagree with the prototype, for example by having
8927 an unacceptable number of arguments, a valid op tree is returned anyway.
8928 The error is reflected in the parser state, normally resulting in a single
8929 exception at the top level of parsing which covers all the compilation
8930 errors that occurred. In the error message, the callee is referred to
8931 by the name defined by the I<namegv> parameter.
8937 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8938 GV *namegv, SV *protosv)
8940 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8941 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8942 return ck_entersub_args_proto(entersubop, namegv, protosv);
8944 return ck_entersub_args_list(entersubop);
8948 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8950 Retrieves the function that will be used to fix up a call to I<cv>.
8951 Specifically, the function is applied to an C<entersub> op tree for a
8952 subroutine call, not marked with C<&>, where the callee can be identified
8953 at compile time as I<cv>.
8955 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8956 argument for it is returned in I<*ckobj_p>. The function is intended
8957 to be called in this manner:
8959 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8961 In this call, I<entersubop> is a pointer to the C<entersub> op,
8962 which may be replaced by the check function, and I<namegv> is a GV
8963 supplying the name that should be used by the check function to refer
8964 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8965 It is permitted to apply the check function in non-standard situations,
8966 such as to a call to a different subroutine or to a method call.
8968 By default, the function is
8969 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8970 and the SV parameter is I<cv> itself. This implements standard
8971 prototype processing. It can be changed, for a particular subroutine,
8972 by L</cv_set_call_checker>.
8978 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8981 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8982 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8984 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8985 *ckobj_p = callmg->mg_obj;
8987 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8993 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8995 Sets the function that will be used to fix up a call to I<cv>.
8996 Specifically, the function is applied to an C<entersub> op tree for a
8997 subroutine call, not marked with C<&>, where the callee can be identified
8998 at compile time as I<cv>.
9000 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9001 for it is supplied in I<ckobj>. The function is intended to be called
9004 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9006 In this call, I<entersubop> is a pointer to the C<entersub> op,
9007 which may be replaced by the check function, and I<namegv> is a GV
9008 supplying the name that should be used by the check function to refer
9009 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9010 It is permitted to apply the check function in non-standard situations,
9011 such as to a call to a different subroutine or to a method call.
9013 The current setting for a particular CV can be retrieved by
9014 L</cv_get_call_checker>.
9020 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9022 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9023 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9024 if (SvMAGICAL((SV*)cv))
9025 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9028 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9029 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9030 if (callmg->mg_flags & MGf_REFCOUNTED) {
9031 SvREFCNT_dec(callmg->mg_obj);
9032 callmg->mg_flags &= ~MGf_REFCOUNTED;
9034 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9035 callmg->mg_obj = ckobj;
9036 if (ckobj != (SV*)cv) {
9037 SvREFCNT_inc_simple_void_NN(ckobj);
9038 callmg->mg_flags |= MGf_REFCOUNTED;
9044 Perl_ck_subr(pTHX_ OP *o)
9050 PERL_ARGS_ASSERT_CK_SUBR;
9052 aop = cUNOPx(o)->op_first;
9053 if (!aop->op_sibling)
9054 aop = cUNOPx(aop)->op_first;
9055 aop = aop->op_sibling;
9056 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9057 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9058 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9060 o->op_private &= ~1;
9061 o->op_private |= OPpENTERSUB_HASTARG;
9062 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9063 if (PERLDB_SUB && PL_curstash != PL_debstash)
9064 o->op_private |= OPpENTERSUB_DB;
9065 if (cvop->op_type == OP_RV2CV) {
9066 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9068 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9069 if (aop->op_type == OP_CONST)
9070 aop->op_private &= ~OPpCONST_STRICT;
9071 else if (aop->op_type == OP_LIST) {
9072 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9073 if (sib && sib->op_type == OP_CONST)
9074 sib->op_private &= ~OPpCONST_STRICT;
9079 return ck_entersub_args_list(o);
9081 Perl_call_checker ckfun;
9083 cv_get_call_checker(cv, &ckfun, &ckobj);
9084 return ckfun(aTHX_ o, namegv, ckobj);
9089 Perl_ck_svconst(pTHX_ OP *o)
9091 PERL_ARGS_ASSERT_CK_SVCONST;
9092 PERL_UNUSED_CONTEXT;
9093 SvREADONLY_on(cSVOPo->op_sv);
9098 Perl_ck_chdir(pTHX_ OP *o)
9100 PERL_ARGS_ASSERT_CK_CHDIR;
9101 if (o->op_flags & OPf_KIDS) {
9102 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9104 if (kid && kid->op_type == OP_CONST &&
9105 (kid->op_private & OPpCONST_BARE))
9107 o->op_flags |= OPf_SPECIAL;
9108 kid->op_private &= ~OPpCONST_STRICT;
9115 Perl_ck_trunc(pTHX_ OP *o)
9117 PERL_ARGS_ASSERT_CK_TRUNC;
9119 if (o->op_flags & OPf_KIDS) {
9120 SVOP *kid = (SVOP*)cUNOPo->op_first;
9122 if (kid->op_type == OP_NULL)
9123 kid = (SVOP*)kid->op_sibling;
9124 if (kid && kid->op_type == OP_CONST &&
9125 (kid->op_private & OPpCONST_BARE))
9127 o->op_flags |= OPf_SPECIAL;
9128 kid->op_private &= ~OPpCONST_STRICT;
9135 Perl_ck_unpack(pTHX_ OP *o)
9137 OP *kid = cLISTOPo->op_first;
9139 PERL_ARGS_ASSERT_CK_UNPACK;
9141 if (kid->op_sibling) {
9142 kid = kid->op_sibling;
9143 if (!kid->op_sibling)
9144 kid->op_sibling = newDEFSVOP();
9150 Perl_ck_substr(pTHX_ OP *o)
9152 PERL_ARGS_ASSERT_CK_SUBSTR;
9155 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9156 OP *kid = cLISTOPo->op_first;
9158 if (kid->op_type == OP_NULL)
9159 kid = kid->op_sibling;
9161 kid->op_flags |= OPf_MOD;
9168 Perl_ck_each(pTHX_ OP *o)
9171 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9172 const unsigned orig_type = o->op_type;
9173 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9174 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9175 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9176 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9178 PERL_ARGS_ASSERT_CK_EACH;
9181 switch (kid->op_type) {
9187 CHANGE_TYPE(o, array_type);
9190 if (kid->op_private == OPpCONST_BARE
9191 || !SvROK(cSVOPx_sv(kid))
9192 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9193 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9195 /* we let ck_fun handle it */
9198 CHANGE_TYPE(o, ref_type);
9202 /* if treating as a reference, defer additional checks to runtime */
9203 return o->op_type == ref_type ? o : ck_fun(o);
9206 /* caller is supposed to assign the return to the
9207 container of the rep_op var */
9209 S_opt_scalarhv(pTHX_ OP *rep_op) {
9213 PERL_ARGS_ASSERT_OPT_SCALARHV;
9215 NewOp(1101, unop, 1, UNOP);
9216 unop->op_type = (OPCODE)OP_BOOLKEYS;
9217 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9218 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9219 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9220 unop->op_first = rep_op;
9221 unop->op_next = rep_op->op_next;
9222 rep_op->op_next = (OP*)unop;
9223 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9224 unop->op_sibling = rep_op->op_sibling;
9225 rep_op->op_sibling = NULL;
9226 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9227 if (rep_op->op_type == OP_PADHV) {
9228 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9229 rep_op->op_flags |= OPf_WANT_LIST;
9234 /* Checks if o acts as an in-place operator on an array. oright points to the
9235 * beginning of the right-hand side. Returns the left-hand side of the
9236 * assignment if o acts in-place, or NULL otherwise. */
9239 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9243 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9246 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9247 || oright->op_next != o
9248 || (oright->op_private & OPpLVAL_INTRO)
9252 /* o2 follows the chain of op_nexts through the LHS of the
9253 * assign (if any) to the aassign op itself */
9255 if (!o2 || o2->op_type != OP_NULL)
9258 if (!o2 || o2->op_type != OP_PUSHMARK)
9261 if (o2 && o2->op_type == OP_GV)
9264 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9265 || (o2->op_private & OPpLVAL_INTRO)
9270 if (!o2 || o2->op_type != OP_NULL)
9273 if (!o2 || o2->op_type != OP_AASSIGN
9274 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9277 /* check that the sort is the first arg on RHS of assign */
9279 o2 = cUNOPx(o2)->op_first;
9280 if (!o2 || o2->op_type != OP_NULL)
9282 o2 = cUNOPx(o2)->op_first;
9283 if (!o2 || o2->op_type != OP_PUSHMARK)
9285 if (o2->op_sibling != o)
9288 /* check the array is the same on both sides */
9289 if (oleft->op_type == OP_RV2AV) {
9290 if (oright->op_type != OP_RV2AV
9291 || !cUNOPx(oright)->op_first
9292 || cUNOPx(oright)->op_first->op_type != OP_GV
9293 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9294 cGVOPx_gv(cUNOPx(oright)->op_first)
9298 else if (oright->op_type != OP_PADAV
9299 || oright->op_targ != oleft->op_targ
9306 /* A peephole optimizer. We visit the ops in the order they're to execute.
9307 * See the comments at the top of this file for more details about when
9308 * peep() is called */
9311 Perl_rpeep(pTHX_ register OP *o)
9314 register OP* oldop = NULL;
9316 if (!o || o->op_opt)
9320 SAVEVPTR(PL_curcop);
9321 for (; o; o = o->op_next) {
9322 #if defined(PERL_MAD) && defined(USE_ITHREADS)
9323 MADPROP *mp = o->op_madprop;
9325 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
9326 OP *prop_op = (OP *) mp->mad_val;
9327 /* I *think* that this is roughly the right thing to do. It
9328 seems that sometimes the optree hooked into the madprops
9329 doesn't have its next pointers set, so it's not possible to
9330 use them to locate all the OPs needing a fixup. Possibly
9331 it's a bit overkill calling LINKLIST to do this, when we
9332 could instead iterate over the OPs (without changing them)
9333 the way op_linklist does internally. However, I'm not sure
9334 if there are corner cases where we have a chain of partially
9335 linked OPs. Or even if we do, does that matter? Or should
9336 we always iterate on op_first,op_next? */
9339 if (prop_op->op_opt)
9341 prop_op->op_opt = 1;
9342 switch (prop_op->op_type) {
9345 case OP_METHOD_NAMED:
9346 /* Duplicate the "relocate sv to the pad for thread
9347 safety" code, as otherwise an opfree of this madprop
9348 in the wrong thread will free the SV to the wrong
9350 if (((SVOP *)prop_op)->op_sv) {
9351 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9352 sv_setsv(PAD_SVl(ix),((SVOP *)prop_op)->op_sv);
9353 SvREFCNT_dec(((SVOP *)prop_op)->op_sv);
9354 ((SVOP *)prop_op)->op_sv = NULL;
9358 } while ((prop_op = prop_op->op_next));
9365 /* By default, this op has now been optimised. A couple of cases below
9366 clear this again. */
9369 switch (o->op_type) {
9371 PL_curcop = ((COP*)o); /* for warnings */
9374 PL_curcop = ((COP*)o); /* for warnings */
9376 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9377 to carry two labels. For now, take the easier option, and skip
9378 this optimisation if the first NEXTSTATE has a label. */
9379 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9380 OP *nextop = o->op_next;
9381 while (nextop && nextop->op_type == OP_NULL)
9382 nextop = nextop->op_next;
9384 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9385 COP *firstcop = (COP *)o;
9386 COP *secondcop = (COP *)nextop;
9387 /* We want the COP pointed to by o (and anything else) to
9388 become the next COP down the line. */
9391 firstcop->op_next = secondcop->op_next;
9393 /* Now steal all its pointers, and duplicate the other
9395 firstcop->cop_line = secondcop->cop_line;
9397 firstcop->cop_stashpv = secondcop->cop_stashpv;
9398 firstcop->cop_file = secondcop->cop_file;
9400 firstcop->cop_stash = secondcop->cop_stash;
9401 firstcop->cop_filegv = secondcop->cop_filegv;
9403 firstcop->cop_hints = secondcop->cop_hints;
9404 firstcop->cop_seq = secondcop->cop_seq;
9405 firstcop->cop_warnings = secondcop->cop_warnings;
9406 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9409 secondcop->cop_stashpv = NULL;
9410 secondcop->cop_file = NULL;
9412 secondcop->cop_stash = NULL;
9413 secondcop->cop_filegv = NULL;
9415 secondcop->cop_warnings = NULL;
9416 secondcop->cop_hints_hash = NULL;
9418 /* If we use op_null(), and hence leave an ex-COP, some
9419 warnings are misreported. For example, the compile-time
9420 error in 'use strict; no strict refs;' */
9421 secondcop->op_type = OP_NULL;
9422 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9428 if (cSVOPo->op_private & OPpCONST_STRICT)
9429 no_bareword_allowed(o);
9432 case OP_METHOD_NAMED:
9433 /* Relocate sv to the pad for thread safety.
9434 * Despite being a "constant", the SV is written to,
9435 * for reference counts, sv_upgrade() etc. */
9437 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9438 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9439 /* If op_sv is already a PADTMP then it is being used by
9440 * some pad, so make a copy. */
9441 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9442 SvREADONLY_on(PAD_SVl(ix));
9443 SvREFCNT_dec(cSVOPo->op_sv);
9445 else if (o->op_type != OP_METHOD_NAMED
9446 && cSVOPo->op_sv == &PL_sv_undef) {
9447 /* PL_sv_undef is hack - it's unsafe to store it in the
9448 AV that is the pad, because av_fetch treats values of
9449 PL_sv_undef as a "free" AV entry and will merrily
9450 replace them with a new SV, causing pad_alloc to think
9451 that this pad slot is free. (When, clearly, it is not)
9453 SvOK_off(PAD_SVl(ix));
9454 SvPADTMP_on(PAD_SVl(ix));
9455 SvREADONLY_on(PAD_SVl(ix));
9458 SvREFCNT_dec(PAD_SVl(ix));
9459 SvPADTMP_on(cSVOPo->op_sv);
9460 PAD_SETSV(ix, cSVOPo->op_sv);
9461 /* XXX I don't know how this isn't readonly already. */
9462 SvREADONLY_on(PAD_SVl(ix));
9464 cSVOPo->op_sv = NULL;
9471 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9472 if (o->op_next->op_private & OPpTARGET_MY) {
9473 if (o->op_flags & OPf_STACKED) /* chained concats */
9474 break; /* ignore_optimization */
9476 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9477 o->op_targ = o->op_next->op_targ;
9478 o->op_next->op_targ = 0;
9479 o->op_private |= OPpTARGET_MY;
9482 op_null(o->op_next);
9486 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9487 break; /* Scalar stub must produce undef. List stub is noop */
9491 if (o->op_targ == OP_NEXTSTATE
9492 || o->op_targ == OP_DBSTATE)
9494 PL_curcop = ((COP*)o);
9496 /* XXX: We avoid setting op_seq here to prevent later calls
9497 to rpeep() from mistakenly concluding that optimisation
9498 has already occurred. This doesn't fix the real problem,
9499 though (See 20010220.007). AMS 20010719 */
9500 /* op_seq functionality is now replaced by op_opt */
9507 if (oldop && o->op_next) {
9508 oldop->op_next = o->op_next;
9516 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9517 OP* const pop = (o->op_type == OP_PADAV) ?
9518 o->op_next : o->op_next->op_next;
9520 if (pop && pop->op_type == OP_CONST &&
9521 ((PL_op = pop->op_next)) &&
9522 pop->op_next->op_type == OP_AELEM &&
9523 !(pop->op_next->op_private &
9524 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9525 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9530 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9531 no_bareword_allowed(pop);
9532 if (o->op_type == OP_GV)
9533 op_null(o->op_next);
9534 op_null(pop->op_next);
9536 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9537 o->op_next = pop->op_next->op_next;
9538 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9539 o->op_private = (U8)i;
9540 if (o->op_type == OP_GV) {
9543 o->op_type = OP_AELEMFAST;
9546 o->op_type = OP_AELEMFAST_LEX;
9551 if (o->op_next->op_type == OP_RV2SV) {
9552 if (!(o->op_next->op_private & OPpDEREF)) {
9553 op_null(o->op_next);
9554 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9556 o->op_next = o->op_next->op_next;
9557 o->op_type = OP_GVSV;
9558 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9561 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9562 GV * const gv = cGVOPo_gv;
9563 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9564 /* XXX could check prototype here instead of just carping */
9565 SV * const sv = sv_newmortal();
9566 gv_efullname3(sv, gv, NULL);
9567 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9568 "%"SVf"() called too early to check prototype",
9572 else if (o->op_next->op_type == OP_READLINE
9573 && o->op_next->op_next->op_type == OP_CONCAT
9574 && (o->op_next->op_next->op_flags & OPf_STACKED))
9576 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9577 o->op_type = OP_RCATLINE;
9578 o->op_flags |= OPf_STACKED;
9579 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9580 op_null(o->op_next->op_next);
9581 op_null(o->op_next);
9591 fop = cUNOP->op_first;
9599 fop = cLOGOP->op_first;
9600 sop = fop->op_sibling;
9601 while (cLOGOP->op_other->op_type == OP_NULL)
9602 cLOGOP->op_other = cLOGOP->op_other->op_next;
9603 CALL_RPEEP(cLOGOP->op_other);
9607 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9609 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9614 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9615 while (nop && nop->op_next) {
9616 switch (nop->op_next->op_type) {
9621 lop = nop = nop->op_next;
9632 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9633 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9634 cLOGOP->op_first = opt_scalarhv(fop);
9635 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9636 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9652 while (cLOGOP->op_other->op_type == OP_NULL)
9653 cLOGOP->op_other = cLOGOP->op_other->op_next;
9654 CALL_RPEEP(cLOGOP->op_other);
9659 while (cLOOP->op_redoop->op_type == OP_NULL)
9660 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9661 CALL_RPEEP(cLOOP->op_redoop);
9662 while (cLOOP->op_nextop->op_type == OP_NULL)
9663 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9664 CALL_RPEEP(cLOOP->op_nextop);
9665 while (cLOOP->op_lastop->op_type == OP_NULL)
9666 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9667 CALL_RPEEP(cLOOP->op_lastop);
9671 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9672 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9673 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9674 cPMOP->op_pmstashstartu.op_pmreplstart
9675 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9676 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9680 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9681 && ckWARN(WARN_SYNTAX))
9683 if (o->op_next->op_sibling) {
9684 const OPCODE type = o->op_next->op_sibling->op_type;
9685 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9686 const line_t oldline = CopLINE(PL_curcop);
9687 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9688 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9689 "Statement unlikely to be reached");
9690 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9691 "\t(Maybe you meant system() when you said exec()?)\n");
9692 CopLINE_set(PL_curcop, oldline);
9703 const char *key = NULL;
9706 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9709 /* Make the CONST have a shared SV */
9710 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9711 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
9712 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
9713 key = SvPV_const(sv, keylen);
9714 lexname = newSVpvn_share(key,
9715 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9721 if ((o->op_private & (OPpLVAL_INTRO)))
9724 rop = (UNOP*)((BINOP*)o)->op_first;
9725 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9727 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9728 if (!SvPAD_TYPED(lexname))
9730 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9731 if (!fields || !GvHV(*fields))
9733 key = SvPV_const(*svp, keylen);
9734 if (!hv_fetch(GvHV(*fields), key,
9735 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9737 Perl_croak(aTHX_ "No such class field \"%s\" "
9738 "in variable %s of type %s",
9739 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9752 SVOP *first_key_op, *key_op;
9754 if ((o->op_private & (OPpLVAL_INTRO))
9755 /* I bet there's always a pushmark... */
9756 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9757 /* hmmm, no optimization if list contains only one key. */
9759 rop = (UNOP*)((LISTOP*)o)->op_last;
9760 if (rop->op_type != OP_RV2HV)
9762 if (rop->op_first->op_type == OP_PADSV)
9763 /* @$hash{qw(keys here)} */
9764 rop = (UNOP*)rop->op_first;
9766 /* @{$hash}{qw(keys here)} */
9767 if (rop->op_first->op_type == OP_SCOPE
9768 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9770 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9776 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9777 if (!SvPAD_TYPED(lexname))
9779 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9780 if (!fields || !GvHV(*fields))
9782 /* Again guessing that the pushmark can be jumped over.... */
9783 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9784 ->op_first->op_sibling;
9785 for (key_op = first_key_op; key_op;
9786 key_op = (SVOP*)key_op->op_sibling) {
9787 if (key_op->op_type != OP_CONST)
9789 svp = cSVOPx_svp(key_op);
9790 key = SvPV_const(*svp, keylen);
9791 if (!hv_fetch(GvHV(*fields), key,
9792 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9794 Perl_croak(aTHX_ "No such class field \"%s\" "
9795 "in variable %s of type %s",
9796 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9807 ( oldop->op_type == OP_AELEM
9808 || oldop->op_type == OP_PADSV
9809 || oldop->op_type == OP_RV2SV
9810 || oldop->op_type == OP_RV2GV
9811 || oldop->op_type == OP_HELEM
9813 && (oldop->op_private & OPpDEREF)
9815 || ( oldop->op_type == OP_ENTERSUB
9816 && oldop->op_private & OPpENTERSUB_DEREF )
9819 o->op_private |= OPpDEREFed;
9823 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9827 /* check that RHS of sort is a single plain array */
9828 OP *oright = cUNOPo->op_first;
9829 if (!oright || oright->op_type != OP_PUSHMARK)
9832 /* reverse sort ... can be optimised. */
9833 if (!cUNOPo->op_sibling) {
9834 /* Nothing follows us on the list. */
9835 OP * const reverse = o->op_next;
9837 if (reverse->op_type == OP_REVERSE &&
9838 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9839 OP * const pushmark = cUNOPx(reverse)->op_first;
9840 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9841 && (cUNOPx(pushmark)->op_sibling == o)) {
9842 /* reverse -> pushmark -> sort */
9843 o->op_private |= OPpSORT_REVERSE;
9845 pushmark->op_next = oright->op_next;
9851 /* make @a = sort @a act in-place */
9853 oright = cUNOPx(oright)->op_sibling;
9856 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9857 oright = cUNOPx(oright)->op_sibling;
9860 oleft = is_inplace_av(o, oright);
9864 /* transfer MODishness etc from LHS arg to RHS arg */
9865 oright->op_flags = oleft->op_flags;
9866 o->op_private |= OPpSORT_INPLACE;
9868 /* excise push->gv->rv2av->null->aassign */
9869 o2 = o->op_next->op_next;
9870 op_null(o2); /* PUSHMARK */
9872 if (o2->op_type == OP_GV) {
9873 op_null(o2); /* GV */
9876 op_null(o2); /* RV2AV or PADAV */
9877 o2 = o2->op_next->op_next;
9878 op_null(o2); /* AASSIGN */
9880 o->op_next = o2->op_next;
9886 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9889 LISTOP *enter, *exlist;
9891 /* @a = reverse @a */
9892 if ((oright = cLISTOPo->op_first)
9893 && (oright->op_type == OP_PUSHMARK)
9894 && (oright = oright->op_sibling)
9895 && (oleft = is_inplace_av(o, oright))) {
9898 /* transfer MODishness etc from LHS arg to RHS arg */
9899 oright->op_flags = oleft->op_flags;
9900 o->op_private |= OPpREVERSE_INPLACE;
9902 /* excise push->gv->rv2av->null->aassign */
9903 o2 = o->op_next->op_next;
9904 op_null(o2); /* PUSHMARK */
9906 if (o2->op_type == OP_GV) {
9907 op_null(o2); /* GV */
9910 op_null(o2); /* RV2AV or PADAV */
9911 o2 = o2->op_next->op_next;
9912 op_null(o2); /* AASSIGN */
9914 o->op_next = o2->op_next;
9918 enter = (LISTOP *) o->op_next;
9921 if (enter->op_type == OP_NULL) {
9922 enter = (LISTOP *) enter->op_next;
9926 /* for $a (...) will have OP_GV then OP_RV2GV here.
9927 for (...) just has an OP_GV. */
9928 if (enter->op_type == OP_GV) {
9929 gvop = (OP *) enter;
9930 enter = (LISTOP *) enter->op_next;
9933 if (enter->op_type == OP_RV2GV) {
9934 enter = (LISTOP *) enter->op_next;
9940 if (enter->op_type != OP_ENTERITER)
9943 iter = enter->op_next;
9944 if (!iter || iter->op_type != OP_ITER)
9947 expushmark = enter->op_first;
9948 if (!expushmark || expushmark->op_type != OP_NULL
9949 || expushmark->op_targ != OP_PUSHMARK)
9952 exlist = (LISTOP *) expushmark->op_sibling;
9953 if (!exlist || exlist->op_type != OP_NULL
9954 || exlist->op_targ != OP_LIST)
9957 if (exlist->op_last != o) {
9958 /* Mmm. Was expecting to point back to this op. */
9961 theirmark = exlist->op_first;
9962 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9965 if (theirmark->op_sibling != o) {
9966 /* There's something between the mark and the reverse, eg
9967 for (1, reverse (...))
9972 ourmark = ((LISTOP *)o)->op_first;
9973 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9976 ourlast = ((LISTOP *)o)->op_last;
9977 if (!ourlast || ourlast->op_next != o)
9980 rv2av = ourmark->op_sibling;
9981 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9982 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9983 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9984 /* We're just reversing a single array. */
9985 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9986 enter->op_flags |= OPf_STACKED;
9989 /* We don't have control over who points to theirmark, so sacrifice
9991 theirmark->op_next = ourmark->op_next;
9992 theirmark->op_flags = ourmark->op_flags;
9993 ourlast->op_next = gvop ? gvop : (OP *) enter;
9996 enter->op_private |= OPpITER_REVERSED;
9997 iter->op_private |= OPpITER_REVERSED;
10004 UNOP *refgen, *rv2cv;
10007 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
10010 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
10013 rv2gv = ((BINOP *)o)->op_last;
10014 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
10017 refgen = (UNOP *)((BINOP *)o)->op_first;
10019 if (!refgen || refgen->op_type != OP_REFGEN)
10022 exlist = (LISTOP *)refgen->op_first;
10023 if (!exlist || exlist->op_type != OP_NULL
10024 || exlist->op_targ != OP_LIST)
10027 if (exlist->op_first->op_type != OP_PUSHMARK)
10030 rv2cv = (UNOP*)exlist->op_last;
10032 if (rv2cv->op_type != OP_RV2CV)
10035 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
10036 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
10037 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
10039 o->op_private |= OPpASSIGN_CV_TO_GV;
10040 rv2gv->op_private |= OPpDONT_INIT_GV;
10041 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
10049 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10050 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10055 Perl_cpeep_t cpeep =
10056 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10058 cpeep(aTHX_ o, oldop);
10069 Perl_peep(pTHX_ register OP *o)
10075 =head1 Custom Operators
10077 =for apidoc Ao||custom_op_xop
10078 Return the XOP structure for a given custom op. This function should be
10079 considered internal to OP_NAME and the other access macros: use them instead.
10085 Perl_custom_op_xop(pTHX_ const OP *o)
10091 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10093 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10094 assert(o->op_type == OP_CUSTOM);
10096 /* This is wrong. It assumes a function pointer can be cast to IV,
10097 * which isn't guaranteed, but this is what the old custom OP code
10098 * did. In principle it should be safer to Copy the bytes of the
10099 * pointer into a PV: since the new interface is hidden behind
10100 * functions, this can be changed later if necessary. */
10101 /* Change custom_op_xop if this ever happens */
10102 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10105 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10107 /* assume noone will have just registered a desc */
10108 if (!he && PL_custom_op_names &&
10109 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10114 /* XXX does all this need to be shared mem? */
10115 Newxz(xop, 1, XOP);
10116 pv = SvPV(HeVAL(he), l);
10117 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10118 if (PL_custom_op_descs &&
10119 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10121 pv = SvPV(HeVAL(he), l);
10122 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10124 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10128 if (!he) return &xop_null;
10130 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10135 =for apidoc Ao||custom_op_register
10136 Register a custom op. See L<perlguts/"Custom Operators">.
10142 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10146 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10148 /* see the comment in custom_op_xop */
10149 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10151 if (!PL_custom_ops)
10152 PL_custom_ops = newHV();
10154 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10155 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10160 /* Efficient sub that returns a constant scalar value. */
10162 const_sv_xsub(pTHX_ CV* cv)
10166 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10170 /* diag_listed_as: SKIPME */
10171 Perl_croak(aTHX_ "usage: %s::%s()",
10172 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10185 * c-indentation-style: bsd
10186 * c-basic-offset: 4
10187 * indent-tabs-mode: t
10190 * ex: set ts=8 sts=4 sw=4 noet: