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 /* if (o->op_madprop && o->op_madprop->mad_next)
552 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
553 "modification of a read only value" for a reason I can't fathom why.
554 It's the "" stringification of $_, where $_ was set to '' in a foreach
555 loop, but it defies simplification into a small test case.
556 However, commenting them out has caused ext/List/Util/t/weak.t to fail
559 mad_free(o->op_madprop);
565 switch (o->op_type) {
566 case OP_NULL: /* Was holding old type, if any. */
567 if (PL_madskills && o->op_targ != OP_NULL) {
568 o->op_type = (Optype)o->op_targ;
573 case OP_ENTEREVAL: /* Was holding hints. */
577 if (!(o->op_flags & OPf_REF)
578 || (PL_check[o->op_type] != Perl_ck_ftst))
584 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
585 /* not an OP_PADAV replacement */
586 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
591 /* It's possible during global destruction that the GV is freed
592 before the optree. Whilst the SvREFCNT_inc is happy to bump from
593 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
594 will trigger an assertion failure, because the entry to sv_clear
595 checks that the scalar is not already freed. A check of for
596 !SvIS_FREED(gv) turns out to be invalid, because during global
597 destruction the reference count can be forced down to zero
598 (with SVf_BREAK set). In which case raising to 1 and then
599 dropping to 0 triggers cleanup before it should happen. I
600 *think* that this might actually be a general, systematic,
601 weakness of the whole idea of SVf_BREAK, in that code *is*
602 allowed to raise and lower references during global destruction,
603 so any *valid* code that happens to do this during global
604 destruction might well trigger premature cleanup. */
605 bool still_valid = gv && SvREFCNT(gv);
608 SvREFCNT_inc_simple_void(gv);
610 if (cPADOPo->op_padix > 0) {
611 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
612 * may still exist on the pad */
613 pad_swipe(cPADOPo->op_padix, TRUE);
614 cPADOPo->op_padix = 0;
617 SvREFCNT_dec(cSVOPo->op_sv);
618 cSVOPo->op_sv = NULL;
621 int try_downgrade = SvREFCNT(gv) == 2;
624 gv_try_downgrade(gv);
628 case OP_METHOD_NAMED:
631 SvREFCNT_dec(cSVOPo->op_sv);
632 cSVOPo->op_sv = NULL;
635 Even if op_clear does a pad_free for the target of the op,
636 pad_free doesn't actually remove the sv that exists in the pad;
637 instead it lives on. This results in that it could be reused as
638 a target later on when the pad was reallocated.
641 pad_swipe(o->op_targ,1);
650 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
655 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
657 if (cPADOPo->op_padix > 0) {
658 pad_swipe(cPADOPo->op_padix, TRUE);
659 cPADOPo->op_padix = 0;
662 SvREFCNT_dec(cSVOPo->op_sv);
663 cSVOPo->op_sv = NULL;
667 PerlMemShared_free(cPVOPo->op_pv);
668 cPVOPo->op_pv = NULL;
672 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
676 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
677 /* No GvIN_PAD_off here, because other references may still
678 * exist on the pad */
679 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
682 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
688 forget_pmop(cPMOPo, 1);
689 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
690 /* we use the same protection as the "SAFE" version of the PM_ macros
691 * here since sv_clean_all might release some PMOPs
692 * after PL_regex_padav has been cleared
693 * and the clearing of PL_regex_padav needs to
694 * happen before sv_clean_all
697 if(PL_regex_pad) { /* We could be in destruction */
698 const IV offset = (cPMOPo)->op_pmoffset;
699 ReREFCNT_dec(PM_GETRE(cPMOPo));
700 PL_regex_pad[offset] = &PL_sv_undef;
701 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
705 ReREFCNT_dec(PM_GETRE(cPMOPo));
706 PM_SETRE(cPMOPo, NULL);
712 if (o->op_targ > 0) {
713 pad_free(o->op_targ);
719 S_cop_free(pTHX_ COP* cop)
721 PERL_ARGS_ASSERT_COP_FREE;
725 if (! specialWARN(cop->cop_warnings))
726 PerlMemShared_free(cop->cop_warnings);
727 cophh_free(CopHINTHASH_get(cop));
731 S_forget_pmop(pTHX_ PMOP *const o
737 HV * const pmstash = PmopSTASH(o);
739 PERL_ARGS_ASSERT_FORGET_PMOP;
741 if (pmstash && !SvIS_FREED(pmstash)) {
742 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
744 PMOP **const array = (PMOP**) mg->mg_ptr;
745 U32 count = mg->mg_len / sizeof(PMOP**);
750 /* Found it. Move the entry at the end to overwrite it. */
751 array[i] = array[--count];
752 mg->mg_len = count * sizeof(PMOP**);
753 /* Could realloc smaller at this point always, but probably
754 not worth it. Probably worth free()ing if we're the
757 Safefree(mg->mg_ptr);
774 S_find_and_forget_pmops(pTHX_ OP *o)
776 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
778 if (o->op_flags & OPf_KIDS) {
779 OP *kid = cUNOPo->op_first;
781 switch (kid->op_type) {
786 forget_pmop((PMOP*)kid, 0);
788 find_and_forget_pmops(kid);
789 kid = kid->op_sibling;
795 Perl_op_null(pTHX_ OP *o)
799 PERL_ARGS_ASSERT_OP_NULL;
801 if (o->op_type == OP_NULL)
805 o->op_targ = o->op_type;
806 o->op_type = OP_NULL;
807 o->op_ppaddr = PL_ppaddr[OP_NULL];
811 Perl_op_refcnt_lock(pTHX)
819 Perl_op_refcnt_unlock(pTHX)
826 /* Contextualizers */
829 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
831 Applies a syntactic context to an op tree representing an expression.
832 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
833 or C<G_VOID> to specify the context to apply. The modified op tree
840 Perl_op_contextualize(pTHX_ OP *o, I32 context)
842 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
844 case G_SCALAR: return scalar(o);
845 case G_ARRAY: return list(o);
846 case G_VOID: return scalarvoid(o);
848 Perl_croak(aTHX_ "panic: op_contextualize bad context");
854 =head1 Optree Manipulation Functions
856 =for apidoc Am|OP*|op_linklist|OP *o
857 This function is the implementation of the L</LINKLIST> macro. It should
858 not be called directly.
864 Perl_op_linklist(pTHX_ OP *o)
868 PERL_ARGS_ASSERT_OP_LINKLIST;
873 /* establish postfix order */
874 first = cUNOPo->op_first;
877 o->op_next = LINKLIST(first);
880 if (kid->op_sibling) {
881 kid->op_next = LINKLIST(kid->op_sibling);
882 kid = kid->op_sibling;
896 S_scalarkids(pTHX_ OP *o)
898 if (o && o->op_flags & OPf_KIDS) {
900 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
907 S_scalarboolean(pTHX_ OP *o)
911 PERL_ARGS_ASSERT_SCALARBOOLEAN;
913 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
914 if (ckWARN(WARN_SYNTAX)) {
915 const line_t oldline = CopLINE(PL_curcop);
917 if (PL_parser && PL_parser->copline != NOLINE)
918 CopLINE_set(PL_curcop, PL_parser->copline);
919 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
920 CopLINE_set(PL_curcop, oldline);
927 Perl_scalar(pTHX_ OP *o)
932 /* assumes no premature commitment */
933 if (!o || (PL_parser && PL_parser->error_count)
934 || (o->op_flags & OPf_WANT)
935 || o->op_type == OP_RETURN)
940 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
942 switch (o->op_type) {
944 scalar(cBINOPo->op_first);
949 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
959 if (o->op_flags & OPf_KIDS) {
960 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
966 kid = cLISTOPo->op_first;
968 kid = kid->op_sibling;
971 OP *sib = kid->op_sibling;
972 if (sib && kid->op_type != OP_LEAVEWHEN) {
973 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
983 PL_curcop = &PL_compiling;
988 kid = cLISTOPo->op_first;
991 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
998 Perl_scalarvoid(pTHX_ OP *o)
1002 const char* useless = NULL;
1006 PERL_ARGS_ASSERT_SCALARVOID;
1008 /* trailing mad null ops don't count as "there" for void processing */
1010 o->op_type != OP_NULL &&
1012 o->op_sibling->op_type == OP_NULL)
1015 for (sib = o->op_sibling;
1016 sib && sib->op_type == OP_NULL;
1017 sib = sib->op_sibling) ;
1023 if (o->op_type == OP_NEXTSTATE
1024 || o->op_type == OP_DBSTATE
1025 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1026 || o->op_targ == OP_DBSTATE)))
1027 PL_curcop = (COP*)o; /* for warning below */
1029 /* assumes no premature commitment */
1030 want = o->op_flags & OPf_WANT;
1031 if ((want && want != OPf_WANT_SCALAR)
1032 || (PL_parser && PL_parser->error_count)
1033 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1038 if ((o->op_private & OPpTARGET_MY)
1039 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1041 return scalar(o); /* As if inside SASSIGN */
1044 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1046 switch (o->op_type) {
1048 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1052 if (o->op_flags & OPf_STACKED)
1056 if (o->op_private == 4)
1099 case OP_GETSOCKNAME:
1100 case OP_GETPEERNAME:
1105 case OP_GETPRIORITY:
1129 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1130 /* Otherwise it's "Useless use of grep iterator" */
1131 useless = OP_DESC(o);
1135 kid = cLISTOPo->op_first;
1136 if (kid && kid->op_type == OP_PUSHRE
1138 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1140 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1142 useless = OP_DESC(o);
1146 kid = cUNOPo->op_first;
1147 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1148 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1151 useless = "negative pattern binding (!~)";
1155 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1156 useless = "non-destructive substitution (s///r)";
1160 useless = "non-destructive transliteration (tr///r)";
1167 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1168 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1169 useless = "a variable";
1174 if (cSVOPo->op_private & OPpCONST_STRICT)
1175 no_bareword_allowed(o);
1177 if (ckWARN(WARN_VOID)) {
1179 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1180 "a constant (%"SVf")", sv));
1181 useless = SvPV_nolen(msv);
1184 useless = "a constant (undef)";
1185 if (o->op_private & OPpCONST_ARYBASE)
1187 /* don't warn on optimised away booleans, eg
1188 * use constant Foo, 5; Foo || print; */
1189 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1191 /* the constants 0 and 1 are permitted as they are
1192 conventionally used as dummies in constructs like
1193 1 while some_condition_with_side_effects; */
1194 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1196 else if (SvPOK(sv)) {
1197 /* perl4's way of mixing documentation and code
1198 (before the invention of POD) was based on a
1199 trick to mix nroff and perl code. The trick was
1200 built upon these three nroff macros being used in
1201 void context. The pink camel has the details in
1202 the script wrapman near page 319. */
1203 const char * const maybe_macro = SvPVX_const(sv);
1204 if (strnEQ(maybe_macro, "di", 2) ||
1205 strnEQ(maybe_macro, "ds", 2) ||
1206 strnEQ(maybe_macro, "ig", 2))
1211 op_null(o); /* don't execute or even remember it */
1215 o->op_type = OP_PREINC; /* pre-increment is faster */
1216 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1220 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1221 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1225 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1226 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1230 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1231 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1236 kid = cLOGOPo->op_first;
1237 if (kid->op_type == OP_NOT
1238 && (kid->op_flags & OPf_KIDS)
1240 if (o->op_type == OP_AND) {
1242 o->op_ppaddr = PL_ppaddr[OP_OR];
1244 o->op_type = OP_AND;
1245 o->op_ppaddr = PL_ppaddr[OP_AND];
1254 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1259 if (o->op_flags & OPf_STACKED)
1266 if (!(o->op_flags & OPf_KIDS))
1277 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1287 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1292 S_listkids(pTHX_ OP *o)
1294 if (o && o->op_flags & OPf_KIDS) {
1296 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1303 Perl_list(pTHX_ OP *o)
1308 /* assumes no premature commitment */
1309 if (!o || (o->op_flags & OPf_WANT)
1310 || (PL_parser && PL_parser->error_count)
1311 || o->op_type == OP_RETURN)
1316 if ((o->op_private & OPpTARGET_MY)
1317 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1319 return o; /* As if inside SASSIGN */
1322 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1324 switch (o->op_type) {
1327 list(cBINOPo->op_first);
1332 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1340 if (!(o->op_flags & OPf_KIDS))
1342 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1343 list(cBINOPo->op_first);
1344 return gen_constant_list(o);
1351 kid = cLISTOPo->op_first;
1353 kid = kid->op_sibling;
1356 OP *sib = kid->op_sibling;
1357 if (sib && kid->op_type != OP_LEAVEWHEN) {
1358 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1368 PL_curcop = &PL_compiling;
1372 kid = cLISTOPo->op_first;
1379 S_scalarseq(pTHX_ OP *o)
1383 const OPCODE type = o->op_type;
1385 if (type == OP_LINESEQ || type == OP_SCOPE ||
1386 type == OP_LEAVE || type == OP_LEAVETRY)
1389 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1390 if (kid->op_sibling) {
1394 PL_curcop = &PL_compiling;
1396 o->op_flags &= ~OPf_PARENS;
1397 if (PL_hints & HINT_BLOCK_SCOPE)
1398 o->op_flags |= OPf_PARENS;
1401 o = newOP(OP_STUB, 0);
1406 S_modkids(pTHX_ OP *o, I32 type)
1408 if (o && o->op_flags & OPf_KIDS) {
1410 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1411 op_lvalue(kid, type);
1417 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1419 Propagate lvalue ("modifiable") context to an op and its children.
1420 I<type> represents the context type, roughly based on the type of op that
1421 would do the modifying, although C<local()> is represented by OP_NULL,
1422 because it has no op type of its own (it is signalled by a flag on
1423 the lvalue op). This function detects things that can't be modified,
1424 such as C<$x+1>, and generates errors for them. It also flags things
1425 that need to behave specially in an lvalue context, such as C<$$x>
1426 which might have to vivify a reference in C<$x>.
1432 Perl_op_lvalue(pTHX_ OP *o, I32 type)
1436 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1439 if (!o || (PL_parser && PL_parser->error_count))
1442 if ((o->op_private & OPpTARGET_MY)
1443 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1448 switch (o->op_type) {
1454 if (!(o->op_private & OPpCONST_ARYBASE))
1457 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1458 CopARYBASE_set(&PL_compiling,
1459 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1463 SAVECOPARYBASE(&PL_compiling);
1464 CopARYBASE_set(&PL_compiling, 0);
1466 else if (type == OP_REFGEN)
1469 Perl_croak(aTHX_ "That use of $[ is unsupported");
1472 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1476 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1477 !(o->op_flags & OPf_STACKED)) {
1478 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1479 /* The default is to set op_private to the number of children,
1480 which for a UNOP such as RV2CV is always 1. And w're using
1481 the bit for a flag in RV2CV, so we need it clear. */
1482 o->op_private &= ~1;
1483 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1484 assert(cUNOPo->op_first->op_type == OP_NULL);
1485 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1488 else if (o->op_private & OPpENTERSUB_NOMOD)
1490 else { /* lvalue subroutine call */
1491 o->op_private |= OPpLVAL_INTRO;
1492 PL_modcount = RETURN_UNLIMITED_NUMBER;
1493 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1494 /* Backward compatibility mode: */
1495 o->op_private |= OPpENTERSUB_INARGS;
1498 else { /* Compile-time error message: */
1499 OP *kid = cUNOPo->op_first;
1503 if (kid->op_type != OP_PUSHMARK) {
1504 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1506 "panic: unexpected lvalue entersub "
1507 "args: type/targ %ld:%"UVuf,
1508 (long)kid->op_type, (UV)kid->op_targ);
1509 kid = kLISTOP->op_first;
1511 while (kid->op_sibling)
1512 kid = kid->op_sibling;
1513 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1515 if (kid->op_type == OP_METHOD_NAMED
1516 || kid->op_type == OP_METHOD)
1520 NewOp(1101, newop, 1, UNOP);
1521 newop->op_type = OP_RV2CV;
1522 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1523 newop->op_first = NULL;
1524 newop->op_next = (OP*)newop;
1525 kid->op_sibling = (OP*)newop;
1526 newop->op_private |= OPpLVAL_INTRO;
1527 newop->op_private &= ~1;
1531 if (kid->op_type != OP_RV2CV)
1533 "panic: unexpected lvalue entersub "
1534 "entry via type/targ %ld:%"UVuf,
1535 (long)kid->op_type, (UV)kid->op_targ);
1536 kid->op_private |= OPpLVAL_INTRO;
1537 break; /* Postpone until runtime */
1541 kid = kUNOP->op_first;
1542 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1543 kid = kUNOP->op_first;
1544 if (kid->op_type == OP_NULL)
1546 "Unexpected constant lvalue entersub "
1547 "entry via type/targ %ld:%"UVuf,
1548 (long)kid->op_type, (UV)kid->op_targ);
1549 if (kid->op_type != OP_GV) {
1550 /* Restore RV2CV to check lvalueness */
1552 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1553 okid->op_next = kid->op_next;
1554 kid->op_next = okid;
1557 okid->op_next = NULL;
1558 okid->op_type = OP_RV2CV;
1560 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1561 okid->op_private |= OPpLVAL_INTRO;
1562 okid->op_private &= ~1;
1566 cv = GvCV(kGVOP_gv);
1576 /* grep, foreach, subcalls, refgen */
1577 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1579 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1580 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1582 : (o->op_type == OP_ENTERSUB
1583 ? "non-lvalue subroutine call"
1585 type ? PL_op_desc[type] : "local"));
1599 case OP_RIGHT_SHIFT:
1608 if (!(o->op_flags & OPf_STACKED))
1615 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1616 op_lvalue(kid, type);
1621 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1622 PL_modcount = RETURN_UNLIMITED_NUMBER;
1623 return o; /* Treat \(@foo) like ordinary list. */
1627 if (scalar_mod_type(o, type))
1629 ref(cUNOPo->op_first, o->op_type);
1633 if (type == OP_LEAVESUBLV)
1634 o->op_private |= OPpMAYBE_LVSUB;
1640 PL_modcount = RETURN_UNLIMITED_NUMBER;
1643 PL_hints |= HINT_BLOCK_SCOPE;
1644 if (type == OP_LEAVESUBLV)
1645 o->op_private |= OPpMAYBE_LVSUB;
1649 ref(cUNOPo->op_first, o->op_type);
1653 PL_hints |= HINT_BLOCK_SCOPE;
1668 PL_modcount = RETURN_UNLIMITED_NUMBER;
1669 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1670 return o; /* Treat \(@foo) like ordinary list. */
1671 if (scalar_mod_type(o, type))
1673 if (type == OP_LEAVESUBLV)
1674 o->op_private |= OPpMAYBE_LVSUB;
1678 if (!type) /* local() */
1679 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1680 PAD_COMPNAME_PV(o->op_targ));
1688 if (type != OP_SASSIGN)
1692 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1697 if (type == OP_LEAVESUBLV)
1698 o->op_private |= OPpMAYBE_LVSUB;
1700 pad_free(o->op_targ);
1701 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1702 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1703 if (o->op_flags & OPf_KIDS)
1704 op_lvalue(cBINOPo->op_first->op_sibling, type);
1709 ref(cBINOPo->op_first, o->op_type);
1710 if (type == OP_ENTERSUB &&
1711 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1712 o->op_private |= OPpLVAL_DEFER;
1713 if (type == OP_LEAVESUBLV)
1714 o->op_private |= OPpMAYBE_LVSUB;
1724 if (o->op_flags & OPf_KIDS)
1725 op_lvalue(cLISTOPo->op_last, type);
1730 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1732 else if (!(o->op_flags & OPf_KIDS))
1734 if (o->op_targ != OP_LIST) {
1735 op_lvalue(cBINOPo->op_first, type);
1741 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1742 op_lvalue(kid, type);
1746 if (type != OP_LEAVESUBLV)
1748 break; /* op_lvalue()ing was handled by ck_return() */
1751 /* [20011101.069] File test operators interpret OPf_REF to mean that
1752 their argument is a filehandle; thus \stat(".") should not set
1754 if (type == OP_REFGEN &&
1755 PL_check[o->op_type] == Perl_ck_ftst)
1758 if (type != OP_LEAVESUBLV)
1759 o->op_flags |= OPf_MOD;
1761 if (type == OP_AASSIGN || type == OP_SASSIGN)
1762 o->op_flags |= OPf_SPECIAL|OPf_REF;
1763 else if (!type) { /* local() */
1766 o->op_private |= OPpLVAL_INTRO;
1767 o->op_flags &= ~OPf_SPECIAL;
1768 PL_hints |= HINT_BLOCK_SCOPE;
1773 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1774 "Useless localization of %s", OP_DESC(o));
1777 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1778 && type != OP_LEAVESUBLV)
1779 o->op_flags |= OPf_REF;
1784 S_scalar_mod_type(const OP *o, I32 type)
1786 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1790 if (o->op_type == OP_RV2GV)
1814 case OP_RIGHT_SHIFT:
1835 S_is_handle_constructor(const OP *o, I32 numargs)
1837 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1839 switch (o->op_type) {
1847 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1860 S_refkids(pTHX_ OP *o, I32 type)
1862 if (o && o->op_flags & OPf_KIDS) {
1864 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1871 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1876 PERL_ARGS_ASSERT_DOREF;
1878 if (!o || (PL_parser && PL_parser->error_count))
1881 switch (o->op_type) {
1883 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1884 !(o->op_flags & OPf_STACKED)) {
1885 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1886 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1887 assert(cUNOPo->op_first->op_type == OP_NULL);
1888 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1889 o->op_flags |= OPf_SPECIAL;
1890 o->op_private &= ~1;
1895 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1896 doref(kid, type, set_op_ref);
1899 if (type == OP_DEFINED)
1900 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1901 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1904 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1905 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1906 : type == OP_RV2HV ? OPpDEREF_HV
1908 o->op_flags |= OPf_MOD;
1915 o->op_flags |= OPf_REF;
1918 if (type == OP_DEFINED)
1919 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1920 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1926 o->op_flags |= OPf_REF;
1931 if (!(o->op_flags & OPf_KIDS))
1933 doref(cBINOPo->op_first, type, set_op_ref);
1937 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1938 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1939 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1940 : type == OP_RV2HV ? OPpDEREF_HV
1942 o->op_flags |= OPf_MOD;
1952 if (!(o->op_flags & OPf_KIDS))
1954 doref(cLISTOPo->op_last, type, set_op_ref);
1964 S_dup_attrlist(pTHX_ OP *o)
1969 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1971 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1972 * where the first kid is OP_PUSHMARK and the remaining ones
1973 * are OP_CONST. We need to push the OP_CONST values.
1975 if (o->op_type == OP_CONST)
1976 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1978 else if (o->op_type == OP_NULL)
1982 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1984 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1985 if (o->op_type == OP_CONST)
1986 rop = op_append_elem(OP_LIST, rop,
1987 newSVOP(OP_CONST, o->op_flags,
1988 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1995 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2000 PERL_ARGS_ASSERT_APPLY_ATTRS;
2002 /* fake up C<use attributes $pkg,$rv,@attrs> */
2003 ENTER; /* need to protect against side-effects of 'use' */
2004 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2006 #define ATTRSMODULE "attributes"
2007 #define ATTRSMODULE_PM "attributes.pm"
2010 /* Don't force the C<use> if we don't need it. */
2011 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2012 if (svp && *svp != &PL_sv_undef)
2013 NOOP; /* already in %INC */
2015 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2016 newSVpvs(ATTRSMODULE), NULL);
2019 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2020 newSVpvs(ATTRSMODULE),
2022 op_prepend_elem(OP_LIST,
2023 newSVOP(OP_CONST, 0, stashsv),
2024 op_prepend_elem(OP_LIST,
2025 newSVOP(OP_CONST, 0,
2027 dup_attrlist(attrs))));
2033 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2036 OP *pack, *imop, *arg;
2039 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2044 assert(target->op_type == OP_PADSV ||
2045 target->op_type == OP_PADHV ||
2046 target->op_type == OP_PADAV);
2048 /* Ensure that attributes.pm is loaded. */
2049 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2051 /* Need package name for method call. */
2052 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2054 /* Build up the real arg-list. */
2055 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2057 arg = newOP(OP_PADSV, 0);
2058 arg->op_targ = target->op_targ;
2059 arg = op_prepend_elem(OP_LIST,
2060 newSVOP(OP_CONST, 0, stashsv),
2061 op_prepend_elem(OP_LIST,
2062 newUNOP(OP_REFGEN, 0,
2063 op_lvalue(arg, OP_REFGEN)),
2064 dup_attrlist(attrs)));
2066 /* Fake up a method call to import */
2067 meth = newSVpvs_share("import");
2068 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2069 op_append_elem(OP_LIST,
2070 op_prepend_elem(OP_LIST, pack, list(arg)),
2071 newSVOP(OP_METHOD_NAMED, 0, meth)));
2072 imop->op_private |= OPpENTERSUB_NOMOD;
2074 /* Combine the ops. */
2075 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2079 =notfor apidoc apply_attrs_string
2081 Attempts to apply a list of attributes specified by the C<attrstr> and
2082 C<len> arguments to the subroutine identified by the C<cv> argument which
2083 is expected to be associated with the package identified by the C<stashpv>
2084 argument (see L<attributes>). It gets this wrong, though, in that it
2085 does not correctly identify the boundaries of the individual attribute
2086 specifications within C<attrstr>. This is not really intended for the
2087 public API, but has to be listed here for systems such as AIX which
2088 need an explicit export list for symbols. (It's called from XS code
2089 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2090 to respect attribute syntax properly would be welcome.
2096 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2097 const char *attrstr, STRLEN len)
2101 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2104 len = strlen(attrstr);
2108 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2110 const char * const sstr = attrstr;
2111 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2112 attrs = op_append_elem(OP_LIST, attrs,
2113 newSVOP(OP_CONST, 0,
2114 newSVpvn(sstr, attrstr-sstr)));
2118 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2119 newSVpvs(ATTRSMODULE),
2120 NULL, op_prepend_elem(OP_LIST,
2121 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2122 op_prepend_elem(OP_LIST,
2123 newSVOP(OP_CONST, 0,
2124 newRV(MUTABLE_SV(cv))),
2129 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2134 PERL_ARGS_ASSERT_MY_KID;
2136 if (!o || (PL_parser && PL_parser->error_count))
2140 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2141 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2145 if (type == OP_LIST) {
2147 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2148 my_kid(kid, attrs, imopsp);
2149 } else if (type == OP_UNDEF
2155 } else if (type == OP_RV2SV || /* "our" declaration */
2157 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2158 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2159 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2161 PL_parser->in_my == KEY_our
2163 : PL_parser->in_my == KEY_state ? "state" : "my"));
2165 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2166 PL_parser->in_my = FALSE;
2167 PL_parser->in_my_stash = NULL;
2168 apply_attrs(GvSTASH(gv),
2169 (type == OP_RV2SV ? GvSV(gv) :
2170 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2171 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2174 o->op_private |= OPpOUR_INTRO;
2177 else if (type != OP_PADSV &&
2180 type != OP_PUSHMARK)
2182 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2184 PL_parser->in_my == KEY_our
2186 : PL_parser->in_my == KEY_state ? "state" : "my"));
2189 else if (attrs && type != OP_PUSHMARK) {
2192 PL_parser->in_my = FALSE;
2193 PL_parser->in_my_stash = NULL;
2195 /* check for C<my Dog $spot> when deciding package */
2196 stash = PAD_COMPNAME_TYPE(o->op_targ);
2198 stash = PL_curstash;
2199 apply_attrs_my(stash, o, attrs, imopsp);
2201 o->op_flags |= OPf_MOD;
2202 o->op_private |= OPpLVAL_INTRO;
2203 if (PL_parser->in_my == KEY_state)
2204 o->op_private |= OPpPAD_STATE;
2209 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2213 int maybe_scalar = 0;
2215 PERL_ARGS_ASSERT_MY_ATTRS;
2217 /* [perl #17376]: this appears to be premature, and results in code such as
2218 C< our(%x); > executing in list mode rather than void mode */
2220 if (o->op_flags & OPf_PARENS)
2230 o = my_kid(o, attrs, &rops);
2232 if (maybe_scalar && o->op_type == OP_PADSV) {
2233 o = scalar(op_append_list(OP_LIST, rops, o));
2234 o->op_private |= OPpLVAL_INTRO;
2237 o = op_append_list(OP_LIST, o, rops);
2239 PL_parser->in_my = FALSE;
2240 PL_parser->in_my_stash = NULL;
2245 Perl_sawparens(pTHX_ OP *o)
2247 PERL_UNUSED_CONTEXT;
2249 o->op_flags |= OPf_PARENS;
2254 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2258 const OPCODE ltype = left->op_type;
2259 const OPCODE rtype = right->op_type;
2261 PERL_ARGS_ASSERT_BIND_MATCH;
2263 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2264 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2266 const char * const desc
2268 rtype == OP_SUBST || rtype == OP_TRANS
2269 || rtype == OP_TRANSR
2271 ? (int)rtype : OP_MATCH];
2272 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2273 ? "@array" : "%hash");
2274 Perl_warner(aTHX_ packWARN(WARN_MISC),
2275 "Applying %s to %s will act on scalar(%s)",
2276 desc, sample, sample);
2279 if (rtype == OP_CONST &&
2280 cSVOPx(right)->op_private & OPpCONST_BARE &&
2281 cSVOPx(right)->op_private & OPpCONST_STRICT)
2283 no_bareword_allowed(right);
2286 /* !~ doesn't make sense with /r, so error on it for now */
2287 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2289 yyerror("Using !~ with s///r doesn't make sense");
2290 if (rtype == OP_TRANSR && type == OP_NOT)
2291 yyerror("Using !~ with tr///r doesn't make sense");
2293 ismatchop = (rtype == OP_MATCH ||
2294 rtype == OP_SUBST ||
2295 rtype == OP_TRANS || rtype == OP_TRANSR)
2296 && !(right->op_flags & OPf_SPECIAL);
2297 if (ismatchop && right->op_private & OPpTARGET_MY) {
2299 right->op_private &= ~OPpTARGET_MY;
2301 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2304 right->op_flags |= OPf_STACKED;
2305 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2306 ! (rtype == OP_TRANS &&
2307 right->op_private & OPpTRANS_IDENTICAL) &&
2308 ! (rtype == OP_SUBST &&
2309 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2310 newleft = op_lvalue(left, rtype);
2313 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2314 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2316 o = op_prepend_elem(rtype, scalar(newleft), right);
2318 return newUNOP(OP_NOT, 0, scalar(o));
2322 return bind_match(type, left,
2323 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2327 Perl_invert(pTHX_ OP *o)
2331 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2335 =for apidoc Amx|OP *|op_scope|OP *o
2337 Wraps up an op tree with some additional ops so that at runtime a dynamic
2338 scope will be created. The original ops run in the new dynamic scope,
2339 and then, provided that they exit normally, the scope will be unwound.
2340 The additional ops used to create and unwind the dynamic scope will
2341 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2342 instead if the ops are simple enough to not need the full dynamic scope
2349 Perl_op_scope(pTHX_ OP *o)
2353 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2354 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2355 o->op_type = OP_LEAVE;
2356 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2358 else if (o->op_type == OP_LINESEQ) {
2360 o->op_type = OP_SCOPE;
2361 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2362 kid = ((LISTOP*)o)->op_first;
2363 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2366 /* The following deals with things like 'do {1 for 1}' */
2367 kid = kid->op_sibling;
2369 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2374 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2380 Perl_block_start(pTHX_ int full)
2383 const int retval = PL_savestack_ix;
2385 pad_block_start(full);
2387 PL_hints &= ~HINT_BLOCK_SCOPE;
2388 SAVECOMPILEWARNINGS();
2389 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2391 CALL_BLOCK_HOOKS(bhk_start, full);
2397 Perl_block_end(pTHX_ I32 floor, OP *seq)
2400 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2401 OP* retval = scalarseq(seq);
2403 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2406 CopHINTS_set(&PL_compiling, PL_hints);
2408 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2411 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2417 =head1 Compile-time scope hooks
2419 =for apidoc Ao||blockhook_register
2421 Register a set of hooks to be called when the Perl lexical scope changes
2422 at compile time. See L<perlguts/"Compile-time scope hooks">.
2428 Perl_blockhook_register(pTHX_ BHK *hk)
2430 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2432 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2439 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2440 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2441 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2444 OP * const o = newOP(OP_PADSV, 0);
2445 o->op_targ = offset;
2451 Perl_newPROG(pTHX_ OP *o)
2455 PERL_ARGS_ASSERT_NEWPROG;
2460 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2461 ((PL_in_eval & EVAL_KEEPERR)
2462 ? OPf_SPECIAL : 0), o);
2463 /* don't use LINKLIST, since PL_eval_root might indirect through
2464 * a rather expensive function call and LINKLIST evaluates its
2465 * argument more than once */
2466 PL_eval_start = op_linklist(PL_eval_root);
2467 PL_eval_root->op_private |= OPpREFCOUNTED;
2468 OpREFCNT_set(PL_eval_root, 1);
2469 PL_eval_root->op_next = 0;
2470 CALL_PEEP(PL_eval_start);
2473 if (o->op_type == OP_STUB) {
2474 PL_comppad_name = 0;
2476 S_op_destroy(aTHX_ o);
2479 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2480 PL_curcop = &PL_compiling;
2481 PL_main_start = LINKLIST(PL_main_root);
2482 PL_main_root->op_private |= OPpREFCOUNTED;
2483 OpREFCNT_set(PL_main_root, 1);
2484 PL_main_root->op_next = 0;
2485 CALL_PEEP(PL_main_start);
2488 /* Register with debugger */
2490 CV * const cv = get_cvs("DB::postponed", 0);
2494 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2496 call_sv(MUTABLE_SV(cv), G_DISCARD);
2503 Perl_localize(pTHX_ OP *o, I32 lex)
2507 PERL_ARGS_ASSERT_LOCALIZE;
2509 if (o->op_flags & OPf_PARENS)
2510 /* [perl #17376]: this appears to be premature, and results in code such as
2511 C< our(%x); > executing in list mode rather than void mode */
2518 if ( PL_parser->bufptr > PL_parser->oldbufptr
2519 && PL_parser->bufptr[-1] == ','
2520 && ckWARN(WARN_PARENTHESIS))
2522 char *s = PL_parser->bufptr;
2525 /* some heuristics to detect a potential error */
2526 while (*s && (strchr(", \t\n", *s)))
2530 if (*s && strchr("@$%*", *s) && *++s
2531 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2534 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2536 while (*s && (strchr(", \t\n", *s)))
2542 if (sigil && (*s == ';' || *s == '=')) {
2543 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2544 "Parentheses missing around \"%s\" list",
2546 ? (PL_parser->in_my == KEY_our
2548 : PL_parser->in_my == KEY_state
2558 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2559 PL_parser->in_my = FALSE;
2560 PL_parser->in_my_stash = NULL;
2565 Perl_jmaybe(pTHX_ OP *o)
2567 PERL_ARGS_ASSERT_JMAYBE;
2569 if (o->op_type == OP_LIST) {
2571 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2572 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2578 S_fold_constants(pTHX_ register OP *o)
2581 register OP * VOL curop;
2583 VOL I32 type = o->op_type;
2588 SV * const oldwarnhook = PL_warnhook;
2589 SV * const olddiehook = PL_diehook;
2593 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2595 if (PL_opargs[type] & OA_RETSCALAR)
2597 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2598 o->op_targ = pad_alloc(type, SVs_PADTMP);
2600 /* integerize op, unless it happens to be C<-foo>.
2601 * XXX should pp_i_negate() do magic string negation instead? */
2602 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2603 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2604 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2606 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2609 if (!(PL_opargs[type] & OA_FOLDCONST))
2614 /* XXX might want a ck_negate() for this */
2615 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2627 /* XXX what about the numeric ops? */
2628 if (PL_hints & HINT_LOCALE)
2633 if (PL_parser && PL_parser->error_count)
2634 goto nope; /* Don't try to run w/ errors */
2636 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2637 const OPCODE type = curop->op_type;
2638 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2640 type != OP_SCALAR &&
2642 type != OP_PUSHMARK)
2648 curop = LINKLIST(o);
2649 old_next = o->op_next;
2653 oldscope = PL_scopestack_ix;
2654 create_eval_scope(G_FAKINGEVAL);
2656 /* Verify that we don't need to save it: */
2657 assert(PL_curcop == &PL_compiling);
2658 StructCopy(&PL_compiling, ¬_compiling, COP);
2659 PL_curcop = ¬_compiling;
2660 /* The above ensures that we run with all the correct hints of the
2661 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2662 assert(IN_PERL_RUNTIME);
2663 PL_warnhook = PERL_WARNHOOK_FATAL;
2670 sv = *(PL_stack_sp--);
2671 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2672 pad_swipe(o->op_targ, FALSE);
2673 else if (SvTEMP(sv)) { /* grab mortal temp? */
2674 SvREFCNT_inc_simple_void(sv);
2679 /* Something tried to die. Abandon constant folding. */
2680 /* Pretend the error never happened. */
2682 o->op_next = old_next;
2686 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2687 PL_warnhook = oldwarnhook;
2688 PL_diehook = olddiehook;
2689 /* XXX note that this croak may fail as we've already blown away
2690 * the stack - eg any nested evals */
2691 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2694 PL_warnhook = oldwarnhook;
2695 PL_diehook = olddiehook;
2696 PL_curcop = &PL_compiling;
2698 if (PL_scopestack_ix > oldscope)
2699 delete_eval_scope();
2708 if (type == OP_RV2GV)
2709 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2711 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2712 op_getmad(o,newop,'f');
2720 S_gen_constant_list(pTHX_ register OP *o)
2724 const I32 oldtmps_floor = PL_tmps_floor;
2727 if (PL_parser && PL_parser->error_count)
2728 return o; /* Don't attempt to run with errors */
2730 PL_op = curop = LINKLIST(o);
2736 assert (!(curop->op_flags & OPf_SPECIAL));
2737 assert(curop->op_type == OP_RANGE);
2739 PL_tmps_floor = oldtmps_floor;
2741 o->op_type = OP_RV2AV;
2742 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2743 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2744 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2745 o->op_opt = 0; /* needs to be revisited in rpeep() */
2746 curop = ((UNOP*)o)->op_first;
2747 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2749 op_getmad(curop,o,'O');
2758 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2761 if (!o || o->op_type != OP_LIST)
2762 o = newLISTOP(OP_LIST, 0, o, NULL);
2764 o->op_flags &= ~OPf_WANT;
2766 if (!(PL_opargs[type] & OA_MARK))
2767 op_null(cLISTOPo->op_first);
2769 o->op_type = (OPCODE)type;
2770 o->op_ppaddr = PL_ppaddr[type];
2771 o->op_flags |= flags;
2773 o = CHECKOP(type, o);
2774 if (o->op_type != (unsigned)type)
2777 return fold_constants(o);
2781 =head1 Optree Manipulation Functions
2784 /* List constructors */
2787 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2789 Append an item to the list of ops contained directly within a list-type
2790 op, returning the lengthened list. I<first> is the list-type op,
2791 and I<last> is the op to append to the list. I<optype> specifies the
2792 intended opcode for the list. If I<first> is not already a list of the
2793 right type, it will be upgraded into one. If either I<first> or I<last>
2794 is null, the other is returned unchanged.
2800 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2808 if (first->op_type != (unsigned)type
2809 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2811 return newLISTOP(type, 0, first, last);
2814 if (first->op_flags & OPf_KIDS)
2815 ((LISTOP*)first)->op_last->op_sibling = last;
2817 first->op_flags |= OPf_KIDS;
2818 ((LISTOP*)first)->op_first = last;
2820 ((LISTOP*)first)->op_last = last;
2825 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2827 Concatenate the lists of ops contained directly within two list-type ops,
2828 returning the combined list. I<first> and I<last> are the list-type ops
2829 to concatenate. I<optype> specifies the intended opcode for the list.
2830 If either I<first> or I<last> is not already a list of the right type,
2831 it will be upgraded into one. If either I<first> or I<last> is null,
2832 the other is returned unchanged.
2838 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2846 if (first->op_type != (unsigned)type)
2847 return op_prepend_elem(type, first, last);
2849 if (last->op_type != (unsigned)type)
2850 return op_append_elem(type, first, last);
2852 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2853 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2854 first->op_flags |= (last->op_flags & OPf_KIDS);
2857 if (((LISTOP*)last)->op_first && first->op_madprop) {
2858 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2860 while (mp->mad_next)
2862 mp->mad_next = first->op_madprop;
2865 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2868 first->op_madprop = last->op_madprop;
2869 last->op_madprop = 0;
2872 S_op_destroy(aTHX_ last);
2878 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2880 Prepend an item to the list of ops contained directly within a list-type
2881 op, returning the lengthened list. I<first> is the op to prepend to the
2882 list, and I<last> is the list-type op. I<optype> specifies the intended
2883 opcode for the list. If I<last> is not already a list of the right type,
2884 it will be upgraded into one. If either I<first> or I<last> is null,
2885 the other is returned unchanged.
2891 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2899 if (last->op_type == (unsigned)type) {
2900 if (type == OP_LIST) { /* already a PUSHMARK there */
2901 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2902 ((LISTOP*)last)->op_first->op_sibling = first;
2903 if (!(first->op_flags & OPf_PARENS))
2904 last->op_flags &= ~OPf_PARENS;
2907 if (!(last->op_flags & OPf_KIDS)) {
2908 ((LISTOP*)last)->op_last = first;
2909 last->op_flags |= OPf_KIDS;
2911 first->op_sibling = ((LISTOP*)last)->op_first;
2912 ((LISTOP*)last)->op_first = first;
2914 last->op_flags |= OPf_KIDS;
2918 return newLISTOP(type, 0, first, last);
2926 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2929 Newxz(tk, 1, TOKEN);
2930 tk->tk_type = (OPCODE)optype;
2931 tk->tk_type = 12345;
2933 tk->tk_mad = madprop;
2938 Perl_token_free(pTHX_ TOKEN* tk)
2940 PERL_ARGS_ASSERT_TOKEN_FREE;
2942 if (tk->tk_type != 12345)
2944 mad_free(tk->tk_mad);
2949 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2954 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2956 if (tk->tk_type != 12345) {
2957 Perl_warner(aTHX_ packWARN(WARN_MISC),
2958 "Invalid TOKEN object ignored");
2965 /* faked up qw list? */
2967 tm->mad_type == MAD_SV &&
2968 SvPVX((SV *)tm->mad_val)[0] == 'q')
2975 /* pretend constant fold didn't happen? */
2976 if (mp->mad_key == 'f' &&
2977 (o->op_type == OP_CONST ||
2978 o->op_type == OP_GV) )
2980 token_getmad(tk,(OP*)mp->mad_val,slot);
2994 if (mp->mad_key == 'X')
2995 mp->mad_key = slot; /* just change the first one */
3005 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3014 /* pretend constant fold didn't happen? */
3015 if (mp->mad_key == 'f' &&
3016 (o->op_type == OP_CONST ||
3017 o->op_type == OP_GV) )
3019 op_getmad(from,(OP*)mp->mad_val,slot);
3026 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3029 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3035 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3044 /* pretend constant fold didn't happen? */
3045 if (mp->mad_key == 'f' &&
3046 (o->op_type == OP_CONST ||
3047 o->op_type == OP_GV) )
3049 op_getmad(from,(OP*)mp->mad_val,slot);
3056 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3059 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3063 PerlIO_printf(PerlIO_stderr(),
3064 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3070 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3088 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3092 addmad(tm, &(o->op_madprop), slot);
3096 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3117 Perl_newMADsv(pTHX_ char key, SV* sv)
3119 PERL_ARGS_ASSERT_NEWMADSV;
3121 return newMADPROP(key, MAD_SV, sv, 0);
3125 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3128 Newxz(mp, 1, MADPROP);
3131 mp->mad_vlen = vlen;
3132 mp->mad_type = type;
3134 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3139 Perl_mad_free(pTHX_ MADPROP* mp)
3141 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3145 mad_free(mp->mad_next);
3146 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3147 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3148 switch (mp->mad_type) {
3152 Safefree((char*)mp->mad_val);
3155 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3156 op_free((OP*)mp->mad_val);
3159 sv_free(MUTABLE_SV(mp->mad_val));
3162 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3171 =head1 Optree construction
3173 =for apidoc Am|OP *|newNULLLIST
3175 Constructs, checks, and returns a new C<stub> op, which represents an
3176 empty list expression.
3182 Perl_newNULLLIST(pTHX)
3184 return newOP(OP_STUB, 0);
3188 S_force_list(pTHX_ OP *o)
3190 if (!o || o->op_type != OP_LIST)
3191 o = newLISTOP(OP_LIST, 0, o, NULL);
3197 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3199 Constructs, checks, and returns an op of any list type. I<type> is
3200 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3201 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3202 supply up to two ops to be direct children of the list op; they are
3203 consumed by this function and become part of the constructed op tree.
3209 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3214 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3216 NewOp(1101, listop, 1, LISTOP);
3218 listop->op_type = (OPCODE)type;
3219 listop->op_ppaddr = PL_ppaddr[type];
3222 listop->op_flags = (U8)flags;
3226 else if (!first && last)
3229 first->op_sibling = last;
3230 listop->op_first = first;
3231 listop->op_last = last;
3232 if (type == OP_LIST) {
3233 OP* const pushop = newOP(OP_PUSHMARK, 0);
3234 pushop->op_sibling = first;
3235 listop->op_first = pushop;
3236 listop->op_flags |= OPf_KIDS;
3238 listop->op_last = pushop;
3241 return CHECKOP(type, listop);
3245 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3247 Constructs, checks, and returns an op of any base type (any type that
3248 has no extra fields). I<type> is the opcode. I<flags> gives the
3249 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3256 Perl_newOP(pTHX_ I32 type, I32 flags)
3261 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3262 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3263 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3264 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3266 NewOp(1101, o, 1, OP);
3267 o->op_type = (OPCODE)type;
3268 o->op_ppaddr = PL_ppaddr[type];
3269 o->op_flags = (U8)flags;
3271 o->op_latefreed = 0;
3275 o->op_private = (U8)(0 | (flags >> 8));
3276 if (PL_opargs[type] & OA_RETSCALAR)
3278 if (PL_opargs[type] & OA_TARGET)
3279 o->op_targ = pad_alloc(type, SVs_PADTMP);
3280 return CHECKOP(type, o);
3284 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3286 Constructs, checks, and returns an op of any unary type. I<type> is
3287 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3288 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3289 bits, the eight bits of C<op_private>, except that the bit with value 1
3290 is automatically set. I<first> supplies an optional op to be the direct
3291 child of the unary op; it is consumed by this function and become part
3292 of the constructed op tree.
3298 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3303 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3304 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3305 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3306 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3307 || type == OP_SASSIGN
3308 || type == OP_ENTERTRY
3309 || type == OP_NULL );
3312 first = newOP(OP_STUB, 0);
3313 if (PL_opargs[type] & OA_MARK)
3314 first = force_list(first);
3316 NewOp(1101, unop, 1, UNOP);
3317 unop->op_type = (OPCODE)type;
3318 unop->op_ppaddr = PL_ppaddr[type];
3319 unop->op_first = first;
3320 unop->op_flags = (U8)(flags | OPf_KIDS);
3321 unop->op_private = (U8)(1 | (flags >> 8));
3322 unop = (UNOP*) CHECKOP(type, unop);
3326 return fold_constants((OP *) unop);
3330 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3332 Constructs, checks, and returns an op of any binary type. I<type>
3333 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3334 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3335 the eight bits of C<op_private>, except that the bit with value 1 or
3336 2 is automatically set as required. I<first> and I<last> supply up to
3337 two ops to be the direct children of the binary op; they are consumed
3338 by this function and become part of the constructed op tree.
3344 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3349 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3350 || type == OP_SASSIGN || type == OP_NULL );
3352 NewOp(1101, binop, 1, BINOP);
3355 first = newOP(OP_NULL, 0);
3357 binop->op_type = (OPCODE)type;
3358 binop->op_ppaddr = PL_ppaddr[type];
3359 binop->op_first = first;
3360 binop->op_flags = (U8)(flags | OPf_KIDS);
3363 binop->op_private = (U8)(1 | (flags >> 8));
3366 binop->op_private = (U8)(2 | (flags >> 8));
3367 first->op_sibling = last;
3370 binop = (BINOP*)CHECKOP(type, binop);
3371 if (binop->op_next || binop->op_type != (OPCODE)type)
3374 binop->op_last = binop->op_first->op_sibling;
3376 return fold_constants((OP *)binop);
3379 static int uvcompare(const void *a, const void *b)
3380 __attribute__nonnull__(1)
3381 __attribute__nonnull__(2)
3382 __attribute__pure__;
3383 static int uvcompare(const void *a, const void *b)
3385 if (*((const UV *)a) < (*(const UV *)b))
3387 if (*((const UV *)a) > (*(const UV *)b))
3389 if (*((const UV *)a+1) < (*(const UV *)b+1))
3391 if (*((const UV *)a+1) > (*(const UV *)b+1))
3397 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3400 SV * const tstr = ((SVOP*)expr)->op_sv;
3403 (repl->op_type == OP_NULL)
3404 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3406 ((SVOP*)repl)->op_sv;
3409 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3410 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3414 register short *tbl;
3416 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3417 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3418 I32 del = o->op_private & OPpTRANS_DELETE;
3421 PERL_ARGS_ASSERT_PMTRANS;
3423 PL_hints |= HINT_BLOCK_SCOPE;
3426 o->op_private |= OPpTRANS_FROM_UTF;
3429 o->op_private |= OPpTRANS_TO_UTF;
3431 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3432 SV* const listsv = newSVpvs("# comment\n");
3434 const U8* tend = t + tlen;
3435 const U8* rend = r + rlen;
3449 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3450 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3453 const U32 flags = UTF8_ALLOW_DEFAULT;
3457 t = tsave = bytes_to_utf8(t, &len);
3460 if (!to_utf && rlen) {
3462 r = rsave = bytes_to_utf8(r, &len);
3466 /* There are several snags with this code on EBCDIC:
3467 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3468 2. scan_const() in toke.c has encoded chars in native encoding which makes
3469 ranges at least in EBCDIC 0..255 range the bottom odd.
3473 U8 tmpbuf[UTF8_MAXBYTES+1];
3476 Newx(cp, 2*tlen, UV);
3478 transv = newSVpvs("");
3480 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3482 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3484 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3488 cp[2*i+1] = cp[2*i];
3492 qsort(cp, i, 2*sizeof(UV), uvcompare);
3493 for (j = 0; j < i; j++) {
3495 diff = val - nextmin;
3497 t = uvuni_to_utf8(tmpbuf,nextmin);
3498 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3500 U8 range_mark = UTF_TO_NATIVE(0xff);
3501 t = uvuni_to_utf8(tmpbuf, val - 1);
3502 sv_catpvn(transv, (char *)&range_mark, 1);
3503 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3510 t = uvuni_to_utf8(tmpbuf,nextmin);
3511 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3513 U8 range_mark = UTF_TO_NATIVE(0xff);
3514 sv_catpvn(transv, (char *)&range_mark, 1);
3516 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3517 UNICODE_ALLOW_SUPER);
3518 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3519 t = (const U8*)SvPVX_const(transv);
3520 tlen = SvCUR(transv);
3524 else if (!rlen && !del) {
3525 r = t; rlen = tlen; rend = tend;
3528 if ((!rlen && !del) || t == r ||
3529 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3531 o->op_private |= OPpTRANS_IDENTICAL;
3535 while (t < tend || tfirst <= tlast) {
3536 /* see if we need more "t" chars */
3537 if (tfirst > tlast) {
3538 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3540 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3542 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3549 /* now see if we need more "r" chars */
3550 if (rfirst > rlast) {
3552 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3554 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3556 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3565 rfirst = rlast = 0xffffffff;
3569 /* now see which range will peter our first, if either. */
3570 tdiff = tlast - tfirst;
3571 rdiff = rlast - rfirst;
3578 if (rfirst == 0xffffffff) {
3579 diff = tdiff; /* oops, pretend rdiff is infinite */
3581 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3582 (long)tfirst, (long)tlast);
3584 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3588 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3589 (long)tfirst, (long)(tfirst + diff),
3592 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3593 (long)tfirst, (long)rfirst);
3595 if (rfirst + diff > max)
3596 max = rfirst + diff;
3598 grows = (tfirst < rfirst &&
3599 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3611 else if (max > 0xff)
3616 PerlMemShared_free(cPVOPo->op_pv);
3617 cPVOPo->op_pv = NULL;
3619 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3621 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3622 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3623 PAD_SETSV(cPADOPo->op_padix, swash);
3625 SvREADONLY_on(swash);
3627 cSVOPo->op_sv = swash;
3629 SvREFCNT_dec(listsv);
3630 SvREFCNT_dec(transv);
3632 if (!del && havefinal && rlen)
3633 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3634 newSVuv((UV)final), 0);
3637 o->op_private |= OPpTRANS_GROWS;
3643 op_getmad(expr,o,'e');
3644 op_getmad(repl,o,'r');
3652 tbl = (short*)cPVOPo->op_pv;
3654 Zero(tbl, 256, short);
3655 for (i = 0; i < (I32)tlen; i++)
3657 for (i = 0, j = 0; i < 256; i++) {
3659 if (j >= (I32)rlen) {
3668 if (i < 128 && r[j] >= 128)
3678 o->op_private |= OPpTRANS_IDENTICAL;
3680 else if (j >= (I32)rlen)
3685 PerlMemShared_realloc(tbl,
3686 (0x101+rlen-j) * sizeof(short));
3687 cPVOPo->op_pv = (char*)tbl;
3689 tbl[0x100] = (short)(rlen - j);
3690 for (i=0; i < (I32)rlen - j; i++)
3691 tbl[0x101+i] = r[j+i];
3695 if (!rlen && !del) {
3698 o->op_private |= OPpTRANS_IDENTICAL;
3700 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3701 o->op_private |= OPpTRANS_IDENTICAL;
3703 for (i = 0; i < 256; i++)
3705 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3706 if (j >= (I32)rlen) {
3708 if (tbl[t[i]] == -1)
3714 if (tbl[t[i]] == -1) {
3715 if (t[i] < 128 && r[j] >= 128)
3722 if(del && rlen == tlen) {
3723 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3724 } else if(rlen > tlen) {
3725 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3729 o->op_private |= OPpTRANS_GROWS;
3731 op_getmad(expr,o,'e');
3732 op_getmad(repl,o,'r');
3742 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3744 Constructs, checks, and returns an op of any pattern matching type.
3745 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3746 and, shifted up eight bits, the eight bits of C<op_private>.
3752 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3757 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3759 NewOp(1101, pmop, 1, PMOP);
3760 pmop->op_type = (OPCODE)type;
3761 pmop->op_ppaddr = PL_ppaddr[type];
3762 pmop->op_flags = (U8)flags;
3763 pmop->op_private = (U8)(0 | (flags >> 8));
3765 if (PL_hints & HINT_RE_TAINT)
3766 pmop->op_pmflags |= PMf_RETAINT;
3767 if (PL_hints & HINT_LOCALE) {
3768 pmop->op_pmflags |= PMf_LOCALE;
3770 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3771 pmop->op_pmflags |= RXf_PMf_UNICODE;
3773 if (PL_hints & HINT_RE_FLAGS) {
3774 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3775 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3777 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3778 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3779 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_dul"), 0, 0
3781 if (reflags && SvOK(reflags)) {
3782 pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
3783 pmop->op_pmflags |= SvIV(reflags);
3789 assert(SvPOK(PL_regex_pad[0]));
3790 if (SvCUR(PL_regex_pad[0])) {
3791 /* Pop off the "packed" IV from the end. */
3792 SV *const repointer_list = PL_regex_pad[0];
3793 const char *p = SvEND(repointer_list) - sizeof(IV);
3794 const IV offset = *((IV*)p);
3796 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3798 SvEND_set(repointer_list, p);
3800 pmop->op_pmoffset = offset;
3801 /* This slot should be free, so assert this: */
3802 assert(PL_regex_pad[offset] == &PL_sv_undef);
3804 SV * const repointer = &PL_sv_undef;
3805 av_push(PL_regex_padav, repointer);
3806 pmop->op_pmoffset = av_len(PL_regex_padav);
3807 PL_regex_pad = AvARRAY(PL_regex_padav);
3811 return CHECKOP(type, pmop);
3814 /* Given some sort of match op o, and an expression expr containing a
3815 * pattern, either compile expr into a regex and attach it to o (if it's
3816 * constant), or convert expr into a runtime regcomp op sequence (if it's
3819 * isreg indicates that the pattern is part of a regex construct, eg
3820 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3821 * split "pattern", which aren't. In the former case, expr will be a list
3822 * if the pattern contains more than one term (eg /a$b/) or if it contains
3823 * a replacement, ie s/// or tr///.
3827 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3832 I32 repl_has_vars = 0;
3836 PERL_ARGS_ASSERT_PMRUNTIME;
3839 o->op_type == OP_SUBST
3840 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
3842 /* last element in list is the replacement; pop it */
3844 repl = cLISTOPx(expr)->op_last;
3845 kid = cLISTOPx(expr)->op_first;
3846 while (kid->op_sibling != repl)
3847 kid = kid->op_sibling;
3848 kid->op_sibling = NULL;
3849 cLISTOPx(expr)->op_last = kid;
3852 if (isreg && expr->op_type == OP_LIST &&
3853 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3855 /* convert single element list to element */
3856 OP* const oe = expr;
3857 expr = cLISTOPx(oe)->op_first->op_sibling;
3858 cLISTOPx(oe)->op_first->op_sibling = NULL;
3859 cLISTOPx(oe)->op_last = NULL;
3863 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
3864 return pmtrans(o, expr, repl);
3867 reglist = isreg && expr->op_type == OP_LIST;
3871 PL_hints |= HINT_BLOCK_SCOPE;
3874 if (expr->op_type == OP_CONST) {
3875 SV *pat = ((SVOP*)expr)->op_sv;
3876 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3878 if (o->op_flags & OPf_SPECIAL)
3879 pm_flags |= RXf_SPLIT;
3882 assert (SvUTF8(pat));
3883 } else if (SvUTF8(pat)) {
3884 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3885 trapped in use 'bytes'? */
3886 /* Make a copy of the octet sequence, but without the flag on, as
3887 the compiler now honours the SvUTF8 flag on pat. */
3889 const char *const p = SvPV(pat, len);
3890 pat = newSVpvn_flags(p, len, SVs_TEMP);
3893 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3896 op_getmad(expr,(OP*)pm,'e');
3902 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3903 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3905 : OP_REGCMAYBE),0,expr);
3907 NewOp(1101, rcop, 1, LOGOP);
3908 rcop->op_type = OP_REGCOMP;
3909 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3910 rcop->op_first = scalar(expr);
3911 rcop->op_flags |= OPf_KIDS
3912 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3913 | (reglist ? OPf_STACKED : 0);
3914 rcop->op_private = 1;
3917 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3919 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3922 /* establish postfix order */
3923 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3925 rcop->op_next = expr;
3926 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3929 rcop->op_next = LINKLIST(expr);
3930 expr->op_next = (OP*)rcop;
3933 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3938 if (pm->op_pmflags & PMf_EVAL) {
3940 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3941 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3943 else if (repl->op_type == OP_CONST)
3947 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3948 if (curop->op_type == OP_SCOPE
3949 || curop->op_type == OP_LEAVE
3950 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3951 if (curop->op_type == OP_GV) {
3952 GV * const gv = cGVOPx_gv(curop);
3954 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3957 else if (curop->op_type == OP_RV2CV)
3959 else if (curop->op_type == OP_RV2SV ||
3960 curop->op_type == OP_RV2AV ||
3961 curop->op_type == OP_RV2HV ||
3962 curop->op_type == OP_RV2GV) {
3963 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3966 else if (curop->op_type == OP_PADSV ||
3967 curop->op_type == OP_PADAV ||
3968 curop->op_type == OP_PADHV ||
3969 curop->op_type == OP_PADANY)
3973 else if (curop->op_type == OP_PUSHRE)
3974 NOOP; /* Okay here, dangerous in newASSIGNOP */
3984 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3986 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3987 op_prepend_elem(o->op_type, scalar(repl), o);
3990 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3991 pm->op_pmflags |= PMf_MAYBE_CONST;
3993 NewOp(1101, rcop, 1, LOGOP);
3994 rcop->op_type = OP_SUBSTCONT;
3995 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3996 rcop->op_first = scalar(repl);
3997 rcop->op_flags |= OPf_KIDS;
3998 rcop->op_private = 1;
4001 /* establish postfix order */
4002 rcop->op_next = LINKLIST(repl);
4003 repl->op_next = (OP*)rcop;
4005 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4006 assert(!(pm->op_pmflags & PMf_ONCE));
4007 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4016 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4018 Constructs, checks, and returns an op of any type that involves an
4019 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4020 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4021 takes ownership of one reference to it.
4027 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4032 PERL_ARGS_ASSERT_NEWSVOP;
4034 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4035 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4036 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4038 NewOp(1101, svop, 1, SVOP);
4039 svop->op_type = (OPCODE)type;
4040 svop->op_ppaddr = PL_ppaddr[type];
4042 svop->op_next = (OP*)svop;
4043 svop->op_flags = (U8)flags;
4044 if (PL_opargs[type] & OA_RETSCALAR)
4046 if (PL_opargs[type] & OA_TARGET)
4047 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4048 return CHECKOP(type, svop);
4054 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4056 Constructs, checks, and returns an op of any type that involves a
4057 reference to a pad element. I<type> is the opcode. I<flags> gives the
4058 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4059 is populated with I<sv>; this function takes ownership of one reference
4062 This function only exists if Perl has been compiled to use ithreads.
4068 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4073 PERL_ARGS_ASSERT_NEWPADOP;
4075 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4076 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4077 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4079 NewOp(1101, padop, 1, PADOP);
4080 padop->op_type = (OPCODE)type;
4081 padop->op_ppaddr = PL_ppaddr[type];
4082 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4083 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4084 PAD_SETSV(padop->op_padix, sv);
4087 padop->op_next = (OP*)padop;
4088 padop->op_flags = (U8)flags;
4089 if (PL_opargs[type] & OA_RETSCALAR)
4091 if (PL_opargs[type] & OA_TARGET)
4092 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4093 return CHECKOP(type, padop);
4096 #endif /* !USE_ITHREADS */
4099 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4101 Constructs, checks, and returns an op of any type that involves an
4102 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4103 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4104 reference; calling this function does not transfer ownership of any
4111 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4115 PERL_ARGS_ASSERT_NEWGVOP;
4119 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4121 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4126 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4128 Constructs, checks, and returns an op of any type that involves an
4129 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4130 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4131 must have been allocated using L</PerlMemShared_malloc>; the memory will
4132 be freed when the op is destroyed.
4138 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4143 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4144 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4146 NewOp(1101, pvop, 1, PVOP);
4147 pvop->op_type = (OPCODE)type;
4148 pvop->op_ppaddr = PL_ppaddr[type];
4150 pvop->op_next = (OP*)pvop;
4151 pvop->op_flags = (U8)flags;
4152 if (PL_opargs[type] & OA_RETSCALAR)
4154 if (PL_opargs[type] & OA_TARGET)
4155 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4156 return CHECKOP(type, pvop);
4164 Perl_package(pTHX_ OP *o)
4167 SV *const sv = cSVOPo->op_sv;
4172 PERL_ARGS_ASSERT_PACKAGE;
4174 save_hptr(&PL_curstash);
4175 save_item(PL_curstname);
4177 PL_curstash = gv_stashsv(sv, GV_ADD);
4179 sv_setsv(PL_curstname, sv);
4181 PL_hints |= HINT_BLOCK_SCOPE;
4182 PL_parser->copline = NOLINE;
4183 PL_parser->expect = XSTATE;
4188 if (!PL_madskills) {
4193 pegop = newOP(OP_NULL,0);
4194 op_getmad(o,pegop,'P');
4200 Perl_package_version( pTHX_ OP *v )
4203 U32 savehints = PL_hints;
4204 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4205 PL_hints &= ~HINT_STRICT_VARS;
4206 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4207 PL_hints = savehints;
4216 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4223 OP *pegop = newOP(OP_NULL,0);
4226 PERL_ARGS_ASSERT_UTILIZE;
4228 if (idop->op_type != OP_CONST)
4229 Perl_croak(aTHX_ "Module name must be constant");
4232 op_getmad(idop,pegop,'U');
4237 SV * const vesv = ((SVOP*)version)->op_sv;
4240 op_getmad(version,pegop,'V');
4241 if (!arg && !SvNIOKp(vesv)) {
4248 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4249 Perl_croak(aTHX_ "Version number must be a constant number");
4251 /* Make copy of idop so we don't free it twice */
4252 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4254 /* Fake up a method call to VERSION */
4255 meth = newSVpvs_share("VERSION");
4256 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4257 op_append_elem(OP_LIST,
4258 op_prepend_elem(OP_LIST, pack, list(version)),
4259 newSVOP(OP_METHOD_NAMED, 0, meth)));
4263 /* Fake up an import/unimport */
4264 if (arg && arg->op_type == OP_STUB) {
4266 op_getmad(arg,pegop,'S');
4267 imop = arg; /* no import on explicit () */
4269 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4270 imop = NULL; /* use 5.0; */
4272 idop->op_private |= OPpCONST_NOVER;
4278 op_getmad(arg,pegop,'A');
4280 /* Make copy of idop so we don't free it twice */
4281 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4283 /* Fake up a method call to import/unimport */
4285 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4286 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4287 op_append_elem(OP_LIST,
4288 op_prepend_elem(OP_LIST, pack, list(arg)),
4289 newSVOP(OP_METHOD_NAMED, 0, meth)));
4292 /* Fake up the BEGIN {}, which does its thing immediately. */
4294 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4297 op_append_elem(OP_LINESEQ,
4298 op_append_elem(OP_LINESEQ,
4299 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4300 newSTATEOP(0, NULL, veop)),
4301 newSTATEOP(0, NULL, imop) ));
4303 /* The "did you use incorrect case?" warning used to be here.
4304 * The problem is that on case-insensitive filesystems one
4305 * might get false positives for "use" (and "require"):
4306 * "use Strict" or "require CARP" will work. This causes
4307 * portability problems for the script: in case-strict
4308 * filesystems the script will stop working.
4310 * The "incorrect case" warning checked whether "use Foo"
4311 * imported "Foo" to your namespace, but that is wrong, too:
4312 * there is no requirement nor promise in the language that
4313 * a Foo.pm should or would contain anything in package "Foo".
4315 * There is very little Configure-wise that can be done, either:
4316 * the case-sensitivity of the build filesystem of Perl does not
4317 * help in guessing the case-sensitivity of the runtime environment.
4320 PL_hints |= HINT_BLOCK_SCOPE;
4321 PL_parser->copline = NOLINE;
4322 PL_parser->expect = XSTATE;
4323 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4326 if (!PL_madskills) {
4327 /* FIXME - don't allocate pegop if !PL_madskills */
4336 =head1 Embedding Functions
4338 =for apidoc load_module
4340 Loads the module whose name is pointed to by the string part of name.
4341 Note that the actual module name, not its filename, should be given.
4342 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4343 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4344 (or 0 for no flags). ver, if specified, provides version semantics
4345 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4346 arguments can be used to specify arguments to the module's import()
4347 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4348 terminated with a final NULL pointer. Note that this list can only
4349 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4350 Otherwise at least a single NULL pointer to designate the default
4351 import list is required.
4356 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4360 PERL_ARGS_ASSERT_LOAD_MODULE;
4362 va_start(args, ver);
4363 vload_module(flags, name, ver, &args);
4367 #ifdef PERL_IMPLICIT_CONTEXT
4369 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4373 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4374 va_start(args, ver);
4375 vload_module(flags, name, ver, &args);
4381 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4385 OP * const modname = newSVOP(OP_CONST, 0, name);
4387 PERL_ARGS_ASSERT_VLOAD_MODULE;
4389 modname->op_private |= OPpCONST_BARE;
4391 veop = newSVOP(OP_CONST, 0, ver);
4395 if (flags & PERL_LOADMOD_NOIMPORT) {
4396 imop = sawparens(newNULLLIST());
4398 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4399 imop = va_arg(*args, OP*);
4404 sv = va_arg(*args, SV*);
4406 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4407 sv = va_arg(*args, SV*);
4411 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4412 * that it has a PL_parser to play with while doing that, and also
4413 * that it doesn't mess with any existing parser, by creating a tmp
4414 * new parser with lex_start(). This won't actually be used for much,
4415 * since pp_require() will create another parser for the real work. */
4418 SAVEVPTR(PL_curcop);
4419 lex_start(NULL, NULL, 0);
4420 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4421 veop, modname, imop);
4426 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4432 PERL_ARGS_ASSERT_DOFILE;
4434 if (!force_builtin) {
4435 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4436 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4437 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4438 gv = gvp ? *gvp : NULL;
4442 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4443 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4444 op_append_elem(OP_LIST, term,
4445 scalar(newUNOP(OP_RV2CV, 0,
4446 newGVOP(OP_GV, 0, gv))))));
4449 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4455 =head1 Optree construction
4457 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4459 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4460 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4461 be set automatically, and, shifted up eight bits, the eight bits of
4462 C<op_private>, except that the bit with value 1 or 2 is automatically
4463 set as required. I<listval> and I<subscript> supply the parameters of
4464 the slice; they are consumed by this function and become part of the
4465 constructed op tree.
4471 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4473 return newBINOP(OP_LSLICE, flags,
4474 list(force_list(subscript)),
4475 list(force_list(listval)) );
4479 S_is_list_assignment(pTHX_ register const OP *o)
4487 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4488 o = cUNOPo->op_first;
4490 flags = o->op_flags;
4492 if (type == OP_COND_EXPR) {
4493 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4494 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4499 yyerror("Assignment to both a list and a scalar");
4503 if (type == OP_LIST &&
4504 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4505 o->op_private & OPpLVAL_INTRO)
4508 if (type == OP_LIST || flags & OPf_PARENS ||
4509 type == OP_RV2AV || type == OP_RV2HV ||
4510 type == OP_ASLICE || type == OP_HSLICE)
4513 if (type == OP_PADAV || type == OP_PADHV)
4516 if (type == OP_RV2SV)
4523 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4525 Constructs, checks, and returns an assignment op. I<left> and I<right>
4526 supply the parameters of the assignment; they are consumed by this
4527 function and become part of the constructed op tree.
4529 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4530 a suitable conditional optree is constructed. If I<optype> is the opcode
4531 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4532 performs the binary operation and assigns the result to the left argument.
4533 Either way, if I<optype> is non-zero then I<flags> has no effect.
4535 If I<optype> is zero, then a plain scalar or list assignment is
4536 constructed. Which type of assignment it is is automatically determined.
4537 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4538 will be set automatically, and, shifted up eight bits, the eight bits
4539 of C<op_private>, except that the bit with value 1 or 2 is automatically
4546 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4552 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4553 return newLOGOP(optype, 0,
4554 op_lvalue(scalar(left), optype),
4555 newUNOP(OP_SASSIGN, 0, scalar(right)));
4558 return newBINOP(optype, OPf_STACKED,
4559 op_lvalue(scalar(left), optype), scalar(right));
4563 if (is_list_assignment(left)) {
4564 static const char no_list_state[] = "Initialization of state variables"
4565 " in list context currently forbidden";
4567 bool maybe_common_vars = TRUE;
4570 /* Grandfathering $[ assignment here. Bletch.*/
4571 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4572 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4573 left = op_lvalue(left, OP_AASSIGN);
4576 else if (left->op_type == OP_CONST) {
4577 deprecate("assignment to $[");
4579 /* Result of assignment is always 1 (or we'd be dead already) */
4580 return newSVOP(OP_CONST, 0, newSViv(1));
4582 curop = list(force_list(left));
4583 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4584 o->op_private = (U8)(0 | (flags >> 8));
4586 if ((left->op_type == OP_LIST
4587 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4589 OP* lop = ((LISTOP*)left)->op_first;
4590 maybe_common_vars = FALSE;
4592 if (lop->op_type == OP_PADSV ||
4593 lop->op_type == OP_PADAV ||
4594 lop->op_type == OP_PADHV ||
4595 lop->op_type == OP_PADANY) {
4596 if (!(lop->op_private & OPpLVAL_INTRO))
4597 maybe_common_vars = TRUE;
4599 if (lop->op_private & OPpPAD_STATE) {
4600 if (left->op_private & OPpLVAL_INTRO) {
4601 /* Each variable in state($a, $b, $c) = ... */
4604 /* Each state variable in
4605 (state $a, my $b, our $c, $d, undef) = ... */
4607 yyerror(no_list_state);
4609 /* Each my variable in
4610 (state $a, my $b, our $c, $d, undef) = ... */
4612 } else if (lop->op_type == OP_UNDEF ||
4613 lop->op_type == OP_PUSHMARK) {
4614 /* undef may be interesting in
4615 (state $a, undef, state $c) */
4617 /* Other ops in the list. */
4618 maybe_common_vars = TRUE;
4620 lop = lop->op_sibling;
4623 else if ((left->op_private & OPpLVAL_INTRO)
4624 && ( left->op_type == OP_PADSV
4625 || left->op_type == OP_PADAV
4626 || left->op_type == OP_PADHV
4627 || left->op_type == OP_PADANY))
4629 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4630 if (left->op_private & OPpPAD_STATE) {
4631 /* All single variable list context state assignments, hence
4641 yyerror(no_list_state);
4645 /* PL_generation sorcery:
4646 * an assignment like ($a,$b) = ($c,$d) is easier than
4647 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4648 * To detect whether there are common vars, the global var
4649 * PL_generation is incremented for each assign op we compile.
4650 * Then, while compiling the assign op, we run through all the
4651 * variables on both sides of the assignment, setting a spare slot
4652 * in each of them to PL_generation. If any of them already have
4653 * that value, we know we've got commonality. We could use a
4654 * single bit marker, but then we'd have to make 2 passes, first
4655 * to clear the flag, then to test and set it. To find somewhere
4656 * to store these values, evil chicanery is done with SvUVX().
4659 if (maybe_common_vars) {
4662 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4663 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4664 if (curop->op_type == OP_GV) {
4665 GV *gv = cGVOPx_gv(curop);
4667 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4669 GvASSIGN_GENERATION_set(gv, PL_generation);
4671 else if (curop->op_type == OP_PADSV ||
4672 curop->op_type == OP_PADAV ||
4673 curop->op_type == OP_PADHV ||
4674 curop->op_type == OP_PADANY)
4676 if (PAD_COMPNAME_GEN(curop->op_targ)
4677 == (STRLEN)PL_generation)
4679 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4682 else if (curop->op_type == OP_RV2CV)
4684 else if (curop->op_type == OP_RV2SV ||
4685 curop->op_type == OP_RV2AV ||
4686 curop->op_type == OP_RV2HV ||
4687 curop->op_type == OP_RV2GV) {
4688 if (lastop->op_type != OP_GV) /* funny deref? */
4691 else if (curop->op_type == OP_PUSHRE) {
4693 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4694 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4696 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4698 GvASSIGN_GENERATION_set(gv, PL_generation);
4702 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4705 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4707 GvASSIGN_GENERATION_set(gv, PL_generation);
4717 o->op_private |= OPpASSIGN_COMMON;
4720 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4721 OP* tmpop = ((LISTOP*)right)->op_first;
4722 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4723 PMOP * const pm = (PMOP*)tmpop;
4724 if (left->op_type == OP_RV2AV &&
4725 !(left->op_private & OPpLVAL_INTRO) &&
4726 !(o->op_private & OPpASSIGN_COMMON) )
4728 tmpop = ((UNOP*)left)->op_first;
4729 if (tmpop->op_type == OP_GV
4731 && !pm->op_pmreplrootu.op_pmtargetoff
4733 && !pm->op_pmreplrootu.op_pmtargetgv
4737 pm->op_pmreplrootu.op_pmtargetoff
4738 = cPADOPx(tmpop)->op_padix;
4739 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4741 pm->op_pmreplrootu.op_pmtargetgv
4742 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4743 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4745 pm->op_pmflags |= PMf_ONCE;
4746 tmpop = cUNOPo->op_first; /* to list (nulled) */
4747 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4748 tmpop->op_sibling = NULL; /* don't free split */
4749 right->op_next = tmpop->op_next; /* fix starting loc */
4750 op_free(o); /* blow off assign */
4751 right->op_flags &= ~OPf_WANT;
4752 /* "I don't know and I don't care." */
4757 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4758 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4760 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4761 if (SvIOK(sv) && SvIVX(sv) == 0)
4762 sv_setiv(sv, PL_modcount+1);
4770 right = newOP(OP_UNDEF, 0);
4771 if (right->op_type == OP_READLINE) {
4772 right->op_flags |= OPf_STACKED;
4773 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
4777 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4778 o = newBINOP(OP_SASSIGN, flags,
4779 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
4783 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4784 deprecate("assignment to $[");
4786 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4787 o->op_private |= OPpCONST_ARYBASE;
4795 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4797 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4798 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4799 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4800 If I<label> is non-null, it supplies the name of a label to attach to
4801 the state op; this function takes ownership of the memory pointed at by
4802 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4805 If I<o> is null, the state op is returned. Otherwise the state op is
4806 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4807 is consumed by this function and becomes part of the returned op tree.
4813 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4816 const U32 seq = intro_my();
4819 NewOp(1101, cop, 1, COP);
4820 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4821 cop->op_type = OP_DBSTATE;
4822 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4825 cop->op_type = OP_NEXTSTATE;
4826 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4828 cop->op_flags = (U8)flags;
4829 CopHINTS_set(cop, PL_hints);
4831 cop->op_private |= NATIVE_HINTS;
4833 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4834 cop->op_next = (OP*)cop;
4837 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4838 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4840 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4841 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4843 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4845 PL_hints |= HINT_BLOCK_SCOPE;
4846 /* It seems that we need to defer freeing this pointer, as other parts
4847 of the grammar end up wanting to copy it after this op has been
4852 if (PL_parser && PL_parser->copline == NOLINE)
4853 CopLINE_set(cop, CopLINE(PL_curcop));
4855 CopLINE_set(cop, PL_parser->copline);
4857 PL_parser->copline = NOLINE;
4860 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4862 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4864 CopSTASH_set(cop, PL_curstash);
4866 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4867 /* this line can have a breakpoint - store the cop in IV */
4868 AV *av = CopFILEAVx(PL_curcop);
4870 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4871 if (svp && *svp != &PL_sv_undef ) {
4872 (void)SvIOK_on(*svp);
4873 SvIV_set(*svp, PTR2IV(cop));
4878 if (flags & OPf_SPECIAL)
4880 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4884 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4886 Constructs, checks, and returns a logical (flow control) op. I<type>
4887 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4888 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4889 the eight bits of C<op_private>, except that the bit with value 1 is
4890 automatically set. I<first> supplies the expression controlling the
4891 flow, and I<other> supplies the side (alternate) chain of ops; they are
4892 consumed by this function and become part of the constructed op tree.
4898 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4902 PERL_ARGS_ASSERT_NEWLOGOP;
4904 return new_logop(type, flags, &first, &other);
4908 S_search_const(pTHX_ OP *o)
4910 PERL_ARGS_ASSERT_SEARCH_CONST;
4912 switch (o->op_type) {
4916 if (o->op_flags & OPf_KIDS)
4917 return search_const(cUNOPo->op_first);
4924 if (!(o->op_flags & OPf_KIDS))
4926 kid = cLISTOPo->op_first;
4928 switch (kid->op_type) {
4932 kid = kid->op_sibling;
4935 if (kid != cLISTOPo->op_last)
4941 kid = cLISTOPo->op_last;
4943 return search_const(kid);
4951 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4959 int prepend_not = 0;
4961 PERL_ARGS_ASSERT_NEW_LOGOP;
4966 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4967 return newBINOP(type, flags, scalar(first), scalar(other));
4969 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4971 scalarboolean(first);
4972 /* optimize AND and OR ops that have NOTs as children */
4973 if (first->op_type == OP_NOT
4974 && (first->op_flags & OPf_KIDS)
4975 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4976 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4978 if (type == OP_AND || type == OP_OR) {
4984 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4986 prepend_not = 1; /* prepend a NOT op later */
4990 /* search for a constant op that could let us fold the test */
4991 if ((cstop = search_const(first))) {
4992 if (cstop->op_private & OPpCONST_STRICT)
4993 no_bareword_allowed(cstop);
4994 else if ((cstop->op_private & OPpCONST_BARE))
4995 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4996 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4997 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4998 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5000 if (other->op_type == OP_CONST)
5001 other->op_private |= OPpCONST_SHORTCIRCUIT;
5003 OP *newop = newUNOP(OP_NULL, 0, other);
5004 op_getmad(first, newop, '1');
5005 newop->op_targ = type; /* set "was" field */
5009 if (other->op_type == OP_LEAVE)
5010 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5011 else if (other->op_type == OP_MATCH
5012 || other->op_type == OP_SUBST
5013 || other->op_type == OP_TRANSR
5014 || other->op_type == OP_TRANS)
5015 /* Mark the op as being unbindable with =~ */
5016 other->op_flags |= OPf_SPECIAL;
5020 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5021 const OP *o2 = other;
5022 if ( ! (o2->op_type == OP_LIST
5023 && (( o2 = cUNOPx(o2)->op_first))
5024 && o2->op_type == OP_PUSHMARK
5025 && (( o2 = o2->op_sibling)) )
5028 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5029 || o2->op_type == OP_PADHV)
5030 && o2->op_private & OPpLVAL_INTRO
5031 && !(o2->op_private & OPpPAD_STATE))
5033 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5034 "Deprecated use of my() in false conditional");
5038 if (first->op_type == OP_CONST)
5039 first->op_private |= OPpCONST_SHORTCIRCUIT;
5041 first = newUNOP(OP_NULL, 0, first);
5042 op_getmad(other, first, '2');
5043 first->op_targ = type; /* set "was" field */
5050 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5051 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5053 const OP * const k1 = ((UNOP*)first)->op_first;
5054 const OP * const k2 = k1->op_sibling;
5056 switch (first->op_type)
5059 if (k2 && k2->op_type == OP_READLINE
5060 && (k2->op_flags & OPf_STACKED)
5061 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5063 warnop = k2->op_type;
5068 if (k1->op_type == OP_READDIR
5069 || k1->op_type == OP_GLOB
5070 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5071 || k1->op_type == OP_EACH)
5073 warnop = ((k1->op_type == OP_NULL)
5074 ? (OPCODE)k1->op_targ : k1->op_type);
5079 const line_t oldline = CopLINE(PL_curcop);
5080 CopLINE_set(PL_curcop, PL_parser->copline);
5081 Perl_warner(aTHX_ packWARN(WARN_MISC),
5082 "Value of %s%s can be \"0\"; test with defined()",
5084 ((warnop == OP_READLINE || warnop == OP_GLOB)
5085 ? " construct" : "() operator"));
5086 CopLINE_set(PL_curcop, oldline);
5093 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5094 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5096 NewOp(1101, logop, 1, LOGOP);
5098 logop->op_type = (OPCODE)type;
5099 logop->op_ppaddr = PL_ppaddr[type];
5100 logop->op_first = first;
5101 logop->op_flags = (U8)(flags | OPf_KIDS);
5102 logop->op_other = LINKLIST(other);
5103 logop->op_private = (U8)(1 | (flags >> 8));
5105 /* establish postfix order */
5106 logop->op_next = LINKLIST(first);
5107 first->op_next = (OP*)logop;
5108 first->op_sibling = other;
5110 CHECKOP(type,logop);
5112 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5119 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5121 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5122 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5123 will be set automatically, and, shifted up eight bits, the eight bits of
5124 C<op_private>, except that the bit with value 1 is automatically set.
5125 I<first> supplies the expression selecting between the two branches,
5126 and I<trueop> and I<falseop> supply the branches; they are consumed by
5127 this function and become part of the constructed op tree.
5133 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5141 PERL_ARGS_ASSERT_NEWCONDOP;
5144 return newLOGOP(OP_AND, 0, first, trueop);
5146 return newLOGOP(OP_OR, 0, first, falseop);
5148 scalarboolean(first);
5149 if ((cstop = search_const(first))) {
5150 /* Left or right arm of the conditional? */
5151 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5152 OP *live = left ? trueop : falseop;
5153 OP *const dead = left ? falseop : trueop;
5154 if (cstop->op_private & OPpCONST_BARE &&
5155 cstop->op_private & OPpCONST_STRICT) {
5156 no_bareword_allowed(cstop);
5159 /* This is all dead code when PERL_MAD is not defined. */
5160 live = newUNOP(OP_NULL, 0, live);
5161 op_getmad(first, live, 'C');
5162 op_getmad(dead, live, left ? 'e' : 't');
5167 if (live->op_type == OP_LEAVE)
5168 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5169 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5170 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5171 /* Mark the op as being unbindable with =~ */
5172 live->op_flags |= OPf_SPECIAL;
5175 NewOp(1101, logop, 1, LOGOP);
5176 logop->op_type = OP_COND_EXPR;
5177 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5178 logop->op_first = first;
5179 logop->op_flags = (U8)(flags | OPf_KIDS);
5180 logop->op_private = (U8)(1 | (flags >> 8));
5181 logop->op_other = LINKLIST(trueop);
5182 logop->op_next = LINKLIST(falseop);
5184 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5187 /* establish postfix order */
5188 start = LINKLIST(first);
5189 first->op_next = (OP*)logop;
5191 first->op_sibling = trueop;
5192 trueop->op_sibling = falseop;
5193 o = newUNOP(OP_NULL, 0, (OP*)logop);
5195 trueop->op_next = falseop->op_next = o;
5202 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5204 Constructs and returns a C<range> op, with subordinate C<flip> and
5205 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5206 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5207 for both the C<flip> and C<range> ops, except that the bit with value
5208 1 is automatically set. I<left> and I<right> supply the expressions
5209 controlling the endpoints of the range; they are consumed by this function
5210 and become part of the constructed op tree.
5216 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5225 PERL_ARGS_ASSERT_NEWRANGE;
5227 NewOp(1101, range, 1, LOGOP);
5229 range->op_type = OP_RANGE;
5230 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5231 range->op_first = left;
5232 range->op_flags = OPf_KIDS;
5233 leftstart = LINKLIST(left);
5234 range->op_other = LINKLIST(right);
5235 range->op_private = (U8)(1 | (flags >> 8));
5237 left->op_sibling = right;
5239 range->op_next = (OP*)range;
5240 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5241 flop = newUNOP(OP_FLOP, 0, flip);
5242 o = newUNOP(OP_NULL, 0, flop);
5244 range->op_next = leftstart;
5246 left->op_next = flip;
5247 right->op_next = flop;
5249 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5250 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5251 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5252 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5254 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5255 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5258 if (!flip->op_private || !flop->op_private)
5259 LINKLIST(o); /* blow off optimizer unless constant */
5265 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5267 Constructs, checks, and returns an op tree expressing a loop. This is
5268 only a loop in the control flow through the op tree; it does not have
5269 the heavyweight loop structure that allows exiting the loop by C<last>
5270 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5271 top-level op, except that some bits will be set automatically as required.
5272 I<expr> supplies the expression controlling loop iteration, and I<block>
5273 supplies the body of the loop; they are consumed by this function and
5274 become part of the constructed op tree. I<debuggable> is currently
5275 unused and should always be 1.
5281 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5286 const bool once = block && block->op_flags & OPf_SPECIAL &&
5287 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5289 PERL_UNUSED_ARG(debuggable);
5292 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5293 return block; /* do {} while 0 does once */
5294 if (expr->op_type == OP_READLINE
5295 || expr->op_type == OP_READDIR
5296 || expr->op_type == OP_GLOB
5297 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5298 expr = newUNOP(OP_DEFINED, 0,
5299 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5300 } else if (expr->op_flags & OPf_KIDS) {
5301 const OP * const k1 = ((UNOP*)expr)->op_first;
5302 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5303 switch (expr->op_type) {
5305 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5306 && (k2->op_flags & OPf_STACKED)
5307 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5308 expr = newUNOP(OP_DEFINED, 0, expr);
5312 if (k1 && (k1->op_type == OP_READDIR
5313 || k1->op_type == OP_GLOB
5314 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5315 || k1->op_type == OP_EACH))
5316 expr = newUNOP(OP_DEFINED, 0, expr);
5322 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5323 * op, in listop. This is wrong. [perl #27024] */
5325 block = newOP(OP_NULL, 0);
5326 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5327 o = new_logop(OP_AND, 0, &expr, &listop);
5330 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5332 if (once && o != listop)
5333 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5336 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5338 o->op_flags |= flags;
5340 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5345 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5347 Constructs, checks, and returns an op tree expressing a C<while> loop.
5348 This is a heavyweight loop, with structure that allows exiting the loop
5349 by C<last> and suchlike.
5351 I<loop> is an optional preconstructed C<enterloop> op to use in the
5352 loop; if it is null then a suitable op will be constructed automatically.
5353 I<expr> supplies the loop's controlling expression. I<block> supplies the
5354 main body of the loop, and I<cont> optionally supplies a C<continue> block
5355 that operates as a second half of the body. All of these optree inputs
5356 are consumed by this function and become part of the constructed op tree.
5358 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5359 op and, shifted up eight bits, the eight bits of C<op_private> for
5360 the C<leaveloop> op, except that (in both cases) some bits will be set
5361 automatically. I<debuggable> is currently unused and should always be 1.
5362 I<has_my> can be supplied as true to force the
5363 loop body to be enclosed in its own scope.
5369 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5370 OP *expr, OP *block, OP *cont, I32 has_my)
5379 PERL_UNUSED_ARG(debuggable);
5382 if (expr->op_type == OP_READLINE
5383 || expr->op_type == OP_READDIR
5384 || expr->op_type == OP_GLOB
5385 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5386 expr = newUNOP(OP_DEFINED, 0,
5387 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5388 } else if (expr->op_flags & OPf_KIDS) {
5389 const OP * const k1 = ((UNOP*)expr)->op_first;
5390 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5391 switch (expr->op_type) {
5393 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5394 && (k2->op_flags & OPf_STACKED)
5395 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5396 expr = newUNOP(OP_DEFINED, 0, expr);
5400 if (k1 && (k1->op_type == OP_READDIR
5401 || k1->op_type == OP_GLOB
5402 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5403 || k1->op_type == OP_EACH))
5404 expr = newUNOP(OP_DEFINED, 0, expr);
5411 block = newOP(OP_NULL, 0);
5412 else if (cont || has_my) {
5413 block = op_scope(block);
5417 next = LINKLIST(cont);
5420 OP * const unstack = newOP(OP_UNSTACK, 0);
5423 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5427 listop = op_append_list(OP_LINESEQ, block, cont);
5429 redo = LINKLIST(listop);
5433 o = new_logop(OP_AND, 0, &expr, &listop);
5434 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5435 op_free(expr); /* oops, it's a while (0) */
5437 return NULL; /* listop already freed by new_logop */
5440 ((LISTOP*)listop)->op_last->op_next =
5441 (o == listop ? redo : LINKLIST(o));
5447 NewOp(1101,loop,1,LOOP);
5448 loop->op_type = OP_ENTERLOOP;
5449 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5450 loop->op_private = 0;
5451 loop->op_next = (OP*)loop;
5454 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5456 loop->op_redoop = redo;
5457 loop->op_lastop = o;
5458 o->op_private |= loopflags;
5461 loop->op_nextop = next;
5463 loop->op_nextop = o;
5465 o->op_flags |= flags;
5466 o->op_private |= (flags >> 8);
5471 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5473 Constructs, checks, and returns an op tree expressing a C<foreach>
5474 loop (iteration through a list of values). This is a heavyweight loop,
5475 with structure that allows exiting the loop by C<last> and suchlike.
5477 I<sv> optionally supplies the variable that will be aliased to each
5478 item in turn; if null, it defaults to C<$_> (either lexical or global).
5479 I<expr> supplies the list of values to iterate over. I<block> supplies
5480 the main body of the loop, and I<cont> optionally supplies a C<continue>
5481 block that operates as a second half of the body. All of these optree
5482 inputs are consumed by this function and become part of the constructed
5485 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5486 op and, shifted up eight bits, the eight bits of C<op_private> for
5487 the C<leaveloop> op, except that (in both cases) some bits will be set
5494 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5499 PADOFFSET padoff = 0;
5504 PERL_ARGS_ASSERT_NEWFOROP;
5507 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5508 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5509 sv->op_type = OP_RV2GV;
5510 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5512 /* The op_type check is needed to prevent a possible segfault
5513 * if the loop variable is undeclared and 'strict vars' is in
5514 * effect. This is illegal but is nonetheless parsed, so we
5515 * may reach this point with an OP_CONST where we're expecting
5518 if (cUNOPx(sv)->op_first->op_type == OP_GV
5519 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5520 iterpflags |= OPpITER_DEF;
5522 else if (sv->op_type == OP_PADSV) { /* private variable */
5523 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5524 padoff = sv->op_targ;
5534 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5536 SV *const namesv = PAD_COMPNAME_SV(padoff);
5538 const char *const name = SvPV_const(namesv, len);
5540 if (len == 2 && name[0] == '$' && name[1] == '_')
5541 iterpflags |= OPpITER_DEF;
5545 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5546 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5547 sv = newGVOP(OP_GV, 0, PL_defgv);
5552 iterpflags |= OPpITER_DEF;
5554 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5555 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5556 iterflags |= OPf_STACKED;
5558 else if (expr->op_type == OP_NULL &&
5559 (expr->op_flags & OPf_KIDS) &&
5560 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5562 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5563 * set the STACKED flag to indicate that these values are to be
5564 * treated as min/max values by 'pp_iterinit'.
5566 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5567 LOGOP* const range = (LOGOP*) flip->op_first;
5568 OP* const left = range->op_first;
5569 OP* const right = left->op_sibling;
5572 range->op_flags &= ~OPf_KIDS;
5573 range->op_first = NULL;
5575 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5576 listop->op_first->op_next = range->op_next;
5577 left->op_next = range->op_other;
5578 right->op_next = (OP*)listop;
5579 listop->op_next = listop->op_first;
5582 op_getmad(expr,(OP*)listop,'O');
5586 expr = (OP*)(listop);
5588 iterflags |= OPf_STACKED;
5591 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5594 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5595 op_append_elem(OP_LIST, expr, scalar(sv))));
5596 assert(!loop->op_next);
5597 /* for my $x () sets OPpLVAL_INTRO;
5598 * for our $x () sets OPpOUR_INTRO */
5599 loop->op_private = (U8)iterpflags;
5600 #ifdef PL_OP_SLAB_ALLOC
5603 NewOp(1234,tmp,1,LOOP);
5604 Copy(loop,tmp,1,LISTOP);
5605 S_op_destroy(aTHX_ (OP*)loop);
5609 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5611 loop->op_targ = padoff;
5612 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5614 op_getmad(madsv, (OP*)loop, 'v');
5619 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5621 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5622 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5623 determining the target of the op; it is consumed by this function and
5624 become part of the constructed op tree.
5630 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5635 PERL_ARGS_ASSERT_NEWLOOPEX;
5637 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5639 if (type != OP_GOTO || label->op_type == OP_CONST) {
5640 /* "last()" means "last" */
5641 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5642 o = newOP(type, OPf_SPECIAL);
5644 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5645 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5649 op_getmad(label,o,'L');
5655 /* Check whether it's going to be a goto &function */
5656 if (label->op_type == OP_ENTERSUB
5657 && !(label->op_flags & OPf_STACKED))
5658 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
5659 o = newUNOP(type, OPf_STACKED, label);
5661 PL_hints |= HINT_BLOCK_SCOPE;
5665 /* if the condition is a literal array or hash
5666 (or @{ ... } etc), make a reference to it.
5669 S_ref_array_or_hash(pTHX_ OP *cond)
5672 && (cond->op_type == OP_RV2AV
5673 || cond->op_type == OP_PADAV
5674 || cond->op_type == OP_RV2HV
5675 || cond->op_type == OP_PADHV))
5677 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
5680 && (cond->op_type == OP_ASLICE
5681 || cond->op_type == OP_HSLICE)) {
5683 /* anonlist now needs a list from this op, was previously used in
5685 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5686 cond->op_flags |= OPf_WANT_LIST;
5688 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
5695 /* These construct the optree fragments representing given()
5698 entergiven and enterwhen are LOGOPs; the op_other pointer
5699 points up to the associated leave op. We need this so we
5700 can put it in the context and make break/continue work.
5701 (Also, of course, pp_enterwhen will jump straight to
5702 op_other if the match fails.)
5706 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5707 I32 enter_opcode, I32 leave_opcode,
5708 PADOFFSET entertarg)
5714 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5716 NewOp(1101, enterop, 1, LOGOP);
5717 enterop->op_type = (Optype)enter_opcode;
5718 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5719 enterop->op_flags = (U8) OPf_KIDS;
5720 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5721 enterop->op_private = 0;
5723 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5726 enterop->op_first = scalar(cond);
5727 cond->op_sibling = block;
5729 o->op_next = LINKLIST(cond);
5730 cond->op_next = (OP *) enterop;
5733 /* This is a default {} block */
5734 enterop->op_first = block;
5735 enterop->op_flags |= OPf_SPECIAL;
5737 o->op_next = (OP *) enterop;
5740 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5741 entergiven and enterwhen both
5744 enterop->op_next = LINKLIST(block);
5745 block->op_next = enterop->op_other = o;
5750 /* Does this look like a boolean operation? For these purposes
5751 a boolean operation is:
5752 - a subroutine call [*]
5753 - a logical connective
5754 - a comparison operator
5755 - a filetest operator, with the exception of -s -M -A -C
5756 - defined(), exists() or eof()
5757 - /$re/ or $foo =~ /$re/
5759 [*] possibly surprising
5762 S_looks_like_bool(pTHX_ const OP *o)
5766 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5768 switch(o->op_type) {
5771 return looks_like_bool(cLOGOPo->op_first);
5775 looks_like_bool(cLOGOPo->op_first)
5776 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5781 o->op_flags & OPf_KIDS
5782 && looks_like_bool(cUNOPo->op_first));
5786 case OP_NOT: case OP_XOR:
5788 case OP_EQ: case OP_NE: case OP_LT:
5789 case OP_GT: case OP_LE: case OP_GE:
5791 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5792 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5794 case OP_SEQ: case OP_SNE: case OP_SLT:
5795 case OP_SGT: case OP_SLE: case OP_SGE:
5799 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5800 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5801 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5802 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5803 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5804 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5805 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5806 case OP_FTTEXT: case OP_FTBINARY:
5808 case OP_DEFINED: case OP_EXISTS:
5809 case OP_MATCH: case OP_EOF:
5816 /* Detect comparisons that have been optimized away */
5817 if (cSVOPo->op_sv == &PL_sv_yes
5818 || cSVOPo->op_sv == &PL_sv_no)
5831 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5833 Constructs, checks, and returns an op tree expressing a C<given> block.
5834 I<cond> supplies the expression that will be locally assigned to a lexical
5835 variable, and I<block> supplies the body of the C<given> construct; they
5836 are consumed by this function and become part of the constructed op tree.
5837 I<defsv_off> is the pad offset of the scalar lexical variable that will
5844 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5847 PERL_ARGS_ASSERT_NEWGIVENOP;
5848 return newGIVWHENOP(
5849 ref_array_or_hash(cond),
5851 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5856 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5858 Constructs, checks, and returns an op tree expressing a C<when> block.
5859 I<cond> supplies the test expression, and I<block> supplies the block
5860 that will be executed if the test evaluates to true; they are consumed
5861 by this function and become part of the constructed op tree. I<cond>
5862 will be interpreted DWIMically, often as a comparison against C<$_>,
5863 and may be null to generate a C<default> block.
5869 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5871 const bool cond_llb = (!cond || looks_like_bool(cond));
5874 PERL_ARGS_ASSERT_NEWWHENOP;
5879 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5881 scalar(ref_array_or_hash(cond)));
5884 return newGIVWHENOP(
5886 op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5887 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5891 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5894 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5896 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5897 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5898 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5899 || (p && (len != SvCUR(cv) /* Not the same length. */
5900 || memNE(p, SvPVX_const(cv), len))))
5901 && ckWARN_d(WARN_PROTOTYPE)) {
5902 SV* const msg = sv_newmortal();
5906 gv_efullname3(name = sv_newmortal(), gv, NULL);
5907 sv_setpvs(msg, "Prototype mismatch:");
5909 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5911 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5913 sv_catpvs(msg, ": none");
5914 sv_catpvs(msg, " vs ");
5916 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5918 sv_catpvs(msg, "none");
5919 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5923 static void const_sv_xsub(pTHX_ CV* cv);
5927 =head1 Optree Manipulation Functions
5929 =for apidoc cv_const_sv
5931 If C<cv> is a constant sub eligible for inlining. returns the constant
5932 value returned by the sub. Otherwise, returns NULL.
5934 Constant subs can be created with C<newCONSTSUB> or as described in
5935 L<perlsub/"Constant Functions">.
5940 Perl_cv_const_sv(pTHX_ const CV *const cv)
5942 PERL_UNUSED_CONTEXT;
5945 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5947 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5950 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5951 * Can be called in 3 ways:
5954 * look for a single OP_CONST with attached value: return the value
5956 * cv && CvCLONE(cv) && !CvCONST(cv)
5958 * examine the clone prototype, and if contains only a single
5959 * OP_CONST referencing a pad const, or a single PADSV referencing
5960 * an outer lexical, return a non-zero value to indicate the CV is
5961 * a candidate for "constizing" at clone time
5965 * We have just cloned an anon prototype that was marked as a const
5966 * candidiate. Try to grab the current value, and in the case of
5967 * PADSV, ignore it if it has multiple references. Return the value.
5971 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5982 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5983 o = cLISTOPo->op_first->op_sibling;
5985 for (; o; o = o->op_next) {
5986 const OPCODE type = o->op_type;
5988 if (sv && o->op_next == o)
5990 if (o->op_next != o) {
5991 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5993 if (type == OP_DBSTATE)
5996 if (type == OP_LEAVESUB || type == OP_RETURN)
6000 if (type == OP_CONST && cSVOPo->op_sv)
6002 else if (cv && type == OP_CONST) {
6003 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6007 else if (cv && type == OP_PADSV) {
6008 if (CvCONST(cv)) { /* newly cloned anon */
6009 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6010 /* the candidate should have 1 ref from this pad and 1 ref
6011 * from the parent */
6012 if (!sv || SvREFCNT(sv) != 2)
6019 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6020 sv = &PL_sv_undef; /* an arbitrary non-null value */
6035 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6038 /* This would be the return value, but the return cannot be reached. */
6039 OP* pegop = newOP(OP_NULL, 0);
6042 PERL_UNUSED_ARG(floor);
6052 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6054 NORETURN_FUNCTION_END;
6059 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6064 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6065 register CV *cv = NULL;
6067 /* If the subroutine has no body, no attributes, and no builtin attributes
6068 then it's just a sub declaration, and we may be able to get away with
6069 storing with a placeholder scalar in the symbol table, rather than a
6070 full GV and CV. If anything is present then it will take a full CV to
6072 const I32 gv_fetch_flags
6073 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6075 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6076 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6080 assert(proto->op_type == OP_CONST);
6081 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6087 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6089 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6090 SV * const sv = sv_newmortal();
6091 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6092 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6093 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6094 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6096 } else if (PL_curstash) {
6097 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6100 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6104 if (!PL_madskills) {
6113 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6114 maximum a prototype before. */
6115 if (SvTYPE(gv) > SVt_NULL) {
6116 if (!SvPOK((const SV *)gv)
6117 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6119 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6121 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6124 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6126 sv_setiv(MUTABLE_SV(gv), -1);
6128 SvREFCNT_dec(PL_compcv);
6129 cv = PL_compcv = NULL;
6133 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6135 if (!block || !ps || *ps || attrs
6136 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6138 || block->op_type == OP_NULL
6143 const_sv = op_const_sv(block, NULL);
6146 const bool exists = CvROOT(cv) || CvXSUB(cv);
6148 /* if the subroutine doesn't exist and wasn't pre-declared
6149 * with a prototype, assume it will be AUTOLOADed,
6150 * skipping the prototype check
6152 if (exists || SvPOK(cv))
6153 cv_ckproto_len(cv, gv, ps, ps_len);
6154 /* already defined (or promised)? */
6155 if (exists || GvASSUMECV(gv)) {
6158 || block->op_type == OP_NULL
6161 if (CvFLAGS(PL_compcv)) {
6162 /* might have had built-in attrs applied */
6163 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6164 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6165 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6167 /* just a "sub foo;" when &foo is already defined */
6168 SAVEFREESV(PL_compcv);
6173 && block->op_type != OP_NULL
6176 if (ckWARN(WARN_REDEFINE)
6178 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6180 const line_t oldline = CopLINE(PL_curcop);
6181 if (PL_parser && PL_parser->copline != NOLINE)
6182 CopLINE_set(PL_curcop, PL_parser->copline);
6183 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6184 CvCONST(cv) ? "Constant subroutine %s redefined"
6185 : "Subroutine %s redefined", name);
6186 CopLINE_set(PL_curcop, oldline);
6189 if (!PL_minus_c) /* keep old one around for madskills */
6192 /* (PL_madskills unset in used file.) */
6200 SvREFCNT_inc_simple_void_NN(const_sv);
6202 assert(!CvROOT(cv) && !CvCONST(cv));
6203 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6204 CvXSUBANY(cv).any_ptr = const_sv;
6205 CvXSUB(cv) = const_sv_xsub;
6211 cv = newCONSTSUB(NULL, name, const_sv);
6213 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6214 (CvGV(cv) && GvSTASH(CvGV(cv)))
6223 SvREFCNT_dec(PL_compcv);
6227 if (cv) { /* must reuse cv if autoloaded */
6228 /* transfer PL_compcv to cv */
6231 && block->op_type != OP_NULL
6234 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6235 AV *const temp_av = CvPADLIST(cv);
6236 CV *const temp_cv = CvOUTSIDE(cv);
6238 assert(!CvWEAKOUTSIDE(cv));
6239 assert(!CvCVGV_RC(cv));
6240 assert(CvGV(cv) == gv);
6243 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6244 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6245 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6246 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6247 CvOUTSIDE(PL_compcv) = temp_cv;
6248 CvPADLIST(PL_compcv) = temp_av;
6251 if (CvFILE(cv) && !CvISXSUB(cv)) {
6252 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
6253 Safefree(CvFILE(cv));
6256 CvFILE_set_from_cop(cv, PL_curcop);
6257 CvSTASH_set(cv, PL_curstash);
6259 /* inner references to PL_compcv must be fixed up ... */
6260 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6261 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6262 ++PL_sub_generation;
6265 /* Might have had built-in attributes applied -- propagate them. */
6266 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6268 /* ... before we throw it away */
6269 SvREFCNT_dec(PL_compcv);
6277 if (strEQ(name, "import")) {
6278 PL_formfeed = MUTABLE_SV(cv);
6279 /* diag_listed_as: SKIPME */
6280 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6284 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6289 CvFILE_set_from_cop(cv, PL_curcop);
6290 CvSTASH_set(cv, PL_curstash);
6293 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6294 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6295 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6299 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6301 if (PL_parser && PL_parser->error_count) {
6305 const char *s = strrchr(name, ':');
6307 if (strEQ(s, "BEGIN")) {
6308 const char not_safe[] =
6309 "BEGIN not safe after errors--compilation aborted";
6310 if (PL_in_eval & EVAL_KEEPERR)
6311 Perl_croak(aTHX_ not_safe);
6313 /* force display of errors found but not reported */
6314 sv_catpv(ERRSV, not_safe);
6315 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6324 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6325 the debugger could be able to set a breakpoint in, so signal to
6326 pp_entereval that it should not throw away any saved lines at scope
6329 PL_breakable_sub_gen++;
6331 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6332 op_lvalue(scalarseq(block), OP_LEAVESUBLV));
6333 block->op_attached = 1;
6336 /* This makes sub {}; work as expected. */
6337 if (block->op_type == OP_STUB) {
6338 OP* const newblock = newSTATEOP(0, NULL, 0);
6340 op_getmad(block,newblock,'B');
6347 block->op_attached = 1;
6348 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6350 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6351 OpREFCNT_set(CvROOT(cv), 1);
6352 CvSTART(cv) = LINKLIST(CvROOT(cv));
6353 CvROOT(cv)->op_next = 0;
6354 CALL_PEEP(CvSTART(cv));
6356 /* now that optimizer has done its work, adjust pad values */
6358 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6361 assert(!CvCONST(cv));
6362 if (ps && !*ps && op_const_sv(block, cv))
6367 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6368 SV * const tmpstr = sv_newmortal();
6369 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6370 GV_ADDMULTI, SVt_PVHV);
6372 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6375 (long)CopLINE(PL_curcop));
6376 gv_efullname3(tmpstr, gv, NULL);
6377 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6378 SvCUR(tmpstr), sv, 0);
6379 hv = GvHVn(db_postponed);
6380 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6381 CV * const pcv = GvCV(db_postponed);
6387 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6392 if (name && ! (PL_parser && PL_parser->error_count))
6393 process_special_blocks(name, gv, cv);
6398 PL_parser->copline = NOLINE;
6404 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6407 const char *const colon = strrchr(fullname,':');
6408 const char *const name = colon ? colon + 1 : fullname;
6410 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6413 if (strEQ(name, "BEGIN")) {
6414 const I32 oldscope = PL_scopestack_ix;
6416 SAVECOPFILE(&PL_compiling);
6417 SAVECOPLINE(&PL_compiling);
6419 DEBUG_x( dump_sub(gv) );
6420 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6421 GvCV(gv) = 0; /* cv has been hijacked */
6422 call_list(oldscope, PL_beginav);
6424 PL_curcop = &PL_compiling;
6425 CopHINTS_set(&PL_compiling, PL_hints);
6432 if strEQ(name, "END") {
6433 DEBUG_x( dump_sub(gv) );
6434 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6437 } else if (*name == 'U') {
6438 if (strEQ(name, "UNITCHECK")) {
6439 /* It's never too late to run a unitcheck block */
6440 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6444 } else if (*name == 'C') {
6445 if (strEQ(name, "CHECK")) {
6447 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6448 "Too late to run CHECK block");
6449 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6453 } else if (*name == 'I') {
6454 if (strEQ(name, "INIT")) {
6456 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6457 "Too late to run INIT block");
6458 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6464 DEBUG_x( dump_sub(gv) );
6465 GvCV(gv) = 0; /* cv has been hijacked */
6470 =for apidoc newCONSTSUB
6472 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6473 eligible for inlining at compile-time.
6475 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6476 which won't be called if used as a destructor, but will suppress the overhead
6477 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6484 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6489 const char *const file = CopFILE(PL_curcop);
6491 SV *const temp_sv = CopFILESV(PL_curcop);
6492 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6497 if (IN_PERL_RUNTIME) {
6498 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6499 * an op shared between threads. Use a non-shared COP for our
6501 SAVEVPTR(PL_curcop);
6502 PL_curcop = &PL_compiling;
6504 SAVECOPLINE(PL_curcop);
6505 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6508 PL_hints &= ~HINT_BLOCK_SCOPE;
6511 SAVESPTR(PL_curstash);
6512 SAVECOPSTASH(PL_curcop);
6513 PL_curstash = stash;
6514 CopSTASH_set(PL_curcop,stash);
6517 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6518 and so doesn't get free()d. (It's expected to be from the C pre-
6519 processor __FILE__ directive). But we need a dynamically allocated one,
6520 and we need it to get freed. */
6521 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6522 XS_DYNAMIC_FILENAME);
6523 CvXSUBANY(cv).any_ptr = sv;
6528 CopSTASH_free(PL_curcop);
6536 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6537 const char *const filename, const char *const proto,
6540 CV *cv = newXS(name, subaddr, filename);
6542 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6544 if (flags & XS_DYNAMIC_FILENAME) {
6545 /* We need to "make arrangements" (ie cheat) to ensure that the
6546 filename lasts as long as the PVCV we just created, but also doesn't
6548 STRLEN filename_len = strlen(filename);
6549 STRLEN proto_and_file_len = filename_len;
6550 char *proto_and_file;
6554 proto_len = strlen(proto);
6555 proto_and_file_len += proto_len;
6557 Newx(proto_and_file, proto_and_file_len + 1, char);
6558 Copy(proto, proto_and_file, proto_len, char);
6559 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6562 proto_and_file = savepvn(filename, filename_len);
6565 /* This gets free()d. :-) */
6566 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6567 SV_HAS_TRAILING_NUL);
6569 /* This gives us the correct prototype, rather than one with the
6570 file name appended. */
6571 SvCUR_set(cv, proto_len);
6575 CvFILE(cv) = proto_and_file + proto_len;
6577 sv_setpv(MUTABLE_SV(cv), proto);
6583 =for apidoc U||newXS
6585 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6586 static storage, as it is used directly as CvFILE(), without a copy being made.
6592 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6595 GV * const gv = gv_fetchpv(name ? name :
6596 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6597 GV_ADDMULTI, SVt_PVCV);
6600 PERL_ARGS_ASSERT_NEWXS;
6603 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6605 if ((cv = (name ? GvCV(gv) : NULL))) {
6607 /* just a cached method */
6611 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6612 /* already defined (or promised) */
6613 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6614 if (ckWARN(WARN_REDEFINE)) {
6615 GV * const gvcv = CvGV(cv);
6617 HV * const stash = GvSTASH(gvcv);
6619 const char *redefined_name = HvNAME_get(stash);
6620 if ( strEQ(redefined_name,"autouse") ) {
6621 const line_t oldline = CopLINE(PL_curcop);
6622 if (PL_parser && PL_parser->copline != NOLINE)
6623 CopLINE_set(PL_curcop, PL_parser->copline);
6624 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6625 CvCONST(cv) ? "Constant subroutine %s redefined"
6626 : "Subroutine %s redefined"
6628 CopLINE_set(PL_curcop, oldline);
6638 if (cv) /* must reuse cv if autoloaded */
6641 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6645 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6651 (void)gv_fetchfile(filename);
6652 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6653 an external constant string */
6655 CvXSUB(cv) = subaddr;
6658 process_special_blocks(name, gv, cv);
6668 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6673 OP* pegop = newOP(OP_NULL, 0);
6677 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6678 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6681 if ((cv = GvFORM(gv))) {
6682 if (ckWARN(WARN_REDEFINE)) {
6683 const line_t oldline = CopLINE(PL_curcop);
6684 if (PL_parser && PL_parser->copline != NOLINE)
6685 CopLINE_set(PL_curcop, PL_parser->copline);
6687 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6688 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6690 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6691 "Format STDOUT redefined");
6693 CopLINE_set(PL_curcop, oldline);
6700 CvFILE_set_from_cop(cv, PL_curcop);
6703 pad_tidy(padtidy_FORMAT);
6704 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6705 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6706 OpREFCNT_set(CvROOT(cv), 1);
6707 CvSTART(cv) = LINKLIST(CvROOT(cv));
6708 CvROOT(cv)->op_next = 0;
6709 CALL_PEEP(CvSTART(cv));
6711 op_getmad(o,pegop,'n');
6712 op_getmad_weak(block, pegop, 'b');
6717 PL_parser->copline = NOLINE;
6725 Perl_newANONLIST(pTHX_ OP *o)
6727 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6731 Perl_newANONHASH(pTHX_ OP *o)
6733 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6737 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6739 return newANONATTRSUB(floor, proto, NULL, block);
6743 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6745 return newUNOP(OP_REFGEN, 0,
6746 newSVOP(OP_ANONCODE, 0,
6747 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6751 Perl_oopsAV(pTHX_ OP *o)
6755 PERL_ARGS_ASSERT_OOPSAV;
6757 switch (o->op_type) {
6759 o->op_type = OP_PADAV;
6760 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6761 return ref(o, OP_RV2AV);
6764 o->op_type = OP_RV2AV;
6765 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6770 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6777 Perl_oopsHV(pTHX_ OP *o)
6781 PERL_ARGS_ASSERT_OOPSHV;
6783 switch (o->op_type) {
6786 o->op_type = OP_PADHV;
6787 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6788 return ref(o, OP_RV2HV);
6792 o->op_type = OP_RV2HV;
6793 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6798 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6805 Perl_newAVREF(pTHX_ OP *o)
6809 PERL_ARGS_ASSERT_NEWAVREF;
6811 if (o->op_type == OP_PADANY) {
6812 o->op_type = OP_PADAV;
6813 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6816 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6817 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6818 "Using an array as a reference is deprecated");
6820 return newUNOP(OP_RV2AV, 0, scalar(o));
6824 Perl_newGVREF(pTHX_ I32 type, OP *o)
6826 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6827 return newUNOP(OP_NULL, 0, o);
6828 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6832 Perl_newHVREF(pTHX_ OP *o)
6836 PERL_ARGS_ASSERT_NEWHVREF;
6838 if (o->op_type == OP_PADANY) {
6839 o->op_type = OP_PADHV;
6840 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6843 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6844 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6845 "Using a hash as a reference is deprecated");
6847 return newUNOP(OP_RV2HV, 0, scalar(o));
6851 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6853 return newUNOP(OP_RV2CV, flags, scalar(o));
6857 Perl_newSVREF(pTHX_ OP *o)
6861 PERL_ARGS_ASSERT_NEWSVREF;
6863 if (o->op_type == OP_PADANY) {
6864 o->op_type = OP_PADSV;
6865 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6868 return newUNOP(OP_RV2SV, 0, scalar(o));
6871 /* Check routines. See the comments at the top of this file for details
6872 * on when these are called */
6875 Perl_ck_anoncode(pTHX_ OP *o)
6877 PERL_ARGS_ASSERT_CK_ANONCODE;
6879 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6881 cSVOPo->op_sv = NULL;
6886 Perl_ck_bitop(pTHX_ OP *o)
6890 PERL_ARGS_ASSERT_CK_BITOP;
6892 #define OP_IS_NUMCOMPARE(op) \
6893 ((op) == OP_LT || (op) == OP_I_LT || \
6894 (op) == OP_GT || (op) == OP_I_GT || \
6895 (op) == OP_LE || (op) == OP_I_LE || \
6896 (op) == OP_GE || (op) == OP_I_GE || \
6897 (op) == OP_EQ || (op) == OP_I_EQ || \
6898 (op) == OP_NE || (op) == OP_I_NE || \
6899 (op) == OP_NCMP || (op) == OP_I_NCMP)
6900 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6901 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6902 && (o->op_type == OP_BIT_OR
6903 || o->op_type == OP_BIT_AND
6904 || o->op_type == OP_BIT_XOR))
6906 const OP * const left = cBINOPo->op_first;
6907 const OP * const right = left->op_sibling;
6908 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6909 (left->op_flags & OPf_PARENS) == 0) ||
6910 (OP_IS_NUMCOMPARE(right->op_type) &&
6911 (right->op_flags & OPf_PARENS) == 0))
6912 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6913 "Possible precedence problem on bitwise %c operator",
6914 o->op_type == OP_BIT_OR ? '|'
6915 : o->op_type == OP_BIT_AND ? '&' : '^'
6922 Perl_ck_concat(pTHX_ OP *o)
6924 const OP * const kid = cUNOPo->op_first;
6926 PERL_ARGS_ASSERT_CK_CONCAT;
6927 PERL_UNUSED_CONTEXT;
6929 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6930 !(kUNOP->op_first->op_flags & OPf_MOD))
6931 o->op_flags |= OPf_STACKED;
6936 Perl_ck_spair(pTHX_ OP *o)
6940 PERL_ARGS_ASSERT_CK_SPAIR;
6942 if (o->op_flags & OPf_KIDS) {
6945 const OPCODE type = o->op_type;
6946 o = modkids(ck_fun(o), type);
6947 kid = cUNOPo->op_first;
6948 newop = kUNOP->op_first->op_sibling;
6950 const OPCODE type = newop->op_type;
6951 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6952 type == OP_PADAV || type == OP_PADHV ||
6953 type == OP_RV2AV || type == OP_RV2HV)
6957 op_getmad(kUNOP->op_first,newop,'K');
6959 op_free(kUNOP->op_first);
6961 kUNOP->op_first = newop;
6963 o->op_ppaddr = PL_ppaddr[++o->op_type];
6968 Perl_ck_delete(pTHX_ OP *o)
6970 PERL_ARGS_ASSERT_CK_DELETE;
6974 if (o->op_flags & OPf_KIDS) {
6975 OP * const kid = cUNOPo->op_first;
6976 switch (kid->op_type) {
6978 o->op_flags |= OPf_SPECIAL;
6981 o->op_private |= OPpSLICE;
6984 o->op_flags |= OPf_SPECIAL;
6989 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6992 if (kid->op_private & OPpLVAL_INTRO)
6993 o->op_private |= OPpLVAL_INTRO;
7000 Perl_ck_die(pTHX_ OP *o)
7002 PERL_ARGS_ASSERT_CK_DIE;
7005 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7011 Perl_ck_eof(pTHX_ OP *o)
7015 PERL_ARGS_ASSERT_CK_EOF;
7017 if (o->op_flags & OPf_KIDS) {
7018 if (cLISTOPo->op_first->op_type == OP_STUB) {
7020 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7022 op_getmad(o,newop,'O');
7034 Perl_ck_eval(pTHX_ OP *o)
7038 PERL_ARGS_ASSERT_CK_EVAL;
7040 PL_hints |= HINT_BLOCK_SCOPE;
7041 if (o->op_flags & OPf_KIDS) {
7042 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7045 o->op_flags &= ~OPf_KIDS;
7048 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7054 cUNOPo->op_first = 0;
7059 NewOp(1101, enter, 1, LOGOP);
7060 enter->op_type = OP_ENTERTRY;
7061 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7062 enter->op_private = 0;
7064 /* establish postfix order */
7065 enter->op_next = (OP*)enter;
7067 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7068 o->op_type = OP_LEAVETRY;
7069 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7070 enter->op_other = o;
7071 op_getmad(oldo,o,'O');
7085 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7086 op_getmad(oldo,o,'O');
7088 o->op_targ = (PADOFFSET)PL_hints;
7089 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7090 /* Store a copy of %^H that pp_entereval can pick up. */
7091 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7092 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7093 cUNOPo->op_first->op_sibling = hhop;
7094 o->op_private |= OPpEVAL_HAS_HH;
7100 Perl_ck_exit(pTHX_ OP *o)
7102 PERL_ARGS_ASSERT_CK_EXIT;
7105 HV * const table = GvHV(PL_hintgv);
7107 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7108 if (svp && *svp && SvTRUE(*svp))
7109 o->op_private |= OPpEXIT_VMSISH;
7111 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7117 Perl_ck_exec(pTHX_ OP *o)
7119 PERL_ARGS_ASSERT_CK_EXEC;
7121 if (o->op_flags & OPf_STACKED) {
7124 kid = cUNOPo->op_first->op_sibling;
7125 if (kid->op_type == OP_RV2GV)
7134 Perl_ck_exists(pTHX_ OP *o)
7138 PERL_ARGS_ASSERT_CK_EXISTS;
7141 if (o->op_flags & OPf_KIDS) {
7142 OP * const kid = cUNOPo->op_first;
7143 if (kid->op_type == OP_ENTERSUB) {
7144 (void) ref(kid, o->op_type);
7145 if (kid->op_type != OP_RV2CV
7146 && !(PL_parser && PL_parser->error_count))
7147 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7149 o->op_private |= OPpEXISTS_SUB;
7151 else if (kid->op_type == OP_AELEM)
7152 o->op_flags |= OPf_SPECIAL;
7153 else if (kid->op_type != OP_HELEM)
7154 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7162 Perl_ck_rvconst(pTHX_ register OP *o)
7165 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7167 PERL_ARGS_ASSERT_CK_RVCONST;
7169 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7170 if (o->op_type == OP_RV2CV)
7171 o->op_private &= ~1;
7173 if (kid->op_type == OP_CONST) {
7176 SV * const kidsv = kid->op_sv;
7178 /* Is it a constant from cv_const_sv()? */
7179 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7180 SV * const rsv = SvRV(kidsv);
7181 const svtype type = SvTYPE(rsv);
7182 const char *badtype = NULL;
7184 switch (o->op_type) {
7186 if (type > SVt_PVMG)
7187 badtype = "a SCALAR";
7190 if (type != SVt_PVAV)
7191 badtype = "an ARRAY";
7194 if (type != SVt_PVHV)
7198 if (type != SVt_PVCV)
7203 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7206 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7207 const char *badthing;
7208 switch (o->op_type) {
7210 badthing = "a SCALAR";
7213 badthing = "an ARRAY";
7216 badthing = "a HASH";
7224 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7225 SVfARG(kidsv), badthing);
7228 * This is a little tricky. We only want to add the symbol if we
7229 * didn't add it in the lexer. Otherwise we get duplicate strict
7230 * warnings. But if we didn't add it in the lexer, we must at
7231 * least pretend like we wanted to add it even if it existed before,
7232 * or we get possible typo warnings. OPpCONST_ENTERED says
7233 * whether the lexer already added THIS instance of this symbol.
7235 iscv = (o->op_type == OP_RV2CV) * 2;
7237 gv = gv_fetchsv(kidsv,
7238 iscv | !(kid->op_private & OPpCONST_ENTERED),
7241 : o->op_type == OP_RV2SV
7243 : o->op_type == OP_RV2AV
7245 : o->op_type == OP_RV2HV
7248 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7250 kid->op_type = OP_GV;
7251 SvREFCNT_dec(kid->op_sv);
7253 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7254 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7255 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7257 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7259 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7261 kid->op_private = 0;
7262 kid->op_ppaddr = PL_ppaddr[OP_GV];
7263 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7271 Perl_ck_ftst(pTHX_ OP *o)
7274 const I32 type = o->op_type;
7276 PERL_ARGS_ASSERT_CK_FTST;
7278 if (o->op_flags & OPf_REF) {
7281 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7282 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7283 const OPCODE kidtype = kid->op_type;
7285 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7286 OP * const newop = newGVOP(type, OPf_REF,
7287 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7289 op_getmad(o,newop,'O');
7295 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7296 o->op_private |= OPpFT_ACCESS;
7297 if (PL_check[kidtype] == Perl_ck_ftst
7298 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7299 o->op_private |= OPpFT_STACKED;
7307 if (type == OP_FTTTY)
7308 o = newGVOP(type, OPf_REF, PL_stdingv);
7310 o = newUNOP(type, 0, newDEFSVOP());
7311 op_getmad(oldo,o,'O');
7317 Perl_ck_fun(pTHX_ OP *o)
7320 const int type = o->op_type;
7321 register I32 oa = PL_opargs[type] >> OASHIFT;
7323 PERL_ARGS_ASSERT_CK_FUN;
7325 if (o->op_flags & OPf_STACKED) {
7326 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7329 return no_fh_allowed(o);
7332 if (o->op_flags & OPf_KIDS) {
7333 OP **tokid = &cLISTOPo->op_first;
7334 register OP *kid = cLISTOPo->op_first;
7338 if (kid->op_type == OP_PUSHMARK ||
7339 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7341 tokid = &kid->op_sibling;
7342 kid = kid->op_sibling;
7344 if (!kid && PL_opargs[type] & OA_DEFGV)
7345 *tokid = kid = newDEFSVOP();
7349 sibl = kid->op_sibling;
7351 if (!sibl && kid->op_type == OP_STUB) {
7358 /* list seen where single (scalar) arg expected? */
7359 if (numargs == 1 && !(oa >> 4)
7360 && kid->op_type == OP_LIST && type != OP_SCALAR)
7362 return too_many_arguments(o,PL_op_desc[type]);
7375 if ((type == OP_PUSH || type == OP_UNSHIFT)
7376 && !kid->op_sibling)
7377 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7378 "Useless use of %s with no values",
7381 if (kid->op_type == OP_CONST &&
7382 (kid->op_private & OPpCONST_BARE))
7384 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7385 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7386 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7387 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7388 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7390 op_getmad(kid,newop,'K');
7395 kid->op_sibling = sibl;
7398 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
7399 bad_type(numargs, "array", PL_op_desc[type], kid);
7400 op_lvalue(kid, type);
7403 if (kid->op_type == OP_CONST &&
7404 (kid->op_private & OPpCONST_BARE))
7406 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7407 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7408 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7409 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7410 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7412 op_getmad(kid,newop,'K');
7417 kid->op_sibling = sibl;
7420 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7421 bad_type(numargs, "hash", PL_op_desc[type], kid);
7422 op_lvalue(kid, type);
7426 OP * const newop = newUNOP(OP_NULL, 0, kid);
7427 kid->op_sibling = 0;
7429 newop->op_next = newop;
7431 kid->op_sibling = sibl;
7436 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7437 if (kid->op_type == OP_CONST &&
7438 (kid->op_private & OPpCONST_BARE))
7440 OP * const newop = newGVOP(OP_GV, 0,
7441 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7442 if (!(o->op_private & 1) && /* if not unop */
7443 kid == cLISTOPo->op_last)
7444 cLISTOPo->op_last = newop;
7446 op_getmad(kid,newop,'K');
7452 else if (kid->op_type == OP_READLINE) {
7453 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7454 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7457 I32 flags = OPf_SPECIAL;
7461 /* is this op a FH constructor? */
7462 if (is_handle_constructor(o,numargs)) {
7463 const char *name = NULL;
7467 /* Set a flag to tell rv2gv to vivify
7468 * need to "prove" flag does not mean something
7469 * else already - NI-S 1999/05/07
7472 if (kid->op_type == OP_PADSV) {
7474 = PAD_COMPNAME_SV(kid->op_targ);
7475 name = SvPV_const(namesv, len);
7477 else if (kid->op_type == OP_RV2SV
7478 && kUNOP->op_first->op_type == OP_GV)
7480 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7482 len = GvNAMELEN(gv);
7484 else if (kid->op_type == OP_AELEM
7485 || kid->op_type == OP_HELEM)
7488 OP *op = ((BINOP*)kid)->op_first;
7492 const char * const a =
7493 kid->op_type == OP_AELEM ?
7495 if (((op->op_type == OP_RV2AV) ||
7496 (op->op_type == OP_RV2HV)) &&
7497 (firstop = ((UNOP*)op)->op_first) &&
7498 (firstop->op_type == OP_GV)) {
7499 /* packagevar $a[] or $h{} */
7500 GV * const gv = cGVOPx_gv(firstop);
7508 else if (op->op_type == OP_PADAV
7509 || op->op_type == OP_PADHV) {
7510 /* lexicalvar $a[] or $h{} */
7511 const char * const padname =
7512 PAD_COMPNAME_PV(op->op_targ);
7521 name = SvPV_const(tmpstr, len);
7526 name = "__ANONIO__";
7529 op_lvalue(kid, type);
7533 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7534 namesv = PAD_SVl(targ);
7535 SvUPGRADE(namesv, SVt_PV);
7537 sv_setpvs(namesv, "$");
7538 sv_catpvn(namesv, name, len);
7541 kid->op_sibling = 0;
7542 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7543 kid->op_targ = targ;
7544 kid->op_private |= priv;
7546 kid->op_sibling = sibl;
7552 op_lvalue(scalar(kid), type);
7556 tokid = &kid->op_sibling;
7557 kid = kid->op_sibling;
7560 if (kid && kid->op_type != OP_STUB)
7561 return too_many_arguments(o,OP_DESC(o));
7562 o->op_private |= numargs;
7564 /* FIXME - should the numargs move as for the PERL_MAD case? */
7565 o->op_private |= numargs;
7567 return too_many_arguments(o,OP_DESC(o));
7571 else if (PL_opargs[type] & OA_DEFGV) {
7573 OP *newop = newUNOP(type, 0, newDEFSVOP());
7574 op_getmad(o,newop,'O');
7577 /* Ordering of these two is important to keep f_map.t passing. */
7579 return newUNOP(type, 0, newDEFSVOP());
7584 while (oa & OA_OPTIONAL)
7586 if (oa && oa != OA_LIST)
7587 return too_few_arguments(o,OP_DESC(o));
7593 Perl_ck_glob(pTHX_ OP *o)
7598 PERL_ARGS_ASSERT_CK_GLOB;
7601 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7602 op_append_elem(OP_GLOB, o, newDEFSVOP());
7604 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7605 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7607 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7610 #if !defined(PERL_EXTERNAL_GLOB)
7611 /* XXX this can be tightened up and made more failsafe. */
7612 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7615 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7616 newSVpvs("File::Glob"), NULL, NULL, NULL);
7617 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7618 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7619 GvCV(gv) = GvCV(glob_gv);
7620 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7621 GvIMPORTED_CV_on(gv);
7625 #endif /* PERL_EXTERNAL_GLOB */
7627 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7628 op_append_elem(OP_GLOB, o,
7629 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7630 o->op_type = OP_LIST;
7631 o->op_ppaddr = PL_ppaddr[OP_LIST];
7632 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7633 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7634 cLISTOPo->op_first->op_targ = 0;
7635 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7636 op_append_elem(OP_LIST, o,
7637 scalar(newUNOP(OP_RV2CV, 0,
7638 newGVOP(OP_GV, 0, gv)))));
7639 o = newUNOP(OP_NULL, 0, ck_subr(o));
7640 o->op_targ = OP_GLOB; /* hint at what it used to be */
7643 gv = newGVgen("main");
7645 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7651 Perl_ck_grep(pTHX_ OP *o)
7656 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7659 PERL_ARGS_ASSERT_CK_GREP;
7661 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7662 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7664 if (o->op_flags & OPf_STACKED) {
7667 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7668 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7669 return no_fh_allowed(o);
7670 for (k = kid; k; k = k->op_next) {
7673 NewOp(1101, gwop, 1, LOGOP);
7674 kid->op_next = (OP*)gwop;
7675 o->op_flags &= ~OPf_STACKED;
7677 kid = cLISTOPo->op_first->op_sibling;
7678 if (type == OP_MAPWHILE)
7683 if (PL_parser && PL_parser->error_count)
7685 kid = cLISTOPo->op_first->op_sibling;
7686 if (kid->op_type != OP_NULL)
7687 Perl_croak(aTHX_ "panic: ck_grep");
7688 kid = kUNOP->op_first;
7691 NewOp(1101, gwop, 1, LOGOP);
7692 gwop->op_type = type;
7693 gwop->op_ppaddr = PL_ppaddr[type];
7694 gwop->op_first = listkids(o);
7695 gwop->op_flags |= OPf_KIDS;
7696 gwop->op_other = LINKLIST(kid);
7697 kid->op_next = (OP*)gwop;
7698 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7699 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7700 o->op_private = gwop->op_private = 0;
7701 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7704 o->op_private = gwop->op_private = OPpGREP_LEX;
7705 gwop->op_targ = o->op_targ = offset;
7708 kid = cLISTOPo->op_first->op_sibling;
7709 if (!kid || !kid->op_sibling)
7710 return too_few_arguments(o,OP_DESC(o));
7711 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7712 op_lvalue(kid, OP_GREPSTART);
7718 Perl_ck_index(pTHX_ OP *o)
7720 PERL_ARGS_ASSERT_CK_INDEX;
7722 if (o->op_flags & OPf_KIDS) {
7723 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7725 kid = kid->op_sibling; /* get past "big" */
7726 if (kid && kid->op_type == OP_CONST)
7727 fbm_compile(((SVOP*)kid)->op_sv, 0);
7733 Perl_ck_lfun(pTHX_ OP *o)
7735 const OPCODE type = o->op_type;
7737 PERL_ARGS_ASSERT_CK_LFUN;
7739 return modkids(ck_fun(o), type);
7743 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7745 PERL_ARGS_ASSERT_CK_DEFINED;
7747 if ((o->op_flags & OPf_KIDS)) {
7748 switch (cUNOPo->op_first->op_type) {
7750 /* This is needed for
7751 if (defined %stash::)
7752 to work. Do not break Tk.
7754 break; /* Globals via GV can be undef */
7756 case OP_AASSIGN: /* Is this a good idea? */
7757 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7758 "defined(@array) is deprecated");
7759 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7760 "\t(Maybe you should just omit the defined()?)\n");
7764 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7765 "defined(%%hash) is deprecated");
7766 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7767 "\t(Maybe you should just omit the defined()?)\n");
7778 Perl_ck_readline(pTHX_ OP *o)
7780 PERL_ARGS_ASSERT_CK_READLINE;
7782 if (!(o->op_flags & OPf_KIDS)) {
7784 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7786 op_getmad(o,newop,'O');
7796 Perl_ck_rfun(pTHX_ OP *o)
7798 const OPCODE type = o->op_type;
7800 PERL_ARGS_ASSERT_CK_RFUN;
7802 return refkids(ck_fun(o), type);
7806 Perl_ck_listiob(pTHX_ OP *o)
7810 PERL_ARGS_ASSERT_CK_LISTIOB;
7812 kid = cLISTOPo->op_first;
7815 kid = cLISTOPo->op_first;
7817 if (kid->op_type == OP_PUSHMARK)
7818 kid = kid->op_sibling;
7819 if (kid && o->op_flags & OPf_STACKED)
7820 kid = kid->op_sibling;
7821 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7822 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7823 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7824 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7825 cLISTOPo->op_first->op_sibling = kid;
7826 cLISTOPo->op_last = kid;
7827 kid = kid->op_sibling;
7832 op_append_elem(o->op_type, o, newDEFSVOP());
7838 Perl_ck_smartmatch(pTHX_ OP *o)
7841 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7842 if (0 == (o->op_flags & OPf_SPECIAL)) {
7843 OP *first = cBINOPo->op_first;
7844 OP *second = first->op_sibling;
7846 /* Implicitly take a reference to an array or hash */
7847 first->op_sibling = NULL;
7848 first = cBINOPo->op_first = ref_array_or_hash(first);
7849 second = first->op_sibling = ref_array_or_hash(second);
7851 /* Implicitly take a reference to a regular expression */
7852 if (first->op_type == OP_MATCH) {
7853 first->op_type = OP_QR;
7854 first->op_ppaddr = PL_ppaddr[OP_QR];
7856 if (second->op_type == OP_MATCH) {
7857 second->op_type = OP_QR;
7858 second->op_ppaddr = PL_ppaddr[OP_QR];
7867 Perl_ck_sassign(pTHX_ OP *o)
7870 OP * const kid = cLISTOPo->op_first;
7872 PERL_ARGS_ASSERT_CK_SASSIGN;
7874 /* has a disposable target? */
7875 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7876 && !(kid->op_flags & OPf_STACKED)
7877 /* Cannot steal the second time! */
7878 && !(kid->op_private & OPpTARGET_MY)
7879 /* Keep the full thing for madskills */
7883 OP * const kkid = kid->op_sibling;
7885 /* Can just relocate the target. */
7886 if (kkid && kkid->op_type == OP_PADSV
7887 && !(kkid->op_private & OPpLVAL_INTRO))
7889 kid->op_targ = kkid->op_targ;
7891 /* Now we do not need PADSV and SASSIGN. */
7892 kid->op_sibling = o->op_sibling; /* NULL */
7893 cLISTOPo->op_first = NULL;
7896 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7900 if (kid->op_sibling) {
7901 OP *kkid = kid->op_sibling;
7902 if (kkid->op_type == OP_PADSV
7903 && (kkid->op_private & OPpLVAL_INTRO)
7904 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7905 const PADOFFSET target = kkid->op_targ;
7906 OP *const other = newOP(OP_PADSV,
7908 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7909 OP *const first = newOP(OP_NULL, 0);
7910 OP *const nullop = newCONDOP(0, first, o, other);
7911 OP *const condop = first->op_next;
7912 /* hijacking PADSTALE for uninitialized state variables */
7913 SvPADSTALE_on(PAD_SVl(target));
7915 condop->op_type = OP_ONCE;
7916 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7917 condop->op_targ = target;
7918 other->op_targ = target;
7920 /* Because we change the type of the op here, we will skip the
7921 assinment binop->op_last = binop->op_first->op_sibling; at the
7922 end of Perl_newBINOP(). So need to do it here. */
7923 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7932 Perl_ck_match(pTHX_ OP *o)
7936 PERL_ARGS_ASSERT_CK_MATCH;
7938 if (o->op_type != OP_QR && PL_compcv) {
7939 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7940 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7941 o->op_targ = offset;
7942 o->op_private |= OPpTARGET_MY;
7945 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7946 o->op_private |= OPpRUNTIME;
7951 Perl_ck_method(pTHX_ OP *o)
7953 OP * const kid = cUNOPo->op_first;
7955 PERL_ARGS_ASSERT_CK_METHOD;
7957 if (kid->op_type == OP_CONST) {
7958 SV* sv = kSVOP->op_sv;
7959 const char * const method = SvPVX_const(sv);
7960 if (!(strchr(method, ':') || strchr(method, '\''))) {
7962 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7963 sv = newSVpvn_share(method, SvCUR(sv), 0);
7966 kSVOP->op_sv = NULL;
7968 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7970 op_getmad(o,cmop,'O');
7981 Perl_ck_null(pTHX_ OP *o)
7983 PERL_ARGS_ASSERT_CK_NULL;
7984 PERL_UNUSED_CONTEXT;
7989 Perl_ck_open(pTHX_ OP *o)
7992 HV * const table = GvHV(PL_hintgv);
7994 PERL_ARGS_ASSERT_CK_OPEN;
7997 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8000 const char *d = SvPV_const(*svp, len);
8001 const I32 mode = mode_from_discipline(d, len);
8002 if (mode & O_BINARY)
8003 o->op_private |= OPpOPEN_IN_RAW;
8004 else if (mode & O_TEXT)
8005 o->op_private |= OPpOPEN_IN_CRLF;
8008 svp = hv_fetchs(table, "open_OUT", FALSE);
8011 const char *d = SvPV_const(*svp, len);
8012 const I32 mode = mode_from_discipline(d, len);
8013 if (mode & O_BINARY)
8014 o->op_private |= OPpOPEN_OUT_RAW;
8015 else if (mode & O_TEXT)
8016 o->op_private |= OPpOPEN_OUT_CRLF;
8019 if (o->op_type == OP_BACKTICK) {
8020 if (!(o->op_flags & OPf_KIDS)) {
8021 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8023 op_getmad(o,newop,'O');
8032 /* In case of three-arg dup open remove strictness
8033 * from the last arg if it is a bareword. */
8034 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8035 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8039 if ((last->op_type == OP_CONST) && /* The bareword. */
8040 (last->op_private & OPpCONST_BARE) &&
8041 (last->op_private & OPpCONST_STRICT) &&
8042 (oa = first->op_sibling) && /* The fh. */
8043 (oa = oa->op_sibling) && /* The mode. */
8044 (oa->op_type == OP_CONST) &&
8045 SvPOK(((SVOP*)oa)->op_sv) &&
8046 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8047 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8048 (last == oa->op_sibling)) /* The bareword. */
8049 last->op_private &= ~OPpCONST_STRICT;
8055 Perl_ck_repeat(pTHX_ OP *o)
8057 PERL_ARGS_ASSERT_CK_REPEAT;
8059 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8060 o->op_private |= OPpREPEAT_DOLIST;
8061 cBINOPo->op_first = force_list(cBINOPo->op_first);
8069 Perl_ck_require(pTHX_ OP *o)
8074 PERL_ARGS_ASSERT_CK_REQUIRE;
8076 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8077 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8079 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8080 SV * const sv = kid->op_sv;
8081 U32 was_readonly = SvREADONLY(sv);
8088 sv_force_normal_flags(sv, 0);
8089 assert(!SvREADONLY(sv));
8099 for (; s < end; s++) {
8100 if (*s == ':' && s[1] == ':') {
8102 Move(s+2, s+1, end - s - 1, char);
8107 sv_catpvs(sv, ".pm");
8108 SvFLAGS(sv) |= was_readonly;
8112 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8113 /* handle override, if any */
8114 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8115 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8116 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8117 gv = gvp ? *gvp : NULL;
8121 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8122 OP * const kid = cUNOPo->op_first;
8125 cUNOPo->op_first = 0;
8129 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8130 op_append_elem(OP_LIST, kid,
8131 scalar(newUNOP(OP_RV2CV, 0,
8134 op_getmad(o,newop,'O');
8138 return scalar(ck_fun(o));
8142 Perl_ck_return(pTHX_ OP *o)
8147 PERL_ARGS_ASSERT_CK_RETURN;
8149 kid = cLISTOPo->op_first->op_sibling;
8150 if (CvLVALUE(PL_compcv)) {
8151 for (; kid; kid = kid->op_sibling)
8152 op_lvalue(kid, OP_LEAVESUBLV);
8154 for (; kid; kid = kid->op_sibling)
8155 if ((kid->op_type == OP_NULL)
8156 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8157 /* This is a do block */
8158 OP *op = kUNOP->op_first;
8159 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8160 op = cUNOPx(op)->op_first;
8161 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8162 /* Force the use of the caller's context */
8163 op->op_flags |= OPf_SPECIAL;
8172 Perl_ck_select(pTHX_ OP *o)
8177 PERL_ARGS_ASSERT_CK_SELECT;
8179 if (o->op_flags & OPf_KIDS) {
8180 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8181 if (kid && kid->op_sibling) {
8182 o->op_type = OP_SSELECT;
8183 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8185 return fold_constants(o);
8189 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8190 if (kid && kid->op_type == OP_RV2GV)
8191 kid->op_private &= ~HINT_STRICT_REFS;
8196 Perl_ck_shift(pTHX_ OP *o)
8199 const I32 type = o->op_type;
8201 PERL_ARGS_ASSERT_CK_SHIFT;
8203 if (!(o->op_flags & OPf_KIDS)) {
8206 if (!CvUNIQUE(PL_compcv)) {
8207 o->op_flags |= OPf_SPECIAL;
8211 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8214 OP * const oldo = o;
8215 o = newUNOP(type, 0, scalar(argop));
8216 op_getmad(oldo,o,'O');
8221 return newUNOP(type, 0, scalar(argop));
8224 return scalar(modkids(ck_push(o), type));
8228 Perl_ck_sort(pTHX_ OP *o)
8233 PERL_ARGS_ASSERT_CK_SORT;
8235 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8236 HV * const hinthv = GvHV(PL_hintgv);
8238 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8240 const I32 sorthints = (I32)SvIV(*svp);
8241 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8242 o->op_private |= OPpSORT_QSORT;
8243 if ((sorthints & HINT_SORT_STABLE) != 0)
8244 o->op_private |= OPpSORT_STABLE;
8249 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8251 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8252 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8254 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8256 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8258 if (kid->op_type == OP_SCOPE) {
8262 else if (kid->op_type == OP_LEAVE) {
8263 if (o->op_type == OP_SORT) {
8264 op_null(kid); /* wipe out leave */
8267 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8268 if (k->op_next == kid)
8270 /* don't descend into loops */
8271 else if (k->op_type == OP_ENTERLOOP
8272 || k->op_type == OP_ENTERITER)
8274 k = cLOOPx(k)->op_lastop;
8279 kid->op_next = 0; /* just disconnect the leave */
8280 k = kLISTOP->op_first;
8285 if (o->op_type == OP_SORT) {
8286 /* provide scalar context for comparison function/block */
8292 o->op_flags |= OPf_SPECIAL;
8294 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8297 firstkid = firstkid->op_sibling;
8300 /* provide list context for arguments */
8301 if (o->op_type == OP_SORT)
8308 S_simplify_sort(pTHX_ OP *o)
8311 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8317 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8319 if (!(o->op_flags & OPf_STACKED))
8321 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8322 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8323 kid = kUNOP->op_first; /* get past null */
8324 if (kid->op_type != OP_SCOPE)
8326 kid = kLISTOP->op_last; /* get past scope */
8327 switch(kid->op_type) {
8335 k = kid; /* remember this node*/
8336 if (kBINOP->op_first->op_type != OP_RV2SV)
8338 kid = kBINOP->op_first; /* get past cmp */
8339 if (kUNOP->op_first->op_type != OP_GV)
8341 kid = kUNOP->op_first; /* get past rv2sv */
8343 if (GvSTASH(gv) != PL_curstash)
8345 gvname = GvNAME(gv);
8346 if (*gvname == 'a' && gvname[1] == '\0')
8348 else if (*gvname == 'b' && gvname[1] == '\0')
8353 kid = k; /* back to cmp */
8354 if (kBINOP->op_last->op_type != OP_RV2SV)
8356 kid = kBINOP->op_last; /* down to 2nd arg */
8357 if (kUNOP->op_first->op_type != OP_GV)
8359 kid = kUNOP->op_first; /* get past rv2sv */
8361 if (GvSTASH(gv) != PL_curstash)
8363 gvname = GvNAME(gv);
8365 ? !(*gvname == 'a' && gvname[1] == '\0')
8366 : !(*gvname == 'b' && gvname[1] == '\0'))
8368 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8370 o->op_private |= OPpSORT_DESCEND;
8371 if (k->op_type == OP_NCMP)
8372 o->op_private |= OPpSORT_NUMERIC;
8373 if (k->op_type == OP_I_NCMP)
8374 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8375 kid = cLISTOPo->op_first->op_sibling;
8376 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8378 op_getmad(kid,o,'S'); /* then delete it */
8380 op_free(kid); /* then delete it */
8385 Perl_ck_split(pTHX_ OP *o)
8390 PERL_ARGS_ASSERT_CK_SPLIT;
8392 if (o->op_flags & OPf_STACKED)
8393 return no_fh_allowed(o);
8395 kid = cLISTOPo->op_first;
8396 if (kid->op_type != OP_NULL)
8397 Perl_croak(aTHX_ "panic: ck_split");
8398 kid = kid->op_sibling;
8399 op_free(cLISTOPo->op_first);
8400 cLISTOPo->op_first = kid;
8402 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8403 cLISTOPo->op_last = kid; /* There was only one element previously */
8406 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8407 OP * const sibl = kid->op_sibling;
8408 kid->op_sibling = 0;
8409 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8410 if (cLISTOPo->op_first == cLISTOPo->op_last)
8411 cLISTOPo->op_last = kid;
8412 cLISTOPo->op_first = kid;
8413 kid->op_sibling = sibl;
8416 kid->op_type = OP_PUSHRE;
8417 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8419 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8420 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8421 "Use of /g modifier is meaningless in split");
8424 if (!kid->op_sibling)
8425 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8427 kid = kid->op_sibling;
8430 if (!kid->op_sibling)
8431 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8432 assert(kid->op_sibling);
8434 kid = kid->op_sibling;
8437 if (kid->op_sibling)
8438 return too_many_arguments(o,OP_DESC(o));
8444 Perl_ck_join(pTHX_ OP *o)
8446 const OP * const kid = cLISTOPo->op_first->op_sibling;
8448 PERL_ARGS_ASSERT_CK_JOIN;
8450 if (kid && kid->op_type == OP_MATCH) {
8451 if (ckWARN(WARN_SYNTAX)) {
8452 const REGEXP *re = PM_GETRE(kPMOP);
8453 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8454 const STRLEN len = re ? RX_PRELEN(re) : 6;
8455 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8456 "/%.*s/ should probably be written as \"%.*s\"",
8457 (int)len, pmstr, (int)len, pmstr);
8464 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8466 Examines an op, which is expected to identify a subroutine at runtime,
8467 and attempts to determine at compile time which subroutine it identifies.
8468 This is normally used during Perl compilation to determine whether
8469 a prototype can be applied to a function call. I<cvop> is the op
8470 being considered, normally an C<rv2cv> op. A pointer to the identified
8471 subroutine is returned, if it could be determined statically, and a null
8472 pointer is returned if it was not possible to determine statically.
8474 Currently, the subroutine can be identified statically if the RV that the
8475 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8476 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8477 suitable if the constant value must be an RV pointing to a CV. Details of
8478 this process may change in future versions of Perl. If the C<rv2cv> op
8479 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8480 the subroutine statically: this flag is used to suppress compile-time
8481 magic on a subroutine call, forcing it to use default runtime behaviour.
8483 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8484 of a GV reference is modified. If a GV was examined and its CV slot was
8485 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8486 If the op is not optimised away, and the CV slot is later populated with
8487 a subroutine having a prototype, that flag eventually triggers the warning
8488 "called too early to check prototype".
8490 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8491 of returning a pointer to the subroutine it returns a pointer to the
8492 GV giving the most appropriate name for the subroutine in this context.
8493 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8494 (C<CvANON>) subroutine that is referenced through a GV it will be the
8495 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8496 A null pointer is returned as usual if there is no statically-determinable
8503 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8508 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8509 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8510 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8511 if (cvop->op_type != OP_RV2CV)
8513 if (cvop->op_private & OPpENTERSUB_AMPER)
8515 if (!(cvop->op_flags & OPf_KIDS))
8517 rvop = cUNOPx(cvop)->op_first;
8518 switch (rvop->op_type) {
8520 gv = cGVOPx_gv(rvop);
8523 if (flags & RV2CVOPCV_MARK_EARLY)
8524 rvop->op_private |= OPpEARLY_CV;
8529 SV *rv = cSVOPx_sv(rvop);
8539 if (SvTYPE((SV*)cv) != SVt_PVCV)
8541 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8542 if (!CvANON(cv) || !gv)
8551 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8553 Performs the default fixup of the arguments part of an C<entersub>
8554 op tree. This consists of applying list context to each of the
8555 argument ops. This is the standard treatment used on a call marked
8556 with C<&>, or a method call, or a call through a subroutine reference,
8557 or any other call where the callee can't be identified at compile time,
8558 or a call where the callee has no prototype.
8564 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8567 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8568 aop = cUNOPx(entersubop)->op_first;
8569 if (!aop->op_sibling)
8570 aop = cUNOPx(aop)->op_first;
8571 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8572 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8574 op_lvalue(aop, OP_ENTERSUB);
8581 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8583 Performs the fixup of the arguments part of an C<entersub> op tree
8584 based on a subroutine prototype. This makes various modifications to
8585 the argument ops, from applying context up to inserting C<refgen> ops,
8586 and checking the number and syntactic types of arguments, as directed by
8587 the prototype. This is the standard treatment used on a subroutine call,
8588 not marked with C<&>, where the callee can be identified at compile time
8589 and has a prototype.
8591 I<protosv> supplies the subroutine prototype to be applied to the call.
8592 It may be a normal defined scalar, of which the string value will be used.
8593 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8594 that has been cast to C<SV*>) which has a prototype. The prototype
8595 supplied, in whichever form, does not need to match the actual callee
8596 referenced by the op tree.
8598 If the argument ops disagree with the prototype, for example by having
8599 an unacceptable number of arguments, a valid op tree is returned anyway.
8600 The error is reflected in the parser state, normally resulting in a single
8601 exception at the top level of parsing which covers all the compilation
8602 errors that occurred. In the error message, the callee is referred to
8603 by the name defined by the I<namegv> parameter.
8609 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8612 const char *proto, *proto_end;
8613 OP *aop, *prev, *cvop;
8616 I32 contextclass = 0;
8617 const char *e = NULL;
8618 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8619 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8620 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8621 proto = SvPV(protosv, proto_len);
8622 proto_end = proto + proto_len;
8623 aop = cUNOPx(entersubop)->op_first;
8624 if (!aop->op_sibling)
8625 aop = cUNOPx(aop)->op_first;
8627 aop = aop->op_sibling;
8628 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8629 while (aop != cvop) {
8631 if (PL_madskills && aop->op_type == OP_STUB) {
8632 aop = aop->op_sibling;
8635 if (PL_madskills && aop->op_type == OP_NULL)
8636 o3 = ((UNOP*)aop)->op_first;
8640 if (proto >= proto_end)
8641 return too_many_arguments(entersubop, gv_ename(namegv));
8649 /* _ must be at the end */
8650 if (proto[1] && proto[1] != ';')
8665 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8667 arg == 1 ? "block or sub {}" : "sub {}",
8668 gv_ename(namegv), o3);
8671 /* '*' allows any scalar type, including bareword */
8674 if (o3->op_type == OP_RV2GV)
8675 goto wrapref; /* autoconvert GLOB -> GLOBref */
8676 else if (o3->op_type == OP_CONST)
8677 o3->op_private &= ~OPpCONST_STRICT;
8678 else if (o3->op_type == OP_ENTERSUB) {
8679 /* accidental subroutine, revert to bareword */
8680 OP *gvop = ((UNOP*)o3)->op_first;
8681 if (gvop && gvop->op_type == OP_NULL) {
8682 gvop = ((UNOP*)gvop)->op_first;
8684 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8687 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8688 (gvop = ((UNOP*)gvop)->op_first) &&
8689 gvop->op_type == OP_GV)
8691 GV * const gv = cGVOPx_gv(gvop);
8692 OP * const sibling = aop->op_sibling;
8693 SV * const n = newSVpvs("");
8695 OP * const oldaop = aop;
8699 gv_fullname4(n, gv, "", FALSE);
8700 aop = newSVOP(OP_CONST, 0, n);
8701 op_getmad(oldaop,aop,'O');
8702 prev->op_sibling = aop;
8703 aop->op_sibling = sibling;
8713 if (o3->op_type == OP_RV2AV ||
8714 o3->op_type == OP_PADAV ||
8715 o3->op_type == OP_RV2HV ||
8716 o3->op_type == OP_PADHV
8731 if (contextclass++ == 0) {
8732 e = strchr(proto, ']');
8733 if (!e || e == proto)
8742 const char *p = proto;
8743 const char *const end = proto;
8745 while (*--p != '[') {}
8746 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8748 gv_ename(namegv), o3);
8753 if (o3->op_type == OP_RV2GV)
8756 bad_type(arg, "symbol", gv_ename(namegv), o3);
8759 if (o3->op_type == OP_ENTERSUB)
8762 bad_type(arg, "subroutine entry", gv_ename(namegv),
8766 if (o3->op_type == OP_RV2SV ||
8767 o3->op_type == OP_PADSV ||
8768 o3->op_type == OP_HELEM ||
8769 o3->op_type == OP_AELEM)
8772 bad_type(arg, "scalar", gv_ename(namegv), o3);
8775 if (o3->op_type == OP_RV2AV ||
8776 o3->op_type == OP_PADAV)
8779 bad_type(arg, "array", gv_ename(namegv), o3);
8782 if (o3->op_type == OP_RV2HV ||
8783 o3->op_type == OP_PADHV)
8786 bad_type(arg, "hash", gv_ename(namegv), o3);
8790 OP* const kid = aop;
8791 OP* const sib = kid->op_sibling;
8792 kid->op_sibling = 0;
8793 aop = newUNOP(OP_REFGEN, 0, kid);
8794 aop->op_sibling = sib;
8795 prev->op_sibling = aop;
8797 if (contextclass && e) {
8812 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8813 gv_ename(namegv), SVfARG(protosv));
8816 op_lvalue(aop, OP_ENTERSUB);
8818 aop = aop->op_sibling;
8820 if (aop == cvop && *proto == '_') {
8821 /* generate an access to $_ */
8823 aop->op_sibling = prev->op_sibling;
8824 prev->op_sibling = aop; /* instead of cvop */
8826 if (!optional && proto_end > proto &&
8827 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8828 return too_few_arguments(entersubop, gv_ename(namegv));
8833 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8835 Performs the fixup of the arguments part of an C<entersub> op tree either
8836 based on a subroutine prototype or using default list-context processing.
8837 This is the standard treatment used on a subroutine call, not marked
8838 with C<&>, where the callee can be identified at compile time.
8840 I<protosv> supplies the subroutine prototype to be applied to the call,
8841 or indicates that there is no prototype. It may be a normal scalar,
8842 in which case if it is defined then the string value will be used
8843 as a prototype, and if it is undefined then there is no prototype.
8844 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8845 that has been cast to C<SV*>), of which the prototype will be used if it
8846 has one. The prototype (or lack thereof) supplied, in whichever form,
8847 does not need to match the actual callee referenced by the op tree.
8849 If the argument ops disagree with the prototype, for example by having
8850 an unacceptable number of arguments, a valid op tree is returned anyway.
8851 The error is reflected in the parser state, normally resulting in a single
8852 exception at the top level of parsing which covers all the compilation
8853 errors that occurred. In the error message, the callee is referred to
8854 by the name defined by the I<namegv> parameter.
8860 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8861 GV *namegv, SV *protosv)
8863 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8864 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8865 return ck_entersub_args_proto(entersubop, namegv, protosv);
8867 return ck_entersub_args_list(entersubop);
8871 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8873 Retrieves the function that will be used to fix up a call to I<cv>.
8874 Specifically, the function is applied to an C<entersub> op tree for a
8875 subroutine call, not marked with C<&>, where the callee can be identified
8876 at compile time as I<cv>.
8878 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8879 argument for it is returned in I<*ckobj_p>. The function is intended
8880 to be called in this manner:
8882 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8884 In this call, I<entersubop> is a pointer to the C<entersub> op,
8885 which may be replaced by the check function, and I<namegv> is a GV
8886 supplying the name that should be used by the check function to refer
8887 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8888 It is permitted to apply the check function in non-standard situations,
8889 such as to a call to a different subroutine or to a method call.
8891 By default, the function is
8892 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8893 and the SV parameter is I<cv> itself. This implements standard
8894 prototype processing. It can be changed, for a particular subroutine,
8895 by L</cv_set_call_checker>.
8901 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8904 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8905 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8907 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8908 *ckobj_p = callmg->mg_obj;
8910 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8916 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8918 Sets the function that will be used to fix up a call to I<cv>.
8919 Specifically, the function is applied to an C<entersub> op tree for a
8920 subroutine call, not marked with C<&>, where the callee can be identified
8921 at compile time as I<cv>.
8923 The C-level function pointer is supplied in I<ckfun>, and an SV argument
8924 for it is supplied in I<ckobj>. The function is intended to be called
8927 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
8929 In this call, I<entersubop> is a pointer to the C<entersub> op,
8930 which may be replaced by the check function, and I<namegv> is a GV
8931 supplying the name that should be used by the check function to refer
8932 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8933 It is permitted to apply the check function in non-standard situations,
8934 such as to a call to a different subroutine or to a method call.
8936 The current setting for a particular CV can be retrieved by
8937 L</cv_get_call_checker>.
8943 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
8945 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
8946 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
8947 if (SvMAGICAL((SV*)cv))
8948 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
8951 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
8952 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
8953 if (callmg->mg_flags & MGf_REFCOUNTED) {
8954 SvREFCNT_dec(callmg->mg_obj);
8955 callmg->mg_flags &= ~MGf_REFCOUNTED;
8957 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
8958 callmg->mg_obj = ckobj;
8959 if (ckobj != (SV*)cv) {
8960 SvREFCNT_inc_simple_void_NN(ckobj);
8961 callmg->mg_flags |= MGf_REFCOUNTED;
8967 Perl_ck_subr(pTHX_ OP *o)
8973 PERL_ARGS_ASSERT_CK_SUBR;
8975 aop = cUNOPx(o)->op_first;
8976 if (!aop->op_sibling)
8977 aop = cUNOPx(aop)->op_first;
8978 aop = aop->op_sibling;
8979 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8980 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
8981 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
8983 o->op_private |= OPpENTERSUB_HASTARG;
8984 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8985 if (PERLDB_SUB && PL_curstash != PL_debstash)
8986 o->op_private |= OPpENTERSUB_DB;
8987 if (cvop->op_type == OP_RV2CV) {
8988 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
8990 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8991 if (aop->op_type == OP_CONST)
8992 aop->op_private &= ~OPpCONST_STRICT;
8993 else if (aop->op_type == OP_LIST) {
8994 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
8995 if (sib && sib->op_type == OP_CONST)
8996 sib->op_private &= ~OPpCONST_STRICT;
9001 return ck_entersub_args_list(o);
9003 Perl_call_checker ckfun;
9005 cv_get_call_checker(cv, &ckfun, &ckobj);
9006 return ckfun(aTHX_ o, namegv, ckobj);
9011 Perl_ck_svconst(pTHX_ OP *o)
9013 PERL_ARGS_ASSERT_CK_SVCONST;
9014 PERL_UNUSED_CONTEXT;
9015 SvREADONLY_on(cSVOPo->op_sv);
9020 Perl_ck_chdir(pTHX_ OP *o)
9022 PERL_ARGS_ASSERT_CK_CHDIR;
9023 if (o->op_flags & OPf_KIDS) {
9024 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9026 if (kid && kid->op_type == OP_CONST &&
9027 (kid->op_private & OPpCONST_BARE))
9029 o->op_flags |= OPf_SPECIAL;
9030 kid->op_private &= ~OPpCONST_STRICT;
9037 Perl_ck_trunc(pTHX_ OP *o)
9039 PERL_ARGS_ASSERT_CK_TRUNC;
9041 if (o->op_flags & OPf_KIDS) {
9042 SVOP *kid = (SVOP*)cUNOPo->op_first;
9044 if (kid->op_type == OP_NULL)
9045 kid = (SVOP*)kid->op_sibling;
9046 if (kid && kid->op_type == OP_CONST &&
9047 (kid->op_private & OPpCONST_BARE))
9049 o->op_flags |= OPf_SPECIAL;
9050 kid->op_private &= ~OPpCONST_STRICT;
9057 Perl_ck_unpack(pTHX_ OP *o)
9059 OP *kid = cLISTOPo->op_first;
9061 PERL_ARGS_ASSERT_CK_UNPACK;
9063 if (kid->op_sibling) {
9064 kid = kid->op_sibling;
9065 if (!kid->op_sibling)
9066 kid->op_sibling = newDEFSVOP();
9072 Perl_ck_substr(pTHX_ OP *o)
9074 PERL_ARGS_ASSERT_CK_SUBSTR;
9077 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9078 OP *kid = cLISTOPo->op_first;
9080 if (kid->op_type == OP_NULL)
9081 kid = kid->op_sibling;
9083 kid->op_flags |= OPf_MOD;
9090 Perl_ck_push(pTHX_ OP *o)
9093 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9097 PERL_ARGS_ASSERT_CK_PUSH;
9099 /* If 1st kid is pushmark (e.g. push, unshift, splice), we need 2nd kid */
9101 cursor = kid->op_type == OP_PUSHMARK ? kid->op_sibling : kid;
9104 /* If not array or array deref, wrap it with an array deref.
9105 * For OP_CONST, we only wrap arrayrefs */
9107 if ( ( cursor->op_type != OP_PADAV
9108 && cursor->op_type != OP_RV2AV
9109 && cursor->op_type != OP_CONST
9112 ( cursor->op_type == OP_CONST
9113 && SvROK(cSVOPx_sv(cursor))
9114 && SvTYPE(SvRV(cSVOPx_sv(cursor))) == SVt_PVAV
9117 proxy = newAVREF(cursor);
9118 if ( cursor == kid ) {
9119 cLISTOPx(o)->op_first = proxy;
9122 cLISTOPx(kid)->op_sibling = proxy;
9124 cLISTOPx(proxy)->op_sibling = cLISTOPx(cursor)->op_sibling;
9125 cLISTOPx(cursor)->op_sibling = NULL;
9132 Perl_ck_each(pTHX_ OP *o)
9135 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9136 const unsigned orig_type = o->op_type;
9137 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9138 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9139 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9140 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9142 PERL_ARGS_ASSERT_CK_EACH;
9145 switch (kid->op_type) {
9151 CHANGE_TYPE(o, array_type);
9154 if (kid->op_private == OPpCONST_BARE)
9155 /* we let ck_fun treat as hash */
9158 CHANGE_TYPE(o, ref_type);
9161 /* if treating as a reference, defer additional checks to runtime */
9162 return o->op_type == ref_type ? o : ck_fun(o);
9165 /* caller is supposed to assign the return to the
9166 container of the rep_op var */
9168 S_opt_scalarhv(pTHX_ OP *rep_op) {
9172 PERL_ARGS_ASSERT_OPT_SCALARHV;
9174 NewOp(1101, unop, 1, UNOP);
9175 unop->op_type = (OPCODE)OP_BOOLKEYS;
9176 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9177 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9178 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9179 unop->op_first = rep_op;
9180 unop->op_next = rep_op->op_next;
9181 rep_op->op_next = (OP*)unop;
9182 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9183 unop->op_sibling = rep_op->op_sibling;
9184 rep_op->op_sibling = NULL;
9185 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9186 if (rep_op->op_type == OP_PADHV) {
9187 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9188 rep_op->op_flags |= OPf_WANT_LIST;
9193 /* Checks if o acts as an in-place operator on an array. oright points to the
9194 * beginning of the right-hand side. Returns the left-hand side of the
9195 * assignment if o acts in-place, or NULL otherwise. */
9198 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9202 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9205 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9206 || oright->op_next != o
9207 || (oright->op_private & OPpLVAL_INTRO)
9211 /* o2 follows the chain of op_nexts through the LHS of the
9212 * assign (if any) to the aassign op itself */
9214 if (!o2 || o2->op_type != OP_NULL)
9217 if (!o2 || o2->op_type != OP_PUSHMARK)
9220 if (o2 && o2->op_type == OP_GV)
9223 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9224 || (o2->op_private & OPpLVAL_INTRO)
9229 if (!o2 || o2->op_type != OP_NULL)
9232 if (!o2 || o2->op_type != OP_AASSIGN
9233 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9236 /* check that the sort is the first arg on RHS of assign */
9238 o2 = cUNOPx(o2)->op_first;
9239 if (!o2 || o2->op_type != OP_NULL)
9241 o2 = cUNOPx(o2)->op_first;
9242 if (!o2 || o2->op_type != OP_PUSHMARK)
9244 if (o2->op_sibling != o)
9247 /* check the array is the same on both sides */
9248 if (oleft->op_type == OP_RV2AV) {
9249 if (oright->op_type != OP_RV2AV
9250 || !cUNOPx(oright)->op_first
9251 || cUNOPx(oright)->op_first->op_type != OP_GV
9252 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9253 cGVOPx_gv(cUNOPx(oright)->op_first)
9257 else if (oright->op_type != OP_PADAV
9258 || oright->op_targ != oleft->op_targ
9265 /* A peephole optimizer. We visit the ops in the order they're to execute.
9266 * See the comments at the top of this file for more details about when
9267 * peep() is called */
9270 Perl_rpeep(pTHX_ register OP *o)
9273 register OP* oldop = NULL;
9275 if (!o || o->op_opt)
9279 SAVEVPTR(PL_curcop);
9280 for (; o; o = o->op_next) {
9283 /* By default, this op has now been optimised. A couple of cases below
9284 clear this again. */
9287 switch (o->op_type) {
9289 PL_curcop = ((COP*)o); /* for warnings */
9292 PL_curcop = ((COP*)o); /* for warnings */
9294 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9295 to carry two labels. For now, take the easier option, and skip
9296 this optimisation if the first NEXTSTATE has a label. */
9297 if (!CopLABEL((COP*)o)) {
9298 OP *nextop = o->op_next;
9299 while (nextop && nextop->op_type == OP_NULL)
9300 nextop = nextop->op_next;
9302 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9303 COP *firstcop = (COP *)o;
9304 COP *secondcop = (COP *)nextop;
9305 /* We want the COP pointed to by o (and anything else) to
9306 become the next COP down the line. */
9309 firstcop->op_next = secondcop->op_next;
9311 /* Now steal all its pointers, and duplicate the other
9313 firstcop->cop_line = secondcop->cop_line;
9315 firstcop->cop_stashpv = secondcop->cop_stashpv;
9316 firstcop->cop_file = secondcop->cop_file;
9318 firstcop->cop_stash = secondcop->cop_stash;
9319 firstcop->cop_filegv = secondcop->cop_filegv;
9321 firstcop->cop_hints = secondcop->cop_hints;
9322 firstcop->cop_seq = secondcop->cop_seq;
9323 firstcop->cop_warnings = secondcop->cop_warnings;
9324 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9327 secondcop->cop_stashpv = NULL;
9328 secondcop->cop_file = NULL;
9330 secondcop->cop_stash = NULL;
9331 secondcop->cop_filegv = NULL;
9333 secondcop->cop_warnings = NULL;
9334 secondcop->cop_hints_hash = NULL;
9336 /* If we use op_null(), and hence leave an ex-COP, some
9337 warnings are misreported. For example, the compile-time
9338 error in 'use strict; no strict refs;' */
9339 secondcop->op_type = OP_NULL;
9340 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9346 if (cSVOPo->op_private & OPpCONST_STRICT)
9347 no_bareword_allowed(o);
9350 case OP_METHOD_NAMED:
9351 /* Relocate sv to the pad for thread safety.
9352 * Despite being a "constant", the SV is written to,
9353 * for reference counts, sv_upgrade() etc. */
9355 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9356 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9357 /* If op_sv is already a PADTMP then it is being used by
9358 * some pad, so make a copy. */
9359 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9360 SvREADONLY_on(PAD_SVl(ix));
9361 SvREFCNT_dec(cSVOPo->op_sv);
9363 else if (o->op_type != OP_METHOD_NAMED
9364 && cSVOPo->op_sv == &PL_sv_undef) {
9365 /* PL_sv_undef is hack - it's unsafe to store it in the
9366 AV that is the pad, because av_fetch treats values of
9367 PL_sv_undef as a "free" AV entry and will merrily
9368 replace them with a new SV, causing pad_alloc to think
9369 that this pad slot is free. (When, clearly, it is not)
9371 SvOK_off(PAD_SVl(ix));
9372 SvPADTMP_on(PAD_SVl(ix));
9373 SvREADONLY_on(PAD_SVl(ix));
9376 SvREFCNT_dec(PAD_SVl(ix));
9377 SvPADTMP_on(cSVOPo->op_sv);
9378 PAD_SETSV(ix, cSVOPo->op_sv);
9379 /* XXX I don't know how this isn't readonly already. */
9380 SvREADONLY_on(PAD_SVl(ix));
9382 cSVOPo->op_sv = NULL;
9389 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9390 if (o->op_next->op_private & OPpTARGET_MY) {
9391 if (o->op_flags & OPf_STACKED) /* chained concats */
9392 break; /* ignore_optimization */
9394 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9395 o->op_targ = o->op_next->op_targ;
9396 o->op_next->op_targ = 0;
9397 o->op_private |= OPpTARGET_MY;
9400 op_null(o->op_next);
9404 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9405 break; /* Scalar stub must produce undef. List stub is noop */
9409 if (o->op_targ == OP_NEXTSTATE
9410 || o->op_targ == OP_DBSTATE)
9412 PL_curcop = ((COP*)o);
9414 /* XXX: We avoid setting op_seq here to prevent later calls
9415 to rpeep() from mistakenly concluding that optimisation
9416 has already occurred. This doesn't fix the real problem,
9417 though (See 20010220.007). AMS 20010719 */
9418 /* op_seq functionality is now replaced by op_opt */
9425 if (oldop && o->op_next) {
9426 oldop->op_next = o->op_next;
9434 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9435 OP* const pop = (o->op_type == OP_PADAV) ?
9436 o->op_next : o->op_next->op_next;
9438 if (pop && pop->op_type == OP_CONST &&
9439 ((PL_op = pop->op_next)) &&
9440 pop->op_next->op_type == OP_AELEM &&
9441 !(pop->op_next->op_private &
9442 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9443 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9448 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9449 no_bareword_allowed(pop);
9450 if (o->op_type == OP_GV)
9451 op_null(o->op_next);
9452 op_null(pop->op_next);
9454 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9455 o->op_next = pop->op_next->op_next;
9456 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9457 o->op_private = (U8)i;
9458 if (o->op_type == OP_GV) {
9463 o->op_flags |= OPf_SPECIAL;
9464 o->op_type = OP_AELEMFAST;
9469 if (o->op_next->op_type == OP_RV2SV) {
9470 if (!(o->op_next->op_private & OPpDEREF)) {
9471 op_null(o->op_next);
9472 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9474 o->op_next = o->op_next->op_next;
9475 o->op_type = OP_GVSV;
9476 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9479 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9480 GV * const gv = cGVOPo_gv;
9481 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9482 /* XXX could check prototype here instead of just carping */
9483 SV * const sv = sv_newmortal();
9484 gv_efullname3(sv, gv, NULL);
9485 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9486 "%"SVf"() called too early to check prototype",
9490 else if (o->op_next->op_type == OP_READLINE
9491 && o->op_next->op_next->op_type == OP_CONCAT
9492 && (o->op_next->op_next->op_flags & OPf_STACKED))
9494 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9495 o->op_type = OP_RCATLINE;
9496 o->op_flags |= OPf_STACKED;
9497 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9498 op_null(o->op_next->op_next);
9499 op_null(o->op_next);
9509 fop = cUNOP->op_first;
9517 fop = cLOGOP->op_first;
9518 sop = fop->op_sibling;
9519 while (cLOGOP->op_other->op_type == OP_NULL)
9520 cLOGOP->op_other = cLOGOP->op_other->op_next;
9521 CALL_RPEEP(cLOGOP->op_other);
9525 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9527 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9532 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9533 while (nop && nop->op_next) {
9534 switch (nop->op_next->op_type) {
9539 lop = nop = nop->op_next;
9550 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9551 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9552 cLOGOP->op_first = opt_scalarhv(fop);
9553 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9554 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9570 while (cLOGOP->op_other->op_type == OP_NULL)
9571 cLOGOP->op_other = cLOGOP->op_other->op_next;
9572 CALL_RPEEP(cLOGOP->op_other);
9577 while (cLOOP->op_redoop->op_type == OP_NULL)
9578 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9579 CALL_RPEEP(cLOOP->op_redoop);
9580 while (cLOOP->op_nextop->op_type == OP_NULL)
9581 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9582 CALL_RPEEP(cLOOP->op_nextop);
9583 while (cLOOP->op_lastop->op_type == OP_NULL)
9584 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9585 CALL_RPEEP(cLOOP->op_lastop);
9589 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9590 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9591 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9592 cPMOP->op_pmstashstartu.op_pmreplstart
9593 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9594 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9598 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9599 && ckWARN(WARN_SYNTAX))
9601 if (o->op_next->op_sibling) {
9602 const OPCODE type = o->op_next->op_sibling->op_type;
9603 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9604 const line_t oldline = CopLINE(PL_curcop);
9605 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9606 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9607 "Statement unlikely to be reached");
9608 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9609 "\t(Maybe you meant system() when you said exec()?)\n");
9610 CopLINE_set(PL_curcop, oldline);
9621 const char *key = NULL;
9624 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9627 /* Make the CONST have a shared SV */
9628 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9629 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
9630 key = SvPV_const(sv, keylen);
9631 lexname = newSVpvn_share(key,
9632 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9638 if ((o->op_private & (OPpLVAL_INTRO)))
9641 rop = (UNOP*)((BINOP*)o)->op_first;
9642 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9644 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9645 if (!SvPAD_TYPED(lexname))
9647 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9648 if (!fields || !GvHV(*fields))
9650 key = SvPV_const(*svp, keylen);
9651 if (!hv_fetch(GvHV(*fields), key,
9652 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9654 Perl_croak(aTHX_ "No such class field \"%s\" "
9655 "in variable %s of type %s",
9656 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9669 SVOP *first_key_op, *key_op;
9671 if ((o->op_private & (OPpLVAL_INTRO))
9672 /* I bet there's always a pushmark... */
9673 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9674 /* hmmm, no optimization if list contains only one key. */
9676 rop = (UNOP*)((LISTOP*)o)->op_last;
9677 if (rop->op_type != OP_RV2HV)
9679 if (rop->op_first->op_type == OP_PADSV)
9680 /* @$hash{qw(keys here)} */
9681 rop = (UNOP*)rop->op_first;
9683 /* @{$hash}{qw(keys here)} */
9684 if (rop->op_first->op_type == OP_SCOPE
9685 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9687 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9693 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9694 if (!SvPAD_TYPED(lexname))
9696 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9697 if (!fields || !GvHV(*fields))
9699 /* Again guessing that the pushmark can be jumped over.... */
9700 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9701 ->op_first->op_sibling;
9702 for (key_op = first_key_op; key_op;
9703 key_op = (SVOP*)key_op->op_sibling) {
9704 if (key_op->op_type != OP_CONST)
9706 svp = cSVOPx_svp(key_op);
9707 key = SvPV_const(*svp, keylen);
9708 if (!hv_fetch(GvHV(*fields), key,
9709 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9711 Perl_croak(aTHX_ "No such class field \"%s\" "
9712 "in variable %s of type %s",
9713 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9722 && ( oldop->op_type == OP_AELEM
9723 || oldop->op_type == OP_PADSV
9724 || oldop->op_type == OP_RV2SV
9725 || oldop->op_type == OP_RV2GV
9726 || oldop->op_type == OP_HELEM
9728 && (oldop->op_private & OPpDEREF)
9730 o->op_private |= OPpDEREFed;
9734 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9738 /* check that RHS of sort is a single plain array */
9739 OP *oright = cUNOPo->op_first;
9740 if (!oright || oright->op_type != OP_PUSHMARK)
9743 /* reverse sort ... can be optimised. */
9744 if (!cUNOPo->op_sibling) {
9745 /* Nothing follows us on the list. */
9746 OP * const reverse = o->op_next;
9748 if (reverse->op_type == OP_REVERSE &&
9749 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9750 OP * const pushmark = cUNOPx(reverse)->op_first;
9751 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9752 && (cUNOPx(pushmark)->op_sibling == o)) {
9753 /* reverse -> pushmark -> sort */
9754 o->op_private |= OPpSORT_REVERSE;
9756 pushmark->op_next = oright->op_next;
9762 /* make @a = sort @a act in-place */
9764 oright = cUNOPx(oright)->op_sibling;
9767 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9768 oright = cUNOPx(oright)->op_sibling;
9771 oleft = is_inplace_av(o, oright);
9775 /* transfer MODishness etc from LHS arg to RHS arg */
9776 oright->op_flags = oleft->op_flags;
9777 o->op_private |= OPpSORT_INPLACE;
9779 /* excise push->gv->rv2av->null->aassign */
9780 o2 = o->op_next->op_next;
9781 op_null(o2); /* PUSHMARK */
9783 if (o2->op_type == OP_GV) {
9784 op_null(o2); /* GV */
9787 op_null(o2); /* RV2AV or PADAV */
9788 o2 = o2->op_next->op_next;
9789 op_null(o2); /* AASSIGN */
9791 o->op_next = o2->op_next;
9797 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9800 LISTOP *enter, *exlist;
9802 /* @a = reverse @a */
9803 if ((oright = cLISTOPo->op_first)
9804 && (oright->op_type == OP_PUSHMARK)
9805 && (oright = oright->op_sibling)
9806 && (oleft = is_inplace_av(o, oright))) {
9809 /* transfer MODishness etc from LHS arg to RHS arg */
9810 oright->op_flags = oleft->op_flags;
9811 o->op_private |= OPpREVERSE_INPLACE;
9813 /* excise push->gv->rv2av->null->aassign */
9814 o2 = o->op_next->op_next;
9815 op_null(o2); /* PUSHMARK */
9817 if (o2->op_type == OP_GV) {
9818 op_null(o2); /* GV */
9821 op_null(o2); /* RV2AV or PADAV */
9822 o2 = o2->op_next->op_next;
9823 op_null(o2); /* AASSIGN */
9825 o->op_next = o2->op_next;
9829 enter = (LISTOP *) o->op_next;
9832 if (enter->op_type == OP_NULL) {
9833 enter = (LISTOP *) enter->op_next;
9837 /* for $a (...) will have OP_GV then OP_RV2GV here.
9838 for (...) just has an OP_GV. */
9839 if (enter->op_type == OP_GV) {
9840 gvop = (OP *) enter;
9841 enter = (LISTOP *) enter->op_next;
9844 if (enter->op_type == OP_RV2GV) {
9845 enter = (LISTOP *) enter->op_next;
9851 if (enter->op_type != OP_ENTERITER)
9854 iter = enter->op_next;
9855 if (!iter || iter->op_type != OP_ITER)
9858 expushmark = enter->op_first;
9859 if (!expushmark || expushmark->op_type != OP_NULL
9860 || expushmark->op_targ != OP_PUSHMARK)
9863 exlist = (LISTOP *) expushmark->op_sibling;
9864 if (!exlist || exlist->op_type != OP_NULL
9865 || exlist->op_targ != OP_LIST)
9868 if (exlist->op_last != o) {
9869 /* Mmm. Was expecting to point back to this op. */
9872 theirmark = exlist->op_first;
9873 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9876 if (theirmark->op_sibling != o) {
9877 /* There's something between the mark and the reverse, eg
9878 for (1, reverse (...))
9883 ourmark = ((LISTOP *)o)->op_first;
9884 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9887 ourlast = ((LISTOP *)o)->op_last;
9888 if (!ourlast || ourlast->op_next != o)
9891 rv2av = ourmark->op_sibling;
9892 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9893 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9894 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9895 /* We're just reversing a single array. */
9896 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9897 enter->op_flags |= OPf_STACKED;
9900 /* We don't have control over who points to theirmark, so sacrifice
9902 theirmark->op_next = ourmark->op_next;
9903 theirmark->op_flags = ourmark->op_flags;
9904 ourlast->op_next = gvop ? gvop : (OP *) enter;
9907 enter->op_private |= OPpITER_REVERSED;
9908 iter->op_private |= OPpITER_REVERSED;
9915 UNOP *refgen, *rv2cv;
9918 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9921 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9924 rv2gv = ((BINOP *)o)->op_last;
9925 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9928 refgen = (UNOP *)((BINOP *)o)->op_first;
9930 if (!refgen || refgen->op_type != OP_REFGEN)
9933 exlist = (LISTOP *)refgen->op_first;
9934 if (!exlist || exlist->op_type != OP_NULL
9935 || exlist->op_targ != OP_LIST)
9938 if (exlist->op_first->op_type != OP_PUSHMARK)
9941 rv2cv = (UNOP*)exlist->op_last;
9943 if (rv2cv->op_type != OP_RV2CV)
9946 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9947 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9948 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9950 o->op_private |= OPpASSIGN_CV_TO_GV;
9951 rv2gv->op_private |= OPpDONT_INIT_GV;
9952 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9960 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9961 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9966 Perl_cpeep_t cpeep =
9967 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
9969 cpeep(aTHX_ o, oldop);
9980 Perl_peep(pTHX_ register OP *o)
9986 =head1 Custom Operators
9988 =for apidoc Ao||custom_op_xop
9989 Return the XOP structure for a given custom op. This function should be
9990 considered internal to OP_NAME and the other access macros: use them instead.
9996 Perl_custom_op_xop(pTHX_ const OP *o)
10002 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10004 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10005 assert(o->op_type == OP_CUSTOM);
10007 /* This is wrong. It assumes a function pointer can be cast to IV,
10008 * which isn't guaranteed, but this is what the old custom OP code
10009 * did. In principle it should be safer to Copy the bytes of the
10010 * pointer into a PV: since the new interface is hidden behind
10011 * functions, this can be changed later if necessary. */
10012 /* Change custom_op_xop if this ever happens */
10013 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10016 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10018 /* assume noone will have just registered a desc */
10019 if (!he && PL_custom_op_names &&
10020 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10025 /* XXX does all this need to be shared mem? */
10026 Newxz(xop, 1, XOP);
10027 pv = SvPV(HeVAL(he), l);
10028 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10029 if (PL_custom_op_descs &&
10030 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10032 pv = SvPV(HeVAL(he), l);
10033 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10035 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10039 if (!he) return &xop_null;
10041 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10046 =for apidoc Ao||custom_op_register
10047 Register a custom op. See L<perlguts/"Custom Operators">.
10053 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10057 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10059 /* see the comment in custom_op_xop */
10060 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10062 if (!PL_custom_ops)
10063 PL_custom_ops = newHV();
10065 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10066 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10071 /* Efficient sub that returns a constant scalar value. */
10073 const_sv_xsub(pTHX_ CV* cv)
10077 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10081 /* diag_listed_as: SKIPME */
10082 Perl_croak(aTHX_ "usage: %s::%s()",
10083 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10096 * c-indentation-style: bsd
10097 * c-basic-offset: 4
10098 * indent-tabs-mode: t
10101 * ex: set ts=8 sts=4 sw=4 noet: