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) CALL_FPTR(PL_peepp)(aTHX_ o)
107 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
109 #if defined(PL_OP_SLAB_ALLOC)
111 #ifdef PERL_DEBUG_READONLY_OPS
112 # define PERL_SLAB_SIZE 4096
113 # include <sys/mman.h>
116 #ifndef PERL_SLAB_SIZE
117 #define PERL_SLAB_SIZE 2048
121 Perl_Slab_Alloc(pTHX_ size_t sz)
125 * To make incrementing use count easy PL_OpSlab is an I32 *
126 * To make inserting the link to slab PL_OpPtr is I32 **
127 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
128 * Add an overhead for pointer to slab and round up as a number of pointers
130 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
131 if ((PL_OpSpace -= sz) < 0) {
132 #ifdef PERL_DEBUG_READONLY_OPS
133 /* We need to allocate chunk by chunk so that we can control the VM
135 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
136 MAP_ANON|MAP_PRIVATE, -1, 0);
138 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
139 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
141 if(PL_OpPtr == MAP_FAILED) {
142 perror("mmap failed");
147 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
152 /* We reserve the 0'th I32 sized chunk as a use count */
153 PL_OpSlab = (I32 *) PL_OpPtr;
154 /* Reduce size by the use count word, and by the size we need.
155 * Latter is to mimic the '-=' in the if() above
157 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
158 /* Allocation pointer starts at the top.
159 Theory: because we build leaves before trunk allocating at end
160 means that at run time access is cache friendly upward
162 PL_OpPtr += PERL_SLAB_SIZE;
164 #ifdef PERL_DEBUG_READONLY_OPS
165 /* We remember this slab. */
166 /* This implementation isn't efficient, but it is simple. */
167 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
168 PL_slabs[PL_slab_count++] = PL_OpSlab;
169 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
172 assert( PL_OpSpace >= 0 );
173 /* Move the allocation pointer down */
175 assert( PL_OpPtr > (I32 **) PL_OpSlab );
176 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
177 (*PL_OpSlab)++; /* Increment use count of slab */
178 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
179 assert( *PL_OpSlab > 0 );
180 return (void *)(PL_OpPtr + 1);
183 #ifdef PERL_DEBUG_READONLY_OPS
185 Perl_pending_Slabs_to_ro(pTHX) {
186 /* Turn all the allocated op slabs read only. */
187 U32 count = PL_slab_count;
188 I32 **const slabs = PL_slabs;
190 /* Reset the array of pending OP slabs, as we're about to turn this lot
191 read only. Also, do it ahead of the loop in case the warn triggers,
192 and a warn handler has an eval */
197 /* Force a new slab for any further allocation. */
201 void *const start = slabs[count];
202 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
203 if(mprotect(start, size, PROT_READ)) {
204 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
205 start, (unsigned long) size, errno);
213 S_Slab_to_rw(pTHX_ void *op)
215 I32 * const * const ptr = (I32 **) op;
216 I32 * const slab = ptr[-1];
218 PERL_ARGS_ASSERT_SLAB_TO_RW;
220 assert( ptr-1 > (I32 **) slab );
221 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
223 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
224 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
225 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
230 Perl_op_refcnt_inc(pTHX_ OP *o)
241 Perl_op_refcnt_dec(pTHX_ OP *o)
243 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
248 # define Slab_to_rw(op)
252 Perl_Slab_Free(pTHX_ void *op)
254 I32 * const * const ptr = (I32 **) op;
255 I32 * const slab = ptr[-1];
256 PERL_ARGS_ASSERT_SLAB_FREE;
257 assert( ptr-1 > (I32 **) slab );
258 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
261 if (--(*slab) == 0) {
263 # define PerlMemShared PerlMem
266 #ifdef PERL_DEBUG_READONLY_OPS
267 U32 count = PL_slab_count;
268 /* Need to remove this slab from our list of slabs */
271 if (PL_slabs[count] == slab) {
273 /* Found it. Move the entry at the end to overwrite it. */
274 DEBUG_m(PerlIO_printf(Perl_debug_log,
275 "Deallocate %p by moving %p from %lu to %lu\n",
277 PL_slabs[PL_slab_count - 1],
278 PL_slab_count, count));
279 PL_slabs[count] = PL_slabs[--PL_slab_count];
280 /* Could realloc smaller at this point, but probably not
282 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
283 perror("munmap failed");
291 PerlMemShared_free(slab);
293 if (slab == PL_OpSlab) {
300 * In the following definition, the ", (OP*)0" is just to make the compiler
301 * think the expression is of the right type: croak actually does a Siglongjmp.
303 #define CHECKOP(type,o) \
304 ((PL_op_mask && PL_op_mask[type]) \
305 ? ( op_free((OP*)o), \
306 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
308 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
310 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
313 S_gv_ename(pTHX_ GV *gv)
315 SV* const tmpsv = sv_newmortal();
317 PERL_ARGS_ASSERT_GV_ENAME;
319 gv_efullname3(tmpsv, gv, NULL);
320 return SvPV_nolen_const(tmpsv);
324 S_no_fh_allowed(pTHX_ OP *o)
326 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
328 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
334 S_too_few_arguments(pTHX_ OP *o, const char *name)
336 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
338 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
343 S_too_many_arguments(pTHX_ OP *o, const char *name)
345 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
347 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
352 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
354 PERL_ARGS_ASSERT_BAD_TYPE;
356 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
357 (int)n, name, t, OP_DESC(kid)));
361 S_no_bareword_allowed(pTHX_ const OP *o)
363 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
366 return; /* various ok barewords are hidden in extra OP_NULL */
367 qerror(Perl_mess(aTHX_
368 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
372 /* "register" allocation */
375 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
379 const bool is_our = (PL_parser->in_my == KEY_our);
381 PERL_ARGS_ASSERT_ALLOCMY;
384 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
387 /* Until we're using the length for real, cross check that we're being
389 assert(strlen(name) == len);
391 /* complain about "my $<special_var>" etc etc */
395 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
396 (name[1] == '_' && (*name == '$' || len > 2))))
398 /* name[2] is true if strlen(name) > 2 */
399 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
400 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
401 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
402 PL_parser->in_my == KEY_state ? "state" : "my"));
404 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
405 PL_parser->in_my == KEY_state ? "state" : "my"));
409 /* allocate a spare slot and store the name in that slot */
411 off = pad_add_name(name, len,
412 is_our ? pad_add_OUR :
413 PL_parser->in_my == KEY_state ? pad_add_STATE : 0,
414 PL_parser->in_my_stash,
416 /* $_ is always in main::, even with our */
417 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
421 /* anon sub prototypes contains state vars should always be cloned,
422 * otherwise the state var would be shared between anon subs */
424 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
425 CvCLONE_on(PL_compcv);
430 /* free the body of an op without examining its contents.
431 * Always use this rather than FreeOp directly */
434 S_op_destroy(pTHX_ OP *o)
436 if (o->op_latefree) {
444 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
446 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
452 Perl_op_free(pTHX_ OP *o)
459 if (o->op_latefreed) {
466 if (o->op_private & OPpREFCOUNTED) {
477 refcnt = OpREFCNT_dec(o);
480 /* Need to find and remove any pattern match ops from the list
481 we maintain for reset(). */
482 find_and_forget_pmops(o);
492 /* Call the op_free hook if it has been set. Do it now so that it's called
493 * at the right time for refcounted ops, but still before all of the kids
497 if (o->op_flags & OPf_KIDS) {
498 register OP *kid, *nextkid;
499 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
500 nextkid = kid->op_sibling; /* Get before next freeing kid */
505 #ifdef PERL_DEBUG_READONLY_OPS
509 /* COP* is not cleared by op_clear() so that we may track line
510 * numbers etc even after null() */
511 if (type == OP_NEXTSTATE || type == OP_DBSTATE
512 || (type == OP_NULL /* the COP might have been null'ed */
513 && ((OPCODE)o->op_targ == OP_NEXTSTATE
514 || (OPCODE)o->op_targ == OP_DBSTATE))) {
519 type = (OPCODE)o->op_targ;
522 if (o->op_latefree) {
528 #ifdef DEBUG_LEAKING_SCALARS
535 Perl_op_clear(pTHX_ OP *o)
540 PERL_ARGS_ASSERT_OP_CLEAR;
543 /* if (o->op_madprop && o->op_madprop->mad_next)
545 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
546 "modification of a read only value" for a reason I can't fathom why.
547 It's the "" stringification of $_, where $_ was set to '' in a foreach
548 loop, but it defies simplification into a small test case.
549 However, commenting them out has caused ext/List/Util/t/weak.t to fail
552 mad_free(o->op_madprop);
558 switch (o->op_type) {
559 case OP_NULL: /* Was holding old type, if any. */
560 if (PL_madskills && o->op_targ != OP_NULL) {
561 o->op_type = (Optype)o->op_targ;
565 case OP_ENTEREVAL: /* Was holding hints. */
569 if (!(o->op_flags & OPf_REF)
570 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
576 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
577 /* not an OP_PADAV replacement */
578 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
583 /* It's possible during global destruction that the GV is freed
584 before the optree. Whilst the SvREFCNT_inc is happy to bump from
585 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
586 will trigger an assertion failure, because the entry to sv_clear
587 checks that the scalar is not already freed. A check of for
588 !SvIS_FREED(gv) turns out to be invalid, because during global
589 destruction the reference count can be forced down to zero
590 (with SVf_BREAK set). In which case raising to 1 and then
591 dropping to 0 triggers cleanup before it should happen. I
592 *think* that this might actually be a general, systematic,
593 weakness of the whole idea of SVf_BREAK, in that code *is*
594 allowed to raise and lower references during global destruction,
595 so any *valid* code that happens to do this during global
596 destruction might well trigger premature cleanup. */
597 bool still_valid = gv && SvREFCNT(gv);
600 SvREFCNT_inc_simple_void(gv);
602 if (cPADOPo->op_padix > 0) {
603 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
604 * may still exist on the pad */
605 pad_swipe(cPADOPo->op_padix, TRUE);
606 cPADOPo->op_padix = 0;
609 SvREFCNT_dec(cSVOPo->op_sv);
610 cSVOPo->op_sv = NULL;
613 int try_downgrade = SvREFCNT(gv) == 2;
616 gv_try_downgrade(gv);
620 case OP_METHOD_NAMED:
623 SvREFCNT_dec(cSVOPo->op_sv);
624 cSVOPo->op_sv = NULL;
627 Even if op_clear does a pad_free for the target of the op,
628 pad_free doesn't actually remove the sv that exists in the pad;
629 instead it lives on. This results in that it could be reused as
630 a target later on when the pad was reallocated.
633 pad_swipe(o->op_targ,1);
642 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
646 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
648 if (cPADOPo->op_padix > 0) {
649 pad_swipe(cPADOPo->op_padix, TRUE);
650 cPADOPo->op_padix = 0;
653 SvREFCNT_dec(cSVOPo->op_sv);
654 cSVOPo->op_sv = NULL;
658 PerlMemShared_free(cPVOPo->op_pv);
659 cPVOPo->op_pv = NULL;
663 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
667 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
668 /* No GvIN_PAD_off here, because other references may still
669 * exist on the pad */
670 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
673 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
679 forget_pmop(cPMOPo, 1);
680 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
681 /* we use the same protection as the "SAFE" version of the PM_ macros
682 * here since sv_clean_all might release some PMOPs
683 * after PL_regex_padav has been cleared
684 * and the clearing of PL_regex_padav needs to
685 * happen before sv_clean_all
688 if(PL_regex_pad) { /* We could be in destruction */
689 const IV offset = (cPMOPo)->op_pmoffset;
690 ReREFCNT_dec(PM_GETRE(cPMOPo));
691 PL_regex_pad[offset] = &PL_sv_undef;
692 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
696 ReREFCNT_dec(PM_GETRE(cPMOPo));
697 PM_SETRE(cPMOPo, NULL);
703 if (o->op_targ > 0) {
704 pad_free(o->op_targ);
710 S_cop_free(pTHX_ COP* cop)
712 PERL_ARGS_ASSERT_COP_FREE;
716 if (! specialWARN(cop->cop_warnings))
717 PerlMemShared_free(cop->cop_warnings);
718 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
722 S_forget_pmop(pTHX_ PMOP *const o
728 HV * const pmstash = PmopSTASH(o);
730 PERL_ARGS_ASSERT_FORGET_PMOP;
732 if (pmstash && !SvIS_FREED(pmstash)) {
733 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
735 PMOP **const array = (PMOP**) mg->mg_ptr;
736 U32 count = mg->mg_len / sizeof(PMOP**);
741 /* Found it. Move the entry at the end to overwrite it. */
742 array[i] = array[--count];
743 mg->mg_len = count * sizeof(PMOP**);
744 /* Could realloc smaller at this point always, but probably
745 not worth it. Probably worth free()ing if we're the
748 Safefree(mg->mg_ptr);
765 S_find_and_forget_pmops(pTHX_ OP *o)
767 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
769 if (o->op_flags & OPf_KIDS) {
770 OP *kid = cUNOPo->op_first;
772 switch (kid->op_type) {
777 forget_pmop((PMOP*)kid, 0);
779 find_and_forget_pmops(kid);
780 kid = kid->op_sibling;
786 Perl_op_null(pTHX_ OP *o)
790 PERL_ARGS_ASSERT_OP_NULL;
792 if (o->op_type == OP_NULL)
796 o->op_targ = o->op_type;
797 o->op_type = OP_NULL;
798 o->op_ppaddr = PL_ppaddr[OP_NULL];
802 Perl_op_refcnt_lock(pTHX)
810 Perl_op_refcnt_unlock(pTHX)
817 /* Contextualizers */
819 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
822 S_linklist(pTHX_ OP *o)
826 PERL_ARGS_ASSERT_LINKLIST;
831 /* establish postfix order */
832 first = cUNOPo->op_first;
835 o->op_next = LINKLIST(first);
838 if (kid->op_sibling) {
839 kid->op_next = LINKLIST(kid->op_sibling);
840 kid = kid->op_sibling;
854 S_scalarkids(pTHX_ OP *o)
856 if (o && o->op_flags & OPf_KIDS) {
858 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
865 S_scalarboolean(pTHX_ OP *o)
869 PERL_ARGS_ASSERT_SCALARBOOLEAN;
871 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
872 if (ckWARN(WARN_SYNTAX)) {
873 const line_t oldline = CopLINE(PL_curcop);
875 if (PL_parser && PL_parser->copline != NOLINE)
876 CopLINE_set(PL_curcop, PL_parser->copline);
877 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
878 CopLINE_set(PL_curcop, oldline);
885 Perl_scalar(pTHX_ OP *o)
890 /* assumes no premature commitment */
891 if (!o || (PL_parser && PL_parser->error_count)
892 || (o->op_flags & OPf_WANT)
893 || o->op_type == OP_RETURN)
898 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
900 switch (o->op_type) {
902 scalar(cBINOPo->op_first);
907 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
917 if (o->op_flags & OPf_KIDS) {
918 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
924 kid = cLISTOPo->op_first;
926 while ((kid = kid->op_sibling)) {
932 PL_curcop = &PL_compiling;
937 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
943 PL_curcop = &PL_compiling;
946 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
953 Perl_scalarvoid(pTHX_ OP *o)
957 const char* useless = NULL;
961 PERL_ARGS_ASSERT_SCALARVOID;
963 /* trailing mad null ops don't count as "there" for void processing */
965 o->op_type != OP_NULL &&
967 o->op_sibling->op_type == OP_NULL)
970 for (sib = o->op_sibling;
971 sib && sib->op_type == OP_NULL;
972 sib = sib->op_sibling) ;
978 if (o->op_type == OP_NEXTSTATE
979 || o->op_type == OP_DBSTATE
980 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
981 || o->op_targ == OP_DBSTATE)))
982 PL_curcop = (COP*)o; /* for warning below */
984 /* assumes no premature commitment */
985 want = o->op_flags & OPf_WANT;
986 if ((want && want != OPf_WANT_SCALAR)
987 || (PL_parser && PL_parser->error_count)
988 || o->op_type == OP_RETURN)
993 if ((o->op_private & OPpTARGET_MY)
994 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
996 return scalar(o); /* As if inside SASSIGN */
999 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1001 switch (o->op_type) {
1003 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1007 if (o->op_flags & OPf_STACKED)
1011 if (o->op_private == 4)
1054 case OP_GETSOCKNAME:
1055 case OP_GETPEERNAME:
1060 case OP_GETPRIORITY:
1084 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1085 /* Otherwise it's "Useless use of grep iterator" */
1086 useless = OP_DESC(o);
1090 kid = cUNOPo->op_first;
1091 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1092 kid->op_type != OP_TRANS) {
1095 useless = "negative pattern binding (!~)";
1102 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1103 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1104 useless = "a variable";
1109 if (cSVOPo->op_private & OPpCONST_STRICT)
1110 no_bareword_allowed(o);
1112 if (ckWARN(WARN_VOID)) {
1114 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1115 "a constant (%"SVf")", sv));
1116 useless = SvPV_nolen(msv);
1119 useless = "a constant (undef)";
1120 if (o->op_private & OPpCONST_ARYBASE)
1122 /* don't warn on optimised away booleans, eg
1123 * use constant Foo, 5; Foo || print; */
1124 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1126 /* the constants 0 and 1 are permitted as they are
1127 conventionally used as dummies in constructs like
1128 1 while some_condition_with_side_effects; */
1129 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1131 else if (SvPOK(sv)) {
1132 /* perl4's way of mixing documentation and code
1133 (before the invention of POD) was based on a
1134 trick to mix nroff and perl code. The trick was
1135 built upon these three nroff macros being used in
1136 void context. The pink camel has the details in
1137 the script wrapman near page 319. */
1138 const char * const maybe_macro = SvPVX_const(sv);
1139 if (strnEQ(maybe_macro, "di", 2) ||
1140 strnEQ(maybe_macro, "ds", 2) ||
1141 strnEQ(maybe_macro, "ig", 2))
1146 op_null(o); /* don't execute or even remember it */
1150 o->op_type = OP_PREINC; /* pre-increment is faster */
1151 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1155 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1156 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1160 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1161 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1165 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1166 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1171 kid = cLOGOPo->op_first;
1172 if (kid->op_type == OP_NOT
1173 && (kid->op_flags & OPf_KIDS)
1175 if (o->op_type == OP_AND) {
1177 o->op_ppaddr = PL_ppaddr[OP_OR];
1179 o->op_type = OP_AND;
1180 o->op_ppaddr = PL_ppaddr[OP_AND];
1189 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1194 if (o->op_flags & OPf_STACKED)
1201 if (!(o->op_flags & OPf_KIDS))
1212 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1219 /* all requires must return a boolean value */
1220 o->op_flags &= ~OPf_WANT;
1226 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1231 S_listkids(pTHX_ OP *o)
1233 if (o && o->op_flags & OPf_KIDS) {
1235 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1242 Perl_list(pTHX_ OP *o)
1247 /* assumes no premature commitment */
1248 if (!o || (o->op_flags & OPf_WANT)
1249 || (PL_parser && PL_parser->error_count)
1250 || o->op_type == OP_RETURN)
1255 if ((o->op_private & OPpTARGET_MY)
1256 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1258 return o; /* As if inside SASSIGN */
1261 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1263 switch (o->op_type) {
1266 list(cBINOPo->op_first);
1271 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1279 if (!(o->op_flags & OPf_KIDS))
1281 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1282 list(cBINOPo->op_first);
1283 return gen_constant_list(o);
1290 kid = cLISTOPo->op_first;
1292 while ((kid = kid->op_sibling)) {
1293 if (kid->op_sibling)
1298 PL_curcop = &PL_compiling;
1302 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1303 if (kid->op_sibling)
1308 PL_curcop = &PL_compiling;
1311 /* all requires must return a boolean value */
1312 o->op_flags &= ~OPf_WANT;
1319 S_scalarseq(pTHX_ OP *o)
1323 const OPCODE type = o->op_type;
1325 if (type == OP_LINESEQ || type == OP_SCOPE ||
1326 type == OP_LEAVE || type == OP_LEAVETRY)
1329 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1330 if (kid->op_sibling) {
1334 PL_curcop = &PL_compiling;
1336 o->op_flags &= ~OPf_PARENS;
1337 if (PL_hints & HINT_BLOCK_SCOPE)
1338 o->op_flags |= OPf_PARENS;
1341 o = newOP(OP_STUB, 0);
1346 S_modkids(pTHX_ OP *o, I32 type)
1348 if (o && o->op_flags & OPf_KIDS) {
1350 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1356 /* Propagate lvalue ("modifiable") context to an op and its children.
1357 * 'type' represents the context type, roughly based on the type of op that
1358 * would do the modifying, although local() is represented by OP_NULL.
1359 * It's responsible for detecting things that can't be modified, flag
1360 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1361 * might have to vivify a reference in $x), and so on.
1363 * For example, "$a+1 = 2" would cause mod() to be called with o being
1364 * OP_ADD and type being OP_SASSIGN, and would output an error.
1368 Perl_mod(pTHX_ OP *o, I32 type)
1372 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1375 if (!o || (PL_parser && PL_parser->error_count))
1378 if ((o->op_private & OPpTARGET_MY)
1379 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1384 switch (o->op_type) {
1390 if (!(o->op_private & OPpCONST_ARYBASE))
1393 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1394 CopARYBASE_set(&PL_compiling,
1395 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1399 SAVECOPARYBASE(&PL_compiling);
1400 CopARYBASE_set(&PL_compiling, 0);
1402 else if (type == OP_REFGEN)
1405 Perl_croak(aTHX_ "That use of $[ is unsupported");
1408 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1412 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1413 !(o->op_flags & OPf_STACKED)) {
1414 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1415 /* The default is to set op_private to the number of children,
1416 which for a UNOP such as RV2CV is always 1. And w're using
1417 the bit for a flag in RV2CV, so we need it clear. */
1418 o->op_private &= ~1;
1419 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1420 assert(cUNOPo->op_first->op_type == OP_NULL);
1421 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1424 else if (o->op_private & OPpENTERSUB_NOMOD)
1426 else { /* lvalue subroutine call */
1427 o->op_private |= OPpLVAL_INTRO;
1428 PL_modcount = RETURN_UNLIMITED_NUMBER;
1429 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1430 /* Backward compatibility mode: */
1431 o->op_private |= OPpENTERSUB_INARGS;
1434 else { /* Compile-time error message: */
1435 OP *kid = cUNOPo->op_first;
1439 if (kid->op_type != OP_PUSHMARK) {
1440 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1442 "panic: unexpected lvalue entersub "
1443 "args: type/targ %ld:%"UVuf,
1444 (long)kid->op_type, (UV)kid->op_targ);
1445 kid = kLISTOP->op_first;
1447 while (kid->op_sibling)
1448 kid = kid->op_sibling;
1449 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1451 if (kid->op_type == OP_METHOD_NAMED
1452 || kid->op_type == OP_METHOD)
1456 NewOp(1101, newop, 1, UNOP);
1457 newop->op_type = OP_RV2CV;
1458 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1459 newop->op_first = NULL;
1460 newop->op_next = (OP*)newop;
1461 kid->op_sibling = (OP*)newop;
1462 newop->op_private |= OPpLVAL_INTRO;
1463 newop->op_private &= ~1;
1467 if (kid->op_type != OP_RV2CV)
1469 "panic: unexpected lvalue entersub "
1470 "entry via type/targ %ld:%"UVuf,
1471 (long)kid->op_type, (UV)kid->op_targ);
1472 kid->op_private |= OPpLVAL_INTRO;
1473 break; /* Postpone until runtime */
1477 kid = kUNOP->op_first;
1478 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1479 kid = kUNOP->op_first;
1480 if (kid->op_type == OP_NULL)
1482 "Unexpected constant lvalue entersub "
1483 "entry via type/targ %ld:%"UVuf,
1484 (long)kid->op_type, (UV)kid->op_targ);
1485 if (kid->op_type != OP_GV) {
1486 /* Restore RV2CV to check lvalueness */
1488 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1489 okid->op_next = kid->op_next;
1490 kid->op_next = okid;
1493 okid->op_next = NULL;
1494 okid->op_type = OP_RV2CV;
1496 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1497 okid->op_private |= OPpLVAL_INTRO;
1498 okid->op_private &= ~1;
1502 cv = GvCV(kGVOP_gv);
1512 /* grep, foreach, subcalls, refgen */
1513 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1515 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1516 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1518 : (o->op_type == OP_ENTERSUB
1519 ? "non-lvalue subroutine call"
1521 type ? PL_op_desc[type] : "local"));
1535 case OP_RIGHT_SHIFT:
1544 if (!(o->op_flags & OPf_STACKED))
1551 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1557 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1558 PL_modcount = RETURN_UNLIMITED_NUMBER;
1559 return o; /* Treat \(@foo) like ordinary list. */
1563 if (scalar_mod_type(o, type))
1565 ref(cUNOPo->op_first, o->op_type);
1569 if (type == OP_LEAVESUBLV)
1570 o->op_private |= OPpMAYBE_LVSUB;
1576 PL_modcount = RETURN_UNLIMITED_NUMBER;
1579 PL_hints |= HINT_BLOCK_SCOPE;
1580 if (type == OP_LEAVESUBLV)
1581 o->op_private |= OPpMAYBE_LVSUB;
1585 ref(cUNOPo->op_first, o->op_type);
1589 PL_hints |= HINT_BLOCK_SCOPE;
1604 PL_modcount = RETURN_UNLIMITED_NUMBER;
1605 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1606 return o; /* Treat \(@foo) like ordinary list. */
1607 if (scalar_mod_type(o, type))
1609 if (type == OP_LEAVESUBLV)
1610 o->op_private |= OPpMAYBE_LVSUB;
1614 if (!type) /* local() */
1615 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1616 PAD_COMPNAME_PV(o->op_targ));
1624 if (type != OP_SASSIGN)
1628 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1633 if (type == OP_LEAVESUBLV)
1634 o->op_private |= OPpMAYBE_LVSUB;
1636 pad_free(o->op_targ);
1637 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1638 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1639 if (o->op_flags & OPf_KIDS)
1640 mod(cBINOPo->op_first->op_sibling, type);
1645 ref(cBINOPo->op_first, o->op_type);
1646 if (type == OP_ENTERSUB &&
1647 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1648 o->op_private |= OPpLVAL_DEFER;
1649 if (type == OP_LEAVESUBLV)
1650 o->op_private |= OPpMAYBE_LVSUB;
1660 if (o->op_flags & OPf_KIDS)
1661 mod(cLISTOPo->op_last, type);
1666 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1668 else if (!(o->op_flags & OPf_KIDS))
1670 if (o->op_targ != OP_LIST) {
1671 mod(cBINOPo->op_first, type);
1677 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1682 if (type != OP_LEAVESUBLV)
1684 break; /* mod()ing was handled by ck_return() */
1687 /* [20011101.069] File test operators interpret OPf_REF to mean that
1688 their argument is a filehandle; thus \stat(".") should not set
1690 if (type == OP_REFGEN &&
1691 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1694 if (type != OP_LEAVESUBLV)
1695 o->op_flags |= OPf_MOD;
1697 if (type == OP_AASSIGN || type == OP_SASSIGN)
1698 o->op_flags |= OPf_SPECIAL|OPf_REF;
1699 else if (!type) { /* local() */
1702 o->op_private |= OPpLVAL_INTRO;
1703 o->op_flags &= ~OPf_SPECIAL;
1704 PL_hints |= HINT_BLOCK_SCOPE;
1709 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1710 "Useless localization of %s", OP_DESC(o));
1713 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1714 && type != OP_LEAVESUBLV)
1715 o->op_flags |= OPf_REF;
1720 S_scalar_mod_type(const OP *o, I32 type)
1722 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1726 if (o->op_type == OP_RV2GV)
1750 case OP_RIGHT_SHIFT:
1770 S_is_handle_constructor(const OP *o, I32 numargs)
1772 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1774 switch (o->op_type) {
1782 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1795 S_refkids(pTHX_ OP *o, I32 type)
1797 if (o && o->op_flags & OPf_KIDS) {
1799 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1806 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1811 PERL_ARGS_ASSERT_DOREF;
1813 if (!o || (PL_parser && PL_parser->error_count))
1816 switch (o->op_type) {
1818 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1819 !(o->op_flags & OPf_STACKED)) {
1820 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1821 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1822 assert(cUNOPo->op_first->op_type == OP_NULL);
1823 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1824 o->op_flags |= OPf_SPECIAL;
1825 o->op_private &= ~1;
1830 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1831 doref(kid, type, set_op_ref);
1834 if (type == OP_DEFINED)
1835 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1836 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1839 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1840 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1841 : type == OP_RV2HV ? OPpDEREF_HV
1843 o->op_flags |= OPf_MOD;
1850 o->op_flags |= OPf_REF;
1853 if (type == OP_DEFINED)
1854 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1855 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1861 o->op_flags |= OPf_REF;
1866 if (!(o->op_flags & OPf_KIDS))
1868 doref(cBINOPo->op_first, type, set_op_ref);
1872 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1873 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1874 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1875 : type == OP_RV2HV ? OPpDEREF_HV
1877 o->op_flags |= OPf_MOD;
1887 if (!(o->op_flags & OPf_KIDS))
1889 doref(cLISTOPo->op_last, type, set_op_ref);
1899 S_dup_attrlist(pTHX_ OP *o)
1904 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1906 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1907 * where the first kid is OP_PUSHMARK and the remaining ones
1908 * are OP_CONST. We need to push the OP_CONST values.
1910 if (o->op_type == OP_CONST)
1911 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1913 else if (o->op_type == OP_NULL)
1917 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1919 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1920 if (o->op_type == OP_CONST)
1921 rop = append_elem(OP_LIST, rop,
1922 newSVOP(OP_CONST, o->op_flags,
1923 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1930 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1935 PERL_ARGS_ASSERT_APPLY_ATTRS;
1937 /* fake up C<use attributes $pkg,$rv,@attrs> */
1938 ENTER; /* need to protect against side-effects of 'use' */
1939 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1941 #define ATTRSMODULE "attributes"
1942 #define ATTRSMODULE_PM "attributes.pm"
1945 /* Don't force the C<use> if we don't need it. */
1946 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1947 if (svp && *svp != &PL_sv_undef)
1948 NOOP; /* already in %INC */
1950 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1951 newSVpvs(ATTRSMODULE), NULL);
1954 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1955 newSVpvs(ATTRSMODULE),
1957 prepend_elem(OP_LIST,
1958 newSVOP(OP_CONST, 0, stashsv),
1959 prepend_elem(OP_LIST,
1960 newSVOP(OP_CONST, 0,
1962 dup_attrlist(attrs))));
1968 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1971 OP *pack, *imop, *arg;
1974 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1979 assert(target->op_type == OP_PADSV ||
1980 target->op_type == OP_PADHV ||
1981 target->op_type == OP_PADAV);
1983 /* Ensure that attributes.pm is loaded. */
1984 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1986 /* Need package name for method call. */
1987 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1989 /* Build up the real arg-list. */
1990 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1992 arg = newOP(OP_PADSV, 0);
1993 arg->op_targ = target->op_targ;
1994 arg = prepend_elem(OP_LIST,
1995 newSVOP(OP_CONST, 0, stashsv),
1996 prepend_elem(OP_LIST,
1997 newUNOP(OP_REFGEN, 0,
1998 mod(arg, OP_REFGEN)),
1999 dup_attrlist(attrs)));
2001 /* Fake up a method call to import */
2002 meth = newSVpvs_share("import");
2003 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2004 append_elem(OP_LIST,
2005 prepend_elem(OP_LIST, pack, list(arg)),
2006 newSVOP(OP_METHOD_NAMED, 0, meth)));
2007 imop->op_private |= OPpENTERSUB_NOMOD;
2009 /* Combine the ops. */
2010 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2014 =notfor apidoc apply_attrs_string
2016 Attempts to apply a list of attributes specified by the C<attrstr> and
2017 C<len> arguments to the subroutine identified by the C<cv> argument which
2018 is expected to be associated with the package identified by the C<stashpv>
2019 argument (see L<attributes>). It gets this wrong, though, in that it
2020 does not correctly identify the boundaries of the individual attribute
2021 specifications within C<attrstr>. This is not really intended for the
2022 public API, but has to be listed here for systems such as AIX which
2023 need an explicit export list for symbols. (It's called from XS code
2024 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2025 to respect attribute syntax properly would be welcome.
2031 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2032 const char *attrstr, STRLEN len)
2036 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2039 len = strlen(attrstr);
2043 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2045 const char * const sstr = attrstr;
2046 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2047 attrs = append_elem(OP_LIST, attrs,
2048 newSVOP(OP_CONST, 0,
2049 newSVpvn(sstr, attrstr-sstr)));
2053 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2054 newSVpvs(ATTRSMODULE),
2055 NULL, prepend_elem(OP_LIST,
2056 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2057 prepend_elem(OP_LIST,
2058 newSVOP(OP_CONST, 0,
2059 newRV(MUTABLE_SV(cv))),
2064 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2069 PERL_ARGS_ASSERT_MY_KID;
2071 if (!o || (PL_parser && PL_parser->error_count))
2075 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2076 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2080 if (type == OP_LIST) {
2082 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2083 my_kid(kid, attrs, imopsp);
2084 } else if (type == OP_UNDEF
2090 } else if (type == OP_RV2SV || /* "our" declaration */
2092 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2093 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2094 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2096 PL_parser->in_my == KEY_our
2098 : PL_parser->in_my == KEY_state ? "state" : "my"));
2100 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2101 PL_parser->in_my = FALSE;
2102 PL_parser->in_my_stash = NULL;
2103 apply_attrs(GvSTASH(gv),
2104 (type == OP_RV2SV ? GvSV(gv) :
2105 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2106 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2109 o->op_private |= OPpOUR_INTRO;
2112 else if (type != OP_PADSV &&
2115 type != OP_PUSHMARK)
2117 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2119 PL_parser->in_my == KEY_our
2121 : PL_parser->in_my == KEY_state ? "state" : "my"));
2124 else if (attrs && type != OP_PUSHMARK) {
2127 PL_parser->in_my = FALSE;
2128 PL_parser->in_my_stash = NULL;
2130 /* check for C<my Dog $spot> when deciding package */
2131 stash = PAD_COMPNAME_TYPE(o->op_targ);
2133 stash = PL_curstash;
2134 apply_attrs_my(stash, o, attrs, imopsp);
2136 o->op_flags |= OPf_MOD;
2137 o->op_private |= OPpLVAL_INTRO;
2138 if (PL_parser->in_my == KEY_state)
2139 o->op_private |= OPpPAD_STATE;
2144 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2148 int maybe_scalar = 0;
2150 PERL_ARGS_ASSERT_MY_ATTRS;
2152 /* [perl #17376]: this appears to be premature, and results in code such as
2153 C< our(%x); > executing in list mode rather than void mode */
2155 if (o->op_flags & OPf_PARENS)
2165 o = my_kid(o, attrs, &rops);
2167 if (maybe_scalar && o->op_type == OP_PADSV) {
2168 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2169 o->op_private |= OPpLVAL_INTRO;
2172 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2174 PL_parser->in_my = FALSE;
2175 PL_parser->in_my_stash = NULL;
2180 Perl_sawparens(pTHX_ OP *o)
2182 PERL_UNUSED_CONTEXT;
2184 o->op_flags |= OPf_PARENS;
2189 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2193 const OPCODE ltype = left->op_type;
2194 const OPCODE rtype = right->op_type;
2196 PERL_ARGS_ASSERT_BIND_MATCH;
2198 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2199 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2201 const char * const desc
2202 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2203 ? (int)rtype : OP_MATCH];
2204 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2205 ? "@array" : "%hash");
2206 Perl_warner(aTHX_ packWARN(WARN_MISC),
2207 "Applying %s to %s will act on scalar(%s)",
2208 desc, sample, sample);
2211 if (rtype == OP_CONST &&
2212 cSVOPx(right)->op_private & OPpCONST_BARE &&
2213 cSVOPx(right)->op_private & OPpCONST_STRICT)
2215 no_bareword_allowed(right);
2218 ismatchop = rtype == OP_MATCH ||
2219 rtype == OP_SUBST ||
2221 if (ismatchop && right->op_private & OPpTARGET_MY) {
2223 right->op_private &= ~OPpTARGET_MY;
2225 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2228 right->op_flags |= OPf_STACKED;
2229 if (rtype != OP_MATCH &&
2230 ! (rtype == OP_TRANS &&
2231 right->op_private & OPpTRANS_IDENTICAL))
2232 newleft = mod(left, rtype);
2235 if (right->op_type == OP_TRANS)
2236 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2238 o = prepend_elem(rtype, scalar(newleft), right);
2240 return newUNOP(OP_NOT, 0, scalar(o));
2244 return bind_match(type, left,
2245 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2249 Perl_invert(pTHX_ OP *o)
2253 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2257 Perl_scope(pTHX_ OP *o)
2261 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2262 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2263 o->op_type = OP_LEAVE;
2264 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2266 else if (o->op_type == OP_LINESEQ) {
2268 o->op_type = OP_SCOPE;
2269 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2270 kid = ((LISTOP*)o)->op_first;
2271 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2274 /* The following deals with things like 'do {1 for 1}' */
2275 kid = kid->op_sibling;
2277 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2282 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2288 Perl_block_start(pTHX_ int full)
2291 const int retval = PL_savestack_ix;
2292 pad_block_start(full);
2294 PL_hints &= ~HINT_BLOCK_SCOPE;
2295 SAVECOMPILEWARNINGS();
2296 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2301 Perl_block_end(pTHX_ I32 floor, OP *seq)
2304 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2305 OP* const retval = scalarseq(seq);
2307 CopHINTS_set(&PL_compiling, PL_hints);
2309 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2318 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2319 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2320 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2323 OP * const o = newOP(OP_PADSV, 0);
2324 o->op_targ = offset;
2330 Perl_newPROG(pTHX_ OP *o)
2334 PERL_ARGS_ASSERT_NEWPROG;
2339 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2340 ((PL_in_eval & EVAL_KEEPERR)
2341 ? OPf_SPECIAL : 0), o);
2342 PL_eval_start = linklist(PL_eval_root);
2343 PL_eval_root->op_private |= OPpREFCOUNTED;
2344 OpREFCNT_set(PL_eval_root, 1);
2345 PL_eval_root->op_next = 0;
2346 CALL_PEEP(PL_eval_start);
2349 if (o->op_type == OP_STUB) {
2350 PL_comppad_name = 0;
2352 S_op_destroy(aTHX_ o);
2355 PL_main_root = scope(sawparens(scalarvoid(o)));
2356 PL_curcop = &PL_compiling;
2357 PL_main_start = LINKLIST(PL_main_root);
2358 PL_main_root->op_private |= OPpREFCOUNTED;
2359 OpREFCNT_set(PL_main_root, 1);
2360 PL_main_root->op_next = 0;
2361 CALL_PEEP(PL_main_start);
2364 /* Register with debugger */
2366 CV * const cv = get_cvs("DB::postponed", 0);
2370 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2372 call_sv(MUTABLE_SV(cv), G_DISCARD);
2379 Perl_localize(pTHX_ OP *o, I32 lex)
2383 PERL_ARGS_ASSERT_LOCALIZE;
2385 if (o->op_flags & OPf_PARENS)
2386 /* [perl #17376]: this appears to be premature, and results in code such as
2387 C< our(%x); > executing in list mode rather than void mode */
2394 if ( PL_parser->bufptr > PL_parser->oldbufptr
2395 && PL_parser->bufptr[-1] == ','
2396 && ckWARN(WARN_PARENTHESIS))
2398 char *s = PL_parser->bufptr;
2401 /* some heuristics to detect a potential error */
2402 while (*s && (strchr(", \t\n", *s)))
2406 if (*s && strchr("@$%*", *s) && *++s
2407 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2410 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2412 while (*s && (strchr(", \t\n", *s)))
2418 if (sigil && (*s == ';' || *s == '=')) {
2419 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2420 "Parentheses missing around \"%s\" list",
2422 ? (PL_parser->in_my == KEY_our
2424 : PL_parser->in_my == KEY_state
2434 o = mod(o, OP_NULL); /* a bit kludgey */
2435 PL_parser->in_my = FALSE;
2436 PL_parser->in_my_stash = NULL;
2441 Perl_jmaybe(pTHX_ OP *o)
2443 PERL_ARGS_ASSERT_JMAYBE;
2445 if (o->op_type == OP_LIST) {
2447 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2448 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2454 S_fold_constants(pTHX_ register OP *o)
2457 register OP * VOL curop;
2459 VOL I32 type = o->op_type;
2464 SV * const oldwarnhook = PL_warnhook;
2465 SV * const olddiehook = PL_diehook;
2469 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2471 if (PL_opargs[type] & OA_RETSCALAR)
2473 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2474 o->op_targ = pad_alloc(type, SVs_PADTMP);
2476 /* integerize op, unless it happens to be C<-foo>.
2477 * XXX should pp_i_negate() do magic string negation instead? */
2478 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2479 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2480 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2482 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2485 if (!(PL_opargs[type] & OA_FOLDCONST))
2490 /* XXX might want a ck_negate() for this */
2491 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2502 /* XXX what about the numeric ops? */
2503 if (PL_hints & HINT_LOCALE)
2508 if (PL_parser && PL_parser->error_count)
2509 goto nope; /* Don't try to run w/ errors */
2511 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2512 const OPCODE type = curop->op_type;
2513 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2515 type != OP_SCALAR &&
2517 type != OP_PUSHMARK)
2523 curop = LINKLIST(o);
2524 old_next = o->op_next;
2528 oldscope = PL_scopestack_ix;
2529 create_eval_scope(G_FAKINGEVAL);
2531 /* Verify that we don't need to save it: */
2532 assert(PL_curcop == &PL_compiling);
2533 StructCopy(&PL_compiling, ¬_compiling, COP);
2534 PL_curcop = ¬_compiling;
2535 /* The above ensures that we run with all the correct hints of the
2536 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2537 assert(IN_PERL_RUNTIME);
2538 PL_warnhook = PERL_WARNHOOK_FATAL;
2545 sv = *(PL_stack_sp--);
2546 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2547 pad_swipe(o->op_targ, FALSE);
2548 else if (SvTEMP(sv)) { /* grab mortal temp? */
2549 SvREFCNT_inc_simple_void(sv);
2554 /* Something tried to die. Abandon constant folding. */
2555 /* Pretend the error never happened. */
2557 o->op_next = old_next;
2561 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2562 PL_warnhook = oldwarnhook;
2563 PL_diehook = olddiehook;
2564 /* XXX note that this croak may fail as we've already blown away
2565 * the stack - eg any nested evals */
2566 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2569 PL_warnhook = oldwarnhook;
2570 PL_diehook = olddiehook;
2571 PL_curcop = &PL_compiling;
2573 if (PL_scopestack_ix > oldscope)
2574 delete_eval_scope();
2583 if (type == OP_RV2GV)
2584 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2586 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2587 op_getmad(o,newop,'f');
2595 S_gen_constant_list(pTHX_ register OP *o)
2599 const I32 oldtmps_floor = PL_tmps_floor;
2602 if (PL_parser && PL_parser->error_count)
2603 return o; /* Don't attempt to run with errors */
2605 PL_op = curop = LINKLIST(o);
2611 assert (!(curop->op_flags & OPf_SPECIAL));
2612 assert(curop->op_type == OP_RANGE);
2614 PL_tmps_floor = oldtmps_floor;
2616 o->op_type = OP_RV2AV;
2617 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2618 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2619 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2620 o->op_opt = 0; /* needs to be revisited in peep() */
2621 curop = ((UNOP*)o)->op_first;
2622 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2624 op_getmad(curop,o,'O');
2633 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2636 if (!o || o->op_type != OP_LIST)
2637 o = newLISTOP(OP_LIST, 0, o, NULL);
2639 o->op_flags &= ~OPf_WANT;
2641 if (!(PL_opargs[type] & OA_MARK))
2642 op_null(cLISTOPo->op_first);
2644 o->op_type = (OPCODE)type;
2645 o->op_ppaddr = PL_ppaddr[type];
2646 o->op_flags |= flags;
2648 o = CHECKOP(type, o);
2649 if (o->op_type != (unsigned)type)
2652 return fold_constants(o);
2655 /* List constructors */
2658 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2666 if (first->op_type != (unsigned)type
2667 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2669 return newLISTOP(type, 0, first, last);
2672 if (first->op_flags & OPf_KIDS)
2673 ((LISTOP*)first)->op_last->op_sibling = last;
2675 first->op_flags |= OPf_KIDS;
2676 ((LISTOP*)first)->op_first = last;
2678 ((LISTOP*)first)->op_last = last;
2683 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2691 if (first->op_type != (unsigned)type)
2692 return prepend_elem(type, (OP*)first, (OP*)last);
2694 if (last->op_type != (unsigned)type)
2695 return append_elem(type, (OP*)first, (OP*)last);
2697 first->op_last->op_sibling = last->op_first;
2698 first->op_last = last->op_last;
2699 first->op_flags |= (last->op_flags & OPf_KIDS);
2702 if (last->op_first && first->op_madprop) {
2703 MADPROP *mp = last->op_first->op_madprop;
2705 while (mp->mad_next)
2707 mp->mad_next = first->op_madprop;
2710 last->op_first->op_madprop = first->op_madprop;
2713 first->op_madprop = last->op_madprop;
2714 last->op_madprop = 0;
2717 S_op_destroy(aTHX_ (OP*)last);
2723 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2731 if (last->op_type == (unsigned)type) {
2732 if (type == OP_LIST) { /* already a PUSHMARK there */
2733 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2734 ((LISTOP*)last)->op_first->op_sibling = first;
2735 if (!(first->op_flags & OPf_PARENS))
2736 last->op_flags &= ~OPf_PARENS;
2739 if (!(last->op_flags & OPf_KIDS)) {
2740 ((LISTOP*)last)->op_last = first;
2741 last->op_flags |= OPf_KIDS;
2743 first->op_sibling = ((LISTOP*)last)->op_first;
2744 ((LISTOP*)last)->op_first = first;
2746 last->op_flags |= OPf_KIDS;
2750 return newLISTOP(type, 0, first, last);
2758 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2761 Newxz(tk, 1, TOKEN);
2762 tk->tk_type = (OPCODE)optype;
2763 tk->tk_type = 12345;
2765 tk->tk_mad = madprop;
2770 Perl_token_free(pTHX_ TOKEN* tk)
2772 PERL_ARGS_ASSERT_TOKEN_FREE;
2774 if (tk->tk_type != 12345)
2776 mad_free(tk->tk_mad);
2781 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2786 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2788 if (tk->tk_type != 12345) {
2789 Perl_warner(aTHX_ packWARN(WARN_MISC),
2790 "Invalid TOKEN object ignored");
2797 /* faked up qw list? */
2799 tm->mad_type == MAD_SV &&
2800 SvPVX((SV *)tm->mad_val)[0] == 'q')
2807 /* pretend constant fold didn't happen? */
2808 if (mp->mad_key == 'f' &&
2809 (o->op_type == OP_CONST ||
2810 o->op_type == OP_GV) )
2812 token_getmad(tk,(OP*)mp->mad_val,slot);
2826 if (mp->mad_key == 'X')
2827 mp->mad_key = slot; /* just change the first one */
2837 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2846 /* pretend constant fold didn't happen? */
2847 if (mp->mad_key == 'f' &&
2848 (o->op_type == OP_CONST ||
2849 o->op_type == OP_GV) )
2851 op_getmad(from,(OP*)mp->mad_val,slot);
2858 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2861 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2867 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2876 /* pretend constant fold didn't happen? */
2877 if (mp->mad_key == 'f' &&
2878 (o->op_type == OP_CONST ||
2879 o->op_type == OP_GV) )
2881 op_getmad(from,(OP*)mp->mad_val,slot);
2888 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2891 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2895 PerlIO_printf(PerlIO_stderr(),
2896 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2902 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2920 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2924 addmad(tm, &(o->op_madprop), slot);
2928 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2949 Perl_newMADsv(pTHX_ char key, SV* sv)
2951 PERL_ARGS_ASSERT_NEWMADSV;
2953 return newMADPROP(key, MAD_SV, sv, 0);
2957 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2960 Newxz(mp, 1, MADPROP);
2963 mp->mad_vlen = vlen;
2964 mp->mad_type = type;
2966 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2971 Perl_mad_free(pTHX_ MADPROP* mp)
2973 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2977 mad_free(mp->mad_next);
2978 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2979 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2980 switch (mp->mad_type) {
2984 Safefree((char*)mp->mad_val);
2987 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2988 op_free((OP*)mp->mad_val);
2991 sv_free(MUTABLE_SV(mp->mad_val));
2994 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3003 Perl_newNULLLIST(pTHX)
3005 return newOP(OP_STUB, 0);
3009 S_force_list(pTHX_ OP *o)
3011 if (!o || o->op_type != OP_LIST)
3012 o = newLISTOP(OP_LIST, 0, o, NULL);
3018 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3023 NewOp(1101, listop, 1, LISTOP);
3025 listop->op_type = (OPCODE)type;
3026 listop->op_ppaddr = PL_ppaddr[type];
3029 listop->op_flags = (U8)flags;
3033 else if (!first && last)
3036 first->op_sibling = last;
3037 listop->op_first = first;
3038 listop->op_last = last;
3039 if (type == OP_LIST) {
3040 OP* const pushop = newOP(OP_PUSHMARK, 0);
3041 pushop->op_sibling = first;
3042 listop->op_first = pushop;
3043 listop->op_flags |= OPf_KIDS;
3045 listop->op_last = pushop;
3048 return CHECKOP(type, listop);
3052 Perl_newOP(pTHX_ I32 type, I32 flags)
3056 NewOp(1101, o, 1, OP);
3057 o->op_type = (OPCODE)type;
3058 o->op_ppaddr = PL_ppaddr[type];
3059 o->op_flags = (U8)flags;
3061 o->op_latefreed = 0;
3065 o->op_private = (U8)(0 | (flags >> 8));
3066 if (PL_opargs[type] & OA_RETSCALAR)
3068 if (PL_opargs[type] & OA_TARGET)
3069 o->op_targ = pad_alloc(type, SVs_PADTMP);
3070 return CHECKOP(type, o);
3074 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3080 first = newOP(OP_STUB, 0);
3081 if (PL_opargs[type] & OA_MARK)
3082 first = force_list(first);
3084 NewOp(1101, unop, 1, UNOP);
3085 unop->op_type = (OPCODE)type;
3086 unop->op_ppaddr = PL_ppaddr[type];
3087 unop->op_first = first;
3088 unop->op_flags = (U8)(flags | OPf_KIDS);
3089 unop->op_private = (U8)(1 | (flags >> 8));
3090 unop = (UNOP*) CHECKOP(type, unop);
3094 return fold_constants((OP *) unop);
3098 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3102 NewOp(1101, binop, 1, BINOP);
3105 first = newOP(OP_NULL, 0);
3107 binop->op_type = (OPCODE)type;
3108 binop->op_ppaddr = PL_ppaddr[type];
3109 binop->op_first = first;
3110 binop->op_flags = (U8)(flags | OPf_KIDS);
3113 binop->op_private = (U8)(1 | (flags >> 8));
3116 binop->op_private = (U8)(2 | (flags >> 8));
3117 first->op_sibling = last;
3120 binop = (BINOP*)CHECKOP(type, binop);
3121 if (binop->op_next || binop->op_type != (OPCODE)type)
3124 binop->op_last = binop->op_first->op_sibling;
3126 return fold_constants((OP *)binop);
3129 static int uvcompare(const void *a, const void *b)
3130 __attribute__nonnull__(1)
3131 __attribute__nonnull__(2)
3132 __attribute__pure__;
3133 static int uvcompare(const void *a, const void *b)
3135 if (*((const UV *)a) < (*(const UV *)b))
3137 if (*((const UV *)a) > (*(const UV *)b))
3139 if (*((const UV *)a+1) < (*(const UV *)b+1))
3141 if (*((const UV *)a+1) > (*(const UV *)b+1))
3147 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3150 SV * const tstr = ((SVOP*)expr)->op_sv;
3153 (repl->op_type == OP_NULL)
3154 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3156 ((SVOP*)repl)->op_sv;
3159 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3160 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3164 register short *tbl;
3166 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3167 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3168 I32 del = o->op_private & OPpTRANS_DELETE;
3171 PERL_ARGS_ASSERT_PMTRANS;
3173 PL_hints |= HINT_BLOCK_SCOPE;
3176 o->op_private |= OPpTRANS_FROM_UTF;
3179 o->op_private |= OPpTRANS_TO_UTF;
3181 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3182 SV* const listsv = newSVpvs("# comment\n");
3184 const U8* tend = t + tlen;
3185 const U8* rend = r + rlen;
3199 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3200 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3203 const U32 flags = UTF8_ALLOW_DEFAULT;
3207 t = tsave = bytes_to_utf8(t, &len);
3210 if (!to_utf && rlen) {
3212 r = rsave = bytes_to_utf8(r, &len);
3216 /* There are several snags with this code on EBCDIC:
3217 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3218 2. scan_const() in toke.c has encoded chars in native encoding which makes
3219 ranges at least in EBCDIC 0..255 range the bottom odd.
3223 U8 tmpbuf[UTF8_MAXBYTES+1];
3226 Newx(cp, 2*tlen, UV);
3228 transv = newSVpvs("");
3230 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3232 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3234 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3238 cp[2*i+1] = cp[2*i];
3242 qsort(cp, i, 2*sizeof(UV), uvcompare);
3243 for (j = 0; j < i; j++) {
3245 diff = val - nextmin;
3247 t = uvuni_to_utf8(tmpbuf,nextmin);
3248 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3250 U8 range_mark = UTF_TO_NATIVE(0xff);
3251 t = uvuni_to_utf8(tmpbuf, val - 1);
3252 sv_catpvn(transv, (char *)&range_mark, 1);
3253 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3260 t = uvuni_to_utf8(tmpbuf,nextmin);
3261 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3263 U8 range_mark = UTF_TO_NATIVE(0xff);
3264 sv_catpvn(transv, (char *)&range_mark, 1);
3266 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3267 UNICODE_ALLOW_SUPER);
3268 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3269 t = (const U8*)SvPVX_const(transv);
3270 tlen = SvCUR(transv);
3274 else if (!rlen && !del) {
3275 r = t; rlen = tlen; rend = tend;
3278 if ((!rlen && !del) || t == r ||
3279 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3281 o->op_private |= OPpTRANS_IDENTICAL;
3285 while (t < tend || tfirst <= tlast) {
3286 /* see if we need more "t" chars */
3287 if (tfirst > tlast) {
3288 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3290 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3292 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3299 /* now see if we need more "r" chars */
3300 if (rfirst > rlast) {
3302 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3304 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3306 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3315 rfirst = rlast = 0xffffffff;
3319 /* now see which range will peter our first, if either. */
3320 tdiff = tlast - tfirst;
3321 rdiff = rlast - rfirst;
3328 if (rfirst == 0xffffffff) {
3329 diff = tdiff; /* oops, pretend rdiff is infinite */
3331 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3332 (long)tfirst, (long)tlast);
3334 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3338 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3339 (long)tfirst, (long)(tfirst + diff),
3342 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3343 (long)tfirst, (long)rfirst);
3345 if (rfirst + diff > max)
3346 max = rfirst + diff;
3348 grows = (tfirst < rfirst &&
3349 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3361 else if (max > 0xff)
3366 PerlMemShared_free(cPVOPo->op_pv);
3367 cPVOPo->op_pv = NULL;
3369 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3371 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3372 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3373 PAD_SETSV(cPADOPo->op_padix, swash);
3375 SvREADONLY_on(swash);
3377 cSVOPo->op_sv = swash;
3379 SvREFCNT_dec(listsv);
3380 SvREFCNT_dec(transv);
3382 if (!del && havefinal && rlen)
3383 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3384 newSVuv((UV)final), 0);
3387 o->op_private |= OPpTRANS_GROWS;
3393 op_getmad(expr,o,'e');
3394 op_getmad(repl,o,'r');
3402 tbl = (short*)cPVOPo->op_pv;
3404 Zero(tbl, 256, short);
3405 for (i = 0; i < (I32)tlen; i++)
3407 for (i = 0, j = 0; i < 256; i++) {
3409 if (j >= (I32)rlen) {
3418 if (i < 128 && r[j] >= 128)
3428 o->op_private |= OPpTRANS_IDENTICAL;
3430 else if (j >= (I32)rlen)
3435 PerlMemShared_realloc(tbl,
3436 (0x101+rlen-j) * sizeof(short));
3437 cPVOPo->op_pv = (char*)tbl;
3439 tbl[0x100] = (short)(rlen - j);
3440 for (i=0; i < (I32)rlen - j; i++)
3441 tbl[0x101+i] = r[j+i];
3445 if (!rlen && !del) {
3448 o->op_private |= OPpTRANS_IDENTICAL;
3450 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3451 o->op_private |= OPpTRANS_IDENTICAL;
3453 for (i = 0; i < 256; i++)
3455 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3456 if (j >= (I32)rlen) {
3458 if (tbl[t[i]] == -1)
3464 if (tbl[t[i]] == -1) {
3465 if (t[i] < 128 && r[j] >= 128)
3472 if(del && rlen == tlen) {
3473 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3474 } else if(rlen > tlen) {
3475 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3479 o->op_private |= OPpTRANS_GROWS;
3481 op_getmad(expr,o,'e');
3482 op_getmad(repl,o,'r');
3492 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3497 NewOp(1101, pmop, 1, PMOP);
3498 pmop->op_type = (OPCODE)type;
3499 pmop->op_ppaddr = PL_ppaddr[type];
3500 pmop->op_flags = (U8)flags;
3501 pmop->op_private = (U8)(0 | (flags >> 8));
3503 if (PL_hints & HINT_RE_TAINT)
3504 pmop->op_pmflags |= PMf_RETAINT;
3505 if (PL_hints & HINT_LOCALE)
3506 pmop->op_pmflags |= PMf_LOCALE;
3510 assert(SvPOK(PL_regex_pad[0]));
3511 if (SvCUR(PL_regex_pad[0])) {
3512 /* Pop off the "packed" IV from the end. */
3513 SV *const repointer_list = PL_regex_pad[0];
3514 const char *p = SvEND(repointer_list) - sizeof(IV);
3515 const IV offset = *((IV*)p);
3517 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3519 SvEND_set(repointer_list, p);
3521 pmop->op_pmoffset = offset;
3522 /* This slot should be free, so assert this: */
3523 assert(PL_regex_pad[offset] == &PL_sv_undef);
3525 SV * const repointer = &PL_sv_undef;
3526 av_push(PL_regex_padav, repointer);
3527 pmop->op_pmoffset = av_len(PL_regex_padav);
3528 PL_regex_pad = AvARRAY(PL_regex_padav);
3532 return CHECKOP(type, pmop);
3535 /* Given some sort of match op o, and an expression expr containing a
3536 * pattern, either compile expr into a regex and attach it to o (if it's
3537 * constant), or convert expr into a runtime regcomp op sequence (if it's
3540 * isreg indicates that the pattern is part of a regex construct, eg
3541 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3542 * split "pattern", which aren't. In the former case, expr will be a list
3543 * if the pattern contains more than one term (eg /a$b/) or if it contains
3544 * a replacement, ie s/// or tr///.
3548 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3553 I32 repl_has_vars = 0;
3557 PERL_ARGS_ASSERT_PMRUNTIME;
3559 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3560 /* last element in list is the replacement; pop it */
3562 repl = cLISTOPx(expr)->op_last;
3563 kid = cLISTOPx(expr)->op_first;
3564 while (kid->op_sibling != repl)
3565 kid = kid->op_sibling;
3566 kid->op_sibling = NULL;
3567 cLISTOPx(expr)->op_last = kid;
3570 if (isreg && expr->op_type == OP_LIST &&
3571 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3573 /* convert single element list to element */
3574 OP* const oe = expr;
3575 expr = cLISTOPx(oe)->op_first->op_sibling;
3576 cLISTOPx(oe)->op_first->op_sibling = NULL;
3577 cLISTOPx(oe)->op_last = NULL;
3581 if (o->op_type == OP_TRANS) {
3582 return pmtrans(o, expr, repl);
3585 reglist = isreg && expr->op_type == OP_LIST;
3589 PL_hints |= HINT_BLOCK_SCOPE;
3592 if (expr->op_type == OP_CONST) {
3593 SV *pat = ((SVOP*)expr)->op_sv;
3594 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3596 if (o->op_flags & OPf_SPECIAL)
3597 pm_flags |= RXf_SPLIT;
3600 assert (SvUTF8(pat));
3601 } else if (SvUTF8(pat)) {
3602 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3603 trapped in use 'bytes'? */
3604 /* Make a copy of the octet sequence, but without the flag on, as
3605 the compiler now honours the SvUTF8 flag on pat. */
3607 const char *const p = SvPV(pat, len);
3608 pat = newSVpvn_flags(p, len, SVs_TEMP);
3611 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3614 op_getmad(expr,(OP*)pm,'e');
3620 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3621 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3623 : OP_REGCMAYBE),0,expr);
3625 NewOp(1101, rcop, 1, LOGOP);
3626 rcop->op_type = OP_REGCOMP;
3627 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3628 rcop->op_first = scalar(expr);
3629 rcop->op_flags |= OPf_KIDS
3630 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3631 | (reglist ? OPf_STACKED : 0);
3632 rcop->op_private = 1;
3635 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3637 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3640 /* establish postfix order */
3641 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3643 rcop->op_next = expr;
3644 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3647 rcop->op_next = LINKLIST(expr);
3648 expr->op_next = (OP*)rcop;
3651 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3656 if (pm->op_pmflags & PMf_EVAL) {
3658 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3659 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3661 else if (repl->op_type == OP_CONST)
3665 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3666 if (curop->op_type == OP_SCOPE
3667 || curop->op_type == OP_LEAVE
3668 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3669 if (curop->op_type == OP_GV) {
3670 GV * const gv = cGVOPx_gv(curop);
3672 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3675 else if (curop->op_type == OP_RV2CV)
3677 else if (curop->op_type == OP_RV2SV ||
3678 curop->op_type == OP_RV2AV ||
3679 curop->op_type == OP_RV2HV ||
3680 curop->op_type == OP_RV2GV) {
3681 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3684 else if (curop->op_type == OP_PADSV ||
3685 curop->op_type == OP_PADAV ||
3686 curop->op_type == OP_PADHV ||
3687 curop->op_type == OP_PADANY)
3691 else if (curop->op_type == OP_PUSHRE)
3692 NOOP; /* Okay here, dangerous in newASSIGNOP */
3702 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3704 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3705 prepend_elem(o->op_type, scalar(repl), o);
3708 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3709 pm->op_pmflags |= PMf_MAYBE_CONST;
3711 NewOp(1101, rcop, 1, LOGOP);
3712 rcop->op_type = OP_SUBSTCONT;
3713 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3714 rcop->op_first = scalar(repl);
3715 rcop->op_flags |= OPf_KIDS;
3716 rcop->op_private = 1;
3719 /* establish postfix order */
3720 rcop->op_next = LINKLIST(repl);
3721 repl->op_next = (OP*)rcop;
3723 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3724 assert(!(pm->op_pmflags & PMf_ONCE));
3725 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3734 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3739 PERL_ARGS_ASSERT_NEWSVOP;
3741 NewOp(1101, svop, 1, SVOP);
3742 svop->op_type = (OPCODE)type;
3743 svop->op_ppaddr = PL_ppaddr[type];
3745 svop->op_next = (OP*)svop;
3746 svop->op_flags = (U8)flags;
3747 if (PL_opargs[type] & OA_RETSCALAR)
3749 if (PL_opargs[type] & OA_TARGET)
3750 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3751 return CHECKOP(type, svop);
3756 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3761 PERL_ARGS_ASSERT_NEWPADOP;
3763 NewOp(1101, padop, 1, PADOP);
3764 padop->op_type = (OPCODE)type;
3765 padop->op_ppaddr = PL_ppaddr[type];
3766 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3767 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3768 PAD_SETSV(padop->op_padix, sv);
3771 padop->op_next = (OP*)padop;
3772 padop->op_flags = (U8)flags;
3773 if (PL_opargs[type] & OA_RETSCALAR)
3775 if (PL_opargs[type] & OA_TARGET)
3776 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3777 return CHECKOP(type, padop);
3782 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3786 PERL_ARGS_ASSERT_NEWGVOP;
3790 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3792 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3797 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3801 NewOp(1101, pvop, 1, PVOP);
3802 pvop->op_type = (OPCODE)type;
3803 pvop->op_ppaddr = PL_ppaddr[type];
3805 pvop->op_next = (OP*)pvop;
3806 pvop->op_flags = (U8)flags;
3807 if (PL_opargs[type] & OA_RETSCALAR)
3809 if (PL_opargs[type] & OA_TARGET)
3810 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3811 return CHECKOP(type, pvop);
3819 Perl_package(pTHX_ OP *o)
3822 SV *const sv = cSVOPo->op_sv;
3827 PERL_ARGS_ASSERT_PACKAGE;
3829 save_hptr(&PL_curstash);
3830 save_item(PL_curstname);
3832 PL_curstash = gv_stashsv(sv, GV_ADD);
3834 sv_setsv(PL_curstname, sv);
3836 PL_hints |= HINT_BLOCK_SCOPE;
3837 PL_parser->copline = NOLINE;
3838 PL_parser->expect = XSTATE;
3843 if (!PL_madskills) {
3848 pegop = newOP(OP_NULL,0);
3849 op_getmad(o,pegop,'P');
3855 Perl_package_version( pTHX_ OP *v )
3858 U32 savehints = PL_hints;
3859 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3860 PL_hints &= ~HINT_STRICT_VARS;
3861 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3862 PL_hints = savehints;
3871 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3878 OP *pegop = newOP(OP_NULL,0);
3881 PERL_ARGS_ASSERT_UTILIZE;
3883 if (idop->op_type != OP_CONST)
3884 Perl_croak(aTHX_ "Module name must be constant");
3887 op_getmad(idop,pegop,'U');
3892 SV * const vesv = ((SVOP*)version)->op_sv;
3895 op_getmad(version,pegop,'V');
3896 if (!arg && !SvNIOKp(vesv)) {
3903 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3904 Perl_croak(aTHX_ "Version number must be a constant number");
3906 /* Make copy of idop so we don't free it twice */
3907 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3909 /* Fake up a method call to VERSION */
3910 meth = newSVpvs_share("VERSION");
3911 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3912 append_elem(OP_LIST,
3913 prepend_elem(OP_LIST, pack, list(version)),
3914 newSVOP(OP_METHOD_NAMED, 0, meth)));
3918 /* Fake up an import/unimport */
3919 if (arg && arg->op_type == OP_STUB) {
3921 op_getmad(arg,pegop,'S');
3922 imop = arg; /* no import on explicit () */
3924 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3925 imop = NULL; /* use 5.0; */
3927 idop->op_private |= OPpCONST_NOVER;
3933 op_getmad(arg,pegop,'A');
3935 /* Make copy of idop so we don't free it twice */
3936 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3938 /* Fake up a method call to import/unimport */
3940 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3941 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3942 append_elem(OP_LIST,
3943 prepend_elem(OP_LIST, pack, list(arg)),
3944 newSVOP(OP_METHOD_NAMED, 0, meth)));
3947 /* Fake up the BEGIN {}, which does its thing immediately. */
3949 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3952 append_elem(OP_LINESEQ,
3953 append_elem(OP_LINESEQ,
3954 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3955 newSTATEOP(0, NULL, veop)),
3956 newSTATEOP(0, NULL, imop) ));
3958 /* The "did you use incorrect case?" warning used to be here.
3959 * The problem is that on case-insensitive filesystems one
3960 * might get false positives for "use" (and "require"):
3961 * "use Strict" or "require CARP" will work. This causes
3962 * portability problems for the script: in case-strict
3963 * filesystems the script will stop working.
3965 * The "incorrect case" warning checked whether "use Foo"
3966 * imported "Foo" to your namespace, but that is wrong, too:
3967 * there is no requirement nor promise in the language that
3968 * a Foo.pm should or would contain anything in package "Foo".
3970 * There is very little Configure-wise that can be done, either:
3971 * the case-sensitivity of the build filesystem of Perl does not
3972 * help in guessing the case-sensitivity of the runtime environment.
3975 PL_hints |= HINT_BLOCK_SCOPE;
3976 PL_parser->copline = NOLINE;
3977 PL_parser->expect = XSTATE;
3978 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3981 if (!PL_madskills) {
3982 /* FIXME - don't allocate pegop if !PL_madskills */
3991 =head1 Embedding Functions
3993 =for apidoc load_module
3995 Loads the module whose name is pointed to by the string part of name.
3996 Note that the actual module name, not its filename, should be given.
3997 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3998 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3999 (or 0 for no flags). ver, if specified, provides version semantics
4000 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4001 arguments can be used to specify arguments to the module's import()
4002 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4003 terminated with a final NULL pointer. Note that this list can only
4004 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4005 Otherwise at least a single NULL pointer to designate the default
4006 import list is required.
4011 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4015 PERL_ARGS_ASSERT_LOAD_MODULE;
4017 va_start(args, ver);
4018 vload_module(flags, name, ver, &args);
4022 #ifdef PERL_IMPLICIT_CONTEXT
4024 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4028 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4029 va_start(args, ver);
4030 vload_module(flags, name, ver, &args);
4036 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4040 OP * const modname = newSVOP(OP_CONST, 0, name);
4042 PERL_ARGS_ASSERT_VLOAD_MODULE;
4044 modname->op_private |= OPpCONST_BARE;
4046 veop = newSVOP(OP_CONST, 0, ver);
4050 if (flags & PERL_LOADMOD_NOIMPORT) {
4051 imop = sawparens(newNULLLIST());
4053 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4054 imop = va_arg(*args, OP*);
4059 sv = va_arg(*args, SV*);
4061 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4062 sv = va_arg(*args, SV*);
4066 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4067 * that it has a PL_parser to play with while doing that, and also
4068 * that it doesn't mess with any existing parser, by creating a tmp
4069 * new parser with lex_start(). This won't actually be used for much,
4070 * since pp_require() will create another parser for the real work. */
4073 SAVEVPTR(PL_curcop);
4074 lex_start(NULL, NULL, FALSE);
4075 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4076 veop, modname, imop);
4081 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4087 PERL_ARGS_ASSERT_DOFILE;
4089 if (!force_builtin) {
4090 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4091 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4092 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4093 gv = gvp ? *gvp : NULL;
4097 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4098 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4099 append_elem(OP_LIST, term,
4100 scalar(newUNOP(OP_RV2CV, 0,
4101 newGVOP(OP_GV, 0, gv))))));
4104 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4110 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4112 return newBINOP(OP_LSLICE, flags,
4113 list(force_list(subscript)),
4114 list(force_list(listval)) );
4118 S_is_list_assignment(pTHX_ register const OP *o)
4126 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4127 o = cUNOPo->op_first;
4129 flags = o->op_flags;
4131 if (type == OP_COND_EXPR) {
4132 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4133 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4138 yyerror("Assignment to both a list and a scalar");
4142 if (type == OP_LIST &&
4143 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4144 o->op_private & OPpLVAL_INTRO)
4147 if (type == OP_LIST || flags & OPf_PARENS ||
4148 type == OP_RV2AV || type == OP_RV2HV ||
4149 type == OP_ASLICE || type == OP_HSLICE)
4152 if (type == OP_PADAV || type == OP_PADHV)
4155 if (type == OP_RV2SV)
4162 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4168 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4169 return newLOGOP(optype, 0,
4170 mod(scalar(left), optype),
4171 newUNOP(OP_SASSIGN, 0, scalar(right)));
4174 return newBINOP(optype, OPf_STACKED,
4175 mod(scalar(left), optype), scalar(right));
4179 if (is_list_assignment(left)) {
4180 static const char no_list_state[] = "Initialization of state variables"
4181 " in list context currently forbidden";
4183 bool maybe_common_vars = TRUE;
4186 /* Grandfathering $[ assignment here. Bletch.*/
4187 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4188 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4189 left = mod(left, OP_AASSIGN);
4192 else if (left->op_type == OP_CONST) {
4194 /* Result of assignment is always 1 (or we'd be dead already) */
4195 return newSVOP(OP_CONST, 0, newSViv(1));
4197 curop = list(force_list(left));
4198 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4199 o->op_private = (U8)(0 | (flags >> 8));
4201 if ((left->op_type == OP_LIST
4202 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4204 OP* lop = ((LISTOP*)left)->op_first;
4205 maybe_common_vars = FALSE;
4207 if (lop->op_type == OP_PADSV ||
4208 lop->op_type == OP_PADAV ||
4209 lop->op_type == OP_PADHV ||
4210 lop->op_type == OP_PADANY) {
4211 if (!(lop->op_private & OPpLVAL_INTRO))
4212 maybe_common_vars = TRUE;
4214 if (lop->op_private & OPpPAD_STATE) {
4215 if (left->op_private & OPpLVAL_INTRO) {
4216 /* Each variable in state($a, $b, $c) = ... */
4219 /* Each state variable in
4220 (state $a, my $b, our $c, $d, undef) = ... */
4222 yyerror(no_list_state);
4224 /* Each my variable in
4225 (state $a, my $b, our $c, $d, undef) = ... */
4227 } else if (lop->op_type == OP_UNDEF ||
4228 lop->op_type == OP_PUSHMARK) {
4229 /* undef may be interesting in
4230 (state $a, undef, state $c) */
4232 /* Other ops in the list. */
4233 maybe_common_vars = TRUE;
4235 lop = lop->op_sibling;
4238 else if ((left->op_private & OPpLVAL_INTRO)
4239 && ( left->op_type == OP_PADSV
4240 || left->op_type == OP_PADAV
4241 || left->op_type == OP_PADHV
4242 || left->op_type == OP_PADANY))
4244 maybe_common_vars = FALSE;
4245 if (left->op_private & OPpPAD_STATE) {
4246 /* All single variable list context state assignments, hence
4256 yyerror(no_list_state);
4260 /* PL_generation sorcery:
4261 * an assignment like ($a,$b) = ($c,$d) is easier than
4262 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4263 * To detect whether there are common vars, the global var
4264 * PL_generation is incremented for each assign op we compile.
4265 * Then, while compiling the assign op, we run through all the
4266 * variables on both sides of the assignment, setting a spare slot
4267 * in each of them to PL_generation. If any of them already have
4268 * that value, we know we've got commonality. We could use a
4269 * single bit marker, but then we'd have to make 2 passes, first
4270 * to clear the flag, then to test and set it. To find somewhere
4271 * to store these values, evil chicanery is done with SvUVX().
4274 if (maybe_common_vars) {
4277 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4278 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4279 if (curop->op_type == OP_GV) {
4280 GV *gv = cGVOPx_gv(curop);
4282 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4284 GvASSIGN_GENERATION_set(gv, PL_generation);
4286 else if (curop->op_type == OP_PADSV ||
4287 curop->op_type == OP_PADAV ||
4288 curop->op_type == OP_PADHV ||
4289 curop->op_type == OP_PADANY)
4291 if (PAD_COMPNAME_GEN(curop->op_targ)
4292 == (STRLEN)PL_generation)
4294 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4297 else if (curop->op_type == OP_RV2CV)
4299 else if (curop->op_type == OP_RV2SV ||
4300 curop->op_type == OP_RV2AV ||
4301 curop->op_type == OP_RV2HV ||
4302 curop->op_type == OP_RV2GV) {
4303 if (lastop->op_type != OP_GV) /* funny deref? */
4306 else if (curop->op_type == OP_PUSHRE) {
4308 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4309 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4311 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4313 GvASSIGN_GENERATION_set(gv, PL_generation);
4317 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4320 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4322 GvASSIGN_GENERATION_set(gv, PL_generation);
4332 o->op_private |= OPpASSIGN_COMMON;
4335 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4336 OP* tmpop = ((LISTOP*)right)->op_first;
4337 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4338 PMOP * const pm = (PMOP*)tmpop;
4339 if (left->op_type == OP_RV2AV &&
4340 !(left->op_private & OPpLVAL_INTRO) &&
4341 !(o->op_private & OPpASSIGN_COMMON) )
4343 tmpop = ((UNOP*)left)->op_first;
4344 if (tmpop->op_type == OP_GV
4346 && !pm->op_pmreplrootu.op_pmtargetoff
4348 && !pm->op_pmreplrootu.op_pmtargetgv
4352 pm->op_pmreplrootu.op_pmtargetoff
4353 = cPADOPx(tmpop)->op_padix;
4354 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4356 pm->op_pmreplrootu.op_pmtargetgv
4357 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4358 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4360 pm->op_pmflags |= PMf_ONCE;
4361 tmpop = cUNOPo->op_first; /* to list (nulled) */
4362 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4363 tmpop->op_sibling = NULL; /* don't free split */
4364 right->op_next = tmpop->op_next; /* fix starting loc */
4365 op_free(o); /* blow off assign */
4366 right->op_flags &= ~OPf_WANT;
4367 /* "I don't know and I don't care." */
4372 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4373 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4375 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4376 if (SvIOK(sv) && SvIVX(sv) == 0)
4377 sv_setiv(sv, PL_modcount+1);
4385 right = newOP(OP_UNDEF, 0);
4386 if (right->op_type == OP_READLINE) {
4387 right->op_flags |= OPf_STACKED;
4388 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4391 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4392 o = newBINOP(OP_SASSIGN, flags,
4393 scalar(right), mod(scalar(left), OP_SASSIGN) );
4397 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4398 deprecate("assignment to $[");
4400 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4401 o->op_private |= OPpCONST_ARYBASE;
4409 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4412 const U32 seq = intro_my();
4415 NewOp(1101, cop, 1, COP);
4416 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4417 cop->op_type = OP_DBSTATE;
4418 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4421 cop->op_type = OP_NEXTSTATE;
4422 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4424 cop->op_flags = (U8)flags;
4425 CopHINTS_set(cop, PL_hints);
4427 cop->op_private |= NATIVE_HINTS;
4429 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4430 cop->op_next = (OP*)cop;
4433 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4434 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4436 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4437 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4438 if (cop->cop_hints_hash) {
4440 cop->cop_hints_hash->refcounted_he_refcnt++;
4441 HINTS_REFCNT_UNLOCK;
4445 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4447 PL_hints |= HINT_BLOCK_SCOPE;
4448 /* It seems that we need to defer freeing this pointer, as other parts
4449 of the grammar end up wanting to copy it after this op has been
4454 if (PL_parser && PL_parser->copline == NOLINE)
4455 CopLINE_set(cop, CopLINE(PL_curcop));
4457 CopLINE_set(cop, PL_parser->copline);
4459 PL_parser->copline = NOLINE;
4462 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4464 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4466 CopSTASH_set(cop, PL_curstash);
4468 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4469 /* this line can have a breakpoint - store the cop in IV */
4470 AV *av = CopFILEAVx(PL_curcop);
4472 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4473 if (svp && *svp != &PL_sv_undef ) {
4474 (void)SvIOK_on(*svp);
4475 SvIV_set(*svp, PTR2IV(cop));
4480 if (flags & OPf_SPECIAL)
4482 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4487 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4491 PERL_ARGS_ASSERT_NEWLOGOP;
4493 return new_logop(type, flags, &first, &other);
4497 S_search_const(pTHX_ OP *o)
4499 PERL_ARGS_ASSERT_SEARCH_CONST;
4501 switch (o->op_type) {
4505 if (o->op_flags & OPf_KIDS)
4506 return search_const(cUNOPo->op_first);
4513 if (!(o->op_flags & OPf_KIDS))
4515 kid = cLISTOPo->op_first;
4517 switch (kid->op_type) {
4521 kid = kid->op_sibling;
4524 if (kid != cLISTOPo->op_last)
4530 kid = cLISTOPo->op_last;
4532 return search_const(kid);
4540 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4548 int prepend_not = 0;
4550 PERL_ARGS_ASSERT_NEW_LOGOP;
4555 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4556 return newBINOP(type, flags, scalar(first), scalar(other));
4558 scalarboolean(first);
4559 /* optimize AND and OR ops that have NOTs as children */
4560 if (first->op_type == OP_NOT
4561 && (first->op_flags & OPf_KIDS)
4562 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4563 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4565 if (type == OP_AND || type == OP_OR) {
4571 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4573 prepend_not = 1; /* prepend a NOT op later */
4577 /* search for a constant op that could let us fold the test */
4578 if ((cstop = search_const(first))) {
4579 if (cstop->op_private & OPpCONST_STRICT)
4580 no_bareword_allowed(cstop);
4581 else if ((cstop->op_private & OPpCONST_BARE))
4582 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4583 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4584 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4585 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4587 if (other->op_type == OP_CONST)
4588 other->op_private |= OPpCONST_SHORTCIRCUIT;
4590 OP *newop = newUNOP(OP_NULL, 0, other);
4591 op_getmad(first, newop, '1');
4592 newop->op_targ = type; /* set "was" field */
4596 if (other->op_type == OP_LEAVE)
4597 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4601 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4602 const OP *o2 = other;
4603 if ( ! (o2->op_type == OP_LIST
4604 && (( o2 = cUNOPx(o2)->op_first))
4605 && o2->op_type == OP_PUSHMARK
4606 && (( o2 = o2->op_sibling)) )
4609 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4610 || o2->op_type == OP_PADHV)
4611 && o2->op_private & OPpLVAL_INTRO
4612 && !(o2->op_private & OPpPAD_STATE))
4614 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4615 "Deprecated use of my() in false conditional");
4619 if (first->op_type == OP_CONST)
4620 first->op_private |= OPpCONST_SHORTCIRCUIT;
4622 first = newUNOP(OP_NULL, 0, first);
4623 op_getmad(other, first, '2');
4624 first->op_targ = type; /* set "was" field */
4631 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4632 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4634 const OP * const k1 = ((UNOP*)first)->op_first;
4635 const OP * const k2 = k1->op_sibling;
4637 switch (first->op_type)
4640 if (k2 && k2->op_type == OP_READLINE
4641 && (k2->op_flags & OPf_STACKED)
4642 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4644 warnop = k2->op_type;
4649 if (k1->op_type == OP_READDIR
4650 || k1->op_type == OP_GLOB
4651 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4652 || k1->op_type == OP_EACH)
4654 warnop = ((k1->op_type == OP_NULL)
4655 ? (OPCODE)k1->op_targ : k1->op_type);
4660 const line_t oldline = CopLINE(PL_curcop);
4661 CopLINE_set(PL_curcop, PL_parser->copline);
4662 Perl_warner(aTHX_ packWARN(WARN_MISC),
4663 "Value of %s%s can be \"0\"; test with defined()",
4665 ((warnop == OP_READLINE || warnop == OP_GLOB)
4666 ? " construct" : "() operator"));
4667 CopLINE_set(PL_curcop, oldline);
4674 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4675 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4677 NewOp(1101, logop, 1, LOGOP);
4679 logop->op_type = (OPCODE)type;
4680 logop->op_ppaddr = PL_ppaddr[type];
4681 logop->op_first = first;
4682 logop->op_flags = (U8)(flags | OPf_KIDS);
4683 logop->op_other = LINKLIST(other);
4684 logop->op_private = (U8)(1 | (flags >> 8));
4686 /* establish postfix order */
4687 logop->op_next = LINKLIST(first);
4688 first->op_next = (OP*)logop;
4689 first->op_sibling = other;
4691 CHECKOP(type,logop);
4693 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4700 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4708 PERL_ARGS_ASSERT_NEWCONDOP;
4711 return newLOGOP(OP_AND, 0, first, trueop);
4713 return newLOGOP(OP_OR, 0, first, falseop);
4715 scalarboolean(first);
4716 if ((cstop = search_const(first))) {
4717 /* Left or right arm of the conditional? */
4718 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4719 OP *live = left ? trueop : falseop;
4720 OP *const dead = left ? falseop : trueop;
4721 if (cstop->op_private & OPpCONST_BARE &&
4722 cstop->op_private & OPpCONST_STRICT) {
4723 no_bareword_allowed(cstop);
4726 /* This is all dead code when PERL_MAD is not defined. */
4727 live = newUNOP(OP_NULL, 0, live);
4728 op_getmad(first, live, 'C');
4729 op_getmad(dead, live, left ? 'e' : 't');
4734 if (live->op_type == OP_LEAVE)
4735 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4738 NewOp(1101, logop, 1, LOGOP);
4739 logop->op_type = OP_COND_EXPR;
4740 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4741 logop->op_first = first;
4742 logop->op_flags = (U8)(flags | OPf_KIDS);
4743 logop->op_private = (U8)(1 | (flags >> 8));
4744 logop->op_other = LINKLIST(trueop);
4745 logop->op_next = LINKLIST(falseop);
4747 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4750 /* establish postfix order */
4751 start = LINKLIST(first);
4752 first->op_next = (OP*)logop;
4754 first->op_sibling = trueop;
4755 trueop->op_sibling = falseop;
4756 o = newUNOP(OP_NULL, 0, (OP*)logop);
4758 trueop->op_next = falseop->op_next = o;
4765 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4774 PERL_ARGS_ASSERT_NEWRANGE;
4776 NewOp(1101, range, 1, LOGOP);
4778 range->op_type = OP_RANGE;
4779 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4780 range->op_first = left;
4781 range->op_flags = OPf_KIDS;
4782 leftstart = LINKLIST(left);
4783 range->op_other = LINKLIST(right);
4784 range->op_private = (U8)(1 | (flags >> 8));
4786 left->op_sibling = right;
4788 range->op_next = (OP*)range;
4789 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4790 flop = newUNOP(OP_FLOP, 0, flip);
4791 o = newUNOP(OP_NULL, 0, flop);
4793 range->op_next = leftstart;
4795 left->op_next = flip;
4796 right->op_next = flop;
4798 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4799 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4800 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4801 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4803 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4804 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4807 if (!flip->op_private || !flop->op_private)
4808 linklist(o); /* blow off optimizer unless constant */
4814 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4819 const bool once = block && block->op_flags & OPf_SPECIAL &&
4820 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4822 PERL_UNUSED_ARG(debuggable);
4825 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4826 return block; /* do {} while 0 does once */
4827 if (expr->op_type == OP_READLINE
4828 || expr->op_type == OP_READDIR
4829 || expr->op_type == OP_GLOB
4830 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4831 expr = newUNOP(OP_DEFINED, 0,
4832 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4833 } else if (expr->op_flags & OPf_KIDS) {
4834 const OP * const k1 = ((UNOP*)expr)->op_first;
4835 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4836 switch (expr->op_type) {
4838 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4839 && (k2->op_flags & OPf_STACKED)
4840 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4841 expr = newUNOP(OP_DEFINED, 0, expr);
4845 if (k1 && (k1->op_type == OP_READDIR
4846 || k1->op_type == OP_GLOB
4847 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4848 || k1->op_type == OP_EACH))
4849 expr = newUNOP(OP_DEFINED, 0, expr);
4855 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4856 * op, in listop. This is wrong. [perl #27024] */
4858 block = newOP(OP_NULL, 0);
4859 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4860 o = new_logop(OP_AND, 0, &expr, &listop);
4863 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4865 if (once && o != listop)
4866 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4869 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4871 o->op_flags |= flags;
4873 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4878 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4879 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4888 PERL_UNUSED_ARG(debuggable);
4891 if (expr->op_type == OP_READLINE
4892 || expr->op_type == OP_READDIR
4893 || expr->op_type == OP_GLOB
4894 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4895 expr = newUNOP(OP_DEFINED, 0,
4896 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4897 } else if (expr->op_flags & OPf_KIDS) {
4898 const OP * const k1 = ((UNOP*)expr)->op_first;
4899 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4900 switch (expr->op_type) {
4902 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4903 && (k2->op_flags & OPf_STACKED)
4904 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4905 expr = newUNOP(OP_DEFINED, 0, expr);
4909 if (k1 && (k1->op_type == OP_READDIR
4910 || k1->op_type == OP_GLOB
4911 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4912 || k1->op_type == OP_EACH))
4913 expr = newUNOP(OP_DEFINED, 0, expr);
4920 block = newOP(OP_NULL, 0);
4921 else if (cont || has_my) {
4922 block = scope(block);
4926 next = LINKLIST(cont);
4929 OP * const unstack = newOP(OP_UNSTACK, 0);
4932 cont = append_elem(OP_LINESEQ, cont, unstack);
4936 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4938 redo = LINKLIST(listop);
4941 PL_parser->copline = (line_t)whileline;
4943 o = new_logop(OP_AND, 0, &expr, &listop);
4944 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4945 op_free(expr); /* oops, it's a while (0) */
4947 return NULL; /* listop already freed by new_logop */
4950 ((LISTOP*)listop)->op_last->op_next =
4951 (o == listop ? redo : LINKLIST(o));
4957 NewOp(1101,loop,1,LOOP);
4958 loop->op_type = OP_ENTERLOOP;
4959 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4960 loop->op_private = 0;
4961 loop->op_next = (OP*)loop;
4964 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4966 loop->op_redoop = redo;
4967 loop->op_lastop = o;
4968 o->op_private |= loopflags;
4971 loop->op_nextop = next;
4973 loop->op_nextop = o;
4975 o->op_flags |= flags;
4976 o->op_private |= (flags >> 8);
4981 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4986 PADOFFSET padoff = 0;
4991 PERL_ARGS_ASSERT_NEWFOROP;
4994 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4995 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4996 sv->op_type = OP_RV2GV;
4997 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4999 /* The op_type check is needed to prevent a possible segfault
5000 * if the loop variable is undeclared and 'strict vars' is in
5001 * effect. This is illegal but is nonetheless parsed, so we
5002 * may reach this point with an OP_CONST where we're expecting
5005 if (cUNOPx(sv)->op_first->op_type == OP_GV
5006 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5007 iterpflags |= OPpITER_DEF;
5009 else if (sv->op_type == OP_PADSV) { /* private variable */
5010 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5011 padoff = sv->op_targ;
5021 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5023 SV *const namesv = PAD_COMPNAME_SV(padoff);
5025 const char *const name = SvPV_const(namesv, len);
5027 if (len == 2 && name[0] == '$' && name[1] == '_')
5028 iterpflags |= OPpITER_DEF;
5032 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5033 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5034 sv = newGVOP(OP_GV, 0, PL_defgv);
5039 iterpflags |= OPpITER_DEF;
5041 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5042 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5043 iterflags |= OPf_STACKED;
5045 else if (expr->op_type == OP_NULL &&
5046 (expr->op_flags & OPf_KIDS) &&
5047 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5049 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5050 * set the STACKED flag to indicate that these values are to be
5051 * treated as min/max values by 'pp_iterinit'.
5053 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5054 LOGOP* const range = (LOGOP*) flip->op_first;
5055 OP* const left = range->op_first;
5056 OP* const right = left->op_sibling;
5059 range->op_flags &= ~OPf_KIDS;
5060 range->op_first = NULL;
5062 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5063 listop->op_first->op_next = range->op_next;
5064 left->op_next = range->op_other;
5065 right->op_next = (OP*)listop;
5066 listop->op_next = listop->op_first;
5069 op_getmad(expr,(OP*)listop,'O');
5073 expr = (OP*)(listop);
5075 iterflags |= OPf_STACKED;
5078 expr = mod(force_list(expr), OP_GREPSTART);
5081 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5082 append_elem(OP_LIST, expr, scalar(sv))));
5083 assert(!loop->op_next);
5084 /* for my $x () sets OPpLVAL_INTRO;
5085 * for our $x () sets OPpOUR_INTRO */
5086 loop->op_private = (U8)iterpflags;
5087 #ifdef PL_OP_SLAB_ALLOC
5090 NewOp(1234,tmp,1,LOOP);
5091 Copy(loop,tmp,1,LISTOP);
5092 S_op_destroy(aTHX_ (OP*)loop);
5096 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5098 loop->op_targ = padoff;
5099 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5101 op_getmad(madsv, (OP*)loop, 'v');
5102 PL_parser->copline = forline;
5103 return newSTATEOP(0, label, wop);
5107 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5112 PERL_ARGS_ASSERT_NEWLOOPEX;
5114 if (type != OP_GOTO || label->op_type == OP_CONST) {
5115 /* "last()" means "last" */
5116 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5117 o = newOP(type, OPf_SPECIAL);
5119 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5120 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5124 op_getmad(label,o,'L');
5130 /* Check whether it's going to be a goto &function */
5131 if (label->op_type == OP_ENTERSUB
5132 && !(label->op_flags & OPf_STACKED))
5133 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5134 o = newUNOP(type, OPf_STACKED, label);
5136 PL_hints |= HINT_BLOCK_SCOPE;
5140 /* if the condition is a literal array or hash
5141 (or @{ ... } etc), make a reference to it.
5144 S_ref_array_or_hash(pTHX_ OP *cond)
5147 && (cond->op_type == OP_RV2AV
5148 || cond->op_type == OP_PADAV
5149 || cond->op_type == OP_RV2HV
5150 || cond->op_type == OP_PADHV))
5152 return newUNOP(OP_REFGEN,
5153 0, mod(cond, OP_REFGEN));
5159 /* These construct the optree fragments representing given()
5162 entergiven and enterwhen are LOGOPs; the op_other pointer
5163 points up to the associated leave op. We need this so we
5164 can put it in the context and make break/continue work.
5165 (Also, of course, pp_enterwhen will jump straight to
5166 op_other if the match fails.)
5170 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5171 I32 enter_opcode, I32 leave_opcode,
5172 PADOFFSET entertarg)
5178 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5180 NewOp(1101, enterop, 1, LOGOP);
5181 enterop->op_type = (Optype)enter_opcode;
5182 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5183 enterop->op_flags = (U8) OPf_KIDS;
5184 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5185 enterop->op_private = 0;
5187 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5190 enterop->op_first = scalar(cond);
5191 cond->op_sibling = block;
5193 o->op_next = LINKLIST(cond);
5194 cond->op_next = (OP *) enterop;
5197 /* This is a default {} block */
5198 enterop->op_first = block;
5199 enterop->op_flags |= OPf_SPECIAL;
5201 o->op_next = (OP *) enterop;
5204 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5205 entergiven and enterwhen both
5208 enterop->op_next = LINKLIST(block);
5209 block->op_next = enterop->op_other = o;
5214 /* Does this look like a boolean operation? For these purposes
5215 a boolean operation is:
5216 - a subroutine call [*]
5217 - a logical connective
5218 - a comparison operator
5219 - a filetest operator, with the exception of -s -M -A -C
5220 - defined(), exists() or eof()
5221 - /$re/ or $foo =~ /$re/
5223 [*] possibly surprising
5226 S_looks_like_bool(pTHX_ const OP *o)
5230 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5232 switch(o->op_type) {
5235 return looks_like_bool(cLOGOPo->op_first);
5239 looks_like_bool(cLOGOPo->op_first)
5240 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5244 o->op_flags & OPf_KIDS
5245 && looks_like_bool(cUNOPo->op_first));
5248 return looks_like_bool(cUNOPo->op_first);
5253 case OP_NOT: case OP_XOR:
5255 case OP_EQ: case OP_NE: case OP_LT:
5256 case OP_GT: case OP_LE: case OP_GE:
5258 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5259 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5261 case OP_SEQ: case OP_SNE: case OP_SLT:
5262 case OP_SGT: case OP_SLE: case OP_SGE:
5266 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5267 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5268 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5269 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5270 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5271 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5272 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5273 case OP_FTTEXT: case OP_FTBINARY:
5275 case OP_DEFINED: case OP_EXISTS:
5276 case OP_MATCH: case OP_EOF:
5283 /* Detect comparisons that have been optimized away */
5284 if (cSVOPo->op_sv == &PL_sv_yes
5285 || cSVOPo->op_sv == &PL_sv_no)
5298 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5301 PERL_ARGS_ASSERT_NEWGIVENOP;
5302 return newGIVWHENOP(
5303 ref_array_or_hash(cond),
5305 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5309 /* If cond is null, this is a default {} block */
5311 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5313 const bool cond_llb = (!cond || looks_like_bool(cond));
5316 PERL_ARGS_ASSERT_NEWWHENOP;
5321 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5323 scalar(ref_array_or_hash(cond)));
5326 return newGIVWHENOP(
5328 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5329 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5333 =for apidoc cv_undef
5335 Clear out all the active components of a CV. This can happen either
5336 by an explicit C<undef &foo>, or by the reference count going to zero.
5337 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5338 children can still follow the full lexical scope chain.
5344 Perl_cv_undef(pTHX_ CV *cv)
5348 PERL_ARGS_ASSERT_CV_UNDEF;
5350 DEBUG_X(PerlIO_printf(Perl_debug_log,
5351 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5352 PTR2UV(cv), PTR2UV(PL_comppad))
5356 if (CvFILE(cv) && !CvISXSUB(cv)) {
5357 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5358 Safefree(CvFILE(cv));
5363 if (!CvISXSUB(cv) && CvROOT(cv)) {
5364 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5365 Perl_croak(aTHX_ "Can't undef active subroutine");
5368 PAD_SAVE_SETNULLPAD();
5370 op_free(CvROOT(cv));
5375 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5380 /* remove CvOUTSIDE unless this is an undef rather than a free */
5381 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5382 if (!CvWEAKOUTSIDE(cv))
5383 SvREFCNT_dec(CvOUTSIDE(cv));
5384 CvOUTSIDE(cv) = NULL;
5387 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5390 if (CvISXSUB(cv) && CvXSUB(cv)) {
5393 /* delete all flags except WEAKOUTSIDE */
5394 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5398 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5401 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5403 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5404 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5405 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5406 || (p && (len != SvCUR(cv) /* Not the same length. */
5407 || memNE(p, SvPVX_const(cv), len))))
5408 && ckWARN_d(WARN_PROTOTYPE)) {
5409 SV* const msg = sv_newmortal();
5413 gv_efullname3(name = sv_newmortal(), gv, NULL);
5414 sv_setpvs(msg, "Prototype mismatch:");
5416 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5418 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5420 sv_catpvs(msg, ": none");
5421 sv_catpvs(msg, " vs ");
5423 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5425 sv_catpvs(msg, "none");
5426 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5430 static void const_sv_xsub(pTHX_ CV* cv);
5434 =head1 Optree Manipulation Functions
5436 =for apidoc cv_const_sv
5438 If C<cv> is a constant sub eligible for inlining. returns the constant
5439 value returned by the sub. Otherwise, returns NULL.
5441 Constant subs can be created with C<newCONSTSUB> or as described in
5442 L<perlsub/"Constant Functions">.
5447 Perl_cv_const_sv(pTHX_ const CV *const cv)
5449 PERL_UNUSED_CONTEXT;
5452 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5454 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5457 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5458 * Can be called in 3 ways:
5461 * look for a single OP_CONST with attached value: return the value
5463 * cv && CvCLONE(cv) && !CvCONST(cv)
5465 * examine the clone prototype, and if contains only a single
5466 * OP_CONST referencing a pad const, or a single PADSV referencing
5467 * an outer lexical, return a non-zero value to indicate the CV is
5468 * a candidate for "constizing" at clone time
5472 * We have just cloned an anon prototype that was marked as a const
5473 * candidiate. Try to grab the current value, and in the case of
5474 * PADSV, ignore it if it has multiple references. Return the value.
5478 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5489 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5490 o = cLISTOPo->op_first->op_sibling;
5492 for (; o; o = o->op_next) {
5493 const OPCODE type = o->op_type;
5495 if (sv && o->op_next == o)
5497 if (o->op_next != o) {
5498 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5500 if (type == OP_DBSTATE)
5503 if (type == OP_LEAVESUB || type == OP_RETURN)
5507 if (type == OP_CONST && cSVOPo->op_sv)
5509 else if (cv && type == OP_CONST) {
5510 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5514 else if (cv && type == OP_PADSV) {
5515 if (CvCONST(cv)) { /* newly cloned anon */
5516 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5517 /* the candidate should have 1 ref from this pad and 1 ref
5518 * from the parent */
5519 if (!sv || SvREFCNT(sv) != 2)
5526 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5527 sv = &PL_sv_undef; /* an arbitrary non-null value */
5542 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5545 /* This would be the return value, but the return cannot be reached. */
5546 OP* pegop = newOP(OP_NULL, 0);
5549 PERL_UNUSED_ARG(floor);
5559 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5561 NORETURN_FUNCTION_END;
5566 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5568 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5572 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5578 register CV *cv = NULL;
5580 /* If the subroutine has no body, no attributes, and no builtin attributes
5581 then it's just a sub declaration, and we may be able to get away with
5582 storing with a placeholder scalar in the symbol table, rather than a
5583 full GV and CV. If anything is present then it will take a full CV to
5585 const I32 gv_fetch_flags
5586 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5588 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5589 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5593 assert(proto->op_type == OP_CONST);
5594 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5600 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5602 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5603 SV * const sv = sv_newmortal();
5604 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5605 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5606 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5607 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5609 } else if (PL_curstash) {
5610 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5613 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5617 if (!PL_madskills) {
5626 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5627 maximum a prototype before. */
5628 if (SvTYPE(gv) > SVt_NULL) {
5629 if (!SvPOK((const SV *)gv)
5630 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5632 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5634 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5637 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5639 sv_setiv(MUTABLE_SV(gv), -1);
5641 SvREFCNT_dec(PL_compcv);
5642 cv = PL_compcv = NULL;
5646 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5648 if (!block || !ps || *ps || attrs
5649 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5651 || block->op_type == OP_NULL
5656 const_sv = op_const_sv(block, NULL);
5659 const bool exists = CvROOT(cv) || CvXSUB(cv);
5661 /* if the subroutine doesn't exist and wasn't pre-declared
5662 * with a prototype, assume it will be AUTOLOADed,
5663 * skipping the prototype check
5665 if (exists || SvPOK(cv))
5666 cv_ckproto_len(cv, gv, ps, ps_len);
5667 /* already defined (or promised)? */
5668 if (exists || GvASSUMECV(gv)) {
5671 || block->op_type == OP_NULL
5674 if (CvFLAGS(PL_compcv)) {
5675 /* might have had built-in attrs applied */
5676 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5678 /* just a "sub foo;" when &foo is already defined */
5679 SAVEFREESV(PL_compcv);
5684 && block->op_type != OP_NULL
5687 if (ckWARN(WARN_REDEFINE)
5689 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5691 const line_t oldline = CopLINE(PL_curcop);
5692 if (PL_parser && PL_parser->copline != NOLINE)
5693 CopLINE_set(PL_curcop, PL_parser->copline);
5694 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5695 CvCONST(cv) ? "Constant subroutine %s redefined"
5696 : "Subroutine %s redefined", name);
5697 CopLINE_set(PL_curcop, oldline);
5700 if (!PL_minus_c) /* keep old one around for madskills */
5703 /* (PL_madskills unset in used file.) */
5711 SvREFCNT_inc_simple_void_NN(const_sv);
5713 assert(!CvROOT(cv) && !CvCONST(cv));
5714 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5715 CvXSUBANY(cv).any_ptr = const_sv;
5716 CvXSUB(cv) = const_sv_xsub;
5722 cv = newCONSTSUB(NULL, name, const_sv);
5724 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5725 (CvGV(cv) && GvSTASH(CvGV(cv)))
5734 SvREFCNT_dec(PL_compcv);
5738 if (cv) { /* must reuse cv if autoloaded */
5739 /* transfer PL_compcv to cv */
5742 && block->op_type != OP_NULL
5746 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5747 if (!CvWEAKOUTSIDE(cv))
5748 SvREFCNT_dec(CvOUTSIDE(cv));
5749 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5750 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5751 CvOUTSIDE(PL_compcv) = 0;
5752 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5753 CvPADLIST(PL_compcv) = 0;
5754 /* inner references to PL_compcv must be fixed up ... */
5755 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5756 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5757 ++PL_sub_generation;
5760 /* Might have had built-in attributes applied -- propagate them. */
5761 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5763 /* ... before we throw it away */
5764 SvREFCNT_dec(PL_compcv);
5772 if (strEQ(name, "import")) {
5773 PL_formfeed = MUTABLE_SV(cv);
5774 /* diag_listed_as: SKIPME */
5775 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
5779 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5784 CvFILE_set_from_cop(cv, PL_curcop);
5785 CvSTASH(cv) = PL_curstash;
5788 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5789 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5790 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5794 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5796 if (PL_parser && PL_parser->error_count) {
5800 const char *s = strrchr(name, ':');
5802 if (strEQ(s, "BEGIN")) {
5803 const char not_safe[] =
5804 "BEGIN not safe after errors--compilation aborted";
5805 if (PL_in_eval & EVAL_KEEPERR)
5806 Perl_croak(aTHX_ not_safe);
5808 /* force display of errors found but not reported */
5809 sv_catpv(ERRSV, not_safe);
5810 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5819 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5820 the debugger could be able to set a breakpoint in, so signal to
5821 pp_entereval that it should not throw away any saved lines at scope
5824 PL_breakable_sub_gen++;
5826 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5827 mod(scalarseq(block), OP_LEAVESUBLV));
5828 block->op_attached = 1;
5831 /* This makes sub {}; work as expected. */
5832 if (block->op_type == OP_STUB) {
5833 OP* const newblock = newSTATEOP(0, NULL, 0);
5835 op_getmad(block,newblock,'B');
5842 block->op_attached = 1;
5843 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5845 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5846 OpREFCNT_set(CvROOT(cv), 1);
5847 CvSTART(cv) = LINKLIST(CvROOT(cv));
5848 CvROOT(cv)->op_next = 0;
5849 CALL_PEEP(CvSTART(cv));
5851 /* now that optimizer has done its work, adjust pad values */
5853 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5856 assert(!CvCONST(cv));
5857 if (ps && !*ps && op_const_sv(block, cv))
5862 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5863 SV * const sv = newSV(0);
5864 SV * const tmpstr = sv_newmortal();
5865 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5866 GV_ADDMULTI, SVt_PVHV);
5869 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5871 (long)PL_subline, (long)CopLINE(PL_curcop));
5872 gv_efullname3(tmpstr, gv, NULL);
5873 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5874 SvCUR(tmpstr), sv, 0);
5875 hv = GvHVn(db_postponed);
5876 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5877 CV * const pcv = GvCV(db_postponed);
5883 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5888 if (name && ! (PL_parser && PL_parser->error_count))
5889 process_special_blocks(name, gv, cv);
5894 PL_parser->copline = NOLINE;
5900 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5903 const char *const colon = strrchr(fullname,':');
5904 const char *const name = colon ? colon + 1 : fullname;
5906 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5909 if (strEQ(name, "BEGIN")) {
5910 const I32 oldscope = PL_scopestack_ix;
5912 SAVECOPFILE(&PL_compiling);
5913 SAVECOPLINE(&PL_compiling);
5915 DEBUG_x( dump_sub(gv) );
5916 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5917 GvCV(gv) = 0; /* cv has been hijacked */
5918 call_list(oldscope, PL_beginav);
5920 PL_curcop = &PL_compiling;
5921 CopHINTS_set(&PL_compiling, PL_hints);
5928 if strEQ(name, "END") {
5929 DEBUG_x( dump_sub(gv) );
5930 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5933 } else if (*name == 'U') {
5934 if (strEQ(name, "UNITCHECK")) {
5935 /* It's never too late to run a unitcheck block */
5936 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5940 } else if (*name == 'C') {
5941 if (strEQ(name, "CHECK")) {
5943 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5944 "Too late to run CHECK block");
5945 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5949 } else if (*name == 'I') {
5950 if (strEQ(name, "INIT")) {
5952 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5953 "Too late to run INIT block");
5954 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5960 DEBUG_x( dump_sub(gv) );
5961 GvCV(gv) = 0; /* cv has been hijacked */
5966 =for apidoc newCONSTSUB
5968 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5969 eligible for inlining at compile-time.
5971 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5972 which won't be called if used as a destructor, but will suppress the overhead
5973 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5980 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5985 const char *const file = CopFILE(PL_curcop);
5987 SV *const temp_sv = CopFILESV(PL_curcop);
5988 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5993 if (IN_PERL_RUNTIME) {
5994 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5995 * an op shared between threads. Use a non-shared COP for our
5997 SAVEVPTR(PL_curcop);
5998 PL_curcop = &PL_compiling;
6000 SAVECOPLINE(PL_curcop);
6001 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6004 PL_hints &= ~HINT_BLOCK_SCOPE;
6007 SAVESPTR(PL_curstash);
6008 SAVECOPSTASH(PL_curcop);
6009 PL_curstash = stash;
6010 CopSTASH_set(PL_curcop,stash);
6013 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6014 and so doesn't get free()d. (It's expected to be from the C pre-
6015 processor __FILE__ directive). But we need a dynamically allocated one,
6016 and we need it to get freed. */
6017 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6018 XS_DYNAMIC_FILENAME);
6019 CvXSUBANY(cv).any_ptr = sv;
6024 CopSTASH_free(PL_curcop);
6032 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6033 const char *const filename, const char *const proto,
6036 CV *cv = newXS(name, subaddr, filename);
6038 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6040 if (flags & XS_DYNAMIC_FILENAME) {
6041 /* We need to "make arrangements" (ie cheat) to ensure that the
6042 filename lasts as long as the PVCV we just created, but also doesn't
6044 STRLEN filename_len = strlen(filename);
6045 STRLEN proto_and_file_len = filename_len;
6046 char *proto_and_file;
6050 proto_len = strlen(proto);
6051 proto_and_file_len += proto_len;
6053 Newx(proto_and_file, proto_and_file_len + 1, char);
6054 Copy(proto, proto_and_file, proto_len, char);
6055 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6058 proto_and_file = savepvn(filename, filename_len);
6061 /* This gets free()d. :-) */
6062 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6063 SV_HAS_TRAILING_NUL);
6065 /* This gives us the correct prototype, rather than one with the
6066 file name appended. */
6067 SvCUR_set(cv, proto_len);
6071 CvFILE(cv) = proto_and_file + proto_len;
6073 sv_setpv(MUTABLE_SV(cv), proto);
6079 =for apidoc U||newXS
6081 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6082 static storage, as it is used directly as CvFILE(), without a copy being made.
6088 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6091 GV * const gv = gv_fetchpv(name ? name :
6092 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6093 GV_ADDMULTI, SVt_PVCV);
6096 PERL_ARGS_ASSERT_NEWXS;
6099 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6101 if ((cv = (name ? GvCV(gv) : NULL))) {
6103 /* just a cached method */
6107 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6108 /* already defined (or promised) */
6109 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6110 if (ckWARN(WARN_REDEFINE)) {
6111 GV * const gvcv = CvGV(cv);
6113 HV * const stash = GvSTASH(gvcv);
6115 const char *redefined_name = HvNAME_get(stash);
6116 if ( strEQ(redefined_name,"autouse") ) {
6117 const line_t oldline = CopLINE(PL_curcop);
6118 if (PL_parser && PL_parser->copline != NOLINE)
6119 CopLINE_set(PL_curcop, PL_parser->copline);
6120 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6121 CvCONST(cv) ? "Constant subroutine %s redefined"
6122 : "Subroutine %s redefined"
6124 CopLINE_set(PL_curcop, oldline);
6134 if (cv) /* must reuse cv if autoloaded */
6137 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6141 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6145 (void)gv_fetchfile(filename);
6146 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6147 an external constant string */
6149 CvXSUB(cv) = subaddr;
6152 process_special_blocks(name, gv, cv);
6164 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6169 OP* pegop = newOP(OP_NULL, 0);
6173 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6174 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6177 if ((cv = GvFORM(gv))) {
6178 if (ckWARN(WARN_REDEFINE)) {
6179 const line_t oldline = CopLINE(PL_curcop);
6180 if (PL_parser && PL_parser->copline != NOLINE)
6181 CopLINE_set(PL_curcop, PL_parser->copline);
6183 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6184 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6186 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6187 "Format STDOUT redefined");
6189 CopLINE_set(PL_curcop, oldline);
6196 CvFILE_set_from_cop(cv, PL_curcop);
6199 pad_tidy(padtidy_FORMAT);
6200 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6201 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6202 OpREFCNT_set(CvROOT(cv), 1);
6203 CvSTART(cv) = LINKLIST(CvROOT(cv));
6204 CvROOT(cv)->op_next = 0;
6205 CALL_PEEP(CvSTART(cv));
6207 op_getmad(o,pegop,'n');
6208 op_getmad_weak(block, pegop, 'b');
6213 PL_parser->copline = NOLINE;
6221 Perl_newANONLIST(pTHX_ OP *o)
6223 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6227 Perl_newANONHASH(pTHX_ OP *o)
6229 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6233 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6235 return newANONATTRSUB(floor, proto, NULL, block);
6239 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6241 return newUNOP(OP_REFGEN, 0,
6242 newSVOP(OP_ANONCODE, 0,
6243 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6247 Perl_oopsAV(pTHX_ OP *o)
6251 PERL_ARGS_ASSERT_OOPSAV;
6253 switch (o->op_type) {
6255 o->op_type = OP_PADAV;
6256 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6257 return ref(o, OP_RV2AV);
6260 o->op_type = OP_RV2AV;
6261 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6266 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6273 Perl_oopsHV(pTHX_ OP *o)
6277 PERL_ARGS_ASSERT_OOPSHV;
6279 switch (o->op_type) {
6282 o->op_type = OP_PADHV;
6283 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6284 return ref(o, OP_RV2HV);
6288 o->op_type = OP_RV2HV;
6289 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6294 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6301 Perl_newAVREF(pTHX_ OP *o)
6305 PERL_ARGS_ASSERT_NEWAVREF;
6307 if (o->op_type == OP_PADANY) {
6308 o->op_type = OP_PADAV;
6309 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6312 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6313 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6314 "Using an array as a reference is deprecated");
6316 return newUNOP(OP_RV2AV, 0, scalar(o));
6320 Perl_newGVREF(pTHX_ I32 type, OP *o)
6322 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6323 return newUNOP(OP_NULL, 0, o);
6324 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6328 Perl_newHVREF(pTHX_ OP *o)
6332 PERL_ARGS_ASSERT_NEWHVREF;
6334 if (o->op_type == OP_PADANY) {
6335 o->op_type = OP_PADHV;
6336 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6339 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6340 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6341 "Using a hash as a reference is deprecated");
6343 return newUNOP(OP_RV2HV, 0, scalar(o));
6347 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6349 return newUNOP(OP_RV2CV, flags, scalar(o));
6353 Perl_newSVREF(pTHX_ OP *o)
6357 PERL_ARGS_ASSERT_NEWSVREF;
6359 if (o->op_type == OP_PADANY) {
6360 o->op_type = OP_PADSV;
6361 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6364 return newUNOP(OP_RV2SV, 0, scalar(o));
6367 /* Check routines. See the comments at the top of this file for details
6368 * on when these are called */
6371 Perl_ck_anoncode(pTHX_ OP *o)
6373 PERL_ARGS_ASSERT_CK_ANONCODE;
6375 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6377 cSVOPo->op_sv = NULL;
6382 Perl_ck_bitop(pTHX_ OP *o)
6386 PERL_ARGS_ASSERT_CK_BITOP;
6388 #define OP_IS_NUMCOMPARE(op) \
6389 ((op) == OP_LT || (op) == OP_I_LT || \
6390 (op) == OP_GT || (op) == OP_I_GT || \
6391 (op) == OP_LE || (op) == OP_I_LE || \
6392 (op) == OP_GE || (op) == OP_I_GE || \
6393 (op) == OP_EQ || (op) == OP_I_EQ || \
6394 (op) == OP_NE || (op) == OP_I_NE || \
6395 (op) == OP_NCMP || (op) == OP_I_NCMP)
6396 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6397 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6398 && (o->op_type == OP_BIT_OR
6399 || o->op_type == OP_BIT_AND
6400 || o->op_type == OP_BIT_XOR))
6402 const OP * const left = cBINOPo->op_first;
6403 const OP * const right = left->op_sibling;
6404 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6405 (left->op_flags & OPf_PARENS) == 0) ||
6406 (OP_IS_NUMCOMPARE(right->op_type) &&
6407 (right->op_flags & OPf_PARENS) == 0))
6408 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6409 "Possible precedence problem on bitwise %c operator",
6410 o->op_type == OP_BIT_OR ? '|'
6411 : o->op_type == OP_BIT_AND ? '&' : '^'
6418 Perl_ck_concat(pTHX_ OP *o)
6420 const OP * const kid = cUNOPo->op_first;
6422 PERL_ARGS_ASSERT_CK_CONCAT;
6423 PERL_UNUSED_CONTEXT;
6425 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6426 !(kUNOP->op_first->op_flags & OPf_MOD))
6427 o->op_flags |= OPf_STACKED;
6432 Perl_ck_spair(pTHX_ OP *o)
6436 PERL_ARGS_ASSERT_CK_SPAIR;
6438 if (o->op_flags & OPf_KIDS) {
6441 const OPCODE type = o->op_type;
6442 o = modkids(ck_fun(o), type);
6443 kid = cUNOPo->op_first;
6444 newop = kUNOP->op_first->op_sibling;
6446 const OPCODE type = newop->op_type;
6447 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6448 type == OP_PADAV || type == OP_PADHV ||
6449 type == OP_RV2AV || type == OP_RV2HV)
6453 op_getmad(kUNOP->op_first,newop,'K');
6455 op_free(kUNOP->op_first);
6457 kUNOP->op_first = newop;
6459 o->op_ppaddr = PL_ppaddr[++o->op_type];
6464 Perl_ck_delete(pTHX_ OP *o)
6466 PERL_ARGS_ASSERT_CK_DELETE;
6470 if (o->op_flags & OPf_KIDS) {
6471 OP * const kid = cUNOPo->op_first;
6472 switch (kid->op_type) {
6474 o->op_flags |= OPf_SPECIAL;
6477 o->op_private |= OPpSLICE;
6480 o->op_flags |= OPf_SPECIAL;
6485 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6488 if (kid->op_private & OPpLVAL_INTRO)
6489 o->op_private |= OPpLVAL_INTRO;
6496 Perl_ck_die(pTHX_ OP *o)
6498 PERL_ARGS_ASSERT_CK_DIE;
6501 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6507 Perl_ck_eof(pTHX_ OP *o)
6511 PERL_ARGS_ASSERT_CK_EOF;
6513 if (o->op_flags & OPf_KIDS) {
6514 if (cLISTOPo->op_first->op_type == OP_STUB) {
6516 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6518 op_getmad(o,newop,'O');
6530 Perl_ck_eval(pTHX_ OP *o)
6534 PERL_ARGS_ASSERT_CK_EVAL;
6536 PL_hints |= HINT_BLOCK_SCOPE;
6537 if (o->op_flags & OPf_KIDS) {
6538 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6541 o->op_flags &= ~OPf_KIDS;
6544 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6550 cUNOPo->op_first = 0;
6555 NewOp(1101, enter, 1, LOGOP);
6556 enter->op_type = OP_ENTERTRY;
6557 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6558 enter->op_private = 0;
6560 /* establish postfix order */
6561 enter->op_next = (OP*)enter;
6563 CHECKOP(OP_ENTERTRY, enter);
6565 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6566 o->op_type = OP_LEAVETRY;
6567 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6568 enter->op_other = o;
6569 op_getmad(oldo,o,'O');
6583 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6584 op_getmad(oldo,o,'O');
6586 o->op_targ = (PADOFFSET)PL_hints;
6587 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6588 /* Store a copy of %^H that pp_entereval can pick up. */
6589 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6590 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6591 cUNOPo->op_first->op_sibling = hhop;
6592 o->op_private |= OPpEVAL_HAS_HH;
6598 Perl_ck_exit(pTHX_ OP *o)
6600 PERL_ARGS_ASSERT_CK_EXIT;
6603 HV * const table = GvHV(PL_hintgv);
6605 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6606 if (svp && *svp && SvTRUE(*svp))
6607 o->op_private |= OPpEXIT_VMSISH;
6609 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6615 Perl_ck_exec(pTHX_ OP *o)
6617 PERL_ARGS_ASSERT_CK_EXEC;
6619 if (o->op_flags & OPf_STACKED) {
6622 kid = cUNOPo->op_first->op_sibling;
6623 if (kid->op_type == OP_RV2GV)
6632 Perl_ck_exists(pTHX_ OP *o)
6636 PERL_ARGS_ASSERT_CK_EXISTS;
6639 if (o->op_flags & OPf_KIDS) {
6640 OP * const kid = cUNOPo->op_first;
6641 if (kid->op_type == OP_ENTERSUB) {
6642 (void) ref(kid, o->op_type);
6643 if (kid->op_type != OP_RV2CV
6644 && !(PL_parser && PL_parser->error_count))
6645 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6647 o->op_private |= OPpEXISTS_SUB;
6649 else if (kid->op_type == OP_AELEM)
6650 o->op_flags |= OPf_SPECIAL;
6651 else if (kid->op_type != OP_HELEM)
6652 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6660 Perl_ck_rvconst(pTHX_ register OP *o)
6663 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6665 PERL_ARGS_ASSERT_CK_RVCONST;
6667 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6668 if (o->op_type == OP_RV2CV)
6669 o->op_private &= ~1;
6671 if (kid->op_type == OP_CONST) {
6674 SV * const kidsv = kid->op_sv;
6676 /* Is it a constant from cv_const_sv()? */
6677 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6678 SV * const rsv = SvRV(kidsv);
6679 const svtype type = SvTYPE(rsv);
6680 const char *badtype = NULL;
6682 switch (o->op_type) {
6684 if (type > SVt_PVMG)
6685 badtype = "a SCALAR";
6688 if (type != SVt_PVAV)
6689 badtype = "an ARRAY";
6692 if (type != SVt_PVHV)
6696 if (type != SVt_PVCV)
6701 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6704 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6705 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6706 /* If this is an access to a stash, disable "strict refs", because
6707 * stashes aren't auto-vivified at compile-time (unless we store
6708 * symbols in them), and we don't want to produce a run-time
6709 * stricture error when auto-vivifying the stash. */
6710 const char *s = SvPV_nolen(kidsv);
6711 const STRLEN l = SvCUR(kidsv);
6712 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6713 o->op_private &= ~HINT_STRICT_REFS;
6715 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6716 const char *badthing;
6717 switch (o->op_type) {
6719 badthing = "a SCALAR";
6722 badthing = "an ARRAY";
6725 badthing = "a HASH";
6733 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6734 SVfARG(kidsv), badthing);
6737 * This is a little tricky. We only want to add the symbol if we
6738 * didn't add it in the lexer. Otherwise we get duplicate strict
6739 * warnings. But if we didn't add it in the lexer, we must at
6740 * least pretend like we wanted to add it even if it existed before,
6741 * or we get possible typo warnings. OPpCONST_ENTERED says
6742 * whether the lexer already added THIS instance of this symbol.
6744 iscv = (o->op_type == OP_RV2CV) * 2;
6746 gv = gv_fetchsv(kidsv,
6747 iscv | !(kid->op_private & OPpCONST_ENTERED),
6750 : o->op_type == OP_RV2SV
6752 : o->op_type == OP_RV2AV
6754 : o->op_type == OP_RV2HV
6757 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6759 kid->op_type = OP_GV;
6760 SvREFCNT_dec(kid->op_sv);
6762 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6763 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6764 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6766 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6768 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6770 kid->op_private = 0;
6771 kid->op_ppaddr = PL_ppaddr[OP_GV];
6778 Perl_ck_ftst(pTHX_ OP *o)
6781 const I32 type = o->op_type;
6783 PERL_ARGS_ASSERT_CK_FTST;
6785 if (o->op_flags & OPf_REF) {
6788 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6789 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6790 const OPCODE kidtype = kid->op_type;
6792 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6793 OP * const newop = newGVOP(type, OPf_REF,
6794 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6796 op_getmad(o,newop,'O');
6802 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6803 o->op_private |= OPpFT_ACCESS;
6804 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6805 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6806 o->op_private |= OPpFT_STACKED;
6814 if (type == OP_FTTTY)
6815 o = newGVOP(type, OPf_REF, PL_stdingv);
6817 o = newUNOP(type, 0, newDEFSVOP());
6818 op_getmad(oldo,o,'O');
6824 Perl_ck_fun(pTHX_ OP *o)
6827 const int type = o->op_type;
6828 register I32 oa = PL_opargs[type] >> OASHIFT;
6830 PERL_ARGS_ASSERT_CK_FUN;
6832 if (o->op_flags & OPf_STACKED) {
6833 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6836 return no_fh_allowed(o);
6839 if (o->op_flags & OPf_KIDS) {
6840 OP **tokid = &cLISTOPo->op_first;
6841 register OP *kid = cLISTOPo->op_first;
6845 if (kid->op_type == OP_PUSHMARK ||
6846 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6848 tokid = &kid->op_sibling;
6849 kid = kid->op_sibling;
6851 if (!kid && PL_opargs[type] & OA_DEFGV)
6852 *tokid = kid = newDEFSVOP();
6856 sibl = kid->op_sibling;
6858 if (!sibl && kid->op_type == OP_STUB) {
6865 /* list seen where single (scalar) arg expected? */
6866 if (numargs == 1 && !(oa >> 4)
6867 && kid->op_type == OP_LIST && type != OP_SCALAR)
6869 return too_many_arguments(o,PL_op_desc[type]);
6882 if ((type == OP_PUSH || type == OP_UNSHIFT)
6883 && !kid->op_sibling)
6884 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6885 "Useless use of %s with no values",
6888 if (kid->op_type == OP_CONST &&
6889 (kid->op_private & OPpCONST_BARE))
6891 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6892 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6893 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6894 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6895 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6897 op_getmad(kid,newop,'K');
6902 kid->op_sibling = sibl;
6905 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6906 bad_type(numargs, "array", PL_op_desc[type], kid);
6910 if (kid->op_type == OP_CONST &&
6911 (kid->op_private & OPpCONST_BARE))
6913 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6914 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6915 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6916 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6917 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6919 op_getmad(kid,newop,'K');
6924 kid->op_sibling = sibl;
6927 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6928 bad_type(numargs, "hash", PL_op_desc[type], kid);
6933 OP * const newop = newUNOP(OP_NULL, 0, kid);
6934 kid->op_sibling = 0;
6936 newop->op_next = newop;
6938 kid->op_sibling = sibl;
6943 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6944 if (kid->op_type == OP_CONST &&
6945 (kid->op_private & OPpCONST_BARE))
6947 OP * const newop = newGVOP(OP_GV, 0,
6948 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6949 if (!(o->op_private & 1) && /* if not unop */
6950 kid == cLISTOPo->op_last)
6951 cLISTOPo->op_last = newop;
6953 op_getmad(kid,newop,'K');
6959 else if (kid->op_type == OP_READLINE) {
6960 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6961 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6964 I32 flags = OPf_SPECIAL;
6968 /* is this op a FH constructor? */
6969 if (is_handle_constructor(o,numargs)) {
6970 const char *name = NULL;
6974 /* Set a flag to tell rv2gv to vivify
6975 * need to "prove" flag does not mean something
6976 * else already - NI-S 1999/05/07
6979 if (kid->op_type == OP_PADSV) {
6981 = PAD_COMPNAME_SV(kid->op_targ);
6982 name = SvPV_const(namesv, len);
6984 else if (kid->op_type == OP_RV2SV
6985 && kUNOP->op_first->op_type == OP_GV)
6987 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6989 len = GvNAMELEN(gv);
6991 else if (kid->op_type == OP_AELEM
6992 || kid->op_type == OP_HELEM)
6995 OP *op = ((BINOP*)kid)->op_first;
6999 const char * const a =
7000 kid->op_type == OP_AELEM ?
7002 if (((op->op_type == OP_RV2AV) ||
7003 (op->op_type == OP_RV2HV)) &&
7004 (firstop = ((UNOP*)op)->op_first) &&
7005 (firstop->op_type == OP_GV)) {
7006 /* packagevar $a[] or $h{} */
7007 GV * const gv = cGVOPx_gv(firstop);
7015 else if (op->op_type == OP_PADAV
7016 || op->op_type == OP_PADHV) {
7017 /* lexicalvar $a[] or $h{} */
7018 const char * const padname =
7019 PAD_COMPNAME_PV(op->op_targ);
7028 name = SvPV_const(tmpstr, len);
7033 name = "__ANONIO__";
7040 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7041 namesv = PAD_SVl(targ);
7042 SvUPGRADE(namesv, SVt_PV);
7044 sv_setpvs(namesv, "$");
7045 sv_catpvn(namesv, name, len);
7048 kid->op_sibling = 0;
7049 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7050 kid->op_targ = targ;
7051 kid->op_private |= priv;
7053 kid->op_sibling = sibl;
7059 mod(scalar(kid), type);
7063 tokid = &kid->op_sibling;
7064 kid = kid->op_sibling;
7067 if (kid && kid->op_type != OP_STUB)
7068 return too_many_arguments(o,OP_DESC(o));
7069 o->op_private |= numargs;
7071 /* FIXME - should the numargs move as for the PERL_MAD case? */
7072 o->op_private |= numargs;
7074 return too_many_arguments(o,OP_DESC(o));
7078 else if (PL_opargs[type] & OA_DEFGV) {
7080 OP *newop = newUNOP(type, 0, newDEFSVOP());
7081 op_getmad(o,newop,'O');
7084 /* Ordering of these two is important to keep f_map.t passing. */
7086 return newUNOP(type, 0, newDEFSVOP());
7091 while (oa & OA_OPTIONAL)
7093 if (oa && oa != OA_LIST)
7094 return too_few_arguments(o,OP_DESC(o));
7100 Perl_ck_glob(pTHX_ OP *o)
7105 PERL_ARGS_ASSERT_CK_GLOB;
7108 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7109 append_elem(OP_GLOB, o, newDEFSVOP());
7111 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7112 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7114 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7117 #if !defined(PERL_EXTERNAL_GLOB)
7118 /* XXX this can be tightened up and made more failsafe. */
7119 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7122 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7123 newSVpvs("File::Glob"), NULL, NULL, NULL);
7124 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7125 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7126 GvCV(gv) = GvCV(glob_gv);
7127 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7128 GvIMPORTED_CV_on(gv);
7131 #endif /* PERL_EXTERNAL_GLOB */
7133 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7134 append_elem(OP_GLOB, o,
7135 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7136 o->op_type = OP_LIST;
7137 o->op_ppaddr = PL_ppaddr[OP_LIST];
7138 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7139 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7140 cLISTOPo->op_first->op_targ = 0;
7141 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7142 append_elem(OP_LIST, o,
7143 scalar(newUNOP(OP_RV2CV, 0,
7144 newGVOP(OP_GV, 0, gv)))));
7145 o = newUNOP(OP_NULL, 0, ck_subr(o));
7146 o->op_targ = OP_GLOB; /* hint at what it used to be */
7149 gv = newGVgen("main");
7151 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7157 Perl_ck_grep(pTHX_ OP *o)
7162 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7165 PERL_ARGS_ASSERT_CK_GREP;
7167 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7168 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7170 if (o->op_flags & OPf_STACKED) {
7173 kid = cLISTOPo->op_first->op_sibling;
7174 if (!cUNOPx(kid)->op_next)
7175 Perl_croak(aTHX_ "panic: ck_grep");
7176 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7179 NewOp(1101, gwop, 1, LOGOP);
7180 kid->op_next = (OP*)gwop;
7181 o->op_flags &= ~OPf_STACKED;
7183 kid = cLISTOPo->op_first->op_sibling;
7184 if (type == OP_MAPWHILE)
7189 if (PL_parser && PL_parser->error_count)
7191 kid = cLISTOPo->op_first->op_sibling;
7192 if (kid->op_type != OP_NULL)
7193 Perl_croak(aTHX_ "panic: ck_grep");
7194 kid = kUNOP->op_first;
7197 NewOp(1101, gwop, 1, LOGOP);
7198 gwop->op_type = type;
7199 gwop->op_ppaddr = PL_ppaddr[type];
7200 gwop->op_first = listkids(o);
7201 gwop->op_flags |= OPf_KIDS;
7202 gwop->op_other = LINKLIST(kid);
7203 kid->op_next = (OP*)gwop;
7204 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7205 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7206 o->op_private = gwop->op_private = 0;
7207 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7210 o->op_private = gwop->op_private = OPpGREP_LEX;
7211 gwop->op_targ = o->op_targ = offset;
7214 kid = cLISTOPo->op_first->op_sibling;
7215 if (!kid || !kid->op_sibling)
7216 return too_few_arguments(o,OP_DESC(o));
7217 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7218 mod(kid, OP_GREPSTART);
7224 Perl_ck_index(pTHX_ OP *o)
7226 PERL_ARGS_ASSERT_CK_INDEX;
7228 if (o->op_flags & OPf_KIDS) {
7229 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7231 kid = kid->op_sibling; /* get past "big" */
7232 if (kid && kid->op_type == OP_CONST)
7233 fbm_compile(((SVOP*)kid)->op_sv, 0);
7239 Perl_ck_lfun(pTHX_ OP *o)
7241 const OPCODE type = o->op_type;
7243 PERL_ARGS_ASSERT_CK_LFUN;
7245 return modkids(ck_fun(o), type);
7249 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7251 PERL_ARGS_ASSERT_CK_DEFINED;
7253 if ((o->op_flags & OPf_KIDS)) {
7254 switch (cUNOPo->op_first->op_type) {
7256 /* This is needed for
7257 if (defined %stash::)
7258 to work. Do not break Tk.
7260 break; /* Globals via GV can be undef */
7262 case OP_AASSIGN: /* Is this a good idea? */
7263 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7264 "defined(@array) is deprecated");
7265 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7266 "\t(Maybe you should just omit the defined()?)\n");
7270 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7271 "defined(%%hash) is deprecated");
7272 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7273 "\t(Maybe you should just omit the defined()?)\n");
7284 Perl_ck_readline(pTHX_ OP *o)
7286 PERL_ARGS_ASSERT_CK_READLINE;
7288 if (!(o->op_flags & OPf_KIDS)) {
7290 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7292 op_getmad(o,newop,'O');
7302 Perl_ck_rfun(pTHX_ OP *o)
7304 const OPCODE type = o->op_type;
7306 PERL_ARGS_ASSERT_CK_RFUN;
7308 return refkids(ck_fun(o), type);
7312 Perl_ck_listiob(pTHX_ OP *o)
7316 PERL_ARGS_ASSERT_CK_LISTIOB;
7318 kid = cLISTOPo->op_first;
7321 kid = cLISTOPo->op_first;
7323 if (kid->op_type == OP_PUSHMARK)
7324 kid = kid->op_sibling;
7325 if (kid && o->op_flags & OPf_STACKED)
7326 kid = kid->op_sibling;
7327 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7328 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7329 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7330 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7331 cLISTOPo->op_first->op_sibling = kid;
7332 cLISTOPo->op_last = kid;
7333 kid = kid->op_sibling;
7338 append_elem(o->op_type, o, newDEFSVOP());
7344 Perl_ck_smartmatch(pTHX_ OP *o)
7347 if (0 == (o->op_flags & OPf_SPECIAL)) {
7348 OP *first = cBINOPo->op_first;
7349 OP *second = first->op_sibling;
7351 /* Implicitly take a reference to an array or hash */
7352 first->op_sibling = NULL;
7353 first = cBINOPo->op_first = ref_array_or_hash(first);
7354 second = first->op_sibling = ref_array_or_hash(second);
7356 /* Implicitly take a reference to a regular expression */
7357 if (first->op_type == OP_MATCH) {
7358 first->op_type = OP_QR;
7359 first->op_ppaddr = PL_ppaddr[OP_QR];
7361 if (second->op_type == OP_MATCH) {
7362 second->op_type = OP_QR;
7363 second->op_ppaddr = PL_ppaddr[OP_QR];
7372 Perl_ck_sassign(pTHX_ OP *o)
7375 OP * const kid = cLISTOPo->op_first;
7377 PERL_ARGS_ASSERT_CK_SASSIGN;
7379 /* has a disposable target? */
7380 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7381 && !(kid->op_flags & OPf_STACKED)
7382 /* Cannot steal the second time! */
7383 && !(kid->op_private & OPpTARGET_MY)
7384 /* Keep the full thing for madskills */
7388 OP * const kkid = kid->op_sibling;
7390 /* Can just relocate the target. */
7391 if (kkid && kkid->op_type == OP_PADSV
7392 && !(kkid->op_private & OPpLVAL_INTRO))
7394 kid->op_targ = kkid->op_targ;
7396 /* Now we do not need PADSV and SASSIGN. */
7397 kid->op_sibling = o->op_sibling; /* NULL */
7398 cLISTOPo->op_first = NULL;
7401 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7405 if (kid->op_sibling) {
7406 OP *kkid = kid->op_sibling;
7407 if (kkid->op_type == OP_PADSV
7408 && (kkid->op_private & OPpLVAL_INTRO)
7409 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7410 const PADOFFSET target = kkid->op_targ;
7411 OP *const other = newOP(OP_PADSV,
7413 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7414 OP *const first = newOP(OP_NULL, 0);
7415 OP *const nullop = newCONDOP(0, first, o, other);
7416 OP *const condop = first->op_next;
7417 /* hijacking PADSTALE for uninitialized state variables */
7418 SvPADSTALE_on(PAD_SVl(target));
7420 condop->op_type = OP_ONCE;
7421 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7422 condop->op_targ = target;
7423 other->op_targ = target;
7425 /* Because we change the type of the op here, we will skip the
7426 assinment binop->op_last = binop->op_first->op_sibling; at the
7427 end of Perl_newBINOP(). So need to do it here. */
7428 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7437 Perl_ck_match(pTHX_ OP *o)
7441 PERL_ARGS_ASSERT_CK_MATCH;
7443 if (o->op_type != OP_QR && PL_compcv) {
7444 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7445 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7446 o->op_targ = offset;
7447 o->op_private |= OPpTARGET_MY;
7450 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7451 o->op_private |= OPpRUNTIME;
7456 Perl_ck_method(pTHX_ OP *o)
7458 OP * const kid = cUNOPo->op_first;
7460 PERL_ARGS_ASSERT_CK_METHOD;
7462 if (kid->op_type == OP_CONST) {
7463 SV* sv = kSVOP->op_sv;
7464 const char * const method = SvPVX_const(sv);
7465 if (!(strchr(method, ':') || strchr(method, '\''))) {
7467 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7468 sv = newSVpvn_share(method, SvCUR(sv), 0);
7471 kSVOP->op_sv = NULL;
7473 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7475 op_getmad(o,cmop,'O');
7486 Perl_ck_null(pTHX_ OP *o)
7488 PERL_ARGS_ASSERT_CK_NULL;
7489 PERL_UNUSED_CONTEXT;
7494 Perl_ck_open(pTHX_ OP *o)
7497 HV * const table = GvHV(PL_hintgv);
7499 PERL_ARGS_ASSERT_CK_OPEN;
7502 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7505 const char *d = SvPV_const(*svp, len);
7506 const I32 mode = mode_from_discipline(d, len);
7507 if (mode & O_BINARY)
7508 o->op_private |= OPpOPEN_IN_RAW;
7509 else if (mode & O_TEXT)
7510 o->op_private |= OPpOPEN_IN_CRLF;
7513 svp = hv_fetchs(table, "open_OUT", FALSE);
7516 const char *d = SvPV_const(*svp, len);
7517 const I32 mode = mode_from_discipline(d, len);
7518 if (mode & O_BINARY)
7519 o->op_private |= OPpOPEN_OUT_RAW;
7520 else if (mode & O_TEXT)
7521 o->op_private |= OPpOPEN_OUT_CRLF;
7524 if (o->op_type == OP_BACKTICK) {
7525 if (!(o->op_flags & OPf_KIDS)) {
7526 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7528 op_getmad(o,newop,'O');
7537 /* In case of three-arg dup open remove strictness
7538 * from the last arg if it is a bareword. */
7539 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7540 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7544 if ((last->op_type == OP_CONST) && /* The bareword. */
7545 (last->op_private & OPpCONST_BARE) &&
7546 (last->op_private & OPpCONST_STRICT) &&
7547 (oa = first->op_sibling) && /* The fh. */
7548 (oa = oa->op_sibling) && /* The mode. */
7549 (oa->op_type == OP_CONST) &&
7550 SvPOK(((SVOP*)oa)->op_sv) &&
7551 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7552 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7553 (last == oa->op_sibling)) /* The bareword. */
7554 last->op_private &= ~OPpCONST_STRICT;
7560 Perl_ck_repeat(pTHX_ OP *o)
7562 PERL_ARGS_ASSERT_CK_REPEAT;
7564 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7565 o->op_private |= OPpREPEAT_DOLIST;
7566 cBINOPo->op_first = force_list(cBINOPo->op_first);
7574 Perl_ck_require(pTHX_ OP *o)
7579 PERL_ARGS_ASSERT_CK_REQUIRE;
7581 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7582 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7584 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7585 SV * const sv = kid->op_sv;
7586 U32 was_readonly = SvREADONLY(sv);
7593 sv_force_normal_flags(sv, 0);
7594 assert(!SvREADONLY(sv));
7604 for (; s < end; s++) {
7605 if (*s == ':' && s[1] == ':') {
7607 Move(s+2, s+1, end - s - 1, char);
7612 sv_catpvs(sv, ".pm");
7613 SvFLAGS(sv) |= was_readonly;
7617 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7618 /* handle override, if any */
7619 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7620 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7621 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7622 gv = gvp ? *gvp : NULL;
7626 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7627 OP * const kid = cUNOPo->op_first;
7630 cUNOPo->op_first = 0;
7634 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7635 append_elem(OP_LIST, kid,
7636 scalar(newUNOP(OP_RV2CV, 0,
7639 op_getmad(o,newop,'O');
7647 Perl_ck_return(pTHX_ OP *o)
7652 PERL_ARGS_ASSERT_CK_RETURN;
7654 kid = cLISTOPo->op_first->op_sibling;
7655 if (CvLVALUE(PL_compcv)) {
7656 for (; kid; kid = kid->op_sibling)
7657 mod(kid, OP_LEAVESUBLV);
7659 for (; kid; kid = kid->op_sibling)
7660 if ((kid->op_type == OP_NULL)
7661 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7662 /* This is a do block */
7663 OP *op = kUNOP->op_first;
7664 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7665 op = cUNOPx(op)->op_first;
7666 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7667 /* Force the use of the caller's context */
7668 op->op_flags |= OPf_SPECIAL;
7677 Perl_ck_select(pTHX_ OP *o)
7682 PERL_ARGS_ASSERT_CK_SELECT;
7684 if (o->op_flags & OPf_KIDS) {
7685 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7686 if (kid && kid->op_sibling) {
7687 o->op_type = OP_SSELECT;
7688 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7690 return fold_constants(o);
7694 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7695 if (kid && kid->op_type == OP_RV2GV)
7696 kid->op_private &= ~HINT_STRICT_REFS;
7701 Perl_ck_shift(pTHX_ OP *o)
7704 const I32 type = o->op_type;
7706 PERL_ARGS_ASSERT_CK_SHIFT;
7708 if (!(o->op_flags & OPf_KIDS)) {
7709 OP *argop = newUNOP(OP_RV2AV, 0,
7710 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7712 OP * const oldo = o;
7713 o = newUNOP(type, 0, scalar(argop));
7714 op_getmad(oldo,o,'O');
7718 return newUNOP(type, 0, scalar(argop));
7721 return scalar(modkids(ck_fun(o), type));
7725 Perl_ck_sort(pTHX_ OP *o)
7730 PERL_ARGS_ASSERT_CK_SORT;
7732 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7733 HV * const hinthv = GvHV(PL_hintgv);
7735 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7737 const I32 sorthints = (I32)SvIV(*svp);
7738 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7739 o->op_private |= OPpSORT_QSORT;
7740 if ((sorthints & HINT_SORT_STABLE) != 0)
7741 o->op_private |= OPpSORT_STABLE;
7746 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7748 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7749 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7751 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7753 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7755 if (kid->op_type == OP_SCOPE) {
7759 else if (kid->op_type == OP_LEAVE) {
7760 if (o->op_type == OP_SORT) {
7761 op_null(kid); /* wipe out leave */
7764 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7765 if (k->op_next == kid)
7767 /* don't descend into loops */
7768 else if (k->op_type == OP_ENTERLOOP
7769 || k->op_type == OP_ENTERITER)
7771 k = cLOOPx(k)->op_lastop;
7776 kid->op_next = 0; /* just disconnect the leave */
7777 k = kLISTOP->op_first;
7782 if (o->op_type == OP_SORT) {
7783 /* provide scalar context for comparison function/block */
7789 o->op_flags |= OPf_SPECIAL;
7791 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7794 firstkid = firstkid->op_sibling;
7797 /* provide list context for arguments */
7798 if (o->op_type == OP_SORT)
7805 S_simplify_sort(pTHX_ OP *o)
7808 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7814 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7816 if (!(o->op_flags & OPf_STACKED))
7818 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7819 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7820 kid = kUNOP->op_first; /* get past null */
7821 if (kid->op_type != OP_SCOPE)
7823 kid = kLISTOP->op_last; /* get past scope */
7824 switch(kid->op_type) {
7832 k = kid; /* remember this node*/
7833 if (kBINOP->op_first->op_type != OP_RV2SV)
7835 kid = kBINOP->op_first; /* get past cmp */
7836 if (kUNOP->op_first->op_type != OP_GV)
7838 kid = kUNOP->op_first; /* get past rv2sv */
7840 if (GvSTASH(gv) != PL_curstash)
7842 gvname = GvNAME(gv);
7843 if (*gvname == 'a' && gvname[1] == '\0')
7845 else if (*gvname == 'b' && gvname[1] == '\0')
7850 kid = k; /* back to cmp */
7851 if (kBINOP->op_last->op_type != OP_RV2SV)
7853 kid = kBINOP->op_last; /* down to 2nd arg */
7854 if (kUNOP->op_first->op_type != OP_GV)
7856 kid = kUNOP->op_first; /* get past rv2sv */
7858 if (GvSTASH(gv) != PL_curstash)
7860 gvname = GvNAME(gv);
7862 ? !(*gvname == 'a' && gvname[1] == '\0')
7863 : !(*gvname == 'b' && gvname[1] == '\0'))
7865 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7867 o->op_private |= OPpSORT_DESCEND;
7868 if (k->op_type == OP_NCMP)
7869 o->op_private |= OPpSORT_NUMERIC;
7870 if (k->op_type == OP_I_NCMP)
7871 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7872 kid = cLISTOPo->op_first->op_sibling;
7873 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7875 op_getmad(kid,o,'S'); /* then delete it */
7877 op_free(kid); /* then delete it */
7882 Perl_ck_split(pTHX_ OP *o)
7887 PERL_ARGS_ASSERT_CK_SPLIT;
7889 if (o->op_flags & OPf_STACKED)
7890 return no_fh_allowed(o);
7892 kid = cLISTOPo->op_first;
7893 if (kid->op_type != OP_NULL)
7894 Perl_croak(aTHX_ "panic: ck_split");
7895 kid = kid->op_sibling;
7896 op_free(cLISTOPo->op_first);
7897 cLISTOPo->op_first = kid;
7899 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7900 cLISTOPo->op_last = kid; /* There was only one element previously */
7903 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7904 OP * const sibl = kid->op_sibling;
7905 kid->op_sibling = 0;
7906 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7907 if (cLISTOPo->op_first == cLISTOPo->op_last)
7908 cLISTOPo->op_last = kid;
7909 cLISTOPo->op_first = kid;
7910 kid->op_sibling = sibl;
7913 kid->op_type = OP_PUSHRE;
7914 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7916 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7917 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7918 "Use of /g modifier is meaningless in split");
7921 if (!kid->op_sibling)
7922 append_elem(OP_SPLIT, o, newDEFSVOP());
7924 kid = kid->op_sibling;
7927 if (!kid->op_sibling)
7928 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7929 assert(kid->op_sibling);
7931 kid = kid->op_sibling;
7934 if (kid->op_sibling)
7935 return too_many_arguments(o,OP_DESC(o));
7941 Perl_ck_join(pTHX_ OP *o)
7943 const OP * const kid = cLISTOPo->op_first->op_sibling;
7945 PERL_ARGS_ASSERT_CK_JOIN;
7947 if (kid && kid->op_type == OP_MATCH) {
7948 if (ckWARN(WARN_SYNTAX)) {
7949 const REGEXP *re = PM_GETRE(kPMOP);
7950 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7951 const STRLEN len = re ? RX_PRELEN(re) : 6;
7952 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7953 "/%.*s/ should probably be written as \"%.*s\"",
7954 (int)len, pmstr, (int)len, pmstr);
7961 Perl_ck_subr(pTHX_ OP *o)
7964 OP *prev = ((cUNOPo->op_first->op_sibling)
7965 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7966 OP *o2 = prev->op_sibling;
7968 const char *proto = NULL;
7969 const char *proto_end = NULL;
7974 I32 contextclass = 0;
7975 const char *e = NULL;
7978 PERL_ARGS_ASSERT_CK_SUBR;
7980 o->op_private |= OPpENTERSUB_HASTARG;
7981 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7982 if (cvop->op_type == OP_RV2CV) {
7983 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7984 op_null(cvop); /* disable rv2cv */
7985 if (!(o->op_private & OPpENTERSUB_AMPER)) {
7986 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7988 switch (tmpop->op_type) {
7990 gv = cGVOPx_gv(tmpop);
7993 tmpop->op_private |= OPpEARLY_CV;
7996 SV *sv = cSVOPx_sv(tmpop);
7997 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8001 if (cv && SvPOK(cv)) {
8003 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8004 proto = SvPV(MUTABLE_SV(cv), len);
8005 proto_end = proto + len;
8009 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8010 if (o2->op_type == OP_CONST)
8011 o2->op_private &= ~OPpCONST_STRICT;
8012 else if (o2->op_type == OP_LIST) {
8013 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8014 if (sib && sib->op_type == OP_CONST)
8015 sib->op_private &= ~OPpCONST_STRICT;
8018 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8019 if (PERLDB_SUB && PL_curstash != PL_debstash)
8020 o->op_private |= OPpENTERSUB_DB;
8021 while (o2 != cvop) {
8023 if (PL_madskills && o2->op_type == OP_STUB) {
8024 o2 = o2->op_sibling;
8027 if (PL_madskills && o2->op_type == OP_NULL)
8028 o3 = ((UNOP*)o2)->op_first;
8032 if (proto >= proto_end)
8033 return too_many_arguments(o, gv_ename(namegv));
8041 /* _ must be at the end */
8042 if (proto[1] && proto[1] != ';')
8057 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8059 arg == 1 ? "block or sub {}" : "sub {}",
8060 gv_ename(namegv), o3);
8063 /* '*' allows any scalar type, including bareword */
8066 if (o3->op_type == OP_RV2GV)
8067 goto wrapref; /* autoconvert GLOB -> GLOBref */
8068 else if (o3->op_type == OP_CONST)
8069 o3->op_private &= ~OPpCONST_STRICT;
8070 else if (o3->op_type == OP_ENTERSUB) {
8071 /* accidental subroutine, revert to bareword */
8072 OP *gvop = ((UNOP*)o3)->op_first;
8073 if (gvop && gvop->op_type == OP_NULL) {
8074 gvop = ((UNOP*)gvop)->op_first;
8076 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8079 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8080 (gvop = ((UNOP*)gvop)->op_first) &&
8081 gvop->op_type == OP_GV)
8083 GV * const gv = cGVOPx_gv(gvop);
8084 OP * const sibling = o2->op_sibling;
8085 SV * const n = newSVpvs("");
8087 OP * const oldo2 = o2;
8091 gv_fullname4(n, gv, "", FALSE);
8092 o2 = newSVOP(OP_CONST, 0, n);
8093 op_getmad(oldo2,o2,'O');
8094 prev->op_sibling = o2;
8095 o2->op_sibling = sibling;
8111 if (contextclass++ == 0) {
8112 e = strchr(proto, ']');
8113 if (!e || e == proto)
8122 const char *p = proto;
8123 const char *const end = proto;
8125 while (*--p != '[') {}
8126 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8128 gv_ename(namegv), o3);
8133 if (o3->op_type == OP_RV2GV)
8136 bad_type(arg, "symbol", gv_ename(namegv), o3);
8139 if (o3->op_type == OP_ENTERSUB)
8142 bad_type(arg, "subroutine entry", gv_ename(namegv),
8146 if (o3->op_type == OP_RV2SV ||
8147 o3->op_type == OP_PADSV ||
8148 o3->op_type == OP_HELEM ||
8149 o3->op_type == OP_AELEM)
8152 bad_type(arg, "scalar", gv_ename(namegv), o3);
8155 if (o3->op_type == OP_RV2AV ||
8156 o3->op_type == OP_PADAV)
8159 bad_type(arg, "array", gv_ename(namegv), o3);
8162 if (o3->op_type == OP_RV2HV ||
8163 o3->op_type == OP_PADHV)
8166 bad_type(arg, "hash", gv_ename(namegv), o3);
8171 OP* const sib = kid->op_sibling;
8172 kid->op_sibling = 0;
8173 o2 = newUNOP(OP_REFGEN, 0, kid);
8174 o2->op_sibling = sib;
8175 prev->op_sibling = o2;
8177 if (contextclass && e) {
8192 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8193 gv_ename(namegv), SVfARG(cv));
8198 mod(o2, OP_ENTERSUB);
8200 o2 = o2->op_sibling;
8202 if (o2 == cvop && proto && *proto == '_') {
8203 /* generate an access to $_ */
8205 o2->op_sibling = prev->op_sibling;
8206 prev->op_sibling = o2; /* instead of cvop */
8208 if (proto && !optional && proto_end > proto &&
8209 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8210 return too_few_arguments(o, gv_ename(namegv));
8213 OP * const oldo = o;
8217 o=newSVOP(OP_CONST, 0, newSViv(0));
8218 op_getmad(oldo,o,'O');
8224 Perl_ck_svconst(pTHX_ OP *o)
8226 PERL_ARGS_ASSERT_CK_SVCONST;
8227 PERL_UNUSED_CONTEXT;
8228 SvREADONLY_on(cSVOPo->op_sv);
8233 Perl_ck_chdir(pTHX_ OP *o)
8235 if (o->op_flags & OPf_KIDS) {
8236 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8238 if (kid && kid->op_type == OP_CONST &&
8239 (kid->op_private & OPpCONST_BARE))
8241 o->op_flags |= OPf_SPECIAL;
8242 kid->op_private &= ~OPpCONST_STRICT;
8249 Perl_ck_trunc(pTHX_ OP *o)
8251 PERL_ARGS_ASSERT_CK_TRUNC;
8253 if (o->op_flags & OPf_KIDS) {
8254 SVOP *kid = (SVOP*)cUNOPo->op_first;
8256 if (kid->op_type == OP_NULL)
8257 kid = (SVOP*)kid->op_sibling;
8258 if (kid && kid->op_type == OP_CONST &&
8259 (kid->op_private & OPpCONST_BARE))
8261 o->op_flags |= OPf_SPECIAL;
8262 kid->op_private &= ~OPpCONST_STRICT;
8269 Perl_ck_unpack(pTHX_ OP *o)
8271 OP *kid = cLISTOPo->op_first;
8273 PERL_ARGS_ASSERT_CK_UNPACK;
8275 if (kid->op_sibling) {
8276 kid = kid->op_sibling;
8277 if (!kid->op_sibling)
8278 kid->op_sibling = newDEFSVOP();
8284 Perl_ck_substr(pTHX_ OP *o)
8286 PERL_ARGS_ASSERT_CK_SUBSTR;
8289 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8290 OP *kid = cLISTOPo->op_first;
8292 if (kid->op_type == OP_NULL)
8293 kid = kid->op_sibling;
8295 kid->op_flags |= OPf_MOD;
8302 Perl_ck_each(pTHX_ OP *o)
8305 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8307 PERL_ARGS_ASSERT_CK_EACH;
8310 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8311 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8312 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8313 o->op_type = new_type;
8314 o->op_ppaddr = PL_ppaddr[new_type];
8316 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8317 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8319 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8326 /* caller is supposed to assign the return to the
8327 container of the rep_op var */
8329 S_opt_scalarhv(pTHX_ OP *rep_op) {
8332 PERL_ARGS_ASSERT_OPT_SCALARHV;
8334 NewOp(1101, unop, 1, UNOP);
8335 unop->op_type = (OPCODE)OP_BOOLKEYS;
8336 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8337 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8338 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8339 unop->op_first = rep_op;
8340 unop->op_next = rep_op->op_next;
8341 rep_op->op_next = (OP*)unop;
8342 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8343 unop->op_sibling = rep_op->op_sibling;
8344 rep_op->op_sibling = NULL;
8345 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8346 if (rep_op->op_type == OP_PADHV) {
8347 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8348 rep_op->op_flags |= OPf_WANT_LIST;
8353 /* Checks if o acts as an in-place operator on an array. oright points to the
8354 * beginning of the right-hand side. Returns the left-hand side of the
8355 * assignment if o acts in-place, or NULL otherwise. */
8358 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8362 PERL_ARGS_ASSERT_IS_INPLACE_AV;
8365 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8366 || oright->op_next != o
8367 || (oright->op_private & OPpLVAL_INTRO)
8371 /* o2 follows the chain of op_nexts through the LHS of the
8372 * assign (if any) to the aassign op itself */
8374 if (!o2 || o2->op_type != OP_NULL)
8377 if (!o2 || o2->op_type != OP_PUSHMARK)
8380 if (o2 && o2->op_type == OP_GV)
8383 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8384 || (o2->op_private & OPpLVAL_INTRO)
8389 if (!o2 || o2->op_type != OP_NULL)
8392 if (!o2 || o2->op_type != OP_AASSIGN
8393 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8396 /* check that the sort is the first arg on RHS of assign */
8398 o2 = cUNOPx(o2)->op_first;
8399 if (!o2 || o2->op_type != OP_NULL)
8401 o2 = cUNOPx(o2)->op_first;
8402 if (!o2 || o2->op_type != OP_PUSHMARK)
8404 if (o2->op_sibling != o)
8407 /* check the array is the same on both sides */
8408 if (oleft->op_type == OP_RV2AV) {
8409 if (oright->op_type != OP_RV2AV
8410 || !cUNOPx(oright)->op_first
8411 || cUNOPx(oright)->op_first->op_type != OP_GV
8412 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8413 cGVOPx_gv(cUNOPx(oright)->op_first)
8417 else if (oright->op_type != OP_PADAV
8418 || oright->op_targ != oleft->op_targ
8425 /* A peephole optimizer. We visit the ops in the order they're to execute.
8426 * See the comments at the top of this file for more details about when
8427 * peep() is called */
8430 Perl_peep(pTHX_ register OP *o)
8433 register OP* oldop = NULL;
8435 if (!o || o->op_opt)
8439 SAVEVPTR(PL_curcop);
8440 for (; o; o = o->op_next) {
8443 /* By default, this op has now been optimised. A couple of cases below
8444 clear this again. */
8447 switch (o->op_type) {
8450 PL_curcop = ((COP*)o); /* for warnings */
8454 if (cSVOPo->op_private & OPpCONST_STRICT)
8455 no_bareword_allowed(o);
8458 case OP_METHOD_NAMED:
8459 /* Relocate sv to the pad for thread safety.
8460 * Despite being a "constant", the SV is written to,
8461 * for reference counts, sv_upgrade() etc. */
8463 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8464 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8465 /* If op_sv is already a PADTMP then it is being used by
8466 * some pad, so make a copy. */
8467 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8468 SvREADONLY_on(PAD_SVl(ix));
8469 SvREFCNT_dec(cSVOPo->op_sv);
8471 else if (o->op_type != OP_METHOD_NAMED
8472 && cSVOPo->op_sv == &PL_sv_undef) {
8473 /* PL_sv_undef is hack - it's unsafe to store it in the
8474 AV that is the pad, because av_fetch treats values of
8475 PL_sv_undef as a "free" AV entry and will merrily
8476 replace them with a new SV, causing pad_alloc to think
8477 that this pad slot is free. (When, clearly, it is not)
8479 SvOK_off(PAD_SVl(ix));
8480 SvPADTMP_on(PAD_SVl(ix));
8481 SvREADONLY_on(PAD_SVl(ix));
8484 SvREFCNT_dec(PAD_SVl(ix));
8485 SvPADTMP_on(cSVOPo->op_sv);
8486 PAD_SETSV(ix, cSVOPo->op_sv);
8487 /* XXX I don't know how this isn't readonly already. */
8488 SvREADONLY_on(PAD_SVl(ix));
8490 cSVOPo->op_sv = NULL;
8497 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8498 if (o->op_next->op_private & OPpTARGET_MY) {
8499 if (o->op_flags & OPf_STACKED) /* chained concats */
8500 break; /* ignore_optimization */
8502 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8503 o->op_targ = o->op_next->op_targ;
8504 o->op_next->op_targ = 0;
8505 o->op_private |= OPpTARGET_MY;
8508 op_null(o->op_next);
8512 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8513 break; /* Scalar stub must produce undef. List stub is noop */
8517 if (o->op_targ == OP_NEXTSTATE
8518 || o->op_targ == OP_DBSTATE)
8520 PL_curcop = ((COP*)o);
8522 /* XXX: We avoid setting op_seq here to prevent later calls
8523 to peep() from mistakenly concluding that optimisation
8524 has already occurred. This doesn't fix the real problem,
8525 though (See 20010220.007). AMS 20010719 */
8526 /* op_seq functionality is now replaced by op_opt */
8533 if (oldop && o->op_next) {
8534 oldop->op_next = o->op_next;
8542 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8543 OP* const pop = (o->op_type == OP_PADAV) ?
8544 o->op_next : o->op_next->op_next;
8546 if (pop && pop->op_type == OP_CONST &&
8547 ((PL_op = pop->op_next)) &&
8548 pop->op_next->op_type == OP_AELEM &&
8549 !(pop->op_next->op_private &
8550 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8551 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8556 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8557 no_bareword_allowed(pop);
8558 if (o->op_type == OP_GV)
8559 op_null(o->op_next);
8560 op_null(pop->op_next);
8562 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8563 o->op_next = pop->op_next->op_next;
8564 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8565 o->op_private = (U8)i;
8566 if (o->op_type == OP_GV) {
8571 o->op_flags |= OPf_SPECIAL;
8572 o->op_type = OP_AELEMFAST;
8577 if (o->op_next->op_type == OP_RV2SV) {
8578 if (!(o->op_next->op_private & OPpDEREF)) {
8579 op_null(o->op_next);
8580 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8582 o->op_next = o->op_next->op_next;
8583 o->op_type = OP_GVSV;
8584 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8587 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8588 GV * const gv = cGVOPo_gv;
8589 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8590 /* XXX could check prototype here instead of just carping */
8591 SV * const sv = sv_newmortal();
8592 gv_efullname3(sv, gv, NULL);
8593 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8594 "%"SVf"() called too early to check prototype",
8598 else if (o->op_next->op_type == OP_READLINE
8599 && o->op_next->op_next->op_type == OP_CONCAT
8600 && (o->op_next->op_next->op_flags & OPf_STACKED))
8602 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8603 o->op_type = OP_RCATLINE;
8604 o->op_flags |= OPf_STACKED;
8605 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8606 op_null(o->op_next->op_next);
8607 op_null(o->op_next);
8617 fop = cUNOP->op_first;
8625 fop = cLOGOP->op_first;
8626 sop = fop->op_sibling;
8627 while (cLOGOP->op_other->op_type == OP_NULL)
8628 cLOGOP->op_other = cLOGOP->op_other->op_next;
8629 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8633 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8635 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8640 if (!(nop->op_flags && OPf_WANT_VOID)) {
8641 while (nop && nop->op_next) {
8642 switch (nop->op_next->op_type) {
8647 lop = nop = nop->op_next;
8658 if (lop->op_flags && OPf_WANT_VOID) {
8659 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8660 cLOGOP->op_first = opt_scalarhv(fop);
8661 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8662 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8678 while (cLOGOP->op_other->op_type == OP_NULL)
8679 cLOGOP->op_other = cLOGOP->op_other->op_next;
8680 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8685 while (cLOOP->op_redoop->op_type == OP_NULL)
8686 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8687 peep(cLOOP->op_redoop);
8688 while (cLOOP->op_nextop->op_type == OP_NULL)
8689 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8690 peep(cLOOP->op_nextop);
8691 while (cLOOP->op_lastop->op_type == OP_NULL)
8692 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8693 peep(cLOOP->op_lastop);
8697 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8698 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8699 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8700 cPMOP->op_pmstashstartu.op_pmreplstart
8701 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8702 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8706 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8707 && ckWARN(WARN_SYNTAX))
8709 if (o->op_next->op_sibling) {
8710 const OPCODE type = o->op_next->op_sibling->op_type;
8711 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8712 const line_t oldline = CopLINE(PL_curcop);
8713 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8714 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8715 "Statement unlikely to be reached");
8716 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8717 "\t(Maybe you meant system() when you said exec()?)\n");
8718 CopLINE_set(PL_curcop, oldline);
8729 const char *key = NULL;
8732 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8735 /* Make the CONST have a shared SV */
8736 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8737 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8738 key = SvPV_const(sv, keylen);
8739 lexname = newSVpvn_share(key,
8740 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8746 if ((o->op_private & (OPpLVAL_INTRO)))
8749 rop = (UNOP*)((BINOP*)o)->op_first;
8750 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8752 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8753 if (!SvPAD_TYPED(lexname))
8755 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8756 if (!fields || !GvHV(*fields))
8758 key = SvPV_const(*svp, keylen);
8759 if (!hv_fetch(GvHV(*fields), key,
8760 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8762 Perl_croak(aTHX_ "No such class field \"%s\" "
8763 "in variable %s of type %s",
8764 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8777 SVOP *first_key_op, *key_op;
8779 if ((o->op_private & (OPpLVAL_INTRO))
8780 /* I bet there's always a pushmark... */
8781 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8782 /* hmmm, no optimization if list contains only one key. */
8784 rop = (UNOP*)((LISTOP*)o)->op_last;
8785 if (rop->op_type != OP_RV2HV)
8787 if (rop->op_first->op_type == OP_PADSV)
8788 /* @$hash{qw(keys here)} */
8789 rop = (UNOP*)rop->op_first;
8791 /* @{$hash}{qw(keys here)} */
8792 if (rop->op_first->op_type == OP_SCOPE
8793 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8795 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8801 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8802 if (!SvPAD_TYPED(lexname))
8804 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8805 if (!fields || !GvHV(*fields))
8807 /* Again guessing that the pushmark can be jumped over.... */
8808 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8809 ->op_first->op_sibling;
8810 for (key_op = first_key_op; key_op;
8811 key_op = (SVOP*)key_op->op_sibling) {
8812 if (key_op->op_type != OP_CONST)
8814 svp = cSVOPx_svp(key_op);
8815 key = SvPV_const(*svp, keylen);
8816 if (!hv_fetch(GvHV(*fields), key,
8817 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8819 Perl_croak(aTHX_ "No such class field \"%s\" "
8820 "in variable %s of type %s",
8821 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8828 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8832 /* check that RHS of sort is a single plain array */
8833 OP *oright = cUNOPo->op_first;
8834 if (!oright || oright->op_type != OP_PUSHMARK)
8837 /* reverse sort ... can be optimised. */
8838 if (!cUNOPo->op_sibling) {
8839 /* Nothing follows us on the list. */
8840 OP * const reverse = o->op_next;
8842 if (reverse->op_type == OP_REVERSE &&
8843 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8844 OP * const pushmark = cUNOPx(reverse)->op_first;
8845 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8846 && (cUNOPx(pushmark)->op_sibling == o)) {
8847 /* reverse -> pushmark -> sort */
8848 o->op_private |= OPpSORT_REVERSE;
8850 pushmark->op_next = oright->op_next;
8856 /* make @a = sort @a act in-place */
8858 oright = cUNOPx(oright)->op_sibling;
8861 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8862 oright = cUNOPx(oright)->op_sibling;
8865 oleft = is_inplace_av(o, oright);
8869 /* transfer MODishness etc from LHS arg to RHS arg */
8870 oright->op_flags = oleft->op_flags;
8871 o->op_private |= OPpSORT_INPLACE;
8873 /* excise push->gv->rv2av->null->aassign */
8874 o2 = o->op_next->op_next;
8875 op_null(o2); /* PUSHMARK */
8877 if (o2->op_type == OP_GV) {
8878 op_null(o2); /* GV */
8881 op_null(o2); /* RV2AV or PADAV */
8882 o2 = o2->op_next->op_next;
8883 op_null(o2); /* AASSIGN */
8885 o->op_next = o2->op_next;
8891 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8894 LISTOP *enter, *exlist;
8896 /* @a = reverse @a */
8897 if ((oright = cLISTOPo->op_first)
8898 && (oright->op_type == OP_PUSHMARK)
8899 && (oright = oright->op_sibling)
8900 && (oleft = is_inplace_av(o, oright))) {
8903 /* transfer MODishness etc from LHS arg to RHS arg */
8904 oright->op_flags = oleft->op_flags;
8905 o->op_private |= OPpREVERSE_INPLACE;
8907 /* excise push->gv->rv2av->null->aassign */
8908 o2 = o->op_next->op_next;
8909 op_null(o2); /* PUSHMARK */
8911 if (o2->op_type == OP_GV) {
8912 op_null(o2); /* GV */
8915 op_null(o2); /* RV2AV or PADAV */
8916 o2 = o2->op_next->op_next;
8917 op_null(o2); /* AASSIGN */
8919 o->op_next = o2->op_next;
8923 enter = (LISTOP *) o->op_next;
8926 if (enter->op_type == OP_NULL) {
8927 enter = (LISTOP *) enter->op_next;
8931 /* for $a (...) will have OP_GV then OP_RV2GV here.
8932 for (...) just has an OP_GV. */
8933 if (enter->op_type == OP_GV) {
8934 gvop = (OP *) enter;
8935 enter = (LISTOP *) enter->op_next;
8938 if (enter->op_type == OP_RV2GV) {
8939 enter = (LISTOP *) enter->op_next;
8945 if (enter->op_type != OP_ENTERITER)
8948 iter = enter->op_next;
8949 if (!iter || iter->op_type != OP_ITER)
8952 expushmark = enter->op_first;
8953 if (!expushmark || expushmark->op_type != OP_NULL
8954 || expushmark->op_targ != OP_PUSHMARK)
8957 exlist = (LISTOP *) expushmark->op_sibling;
8958 if (!exlist || exlist->op_type != OP_NULL
8959 || exlist->op_targ != OP_LIST)
8962 if (exlist->op_last != o) {
8963 /* Mmm. Was expecting to point back to this op. */
8966 theirmark = exlist->op_first;
8967 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8970 if (theirmark->op_sibling != o) {
8971 /* There's something between the mark and the reverse, eg
8972 for (1, reverse (...))
8977 ourmark = ((LISTOP *)o)->op_first;
8978 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8981 ourlast = ((LISTOP *)o)->op_last;
8982 if (!ourlast || ourlast->op_next != o)
8985 rv2av = ourmark->op_sibling;
8986 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8987 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8988 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8989 /* We're just reversing a single array. */
8990 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8991 enter->op_flags |= OPf_STACKED;
8994 /* We don't have control over who points to theirmark, so sacrifice
8996 theirmark->op_next = ourmark->op_next;
8997 theirmark->op_flags = ourmark->op_flags;
8998 ourlast->op_next = gvop ? gvop : (OP *) enter;
9001 enter->op_private |= OPpITER_REVERSED;
9002 iter->op_private |= OPpITER_REVERSED;
9009 UNOP *refgen, *rv2cv;
9012 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9015 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9018 rv2gv = ((BINOP *)o)->op_last;
9019 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9022 refgen = (UNOP *)((BINOP *)o)->op_first;
9024 if (!refgen || refgen->op_type != OP_REFGEN)
9027 exlist = (LISTOP *)refgen->op_first;
9028 if (!exlist || exlist->op_type != OP_NULL
9029 || exlist->op_targ != OP_LIST)
9032 if (exlist->op_first->op_type != OP_PUSHMARK)
9035 rv2cv = (UNOP*)exlist->op_last;
9037 if (rv2cv->op_type != OP_RV2CV)
9040 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9041 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9042 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9044 o->op_private |= OPpASSIGN_CV_TO_GV;
9045 rv2gv->op_private |= OPpDONT_INIT_GV;
9046 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9054 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9055 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9065 Perl_custom_op_name(pTHX_ const OP* o)
9068 const IV index = PTR2IV(o->op_ppaddr);
9072 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9074 if (!PL_custom_op_names) /* This probably shouldn't happen */
9075 return (char *)PL_op_name[OP_CUSTOM];
9077 keysv = sv_2mortal(newSViv(index));
9079 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9081 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9083 return SvPV_nolen(HeVAL(he));
9087 Perl_custom_op_desc(pTHX_ const OP* o)
9090 const IV index = PTR2IV(o->op_ppaddr);
9094 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9096 if (!PL_custom_op_descs)
9097 return (char *)PL_op_desc[OP_CUSTOM];
9099 keysv = sv_2mortal(newSViv(index));
9101 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9103 return (char *)PL_op_desc[OP_CUSTOM];
9105 return SvPV_nolen(HeVAL(he));
9110 /* Efficient sub that returns a constant scalar value. */
9112 const_sv_xsub(pTHX_ CV* cv)
9116 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9120 /* diag_listed_as: SKIPME */
9121 Perl_croak(aTHX_ "usage: %s::%s()",
9122 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9135 * c-indentation-style: bsd
9137 * indent-tabs-mode: t
9140 * ex: set ts=8 sts=4 sw=4 noet: