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 /* check for duplicate declaration */
410 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
412 /* allocate a spare slot and store the name in that slot */
414 off = pad_add_name(name,
415 PL_parser->in_my_stash,
417 /* $_ is always in main::, even with our */
418 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
422 PL_parser->in_my == KEY_state
424 /* anon sub prototypes contains state vars should always be cloned,
425 * otherwise the state var would be shared between anon subs */
427 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
428 CvCLONE_on(PL_compcv);
433 /* free the body of an op without examining its contents.
434 * Always use this rather than FreeOp directly */
437 S_op_destroy(pTHX_ OP *o)
439 if (o->op_latefree) {
447 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
449 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
455 Perl_op_free(pTHX_ OP *o)
462 if (o->op_latefreed) {
469 if (o->op_private & OPpREFCOUNTED) {
480 refcnt = OpREFCNT_dec(o);
483 /* Need to find and remove any pattern match ops from the list
484 we maintain for reset(). */
485 find_and_forget_pmops(o);
495 /* Call the op_free hook if it has been set. Do it now so that it's called
496 * at the right time for refcounted ops, but still before all of the kids
500 if (o->op_flags & OPf_KIDS) {
501 register OP *kid, *nextkid;
502 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
503 nextkid = kid->op_sibling; /* Get before next freeing kid */
508 #ifdef PERL_DEBUG_READONLY_OPS
512 /* COP* is not cleared by op_clear() so that we may track line
513 * numbers etc even after null() */
514 if (type == OP_NEXTSTATE || type == OP_DBSTATE
515 || (type == OP_NULL /* the COP might have been null'ed */
516 && ((OPCODE)o->op_targ == OP_NEXTSTATE
517 || (OPCODE)o->op_targ == OP_DBSTATE))) {
522 type = (OPCODE)o->op_targ;
525 if (o->op_latefree) {
531 #ifdef DEBUG_LEAKING_SCALARS
538 Perl_op_clear(pTHX_ OP *o)
543 PERL_ARGS_ASSERT_OP_CLEAR;
546 /* if (o->op_madprop && o->op_madprop->mad_next)
548 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
549 "modification of a read only value" for a reason I can't fathom why.
550 It's the "" stringification of $_, where $_ was set to '' in a foreach
551 loop, but it defies simplification into a small test case.
552 However, commenting them out has caused ext/List/Util/t/weak.t to fail
555 mad_free(o->op_madprop);
561 switch (o->op_type) {
562 case OP_NULL: /* Was holding old type, if any. */
563 if (PL_madskills && o->op_targ != OP_NULL) {
564 o->op_type = (Optype)o->op_targ;
568 case OP_ENTEREVAL: /* Was holding hints. */
572 if (!(o->op_flags & OPf_REF)
573 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
579 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
580 /* not an OP_PADAV replacement */
581 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
586 /* It's possible during global destruction that the GV is freed
587 before the optree. Whilst the SvREFCNT_inc is happy to bump from
588 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
589 will trigger an assertion failure, because the entry to sv_clear
590 checks that the scalar is not already freed. A check of for
591 !SvIS_FREED(gv) turns out to be invalid, because during global
592 destruction the reference count can be forced down to zero
593 (with SVf_BREAK set). In which case raising to 1 and then
594 dropping to 0 triggers cleanup before it should happen. I
595 *think* that this might actually be a general, systematic,
596 weakness of the whole idea of SVf_BREAK, in that code *is*
597 allowed to raise and lower references during global destruction,
598 so any *valid* code that happens to do this during global
599 destruction might well trigger premature cleanup. */
600 bool still_valid = gv && SvREFCNT(gv);
603 SvREFCNT_inc_simple_void(gv);
605 if (cPADOPo->op_padix > 0) {
606 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
607 * may still exist on the pad */
608 pad_swipe(cPADOPo->op_padix, TRUE);
609 cPADOPo->op_padix = 0;
612 SvREFCNT_dec(cSVOPo->op_sv);
613 cSVOPo->op_sv = NULL;
616 int try_downgrade = SvREFCNT(gv) == 2;
619 gv_try_downgrade(gv);
623 case OP_METHOD_NAMED:
626 SvREFCNT_dec(cSVOPo->op_sv);
627 cSVOPo->op_sv = NULL;
630 Even if op_clear does a pad_free for the target of the op,
631 pad_free doesn't actually remove the sv that exists in the pad;
632 instead it lives on. This results in that it could be reused as
633 a target later on when the pad was reallocated.
636 pad_swipe(o->op_targ,1);
645 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
649 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
651 if (cPADOPo->op_padix > 0) {
652 pad_swipe(cPADOPo->op_padix, TRUE);
653 cPADOPo->op_padix = 0;
656 SvREFCNT_dec(cSVOPo->op_sv);
657 cSVOPo->op_sv = NULL;
661 PerlMemShared_free(cPVOPo->op_pv);
662 cPVOPo->op_pv = NULL;
666 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
670 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
671 /* No GvIN_PAD_off here, because other references may still
672 * exist on the pad */
673 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
676 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
682 forget_pmop(cPMOPo, 1);
683 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
684 /* we use the same protection as the "SAFE" version of the PM_ macros
685 * here since sv_clean_all might release some PMOPs
686 * after PL_regex_padav has been cleared
687 * and the clearing of PL_regex_padav needs to
688 * happen before sv_clean_all
691 if(PL_regex_pad) { /* We could be in destruction */
692 const IV offset = (cPMOPo)->op_pmoffset;
693 ReREFCNT_dec(PM_GETRE(cPMOPo));
694 PL_regex_pad[offset] = &PL_sv_undef;
695 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
699 ReREFCNT_dec(PM_GETRE(cPMOPo));
700 PM_SETRE(cPMOPo, NULL);
706 if (o->op_targ > 0) {
707 pad_free(o->op_targ);
713 S_cop_free(pTHX_ COP* cop)
715 PERL_ARGS_ASSERT_COP_FREE;
719 if (! specialWARN(cop->cop_warnings))
720 PerlMemShared_free(cop->cop_warnings);
721 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
725 S_forget_pmop(pTHX_ PMOP *const o
731 HV * const pmstash = PmopSTASH(o);
733 PERL_ARGS_ASSERT_FORGET_PMOP;
735 if (pmstash && !SvIS_FREED(pmstash)) {
736 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
738 PMOP **const array = (PMOP**) mg->mg_ptr;
739 U32 count = mg->mg_len / sizeof(PMOP**);
744 /* Found it. Move the entry at the end to overwrite it. */
745 array[i] = array[--count];
746 mg->mg_len = count * sizeof(PMOP**);
747 /* Could realloc smaller at this point always, but probably
748 not worth it. Probably worth free()ing if we're the
751 Safefree(mg->mg_ptr);
768 S_find_and_forget_pmops(pTHX_ OP *o)
770 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
772 if (o->op_flags & OPf_KIDS) {
773 OP *kid = cUNOPo->op_first;
775 switch (kid->op_type) {
780 forget_pmop((PMOP*)kid, 0);
782 find_and_forget_pmops(kid);
783 kid = kid->op_sibling;
789 Perl_op_null(pTHX_ OP *o)
793 PERL_ARGS_ASSERT_OP_NULL;
795 if (o->op_type == OP_NULL)
799 o->op_targ = o->op_type;
800 o->op_type = OP_NULL;
801 o->op_ppaddr = PL_ppaddr[OP_NULL];
805 Perl_op_refcnt_lock(pTHX)
813 Perl_op_refcnt_unlock(pTHX)
820 /* Contextualizers */
822 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
825 S_linklist(pTHX_ OP *o)
829 PERL_ARGS_ASSERT_LINKLIST;
834 /* establish postfix order */
835 first = cUNOPo->op_first;
838 o->op_next = LINKLIST(first);
841 if (kid->op_sibling) {
842 kid->op_next = LINKLIST(kid->op_sibling);
843 kid = kid->op_sibling;
857 S_scalarkids(pTHX_ OP *o)
859 if (o && o->op_flags & OPf_KIDS) {
861 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
868 S_scalarboolean(pTHX_ OP *o)
872 PERL_ARGS_ASSERT_SCALARBOOLEAN;
874 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
875 if (ckWARN(WARN_SYNTAX)) {
876 const line_t oldline = CopLINE(PL_curcop);
878 if (PL_parser && PL_parser->copline != NOLINE)
879 CopLINE_set(PL_curcop, PL_parser->copline);
880 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
881 CopLINE_set(PL_curcop, oldline);
888 Perl_scalar(pTHX_ OP *o)
893 /* assumes no premature commitment */
894 if (!o || (PL_parser && PL_parser->error_count)
895 || (o->op_flags & OPf_WANT)
896 || o->op_type == OP_RETURN)
901 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
903 switch (o->op_type) {
905 scalar(cBINOPo->op_first);
910 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
920 if (o->op_flags & OPf_KIDS) {
921 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
927 kid = cLISTOPo->op_first;
929 while ((kid = kid->op_sibling)) {
935 PL_curcop = &PL_compiling;
940 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
946 PL_curcop = &PL_compiling;
949 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
956 Perl_scalarvoid(pTHX_ OP *o)
960 const char* useless = NULL;
964 PERL_ARGS_ASSERT_SCALARVOID;
966 /* trailing mad null ops don't count as "there" for void processing */
968 o->op_type != OP_NULL &&
970 o->op_sibling->op_type == OP_NULL)
973 for (sib = o->op_sibling;
974 sib && sib->op_type == OP_NULL;
975 sib = sib->op_sibling) ;
981 if (o->op_type == OP_NEXTSTATE
982 || o->op_type == OP_DBSTATE
983 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
984 || o->op_targ == OP_DBSTATE)))
985 PL_curcop = (COP*)o; /* for warning below */
987 /* assumes no premature commitment */
988 want = o->op_flags & OPf_WANT;
989 if ((want && want != OPf_WANT_SCALAR)
990 || (PL_parser && PL_parser->error_count)
991 || o->op_type == OP_RETURN)
996 if ((o->op_private & OPpTARGET_MY)
997 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
999 return scalar(o); /* As if inside SASSIGN */
1002 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1004 switch (o->op_type) {
1006 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1010 if (o->op_flags & OPf_STACKED)
1014 if (o->op_private == 4)
1057 case OP_GETSOCKNAME:
1058 case OP_GETPEERNAME:
1063 case OP_GETPRIORITY:
1087 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1088 /* Otherwise it's "Useless use of grep iterator" */
1089 useless = OP_DESC(o);
1093 kid = cUNOPo->op_first;
1094 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1095 kid->op_type != OP_TRANS) {
1098 useless = "negative pattern binding (!~)";
1105 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1106 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1107 useless = "a variable";
1112 if (cSVOPo->op_private & OPpCONST_STRICT)
1113 no_bareword_allowed(o);
1115 if (ckWARN(WARN_VOID)) {
1117 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1118 "a constant (%"SVf")", sv));
1119 useless = SvPV_nolen(msv);
1122 useless = "a constant (undef)";
1123 if (o->op_private & OPpCONST_ARYBASE)
1125 /* don't warn on optimised away booleans, eg
1126 * use constant Foo, 5; Foo || print; */
1127 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1129 /* the constants 0 and 1 are permitted as they are
1130 conventionally used as dummies in constructs like
1131 1 while some_condition_with_side_effects; */
1132 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1134 else if (SvPOK(sv)) {
1135 /* perl4's way of mixing documentation and code
1136 (before the invention of POD) was based on a
1137 trick to mix nroff and perl code. The trick was
1138 built upon these three nroff macros being used in
1139 void context. The pink camel has the details in
1140 the script wrapman near page 319. */
1141 const char * const maybe_macro = SvPVX_const(sv);
1142 if (strnEQ(maybe_macro, "di", 2) ||
1143 strnEQ(maybe_macro, "ds", 2) ||
1144 strnEQ(maybe_macro, "ig", 2))
1149 op_null(o); /* don't execute or even remember it */
1153 o->op_type = OP_PREINC; /* pre-increment is faster */
1154 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1158 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1159 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1163 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1164 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1168 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1169 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1174 kid = cLOGOPo->op_first;
1175 if (kid->op_type == OP_NOT
1176 && (kid->op_flags & OPf_KIDS)
1178 if (o->op_type == OP_AND) {
1180 o->op_ppaddr = PL_ppaddr[OP_OR];
1182 o->op_type = OP_AND;
1183 o->op_ppaddr = PL_ppaddr[OP_AND];
1192 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1197 if (o->op_flags & OPf_STACKED)
1204 if (!(o->op_flags & OPf_KIDS))
1215 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1222 /* all requires must return a boolean value */
1223 o->op_flags &= ~OPf_WANT;
1229 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1234 S_listkids(pTHX_ OP *o)
1236 if (o && o->op_flags & OPf_KIDS) {
1238 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1245 Perl_list(pTHX_ OP *o)
1250 /* assumes no premature commitment */
1251 if (!o || (o->op_flags & OPf_WANT)
1252 || (PL_parser && PL_parser->error_count)
1253 || o->op_type == OP_RETURN)
1258 if ((o->op_private & OPpTARGET_MY)
1259 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1261 return o; /* As if inside SASSIGN */
1264 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1266 switch (o->op_type) {
1269 list(cBINOPo->op_first);
1274 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1282 if (!(o->op_flags & OPf_KIDS))
1284 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1285 list(cBINOPo->op_first);
1286 return gen_constant_list(o);
1293 kid = cLISTOPo->op_first;
1295 while ((kid = kid->op_sibling)) {
1296 if (kid->op_sibling)
1301 PL_curcop = &PL_compiling;
1305 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1306 if (kid->op_sibling)
1311 PL_curcop = &PL_compiling;
1314 /* all requires must return a boolean value */
1315 o->op_flags &= ~OPf_WANT;
1322 S_scalarseq(pTHX_ OP *o)
1326 const OPCODE type = o->op_type;
1328 if (type == OP_LINESEQ || type == OP_SCOPE ||
1329 type == OP_LEAVE || type == OP_LEAVETRY)
1332 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1333 if (kid->op_sibling) {
1337 PL_curcop = &PL_compiling;
1339 o->op_flags &= ~OPf_PARENS;
1340 if (PL_hints & HINT_BLOCK_SCOPE)
1341 o->op_flags |= OPf_PARENS;
1344 o = newOP(OP_STUB, 0);
1349 S_modkids(pTHX_ OP *o, I32 type)
1351 if (o && o->op_flags & OPf_KIDS) {
1353 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1359 /* Propagate lvalue ("modifiable") context to an op and its children.
1360 * 'type' represents the context type, roughly based on the type of op that
1361 * would do the modifying, although local() is represented by OP_NULL.
1362 * It's responsible for detecting things that can't be modified, flag
1363 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1364 * might have to vivify a reference in $x), and so on.
1366 * For example, "$a+1 = 2" would cause mod() to be called with o being
1367 * OP_ADD and type being OP_SASSIGN, and would output an error.
1371 Perl_mod(pTHX_ OP *o, I32 type)
1375 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1378 if (!o || (PL_parser && PL_parser->error_count))
1381 if ((o->op_private & OPpTARGET_MY)
1382 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1387 switch (o->op_type) {
1393 if (!(o->op_private & OPpCONST_ARYBASE))
1396 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1397 CopARYBASE_set(&PL_compiling,
1398 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1402 SAVECOPARYBASE(&PL_compiling);
1403 CopARYBASE_set(&PL_compiling, 0);
1405 else if (type == OP_REFGEN)
1408 Perl_croak(aTHX_ "That use of $[ is unsupported");
1411 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1415 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1416 !(o->op_flags & OPf_STACKED)) {
1417 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1418 /* The default is to set op_private to the number of children,
1419 which for a UNOP such as RV2CV is always 1. And w're using
1420 the bit for a flag in RV2CV, so we need it clear. */
1421 o->op_private &= ~1;
1422 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1423 assert(cUNOPo->op_first->op_type == OP_NULL);
1424 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1427 else if (o->op_private & OPpENTERSUB_NOMOD)
1429 else { /* lvalue subroutine call */
1430 o->op_private |= OPpLVAL_INTRO;
1431 PL_modcount = RETURN_UNLIMITED_NUMBER;
1432 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1433 /* Backward compatibility mode: */
1434 o->op_private |= OPpENTERSUB_INARGS;
1437 else { /* Compile-time error message: */
1438 OP *kid = cUNOPo->op_first;
1442 if (kid->op_type != OP_PUSHMARK) {
1443 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1445 "panic: unexpected lvalue entersub "
1446 "args: type/targ %ld:%"UVuf,
1447 (long)kid->op_type, (UV)kid->op_targ);
1448 kid = kLISTOP->op_first;
1450 while (kid->op_sibling)
1451 kid = kid->op_sibling;
1452 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1454 if (kid->op_type == OP_METHOD_NAMED
1455 || kid->op_type == OP_METHOD)
1459 NewOp(1101, newop, 1, UNOP);
1460 newop->op_type = OP_RV2CV;
1461 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1462 newop->op_first = NULL;
1463 newop->op_next = (OP*)newop;
1464 kid->op_sibling = (OP*)newop;
1465 newop->op_private |= OPpLVAL_INTRO;
1466 newop->op_private &= ~1;
1470 if (kid->op_type != OP_RV2CV)
1472 "panic: unexpected lvalue entersub "
1473 "entry via type/targ %ld:%"UVuf,
1474 (long)kid->op_type, (UV)kid->op_targ);
1475 kid->op_private |= OPpLVAL_INTRO;
1476 break; /* Postpone until runtime */
1480 kid = kUNOP->op_first;
1481 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1482 kid = kUNOP->op_first;
1483 if (kid->op_type == OP_NULL)
1485 "Unexpected constant lvalue entersub "
1486 "entry via type/targ %ld:%"UVuf,
1487 (long)kid->op_type, (UV)kid->op_targ);
1488 if (kid->op_type != OP_GV) {
1489 /* Restore RV2CV to check lvalueness */
1491 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1492 okid->op_next = kid->op_next;
1493 kid->op_next = okid;
1496 okid->op_next = NULL;
1497 okid->op_type = OP_RV2CV;
1499 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1500 okid->op_private |= OPpLVAL_INTRO;
1501 okid->op_private &= ~1;
1505 cv = GvCV(kGVOP_gv);
1515 /* grep, foreach, subcalls, refgen */
1516 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1518 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1519 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1521 : (o->op_type == OP_ENTERSUB
1522 ? "non-lvalue subroutine call"
1524 type ? PL_op_desc[type] : "local"));
1538 case OP_RIGHT_SHIFT:
1547 if (!(o->op_flags & OPf_STACKED))
1554 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1560 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1561 PL_modcount = RETURN_UNLIMITED_NUMBER;
1562 return o; /* Treat \(@foo) like ordinary list. */
1566 if (scalar_mod_type(o, type))
1568 ref(cUNOPo->op_first, o->op_type);
1572 if (type == OP_LEAVESUBLV)
1573 o->op_private |= OPpMAYBE_LVSUB;
1579 PL_modcount = RETURN_UNLIMITED_NUMBER;
1582 PL_hints |= HINT_BLOCK_SCOPE;
1583 if (type == OP_LEAVESUBLV)
1584 o->op_private |= OPpMAYBE_LVSUB;
1588 ref(cUNOPo->op_first, o->op_type);
1592 PL_hints |= HINT_BLOCK_SCOPE;
1607 PL_modcount = RETURN_UNLIMITED_NUMBER;
1608 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1609 return o; /* Treat \(@foo) like ordinary list. */
1610 if (scalar_mod_type(o, type))
1612 if (type == OP_LEAVESUBLV)
1613 o->op_private |= OPpMAYBE_LVSUB;
1617 if (!type) /* local() */
1618 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1619 PAD_COMPNAME_PV(o->op_targ));
1627 if (type != OP_SASSIGN)
1631 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1636 if (type == OP_LEAVESUBLV)
1637 o->op_private |= OPpMAYBE_LVSUB;
1639 pad_free(o->op_targ);
1640 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1641 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1642 if (o->op_flags & OPf_KIDS)
1643 mod(cBINOPo->op_first->op_sibling, type);
1648 ref(cBINOPo->op_first, o->op_type);
1649 if (type == OP_ENTERSUB &&
1650 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1651 o->op_private |= OPpLVAL_DEFER;
1652 if (type == OP_LEAVESUBLV)
1653 o->op_private |= OPpMAYBE_LVSUB;
1663 if (o->op_flags & OPf_KIDS)
1664 mod(cLISTOPo->op_last, type);
1669 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1671 else if (!(o->op_flags & OPf_KIDS))
1673 if (o->op_targ != OP_LIST) {
1674 mod(cBINOPo->op_first, type);
1680 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1685 if (type != OP_LEAVESUBLV)
1687 break; /* mod()ing was handled by ck_return() */
1690 /* [20011101.069] File test operators interpret OPf_REF to mean that
1691 their argument is a filehandle; thus \stat(".") should not set
1693 if (type == OP_REFGEN &&
1694 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1697 if (type != OP_LEAVESUBLV)
1698 o->op_flags |= OPf_MOD;
1700 if (type == OP_AASSIGN || type == OP_SASSIGN)
1701 o->op_flags |= OPf_SPECIAL|OPf_REF;
1702 else if (!type) { /* local() */
1705 o->op_private |= OPpLVAL_INTRO;
1706 o->op_flags &= ~OPf_SPECIAL;
1707 PL_hints |= HINT_BLOCK_SCOPE;
1712 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1713 "Useless localization of %s", OP_DESC(o));
1716 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1717 && type != OP_LEAVESUBLV)
1718 o->op_flags |= OPf_REF;
1723 S_scalar_mod_type(const OP *o, I32 type)
1725 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1729 if (o->op_type == OP_RV2GV)
1753 case OP_RIGHT_SHIFT:
1773 S_is_handle_constructor(const OP *o, I32 numargs)
1775 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1777 switch (o->op_type) {
1785 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1798 S_refkids(pTHX_ OP *o, I32 type)
1800 if (o && o->op_flags & OPf_KIDS) {
1802 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1809 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1814 PERL_ARGS_ASSERT_DOREF;
1816 if (!o || (PL_parser && PL_parser->error_count))
1819 switch (o->op_type) {
1821 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1822 !(o->op_flags & OPf_STACKED)) {
1823 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1824 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1825 assert(cUNOPo->op_first->op_type == OP_NULL);
1826 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1827 o->op_flags |= OPf_SPECIAL;
1828 o->op_private &= ~1;
1833 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1834 doref(kid, type, set_op_ref);
1837 if (type == OP_DEFINED)
1838 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1839 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1842 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1843 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1844 : type == OP_RV2HV ? OPpDEREF_HV
1846 o->op_flags |= OPf_MOD;
1853 o->op_flags |= OPf_REF;
1856 if (type == OP_DEFINED)
1857 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1858 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1864 o->op_flags |= OPf_REF;
1869 if (!(o->op_flags & OPf_KIDS))
1871 doref(cBINOPo->op_first, type, set_op_ref);
1875 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1876 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1877 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1878 : type == OP_RV2HV ? OPpDEREF_HV
1880 o->op_flags |= OPf_MOD;
1890 if (!(o->op_flags & OPf_KIDS))
1892 doref(cLISTOPo->op_last, type, set_op_ref);
1902 S_dup_attrlist(pTHX_ OP *o)
1907 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1909 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1910 * where the first kid is OP_PUSHMARK and the remaining ones
1911 * are OP_CONST. We need to push the OP_CONST values.
1913 if (o->op_type == OP_CONST)
1914 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1916 else if (o->op_type == OP_NULL)
1920 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1922 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1923 if (o->op_type == OP_CONST)
1924 rop = append_elem(OP_LIST, rop,
1925 newSVOP(OP_CONST, o->op_flags,
1926 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1933 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1938 PERL_ARGS_ASSERT_APPLY_ATTRS;
1940 /* fake up C<use attributes $pkg,$rv,@attrs> */
1941 ENTER; /* need to protect against side-effects of 'use' */
1942 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1944 #define ATTRSMODULE "attributes"
1945 #define ATTRSMODULE_PM "attributes.pm"
1948 /* Don't force the C<use> if we don't need it. */
1949 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1950 if (svp && *svp != &PL_sv_undef)
1951 NOOP; /* already in %INC */
1953 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1954 newSVpvs(ATTRSMODULE), NULL);
1957 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1958 newSVpvs(ATTRSMODULE),
1960 prepend_elem(OP_LIST,
1961 newSVOP(OP_CONST, 0, stashsv),
1962 prepend_elem(OP_LIST,
1963 newSVOP(OP_CONST, 0,
1965 dup_attrlist(attrs))));
1971 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1974 OP *pack, *imop, *arg;
1977 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1982 assert(target->op_type == OP_PADSV ||
1983 target->op_type == OP_PADHV ||
1984 target->op_type == OP_PADAV);
1986 /* Ensure that attributes.pm is loaded. */
1987 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1989 /* Need package name for method call. */
1990 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1992 /* Build up the real arg-list. */
1993 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1995 arg = newOP(OP_PADSV, 0);
1996 arg->op_targ = target->op_targ;
1997 arg = prepend_elem(OP_LIST,
1998 newSVOP(OP_CONST, 0, stashsv),
1999 prepend_elem(OP_LIST,
2000 newUNOP(OP_REFGEN, 0,
2001 mod(arg, OP_REFGEN)),
2002 dup_attrlist(attrs)));
2004 /* Fake up a method call to import */
2005 meth = newSVpvs_share("import");
2006 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2007 append_elem(OP_LIST,
2008 prepend_elem(OP_LIST, pack, list(arg)),
2009 newSVOP(OP_METHOD_NAMED, 0, meth)));
2010 imop->op_private |= OPpENTERSUB_NOMOD;
2012 /* Combine the ops. */
2013 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2017 =notfor apidoc apply_attrs_string
2019 Attempts to apply a list of attributes specified by the C<attrstr> and
2020 C<len> arguments to the subroutine identified by the C<cv> argument which
2021 is expected to be associated with the package identified by the C<stashpv>
2022 argument (see L<attributes>). It gets this wrong, though, in that it
2023 does not correctly identify the boundaries of the individual attribute
2024 specifications within C<attrstr>. This is not really intended for the
2025 public API, but has to be listed here for systems such as AIX which
2026 need an explicit export list for symbols. (It's called from XS code
2027 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2028 to respect attribute syntax properly would be welcome.
2034 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2035 const char *attrstr, STRLEN len)
2039 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2042 len = strlen(attrstr);
2046 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2048 const char * const sstr = attrstr;
2049 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2050 attrs = append_elem(OP_LIST, attrs,
2051 newSVOP(OP_CONST, 0,
2052 newSVpvn(sstr, attrstr-sstr)));
2056 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2057 newSVpvs(ATTRSMODULE),
2058 NULL, prepend_elem(OP_LIST,
2059 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2060 prepend_elem(OP_LIST,
2061 newSVOP(OP_CONST, 0,
2062 newRV(MUTABLE_SV(cv))),
2067 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2072 PERL_ARGS_ASSERT_MY_KID;
2074 if (!o || (PL_parser && PL_parser->error_count))
2078 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2079 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2083 if (type == OP_LIST) {
2085 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2086 my_kid(kid, attrs, imopsp);
2087 } else if (type == OP_UNDEF
2093 } else if (type == OP_RV2SV || /* "our" declaration */
2095 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2096 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2097 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2099 PL_parser->in_my == KEY_our
2101 : PL_parser->in_my == KEY_state ? "state" : "my"));
2103 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2104 PL_parser->in_my = FALSE;
2105 PL_parser->in_my_stash = NULL;
2106 apply_attrs(GvSTASH(gv),
2107 (type == OP_RV2SV ? GvSV(gv) :
2108 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2109 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2112 o->op_private |= OPpOUR_INTRO;
2115 else if (type != OP_PADSV &&
2118 type != OP_PUSHMARK)
2120 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2122 PL_parser->in_my == KEY_our
2124 : PL_parser->in_my == KEY_state ? "state" : "my"));
2127 else if (attrs && type != OP_PUSHMARK) {
2130 PL_parser->in_my = FALSE;
2131 PL_parser->in_my_stash = NULL;
2133 /* check for C<my Dog $spot> when deciding package */
2134 stash = PAD_COMPNAME_TYPE(o->op_targ);
2136 stash = PL_curstash;
2137 apply_attrs_my(stash, o, attrs, imopsp);
2139 o->op_flags |= OPf_MOD;
2140 o->op_private |= OPpLVAL_INTRO;
2141 if (PL_parser->in_my == KEY_state)
2142 o->op_private |= OPpPAD_STATE;
2147 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2151 int maybe_scalar = 0;
2153 PERL_ARGS_ASSERT_MY_ATTRS;
2155 /* [perl #17376]: this appears to be premature, and results in code such as
2156 C< our(%x); > executing in list mode rather than void mode */
2158 if (o->op_flags & OPf_PARENS)
2168 o = my_kid(o, attrs, &rops);
2170 if (maybe_scalar && o->op_type == OP_PADSV) {
2171 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2172 o->op_private |= OPpLVAL_INTRO;
2175 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2177 PL_parser->in_my = FALSE;
2178 PL_parser->in_my_stash = NULL;
2183 Perl_sawparens(pTHX_ OP *o)
2185 PERL_UNUSED_CONTEXT;
2187 o->op_flags |= OPf_PARENS;
2192 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2196 const OPCODE ltype = left->op_type;
2197 const OPCODE rtype = right->op_type;
2199 PERL_ARGS_ASSERT_BIND_MATCH;
2201 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2202 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2204 const char * const desc
2205 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2206 ? (int)rtype : OP_MATCH];
2207 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2208 ? "@array" : "%hash");
2209 Perl_warner(aTHX_ packWARN(WARN_MISC),
2210 "Applying %s to %s will act on scalar(%s)",
2211 desc, sample, sample);
2214 if (rtype == OP_CONST &&
2215 cSVOPx(right)->op_private & OPpCONST_BARE &&
2216 cSVOPx(right)->op_private & OPpCONST_STRICT)
2218 no_bareword_allowed(right);
2221 ismatchop = rtype == OP_MATCH ||
2222 rtype == OP_SUBST ||
2224 if (ismatchop && right->op_private & OPpTARGET_MY) {
2226 right->op_private &= ~OPpTARGET_MY;
2228 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2231 right->op_flags |= OPf_STACKED;
2232 if (rtype != OP_MATCH &&
2233 ! (rtype == OP_TRANS &&
2234 right->op_private & OPpTRANS_IDENTICAL))
2235 newleft = mod(left, rtype);
2238 if (right->op_type == OP_TRANS)
2239 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2241 o = prepend_elem(rtype, scalar(newleft), right);
2243 return newUNOP(OP_NOT, 0, scalar(o));
2247 return bind_match(type, left,
2248 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2252 Perl_invert(pTHX_ OP *o)
2256 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2260 Perl_scope(pTHX_ OP *o)
2264 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2265 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2266 o->op_type = OP_LEAVE;
2267 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2269 else if (o->op_type == OP_LINESEQ) {
2271 o->op_type = OP_SCOPE;
2272 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2273 kid = ((LISTOP*)o)->op_first;
2274 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2277 /* The following deals with things like 'do {1 for 1}' */
2278 kid = kid->op_sibling;
2280 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2285 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2291 Perl_block_start(pTHX_ int full)
2294 const int retval = PL_savestack_ix;
2295 pad_block_start(full);
2297 PL_hints &= ~HINT_BLOCK_SCOPE;
2298 SAVECOMPILEWARNINGS();
2299 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2304 Perl_block_end(pTHX_ I32 floor, OP *seq)
2307 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2308 OP* const retval = scalarseq(seq);
2310 CopHINTS_set(&PL_compiling, PL_hints);
2312 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2321 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2322 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2323 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2326 OP * const o = newOP(OP_PADSV, 0);
2327 o->op_targ = offset;
2333 Perl_newPROG(pTHX_ OP *o)
2337 PERL_ARGS_ASSERT_NEWPROG;
2342 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2343 ((PL_in_eval & EVAL_KEEPERR)
2344 ? OPf_SPECIAL : 0), o);
2345 PL_eval_start = linklist(PL_eval_root);
2346 PL_eval_root->op_private |= OPpREFCOUNTED;
2347 OpREFCNT_set(PL_eval_root, 1);
2348 PL_eval_root->op_next = 0;
2349 CALL_PEEP(PL_eval_start);
2352 if (o->op_type == OP_STUB) {
2353 PL_comppad_name = 0;
2355 S_op_destroy(aTHX_ o);
2358 PL_main_root = scope(sawparens(scalarvoid(o)));
2359 PL_curcop = &PL_compiling;
2360 PL_main_start = LINKLIST(PL_main_root);
2361 PL_main_root->op_private |= OPpREFCOUNTED;
2362 OpREFCNT_set(PL_main_root, 1);
2363 PL_main_root->op_next = 0;
2364 CALL_PEEP(PL_main_start);
2367 /* Register with debugger */
2369 CV * const cv = get_cvs("DB::postponed", 0);
2373 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2375 call_sv(MUTABLE_SV(cv), G_DISCARD);
2382 Perl_localize(pTHX_ OP *o, I32 lex)
2386 PERL_ARGS_ASSERT_LOCALIZE;
2388 if (o->op_flags & OPf_PARENS)
2389 /* [perl #17376]: this appears to be premature, and results in code such as
2390 C< our(%x); > executing in list mode rather than void mode */
2397 if ( PL_parser->bufptr > PL_parser->oldbufptr
2398 && PL_parser->bufptr[-1] == ','
2399 && ckWARN(WARN_PARENTHESIS))
2401 char *s = PL_parser->bufptr;
2404 /* some heuristics to detect a potential error */
2405 while (*s && (strchr(", \t\n", *s)))
2409 if (*s && strchr("@$%*", *s) && *++s
2410 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2413 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2415 while (*s && (strchr(", \t\n", *s)))
2421 if (sigil && (*s == ';' || *s == '=')) {
2422 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2423 "Parentheses missing around \"%s\" list",
2425 ? (PL_parser->in_my == KEY_our
2427 : PL_parser->in_my == KEY_state
2437 o = mod(o, OP_NULL); /* a bit kludgey */
2438 PL_parser->in_my = FALSE;
2439 PL_parser->in_my_stash = NULL;
2444 Perl_jmaybe(pTHX_ OP *o)
2446 PERL_ARGS_ASSERT_JMAYBE;
2448 if (o->op_type == OP_LIST) {
2450 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2451 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2457 S_fold_constants(pTHX_ register OP *o)
2460 register OP * VOL curop;
2462 VOL I32 type = o->op_type;
2467 SV * const oldwarnhook = PL_warnhook;
2468 SV * const olddiehook = PL_diehook;
2472 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2474 if (PL_opargs[type] & OA_RETSCALAR)
2476 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2477 o->op_targ = pad_alloc(type, SVs_PADTMP);
2479 /* integerize op, unless it happens to be C<-foo>.
2480 * XXX should pp_i_negate() do magic string negation instead? */
2481 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2482 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2483 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2485 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2488 if (!(PL_opargs[type] & OA_FOLDCONST))
2493 /* XXX might want a ck_negate() for this */
2494 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2505 /* XXX what about the numeric ops? */
2506 if (PL_hints & HINT_LOCALE)
2511 if (PL_parser && PL_parser->error_count)
2512 goto nope; /* Don't try to run w/ errors */
2514 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2515 const OPCODE type = curop->op_type;
2516 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2518 type != OP_SCALAR &&
2520 type != OP_PUSHMARK)
2526 curop = LINKLIST(o);
2527 old_next = o->op_next;
2531 oldscope = PL_scopestack_ix;
2532 create_eval_scope(G_FAKINGEVAL);
2534 /* Verify that we don't need to save it: */
2535 assert(PL_curcop == &PL_compiling);
2536 StructCopy(&PL_compiling, ¬_compiling, COP);
2537 PL_curcop = ¬_compiling;
2538 /* The above ensures that we run with all the correct hints of the
2539 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2540 assert(IN_PERL_RUNTIME);
2541 PL_warnhook = PERL_WARNHOOK_FATAL;
2548 sv = *(PL_stack_sp--);
2549 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2550 pad_swipe(o->op_targ, FALSE);
2551 else if (SvTEMP(sv)) { /* grab mortal temp? */
2552 SvREFCNT_inc_simple_void(sv);
2557 /* Something tried to die. Abandon constant folding. */
2558 /* Pretend the error never happened. */
2560 o->op_next = old_next;
2564 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2565 PL_warnhook = oldwarnhook;
2566 PL_diehook = olddiehook;
2567 /* XXX note that this croak may fail as we've already blown away
2568 * the stack - eg any nested evals */
2569 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2572 PL_warnhook = oldwarnhook;
2573 PL_diehook = olddiehook;
2574 PL_curcop = &PL_compiling;
2576 if (PL_scopestack_ix > oldscope)
2577 delete_eval_scope();
2586 if (type == OP_RV2GV)
2587 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2589 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2590 op_getmad(o,newop,'f');
2598 S_gen_constant_list(pTHX_ register OP *o)
2602 const I32 oldtmps_floor = PL_tmps_floor;
2605 if (PL_parser && PL_parser->error_count)
2606 return o; /* Don't attempt to run with errors */
2608 PL_op = curop = LINKLIST(o);
2614 assert (!(curop->op_flags & OPf_SPECIAL));
2615 assert(curop->op_type == OP_RANGE);
2617 PL_tmps_floor = oldtmps_floor;
2619 o->op_type = OP_RV2AV;
2620 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2621 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2622 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2623 o->op_opt = 0; /* needs to be revisited in peep() */
2624 curop = ((UNOP*)o)->op_first;
2625 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2627 op_getmad(curop,o,'O');
2636 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2639 if (!o || o->op_type != OP_LIST)
2640 o = newLISTOP(OP_LIST, 0, o, NULL);
2642 o->op_flags &= ~OPf_WANT;
2644 if (!(PL_opargs[type] & OA_MARK))
2645 op_null(cLISTOPo->op_first);
2647 o->op_type = (OPCODE)type;
2648 o->op_ppaddr = PL_ppaddr[type];
2649 o->op_flags |= flags;
2651 o = CHECKOP(type, o);
2652 if (o->op_type != (unsigned)type)
2655 return fold_constants(o);
2658 /* List constructors */
2661 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2669 if (first->op_type != (unsigned)type
2670 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2672 return newLISTOP(type, 0, first, last);
2675 if (first->op_flags & OPf_KIDS)
2676 ((LISTOP*)first)->op_last->op_sibling = last;
2678 first->op_flags |= OPf_KIDS;
2679 ((LISTOP*)first)->op_first = last;
2681 ((LISTOP*)first)->op_last = last;
2686 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2694 if (first->op_type != (unsigned)type)
2695 return prepend_elem(type, (OP*)first, (OP*)last);
2697 if (last->op_type != (unsigned)type)
2698 return append_elem(type, (OP*)first, (OP*)last);
2700 first->op_last->op_sibling = last->op_first;
2701 first->op_last = last->op_last;
2702 first->op_flags |= (last->op_flags & OPf_KIDS);
2705 if (last->op_first && first->op_madprop) {
2706 MADPROP *mp = last->op_first->op_madprop;
2708 while (mp->mad_next)
2710 mp->mad_next = first->op_madprop;
2713 last->op_first->op_madprop = first->op_madprop;
2716 first->op_madprop = last->op_madprop;
2717 last->op_madprop = 0;
2720 S_op_destroy(aTHX_ (OP*)last);
2726 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2734 if (last->op_type == (unsigned)type) {
2735 if (type == OP_LIST) { /* already a PUSHMARK there */
2736 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2737 ((LISTOP*)last)->op_first->op_sibling = first;
2738 if (!(first->op_flags & OPf_PARENS))
2739 last->op_flags &= ~OPf_PARENS;
2742 if (!(last->op_flags & OPf_KIDS)) {
2743 ((LISTOP*)last)->op_last = first;
2744 last->op_flags |= OPf_KIDS;
2746 first->op_sibling = ((LISTOP*)last)->op_first;
2747 ((LISTOP*)last)->op_first = first;
2749 last->op_flags |= OPf_KIDS;
2753 return newLISTOP(type, 0, first, last);
2761 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2764 Newxz(tk, 1, TOKEN);
2765 tk->tk_type = (OPCODE)optype;
2766 tk->tk_type = 12345;
2768 tk->tk_mad = madprop;
2773 Perl_token_free(pTHX_ TOKEN* tk)
2775 PERL_ARGS_ASSERT_TOKEN_FREE;
2777 if (tk->tk_type != 12345)
2779 mad_free(tk->tk_mad);
2784 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2789 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2791 if (tk->tk_type != 12345) {
2792 Perl_warner(aTHX_ packWARN(WARN_MISC),
2793 "Invalid TOKEN object ignored");
2800 /* faked up qw list? */
2802 tm->mad_type == MAD_SV &&
2803 SvPVX((SV *)tm->mad_val)[0] == 'q')
2810 /* pretend constant fold didn't happen? */
2811 if (mp->mad_key == 'f' &&
2812 (o->op_type == OP_CONST ||
2813 o->op_type == OP_GV) )
2815 token_getmad(tk,(OP*)mp->mad_val,slot);
2829 if (mp->mad_key == 'X')
2830 mp->mad_key = slot; /* just change the first one */
2840 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2849 /* pretend constant fold didn't happen? */
2850 if (mp->mad_key == 'f' &&
2851 (o->op_type == OP_CONST ||
2852 o->op_type == OP_GV) )
2854 op_getmad(from,(OP*)mp->mad_val,slot);
2861 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2864 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2870 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2879 /* pretend constant fold didn't happen? */
2880 if (mp->mad_key == 'f' &&
2881 (o->op_type == OP_CONST ||
2882 o->op_type == OP_GV) )
2884 op_getmad(from,(OP*)mp->mad_val,slot);
2891 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2894 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2898 PerlIO_printf(PerlIO_stderr(),
2899 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2905 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2923 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2927 addmad(tm, &(o->op_madprop), slot);
2931 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2952 Perl_newMADsv(pTHX_ char key, SV* sv)
2954 PERL_ARGS_ASSERT_NEWMADSV;
2956 return newMADPROP(key, MAD_SV, sv, 0);
2960 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2963 Newxz(mp, 1, MADPROP);
2966 mp->mad_vlen = vlen;
2967 mp->mad_type = type;
2969 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2974 Perl_mad_free(pTHX_ MADPROP* mp)
2976 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2980 mad_free(mp->mad_next);
2981 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2982 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2983 switch (mp->mad_type) {
2987 Safefree((char*)mp->mad_val);
2990 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2991 op_free((OP*)mp->mad_val);
2994 sv_free(MUTABLE_SV(mp->mad_val));
2997 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3006 Perl_newNULLLIST(pTHX)
3008 return newOP(OP_STUB, 0);
3012 S_force_list(pTHX_ OP *o)
3014 if (!o || o->op_type != OP_LIST)
3015 o = newLISTOP(OP_LIST, 0, o, NULL);
3021 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3026 NewOp(1101, listop, 1, LISTOP);
3028 listop->op_type = (OPCODE)type;
3029 listop->op_ppaddr = PL_ppaddr[type];
3032 listop->op_flags = (U8)flags;
3036 else if (!first && last)
3039 first->op_sibling = last;
3040 listop->op_first = first;
3041 listop->op_last = last;
3042 if (type == OP_LIST) {
3043 OP* const pushop = newOP(OP_PUSHMARK, 0);
3044 pushop->op_sibling = first;
3045 listop->op_first = pushop;
3046 listop->op_flags |= OPf_KIDS;
3048 listop->op_last = pushop;
3051 return CHECKOP(type, listop);
3055 Perl_newOP(pTHX_ I32 type, I32 flags)
3059 NewOp(1101, o, 1, OP);
3060 o->op_type = (OPCODE)type;
3061 o->op_ppaddr = PL_ppaddr[type];
3062 o->op_flags = (U8)flags;
3064 o->op_latefreed = 0;
3068 o->op_private = (U8)(0 | (flags >> 8));
3069 if (PL_opargs[type] & OA_RETSCALAR)
3071 if (PL_opargs[type] & OA_TARGET)
3072 o->op_targ = pad_alloc(type, SVs_PADTMP);
3073 return CHECKOP(type, o);
3077 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3083 first = newOP(OP_STUB, 0);
3084 if (PL_opargs[type] & OA_MARK)
3085 first = force_list(first);
3087 NewOp(1101, unop, 1, UNOP);
3088 unop->op_type = (OPCODE)type;
3089 unop->op_ppaddr = PL_ppaddr[type];
3090 unop->op_first = first;
3091 unop->op_flags = (U8)(flags | OPf_KIDS);
3092 unop->op_private = (U8)(1 | (flags >> 8));
3093 unop = (UNOP*) CHECKOP(type, unop);
3097 return fold_constants((OP *) unop);
3101 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3105 NewOp(1101, binop, 1, BINOP);
3108 first = newOP(OP_NULL, 0);
3110 binop->op_type = (OPCODE)type;
3111 binop->op_ppaddr = PL_ppaddr[type];
3112 binop->op_first = first;
3113 binop->op_flags = (U8)(flags | OPf_KIDS);
3116 binop->op_private = (U8)(1 | (flags >> 8));
3119 binop->op_private = (U8)(2 | (flags >> 8));
3120 first->op_sibling = last;
3123 binop = (BINOP*)CHECKOP(type, binop);
3124 if (binop->op_next || binop->op_type != (OPCODE)type)
3127 binop->op_last = binop->op_first->op_sibling;
3129 return fold_constants((OP *)binop);
3132 static int uvcompare(const void *a, const void *b)
3133 __attribute__nonnull__(1)
3134 __attribute__nonnull__(2)
3135 __attribute__pure__;
3136 static int uvcompare(const void *a, const void *b)
3138 if (*((const UV *)a) < (*(const UV *)b))
3140 if (*((const UV *)a) > (*(const UV *)b))
3142 if (*((const UV *)a+1) < (*(const UV *)b+1))
3144 if (*((const UV *)a+1) > (*(const UV *)b+1))
3150 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3153 SV * const tstr = ((SVOP*)expr)->op_sv;
3156 (repl->op_type == OP_NULL)
3157 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3159 ((SVOP*)repl)->op_sv;
3162 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3163 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3167 register short *tbl;
3169 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3170 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3171 I32 del = o->op_private & OPpTRANS_DELETE;
3174 PERL_ARGS_ASSERT_PMTRANS;
3176 PL_hints |= HINT_BLOCK_SCOPE;
3179 o->op_private |= OPpTRANS_FROM_UTF;
3182 o->op_private |= OPpTRANS_TO_UTF;
3184 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3185 SV* const listsv = newSVpvs("# comment\n");
3187 const U8* tend = t + tlen;
3188 const U8* rend = r + rlen;
3202 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3203 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3206 const U32 flags = UTF8_ALLOW_DEFAULT;
3210 t = tsave = bytes_to_utf8(t, &len);
3213 if (!to_utf && rlen) {
3215 r = rsave = bytes_to_utf8(r, &len);
3219 /* There are several snags with this code on EBCDIC:
3220 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3221 2. scan_const() in toke.c has encoded chars in native encoding which makes
3222 ranges at least in EBCDIC 0..255 range the bottom odd.
3226 U8 tmpbuf[UTF8_MAXBYTES+1];
3229 Newx(cp, 2*tlen, UV);
3231 transv = newSVpvs("");
3233 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3235 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3237 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3241 cp[2*i+1] = cp[2*i];
3245 qsort(cp, i, 2*sizeof(UV), uvcompare);
3246 for (j = 0; j < i; j++) {
3248 diff = val - nextmin;
3250 t = uvuni_to_utf8(tmpbuf,nextmin);
3251 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3253 U8 range_mark = UTF_TO_NATIVE(0xff);
3254 t = uvuni_to_utf8(tmpbuf, val - 1);
3255 sv_catpvn(transv, (char *)&range_mark, 1);
3256 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3263 t = uvuni_to_utf8(tmpbuf,nextmin);
3264 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3266 U8 range_mark = UTF_TO_NATIVE(0xff);
3267 sv_catpvn(transv, (char *)&range_mark, 1);
3269 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3270 UNICODE_ALLOW_SUPER);
3271 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3272 t = (const U8*)SvPVX_const(transv);
3273 tlen = SvCUR(transv);
3277 else if (!rlen && !del) {
3278 r = t; rlen = tlen; rend = tend;
3281 if ((!rlen && !del) || t == r ||
3282 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3284 o->op_private |= OPpTRANS_IDENTICAL;
3288 while (t < tend || tfirst <= tlast) {
3289 /* see if we need more "t" chars */
3290 if (tfirst > tlast) {
3291 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3293 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3295 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3302 /* now see if we need more "r" chars */
3303 if (rfirst > rlast) {
3305 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3307 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3309 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3318 rfirst = rlast = 0xffffffff;
3322 /* now see which range will peter our first, if either. */
3323 tdiff = tlast - tfirst;
3324 rdiff = rlast - rfirst;
3331 if (rfirst == 0xffffffff) {
3332 diff = tdiff; /* oops, pretend rdiff is infinite */
3334 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3335 (long)tfirst, (long)tlast);
3337 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3341 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3342 (long)tfirst, (long)(tfirst + diff),
3345 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3346 (long)tfirst, (long)rfirst);
3348 if (rfirst + diff > max)
3349 max = rfirst + diff;
3351 grows = (tfirst < rfirst &&
3352 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3364 else if (max > 0xff)
3369 PerlMemShared_free(cPVOPo->op_pv);
3370 cPVOPo->op_pv = NULL;
3372 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3374 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3375 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3376 PAD_SETSV(cPADOPo->op_padix, swash);
3378 SvREADONLY_on(swash);
3380 cSVOPo->op_sv = swash;
3382 SvREFCNT_dec(listsv);
3383 SvREFCNT_dec(transv);
3385 if (!del && havefinal && rlen)
3386 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3387 newSVuv((UV)final), 0);
3390 o->op_private |= OPpTRANS_GROWS;
3396 op_getmad(expr,o,'e');
3397 op_getmad(repl,o,'r');
3405 tbl = (short*)cPVOPo->op_pv;
3407 Zero(tbl, 256, short);
3408 for (i = 0; i < (I32)tlen; i++)
3410 for (i = 0, j = 0; i < 256; i++) {
3412 if (j >= (I32)rlen) {
3421 if (i < 128 && r[j] >= 128)
3431 o->op_private |= OPpTRANS_IDENTICAL;
3433 else if (j >= (I32)rlen)
3438 PerlMemShared_realloc(tbl,
3439 (0x101+rlen-j) * sizeof(short));
3440 cPVOPo->op_pv = (char*)tbl;
3442 tbl[0x100] = (short)(rlen - j);
3443 for (i=0; i < (I32)rlen - j; i++)
3444 tbl[0x101+i] = r[j+i];
3448 if (!rlen && !del) {
3451 o->op_private |= OPpTRANS_IDENTICAL;
3453 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3454 o->op_private |= OPpTRANS_IDENTICAL;
3456 for (i = 0; i < 256; i++)
3458 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3459 if (j >= (I32)rlen) {
3461 if (tbl[t[i]] == -1)
3467 if (tbl[t[i]] == -1) {
3468 if (t[i] < 128 && r[j] >= 128)
3475 if(del && rlen == tlen) {
3476 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3477 } else if(rlen > tlen) {
3478 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3482 o->op_private |= OPpTRANS_GROWS;
3484 op_getmad(expr,o,'e');
3485 op_getmad(repl,o,'r');
3495 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3500 NewOp(1101, pmop, 1, PMOP);
3501 pmop->op_type = (OPCODE)type;
3502 pmop->op_ppaddr = PL_ppaddr[type];
3503 pmop->op_flags = (U8)flags;
3504 pmop->op_private = (U8)(0 | (flags >> 8));
3506 if (PL_hints & HINT_RE_TAINT)
3507 pmop->op_pmflags |= PMf_RETAINT;
3508 if (PL_hints & HINT_LOCALE)
3509 pmop->op_pmflags |= PMf_LOCALE;
3513 assert(SvPOK(PL_regex_pad[0]));
3514 if (SvCUR(PL_regex_pad[0])) {
3515 /* Pop off the "packed" IV from the end. */
3516 SV *const repointer_list = PL_regex_pad[0];
3517 const char *p = SvEND(repointer_list) - sizeof(IV);
3518 const IV offset = *((IV*)p);
3520 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3522 SvEND_set(repointer_list, p);
3524 pmop->op_pmoffset = offset;
3525 /* This slot should be free, so assert this: */
3526 assert(PL_regex_pad[offset] == &PL_sv_undef);
3528 SV * const repointer = &PL_sv_undef;
3529 av_push(PL_regex_padav, repointer);
3530 pmop->op_pmoffset = av_len(PL_regex_padav);
3531 PL_regex_pad = AvARRAY(PL_regex_padav);
3535 return CHECKOP(type, pmop);
3538 /* Given some sort of match op o, and an expression expr containing a
3539 * pattern, either compile expr into a regex and attach it to o (if it's
3540 * constant), or convert expr into a runtime regcomp op sequence (if it's
3543 * isreg indicates that the pattern is part of a regex construct, eg
3544 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3545 * split "pattern", which aren't. In the former case, expr will be a list
3546 * if the pattern contains more than one term (eg /a$b/) or if it contains
3547 * a replacement, ie s/// or tr///.
3551 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3556 I32 repl_has_vars = 0;
3560 PERL_ARGS_ASSERT_PMRUNTIME;
3562 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3563 /* last element in list is the replacement; pop it */
3565 repl = cLISTOPx(expr)->op_last;
3566 kid = cLISTOPx(expr)->op_first;
3567 while (kid->op_sibling != repl)
3568 kid = kid->op_sibling;
3569 kid->op_sibling = NULL;
3570 cLISTOPx(expr)->op_last = kid;
3573 if (isreg && expr->op_type == OP_LIST &&
3574 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3576 /* convert single element list to element */
3577 OP* const oe = expr;
3578 expr = cLISTOPx(oe)->op_first->op_sibling;
3579 cLISTOPx(oe)->op_first->op_sibling = NULL;
3580 cLISTOPx(oe)->op_last = NULL;
3584 if (o->op_type == OP_TRANS) {
3585 return pmtrans(o, expr, repl);
3588 reglist = isreg && expr->op_type == OP_LIST;
3592 PL_hints |= HINT_BLOCK_SCOPE;
3595 if (expr->op_type == OP_CONST) {
3596 SV *pat = ((SVOP*)expr)->op_sv;
3597 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3599 if (o->op_flags & OPf_SPECIAL)
3600 pm_flags |= RXf_SPLIT;
3603 assert (SvUTF8(pat));
3604 } else if (SvUTF8(pat)) {
3605 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3606 trapped in use 'bytes'? */
3607 /* Make a copy of the octet sequence, but without the flag on, as
3608 the compiler now honours the SvUTF8 flag on pat. */
3610 const char *const p = SvPV(pat, len);
3611 pat = newSVpvn_flags(p, len, SVs_TEMP);
3614 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3617 op_getmad(expr,(OP*)pm,'e');
3623 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3624 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3626 : OP_REGCMAYBE),0,expr);
3628 NewOp(1101, rcop, 1, LOGOP);
3629 rcop->op_type = OP_REGCOMP;
3630 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3631 rcop->op_first = scalar(expr);
3632 rcop->op_flags |= OPf_KIDS
3633 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3634 | (reglist ? OPf_STACKED : 0);
3635 rcop->op_private = 1;
3638 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3640 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3643 /* establish postfix order */
3644 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3646 rcop->op_next = expr;
3647 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3650 rcop->op_next = LINKLIST(expr);
3651 expr->op_next = (OP*)rcop;
3654 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3659 if (pm->op_pmflags & PMf_EVAL) {
3661 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3662 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3664 else if (repl->op_type == OP_CONST)
3668 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3669 if (curop->op_type == OP_SCOPE
3670 || curop->op_type == OP_LEAVE
3671 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3672 if (curop->op_type == OP_GV) {
3673 GV * const gv = cGVOPx_gv(curop);
3675 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3678 else if (curop->op_type == OP_RV2CV)
3680 else if (curop->op_type == OP_RV2SV ||
3681 curop->op_type == OP_RV2AV ||
3682 curop->op_type == OP_RV2HV ||
3683 curop->op_type == OP_RV2GV) {
3684 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3687 else if (curop->op_type == OP_PADSV ||
3688 curop->op_type == OP_PADAV ||
3689 curop->op_type == OP_PADHV ||
3690 curop->op_type == OP_PADANY)
3694 else if (curop->op_type == OP_PUSHRE)
3695 NOOP; /* Okay here, dangerous in newASSIGNOP */
3705 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3707 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3708 prepend_elem(o->op_type, scalar(repl), o);
3711 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3712 pm->op_pmflags |= PMf_MAYBE_CONST;
3714 NewOp(1101, rcop, 1, LOGOP);
3715 rcop->op_type = OP_SUBSTCONT;
3716 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3717 rcop->op_first = scalar(repl);
3718 rcop->op_flags |= OPf_KIDS;
3719 rcop->op_private = 1;
3722 /* establish postfix order */
3723 rcop->op_next = LINKLIST(repl);
3724 repl->op_next = (OP*)rcop;
3726 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3727 assert(!(pm->op_pmflags & PMf_ONCE));
3728 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3737 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3742 PERL_ARGS_ASSERT_NEWSVOP;
3744 NewOp(1101, svop, 1, SVOP);
3745 svop->op_type = (OPCODE)type;
3746 svop->op_ppaddr = PL_ppaddr[type];
3748 svop->op_next = (OP*)svop;
3749 svop->op_flags = (U8)flags;
3750 if (PL_opargs[type] & OA_RETSCALAR)
3752 if (PL_opargs[type] & OA_TARGET)
3753 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3754 return CHECKOP(type, svop);
3759 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3764 PERL_ARGS_ASSERT_NEWPADOP;
3766 NewOp(1101, padop, 1, PADOP);
3767 padop->op_type = (OPCODE)type;
3768 padop->op_ppaddr = PL_ppaddr[type];
3769 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3770 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3771 PAD_SETSV(padop->op_padix, sv);
3774 padop->op_next = (OP*)padop;
3775 padop->op_flags = (U8)flags;
3776 if (PL_opargs[type] & OA_RETSCALAR)
3778 if (PL_opargs[type] & OA_TARGET)
3779 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3780 return CHECKOP(type, padop);
3785 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3789 PERL_ARGS_ASSERT_NEWGVOP;
3793 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3795 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3800 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3804 NewOp(1101, pvop, 1, PVOP);
3805 pvop->op_type = (OPCODE)type;
3806 pvop->op_ppaddr = PL_ppaddr[type];
3808 pvop->op_next = (OP*)pvop;
3809 pvop->op_flags = (U8)flags;
3810 if (PL_opargs[type] & OA_RETSCALAR)
3812 if (PL_opargs[type] & OA_TARGET)
3813 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3814 return CHECKOP(type, pvop);
3822 Perl_package(pTHX_ OP *o)
3825 SV *const sv = cSVOPo->op_sv;
3830 PERL_ARGS_ASSERT_PACKAGE;
3832 save_hptr(&PL_curstash);
3833 save_item(PL_curstname);
3835 PL_curstash = gv_stashsv(sv, GV_ADD);
3837 sv_setsv(PL_curstname, sv);
3839 PL_hints |= HINT_BLOCK_SCOPE;
3840 PL_parser->copline = NOLINE;
3841 PL_parser->expect = XSTATE;
3846 if (!PL_madskills) {
3851 pegop = newOP(OP_NULL,0);
3852 op_getmad(o,pegop,'P');
3858 Perl_package_version( pTHX_ OP *v )
3861 U32 savehints = PL_hints;
3862 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3863 PL_hints &= ~HINT_STRICT_VARS;
3864 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3865 PL_hints = savehints;
3874 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3881 OP *pegop = newOP(OP_NULL,0);
3884 PERL_ARGS_ASSERT_UTILIZE;
3886 if (idop->op_type != OP_CONST)
3887 Perl_croak(aTHX_ "Module name must be constant");
3890 op_getmad(idop,pegop,'U');
3895 SV * const vesv = ((SVOP*)version)->op_sv;
3898 op_getmad(version,pegop,'V');
3899 if (!arg && !SvNIOKp(vesv)) {
3906 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3907 Perl_croak(aTHX_ "Version number must be a constant number");
3909 /* Make copy of idop so we don't free it twice */
3910 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3912 /* Fake up a method call to VERSION */
3913 meth = newSVpvs_share("VERSION");
3914 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3915 append_elem(OP_LIST,
3916 prepend_elem(OP_LIST, pack, list(version)),
3917 newSVOP(OP_METHOD_NAMED, 0, meth)));
3921 /* Fake up an import/unimport */
3922 if (arg && arg->op_type == OP_STUB) {
3924 op_getmad(arg,pegop,'S');
3925 imop = arg; /* no import on explicit () */
3927 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3928 imop = NULL; /* use 5.0; */
3930 idop->op_private |= OPpCONST_NOVER;
3936 op_getmad(arg,pegop,'A');
3938 /* Make copy of idop so we don't free it twice */
3939 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3941 /* Fake up a method call to import/unimport */
3943 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3944 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3945 append_elem(OP_LIST,
3946 prepend_elem(OP_LIST, pack, list(arg)),
3947 newSVOP(OP_METHOD_NAMED, 0, meth)));
3950 /* Fake up the BEGIN {}, which does its thing immediately. */
3952 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3955 append_elem(OP_LINESEQ,
3956 append_elem(OP_LINESEQ,
3957 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3958 newSTATEOP(0, NULL, veop)),
3959 newSTATEOP(0, NULL, imop) ));
3961 /* The "did you use incorrect case?" warning used to be here.
3962 * The problem is that on case-insensitive filesystems one
3963 * might get false positives for "use" (and "require"):
3964 * "use Strict" or "require CARP" will work. This causes
3965 * portability problems for the script: in case-strict
3966 * filesystems the script will stop working.
3968 * The "incorrect case" warning checked whether "use Foo"
3969 * imported "Foo" to your namespace, but that is wrong, too:
3970 * there is no requirement nor promise in the language that
3971 * a Foo.pm should or would contain anything in package "Foo".
3973 * There is very little Configure-wise that can be done, either:
3974 * the case-sensitivity of the build filesystem of Perl does not
3975 * help in guessing the case-sensitivity of the runtime environment.
3978 PL_hints |= HINT_BLOCK_SCOPE;
3979 PL_parser->copline = NOLINE;
3980 PL_parser->expect = XSTATE;
3981 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3984 if (!PL_madskills) {
3985 /* FIXME - don't allocate pegop if !PL_madskills */
3994 =head1 Embedding Functions
3996 =for apidoc load_module
3998 Loads the module whose name is pointed to by the string part of name.
3999 Note that the actual module name, not its filename, should be given.
4000 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4001 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4002 (or 0 for no flags). ver, if specified, provides version semantics
4003 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4004 arguments can be used to specify arguments to the module's import()
4005 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4006 terminated with a final NULL pointer. Note that this list can only
4007 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4008 Otherwise at least a single NULL pointer to designate the default
4009 import list is required.
4014 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4018 PERL_ARGS_ASSERT_LOAD_MODULE;
4020 va_start(args, ver);
4021 vload_module(flags, name, ver, &args);
4025 #ifdef PERL_IMPLICIT_CONTEXT
4027 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4031 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4032 va_start(args, ver);
4033 vload_module(flags, name, ver, &args);
4039 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4043 OP * const modname = newSVOP(OP_CONST, 0, name);
4045 PERL_ARGS_ASSERT_VLOAD_MODULE;
4047 modname->op_private |= OPpCONST_BARE;
4049 veop = newSVOP(OP_CONST, 0, ver);
4053 if (flags & PERL_LOADMOD_NOIMPORT) {
4054 imop = sawparens(newNULLLIST());
4056 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4057 imop = va_arg(*args, OP*);
4062 sv = va_arg(*args, SV*);
4064 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4065 sv = va_arg(*args, SV*);
4069 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4070 * that it has a PL_parser to play with while doing that, and also
4071 * that it doesn't mess with any existing parser, by creating a tmp
4072 * new parser with lex_start(). This won't actually be used for much,
4073 * since pp_require() will create another parser for the real work. */
4076 SAVEVPTR(PL_curcop);
4077 lex_start(NULL, NULL, FALSE);
4078 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4079 veop, modname, imop);
4084 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4090 PERL_ARGS_ASSERT_DOFILE;
4092 if (!force_builtin) {
4093 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4094 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4095 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4096 gv = gvp ? *gvp : NULL;
4100 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4101 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4102 append_elem(OP_LIST, term,
4103 scalar(newUNOP(OP_RV2CV, 0,
4104 newGVOP(OP_GV, 0, gv))))));
4107 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4113 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4115 return newBINOP(OP_LSLICE, flags,
4116 list(force_list(subscript)),
4117 list(force_list(listval)) );
4121 S_is_list_assignment(pTHX_ register const OP *o)
4129 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4130 o = cUNOPo->op_first;
4132 flags = o->op_flags;
4134 if (type == OP_COND_EXPR) {
4135 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4136 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4141 yyerror("Assignment to both a list and a scalar");
4145 if (type == OP_LIST &&
4146 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4147 o->op_private & OPpLVAL_INTRO)
4150 if (type == OP_LIST || flags & OPf_PARENS ||
4151 type == OP_RV2AV || type == OP_RV2HV ||
4152 type == OP_ASLICE || type == OP_HSLICE)
4155 if (type == OP_PADAV || type == OP_PADHV)
4158 if (type == OP_RV2SV)
4165 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4171 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4172 return newLOGOP(optype, 0,
4173 mod(scalar(left), optype),
4174 newUNOP(OP_SASSIGN, 0, scalar(right)));
4177 return newBINOP(optype, OPf_STACKED,
4178 mod(scalar(left), optype), scalar(right));
4182 if (is_list_assignment(left)) {
4183 static const char no_list_state[] = "Initialization of state variables"
4184 " in list context currently forbidden";
4186 bool maybe_common_vars = TRUE;
4189 /* Grandfathering $[ assignment here. Bletch.*/
4190 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4191 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4192 left = mod(left, OP_AASSIGN);
4195 else if (left->op_type == OP_CONST) {
4197 /* Result of assignment is always 1 (or we'd be dead already) */
4198 return newSVOP(OP_CONST, 0, newSViv(1));
4200 curop = list(force_list(left));
4201 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4202 o->op_private = (U8)(0 | (flags >> 8));
4204 if ((left->op_type == OP_LIST
4205 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4207 OP* lop = ((LISTOP*)left)->op_first;
4208 maybe_common_vars = FALSE;
4210 if (lop->op_type == OP_PADSV ||
4211 lop->op_type == OP_PADAV ||
4212 lop->op_type == OP_PADHV ||
4213 lop->op_type == OP_PADANY) {
4214 if (!(lop->op_private & OPpLVAL_INTRO))
4215 maybe_common_vars = TRUE;
4217 if (lop->op_private & OPpPAD_STATE) {
4218 if (left->op_private & OPpLVAL_INTRO) {
4219 /* Each variable in state($a, $b, $c) = ... */
4222 /* Each state variable in
4223 (state $a, my $b, our $c, $d, undef) = ... */
4225 yyerror(no_list_state);
4227 /* Each my variable in
4228 (state $a, my $b, our $c, $d, undef) = ... */
4230 } else if (lop->op_type == OP_UNDEF ||
4231 lop->op_type == OP_PUSHMARK) {
4232 /* undef may be interesting in
4233 (state $a, undef, state $c) */
4235 /* Other ops in the list. */
4236 maybe_common_vars = TRUE;
4238 lop = lop->op_sibling;
4241 else if ((left->op_private & OPpLVAL_INTRO)
4242 && ( left->op_type == OP_PADSV
4243 || left->op_type == OP_PADAV
4244 || left->op_type == OP_PADHV
4245 || left->op_type == OP_PADANY))
4247 maybe_common_vars = FALSE;
4248 if (left->op_private & OPpPAD_STATE) {
4249 /* All single variable list context state assignments, hence
4259 yyerror(no_list_state);
4263 /* PL_generation sorcery:
4264 * an assignment like ($a,$b) = ($c,$d) is easier than
4265 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4266 * To detect whether there are common vars, the global var
4267 * PL_generation is incremented for each assign op we compile.
4268 * Then, while compiling the assign op, we run through all the
4269 * variables on both sides of the assignment, setting a spare slot
4270 * in each of them to PL_generation. If any of them already have
4271 * that value, we know we've got commonality. We could use a
4272 * single bit marker, but then we'd have to make 2 passes, first
4273 * to clear the flag, then to test and set it. To find somewhere
4274 * to store these values, evil chicanery is done with SvUVX().
4277 if (maybe_common_vars) {
4280 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4281 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4282 if (curop->op_type == OP_GV) {
4283 GV *gv = cGVOPx_gv(curop);
4285 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4287 GvASSIGN_GENERATION_set(gv, PL_generation);
4289 else if (curop->op_type == OP_PADSV ||
4290 curop->op_type == OP_PADAV ||
4291 curop->op_type == OP_PADHV ||
4292 curop->op_type == OP_PADANY)
4294 if (PAD_COMPNAME_GEN(curop->op_targ)
4295 == (STRLEN)PL_generation)
4297 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4300 else if (curop->op_type == OP_RV2CV)
4302 else if (curop->op_type == OP_RV2SV ||
4303 curop->op_type == OP_RV2AV ||
4304 curop->op_type == OP_RV2HV ||
4305 curop->op_type == OP_RV2GV) {
4306 if (lastop->op_type != OP_GV) /* funny deref? */
4309 else if (curop->op_type == OP_PUSHRE) {
4311 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4312 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4314 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4316 GvASSIGN_GENERATION_set(gv, PL_generation);
4320 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4323 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4325 GvASSIGN_GENERATION_set(gv, PL_generation);
4335 o->op_private |= OPpASSIGN_COMMON;
4338 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4339 OP* tmpop = ((LISTOP*)right)->op_first;
4340 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4341 PMOP * const pm = (PMOP*)tmpop;
4342 if (left->op_type == OP_RV2AV &&
4343 !(left->op_private & OPpLVAL_INTRO) &&
4344 !(o->op_private & OPpASSIGN_COMMON) )
4346 tmpop = ((UNOP*)left)->op_first;
4347 if (tmpop->op_type == OP_GV
4349 && !pm->op_pmreplrootu.op_pmtargetoff
4351 && !pm->op_pmreplrootu.op_pmtargetgv
4355 pm->op_pmreplrootu.op_pmtargetoff
4356 = cPADOPx(tmpop)->op_padix;
4357 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4359 pm->op_pmreplrootu.op_pmtargetgv
4360 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4361 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4363 pm->op_pmflags |= PMf_ONCE;
4364 tmpop = cUNOPo->op_first; /* to list (nulled) */
4365 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4366 tmpop->op_sibling = NULL; /* don't free split */
4367 right->op_next = tmpop->op_next; /* fix starting loc */
4368 op_free(o); /* blow off assign */
4369 right->op_flags &= ~OPf_WANT;
4370 /* "I don't know and I don't care." */
4375 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4376 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4378 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4379 if (SvIOK(sv) && SvIVX(sv) == 0)
4380 sv_setiv(sv, PL_modcount+1);
4388 right = newOP(OP_UNDEF, 0);
4389 if (right->op_type == OP_READLINE) {
4390 right->op_flags |= OPf_STACKED;
4391 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4394 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4395 o = newBINOP(OP_SASSIGN, flags,
4396 scalar(right), mod(scalar(left), OP_SASSIGN) );
4400 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4401 deprecate("assignment to $[");
4403 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4404 o->op_private |= OPpCONST_ARYBASE;
4412 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4415 const U32 seq = intro_my();
4418 NewOp(1101, cop, 1, COP);
4419 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4420 cop->op_type = OP_DBSTATE;
4421 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4424 cop->op_type = OP_NEXTSTATE;
4425 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4427 cop->op_flags = (U8)flags;
4428 CopHINTS_set(cop, PL_hints);
4430 cop->op_private |= NATIVE_HINTS;
4432 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4433 cop->op_next = (OP*)cop;
4436 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4437 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4439 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4440 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4441 if (cop->cop_hints_hash) {
4443 cop->cop_hints_hash->refcounted_he_refcnt++;
4444 HINTS_REFCNT_UNLOCK;
4448 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4450 PL_hints |= HINT_BLOCK_SCOPE;
4451 /* It seems that we need to defer freeing this pointer, as other parts
4452 of the grammar end up wanting to copy it after this op has been
4457 if (PL_parser && PL_parser->copline == NOLINE)
4458 CopLINE_set(cop, CopLINE(PL_curcop));
4460 CopLINE_set(cop, PL_parser->copline);
4462 PL_parser->copline = NOLINE;
4465 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4467 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4469 CopSTASH_set(cop, PL_curstash);
4471 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4472 /* this line can have a breakpoint - store the cop in IV */
4473 AV *av = CopFILEAVx(PL_curcop);
4475 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4476 if (svp && *svp != &PL_sv_undef ) {
4477 (void)SvIOK_on(*svp);
4478 SvIV_set(*svp, PTR2IV(cop));
4483 if (flags & OPf_SPECIAL)
4485 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4490 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4494 PERL_ARGS_ASSERT_NEWLOGOP;
4496 return new_logop(type, flags, &first, &other);
4500 S_search_const(pTHX_ OP *o)
4502 PERL_ARGS_ASSERT_SEARCH_CONST;
4504 switch (o->op_type) {
4508 if (o->op_flags & OPf_KIDS)
4509 return search_const(cUNOPo->op_first);
4516 if (!(o->op_flags & OPf_KIDS))
4518 kid = cLISTOPo->op_first;
4520 switch (kid->op_type) {
4524 kid = kid->op_sibling;
4527 if (kid != cLISTOPo->op_last)
4533 kid = cLISTOPo->op_last;
4535 return search_const(kid);
4543 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4551 int prepend_not = 0;
4553 PERL_ARGS_ASSERT_NEW_LOGOP;
4558 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4559 return newBINOP(type, flags, scalar(first), scalar(other));
4561 scalarboolean(first);
4562 /* optimize AND and OR ops that have NOTs as children */
4563 if (first->op_type == OP_NOT
4564 && (first->op_flags & OPf_KIDS)
4565 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4566 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4568 if (type == OP_AND || type == OP_OR) {
4574 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4576 prepend_not = 1; /* prepend a NOT op later */
4580 /* search for a constant op that could let us fold the test */
4581 if ((cstop = search_const(first))) {
4582 if (cstop->op_private & OPpCONST_STRICT)
4583 no_bareword_allowed(cstop);
4584 else if ((cstop->op_private & OPpCONST_BARE))
4585 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4586 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4587 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4588 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4590 if (other->op_type == OP_CONST)
4591 other->op_private |= OPpCONST_SHORTCIRCUIT;
4593 OP *newop = newUNOP(OP_NULL, 0, other);
4594 op_getmad(first, newop, '1');
4595 newop->op_targ = type; /* set "was" field */
4599 if (other->op_type == OP_LEAVE)
4600 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4604 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4605 const OP *o2 = other;
4606 if ( ! (o2->op_type == OP_LIST
4607 && (( o2 = cUNOPx(o2)->op_first))
4608 && o2->op_type == OP_PUSHMARK
4609 && (( o2 = o2->op_sibling)) )
4612 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4613 || o2->op_type == OP_PADHV)
4614 && o2->op_private & OPpLVAL_INTRO
4615 && !(o2->op_private & OPpPAD_STATE))
4617 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4618 "Deprecated use of my() in false conditional");
4622 if (first->op_type == OP_CONST)
4623 first->op_private |= OPpCONST_SHORTCIRCUIT;
4625 first = newUNOP(OP_NULL, 0, first);
4626 op_getmad(other, first, '2');
4627 first->op_targ = type; /* set "was" field */
4634 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4635 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4637 const OP * const k1 = ((UNOP*)first)->op_first;
4638 const OP * const k2 = k1->op_sibling;
4640 switch (first->op_type)
4643 if (k2 && k2->op_type == OP_READLINE
4644 && (k2->op_flags & OPf_STACKED)
4645 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4647 warnop = k2->op_type;
4652 if (k1->op_type == OP_READDIR
4653 || k1->op_type == OP_GLOB
4654 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4655 || k1->op_type == OP_EACH)
4657 warnop = ((k1->op_type == OP_NULL)
4658 ? (OPCODE)k1->op_targ : k1->op_type);
4663 const line_t oldline = CopLINE(PL_curcop);
4664 CopLINE_set(PL_curcop, PL_parser->copline);
4665 Perl_warner(aTHX_ packWARN(WARN_MISC),
4666 "Value of %s%s can be \"0\"; test with defined()",
4668 ((warnop == OP_READLINE || warnop == OP_GLOB)
4669 ? " construct" : "() operator"));
4670 CopLINE_set(PL_curcop, oldline);
4677 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4678 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4680 NewOp(1101, logop, 1, LOGOP);
4682 logop->op_type = (OPCODE)type;
4683 logop->op_ppaddr = PL_ppaddr[type];
4684 logop->op_first = first;
4685 logop->op_flags = (U8)(flags | OPf_KIDS);
4686 logop->op_other = LINKLIST(other);
4687 logop->op_private = (U8)(1 | (flags >> 8));
4689 /* establish postfix order */
4690 logop->op_next = LINKLIST(first);
4691 first->op_next = (OP*)logop;
4692 first->op_sibling = other;
4694 CHECKOP(type,logop);
4696 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4703 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4711 PERL_ARGS_ASSERT_NEWCONDOP;
4714 return newLOGOP(OP_AND, 0, first, trueop);
4716 return newLOGOP(OP_OR, 0, first, falseop);
4718 scalarboolean(first);
4719 if ((cstop = search_const(first))) {
4720 /* Left or right arm of the conditional? */
4721 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4722 OP *live = left ? trueop : falseop;
4723 OP *const dead = left ? falseop : trueop;
4724 if (cstop->op_private & OPpCONST_BARE &&
4725 cstop->op_private & OPpCONST_STRICT) {
4726 no_bareword_allowed(cstop);
4729 /* This is all dead code when PERL_MAD is not defined. */
4730 live = newUNOP(OP_NULL, 0, live);
4731 op_getmad(first, live, 'C');
4732 op_getmad(dead, live, left ? 'e' : 't');
4737 if (live->op_type == OP_LEAVE)
4738 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4741 NewOp(1101, logop, 1, LOGOP);
4742 logop->op_type = OP_COND_EXPR;
4743 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4744 logop->op_first = first;
4745 logop->op_flags = (U8)(flags | OPf_KIDS);
4746 logop->op_private = (U8)(1 | (flags >> 8));
4747 logop->op_other = LINKLIST(trueop);
4748 logop->op_next = LINKLIST(falseop);
4750 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4753 /* establish postfix order */
4754 start = LINKLIST(first);
4755 first->op_next = (OP*)logop;
4757 first->op_sibling = trueop;
4758 trueop->op_sibling = falseop;
4759 o = newUNOP(OP_NULL, 0, (OP*)logop);
4761 trueop->op_next = falseop->op_next = o;
4768 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4777 PERL_ARGS_ASSERT_NEWRANGE;
4779 NewOp(1101, range, 1, LOGOP);
4781 range->op_type = OP_RANGE;
4782 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4783 range->op_first = left;
4784 range->op_flags = OPf_KIDS;
4785 leftstart = LINKLIST(left);
4786 range->op_other = LINKLIST(right);
4787 range->op_private = (U8)(1 | (flags >> 8));
4789 left->op_sibling = right;
4791 range->op_next = (OP*)range;
4792 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4793 flop = newUNOP(OP_FLOP, 0, flip);
4794 o = newUNOP(OP_NULL, 0, flop);
4796 range->op_next = leftstart;
4798 left->op_next = flip;
4799 right->op_next = flop;
4801 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4802 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4803 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4804 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4806 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4807 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4810 if (!flip->op_private || !flop->op_private)
4811 linklist(o); /* blow off optimizer unless constant */
4817 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4822 const bool once = block && block->op_flags & OPf_SPECIAL &&
4823 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4825 PERL_UNUSED_ARG(debuggable);
4828 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4829 return block; /* do {} while 0 does once */
4830 if (expr->op_type == OP_READLINE
4831 || expr->op_type == OP_READDIR
4832 || expr->op_type == OP_GLOB
4833 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4834 expr = newUNOP(OP_DEFINED, 0,
4835 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4836 } else if (expr->op_flags & OPf_KIDS) {
4837 const OP * const k1 = ((UNOP*)expr)->op_first;
4838 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4839 switch (expr->op_type) {
4841 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4842 && (k2->op_flags & OPf_STACKED)
4843 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4844 expr = newUNOP(OP_DEFINED, 0, expr);
4848 if (k1 && (k1->op_type == OP_READDIR
4849 || k1->op_type == OP_GLOB
4850 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4851 || k1->op_type == OP_EACH))
4852 expr = newUNOP(OP_DEFINED, 0, expr);
4858 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4859 * op, in listop. This is wrong. [perl #27024] */
4861 block = newOP(OP_NULL, 0);
4862 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4863 o = new_logop(OP_AND, 0, &expr, &listop);
4866 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4868 if (once && o != listop)
4869 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4872 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4874 o->op_flags |= flags;
4876 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4881 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4882 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4891 PERL_UNUSED_ARG(debuggable);
4894 if (expr->op_type == OP_READLINE
4895 || expr->op_type == OP_READDIR
4896 || expr->op_type == OP_GLOB
4897 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4898 expr = newUNOP(OP_DEFINED, 0,
4899 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4900 } else if (expr->op_flags & OPf_KIDS) {
4901 const OP * const k1 = ((UNOP*)expr)->op_first;
4902 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4903 switch (expr->op_type) {
4905 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4906 && (k2->op_flags & OPf_STACKED)
4907 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4908 expr = newUNOP(OP_DEFINED, 0, expr);
4912 if (k1 && (k1->op_type == OP_READDIR
4913 || k1->op_type == OP_GLOB
4914 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4915 || k1->op_type == OP_EACH))
4916 expr = newUNOP(OP_DEFINED, 0, expr);
4923 block = newOP(OP_NULL, 0);
4924 else if (cont || has_my) {
4925 block = scope(block);
4929 next = LINKLIST(cont);
4932 OP * const unstack = newOP(OP_UNSTACK, 0);
4935 cont = append_elem(OP_LINESEQ, cont, unstack);
4939 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4941 redo = LINKLIST(listop);
4944 PL_parser->copline = (line_t)whileline;
4946 o = new_logop(OP_AND, 0, &expr, &listop);
4947 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4948 op_free(expr); /* oops, it's a while (0) */
4950 return NULL; /* listop already freed by new_logop */
4953 ((LISTOP*)listop)->op_last->op_next =
4954 (o == listop ? redo : LINKLIST(o));
4960 NewOp(1101,loop,1,LOOP);
4961 loop->op_type = OP_ENTERLOOP;
4962 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4963 loop->op_private = 0;
4964 loop->op_next = (OP*)loop;
4967 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4969 loop->op_redoop = redo;
4970 loop->op_lastop = o;
4971 o->op_private |= loopflags;
4974 loop->op_nextop = next;
4976 loop->op_nextop = o;
4978 o->op_flags |= flags;
4979 o->op_private |= (flags >> 8);
4984 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4989 PADOFFSET padoff = 0;
4994 PERL_ARGS_ASSERT_NEWFOROP;
4997 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4998 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4999 sv->op_type = OP_RV2GV;
5000 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5002 /* The op_type check is needed to prevent a possible segfault
5003 * if the loop variable is undeclared and 'strict vars' is in
5004 * effect. This is illegal but is nonetheless parsed, so we
5005 * may reach this point with an OP_CONST where we're expecting
5008 if (cUNOPx(sv)->op_first->op_type == OP_GV
5009 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5010 iterpflags |= OPpITER_DEF;
5012 else if (sv->op_type == OP_PADSV) { /* private variable */
5013 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5014 padoff = sv->op_targ;
5024 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5026 SV *const namesv = PAD_COMPNAME_SV(padoff);
5028 const char *const name = SvPV_const(namesv, len);
5030 if (len == 2 && name[0] == '$' && name[1] == '_')
5031 iterpflags |= OPpITER_DEF;
5035 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5036 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5037 sv = newGVOP(OP_GV, 0, PL_defgv);
5042 iterpflags |= OPpITER_DEF;
5044 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5045 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5046 iterflags |= OPf_STACKED;
5048 else if (expr->op_type == OP_NULL &&
5049 (expr->op_flags & OPf_KIDS) &&
5050 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5052 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5053 * set the STACKED flag to indicate that these values are to be
5054 * treated as min/max values by 'pp_iterinit'.
5056 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5057 LOGOP* const range = (LOGOP*) flip->op_first;
5058 OP* const left = range->op_first;
5059 OP* const right = left->op_sibling;
5062 range->op_flags &= ~OPf_KIDS;
5063 range->op_first = NULL;
5065 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5066 listop->op_first->op_next = range->op_next;
5067 left->op_next = range->op_other;
5068 right->op_next = (OP*)listop;
5069 listop->op_next = listop->op_first;
5072 op_getmad(expr,(OP*)listop,'O');
5076 expr = (OP*)(listop);
5078 iterflags |= OPf_STACKED;
5081 expr = mod(force_list(expr), OP_GREPSTART);
5084 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5085 append_elem(OP_LIST, expr, scalar(sv))));
5086 assert(!loop->op_next);
5087 /* for my $x () sets OPpLVAL_INTRO;
5088 * for our $x () sets OPpOUR_INTRO */
5089 loop->op_private = (U8)iterpflags;
5090 #ifdef PL_OP_SLAB_ALLOC
5093 NewOp(1234,tmp,1,LOOP);
5094 Copy(loop,tmp,1,LISTOP);
5095 S_op_destroy(aTHX_ (OP*)loop);
5099 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5101 loop->op_targ = padoff;
5102 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5104 op_getmad(madsv, (OP*)loop, 'v');
5105 PL_parser->copline = forline;
5106 return newSTATEOP(0, label, wop);
5110 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5115 PERL_ARGS_ASSERT_NEWLOOPEX;
5117 if (type != OP_GOTO || label->op_type == OP_CONST) {
5118 /* "last()" means "last" */
5119 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5120 o = newOP(type, OPf_SPECIAL);
5122 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5123 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5127 op_getmad(label,o,'L');
5133 /* Check whether it's going to be a goto &function */
5134 if (label->op_type == OP_ENTERSUB
5135 && !(label->op_flags & OPf_STACKED))
5136 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5137 o = newUNOP(type, OPf_STACKED, label);
5139 PL_hints |= HINT_BLOCK_SCOPE;
5143 /* if the condition is a literal array or hash
5144 (or @{ ... } etc), make a reference to it.
5147 S_ref_array_or_hash(pTHX_ OP *cond)
5150 && (cond->op_type == OP_RV2AV
5151 || cond->op_type == OP_PADAV
5152 || cond->op_type == OP_RV2HV
5153 || cond->op_type == OP_PADHV))
5155 return newUNOP(OP_REFGEN,
5156 0, mod(cond, OP_REFGEN));
5162 /* These construct the optree fragments representing given()
5165 entergiven and enterwhen are LOGOPs; the op_other pointer
5166 points up to the associated leave op. We need this so we
5167 can put it in the context and make break/continue work.
5168 (Also, of course, pp_enterwhen will jump straight to
5169 op_other if the match fails.)
5173 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5174 I32 enter_opcode, I32 leave_opcode,
5175 PADOFFSET entertarg)
5181 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5183 NewOp(1101, enterop, 1, LOGOP);
5184 enterop->op_type = (Optype)enter_opcode;
5185 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5186 enterop->op_flags = (U8) OPf_KIDS;
5187 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5188 enterop->op_private = 0;
5190 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5193 enterop->op_first = scalar(cond);
5194 cond->op_sibling = block;
5196 o->op_next = LINKLIST(cond);
5197 cond->op_next = (OP *) enterop;
5200 /* This is a default {} block */
5201 enterop->op_first = block;
5202 enterop->op_flags |= OPf_SPECIAL;
5204 o->op_next = (OP *) enterop;
5207 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5208 entergiven and enterwhen both
5211 enterop->op_next = LINKLIST(block);
5212 block->op_next = enterop->op_other = o;
5217 /* Does this look like a boolean operation? For these purposes
5218 a boolean operation is:
5219 - a subroutine call [*]
5220 - a logical connective
5221 - a comparison operator
5222 - a filetest operator, with the exception of -s -M -A -C
5223 - defined(), exists() or eof()
5224 - /$re/ or $foo =~ /$re/
5226 [*] possibly surprising
5229 S_looks_like_bool(pTHX_ const OP *o)
5233 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5235 switch(o->op_type) {
5238 return looks_like_bool(cLOGOPo->op_first);
5242 looks_like_bool(cLOGOPo->op_first)
5243 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5247 o->op_flags & OPf_KIDS
5248 && looks_like_bool(cUNOPo->op_first));
5251 return looks_like_bool(cUNOPo->op_first);
5256 case OP_NOT: case OP_XOR:
5258 case OP_EQ: case OP_NE: case OP_LT:
5259 case OP_GT: case OP_LE: case OP_GE:
5261 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5262 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5264 case OP_SEQ: case OP_SNE: case OP_SLT:
5265 case OP_SGT: case OP_SLE: case OP_SGE:
5269 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5270 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5271 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5272 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5273 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5274 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5275 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5276 case OP_FTTEXT: case OP_FTBINARY:
5278 case OP_DEFINED: case OP_EXISTS:
5279 case OP_MATCH: case OP_EOF:
5286 /* Detect comparisons that have been optimized away */
5287 if (cSVOPo->op_sv == &PL_sv_yes
5288 || cSVOPo->op_sv == &PL_sv_no)
5301 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5304 PERL_ARGS_ASSERT_NEWGIVENOP;
5305 return newGIVWHENOP(
5306 ref_array_or_hash(cond),
5308 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5312 /* If cond is null, this is a default {} block */
5314 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5316 const bool cond_llb = (!cond || looks_like_bool(cond));
5319 PERL_ARGS_ASSERT_NEWWHENOP;
5324 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5326 scalar(ref_array_or_hash(cond)));
5329 return newGIVWHENOP(
5331 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5332 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5336 =for apidoc cv_undef
5338 Clear out all the active components of a CV. This can happen either
5339 by an explicit C<undef &foo>, or by the reference count going to zero.
5340 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5341 children can still follow the full lexical scope chain.
5347 Perl_cv_undef(pTHX_ CV *cv)
5351 PERL_ARGS_ASSERT_CV_UNDEF;
5353 DEBUG_X(PerlIO_printf(Perl_debug_log,
5354 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5355 PTR2UV(cv), PTR2UV(PL_comppad))
5359 if (CvFILE(cv) && !CvISXSUB(cv)) {
5360 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5361 Safefree(CvFILE(cv));
5366 if (!CvISXSUB(cv) && CvROOT(cv)) {
5367 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5368 Perl_croak(aTHX_ "Can't undef active subroutine");
5371 PAD_SAVE_SETNULLPAD();
5373 op_free(CvROOT(cv));
5378 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5383 /* remove CvOUTSIDE unless this is an undef rather than a free */
5384 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5385 if (!CvWEAKOUTSIDE(cv))
5386 SvREFCNT_dec(CvOUTSIDE(cv));
5387 CvOUTSIDE(cv) = NULL;
5390 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5393 if (CvISXSUB(cv) && CvXSUB(cv)) {
5396 /* delete all flags except WEAKOUTSIDE */
5397 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5401 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5404 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5406 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5407 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5408 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5409 || (p && (len != SvCUR(cv) /* Not the same length. */
5410 || memNE(p, SvPVX_const(cv), len))))
5411 && ckWARN_d(WARN_PROTOTYPE)) {
5412 SV* const msg = sv_newmortal();
5416 gv_efullname3(name = sv_newmortal(), gv, NULL);
5417 sv_setpvs(msg, "Prototype mismatch:");
5419 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5421 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5423 sv_catpvs(msg, ": none");
5424 sv_catpvs(msg, " vs ");
5426 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5428 sv_catpvs(msg, "none");
5429 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5433 static void const_sv_xsub(pTHX_ CV* cv);
5437 =head1 Optree Manipulation Functions
5439 =for apidoc cv_const_sv
5441 If C<cv> is a constant sub eligible for inlining. returns the constant
5442 value returned by the sub. Otherwise, returns NULL.
5444 Constant subs can be created with C<newCONSTSUB> or as described in
5445 L<perlsub/"Constant Functions">.
5450 Perl_cv_const_sv(pTHX_ const CV *const cv)
5452 PERL_UNUSED_CONTEXT;
5455 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5457 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5460 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5461 * Can be called in 3 ways:
5464 * look for a single OP_CONST with attached value: return the value
5466 * cv && CvCLONE(cv) && !CvCONST(cv)
5468 * examine the clone prototype, and if contains only a single
5469 * OP_CONST referencing a pad const, or a single PADSV referencing
5470 * an outer lexical, return a non-zero value to indicate the CV is
5471 * a candidate for "constizing" at clone time
5475 * We have just cloned an anon prototype that was marked as a const
5476 * candidiate. Try to grab the current value, and in the case of
5477 * PADSV, ignore it if it has multiple references. Return the value.
5481 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5492 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5493 o = cLISTOPo->op_first->op_sibling;
5495 for (; o; o = o->op_next) {
5496 const OPCODE type = o->op_type;
5498 if (sv && o->op_next == o)
5500 if (o->op_next != o) {
5501 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5503 if (type == OP_DBSTATE)
5506 if (type == OP_LEAVESUB || type == OP_RETURN)
5510 if (type == OP_CONST && cSVOPo->op_sv)
5512 else if (cv && type == OP_CONST) {
5513 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5517 else if (cv && type == OP_PADSV) {
5518 if (CvCONST(cv)) { /* newly cloned anon */
5519 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5520 /* the candidate should have 1 ref from this pad and 1 ref
5521 * from the parent */
5522 if (!sv || SvREFCNT(sv) != 2)
5529 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5530 sv = &PL_sv_undef; /* an arbitrary non-null value */
5545 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5548 /* This would be the return value, but the return cannot be reached. */
5549 OP* pegop = newOP(OP_NULL, 0);
5552 PERL_UNUSED_ARG(floor);
5562 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5564 NORETURN_FUNCTION_END;
5569 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5571 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5575 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5581 register CV *cv = NULL;
5583 /* If the subroutine has no body, no attributes, and no builtin attributes
5584 then it's just a sub declaration, and we may be able to get away with
5585 storing with a placeholder scalar in the symbol table, rather than a
5586 full GV and CV. If anything is present then it will take a full CV to
5588 const I32 gv_fetch_flags
5589 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5591 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5592 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5596 assert(proto->op_type == OP_CONST);
5597 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5603 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5605 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5606 SV * const sv = sv_newmortal();
5607 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5608 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5609 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5610 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5612 } else if (PL_curstash) {
5613 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5616 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5620 if (!PL_madskills) {
5629 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5630 maximum a prototype before. */
5631 if (SvTYPE(gv) > SVt_NULL) {
5632 if (!SvPOK((const SV *)gv)
5633 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5635 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5637 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5640 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5642 sv_setiv(MUTABLE_SV(gv), -1);
5644 SvREFCNT_dec(PL_compcv);
5645 cv = PL_compcv = NULL;
5649 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5651 if (!block || !ps || *ps || attrs
5652 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5654 || block->op_type == OP_NULL
5659 const_sv = op_const_sv(block, NULL);
5662 const bool exists = CvROOT(cv) || CvXSUB(cv);
5664 /* if the subroutine doesn't exist and wasn't pre-declared
5665 * with a prototype, assume it will be AUTOLOADed,
5666 * skipping the prototype check
5668 if (exists || SvPOK(cv))
5669 cv_ckproto_len(cv, gv, ps, ps_len);
5670 /* already defined (or promised)? */
5671 if (exists || GvASSUMECV(gv)) {
5674 || block->op_type == OP_NULL
5677 if (CvFLAGS(PL_compcv)) {
5678 /* might have had built-in attrs applied */
5679 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5681 /* just a "sub foo;" when &foo is already defined */
5682 SAVEFREESV(PL_compcv);
5687 && block->op_type != OP_NULL
5690 if (ckWARN(WARN_REDEFINE)
5692 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5694 const line_t oldline = CopLINE(PL_curcop);
5695 if (PL_parser && PL_parser->copline != NOLINE)
5696 CopLINE_set(PL_curcop, PL_parser->copline);
5697 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5698 CvCONST(cv) ? "Constant subroutine %s redefined"
5699 : "Subroutine %s redefined", name);
5700 CopLINE_set(PL_curcop, oldline);
5703 if (!PL_minus_c) /* keep old one around for madskills */
5706 /* (PL_madskills unset in used file.) */
5714 SvREFCNT_inc_simple_void_NN(const_sv);
5716 assert(!CvROOT(cv) && !CvCONST(cv));
5717 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5718 CvXSUBANY(cv).any_ptr = const_sv;
5719 CvXSUB(cv) = const_sv_xsub;
5725 cv = newCONSTSUB(NULL, name, const_sv);
5727 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5728 (CvGV(cv) && GvSTASH(CvGV(cv)))
5737 SvREFCNT_dec(PL_compcv);
5741 if (cv) { /* must reuse cv if autoloaded */
5742 /* transfer PL_compcv to cv */
5745 && block->op_type != OP_NULL
5749 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5750 if (!CvWEAKOUTSIDE(cv))
5751 SvREFCNT_dec(CvOUTSIDE(cv));
5752 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5753 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5754 CvOUTSIDE(PL_compcv) = 0;
5755 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5756 CvPADLIST(PL_compcv) = 0;
5757 /* inner references to PL_compcv must be fixed up ... */
5758 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5759 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5760 ++PL_sub_generation;
5763 /* Might have had built-in attributes applied -- propagate them. */
5764 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5766 /* ... before we throw it away */
5767 SvREFCNT_dec(PL_compcv);
5775 if (strEQ(name, "import")) {
5776 PL_formfeed = MUTABLE_SV(cv);
5777 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5781 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5786 CvFILE_set_from_cop(cv, PL_curcop);
5787 CvSTASH(cv) = PL_curstash;
5790 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5791 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5792 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5796 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5798 if (PL_parser && PL_parser->error_count) {
5802 const char *s = strrchr(name, ':');
5804 if (strEQ(s, "BEGIN")) {
5805 const char not_safe[] =
5806 "BEGIN not safe after errors--compilation aborted";
5807 if (PL_in_eval & EVAL_KEEPERR)
5808 Perl_croak(aTHX_ not_safe);
5810 /* force display of errors found but not reported */
5811 sv_catpv(ERRSV, not_safe);
5812 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5821 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5822 the debugger could be able to set a breakpoint in, so signal to
5823 pp_entereval that it should not throw away any saved lines at scope
5826 PL_breakable_sub_gen++;
5828 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5829 mod(scalarseq(block), OP_LEAVESUBLV));
5830 block->op_attached = 1;
5833 /* This makes sub {}; work as expected. */
5834 if (block->op_type == OP_STUB) {
5835 OP* const newblock = newSTATEOP(0, NULL, 0);
5837 op_getmad(block,newblock,'B');
5844 block->op_attached = 1;
5845 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5847 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5848 OpREFCNT_set(CvROOT(cv), 1);
5849 CvSTART(cv) = LINKLIST(CvROOT(cv));
5850 CvROOT(cv)->op_next = 0;
5851 CALL_PEEP(CvSTART(cv));
5853 /* now that optimizer has done its work, adjust pad values */
5855 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5858 assert(!CvCONST(cv));
5859 if (ps && !*ps && op_const_sv(block, cv))
5864 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5865 SV * const sv = newSV(0);
5866 SV * const tmpstr = sv_newmortal();
5867 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5868 GV_ADDMULTI, SVt_PVHV);
5871 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5873 (long)PL_subline, (long)CopLINE(PL_curcop));
5874 gv_efullname3(tmpstr, gv, NULL);
5875 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5876 SvCUR(tmpstr), sv, 0);
5877 hv = GvHVn(db_postponed);
5878 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5879 CV * const pcv = GvCV(db_postponed);
5885 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5890 if (name && ! (PL_parser && PL_parser->error_count))
5891 process_special_blocks(name, gv, cv);
5896 PL_parser->copline = NOLINE;
5902 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5905 const char *const colon = strrchr(fullname,':');
5906 const char *const name = colon ? colon + 1 : fullname;
5908 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5911 if (strEQ(name, "BEGIN")) {
5912 const I32 oldscope = PL_scopestack_ix;
5914 SAVECOPFILE(&PL_compiling);
5915 SAVECOPLINE(&PL_compiling);
5917 DEBUG_x( dump_sub(gv) );
5918 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5919 GvCV(gv) = 0; /* cv has been hijacked */
5920 call_list(oldscope, PL_beginav);
5922 PL_curcop = &PL_compiling;
5923 CopHINTS_set(&PL_compiling, PL_hints);
5930 if strEQ(name, "END") {
5931 DEBUG_x( dump_sub(gv) );
5932 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5935 } else if (*name == 'U') {
5936 if (strEQ(name, "UNITCHECK")) {
5937 /* It's never too late to run a unitcheck block */
5938 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5942 } else if (*name == 'C') {
5943 if (strEQ(name, "CHECK")) {
5945 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5946 "Too late to run CHECK block");
5947 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5951 } else if (*name == 'I') {
5952 if (strEQ(name, "INIT")) {
5954 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5955 "Too late to run INIT block");
5956 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5962 DEBUG_x( dump_sub(gv) );
5963 GvCV(gv) = 0; /* cv has been hijacked */
5968 =for apidoc newCONSTSUB
5970 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5971 eligible for inlining at compile-time.
5973 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5974 which won't be called if used as a destructor, but will suppress the overhead
5975 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5982 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5987 const char *const file = CopFILE(PL_curcop);
5989 SV *const temp_sv = CopFILESV(PL_curcop);
5990 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5995 if (IN_PERL_RUNTIME) {
5996 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5997 * an op shared between threads. Use a non-shared COP for our
5999 SAVEVPTR(PL_curcop);
6000 PL_curcop = &PL_compiling;
6002 SAVECOPLINE(PL_curcop);
6003 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6006 PL_hints &= ~HINT_BLOCK_SCOPE;
6009 SAVESPTR(PL_curstash);
6010 SAVECOPSTASH(PL_curcop);
6011 PL_curstash = stash;
6012 CopSTASH_set(PL_curcop,stash);
6015 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6016 and so doesn't get free()d. (It's expected to be from the C pre-
6017 processor __FILE__ directive). But we need a dynamically allocated one,
6018 and we need it to get freed. */
6019 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6020 XS_DYNAMIC_FILENAME);
6021 CvXSUBANY(cv).any_ptr = sv;
6026 CopSTASH_free(PL_curcop);
6034 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6035 const char *const filename, const char *const proto,
6038 CV *cv = newXS(name, subaddr, filename);
6040 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6042 if (flags & XS_DYNAMIC_FILENAME) {
6043 /* We need to "make arrangements" (ie cheat) to ensure that the
6044 filename lasts as long as the PVCV we just created, but also doesn't
6046 STRLEN filename_len = strlen(filename);
6047 STRLEN proto_and_file_len = filename_len;
6048 char *proto_and_file;
6052 proto_len = strlen(proto);
6053 proto_and_file_len += proto_len;
6055 Newx(proto_and_file, proto_and_file_len + 1, char);
6056 Copy(proto, proto_and_file, proto_len, char);
6057 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6060 proto_and_file = savepvn(filename, filename_len);
6063 /* This gets free()d. :-) */
6064 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6065 SV_HAS_TRAILING_NUL);
6067 /* This gives us the correct prototype, rather than one with the
6068 file name appended. */
6069 SvCUR_set(cv, proto_len);
6073 CvFILE(cv) = proto_and_file + proto_len;
6075 sv_setpv(MUTABLE_SV(cv), proto);
6081 =for apidoc U||newXS
6083 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6084 static storage, as it is used directly as CvFILE(), without a copy being made.
6090 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6093 GV * const gv = gv_fetchpv(name ? name :
6094 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6095 GV_ADDMULTI, SVt_PVCV);
6098 PERL_ARGS_ASSERT_NEWXS;
6101 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6103 if ((cv = (name ? GvCV(gv) : NULL))) {
6105 /* just a cached method */
6109 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6110 /* already defined (or promised) */
6111 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6112 if (ckWARN(WARN_REDEFINE)) {
6113 GV * const gvcv = CvGV(cv);
6115 HV * const stash = GvSTASH(gvcv);
6117 const char *redefined_name = HvNAME_get(stash);
6118 if ( strEQ(redefined_name,"autouse") ) {
6119 const line_t oldline = CopLINE(PL_curcop);
6120 if (PL_parser && PL_parser->copline != NOLINE)
6121 CopLINE_set(PL_curcop, PL_parser->copline);
6122 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6123 CvCONST(cv) ? "Constant subroutine %s redefined"
6124 : "Subroutine %s redefined"
6126 CopLINE_set(PL_curcop, oldline);
6136 if (cv) /* must reuse cv if autoloaded */
6139 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6143 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6147 (void)gv_fetchfile(filename);
6148 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6149 an external constant string */
6151 CvXSUB(cv) = subaddr;
6154 process_special_blocks(name, gv, cv);
6166 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6171 OP* pegop = newOP(OP_NULL, 0);
6175 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6176 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6179 if ((cv = GvFORM(gv))) {
6180 if (ckWARN(WARN_REDEFINE)) {
6181 const line_t oldline = CopLINE(PL_curcop);
6182 if (PL_parser && PL_parser->copline != NOLINE)
6183 CopLINE_set(PL_curcop, PL_parser->copline);
6185 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6186 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6188 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6189 "Format STDOUT redefined");
6191 CopLINE_set(PL_curcop, oldline);
6198 CvFILE_set_from_cop(cv, PL_curcop);
6201 pad_tidy(padtidy_FORMAT);
6202 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6203 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6204 OpREFCNT_set(CvROOT(cv), 1);
6205 CvSTART(cv) = LINKLIST(CvROOT(cv));
6206 CvROOT(cv)->op_next = 0;
6207 CALL_PEEP(CvSTART(cv));
6209 op_getmad(o,pegop,'n');
6210 op_getmad_weak(block, pegop, 'b');
6215 PL_parser->copline = NOLINE;
6223 Perl_newANONLIST(pTHX_ OP *o)
6225 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6229 Perl_newANONHASH(pTHX_ OP *o)
6231 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6235 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6237 return newANONATTRSUB(floor, proto, NULL, block);
6241 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6243 return newUNOP(OP_REFGEN, 0,
6244 newSVOP(OP_ANONCODE, 0,
6245 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6249 Perl_oopsAV(pTHX_ OP *o)
6253 PERL_ARGS_ASSERT_OOPSAV;
6255 switch (o->op_type) {
6257 o->op_type = OP_PADAV;
6258 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6259 return ref(o, OP_RV2AV);
6262 o->op_type = OP_RV2AV;
6263 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6268 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6275 Perl_oopsHV(pTHX_ OP *o)
6279 PERL_ARGS_ASSERT_OOPSHV;
6281 switch (o->op_type) {
6284 o->op_type = OP_PADHV;
6285 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6286 return ref(o, OP_RV2HV);
6290 o->op_type = OP_RV2HV;
6291 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6296 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6303 Perl_newAVREF(pTHX_ OP *o)
6307 PERL_ARGS_ASSERT_NEWAVREF;
6309 if (o->op_type == OP_PADANY) {
6310 o->op_type = OP_PADAV;
6311 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6314 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6315 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6316 "Using an array as a reference is deprecated");
6318 return newUNOP(OP_RV2AV, 0, scalar(o));
6322 Perl_newGVREF(pTHX_ I32 type, OP *o)
6324 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6325 return newUNOP(OP_NULL, 0, o);
6326 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6330 Perl_newHVREF(pTHX_ OP *o)
6334 PERL_ARGS_ASSERT_NEWHVREF;
6336 if (o->op_type == OP_PADANY) {
6337 o->op_type = OP_PADHV;
6338 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6341 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6342 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6343 "Using a hash as a reference is deprecated");
6345 return newUNOP(OP_RV2HV, 0, scalar(o));
6349 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6351 return newUNOP(OP_RV2CV, flags, scalar(o));
6355 Perl_newSVREF(pTHX_ OP *o)
6359 PERL_ARGS_ASSERT_NEWSVREF;
6361 if (o->op_type == OP_PADANY) {
6362 o->op_type = OP_PADSV;
6363 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6366 return newUNOP(OP_RV2SV, 0, scalar(o));
6369 /* Check routines. See the comments at the top of this file for details
6370 * on when these are called */
6373 Perl_ck_anoncode(pTHX_ OP *o)
6375 PERL_ARGS_ASSERT_CK_ANONCODE;
6377 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6379 cSVOPo->op_sv = NULL;
6384 Perl_ck_bitop(pTHX_ OP *o)
6388 PERL_ARGS_ASSERT_CK_BITOP;
6390 #define OP_IS_NUMCOMPARE(op) \
6391 ((op) == OP_LT || (op) == OP_I_LT || \
6392 (op) == OP_GT || (op) == OP_I_GT || \
6393 (op) == OP_LE || (op) == OP_I_LE || \
6394 (op) == OP_GE || (op) == OP_I_GE || \
6395 (op) == OP_EQ || (op) == OP_I_EQ || \
6396 (op) == OP_NE || (op) == OP_I_NE || \
6397 (op) == OP_NCMP || (op) == OP_I_NCMP)
6398 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6399 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6400 && (o->op_type == OP_BIT_OR
6401 || o->op_type == OP_BIT_AND
6402 || o->op_type == OP_BIT_XOR))
6404 const OP * const left = cBINOPo->op_first;
6405 const OP * const right = left->op_sibling;
6406 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6407 (left->op_flags & OPf_PARENS) == 0) ||
6408 (OP_IS_NUMCOMPARE(right->op_type) &&
6409 (right->op_flags & OPf_PARENS) == 0))
6410 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6411 "Possible precedence problem on bitwise %c operator",
6412 o->op_type == OP_BIT_OR ? '|'
6413 : o->op_type == OP_BIT_AND ? '&' : '^'
6420 Perl_ck_concat(pTHX_ OP *o)
6422 const OP * const kid = cUNOPo->op_first;
6424 PERL_ARGS_ASSERT_CK_CONCAT;
6425 PERL_UNUSED_CONTEXT;
6427 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6428 !(kUNOP->op_first->op_flags & OPf_MOD))
6429 o->op_flags |= OPf_STACKED;
6434 Perl_ck_spair(pTHX_ OP *o)
6438 PERL_ARGS_ASSERT_CK_SPAIR;
6440 if (o->op_flags & OPf_KIDS) {
6443 const OPCODE type = o->op_type;
6444 o = modkids(ck_fun(o), type);
6445 kid = cUNOPo->op_first;
6446 newop = kUNOP->op_first->op_sibling;
6448 const OPCODE type = newop->op_type;
6449 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6450 type == OP_PADAV || type == OP_PADHV ||
6451 type == OP_RV2AV || type == OP_RV2HV)
6455 op_getmad(kUNOP->op_first,newop,'K');
6457 op_free(kUNOP->op_first);
6459 kUNOP->op_first = newop;
6461 o->op_ppaddr = PL_ppaddr[++o->op_type];
6466 Perl_ck_delete(pTHX_ OP *o)
6468 PERL_ARGS_ASSERT_CK_DELETE;
6472 if (o->op_flags & OPf_KIDS) {
6473 OP * const kid = cUNOPo->op_first;
6474 switch (kid->op_type) {
6476 o->op_flags |= OPf_SPECIAL;
6479 o->op_private |= OPpSLICE;
6482 o->op_flags |= OPf_SPECIAL;
6487 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6490 if (kid->op_private & OPpLVAL_INTRO)
6491 o->op_private |= OPpLVAL_INTRO;
6498 Perl_ck_die(pTHX_ OP *o)
6500 PERL_ARGS_ASSERT_CK_DIE;
6503 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6509 Perl_ck_eof(pTHX_ OP *o)
6513 PERL_ARGS_ASSERT_CK_EOF;
6515 if (o->op_flags & OPf_KIDS) {
6516 if (cLISTOPo->op_first->op_type == OP_STUB) {
6518 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6520 op_getmad(o,newop,'O');
6532 Perl_ck_eval(pTHX_ OP *o)
6536 PERL_ARGS_ASSERT_CK_EVAL;
6538 PL_hints |= HINT_BLOCK_SCOPE;
6539 if (o->op_flags & OPf_KIDS) {
6540 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6543 o->op_flags &= ~OPf_KIDS;
6546 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6552 cUNOPo->op_first = 0;
6557 NewOp(1101, enter, 1, LOGOP);
6558 enter->op_type = OP_ENTERTRY;
6559 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6560 enter->op_private = 0;
6562 /* establish postfix order */
6563 enter->op_next = (OP*)enter;
6565 CHECKOP(OP_ENTERTRY, enter);
6567 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6568 o->op_type = OP_LEAVETRY;
6569 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6570 enter->op_other = o;
6571 op_getmad(oldo,o,'O');
6585 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6586 op_getmad(oldo,o,'O');
6588 o->op_targ = (PADOFFSET)PL_hints;
6589 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6590 /* Store a copy of %^H that pp_entereval can pick up. */
6591 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6592 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6593 cUNOPo->op_first->op_sibling = hhop;
6594 o->op_private |= OPpEVAL_HAS_HH;
6600 Perl_ck_exit(pTHX_ OP *o)
6602 PERL_ARGS_ASSERT_CK_EXIT;
6605 HV * const table = GvHV(PL_hintgv);
6607 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6608 if (svp && *svp && SvTRUE(*svp))
6609 o->op_private |= OPpEXIT_VMSISH;
6611 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6617 Perl_ck_exec(pTHX_ OP *o)
6619 PERL_ARGS_ASSERT_CK_EXEC;
6621 if (o->op_flags & OPf_STACKED) {
6624 kid = cUNOPo->op_first->op_sibling;
6625 if (kid->op_type == OP_RV2GV)
6634 Perl_ck_exists(pTHX_ OP *o)
6638 PERL_ARGS_ASSERT_CK_EXISTS;
6641 if (o->op_flags & OPf_KIDS) {
6642 OP * const kid = cUNOPo->op_first;
6643 if (kid->op_type == OP_ENTERSUB) {
6644 (void) ref(kid, o->op_type);
6645 if (kid->op_type != OP_RV2CV
6646 && !(PL_parser && PL_parser->error_count))
6647 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6649 o->op_private |= OPpEXISTS_SUB;
6651 else if (kid->op_type == OP_AELEM)
6652 o->op_flags |= OPf_SPECIAL;
6653 else if (kid->op_type != OP_HELEM)
6654 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6662 Perl_ck_rvconst(pTHX_ register OP *o)
6665 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6667 PERL_ARGS_ASSERT_CK_RVCONST;
6669 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6670 if (o->op_type == OP_RV2CV)
6671 o->op_private &= ~1;
6673 if (kid->op_type == OP_CONST) {
6676 SV * const kidsv = kid->op_sv;
6678 /* Is it a constant from cv_const_sv()? */
6679 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6680 SV * const rsv = SvRV(kidsv);
6681 const svtype type = SvTYPE(rsv);
6682 const char *badtype = NULL;
6684 switch (o->op_type) {
6686 if (type > SVt_PVMG)
6687 badtype = "a SCALAR";
6690 if (type != SVt_PVAV)
6691 badtype = "an ARRAY";
6694 if (type != SVt_PVHV)
6698 if (type != SVt_PVCV)
6703 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6706 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6707 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6708 /* If this is an access to a stash, disable "strict refs", because
6709 * stashes aren't auto-vivified at compile-time (unless we store
6710 * symbols in them), and we don't want to produce a run-time
6711 * stricture error when auto-vivifying the stash. */
6712 const char *s = SvPV_nolen(kidsv);
6713 const STRLEN l = SvCUR(kidsv);
6714 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6715 o->op_private &= ~HINT_STRICT_REFS;
6717 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6718 const char *badthing;
6719 switch (o->op_type) {
6721 badthing = "a SCALAR";
6724 badthing = "an ARRAY";
6727 badthing = "a HASH";
6735 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6736 SVfARG(kidsv), badthing);
6739 * This is a little tricky. We only want to add the symbol if we
6740 * didn't add it in the lexer. Otherwise we get duplicate strict
6741 * warnings. But if we didn't add it in the lexer, we must at
6742 * least pretend like we wanted to add it even if it existed before,
6743 * or we get possible typo warnings. OPpCONST_ENTERED says
6744 * whether the lexer already added THIS instance of this symbol.
6746 iscv = (o->op_type == OP_RV2CV) * 2;
6748 gv = gv_fetchsv(kidsv,
6749 iscv | !(kid->op_private & OPpCONST_ENTERED),
6752 : o->op_type == OP_RV2SV
6754 : o->op_type == OP_RV2AV
6756 : o->op_type == OP_RV2HV
6759 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6761 kid->op_type = OP_GV;
6762 SvREFCNT_dec(kid->op_sv);
6764 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6765 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6766 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6768 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6770 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6772 kid->op_private = 0;
6773 kid->op_ppaddr = PL_ppaddr[OP_GV];
6780 Perl_ck_ftst(pTHX_ OP *o)
6783 const I32 type = o->op_type;
6785 PERL_ARGS_ASSERT_CK_FTST;
6787 if (o->op_flags & OPf_REF) {
6790 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6791 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6792 const OPCODE kidtype = kid->op_type;
6794 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6795 OP * const newop = newGVOP(type, OPf_REF,
6796 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6798 op_getmad(o,newop,'O');
6804 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6805 o->op_private |= OPpFT_ACCESS;
6806 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6807 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6808 o->op_private |= OPpFT_STACKED;
6816 if (type == OP_FTTTY)
6817 o = newGVOP(type, OPf_REF, PL_stdingv);
6819 o = newUNOP(type, 0, newDEFSVOP());
6820 op_getmad(oldo,o,'O');
6826 Perl_ck_fun(pTHX_ OP *o)
6829 const int type = o->op_type;
6830 register I32 oa = PL_opargs[type] >> OASHIFT;
6832 PERL_ARGS_ASSERT_CK_FUN;
6834 if (o->op_flags & OPf_STACKED) {
6835 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6838 return no_fh_allowed(o);
6841 if (o->op_flags & OPf_KIDS) {
6842 OP **tokid = &cLISTOPo->op_first;
6843 register OP *kid = cLISTOPo->op_first;
6847 if (kid->op_type == OP_PUSHMARK ||
6848 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6850 tokid = &kid->op_sibling;
6851 kid = kid->op_sibling;
6853 if (!kid && PL_opargs[type] & OA_DEFGV)
6854 *tokid = kid = newDEFSVOP();
6858 sibl = kid->op_sibling;
6860 if (!sibl && kid->op_type == OP_STUB) {
6867 /* list seen where single (scalar) arg expected? */
6868 if (numargs == 1 && !(oa >> 4)
6869 && kid->op_type == OP_LIST && type != OP_SCALAR)
6871 return too_many_arguments(o,PL_op_desc[type]);
6884 if ((type == OP_PUSH || type == OP_UNSHIFT)
6885 && !kid->op_sibling)
6886 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6887 "Useless use of %s with no values",
6890 if (kid->op_type == OP_CONST &&
6891 (kid->op_private & OPpCONST_BARE))
6893 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6894 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6895 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6896 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6897 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6899 op_getmad(kid,newop,'K');
6904 kid->op_sibling = sibl;
6907 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6908 bad_type(numargs, "array", PL_op_desc[type], kid);
6912 if (kid->op_type == OP_CONST &&
6913 (kid->op_private & OPpCONST_BARE))
6915 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6916 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6917 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6918 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6919 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6921 op_getmad(kid,newop,'K');
6926 kid->op_sibling = sibl;
6929 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6930 bad_type(numargs, "hash", PL_op_desc[type], kid);
6935 OP * const newop = newUNOP(OP_NULL, 0, kid);
6936 kid->op_sibling = 0;
6938 newop->op_next = newop;
6940 kid->op_sibling = sibl;
6945 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6946 if (kid->op_type == OP_CONST &&
6947 (kid->op_private & OPpCONST_BARE))
6949 OP * const newop = newGVOP(OP_GV, 0,
6950 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6951 if (!(o->op_private & 1) && /* if not unop */
6952 kid == cLISTOPo->op_last)
6953 cLISTOPo->op_last = newop;
6955 op_getmad(kid,newop,'K');
6961 else if (kid->op_type == OP_READLINE) {
6962 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6963 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6966 I32 flags = OPf_SPECIAL;
6970 /* is this op a FH constructor? */
6971 if (is_handle_constructor(o,numargs)) {
6972 const char *name = NULL;
6976 /* Set a flag to tell rv2gv to vivify
6977 * need to "prove" flag does not mean something
6978 * else already - NI-S 1999/05/07
6981 if (kid->op_type == OP_PADSV) {
6983 = PAD_COMPNAME_SV(kid->op_targ);
6984 name = SvPV_const(namesv, len);
6986 else if (kid->op_type == OP_RV2SV
6987 && kUNOP->op_first->op_type == OP_GV)
6989 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6991 len = GvNAMELEN(gv);
6993 else if (kid->op_type == OP_AELEM
6994 || kid->op_type == OP_HELEM)
6997 OP *op = ((BINOP*)kid)->op_first;
7001 const char * const a =
7002 kid->op_type == OP_AELEM ?
7004 if (((op->op_type == OP_RV2AV) ||
7005 (op->op_type == OP_RV2HV)) &&
7006 (firstop = ((UNOP*)op)->op_first) &&
7007 (firstop->op_type == OP_GV)) {
7008 /* packagevar $a[] or $h{} */
7009 GV * const gv = cGVOPx_gv(firstop);
7017 else if (op->op_type == OP_PADAV
7018 || op->op_type == OP_PADHV) {
7019 /* lexicalvar $a[] or $h{} */
7020 const char * const padname =
7021 PAD_COMPNAME_PV(op->op_targ);
7030 name = SvPV_const(tmpstr, len);
7035 name = "__ANONIO__";
7042 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7043 namesv = PAD_SVl(targ);
7044 SvUPGRADE(namesv, SVt_PV);
7046 sv_setpvs(namesv, "$");
7047 sv_catpvn(namesv, name, len);
7050 kid->op_sibling = 0;
7051 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7052 kid->op_targ = targ;
7053 kid->op_private |= priv;
7055 kid->op_sibling = sibl;
7061 mod(scalar(kid), type);
7065 tokid = &kid->op_sibling;
7066 kid = kid->op_sibling;
7069 if (kid && kid->op_type != OP_STUB)
7070 return too_many_arguments(o,OP_DESC(o));
7071 o->op_private |= numargs;
7073 /* FIXME - should the numargs move as for the PERL_MAD case? */
7074 o->op_private |= numargs;
7076 return too_many_arguments(o,OP_DESC(o));
7080 else if (PL_opargs[type] & OA_DEFGV) {
7082 OP *newop = newUNOP(type, 0, newDEFSVOP());
7083 op_getmad(o,newop,'O');
7086 /* Ordering of these two is important to keep f_map.t passing. */
7088 return newUNOP(type, 0, newDEFSVOP());
7093 while (oa & OA_OPTIONAL)
7095 if (oa && oa != OA_LIST)
7096 return too_few_arguments(o,OP_DESC(o));
7102 Perl_ck_glob(pTHX_ OP *o)
7107 PERL_ARGS_ASSERT_CK_GLOB;
7110 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7111 append_elem(OP_GLOB, o, newDEFSVOP());
7113 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7114 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7116 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7119 #if !defined(PERL_EXTERNAL_GLOB)
7120 /* XXX this can be tightened up and made more failsafe. */
7121 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7124 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7125 newSVpvs("File::Glob"), NULL, NULL, NULL);
7126 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7127 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7128 GvCV(gv) = GvCV(glob_gv);
7129 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7130 GvIMPORTED_CV_on(gv);
7133 #endif /* PERL_EXTERNAL_GLOB */
7135 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7136 append_elem(OP_GLOB, o,
7137 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7138 o->op_type = OP_LIST;
7139 o->op_ppaddr = PL_ppaddr[OP_LIST];
7140 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7141 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7142 cLISTOPo->op_first->op_targ = 0;
7143 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7144 append_elem(OP_LIST, o,
7145 scalar(newUNOP(OP_RV2CV, 0,
7146 newGVOP(OP_GV, 0, gv)))));
7147 o = newUNOP(OP_NULL, 0, ck_subr(o));
7148 o->op_targ = OP_GLOB; /* hint at what it used to be */
7151 gv = newGVgen("main");
7153 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7159 Perl_ck_grep(pTHX_ OP *o)
7164 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7167 PERL_ARGS_ASSERT_CK_GREP;
7169 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7170 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7172 if (o->op_flags & OPf_STACKED) {
7175 kid = cLISTOPo->op_first->op_sibling;
7176 if (!cUNOPx(kid)->op_next)
7177 Perl_croak(aTHX_ "panic: ck_grep");
7178 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7181 NewOp(1101, gwop, 1, LOGOP);
7182 kid->op_next = (OP*)gwop;
7183 o->op_flags &= ~OPf_STACKED;
7185 kid = cLISTOPo->op_first->op_sibling;
7186 if (type == OP_MAPWHILE)
7191 if (PL_parser && PL_parser->error_count)
7193 kid = cLISTOPo->op_first->op_sibling;
7194 if (kid->op_type != OP_NULL)
7195 Perl_croak(aTHX_ "panic: ck_grep");
7196 kid = kUNOP->op_first;
7199 NewOp(1101, gwop, 1, LOGOP);
7200 gwop->op_type = type;
7201 gwop->op_ppaddr = PL_ppaddr[type];
7202 gwop->op_first = listkids(o);
7203 gwop->op_flags |= OPf_KIDS;
7204 gwop->op_other = LINKLIST(kid);
7205 kid->op_next = (OP*)gwop;
7206 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7207 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7208 o->op_private = gwop->op_private = 0;
7209 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7212 o->op_private = gwop->op_private = OPpGREP_LEX;
7213 gwop->op_targ = o->op_targ = offset;
7216 kid = cLISTOPo->op_first->op_sibling;
7217 if (!kid || !kid->op_sibling)
7218 return too_few_arguments(o,OP_DESC(o));
7219 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7220 mod(kid, OP_GREPSTART);
7226 Perl_ck_index(pTHX_ OP *o)
7228 PERL_ARGS_ASSERT_CK_INDEX;
7230 if (o->op_flags & OPf_KIDS) {
7231 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7233 kid = kid->op_sibling; /* get past "big" */
7234 if (kid && kid->op_type == OP_CONST)
7235 fbm_compile(((SVOP*)kid)->op_sv, 0);
7241 Perl_ck_lfun(pTHX_ OP *o)
7243 const OPCODE type = o->op_type;
7245 PERL_ARGS_ASSERT_CK_LFUN;
7247 return modkids(ck_fun(o), type);
7251 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7253 PERL_ARGS_ASSERT_CK_DEFINED;
7255 if ((o->op_flags & OPf_KIDS)) {
7256 switch (cUNOPo->op_first->op_type) {
7258 /* This is needed for
7259 if (defined %stash::)
7260 to work. Do not break Tk.
7262 break; /* Globals via GV can be undef */
7264 case OP_AASSIGN: /* Is this a good idea? */
7265 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7266 "defined(@array) is deprecated");
7267 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7268 "\t(Maybe you should just omit the defined()?)\n");
7272 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7273 "defined(%%hash) is deprecated");
7274 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7275 "\t(Maybe you should just omit the defined()?)\n");
7286 Perl_ck_readline(pTHX_ OP *o)
7288 PERL_ARGS_ASSERT_CK_READLINE;
7290 if (!(o->op_flags & OPf_KIDS)) {
7292 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7294 op_getmad(o,newop,'O');
7304 Perl_ck_rfun(pTHX_ OP *o)
7306 const OPCODE type = o->op_type;
7308 PERL_ARGS_ASSERT_CK_RFUN;
7310 return refkids(ck_fun(o), type);
7314 Perl_ck_listiob(pTHX_ OP *o)
7318 PERL_ARGS_ASSERT_CK_LISTIOB;
7320 kid = cLISTOPo->op_first;
7323 kid = cLISTOPo->op_first;
7325 if (kid->op_type == OP_PUSHMARK)
7326 kid = kid->op_sibling;
7327 if (kid && o->op_flags & OPf_STACKED)
7328 kid = kid->op_sibling;
7329 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7330 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7331 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7332 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7333 cLISTOPo->op_first->op_sibling = kid;
7334 cLISTOPo->op_last = kid;
7335 kid = kid->op_sibling;
7340 append_elem(o->op_type, o, newDEFSVOP());
7346 Perl_ck_smartmatch(pTHX_ OP *o)
7349 if (0 == (o->op_flags & OPf_SPECIAL)) {
7350 OP *first = cBINOPo->op_first;
7351 OP *second = first->op_sibling;
7353 /* Implicitly take a reference to an array or hash */
7354 first->op_sibling = NULL;
7355 first = cBINOPo->op_first = ref_array_or_hash(first);
7356 second = first->op_sibling = ref_array_or_hash(second);
7358 /* Implicitly take a reference to a regular expression */
7359 if (first->op_type == OP_MATCH) {
7360 first->op_type = OP_QR;
7361 first->op_ppaddr = PL_ppaddr[OP_QR];
7363 if (second->op_type == OP_MATCH) {
7364 second->op_type = OP_QR;
7365 second->op_ppaddr = PL_ppaddr[OP_QR];
7374 Perl_ck_sassign(pTHX_ OP *o)
7377 OP * const kid = cLISTOPo->op_first;
7379 PERL_ARGS_ASSERT_CK_SASSIGN;
7381 /* has a disposable target? */
7382 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7383 && !(kid->op_flags & OPf_STACKED)
7384 /* Cannot steal the second time! */
7385 && !(kid->op_private & OPpTARGET_MY)
7386 /* Keep the full thing for madskills */
7390 OP * const kkid = kid->op_sibling;
7392 /* Can just relocate the target. */
7393 if (kkid && kkid->op_type == OP_PADSV
7394 && !(kkid->op_private & OPpLVAL_INTRO))
7396 kid->op_targ = kkid->op_targ;
7398 /* Now we do not need PADSV and SASSIGN. */
7399 kid->op_sibling = o->op_sibling; /* NULL */
7400 cLISTOPo->op_first = NULL;
7403 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7407 if (kid->op_sibling) {
7408 OP *kkid = kid->op_sibling;
7409 if (kkid->op_type == OP_PADSV
7410 && (kkid->op_private & OPpLVAL_INTRO)
7411 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7412 const PADOFFSET target = kkid->op_targ;
7413 OP *const other = newOP(OP_PADSV,
7415 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7416 OP *const first = newOP(OP_NULL, 0);
7417 OP *const nullop = newCONDOP(0, first, o, other);
7418 OP *const condop = first->op_next;
7419 /* hijacking PADSTALE for uninitialized state variables */
7420 SvPADSTALE_on(PAD_SVl(target));
7422 condop->op_type = OP_ONCE;
7423 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7424 condop->op_targ = target;
7425 other->op_targ = target;
7427 /* Because we change the type of the op here, we will skip the
7428 assinment binop->op_last = binop->op_first->op_sibling; at the
7429 end of Perl_newBINOP(). So need to do it here. */
7430 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7439 Perl_ck_match(pTHX_ OP *o)
7443 PERL_ARGS_ASSERT_CK_MATCH;
7445 if (o->op_type != OP_QR && PL_compcv) {
7446 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7447 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7448 o->op_targ = offset;
7449 o->op_private |= OPpTARGET_MY;
7452 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7453 o->op_private |= OPpRUNTIME;
7458 Perl_ck_method(pTHX_ OP *o)
7460 OP * const kid = cUNOPo->op_first;
7462 PERL_ARGS_ASSERT_CK_METHOD;
7464 if (kid->op_type == OP_CONST) {
7465 SV* sv = kSVOP->op_sv;
7466 const char * const method = SvPVX_const(sv);
7467 if (!(strchr(method, ':') || strchr(method, '\''))) {
7469 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7470 sv = newSVpvn_share(method, SvCUR(sv), 0);
7473 kSVOP->op_sv = NULL;
7475 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7477 op_getmad(o,cmop,'O');
7488 Perl_ck_null(pTHX_ OP *o)
7490 PERL_ARGS_ASSERT_CK_NULL;
7491 PERL_UNUSED_CONTEXT;
7496 Perl_ck_open(pTHX_ OP *o)
7499 HV * const table = GvHV(PL_hintgv);
7501 PERL_ARGS_ASSERT_CK_OPEN;
7504 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7507 const char *d = SvPV_const(*svp, len);
7508 const I32 mode = mode_from_discipline(d, len);
7509 if (mode & O_BINARY)
7510 o->op_private |= OPpOPEN_IN_RAW;
7511 else if (mode & O_TEXT)
7512 o->op_private |= OPpOPEN_IN_CRLF;
7515 svp = hv_fetchs(table, "open_OUT", FALSE);
7518 const char *d = SvPV_const(*svp, len);
7519 const I32 mode = mode_from_discipline(d, len);
7520 if (mode & O_BINARY)
7521 o->op_private |= OPpOPEN_OUT_RAW;
7522 else if (mode & O_TEXT)
7523 o->op_private |= OPpOPEN_OUT_CRLF;
7526 if (o->op_type == OP_BACKTICK) {
7527 if (!(o->op_flags & OPf_KIDS)) {
7528 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7530 op_getmad(o,newop,'O');
7539 /* In case of three-arg dup open remove strictness
7540 * from the last arg if it is a bareword. */
7541 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7542 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7546 if ((last->op_type == OP_CONST) && /* The bareword. */
7547 (last->op_private & OPpCONST_BARE) &&
7548 (last->op_private & OPpCONST_STRICT) &&
7549 (oa = first->op_sibling) && /* The fh. */
7550 (oa = oa->op_sibling) && /* The mode. */
7551 (oa->op_type == OP_CONST) &&
7552 SvPOK(((SVOP*)oa)->op_sv) &&
7553 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7554 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7555 (last == oa->op_sibling)) /* The bareword. */
7556 last->op_private &= ~OPpCONST_STRICT;
7562 Perl_ck_repeat(pTHX_ OP *o)
7564 PERL_ARGS_ASSERT_CK_REPEAT;
7566 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7567 o->op_private |= OPpREPEAT_DOLIST;
7568 cBINOPo->op_first = force_list(cBINOPo->op_first);
7576 Perl_ck_require(pTHX_ OP *o)
7581 PERL_ARGS_ASSERT_CK_REQUIRE;
7583 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7584 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7586 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7587 SV * const sv = kid->op_sv;
7588 U32 was_readonly = SvREADONLY(sv);
7595 sv_force_normal_flags(sv, 0);
7596 assert(!SvREADONLY(sv));
7606 for (; s < end; s++) {
7607 if (*s == ':' && s[1] == ':') {
7609 Move(s+2, s+1, end - s - 1, char);
7614 sv_catpvs(sv, ".pm");
7615 SvFLAGS(sv) |= was_readonly;
7619 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7620 /* handle override, if any */
7621 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7622 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7623 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7624 gv = gvp ? *gvp : NULL;
7628 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7629 OP * const kid = cUNOPo->op_first;
7632 cUNOPo->op_first = 0;
7636 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7637 append_elem(OP_LIST, kid,
7638 scalar(newUNOP(OP_RV2CV, 0,
7641 op_getmad(o,newop,'O');
7649 Perl_ck_return(pTHX_ OP *o)
7654 PERL_ARGS_ASSERT_CK_RETURN;
7656 kid = cLISTOPo->op_first->op_sibling;
7657 if (CvLVALUE(PL_compcv)) {
7658 for (; kid; kid = kid->op_sibling)
7659 mod(kid, OP_LEAVESUBLV);
7661 for (; kid; kid = kid->op_sibling)
7662 if ((kid->op_type == OP_NULL)
7663 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7664 /* This is a do block */
7665 OP *op = kUNOP->op_first;
7666 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7667 op = cUNOPx(op)->op_first;
7668 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7669 /* Force the use of the caller's context */
7670 op->op_flags |= OPf_SPECIAL;
7679 Perl_ck_select(pTHX_ OP *o)
7684 PERL_ARGS_ASSERT_CK_SELECT;
7686 if (o->op_flags & OPf_KIDS) {
7687 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7688 if (kid && kid->op_sibling) {
7689 o->op_type = OP_SSELECT;
7690 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7692 return fold_constants(o);
7696 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7697 if (kid && kid->op_type == OP_RV2GV)
7698 kid->op_private &= ~HINT_STRICT_REFS;
7703 Perl_ck_shift(pTHX_ OP *o)
7706 const I32 type = o->op_type;
7708 PERL_ARGS_ASSERT_CK_SHIFT;
7710 if (!(o->op_flags & OPf_KIDS)) {
7711 OP *argop = newUNOP(OP_RV2AV, 0,
7712 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7714 OP * const oldo = o;
7715 o = newUNOP(type, 0, scalar(argop));
7716 op_getmad(oldo,o,'O');
7720 return newUNOP(type, 0, scalar(argop));
7723 return scalar(modkids(ck_fun(o), type));
7727 Perl_ck_sort(pTHX_ OP *o)
7732 PERL_ARGS_ASSERT_CK_SORT;
7734 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7735 HV * const hinthv = GvHV(PL_hintgv);
7737 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7739 const I32 sorthints = (I32)SvIV(*svp);
7740 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7741 o->op_private |= OPpSORT_QSORT;
7742 if ((sorthints & HINT_SORT_STABLE) != 0)
7743 o->op_private |= OPpSORT_STABLE;
7748 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7750 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7751 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7753 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7755 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7757 if (kid->op_type == OP_SCOPE) {
7761 else if (kid->op_type == OP_LEAVE) {
7762 if (o->op_type == OP_SORT) {
7763 op_null(kid); /* wipe out leave */
7766 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7767 if (k->op_next == kid)
7769 /* don't descend into loops */
7770 else if (k->op_type == OP_ENTERLOOP
7771 || k->op_type == OP_ENTERITER)
7773 k = cLOOPx(k)->op_lastop;
7778 kid->op_next = 0; /* just disconnect the leave */
7779 k = kLISTOP->op_first;
7784 if (o->op_type == OP_SORT) {
7785 /* provide scalar context for comparison function/block */
7791 o->op_flags |= OPf_SPECIAL;
7793 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7796 firstkid = firstkid->op_sibling;
7799 /* provide list context for arguments */
7800 if (o->op_type == OP_SORT)
7807 S_simplify_sort(pTHX_ OP *o)
7810 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7816 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7818 if (!(o->op_flags & OPf_STACKED))
7820 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7821 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7822 kid = kUNOP->op_first; /* get past null */
7823 if (kid->op_type != OP_SCOPE)
7825 kid = kLISTOP->op_last; /* get past scope */
7826 switch(kid->op_type) {
7834 k = kid; /* remember this node*/
7835 if (kBINOP->op_first->op_type != OP_RV2SV)
7837 kid = kBINOP->op_first; /* get past cmp */
7838 if (kUNOP->op_first->op_type != OP_GV)
7840 kid = kUNOP->op_first; /* get past rv2sv */
7842 if (GvSTASH(gv) != PL_curstash)
7844 gvname = GvNAME(gv);
7845 if (*gvname == 'a' && gvname[1] == '\0')
7847 else if (*gvname == 'b' && gvname[1] == '\0')
7852 kid = k; /* back to cmp */
7853 if (kBINOP->op_last->op_type != OP_RV2SV)
7855 kid = kBINOP->op_last; /* down to 2nd arg */
7856 if (kUNOP->op_first->op_type != OP_GV)
7858 kid = kUNOP->op_first; /* get past rv2sv */
7860 if (GvSTASH(gv) != PL_curstash)
7862 gvname = GvNAME(gv);
7864 ? !(*gvname == 'a' && gvname[1] == '\0')
7865 : !(*gvname == 'b' && gvname[1] == '\0'))
7867 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7869 o->op_private |= OPpSORT_DESCEND;
7870 if (k->op_type == OP_NCMP)
7871 o->op_private |= OPpSORT_NUMERIC;
7872 if (k->op_type == OP_I_NCMP)
7873 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7874 kid = cLISTOPo->op_first->op_sibling;
7875 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7877 op_getmad(kid,o,'S'); /* then delete it */
7879 op_free(kid); /* then delete it */
7884 Perl_ck_split(pTHX_ OP *o)
7889 PERL_ARGS_ASSERT_CK_SPLIT;
7891 if (o->op_flags & OPf_STACKED)
7892 return no_fh_allowed(o);
7894 kid = cLISTOPo->op_first;
7895 if (kid->op_type != OP_NULL)
7896 Perl_croak(aTHX_ "panic: ck_split");
7897 kid = kid->op_sibling;
7898 op_free(cLISTOPo->op_first);
7899 cLISTOPo->op_first = kid;
7901 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7902 cLISTOPo->op_last = kid; /* There was only one element previously */
7905 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7906 OP * const sibl = kid->op_sibling;
7907 kid->op_sibling = 0;
7908 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7909 if (cLISTOPo->op_first == cLISTOPo->op_last)
7910 cLISTOPo->op_last = kid;
7911 cLISTOPo->op_first = kid;
7912 kid->op_sibling = sibl;
7915 kid->op_type = OP_PUSHRE;
7916 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7918 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7919 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7920 "Use of /g modifier is meaningless in split");
7923 if (!kid->op_sibling)
7924 append_elem(OP_SPLIT, o, newDEFSVOP());
7926 kid = kid->op_sibling;
7929 if (!kid->op_sibling)
7930 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7931 assert(kid->op_sibling);
7933 kid = kid->op_sibling;
7936 if (kid->op_sibling)
7937 return too_many_arguments(o,OP_DESC(o));
7943 Perl_ck_join(pTHX_ OP *o)
7945 const OP * const kid = cLISTOPo->op_first->op_sibling;
7947 PERL_ARGS_ASSERT_CK_JOIN;
7949 if (kid && kid->op_type == OP_MATCH) {
7950 if (ckWARN(WARN_SYNTAX)) {
7951 const REGEXP *re = PM_GETRE(kPMOP);
7952 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7953 const STRLEN len = re ? RX_PRELEN(re) : 6;
7954 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7955 "/%.*s/ should probably be written as \"%.*s\"",
7956 (int)len, pmstr, (int)len, pmstr);
7963 Perl_ck_subr(pTHX_ OP *o)
7966 OP *prev = ((cUNOPo->op_first->op_sibling)
7967 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7968 OP *o2 = prev->op_sibling;
7970 const char *proto = NULL;
7971 const char *proto_end = NULL;
7976 I32 contextclass = 0;
7977 const char *e = NULL;
7980 PERL_ARGS_ASSERT_CK_SUBR;
7982 o->op_private |= OPpENTERSUB_HASTARG;
7983 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7984 if (cvop->op_type == OP_RV2CV) {
7985 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7986 op_null(cvop); /* disable rv2cv */
7987 if (!(o->op_private & OPpENTERSUB_AMPER)) {
7988 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7990 switch (tmpop->op_type) {
7992 gv = cGVOPx_gv(tmpop);
7995 tmpop->op_private |= OPpEARLY_CV;
7998 SV *sv = cSVOPx_sv(tmpop);
7999 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8003 if (cv && SvPOK(cv)) {
8005 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8006 proto = SvPV(MUTABLE_SV(cv), len);
8007 proto_end = proto + len;
8011 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8012 if (o2->op_type == OP_CONST)
8013 o2->op_private &= ~OPpCONST_STRICT;
8014 else if (o2->op_type == OP_LIST) {
8015 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8016 if (sib && sib->op_type == OP_CONST)
8017 sib->op_private &= ~OPpCONST_STRICT;
8020 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8021 if (PERLDB_SUB && PL_curstash != PL_debstash)
8022 o->op_private |= OPpENTERSUB_DB;
8023 while (o2 != cvop) {
8025 if (PL_madskills && o2->op_type == OP_STUB) {
8026 o2 = o2->op_sibling;
8029 if (PL_madskills && o2->op_type == OP_NULL)
8030 o3 = ((UNOP*)o2)->op_first;
8034 if (proto >= proto_end)
8035 return too_many_arguments(o, gv_ename(namegv));
8043 /* _ must be at the end */
8044 if (proto[1] && proto[1] != ';')
8059 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8061 arg == 1 ? "block or sub {}" : "sub {}",
8062 gv_ename(namegv), o3);
8065 /* '*' allows any scalar type, including bareword */
8068 if (o3->op_type == OP_RV2GV)
8069 goto wrapref; /* autoconvert GLOB -> GLOBref */
8070 else if (o3->op_type == OP_CONST)
8071 o3->op_private &= ~OPpCONST_STRICT;
8072 else if (o3->op_type == OP_ENTERSUB) {
8073 /* accidental subroutine, revert to bareword */
8074 OP *gvop = ((UNOP*)o3)->op_first;
8075 if (gvop && gvop->op_type == OP_NULL) {
8076 gvop = ((UNOP*)gvop)->op_first;
8078 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8081 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8082 (gvop = ((UNOP*)gvop)->op_first) &&
8083 gvop->op_type == OP_GV)
8085 GV * const gv = cGVOPx_gv(gvop);
8086 OP * const sibling = o2->op_sibling;
8087 SV * const n = newSVpvs("");
8089 OP * const oldo2 = o2;
8093 gv_fullname4(n, gv, "", FALSE);
8094 o2 = newSVOP(OP_CONST, 0, n);
8095 op_getmad(oldo2,o2,'O');
8096 prev->op_sibling = o2;
8097 o2->op_sibling = sibling;
8113 if (contextclass++ == 0) {
8114 e = strchr(proto, ']');
8115 if (!e || e == proto)
8124 const char *p = proto;
8125 const char *const end = proto;
8127 while (*--p != '[') {}
8128 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8130 gv_ename(namegv), o3);
8135 if (o3->op_type == OP_RV2GV)
8138 bad_type(arg, "symbol", gv_ename(namegv), o3);
8141 if (o3->op_type == OP_ENTERSUB)
8144 bad_type(arg, "subroutine entry", gv_ename(namegv),
8148 if (o3->op_type == OP_RV2SV ||
8149 o3->op_type == OP_PADSV ||
8150 o3->op_type == OP_HELEM ||
8151 o3->op_type == OP_AELEM)
8154 bad_type(arg, "scalar", gv_ename(namegv), o3);
8157 if (o3->op_type == OP_RV2AV ||
8158 o3->op_type == OP_PADAV)
8161 bad_type(arg, "array", gv_ename(namegv), o3);
8164 if (o3->op_type == OP_RV2HV ||
8165 o3->op_type == OP_PADHV)
8168 bad_type(arg, "hash", gv_ename(namegv), o3);
8173 OP* const sib = kid->op_sibling;
8174 kid->op_sibling = 0;
8175 o2 = newUNOP(OP_REFGEN, 0, kid);
8176 o2->op_sibling = sib;
8177 prev->op_sibling = o2;
8179 if (contextclass && e) {
8194 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8195 gv_ename(namegv), SVfARG(cv));
8200 mod(o2, OP_ENTERSUB);
8202 o2 = o2->op_sibling;
8204 if (o2 == cvop && proto && *proto == '_') {
8205 /* generate an access to $_ */
8207 o2->op_sibling = prev->op_sibling;
8208 prev->op_sibling = o2; /* instead of cvop */
8210 if (proto && !optional && proto_end > proto &&
8211 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8212 return too_few_arguments(o, gv_ename(namegv));
8215 OP * const oldo = o;
8219 o=newSVOP(OP_CONST, 0, newSViv(0));
8220 op_getmad(oldo,o,'O');
8226 Perl_ck_svconst(pTHX_ OP *o)
8228 PERL_ARGS_ASSERT_CK_SVCONST;
8229 PERL_UNUSED_CONTEXT;
8230 SvREADONLY_on(cSVOPo->op_sv);
8235 Perl_ck_chdir(pTHX_ OP *o)
8237 if (o->op_flags & OPf_KIDS) {
8238 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8240 if (kid && kid->op_type == OP_CONST &&
8241 (kid->op_private & OPpCONST_BARE))
8243 o->op_flags |= OPf_SPECIAL;
8244 kid->op_private &= ~OPpCONST_STRICT;
8251 Perl_ck_trunc(pTHX_ OP *o)
8253 PERL_ARGS_ASSERT_CK_TRUNC;
8255 if (o->op_flags & OPf_KIDS) {
8256 SVOP *kid = (SVOP*)cUNOPo->op_first;
8258 if (kid->op_type == OP_NULL)
8259 kid = (SVOP*)kid->op_sibling;
8260 if (kid && kid->op_type == OP_CONST &&
8261 (kid->op_private & OPpCONST_BARE))
8263 o->op_flags |= OPf_SPECIAL;
8264 kid->op_private &= ~OPpCONST_STRICT;
8271 Perl_ck_unpack(pTHX_ OP *o)
8273 OP *kid = cLISTOPo->op_first;
8275 PERL_ARGS_ASSERT_CK_UNPACK;
8277 if (kid->op_sibling) {
8278 kid = kid->op_sibling;
8279 if (!kid->op_sibling)
8280 kid->op_sibling = newDEFSVOP();
8286 Perl_ck_substr(pTHX_ OP *o)
8288 PERL_ARGS_ASSERT_CK_SUBSTR;
8291 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8292 OP *kid = cLISTOPo->op_first;
8294 if (kid->op_type == OP_NULL)
8295 kid = kid->op_sibling;
8297 kid->op_flags |= OPf_MOD;
8304 Perl_ck_each(pTHX_ OP *o)
8307 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8309 PERL_ARGS_ASSERT_CK_EACH;
8312 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8313 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8314 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8315 o->op_type = new_type;
8316 o->op_ppaddr = PL_ppaddr[new_type];
8318 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8319 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8321 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8328 /* caller is supposed to assign the return to the
8329 container of the rep_op var */
8331 S_opt_scalarhv(pTHX_ OP *rep_op) {
8334 PERL_ARGS_ASSERT_OPT_SCALARHV;
8336 NewOp(1101, unop, 1, UNOP);
8337 unop->op_type = (OPCODE)OP_BOOLKEYS;
8338 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8339 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8340 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8341 unop->op_first = rep_op;
8342 unop->op_next = rep_op->op_next;
8343 rep_op->op_next = (OP*)unop;
8344 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8345 unop->op_sibling = rep_op->op_sibling;
8346 rep_op->op_sibling = NULL;
8347 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8348 if (rep_op->op_type == OP_PADHV) {
8349 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8350 rep_op->op_flags |= OPf_WANT_LIST;
8355 /* A peephole optimizer. We visit the ops in the order they're to execute.
8356 * See the comments at the top of this file for more details about when
8357 * peep() is called */
8360 Perl_peep(pTHX_ register OP *o)
8363 register OP* oldop = NULL;
8365 if (!o || o->op_opt)
8369 SAVEVPTR(PL_curcop);
8370 for (; o; o = o->op_next) {
8373 /* By default, this op has now been optimised. A couple of cases below
8374 clear this again. */
8377 switch (o->op_type) {
8380 PL_curcop = ((COP*)o); /* for warnings */
8384 if (cSVOPo->op_private & OPpCONST_STRICT)
8385 no_bareword_allowed(o);
8388 case OP_METHOD_NAMED:
8389 /* Relocate sv to the pad for thread safety.
8390 * Despite being a "constant", the SV is written to,
8391 * for reference counts, sv_upgrade() etc. */
8393 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8394 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8395 /* If op_sv is already a PADTMP then it is being used by
8396 * some pad, so make a copy. */
8397 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8398 SvREADONLY_on(PAD_SVl(ix));
8399 SvREFCNT_dec(cSVOPo->op_sv);
8401 else if (o->op_type != OP_METHOD_NAMED
8402 && cSVOPo->op_sv == &PL_sv_undef) {
8403 /* PL_sv_undef is hack - it's unsafe to store it in the
8404 AV that is the pad, because av_fetch treats values of
8405 PL_sv_undef as a "free" AV entry and will merrily
8406 replace them with a new SV, causing pad_alloc to think
8407 that this pad slot is free. (When, clearly, it is not)
8409 SvOK_off(PAD_SVl(ix));
8410 SvPADTMP_on(PAD_SVl(ix));
8411 SvREADONLY_on(PAD_SVl(ix));
8414 SvREFCNT_dec(PAD_SVl(ix));
8415 SvPADTMP_on(cSVOPo->op_sv);
8416 PAD_SETSV(ix, cSVOPo->op_sv);
8417 /* XXX I don't know how this isn't readonly already. */
8418 SvREADONLY_on(PAD_SVl(ix));
8420 cSVOPo->op_sv = NULL;
8427 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8428 if (o->op_next->op_private & OPpTARGET_MY) {
8429 if (o->op_flags & OPf_STACKED) /* chained concats */
8430 break; /* ignore_optimization */
8432 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8433 o->op_targ = o->op_next->op_targ;
8434 o->op_next->op_targ = 0;
8435 o->op_private |= OPpTARGET_MY;
8438 op_null(o->op_next);
8442 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8443 break; /* Scalar stub must produce undef. List stub is noop */
8447 if (o->op_targ == OP_NEXTSTATE
8448 || o->op_targ == OP_DBSTATE)
8450 PL_curcop = ((COP*)o);
8452 /* XXX: We avoid setting op_seq here to prevent later calls
8453 to peep() from mistakenly concluding that optimisation
8454 has already occurred. This doesn't fix the real problem,
8455 though (See 20010220.007). AMS 20010719 */
8456 /* op_seq functionality is now replaced by op_opt */
8463 if (oldop && o->op_next) {
8464 oldop->op_next = o->op_next;
8472 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8473 OP* const pop = (o->op_type == OP_PADAV) ?
8474 o->op_next : o->op_next->op_next;
8476 if (pop && pop->op_type == OP_CONST &&
8477 ((PL_op = pop->op_next)) &&
8478 pop->op_next->op_type == OP_AELEM &&
8479 !(pop->op_next->op_private &
8480 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8481 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8486 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8487 no_bareword_allowed(pop);
8488 if (o->op_type == OP_GV)
8489 op_null(o->op_next);
8490 op_null(pop->op_next);
8492 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8493 o->op_next = pop->op_next->op_next;
8494 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8495 o->op_private = (U8)i;
8496 if (o->op_type == OP_GV) {
8501 o->op_flags |= OPf_SPECIAL;
8502 o->op_type = OP_AELEMFAST;
8507 if (o->op_next->op_type == OP_RV2SV) {
8508 if (!(o->op_next->op_private & OPpDEREF)) {
8509 op_null(o->op_next);
8510 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8512 o->op_next = o->op_next->op_next;
8513 o->op_type = OP_GVSV;
8514 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8517 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8518 GV * const gv = cGVOPo_gv;
8519 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8520 /* XXX could check prototype here instead of just carping */
8521 SV * const sv = sv_newmortal();
8522 gv_efullname3(sv, gv, NULL);
8523 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8524 "%"SVf"() called too early to check prototype",
8528 else if (o->op_next->op_type == OP_READLINE
8529 && o->op_next->op_next->op_type == OP_CONCAT
8530 && (o->op_next->op_next->op_flags & OPf_STACKED))
8532 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8533 o->op_type = OP_RCATLINE;
8534 o->op_flags |= OPf_STACKED;
8535 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8536 op_null(o->op_next->op_next);
8537 op_null(o->op_next);
8547 fop = cUNOP->op_first;
8555 fop = cLOGOP->op_first;
8556 sop = fop->op_sibling;
8557 while (cLOGOP->op_other->op_type == OP_NULL)
8558 cLOGOP->op_other = cLOGOP->op_other->op_next;
8559 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8563 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8565 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8570 if (!(nop->op_flags && OPf_WANT_VOID)) {
8571 while (nop && nop->op_next) {
8572 switch (nop->op_next->op_type) {
8577 lop = nop = nop->op_next;
8588 if (lop->op_flags && OPf_WANT_VOID) {
8589 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8590 cLOGOP->op_first = opt_scalarhv(fop);
8591 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8592 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8608 while (cLOGOP->op_other->op_type == OP_NULL)
8609 cLOGOP->op_other = cLOGOP->op_other->op_next;
8610 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8615 while (cLOOP->op_redoop->op_type == OP_NULL)
8616 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8617 peep(cLOOP->op_redoop);
8618 while (cLOOP->op_nextop->op_type == OP_NULL)
8619 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8620 peep(cLOOP->op_nextop);
8621 while (cLOOP->op_lastop->op_type == OP_NULL)
8622 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8623 peep(cLOOP->op_lastop);
8627 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8628 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8629 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8630 cPMOP->op_pmstashstartu.op_pmreplstart
8631 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8632 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8636 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8637 && ckWARN(WARN_SYNTAX))
8639 if (o->op_next->op_sibling) {
8640 const OPCODE type = o->op_next->op_sibling->op_type;
8641 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8642 const line_t oldline = CopLINE(PL_curcop);
8643 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8644 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8645 "Statement unlikely to be reached");
8646 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8647 "\t(Maybe you meant system() when you said exec()?)\n");
8648 CopLINE_set(PL_curcop, oldline);
8659 const char *key = NULL;
8662 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8665 /* Make the CONST have a shared SV */
8666 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8667 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8668 key = SvPV_const(sv, keylen);
8669 lexname = newSVpvn_share(key,
8670 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8676 if ((o->op_private & (OPpLVAL_INTRO)))
8679 rop = (UNOP*)((BINOP*)o)->op_first;
8680 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8682 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8683 if (!SvPAD_TYPED(lexname))
8685 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8686 if (!fields || !GvHV(*fields))
8688 key = SvPV_const(*svp, keylen);
8689 if (!hv_fetch(GvHV(*fields), key,
8690 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8692 Perl_croak(aTHX_ "No such class field \"%s\" "
8693 "in variable %s of type %s",
8694 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8707 SVOP *first_key_op, *key_op;
8709 if ((o->op_private & (OPpLVAL_INTRO))
8710 /* I bet there's always a pushmark... */
8711 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8712 /* hmmm, no optimization if list contains only one key. */
8714 rop = (UNOP*)((LISTOP*)o)->op_last;
8715 if (rop->op_type != OP_RV2HV)
8717 if (rop->op_first->op_type == OP_PADSV)
8718 /* @$hash{qw(keys here)} */
8719 rop = (UNOP*)rop->op_first;
8721 /* @{$hash}{qw(keys here)} */
8722 if (rop->op_first->op_type == OP_SCOPE
8723 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8725 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8731 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8732 if (!SvPAD_TYPED(lexname))
8734 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8735 if (!fields || !GvHV(*fields))
8737 /* Again guessing that the pushmark can be jumped over.... */
8738 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8739 ->op_first->op_sibling;
8740 for (key_op = first_key_op; key_op;
8741 key_op = (SVOP*)key_op->op_sibling) {
8742 if (key_op->op_type != OP_CONST)
8744 svp = cSVOPx_svp(key_op);
8745 key = SvPV_const(*svp, keylen);
8746 if (!hv_fetch(GvHV(*fields), key,
8747 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8749 Perl_croak(aTHX_ "No such class field \"%s\" "
8750 "in variable %s of type %s",
8751 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8758 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8762 /* check that RHS of sort is a single plain array */
8763 OP *oright = cUNOPo->op_first;
8764 if (!oright || oright->op_type != OP_PUSHMARK)
8767 /* reverse sort ... can be optimised. */
8768 if (!cUNOPo->op_sibling) {
8769 /* Nothing follows us on the list. */
8770 OP * const reverse = o->op_next;
8772 if (reverse->op_type == OP_REVERSE &&
8773 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8774 OP * const pushmark = cUNOPx(reverse)->op_first;
8775 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8776 && (cUNOPx(pushmark)->op_sibling == o)) {
8777 /* reverse -> pushmark -> sort */
8778 o->op_private |= OPpSORT_REVERSE;
8780 pushmark->op_next = oright->op_next;
8786 /* make @a = sort @a act in-place */
8788 oright = cUNOPx(oright)->op_sibling;
8791 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8792 oright = cUNOPx(oright)->op_sibling;
8796 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8797 || oright->op_next != o
8798 || (oright->op_private & OPpLVAL_INTRO)
8802 /* o2 follows the chain of op_nexts through the LHS of the
8803 * assign (if any) to the aassign op itself */
8805 if (!o2 || o2->op_type != OP_NULL)
8808 if (!o2 || o2->op_type != OP_PUSHMARK)
8811 if (o2 && o2->op_type == OP_GV)
8814 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8815 || (o2->op_private & OPpLVAL_INTRO)
8820 if (!o2 || o2->op_type != OP_NULL)
8823 if (!o2 || o2->op_type != OP_AASSIGN
8824 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8827 /* check that the sort is the first arg on RHS of assign */
8829 o2 = cUNOPx(o2)->op_first;
8830 if (!o2 || o2->op_type != OP_NULL)
8832 o2 = cUNOPx(o2)->op_first;
8833 if (!o2 || o2->op_type != OP_PUSHMARK)
8835 if (o2->op_sibling != o)
8838 /* check the array is the same on both sides */
8839 if (oleft->op_type == OP_RV2AV) {
8840 if (oright->op_type != OP_RV2AV
8841 || !cUNOPx(oright)->op_first
8842 || cUNOPx(oright)->op_first->op_type != OP_GV
8843 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8844 cGVOPx_gv(cUNOPx(oright)->op_first)
8848 else if (oright->op_type != OP_PADAV
8849 || oright->op_targ != oleft->op_targ
8853 /* transfer MODishness etc from LHS arg to RHS arg */
8854 oright->op_flags = oleft->op_flags;
8855 o->op_private |= OPpSORT_INPLACE;
8857 /* excise push->gv->rv2av->null->aassign */
8858 o2 = o->op_next->op_next;
8859 op_null(o2); /* PUSHMARK */
8861 if (o2->op_type == OP_GV) {
8862 op_null(o2); /* GV */
8865 op_null(o2); /* RV2AV or PADAV */
8866 o2 = o2->op_next->op_next;
8867 op_null(o2); /* AASSIGN */
8869 o->op_next = o2->op_next;
8875 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8877 LISTOP *enter, *exlist;
8879 enter = (LISTOP *) o->op_next;
8882 if (enter->op_type == OP_NULL) {
8883 enter = (LISTOP *) enter->op_next;
8887 /* for $a (...) will have OP_GV then OP_RV2GV here.
8888 for (...) just has an OP_GV. */
8889 if (enter->op_type == OP_GV) {
8890 gvop = (OP *) enter;
8891 enter = (LISTOP *) enter->op_next;
8894 if (enter->op_type == OP_RV2GV) {
8895 enter = (LISTOP *) enter->op_next;
8901 if (enter->op_type != OP_ENTERITER)
8904 iter = enter->op_next;
8905 if (!iter || iter->op_type != OP_ITER)
8908 expushmark = enter->op_first;
8909 if (!expushmark || expushmark->op_type != OP_NULL
8910 || expushmark->op_targ != OP_PUSHMARK)
8913 exlist = (LISTOP *) expushmark->op_sibling;
8914 if (!exlist || exlist->op_type != OP_NULL
8915 || exlist->op_targ != OP_LIST)
8918 if (exlist->op_last != o) {
8919 /* Mmm. Was expecting to point back to this op. */
8922 theirmark = exlist->op_first;
8923 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8926 if (theirmark->op_sibling != o) {
8927 /* There's something between the mark and the reverse, eg
8928 for (1, reverse (...))
8933 ourmark = ((LISTOP *)o)->op_first;
8934 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8937 ourlast = ((LISTOP *)o)->op_last;
8938 if (!ourlast || ourlast->op_next != o)
8941 rv2av = ourmark->op_sibling;
8942 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8943 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8944 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8945 /* We're just reversing a single array. */
8946 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8947 enter->op_flags |= OPf_STACKED;
8950 /* We don't have control over who points to theirmark, so sacrifice
8952 theirmark->op_next = ourmark->op_next;
8953 theirmark->op_flags = ourmark->op_flags;
8954 ourlast->op_next = gvop ? gvop : (OP *) enter;
8957 enter->op_private |= OPpITER_REVERSED;
8958 iter->op_private |= OPpITER_REVERSED;
8965 UNOP *refgen, *rv2cv;
8968 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8971 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8974 rv2gv = ((BINOP *)o)->op_last;
8975 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8978 refgen = (UNOP *)((BINOP *)o)->op_first;
8980 if (!refgen || refgen->op_type != OP_REFGEN)
8983 exlist = (LISTOP *)refgen->op_first;
8984 if (!exlist || exlist->op_type != OP_NULL
8985 || exlist->op_targ != OP_LIST)
8988 if (exlist->op_first->op_type != OP_PUSHMARK)
8991 rv2cv = (UNOP*)exlist->op_last;
8993 if (rv2cv->op_type != OP_RV2CV)
8996 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8997 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8998 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9000 o->op_private |= OPpASSIGN_CV_TO_GV;
9001 rv2gv->op_private |= OPpDONT_INIT_GV;
9002 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9010 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9011 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9021 Perl_custom_op_name(pTHX_ const OP* o)
9024 const IV index = PTR2IV(o->op_ppaddr);
9028 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9030 if (!PL_custom_op_names) /* This probably shouldn't happen */
9031 return (char *)PL_op_name[OP_CUSTOM];
9033 keysv = sv_2mortal(newSViv(index));
9035 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9037 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9039 return SvPV_nolen(HeVAL(he));
9043 Perl_custom_op_desc(pTHX_ const OP* o)
9046 const IV index = PTR2IV(o->op_ppaddr);
9050 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9052 if (!PL_custom_op_descs)
9053 return (char *)PL_op_desc[OP_CUSTOM];
9055 keysv = sv_2mortal(newSViv(index));
9057 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9059 return (char *)PL_op_desc[OP_CUSTOM];
9061 return SvPV_nolen(HeVAL(he));
9066 /* Efficient sub that returns a constant scalar value. */
9068 const_sv_xsub(pTHX_ CV* cv)
9072 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9076 /* diag_listed_as: SKIPME */
9077 Perl_croak(aTHX_ "usage: %s::%s()",
9078 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9091 * c-indentation-style: bsd
9093 * indent-tabs-mode: t
9096 * ex: set ts=8 sts=4 sw=4 noet: