4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
106 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
107 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
109 #if defined(PL_OP_SLAB_ALLOC)
111 #ifdef PERL_DEBUG_READONLY_OPS
112 # define PERL_SLAB_SIZE 4096
113 # include <sys/mman.h>
116 #ifndef PERL_SLAB_SIZE
117 #define PERL_SLAB_SIZE 2048
121 Perl_Slab_Alloc(pTHX_ size_t sz)
125 * To make incrementing use count easy PL_OpSlab is an I32 *
126 * To make inserting the link to slab PL_OpPtr is I32 **
127 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
128 * Add an overhead for pointer to slab and round up as a number of pointers
130 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
131 if ((PL_OpSpace -= sz) < 0) {
132 #ifdef PERL_DEBUG_READONLY_OPS
133 /* We need to allocate chunk by chunk so that we can control the VM
135 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
136 MAP_ANON|MAP_PRIVATE, -1, 0);
138 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
139 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
141 if(PL_OpPtr == MAP_FAILED) {
142 perror("mmap failed");
147 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
152 /* We reserve the 0'th I32 sized chunk as a use count */
153 PL_OpSlab = (I32 *) PL_OpPtr;
154 /* Reduce size by the use count word, and by the size we need.
155 * Latter is to mimic the '-=' in the if() above
157 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
158 /* Allocation pointer starts at the top.
159 Theory: because we build leaves before trunk allocating at end
160 means that at run time access is cache friendly upward
162 PL_OpPtr += PERL_SLAB_SIZE;
164 #ifdef PERL_DEBUG_READONLY_OPS
165 /* We remember this slab. */
166 /* This implementation isn't efficient, but it is simple. */
167 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
168 PL_slabs[PL_slab_count++] = PL_OpSlab;
169 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
172 assert( PL_OpSpace >= 0 );
173 /* Move the allocation pointer down */
175 assert( PL_OpPtr > (I32 **) PL_OpSlab );
176 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
177 (*PL_OpSlab)++; /* Increment use count of slab */
178 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
179 assert( *PL_OpSlab > 0 );
180 return (void *)(PL_OpPtr + 1);
183 #ifdef PERL_DEBUG_READONLY_OPS
185 Perl_pending_Slabs_to_ro(pTHX) {
186 /* Turn all the allocated op slabs read only. */
187 U32 count = PL_slab_count;
188 I32 **const slabs = PL_slabs;
190 /* Reset the array of pending OP slabs, as we're about to turn this lot
191 read only. Also, do it ahead of the loop in case the warn triggers,
192 and a warn handler has an eval */
197 /* Force a new slab for any further allocation. */
201 void *const start = slabs[count];
202 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
203 if(mprotect(start, size, PROT_READ)) {
204 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
205 start, (unsigned long) size, errno);
213 S_Slab_to_rw(pTHX_ void *op)
215 I32 * const * const ptr = (I32 **) op;
216 I32 * const slab = ptr[-1];
218 PERL_ARGS_ASSERT_SLAB_TO_RW;
220 assert( ptr-1 > (I32 **) slab );
221 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
223 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
224 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
225 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
230 Perl_op_refcnt_inc(pTHX_ OP *o)
241 Perl_op_refcnt_dec(pTHX_ OP *o)
243 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
248 # define Slab_to_rw(op)
252 Perl_Slab_Free(pTHX_ void *op)
254 I32 * const * const ptr = (I32 **) op;
255 I32 * const slab = ptr[-1];
256 PERL_ARGS_ASSERT_SLAB_FREE;
257 assert( ptr-1 > (I32 **) slab );
258 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
261 if (--(*slab) == 0) {
263 # define PerlMemShared PerlMem
266 #ifdef PERL_DEBUG_READONLY_OPS
267 U32 count = PL_slab_count;
268 /* Need to remove this slab from our list of slabs */
271 if (PL_slabs[count] == slab) {
273 /* Found it. Move the entry at the end to overwrite it. */
274 DEBUG_m(PerlIO_printf(Perl_debug_log,
275 "Deallocate %p by moving %p from %lu to %lu\n",
277 PL_slabs[PL_slab_count - 1],
278 PL_slab_count, count));
279 PL_slabs[count] = PL_slabs[--PL_slab_count];
280 /* Could realloc smaller at this point, but probably not
282 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
283 perror("munmap failed");
291 PerlMemShared_free(slab);
293 if (slab == PL_OpSlab) {
300 * In the following definition, the ", (OP*)0" is just to make the compiler
301 * think the expression is of the right type: croak actually does a Siglongjmp.
303 #define CHECKOP(type,o) \
304 ((PL_op_mask && PL_op_mask[type]) \
305 ? ( op_free((OP*)o), \
306 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
308 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
310 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
313 S_gv_ename(pTHX_ GV *gv)
315 SV* const tmpsv = sv_newmortal();
317 PERL_ARGS_ASSERT_GV_ENAME;
319 gv_efullname3(tmpsv, gv, NULL);
320 return SvPV_nolen_const(tmpsv);
324 S_no_fh_allowed(pTHX_ OP *o)
326 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
328 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
334 S_too_few_arguments(pTHX_ OP *o, const char *name)
336 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
338 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
343 S_too_many_arguments(pTHX_ OP *o, const char *name)
345 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
347 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
352 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
354 PERL_ARGS_ASSERT_BAD_TYPE;
356 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
357 (int)n, name, t, OP_DESC(kid)));
361 S_no_bareword_allowed(pTHX_ const OP *o)
363 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
366 return; /* various ok barewords are hidden in extra OP_NULL */
367 qerror(Perl_mess(aTHX_
368 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
372 /* "register" allocation */
375 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
379 const bool is_our = (PL_parser->in_my == KEY_our);
381 PERL_ARGS_ASSERT_ALLOCMY;
384 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
387 /* Until we're using the length for real, cross check that we're being
389 assert(strlen(name) == len);
391 /* complain about "my $<special_var>" etc etc */
395 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
396 (name[1] == '_' && (*name == '$' || len > 2))))
398 /* name[2] is true if strlen(name) > 2 */
399 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
400 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
401 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
402 PL_parser->in_my == KEY_state ? "state" : "my"));
404 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
405 PL_parser->in_my == KEY_state ? "state" : "my"));
409 /* allocate a spare slot and store the name in that slot */
411 off = pad_add_name(name, len,
412 is_our ? padadd_OUR :
413 PL_parser->in_my == KEY_state ? padadd_STATE : 0,
414 PL_parser->in_my_stash,
416 /* $_ is always in main::, even with our */
417 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
421 /* anon sub prototypes contains state vars should always be cloned,
422 * otherwise the state var would be shared between anon subs */
424 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
425 CvCLONE_on(PL_compcv);
430 /* free the body of an op without examining its contents.
431 * Always use this rather than FreeOp directly */
434 S_op_destroy(pTHX_ OP *o)
436 if (o->op_latefree) {
444 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
446 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
452 Perl_op_free(pTHX_ OP *o)
459 if (o->op_latefreed) {
466 if (o->op_private & OPpREFCOUNTED) {
477 refcnt = OpREFCNT_dec(o);
480 /* Need to find and remove any pattern match ops from the list
481 we maintain for reset(). */
482 find_and_forget_pmops(o);
492 /* Call the op_free hook if it has been set. Do it now so that it's called
493 * at the right time for refcounted ops, but still before all of the kids
497 if (o->op_flags & OPf_KIDS) {
498 register OP *kid, *nextkid;
499 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
500 nextkid = kid->op_sibling; /* Get before next freeing kid */
505 #ifdef PERL_DEBUG_READONLY_OPS
509 /* COP* is not cleared by op_clear() so that we may track line
510 * numbers etc even after null() */
511 if (type == OP_NEXTSTATE || type == OP_DBSTATE
512 || (type == OP_NULL /* the COP might have been null'ed */
513 && ((OPCODE)o->op_targ == OP_NEXTSTATE
514 || (OPCODE)o->op_targ == OP_DBSTATE))) {
519 type = (OPCODE)o->op_targ;
522 if (o->op_latefree) {
528 #ifdef DEBUG_LEAKING_SCALARS
535 Perl_op_clear(pTHX_ OP *o)
540 PERL_ARGS_ASSERT_OP_CLEAR;
543 /* if (o->op_madprop && o->op_madprop->mad_next)
545 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
546 "modification of a read only value" for a reason I can't fathom why.
547 It's the "" stringification of $_, where $_ was set to '' in a foreach
548 loop, but it defies simplification into a small test case.
549 However, commenting them out has caused ext/List/Util/t/weak.t to fail
552 mad_free(o->op_madprop);
558 switch (o->op_type) {
559 case OP_NULL: /* Was holding old type, if any. */
560 if (PL_madskills && o->op_targ != OP_NULL) {
561 o->op_type = (Optype)o->op_targ;
566 case OP_ENTEREVAL: /* Was holding hints. */
570 if (!(o->op_flags & OPf_REF)
571 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
577 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
578 /* not an OP_PADAV replacement */
579 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
584 /* It's possible during global destruction that the GV is freed
585 before the optree. Whilst the SvREFCNT_inc is happy to bump from
586 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
587 will trigger an assertion failure, because the entry to sv_clear
588 checks that the scalar is not already freed. A check of for
589 !SvIS_FREED(gv) turns out to be invalid, because during global
590 destruction the reference count can be forced down to zero
591 (with SVf_BREAK set). In which case raising to 1 and then
592 dropping to 0 triggers cleanup before it should happen. I
593 *think* that this might actually be a general, systematic,
594 weakness of the whole idea of SVf_BREAK, in that code *is*
595 allowed to raise and lower references during global destruction,
596 so any *valid* code that happens to do this during global
597 destruction might well trigger premature cleanup. */
598 bool still_valid = gv && SvREFCNT(gv);
601 SvREFCNT_inc_simple_void(gv);
603 if (cPADOPo->op_padix > 0) {
604 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
605 * may still exist on the pad */
606 pad_swipe(cPADOPo->op_padix, TRUE);
607 cPADOPo->op_padix = 0;
610 SvREFCNT_dec(cSVOPo->op_sv);
611 cSVOPo->op_sv = NULL;
614 int try_downgrade = SvREFCNT(gv) == 2;
617 gv_try_downgrade(gv);
621 case OP_METHOD_NAMED:
624 SvREFCNT_dec(cSVOPo->op_sv);
625 cSVOPo->op_sv = NULL;
628 Even if op_clear does a pad_free for the target of the op,
629 pad_free doesn't actually remove the sv that exists in the pad;
630 instead it lives on. This results in that it could be reused as
631 a target later on when the pad was reallocated.
634 pad_swipe(o->op_targ,1);
643 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
647 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
649 if (cPADOPo->op_padix > 0) {
650 pad_swipe(cPADOPo->op_padix, TRUE);
651 cPADOPo->op_padix = 0;
654 SvREFCNT_dec(cSVOPo->op_sv);
655 cSVOPo->op_sv = NULL;
659 PerlMemShared_free(cPVOPo->op_pv);
660 cPVOPo->op_pv = NULL;
664 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
668 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
669 /* No GvIN_PAD_off here, because other references may still
670 * exist on the pad */
671 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
674 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
680 forget_pmop(cPMOPo, 1);
681 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
682 /* we use the same protection as the "SAFE" version of the PM_ macros
683 * here since sv_clean_all might release some PMOPs
684 * after PL_regex_padav has been cleared
685 * and the clearing of PL_regex_padav needs to
686 * happen before sv_clean_all
689 if(PL_regex_pad) { /* We could be in destruction */
690 const IV offset = (cPMOPo)->op_pmoffset;
691 ReREFCNT_dec(PM_GETRE(cPMOPo));
692 PL_regex_pad[offset] = &PL_sv_undef;
693 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
697 ReREFCNT_dec(PM_GETRE(cPMOPo));
698 PM_SETRE(cPMOPo, NULL);
704 if (o->op_targ > 0) {
705 pad_free(o->op_targ);
711 S_cop_free(pTHX_ COP* cop)
713 PERL_ARGS_ASSERT_COP_FREE;
717 if (! specialWARN(cop->cop_warnings))
718 PerlMemShared_free(cop->cop_warnings);
719 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
723 S_forget_pmop(pTHX_ PMOP *const o
729 HV * const pmstash = PmopSTASH(o);
731 PERL_ARGS_ASSERT_FORGET_PMOP;
733 if (pmstash && !SvIS_FREED(pmstash)) {
734 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
736 PMOP **const array = (PMOP**) mg->mg_ptr;
737 U32 count = mg->mg_len / sizeof(PMOP**);
742 /* Found it. Move the entry at the end to overwrite it. */
743 array[i] = array[--count];
744 mg->mg_len = count * sizeof(PMOP**);
745 /* Could realloc smaller at this point always, but probably
746 not worth it. Probably worth free()ing if we're the
749 Safefree(mg->mg_ptr);
766 S_find_and_forget_pmops(pTHX_ OP *o)
768 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
770 if (o->op_flags & OPf_KIDS) {
771 OP *kid = cUNOPo->op_first;
773 switch (kid->op_type) {
778 forget_pmop((PMOP*)kid, 0);
780 find_and_forget_pmops(kid);
781 kid = kid->op_sibling;
787 Perl_op_null(pTHX_ OP *o)
791 PERL_ARGS_ASSERT_OP_NULL;
793 if (o->op_type == OP_NULL)
797 o->op_targ = o->op_type;
798 o->op_type = OP_NULL;
799 o->op_ppaddr = PL_ppaddr[OP_NULL];
803 Perl_op_refcnt_lock(pTHX)
811 Perl_op_refcnt_unlock(pTHX)
818 /* Contextualizers */
820 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
823 S_linklist(pTHX_ OP *o)
827 PERL_ARGS_ASSERT_LINKLIST;
832 /* establish postfix order */
833 first = cUNOPo->op_first;
836 o->op_next = LINKLIST(first);
839 if (kid->op_sibling) {
840 kid->op_next = LINKLIST(kid->op_sibling);
841 kid = kid->op_sibling;
855 S_scalarkids(pTHX_ OP *o)
857 if (o && o->op_flags & OPf_KIDS) {
859 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
866 S_scalarboolean(pTHX_ OP *o)
870 PERL_ARGS_ASSERT_SCALARBOOLEAN;
872 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
873 if (ckWARN(WARN_SYNTAX)) {
874 const line_t oldline = CopLINE(PL_curcop);
876 if (PL_parser && PL_parser->copline != NOLINE)
877 CopLINE_set(PL_curcop, PL_parser->copline);
878 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
879 CopLINE_set(PL_curcop, oldline);
886 Perl_scalar(pTHX_ OP *o)
891 /* assumes no premature commitment */
892 if (!o || (PL_parser && PL_parser->error_count)
893 || (o->op_flags & OPf_WANT)
894 || o->op_type == OP_RETURN)
899 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
901 switch (o->op_type) {
903 scalar(cBINOPo->op_first);
908 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
918 if (o->op_flags & OPf_KIDS) {
919 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
925 kid = cLISTOPo->op_first;
927 kid = kid->op_sibling;
930 OP *sib = kid->op_sibling;
931 if (sib && kid->op_type != OP_LEAVEWHEN) {
932 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
942 PL_curcop = &PL_compiling;
947 kid = cLISTOPo->op_first;
950 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
957 Perl_scalarvoid(pTHX_ OP *o)
961 const char* useless = NULL;
965 PERL_ARGS_ASSERT_SCALARVOID;
967 /* trailing mad null ops don't count as "there" for void processing */
969 o->op_type != OP_NULL &&
971 o->op_sibling->op_type == OP_NULL)
974 for (sib = o->op_sibling;
975 sib && sib->op_type == OP_NULL;
976 sib = sib->op_sibling) ;
982 if (o->op_type == OP_NEXTSTATE
983 || o->op_type == OP_DBSTATE
984 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
985 || o->op_targ == OP_DBSTATE)))
986 PL_curcop = (COP*)o; /* for warning below */
988 /* assumes no premature commitment */
989 want = o->op_flags & OPf_WANT;
990 if ((want && want != OPf_WANT_SCALAR)
991 || (PL_parser && PL_parser->error_count)
992 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
997 if ((o->op_private & OPpTARGET_MY)
998 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1000 return scalar(o); /* As if inside SASSIGN */
1003 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1005 switch (o->op_type) {
1007 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1011 if (o->op_flags & OPf_STACKED)
1015 if (o->op_private == 4)
1058 case OP_GETSOCKNAME:
1059 case OP_GETPEERNAME:
1064 case OP_GETPRIORITY:
1088 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1089 /* Otherwise it's "Useless use of grep iterator" */
1090 useless = OP_DESC(o);
1094 kid = cLISTOPo->op_first;
1095 if (kid && kid->op_type == OP_PUSHRE
1097 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1099 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1101 useless = OP_DESC(o);
1105 kid = cUNOPo->op_first;
1106 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1107 kid->op_type != OP_TRANS) {
1110 useless = "negative pattern binding (!~)";
1114 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1115 useless = "Non-destructive substitution (s///r)";
1122 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1123 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1124 useless = "a variable";
1129 if (cSVOPo->op_private & OPpCONST_STRICT)
1130 no_bareword_allowed(o);
1132 if (ckWARN(WARN_VOID)) {
1134 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1135 "a constant (%"SVf")", sv));
1136 useless = SvPV_nolen(msv);
1139 useless = "a constant (undef)";
1140 if (o->op_private & OPpCONST_ARYBASE)
1142 /* don't warn on optimised away booleans, eg
1143 * use constant Foo, 5; Foo || print; */
1144 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1146 /* the constants 0 and 1 are permitted as they are
1147 conventionally used as dummies in constructs like
1148 1 while some_condition_with_side_effects; */
1149 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1151 else if (SvPOK(sv)) {
1152 /* perl4's way of mixing documentation and code
1153 (before the invention of POD) was based on a
1154 trick to mix nroff and perl code. The trick was
1155 built upon these three nroff macros being used in
1156 void context. The pink camel has the details in
1157 the script wrapman near page 319. */
1158 const char * const maybe_macro = SvPVX_const(sv);
1159 if (strnEQ(maybe_macro, "di", 2) ||
1160 strnEQ(maybe_macro, "ds", 2) ||
1161 strnEQ(maybe_macro, "ig", 2))
1166 op_null(o); /* don't execute or even remember it */
1170 o->op_type = OP_PREINC; /* pre-increment is faster */
1171 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1175 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1176 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1180 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1181 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1185 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1186 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1191 kid = cLOGOPo->op_first;
1192 if (kid->op_type == OP_NOT
1193 && (kid->op_flags & OPf_KIDS)
1195 if (o->op_type == OP_AND) {
1197 o->op_ppaddr = PL_ppaddr[OP_OR];
1199 o->op_type = OP_AND;
1200 o->op_ppaddr = PL_ppaddr[OP_AND];
1209 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1214 if (o->op_flags & OPf_STACKED)
1221 if (!(o->op_flags & OPf_KIDS))
1232 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1242 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1247 S_listkids(pTHX_ OP *o)
1249 if (o && o->op_flags & OPf_KIDS) {
1251 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1258 Perl_list(pTHX_ OP *o)
1263 /* assumes no premature commitment */
1264 if (!o || (o->op_flags & OPf_WANT)
1265 || (PL_parser && PL_parser->error_count)
1266 || o->op_type == OP_RETURN)
1271 if ((o->op_private & OPpTARGET_MY)
1272 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1274 return o; /* As if inside SASSIGN */
1277 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1279 switch (o->op_type) {
1282 list(cBINOPo->op_first);
1287 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1295 if (!(o->op_flags & OPf_KIDS))
1297 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1298 list(cBINOPo->op_first);
1299 return gen_constant_list(o);
1306 kid = cLISTOPo->op_first;
1308 kid = kid->op_sibling;
1311 OP *sib = kid->op_sibling;
1312 if (sib && kid->op_type != OP_LEAVEWHEN) {
1313 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1323 PL_curcop = &PL_compiling;
1327 kid = cLISTOPo->op_first;
1334 S_scalarseq(pTHX_ OP *o)
1338 const OPCODE type = o->op_type;
1340 if (type == OP_LINESEQ || type == OP_SCOPE ||
1341 type == OP_LEAVE || type == OP_LEAVETRY)
1344 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1345 if (kid->op_sibling) {
1349 PL_curcop = &PL_compiling;
1351 o->op_flags &= ~OPf_PARENS;
1352 if (PL_hints & HINT_BLOCK_SCOPE)
1353 o->op_flags |= OPf_PARENS;
1356 o = newOP(OP_STUB, 0);
1361 S_modkids(pTHX_ OP *o, I32 type)
1363 if (o && o->op_flags & OPf_KIDS) {
1365 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1371 /* Propagate lvalue ("modifiable") context to an op and its children.
1372 * 'type' represents the context type, roughly based on the type of op that
1373 * would do the modifying, although local() is represented by OP_NULL.
1374 * It's responsible for detecting things that can't be modified, flag
1375 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1376 * might have to vivify a reference in $x), and so on.
1378 * For example, "$a+1 = 2" would cause mod() to be called with o being
1379 * OP_ADD and type being OP_SASSIGN, and would output an error.
1383 Perl_mod(pTHX_ OP *o, I32 type)
1387 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1390 if (!o || (PL_parser && PL_parser->error_count))
1393 if ((o->op_private & OPpTARGET_MY)
1394 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1399 switch (o->op_type) {
1405 if (!(o->op_private & OPpCONST_ARYBASE))
1408 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1409 CopARYBASE_set(&PL_compiling,
1410 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1414 SAVECOPARYBASE(&PL_compiling);
1415 CopARYBASE_set(&PL_compiling, 0);
1417 else if (type == OP_REFGEN)
1420 Perl_croak(aTHX_ "That use of $[ is unsupported");
1423 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1427 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1428 !(o->op_flags & OPf_STACKED)) {
1429 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1430 /* The default is to set op_private to the number of children,
1431 which for a UNOP such as RV2CV is always 1. And w're using
1432 the bit for a flag in RV2CV, so we need it clear. */
1433 o->op_private &= ~1;
1434 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1435 assert(cUNOPo->op_first->op_type == OP_NULL);
1436 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1439 else if (o->op_private & OPpENTERSUB_NOMOD)
1441 else { /* lvalue subroutine call */
1442 o->op_private |= OPpLVAL_INTRO;
1443 PL_modcount = RETURN_UNLIMITED_NUMBER;
1444 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1445 /* Backward compatibility mode: */
1446 o->op_private |= OPpENTERSUB_INARGS;
1449 else { /* Compile-time error message: */
1450 OP *kid = cUNOPo->op_first;
1454 if (kid->op_type != OP_PUSHMARK) {
1455 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1457 "panic: unexpected lvalue entersub "
1458 "args: type/targ %ld:%"UVuf,
1459 (long)kid->op_type, (UV)kid->op_targ);
1460 kid = kLISTOP->op_first;
1462 while (kid->op_sibling)
1463 kid = kid->op_sibling;
1464 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1466 if (kid->op_type == OP_METHOD_NAMED
1467 || kid->op_type == OP_METHOD)
1471 NewOp(1101, newop, 1, UNOP);
1472 newop->op_type = OP_RV2CV;
1473 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1474 newop->op_first = NULL;
1475 newop->op_next = (OP*)newop;
1476 kid->op_sibling = (OP*)newop;
1477 newop->op_private |= OPpLVAL_INTRO;
1478 newop->op_private &= ~1;
1482 if (kid->op_type != OP_RV2CV)
1484 "panic: unexpected lvalue entersub "
1485 "entry via type/targ %ld:%"UVuf,
1486 (long)kid->op_type, (UV)kid->op_targ);
1487 kid->op_private |= OPpLVAL_INTRO;
1488 break; /* Postpone until runtime */
1492 kid = kUNOP->op_first;
1493 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1494 kid = kUNOP->op_first;
1495 if (kid->op_type == OP_NULL)
1497 "Unexpected constant lvalue entersub "
1498 "entry via type/targ %ld:%"UVuf,
1499 (long)kid->op_type, (UV)kid->op_targ);
1500 if (kid->op_type != OP_GV) {
1501 /* Restore RV2CV to check lvalueness */
1503 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1504 okid->op_next = kid->op_next;
1505 kid->op_next = okid;
1508 okid->op_next = NULL;
1509 okid->op_type = OP_RV2CV;
1511 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1512 okid->op_private |= OPpLVAL_INTRO;
1513 okid->op_private &= ~1;
1517 cv = GvCV(kGVOP_gv);
1527 /* grep, foreach, subcalls, refgen */
1528 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1530 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1531 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1533 : (o->op_type == OP_ENTERSUB
1534 ? "non-lvalue subroutine call"
1536 type ? PL_op_desc[type] : "local"));
1550 case OP_RIGHT_SHIFT:
1559 if (!(o->op_flags & OPf_STACKED))
1566 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1572 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1573 PL_modcount = RETURN_UNLIMITED_NUMBER;
1574 return o; /* Treat \(@foo) like ordinary list. */
1578 if (scalar_mod_type(o, type))
1580 ref(cUNOPo->op_first, o->op_type);
1584 if (type == OP_LEAVESUBLV)
1585 o->op_private |= OPpMAYBE_LVSUB;
1591 PL_modcount = RETURN_UNLIMITED_NUMBER;
1594 PL_hints |= HINT_BLOCK_SCOPE;
1595 if (type == OP_LEAVESUBLV)
1596 o->op_private |= OPpMAYBE_LVSUB;
1600 ref(cUNOPo->op_first, o->op_type);
1604 PL_hints |= HINT_BLOCK_SCOPE;
1619 PL_modcount = RETURN_UNLIMITED_NUMBER;
1620 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1621 return o; /* Treat \(@foo) like ordinary list. */
1622 if (scalar_mod_type(o, type))
1624 if (type == OP_LEAVESUBLV)
1625 o->op_private |= OPpMAYBE_LVSUB;
1629 if (!type) /* local() */
1630 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1631 PAD_COMPNAME_PV(o->op_targ));
1639 if (type != OP_SASSIGN)
1643 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1648 if (type == OP_LEAVESUBLV)
1649 o->op_private |= OPpMAYBE_LVSUB;
1651 pad_free(o->op_targ);
1652 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1653 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1654 if (o->op_flags & OPf_KIDS)
1655 mod(cBINOPo->op_first->op_sibling, type);
1660 ref(cBINOPo->op_first, o->op_type);
1661 if (type == OP_ENTERSUB &&
1662 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1663 o->op_private |= OPpLVAL_DEFER;
1664 if (type == OP_LEAVESUBLV)
1665 o->op_private |= OPpMAYBE_LVSUB;
1675 if (o->op_flags & OPf_KIDS)
1676 mod(cLISTOPo->op_last, type);
1681 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1683 else if (!(o->op_flags & OPf_KIDS))
1685 if (o->op_targ != OP_LIST) {
1686 mod(cBINOPo->op_first, type);
1692 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1697 if (type != OP_LEAVESUBLV)
1699 break; /* mod()ing was handled by ck_return() */
1702 /* [20011101.069] File test operators interpret OPf_REF to mean that
1703 their argument is a filehandle; thus \stat(".") should not set
1705 if (type == OP_REFGEN &&
1706 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1709 if (type != OP_LEAVESUBLV)
1710 o->op_flags |= OPf_MOD;
1712 if (type == OP_AASSIGN || type == OP_SASSIGN)
1713 o->op_flags |= OPf_SPECIAL|OPf_REF;
1714 else if (!type) { /* local() */
1717 o->op_private |= OPpLVAL_INTRO;
1718 o->op_flags &= ~OPf_SPECIAL;
1719 PL_hints |= HINT_BLOCK_SCOPE;
1724 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1725 "Useless localization of %s", OP_DESC(o));
1728 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1729 && type != OP_LEAVESUBLV)
1730 o->op_flags |= OPf_REF;
1735 S_scalar_mod_type(const OP *o, I32 type)
1737 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1741 if (o->op_type == OP_RV2GV)
1765 case OP_RIGHT_SHIFT:
1785 S_is_handle_constructor(const OP *o, I32 numargs)
1787 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1789 switch (o->op_type) {
1797 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1810 S_refkids(pTHX_ OP *o, I32 type)
1812 if (o && o->op_flags & OPf_KIDS) {
1814 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1821 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1826 PERL_ARGS_ASSERT_DOREF;
1828 if (!o || (PL_parser && PL_parser->error_count))
1831 switch (o->op_type) {
1833 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1834 !(o->op_flags & OPf_STACKED)) {
1835 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1836 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1837 assert(cUNOPo->op_first->op_type == OP_NULL);
1838 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1839 o->op_flags |= OPf_SPECIAL;
1840 o->op_private &= ~1;
1845 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1846 doref(kid, type, set_op_ref);
1849 if (type == OP_DEFINED)
1850 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1851 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1854 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1855 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1856 : type == OP_RV2HV ? OPpDEREF_HV
1858 o->op_flags |= OPf_MOD;
1865 o->op_flags |= OPf_REF;
1868 if (type == OP_DEFINED)
1869 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1870 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1876 o->op_flags |= OPf_REF;
1881 if (!(o->op_flags & OPf_KIDS))
1883 doref(cBINOPo->op_first, type, set_op_ref);
1887 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1888 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1889 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1890 : type == OP_RV2HV ? OPpDEREF_HV
1892 o->op_flags |= OPf_MOD;
1902 if (!(o->op_flags & OPf_KIDS))
1904 doref(cLISTOPo->op_last, type, set_op_ref);
1914 S_dup_attrlist(pTHX_ OP *o)
1919 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1921 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1922 * where the first kid is OP_PUSHMARK and the remaining ones
1923 * are OP_CONST. We need to push the OP_CONST values.
1925 if (o->op_type == OP_CONST)
1926 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1928 else if (o->op_type == OP_NULL)
1932 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1934 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1935 if (o->op_type == OP_CONST)
1936 rop = append_elem(OP_LIST, rop,
1937 newSVOP(OP_CONST, o->op_flags,
1938 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1945 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1950 PERL_ARGS_ASSERT_APPLY_ATTRS;
1952 /* fake up C<use attributes $pkg,$rv,@attrs> */
1953 ENTER; /* need to protect against side-effects of 'use' */
1954 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1956 #define ATTRSMODULE "attributes"
1957 #define ATTRSMODULE_PM "attributes.pm"
1960 /* Don't force the C<use> if we don't need it. */
1961 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1962 if (svp && *svp != &PL_sv_undef)
1963 NOOP; /* already in %INC */
1965 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1966 newSVpvs(ATTRSMODULE), NULL);
1969 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1970 newSVpvs(ATTRSMODULE),
1972 prepend_elem(OP_LIST,
1973 newSVOP(OP_CONST, 0, stashsv),
1974 prepend_elem(OP_LIST,
1975 newSVOP(OP_CONST, 0,
1977 dup_attrlist(attrs))));
1983 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1986 OP *pack, *imop, *arg;
1989 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1994 assert(target->op_type == OP_PADSV ||
1995 target->op_type == OP_PADHV ||
1996 target->op_type == OP_PADAV);
1998 /* Ensure that attributes.pm is loaded. */
1999 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2001 /* Need package name for method call. */
2002 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2004 /* Build up the real arg-list. */
2005 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2007 arg = newOP(OP_PADSV, 0);
2008 arg->op_targ = target->op_targ;
2009 arg = prepend_elem(OP_LIST,
2010 newSVOP(OP_CONST, 0, stashsv),
2011 prepend_elem(OP_LIST,
2012 newUNOP(OP_REFGEN, 0,
2013 mod(arg, OP_REFGEN)),
2014 dup_attrlist(attrs)));
2016 /* Fake up a method call to import */
2017 meth = newSVpvs_share("import");
2018 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2019 append_elem(OP_LIST,
2020 prepend_elem(OP_LIST, pack, list(arg)),
2021 newSVOP(OP_METHOD_NAMED, 0, meth)));
2022 imop->op_private |= OPpENTERSUB_NOMOD;
2024 /* Combine the ops. */
2025 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2029 =notfor apidoc apply_attrs_string
2031 Attempts to apply a list of attributes specified by the C<attrstr> and
2032 C<len> arguments to the subroutine identified by the C<cv> argument which
2033 is expected to be associated with the package identified by the C<stashpv>
2034 argument (see L<attributes>). It gets this wrong, though, in that it
2035 does not correctly identify the boundaries of the individual attribute
2036 specifications within C<attrstr>. This is not really intended for the
2037 public API, but has to be listed here for systems such as AIX which
2038 need an explicit export list for symbols. (It's called from XS code
2039 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2040 to respect attribute syntax properly would be welcome.
2046 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2047 const char *attrstr, STRLEN len)
2051 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2054 len = strlen(attrstr);
2058 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2060 const char * const sstr = attrstr;
2061 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2062 attrs = append_elem(OP_LIST, attrs,
2063 newSVOP(OP_CONST, 0,
2064 newSVpvn(sstr, attrstr-sstr)));
2068 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2069 newSVpvs(ATTRSMODULE),
2070 NULL, prepend_elem(OP_LIST,
2071 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2072 prepend_elem(OP_LIST,
2073 newSVOP(OP_CONST, 0,
2074 newRV(MUTABLE_SV(cv))),
2079 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2084 PERL_ARGS_ASSERT_MY_KID;
2086 if (!o || (PL_parser && PL_parser->error_count))
2090 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2091 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2095 if (type == OP_LIST) {
2097 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2098 my_kid(kid, attrs, imopsp);
2099 } else if (type == OP_UNDEF
2105 } else if (type == OP_RV2SV || /* "our" declaration */
2107 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2108 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2109 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2111 PL_parser->in_my == KEY_our
2113 : PL_parser->in_my == KEY_state ? "state" : "my"));
2115 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2116 PL_parser->in_my = FALSE;
2117 PL_parser->in_my_stash = NULL;
2118 apply_attrs(GvSTASH(gv),
2119 (type == OP_RV2SV ? GvSV(gv) :
2120 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2121 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2124 o->op_private |= OPpOUR_INTRO;
2127 else if (type != OP_PADSV &&
2130 type != OP_PUSHMARK)
2132 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2134 PL_parser->in_my == KEY_our
2136 : PL_parser->in_my == KEY_state ? "state" : "my"));
2139 else if (attrs && type != OP_PUSHMARK) {
2142 PL_parser->in_my = FALSE;
2143 PL_parser->in_my_stash = NULL;
2145 /* check for C<my Dog $spot> when deciding package */
2146 stash = PAD_COMPNAME_TYPE(o->op_targ);
2148 stash = PL_curstash;
2149 apply_attrs_my(stash, o, attrs, imopsp);
2151 o->op_flags |= OPf_MOD;
2152 o->op_private |= OPpLVAL_INTRO;
2153 if (PL_parser->in_my == KEY_state)
2154 o->op_private |= OPpPAD_STATE;
2159 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2163 int maybe_scalar = 0;
2165 PERL_ARGS_ASSERT_MY_ATTRS;
2167 /* [perl #17376]: this appears to be premature, and results in code such as
2168 C< our(%x); > executing in list mode rather than void mode */
2170 if (o->op_flags & OPf_PARENS)
2180 o = my_kid(o, attrs, &rops);
2182 if (maybe_scalar && o->op_type == OP_PADSV) {
2183 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2184 o->op_private |= OPpLVAL_INTRO;
2187 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2189 PL_parser->in_my = FALSE;
2190 PL_parser->in_my_stash = NULL;
2195 Perl_sawparens(pTHX_ OP *o)
2197 PERL_UNUSED_CONTEXT;
2199 o->op_flags |= OPf_PARENS;
2204 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2208 const OPCODE ltype = left->op_type;
2209 const OPCODE rtype = right->op_type;
2211 PERL_ARGS_ASSERT_BIND_MATCH;
2213 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2214 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2216 const char * const desc
2217 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2218 ? (int)rtype : OP_MATCH];
2219 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2220 ? "@array" : "%hash");
2221 Perl_warner(aTHX_ packWARN(WARN_MISC),
2222 "Applying %s to %s will act on scalar(%s)",
2223 desc, sample, sample);
2226 if (rtype == OP_CONST &&
2227 cSVOPx(right)->op_private & OPpCONST_BARE &&
2228 cSVOPx(right)->op_private & OPpCONST_STRICT)
2230 no_bareword_allowed(right);
2233 /* !~ doesn't make sense with s///r, so error on it for now */
2234 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2236 yyerror("Using !~ with s///r doesn't make sense");
2238 ismatchop = rtype == OP_MATCH ||
2239 rtype == OP_SUBST ||
2241 if (ismatchop && right->op_private & OPpTARGET_MY) {
2243 right->op_private &= ~OPpTARGET_MY;
2245 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2248 right->op_flags |= OPf_STACKED;
2249 if (rtype != OP_MATCH &&
2250 ! (rtype == OP_TRANS &&
2251 right->op_private & OPpTRANS_IDENTICAL) &&
2252 ! (rtype == OP_SUBST &&
2253 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2254 newleft = mod(left, rtype);
2257 if (right->op_type == OP_TRANS)
2258 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2260 o = prepend_elem(rtype, scalar(newleft), right);
2262 return newUNOP(OP_NOT, 0, scalar(o));
2266 return bind_match(type, left,
2267 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2271 Perl_invert(pTHX_ OP *o)
2275 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2279 Perl_scope(pTHX_ OP *o)
2283 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2284 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2285 o->op_type = OP_LEAVE;
2286 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2288 else if (o->op_type == OP_LINESEQ) {
2290 o->op_type = OP_SCOPE;
2291 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2292 kid = ((LISTOP*)o)->op_first;
2293 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2296 /* The following deals with things like 'do {1 for 1}' */
2297 kid = kid->op_sibling;
2299 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2304 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2310 Perl_block_start(pTHX_ int full)
2313 const int retval = PL_savestack_ix;
2315 pad_block_start(full);
2317 PL_hints &= ~HINT_BLOCK_SCOPE;
2318 SAVECOMPILEWARNINGS();
2319 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2321 CALL_BLOCK_HOOKS(start, full);
2327 Perl_block_end(pTHX_ I32 floor, OP *seq)
2330 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2331 OP* retval = scalarseq(seq);
2333 CALL_BLOCK_HOOKS(pre_end, &retval);
2336 CopHINTS_set(&PL_compiling, PL_hints);
2338 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2341 CALL_BLOCK_HOOKS(post_end, &retval);
2347 =head1 Compile-time scope hooks
2349 =for apidoc Ao||blockhook_register
2351 Register a set of hooks to be called when the Perl lexical scope changes
2352 at compile time. See L<perlguts/"Compile-time scope hooks">.
2358 Perl_blockhook_register(pTHX_ BHK *hk)
2360 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2362 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2369 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2370 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2371 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2374 OP * const o = newOP(OP_PADSV, 0);
2375 o->op_targ = offset;
2381 Perl_newPROG(pTHX_ OP *o)
2385 PERL_ARGS_ASSERT_NEWPROG;
2390 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2391 ((PL_in_eval & EVAL_KEEPERR)
2392 ? OPf_SPECIAL : 0), o);
2393 PL_eval_start = linklist(PL_eval_root);
2394 PL_eval_root->op_private |= OPpREFCOUNTED;
2395 OpREFCNT_set(PL_eval_root, 1);
2396 PL_eval_root->op_next = 0;
2397 CALL_PEEP(PL_eval_start);
2400 if (o->op_type == OP_STUB) {
2401 PL_comppad_name = 0;
2403 S_op_destroy(aTHX_ o);
2406 PL_main_root = scope(sawparens(scalarvoid(o)));
2407 PL_curcop = &PL_compiling;
2408 PL_main_start = LINKLIST(PL_main_root);
2409 PL_main_root->op_private |= OPpREFCOUNTED;
2410 OpREFCNT_set(PL_main_root, 1);
2411 PL_main_root->op_next = 0;
2412 CALL_PEEP(PL_main_start);
2415 /* Register with debugger */
2417 CV * const cv = get_cvs("DB::postponed", 0);
2421 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2423 call_sv(MUTABLE_SV(cv), G_DISCARD);
2430 Perl_localize(pTHX_ OP *o, I32 lex)
2434 PERL_ARGS_ASSERT_LOCALIZE;
2436 if (o->op_flags & OPf_PARENS)
2437 /* [perl #17376]: this appears to be premature, and results in code such as
2438 C< our(%x); > executing in list mode rather than void mode */
2445 if ( PL_parser->bufptr > PL_parser->oldbufptr
2446 && PL_parser->bufptr[-1] == ','
2447 && ckWARN(WARN_PARENTHESIS))
2449 char *s = PL_parser->bufptr;
2452 /* some heuristics to detect a potential error */
2453 while (*s && (strchr(", \t\n", *s)))
2457 if (*s && strchr("@$%*", *s) && *++s
2458 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2461 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2463 while (*s && (strchr(", \t\n", *s)))
2469 if (sigil && (*s == ';' || *s == '=')) {
2470 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2471 "Parentheses missing around \"%s\" list",
2473 ? (PL_parser->in_my == KEY_our
2475 : PL_parser->in_my == KEY_state
2485 o = mod(o, OP_NULL); /* a bit kludgey */
2486 PL_parser->in_my = FALSE;
2487 PL_parser->in_my_stash = NULL;
2492 Perl_jmaybe(pTHX_ OP *o)
2494 PERL_ARGS_ASSERT_JMAYBE;
2496 if (o->op_type == OP_LIST) {
2498 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2499 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2505 S_fold_constants(pTHX_ register OP *o)
2508 register OP * VOL curop;
2510 VOL I32 type = o->op_type;
2515 SV * const oldwarnhook = PL_warnhook;
2516 SV * const olddiehook = PL_diehook;
2520 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2522 if (PL_opargs[type] & OA_RETSCALAR)
2524 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2525 o->op_targ = pad_alloc(type, SVs_PADTMP);
2527 /* integerize op, unless it happens to be C<-foo>.
2528 * XXX should pp_i_negate() do magic string negation instead? */
2529 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2530 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2531 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2533 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2536 if (!(PL_opargs[type] & OA_FOLDCONST))
2541 /* XXX might want a ck_negate() for this */
2542 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2553 /* XXX what about the numeric ops? */
2554 if (PL_hints & HINT_LOCALE)
2559 if (PL_parser && PL_parser->error_count)
2560 goto nope; /* Don't try to run w/ errors */
2562 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2563 const OPCODE type = curop->op_type;
2564 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2566 type != OP_SCALAR &&
2568 type != OP_PUSHMARK)
2574 curop = LINKLIST(o);
2575 old_next = o->op_next;
2579 oldscope = PL_scopestack_ix;
2580 create_eval_scope(G_FAKINGEVAL);
2582 /* Verify that we don't need to save it: */
2583 assert(PL_curcop == &PL_compiling);
2584 StructCopy(&PL_compiling, ¬_compiling, COP);
2585 PL_curcop = ¬_compiling;
2586 /* The above ensures that we run with all the correct hints of the
2587 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2588 assert(IN_PERL_RUNTIME);
2589 PL_warnhook = PERL_WARNHOOK_FATAL;
2596 sv = *(PL_stack_sp--);
2597 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2598 pad_swipe(o->op_targ, FALSE);
2599 else if (SvTEMP(sv)) { /* grab mortal temp? */
2600 SvREFCNT_inc_simple_void(sv);
2605 /* Something tried to die. Abandon constant folding. */
2606 /* Pretend the error never happened. */
2608 o->op_next = old_next;
2612 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2613 PL_warnhook = oldwarnhook;
2614 PL_diehook = olddiehook;
2615 /* XXX note that this croak may fail as we've already blown away
2616 * the stack - eg any nested evals */
2617 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2620 PL_warnhook = oldwarnhook;
2621 PL_diehook = olddiehook;
2622 PL_curcop = &PL_compiling;
2624 if (PL_scopestack_ix > oldscope)
2625 delete_eval_scope();
2634 if (type == OP_RV2GV)
2635 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2637 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2638 op_getmad(o,newop,'f');
2646 S_gen_constant_list(pTHX_ register OP *o)
2650 const I32 oldtmps_floor = PL_tmps_floor;
2653 if (PL_parser && PL_parser->error_count)
2654 return o; /* Don't attempt to run with errors */
2656 PL_op = curop = LINKLIST(o);
2662 assert (!(curop->op_flags & OPf_SPECIAL));
2663 assert(curop->op_type == OP_RANGE);
2665 PL_tmps_floor = oldtmps_floor;
2667 o->op_type = OP_RV2AV;
2668 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2669 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2670 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2671 o->op_opt = 0; /* needs to be revisited in peep() */
2672 curop = ((UNOP*)o)->op_first;
2673 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2675 op_getmad(curop,o,'O');
2684 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2687 if (!o || o->op_type != OP_LIST)
2688 o = newLISTOP(OP_LIST, 0, o, NULL);
2690 o->op_flags &= ~OPf_WANT;
2692 if (!(PL_opargs[type] & OA_MARK))
2693 op_null(cLISTOPo->op_first);
2695 o->op_type = (OPCODE)type;
2696 o->op_ppaddr = PL_ppaddr[type];
2697 o->op_flags |= flags;
2699 o = CHECKOP(type, o);
2700 if (o->op_type != (unsigned)type)
2703 return fold_constants(o);
2706 /* List constructors */
2709 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2717 if (first->op_type != (unsigned)type
2718 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2720 return newLISTOP(type, 0, first, last);
2723 if (first->op_flags & OPf_KIDS)
2724 ((LISTOP*)first)->op_last->op_sibling = last;
2726 first->op_flags |= OPf_KIDS;
2727 ((LISTOP*)first)->op_first = last;
2729 ((LISTOP*)first)->op_last = last;
2734 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2742 if (first->op_type != (unsigned)type)
2743 return prepend_elem(type, (OP*)first, (OP*)last);
2745 if (last->op_type != (unsigned)type)
2746 return append_elem(type, (OP*)first, (OP*)last);
2748 first->op_last->op_sibling = last->op_first;
2749 first->op_last = last->op_last;
2750 first->op_flags |= (last->op_flags & OPf_KIDS);
2753 if (last->op_first && first->op_madprop) {
2754 MADPROP *mp = last->op_first->op_madprop;
2756 while (mp->mad_next)
2758 mp->mad_next = first->op_madprop;
2761 last->op_first->op_madprop = first->op_madprop;
2764 first->op_madprop = last->op_madprop;
2765 last->op_madprop = 0;
2768 S_op_destroy(aTHX_ (OP*)last);
2774 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2782 if (last->op_type == (unsigned)type) {
2783 if (type == OP_LIST) { /* already a PUSHMARK there */
2784 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2785 ((LISTOP*)last)->op_first->op_sibling = first;
2786 if (!(first->op_flags & OPf_PARENS))
2787 last->op_flags &= ~OPf_PARENS;
2790 if (!(last->op_flags & OPf_KIDS)) {
2791 ((LISTOP*)last)->op_last = first;
2792 last->op_flags |= OPf_KIDS;
2794 first->op_sibling = ((LISTOP*)last)->op_first;
2795 ((LISTOP*)last)->op_first = first;
2797 last->op_flags |= OPf_KIDS;
2801 return newLISTOP(type, 0, first, last);
2809 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2812 Newxz(tk, 1, TOKEN);
2813 tk->tk_type = (OPCODE)optype;
2814 tk->tk_type = 12345;
2816 tk->tk_mad = madprop;
2821 Perl_token_free(pTHX_ TOKEN* tk)
2823 PERL_ARGS_ASSERT_TOKEN_FREE;
2825 if (tk->tk_type != 12345)
2827 mad_free(tk->tk_mad);
2832 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2837 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2839 if (tk->tk_type != 12345) {
2840 Perl_warner(aTHX_ packWARN(WARN_MISC),
2841 "Invalid TOKEN object ignored");
2848 /* faked up qw list? */
2850 tm->mad_type == MAD_SV &&
2851 SvPVX((SV *)tm->mad_val)[0] == 'q')
2858 /* pretend constant fold didn't happen? */
2859 if (mp->mad_key == 'f' &&
2860 (o->op_type == OP_CONST ||
2861 o->op_type == OP_GV) )
2863 token_getmad(tk,(OP*)mp->mad_val,slot);
2877 if (mp->mad_key == 'X')
2878 mp->mad_key = slot; /* just change the first one */
2888 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2897 /* pretend constant fold didn't happen? */
2898 if (mp->mad_key == 'f' &&
2899 (o->op_type == OP_CONST ||
2900 o->op_type == OP_GV) )
2902 op_getmad(from,(OP*)mp->mad_val,slot);
2909 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2912 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2918 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2927 /* pretend constant fold didn't happen? */
2928 if (mp->mad_key == 'f' &&
2929 (o->op_type == OP_CONST ||
2930 o->op_type == OP_GV) )
2932 op_getmad(from,(OP*)mp->mad_val,slot);
2939 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2942 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2946 PerlIO_printf(PerlIO_stderr(),
2947 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2953 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2971 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2975 addmad(tm, &(o->op_madprop), slot);
2979 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3000 Perl_newMADsv(pTHX_ char key, SV* sv)
3002 PERL_ARGS_ASSERT_NEWMADSV;
3004 return newMADPROP(key, MAD_SV, sv, 0);
3008 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3011 Newxz(mp, 1, MADPROP);
3014 mp->mad_vlen = vlen;
3015 mp->mad_type = type;
3017 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3022 Perl_mad_free(pTHX_ MADPROP* mp)
3024 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3028 mad_free(mp->mad_next);
3029 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3030 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3031 switch (mp->mad_type) {
3035 Safefree((char*)mp->mad_val);
3038 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3039 op_free((OP*)mp->mad_val);
3042 sv_free(MUTABLE_SV(mp->mad_val));
3045 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3054 Perl_newNULLLIST(pTHX)
3056 return newOP(OP_STUB, 0);
3060 S_force_list(pTHX_ OP *o)
3062 if (!o || o->op_type != OP_LIST)
3063 o = newLISTOP(OP_LIST, 0, o, NULL);
3069 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3074 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3076 NewOp(1101, listop, 1, LISTOP);
3078 listop->op_type = (OPCODE)type;
3079 listop->op_ppaddr = PL_ppaddr[type];
3082 listop->op_flags = (U8)flags;
3086 else if (!first && last)
3089 first->op_sibling = last;
3090 listop->op_first = first;
3091 listop->op_last = last;
3092 if (type == OP_LIST) {
3093 OP* const pushop = newOP(OP_PUSHMARK, 0);
3094 pushop->op_sibling = first;
3095 listop->op_first = pushop;
3096 listop->op_flags |= OPf_KIDS;
3098 listop->op_last = pushop;
3101 return CHECKOP(type, listop);
3105 Perl_newOP(pTHX_ I32 type, I32 flags)
3110 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3111 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3112 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3113 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3115 NewOp(1101, o, 1, OP);
3116 o->op_type = (OPCODE)type;
3117 o->op_ppaddr = PL_ppaddr[type];
3118 o->op_flags = (U8)flags;
3120 o->op_latefreed = 0;
3124 o->op_private = (U8)(0 | (flags >> 8));
3125 if (PL_opargs[type] & OA_RETSCALAR)
3127 if (PL_opargs[type] & OA_TARGET)
3128 o->op_targ = pad_alloc(type, SVs_PADTMP);
3129 return CHECKOP(type, o);
3133 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3138 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3139 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3140 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3141 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3142 || type == OP_SASSIGN
3143 || type == OP_ENTERTRY
3144 || type == OP_NULL );
3147 first = newOP(OP_STUB, 0);
3148 if (PL_opargs[type] & OA_MARK)
3149 first = force_list(first);
3151 NewOp(1101, unop, 1, UNOP);
3152 unop->op_type = (OPCODE)type;
3153 unop->op_ppaddr = PL_ppaddr[type];
3154 unop->op_first = first;
3155 unop->op_flags = (U8)(flags | OPf_KIDS);
3156 unop->op_private = (U8)(1 | (flags >> 8));
3157 unop = (UNOP*) CHECKOP(type, unop);
3161 return fold_constants((OP *) unop);
3165 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3170 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3171 || type == OP_SASSIGN || type == OP_NULL );
3173 NewOp(1101, binop, 1, BINOP);
3176 first = newOP(OP_NULL, 0);
3178 binop->op_type = (OPCODE)type;
3179 binop->op_ppaddr = PL_ppaddr[type];
3180 binop->op_first = first;
3181 binop->op_flags = (U8)(flags | OPf_KIDS);
3184 binop->op_private = (U8)(1 | (flags >> 8));
3187 binop->op_private = (U8)(2 | (flags >> 8));
3188 first->op_sibling = last;
3191 binop = (BINOP*)CHECKOP(type, binop);
3192 if (binop->op_next || binop->op_type != (OPCODE)type)
3195 binop->op_last = binop->op_first->op_sibling;
3197 return fold_constants((OP *)binop);
3200 static int uvcompare(const void *a, const void *b)
3201 __attribute__nonnull__(1)
3202 __attribute__nonnull__(2)
3203 __attribute__pure__;
3204 static int uvcompare(const void *a, const void *b)
3206 if (*((const UV *)a) < (*(const UV *)b))
3208 if (*((const UV *)a) > (*(const UV *)b))
3210 if (*((const UV *)a+1) < (*(const UV *)b+1))
3212 if (*((const UV *)a+1) > (*(const UV *)b+1))
3218 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3221 SV * const tstr = ((SVOP*)expr)->op_sv;
3224 (repl->op_type == OP_NULL)
3225 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3227 ((SVOP*)repl)->op_sv;
3230 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3231 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3235 register short *tbl;
3237 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3238 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3239 I32 del = o->op_private & OPpTRANS_DELETE;
3242 PERL_ARGS_ASSERT_PMTRANS;
3244 PL_hints |= HINT_BLOCK_SCOPE;
3247 o->op_private |= OPpTRANS_FROM_UTF;
3250 o->op_private |= OPpTRANS_TO_UTF;
3252 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3253 SV* const listsv = newSVpvs("# comment\n");
3255 const U8* tend = t + tlen;
3256 const U8* rend = r + rlen;
3270 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3271 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3274 const U32 flags = UTF8_ALLOW_DEFAULT;
3278 t = tsave = bytes_to_utf8(t, &len);
3281 if (!to_utf && rlen) {
3283 r = rsave = bytes_to_utf8(r, &len);
3287 /* There are several snags with this code on EBCDIC:
3288 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3289 2. scan_const() in toke.c has encoded chars in native encoding which makes
3290 ranges at least in EBCDIC 0..255 range the bottom odd.
3294 U8 tmpbuf[UTF8_MAXBYTES+1];
3297 Newx(cp, 2*tlen, UV);
3299 transv = newSVpvs("");
3301 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3303 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3305 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3309 cp[2*i+1] = cp[2*i];
3313 qsort(cp, i, 2*sizeof(UV), uvcompare);
3314 for (j = 0; j < i; j++) {
3316 diff = val - nextmin;
3318 t = uvuni_to_utf8(tmpbuf,nextmin);
3319 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3321 U8 range_mark = UTF_TO_NATIVE(0xff);
3322 t = uvuni_to_utf8(tmpbuf, val - 1);
3323 sv_catpvn(transv, (char *)&range_mark, 1);
3324 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3331 t = uvuni_to_utf8(tmpbuf,nextmin);
3332 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3334 U8 range_mark = UTF_TO_NATIVE(0xff);
3335 sv_catpvn(transv, (char *)&range_mark, 1);
3337 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3338 UNICODE_ALLOW_SUPER);
3339 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3340 t = (const U8*)SvPVX_const(transv);
3341 tlen = SvCUR(transv);
3345 else if (!rlen && !del) {
3346 r = t; rlen = tlen; rend = tend;
3349 if ((!rlen && !del) || t == r ||
3350 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3352 o->op_private |= OPpTRANS_IDENTICAL;
3356 while (t < tend || tfirst <= tlast) {
3357 /* see if we need more "t" chars */
3358 if (tfirst > tlast) {
3359 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3361 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3363 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3370 /* now see if we need more "r" chars */
3371 if (rfirst > rlast) {
3373 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3375 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3377 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3386 rfirst = rlast = 0xffffffff;
3390 /* now see which range will peter our first, if either. */
3391 tdiff = tlast - tfirst;
3392 rdiff = rlast - rfirst;
3399 if (rfirst == 0xffffffff) {
3400 diff = tdiff; /* oops, pretend rdiff is infinite */
3402 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3403 (long)tfirst, (long)tlast);
3405 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3409 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3410 (long)tfirst, (long)(tfirst + diff),
3413 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3414 (long)tfirst, (long)rfirst);
3416 if (rfirst + diff > max)
3417 max = rfirst + diff;
3419 grows = (tfirst < rfirst &&
3420 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3432 else if (max > 0xff)
3437 PerlMemShared_free(cPVOPo->op_pv);
3438 cPVOPo->op_pv = NULL;
3440 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3442 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3443 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3444 PAD_SETSV(cPADOPo->op_padix, swash);
3446 SvREADONLY_on(swash);
3448 cSVOPo->op_sv = swash;
3450 SvREFCNT_dec(listsv);
3451 SvREFCNT_dec(transv);
3453 if (!del && havefinal && rlen)
3454 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3455 newSVuv((UV)final), 0);
3458 o->op_private |= OPpTRANS_GROWS;
3464 op_getmad(expr,o,'e');
3465 op_getmad(repl,o,'r');
3473 tbl = (short*)cPVOPo->op_pv;
3475 Zero(tbl, 256, short);
3476 for (i = 0; i < (I32)tlen; i++)
3478 for (i = 0, j = 0; i < 256; i++) {
3480 if (j >= (I32)rlen) {
3489 if (i < 128 && r[j] >= 128)
3499 o->op_private |= OPpTRANS_IDENTICAL;
3501 else if (j >= (I32)rlen)
3506 PerlMemShared_realloc(tbl,
3507 (0x101+rlen-j) * sizeof(short));
3508 cPVOPo->op_pv = (char*)tbl;
3510 tbl[0x100] = (short)(rlen - j);
3511 for (i=0; i < (I32)rlen - j; i++)
3512 tbl[0x101+i] = r[j+i];
3516 if (!rlen && !del) {
3519 o->op_private |= OPpTRANS_IDENTICAL;
3521 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3522 o->op_private |= OPpTRANS_IDENTICAL;
3524 for (i = 0; i < 256; i++)
3526 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3527 if (j >= (I32)rlen) {
3529 if (tbl[t[i]] == -1)
3535 if (tbl[t[i]] == -1) {
3536 if (t[i] < 128 && r[j] >= 128)
3543 if(del && rlen == tlen) {
3544 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3545 } else if(rlen > tlen) {
3546 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3550 o->op_private |= OPpTRANS_GROWS;
3552 op_getmad(expr,o,'e');
3553 op_getmad(repl,o,'r');
3563 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3568 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3570 NewOp(1101, pmop, 1, PMOP);
3571 pmop->op_type = (OPCODE)type;
3572 pmop->op_ppaddr = PL_ppaddr[type];
3573 pmop->op_flags = (U8)flags;
3574 pmop->op_private = (U8)(0 | (flags >> 8));
3576 if (PL_hints & HINT_RE_TAINT)
3577 pmop->op_pmflags |= PMf_RETAINT;
3578 if (PL_hints & HINT_LOCALE)
3579 pmop->op_pmflags |= PMf_LOCALE;
3583 assert(SvPOK(PL_regex_pad[0]));
3584 if (SvCUR(PL_regex_pad[0])) {
3585 /* Pop off the "packed" IV from the end. */
3586 SV *const repointer_list = PL_regex_pad[0];
3587 const char *p = SvEND(repointer_list) - sizeof(IV);
3588 const IV offset = *((IV*)p);
3590 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3592 SvEND_set(repointer_list, p);
3594 pmop->op_pmoffset = offset;
3595 /* This slot should be free, so assert this: */
3596 assert(PL_regex_pad[offset] == &PL_sv_undef);
3598 SV * const repointer = &PL_sv_undef;
3599 av_push(PL_regex_padav, repointer);
3600 pmop->op_pmoffset = av_len(PL_regex_padav);
3601 PL_regex_pad = AvARRAY(PL_regex_padav);
3605 return CHECKOP(type, pmop);
3608 /* Given some sort of match op o, and an expression expr containing a
3609 * pattern, either compile expr into a regex and attach it to o (if it's
3610 * constant), or convert expr into a runtime regcomp op sequence (if it's
3613 * isreg indicates that the pattern is part of a regex construct, eg
3614 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3615 * split "pattern", which aren't. In the former case, expr will be a list
3616 * if the pattern contains more than one term (eg /a$b/) or if it contains
3617 * a replacement, ie s/// or tr///.
3621 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3626 I32 repl_has_vars = 0;
3630 PERL_ARGS_ASSERT_PMRUNTIME;
3632 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3633 /* last element in list is the replacement; pop it */
3635 repl = cLISTOPx(expr)->op_last;
3636 kid = cLISTOPx(expr)->op_first;
3637 while (kid->op_sibling != repl)
3638 kid = kid->op_sibling;
3639 kid->op_sibling = NULL;
3640 cLISTOPx(expr)->op_last = kid;
3643 if (isreg && expr->op_type == OP_LIST &&
3644 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3646 /* convert single element list to element */
3647 OP* const oe = expr;
3648 expr = cLISTOPx(oe)->op_first->op_sibling;
3649 cLISTOPx(oe)->op_first->op_sibling = NULL;
3650 cLISTOPx(oe)->op_last = NULL;
3654 if (o->op_type == OP_TRANS) {
3655 return pmtrans(o, expr, repl);
3658 reglist = isreg && expr->op_type == OP_LIST;
3662 PL_hints |= HINT_BLOCK_SCOPE;
3665 if (expr->op_type == OP_CONST) {
3666 SV *pat = ((SVOP*)expr)->op_sv;
3667 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3669 if (o->op_flags & OPf_SPECIAL)
3670 pm_flags |= RXf_SPLIT;
3673 assert (SvUTF8(pat));
3674 } else if (SvUTF8(pat)) {
3675 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3676 trapped in use 'bytes'? */
3677 /* Make a copy of the octet sequence, but without the flag on, as
3678 the compiler now honours the SvUTF8 flag on pat. */
3680 const char *const p = SvPV(pat, len);
3681 pat = newSVpvn_flags(p, len, SVs_TEMP);
3684 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3687 op_getmad(expr,(OP*)pm,'e');
3693 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3694 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3696 : OP_REGCMAYBE),0,expr);
3698 NewOp(1101, rcop, 1, LOGOP);
3699 rcop->op_type = OP_REGCOMP;
3700 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3701 rcop->op_first = scalar(expr);
3702 rcop->op_flags |= OPf_KIDS
3703 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3704 | (reglist ? OPf_STACKED : 0);
3705 rcop->op_private = 1;
3708 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3710 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3713 /* establish postfix order */
3714 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3716 rcop->op_next = expr;
3717 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3720 rcop->op_next = LINKLIST(expr);
3721 expr->op_next = (OP*)rcop;
3724 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3729 if (pm->op_pmflags & PMf_EVAL) {
3731 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3732 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3734 else if (repl->op_type == OP_CONST)
3738 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3739 if (curop->op_type == OP_SCOPE
3740 || curop->op_type == OP_LEAVE
3741 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3742 if (curop->op_type == OP_GV) {
3743 GV * const gv = cGVOPx_gv(curop);
3745 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3748 else if (curop->op_type == OP_RV2CV)
3750 else if (curop->op_type == OP_RV2SV ||
3751 curop->op_type == OP_RV2AV ||
3752 curop->op_type == OP_RV2HV ||
3753 curop->op_type == OP_RV2GV) {
3754 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3757 else if (curop->op_type == OP_PADSV ||
3758 curop->op_type == OP_PADAV ||
3759 curop->op_type == OP_PADHV ||
3760 curop->op_type == OP_PADANY)
3764 else if (curop->op_type == OP_PUSHRE)
3765 NOOP; /* Okay here, dangerous in newASSIGNOP */
3775 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3777 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3778 prepend_elem(o->op_type, scalar(repl), o);
3781 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3782 pm->op_pmflags |= PMf_MAYBE_CONST;
3784 NewOp(1101, rcop, 1, LOGOP);
3785 rcop->op_type = OP_SUBSTCONT;
3786 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3787 rcop->op_first = scalar(repl);
3788 rcop->op_flags |= OPf_KIDS;
3789 rcop->op_private = 1;
3792 /* establish postfix order */
3793 rcop->op_next = LINKLIST(repl);
3794 repl->op_next = (OP*)rcop;
3796 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3797 assert(!(pm->op_pmflags & PMf_ONCE));
3798 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3807 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3812 PERL_ARGS_ASSERT_NEWSVOP;
3814 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3815 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3816 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3818 NewOp(1101, svop, 1, SVOP);
3819 svop->op_type = (OPCODE)type;
3820 svop->op_ppaddr = PL_ppaddr[type];
3822 svop->op_next = (OP*)svop;
3823 svop->op_flags = (U8)flags;
3824 if (PL_opargs[type] & OA_RETSCALAR)
3826 if (PL_opargs[type] & OA_TARGET)
3827 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3828 return CHECKOP(type, svop);
3833 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3838 PERL_ARGS_ASSERT_NEWPADOP;
3840 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3841 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3842 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3844 NewOp(1101, padop, 1, PADOP);
3845 padop->op_type = (OPCODE)type;
3846 padop->op_ppaddr = PL_ppaddr[type];
3847 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3848 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3849 PAD_SETSV(padop->op_padix, sv);
3852 padop->op_next = (OP*)padop;
3853 padop->op_flags = (U8)flags;
3854 if (PL_opargs[type] & OA_RETSCALAR)
3856 if (PL_opargs[type] & OA_TARGET)
3857 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3858 return CHECKOP(type, padop);
3863 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3867 PERL_ARGS_ASSERT_NEWGVOP;
3871 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3873 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3878 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3883 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3884 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3886 NewOp(1101, pvop, 1, PVOP);
3887 pvop->op_type = (OPCODE)type;
3888 pvop->op_ppaddr = PL_ppaddr[type];
3890 pvop->op_next = (OP*)pvop;
3891 pvop->op_flags = (U8)flags;
3892 if (PL_opargs[type] & OA_RETSCALAR)
3894 if (PL_opargs[type] & OA_TARGET)
3895 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3896 return CHECKOP(type, pvop);
3904 Perl_package(pTHX_ OP *o)
3907 SV *const sv = cSVOPo->op_sv;
3912 PERL_ARGS_ASSERT_PACKAGE;
3914 save_hptr(&PL_curstash);
3915 save_item(PL_curstname);
3917 PL_curstash = gv_stashsv(sv, GV_ADD);
3919 sv_setsv(PL_curstname, sv);
3921 PL_hints |= HINT_BLOCK_SCOPE;
3922 PL_parser->copline = NOLINE;
3923 PL_parser->expect = XSTATE;
3928 if (!PL_madskills) {
3933 pegop = newOP(OP_NULL,0);
3934 op_getmad(o,pegop,'P');
3940 Perl_package_version( pTHX_ OP *v )
3943 U32 savehints = PL_hints;
3944 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3945 PL_hints &= ~HINT_STRICT_VARS;
3946 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3947 PL_hints = savehints;
3956 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3963 OP *pegop = newOP(OP_NULL,0);
3966 PERL_ARGS_ASSERT_UTILIZE;
3968 if (idop->op_type != OP_CONST)
3969 Perl_croak(aTHX_ "Module name must be constant");
3972 op_getmad(idop,pegop,'U');
3977 SV * const vesv = ((SVOP*)version)->op_sv;
3980 op_getmad(version,pegop,'V');
3981 if (!arg && !SvNIOKp(vesv)) {
3988 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3989 Perl_croak(aTHX_ "Version number must be a constant number");
3991 /* Make copy of idop so we don't free it twice */
3992 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3994 /* Fake up a method call to VERSION */
3995 meth = newSVpvs_share("VERSION");
3996 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3997 append_elem(OP_LIST,
3998 prepend_elem(OP_LIST, pack, list(version)),
3999 newSVOP(OP_METHOD_NAMED, 0, meth)));
4003 /* Fake up an import/unimport */
4004 if (arg && arg->op_type == OP_STUB) {
4006 op_getmad(arg,pegop,'S');
4007 imop = arg; /* no import on explicit () */
4009 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4010 imop = NULL; /* use 5.0; */
4012 idop->op_private |= OPpCONST_NOVER;
4018 op_getmad(arg,pegop,'A');
4020 /* Make copy of idop so we don't free it twice */
4021 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4023 /* Fake up a method call to import/unimport */
4025 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4026 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4027 append_elem(OP_LIST,
4028 prepend_elem(OP_LIST, pack, list(arg)),
4029 newSVOP(OP_METHOD_NAMED, 0, meth)));
4032 /* Fake up the BEGIN {}, which does its thing immediately. */
4034 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4037 append_elem(OP_LINESEQ,
4038 append_elem(OP_LINESEQ,
4039 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4040 newSTATEOP(0, NULL, veop)),
4041 newSTATEOP(0, NULL, imop) ));
4043 /* The "did you use incorrect case?" warning used to be here.
4044 * The problem is that on case-insensitive filesystems one
4045 * might get false positives for "use" (and "require"):
4046 * "use Strict" or "require CARP" will work. This causes
4047 * portability problems for the script: in case-strict
4048 * filesystems the script will stop working.
4050 * The "incorrect case" warning checked whether "use Foo"
4051 * imported "Foo" to your namespace, but that is wrong, too:
4052 * there is no requirement nor promise in the language that
4053 * a Foo.pm should or would contain anything in package "Foo".
4055 * There is very little Configure-wise that can be done, either:
4056 * the case-sensitivity of the build filesystem of Perl does not
4057 * help in guessing the case-sensitivity of the runtime environment.
4060 PL_hints |= HINT_BLOCK_SCOPE;
4061 PL_parser->copline = NOLINE;
4062 PL_parser->expect = XSTATE;
4063 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4066 if (!PL_madskills) {
4067 /* FIXME - don't allocate pegop if !PL_madskills */
4076 =head1 Embedding Functions
4078 =for apidoc load_module
4080 Loads the module whose name is pointed to by the string part of name.
4081 Note that the actual module name, not its filename, should be given.
4082 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4083 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4084 (or 0 for no flags). ver, if specified, provides version semantics
4085 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4086 arguments can be used to specify arguments to the module's import()
4087 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4088 terminated with a final NULL pointer. Note that this list can only
4089 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4090 Otherwise at least a single NULL pointer to designate the default
4091 import list is required.
4096 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4100 PERL_ARGS_ASSERT_LOAD_MODULE;
4102 va_start(args, ver);
4103 vload_module(flags, name, ver, &args);
4107 #ifdef PERL_IMPLICIT_CONTEXT
4109 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4113 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4114 va_start(args, ver);
4115 vload_module(flags, name, ver, &args);
4121 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4125 OP * const modname = newSVOP(OP_CONST, 0, name);
4127 PERL_ARGS_ASSERT_VLOAD_MODULE;
4129 modname->op_private |= OPpCONST_BARE;
4131 veop = newSVOP(OP_CONST, 0, ver);
4135 if (flags & PERL_LOADMOD_NOIMPORT) {
4136 imop = sawparens(newNULLLIST());
4138 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4139 imop = va_arg(*args, OP*);
4144 sv = va_arg(*args, SV*);
4146 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4147 sv = va_arg(*args, SV*);
4151 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4152 * that it has a PL_parser to play with while doing that, and also
4153 * that it doesn't mess with any existing parser, by creating a tmp
4154 * new parser with lex_start(). This won't actually be used for much,
4155 * since pp_require() will create another parser for the real work. */
4158 SAVEVPTR(PL_curcop);
4159 lex_start(NULL, NULL, FALSE);
4160 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4161 veop, modname, imop);
4166 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4172 PERL_ARGS_ASSERT_DOFILE;
4174 if (!force_builtin) {
4175 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4176 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4177 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4178 gv = gvp ? *gvp : NULL;
4182 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4183 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4184 append_elem(OP_LIST, term,
4185 scalar(newUNOP(OP_RV2CV, 0,
4186 newGVOP(OP_GV, 0, gv))))));
4189 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4195 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4197 return newBINOP(OP_LSLICE, flags,
4198 list(force_list(subscript)),
4199 list(force_list(listval)) );
4203 S_is_list_assignment(pTHX_ register const OP *o)
4211 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4212 o = cUNOPo->op_first;
4214 flags = o->op_flags;
4216 if (type == OP_COND_EXPR) {
4217 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4218 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4223 yyerror("Assignment to both a list and a scalar");
4227 if (type == OP_LIST &&
4228 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4229 o->op_private & OPpLVAL_INTRO)
4232 if (type == OP_LIST || flags & OPf_PARENS ||
4233 type == OP_RV2AV || type == OP_RV2HV ||
4234 type == OP_ASLICE || type == OP_HSLICE)
4237 if (type == OP_PADAV || type == OP_PADHV)
4240 if (type == OP_RV2SV)
4247 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4253 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4254 return newLOGOP(optype, 0,
4255 mod(scalar(left), optype),
4256 newUNOP(OP_SASSIGN, 0, scalar(right)));
4259 return newBINOP(optype, OPf_STACKED,
4260 mod(scalar(left), optype), scalar(right));
4264 if (is_list_assignment(left)) {
4265 static const char no_list_state[] = "Initialization of state variables"
4266 " in list context currently forbidden";
4268 bool maybe_common_vars = TRUE;
4271 /* Grandfathering $[ assignment here. Bletch.*/
4272 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4273 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4274 left = mod(left, OP_AASSIGN);
4277 else if (left->op_type == OP_CONST) {
4278 deprecate("assignment to $[");
4280 /* Result of assignment is always 1 (or we'd be dead already) */
4281 return newSVOP(OP_CONST, 0, newSViv(1));
4283 curop = list(force_list(left));
4284 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4285 o->op_private = (U8)(0 | (flags >> 8));
4287 if ((left->op_type == OP_LIST
4288 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4290 OP* lop = ((LISTOP*)left)->op_first;
4291 maybe_common_vars = FALSE;
4293 if (lop->op_type == OP_PADSV ||
4294 lop->op_type == OP_PADAV ||
4295 lop->op_type == OP_PADHV ||
4296 lop->op_type == OP_PADANY) {
4297 if (!(lop->op_private & OPpLVAL_INTRO))
4298 maybe_common_vars = TRUE;
4300 if (lop->op_private & OPpPAD_STATE) {
4301 if (left->op_private & OPpLVAL_INTRO) {
4302 /* Each variable in state($a, $b, $c) = ... */
4305 /* Each state variable in
4306 (state $a, my $b, our $c, $d, undef) = ... */
4308 yyerror(no_list_state);
4310 /* Each my variable in
4311 (state $a, my $b, our $c, $d, undef) = ... */
4313 } else if (lop->op_type == OP_UNDEF ||
4314 lop->op_type == OP_PUSHMARK) {
4315 /* undef may be interesting in
4316 (state $a, undef, state $c) */
4318 /* Other ops in the list. */
4319 maybe_common_vars = TRUE;
4321 lop = lop->op_sibling;
4324 else if ((left->op_private & OPpLVAL_INTRO)
4325 && ( left->op_type == OP_PADSV
4326 || left->op_type == OP_PADAV
4327 || left->op_type == OP_PADHV
4328 || left->op_type == OP_PADANY))
4330 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4331 if (left->op_private & OPpPAD_STATE) {
4332 /* All single variable list context state assignments, hence
4342 yyerror(no_list_state);
4346 /* PL_generation sorcery:
4347 * an assignment like ($a,$b) = ($c,$d) is easier than
4348 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4349 * To detect whether there are common vars, the global var
4350 * PL_generation is incremented for each assign op we compile.
4351 * Then, while compiling the assign op, we run through all the
4352 * variables on both sides of the assignment, setting a spare slot
4353 * in each of them to PL_generation. If any of them already have
4354 * that value, we know we've got commonality. We could use a
4355 * single bit marker, but then we'd have to make 2 passes, first
4356 * to clear the flag, then to test and set it. To find somewhere
4357 * to store these values, evil chicanery is done with SvUVX().
4360 if (maybe_common_vars) {
4363 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4364 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4365 if (curop->op_type == OP_GV) {
4366 GV *gv = cGVOPx_gv(curop);
4368 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4370 GvASSIGN_GENERATION_set(gv, PL_generation);
4372 else if (curop->op_type == OP_PADSV ||
4373 curop->op_type == OP_PADAV ||
4374 curop->op_type == OP_PADHV ||
4375 curop->op_type == OP_PADANY)
4377 if (PAD_COMPNAME_GEN(curop->op_targ)
4378 == (STRLEN)PL_generation)
4380 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4383 else if (curop->op_type == OP_RV2CV)
4385 else if (curop->op_type == OP_RV2SV ||
4386 curop->op_type == OP_RV2AV ||
4387 curop->op_type == OP_RV2HV ||
4388 curop->op_type == OP_RV2GV) {
4389 if (lastop->op_type != OP_GV) /* funny deref? */
4392 else if (curop->op_type == OP_PUSHRE) {
4394 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4395 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4397 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4399 GvASSIGN_GENERATION_set(gv, PL_generation);
4403 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4406 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4408 GvASSIGN_GENERATION_set(gv, PL_generation);
4418 o->op_private |= OPpASSIGN_COMMON;
4421 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4422 OP* tmpop = ((LISTOP*)right)->op_first;
4423 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4424 PMOP * const pm = (PMOP*)tmpop;
4425 if (left->op_type == OP_RV2AV &&
4426 !(left->op_private & OPpLVAL_INTRO) &&
4427 !(o->op_private & OPpASSIGN_COMMON) )
4429 tmpop = ((UNOP*)left)->op_first;
4430 if (tmpop->op_type == OP_GV
4432 && !pm->op_pmreplrootu.op_pmtargetoff
4434 && !pm->op_pmreplrootu.op_pmtargetgv
4438 pm->op_pmreplrootu.op_pmtargetoff
4439 = cPADOPx(tmpop)->op_padix;
4440 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4442 pm->op_pmreplrootu.op_pmtargetgv
4443 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4444 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4446 pm->op_pmflags |= PMf_ONCE;
4447 tmpop = cUNOPo->op_first; /* to list (nulled) */
4448 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4449 tmpop->op_sibling = NULL; /* don't free split */
4450 right->op_next = tmpop->op_next; /* fix starting loc */
4451 op_free(o); /* blow off assign */
4452 right->op_flags &= ~OPf_WANT;
4453 /* "I don't know and I don't care." */
4458 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4459 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4461 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4462 if (SvIOK(sv) && SvIVX(sv) == 0)
4463 sv_setiv(sv, PL_modcount+1);
4471 right = newOP(OP_UNDEF, 0);
4472 if (right->op_type == OP_READLINE) {
4473 right->op_flags |= OPf_STACKED;
4474 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4477 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4478 o = newBINOP(OP_SASSIGN, flags,
4479 scalar(right), mod(scalar(left), OP_SASSIGN) );
4483 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4484 deprecate("assignment to $[");
4486 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4487 o->op_private |= OPpCONST_ARYBASE;
4495 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4498 const U32 seq = intro_my();
4501 NewOp(1101, cop, 1, COP);
4502 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4503 cop->op_type = OP_DBSTATE;
4504 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4507 cop->op_type = OP_NEXTSTATE;
4508 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4510 cop->op_flags = (U8)flags;
4511 CopHINTS_set(cop, PL_hints);
4513 cop->op_private |= NATIVE_HINTS;
4515 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4516 cop->op_next = (OP*)cop;
4519 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4520 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4522 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4523 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4524 if (cop->cop_hints_hash) {
4526 cop->cop_hints_hash->refcounted_he_refcnt++;
4527 HINTS_REFCNT_UNLOCK;
4531 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4533 PL_hints |= HINT_BLOCK_SCOPE;
4534 /* It seems that we need to defer freeing this pointer, as other parts
4535 of the grammar end up wanting to copy it after this op has been
4540 if (PL_parser && PL_parser->copline == NOLINE)
4541 CopLINE_set(cop, CopLINE(PL_curcop));
4543 CopLINE_set(cop, PL_parser->copline);
4545 PL_parser->copline = NOLINE;
4548 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4550 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4552 CopSTASH_set(cop, PL_curstash);
4554 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4555 /* this line can have a breakpoint - store the cop in IV */
4556 AV *av = CopFILEAVx(PL_curcop);
4558 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4559 if (svp && *svp != &PL_sv_undef ) {
4560 (void)SvIOK_on(*svp);
4561 SvIV_set(*svp, PTR2IV(cop));
4566 if (flags & OPf_SPECIAL)
4568 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4573 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4577 PERL_ARGS_ASSERT_NEWLOGOP;
4579 return new_logop(type, flags, &first, &other);
4583 S_search_const(pTHX_ OP *o)
4585 PERL_ARGS_ASSERT_SEARCH_CONST;
4587 switch (o->op_type) {
4591 if (o->op_flags & OPf_KIDS)
4592 return search_const(cUNOPo->op_first);
4599 if (!(o->op_flags & OPf_KIDS))
4601 kid = cLISTOPo->op_first;
4603 switch (kid->op_type) {
4607 kid = kid->op_sibling;
4610 if (kid != cLISTOPo->op_last)
4616 kid = cLISTOPo->op_last;
4618 return search_const(kid);
4626 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4634 int prepend_not = 0;
4636 PERL_ARGS_ASSERT_NEW_LOGOP;
4641 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4642 return newBINOP(type, flags, scalar(first), scalar(other));
4644 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4646 scalarboolean(first);
4647 /* optimize AND and OR ops that have NOTs as children */
4648 if (first->op_type == OP_NOT
4649 && (first->op_flags & OPf_KIDS)
4650 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4651 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4653 if (type == OP_AND || type == OP_OR) {
4659 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4661 prepend_not = 1; /* prepend a NOT op later */
4665 /* search for a constant op that could let us fold the test */
4666 if ((cstop = search_const(first))) {
4667 if (cstop->op_private & OPpCONST_STRICT)
4668 no_bareword_allowed(cstop);
4669 else if ((cstop->op_private & OPpCONST_BARE))
4670 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4671 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4672 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4673 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4675 if (other->op_type == OP_CONST)
4676 other->op_private |= OPpCONST_SHORTCIRCUIT;
4678 OP *newop = newUNOP(OP_NULL, 0, other);
4679 op_getmad(first, newop, '1');
4680 newop->op_targ = type; /* set "was" field */
4684 if (other->op_type == OP_LEAVE)
4685 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4689 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4690 const OP *o2 = other;
4691 if ( ! (o2->op_type == OP_LIST
4692 && (( o2 = cUNOPx(o2)->op_first))
4693 && o2->op_type == OP_PUSHMARK
4694 && (( o2 = o2->op_sibling)) )
4697 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4698 || o2->op_type == OP_PADHV)
4699 && o2->op_private & OPpLVAL_INTRO
4700 && !(o2->op_private & OPpPAD_STATE))
4702 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4703 "Deprecated use of my() in false conditional");
4707 if (first->op_type == OP_CONST)
4708 first->op_private |= OPpCONST_SHORTCIRCUIT;
4710 first = newUNOP(OP_NULL, 0, first);
4711 op_getmad(other, first, '2');
4712 first->op_targ = type; /* set "was" field */
4719 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4720 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4722 const OP * const k1 = ((UNOP*)first)->op_first;
4723 const OP * const k2 = k1->op_sibling;
4725 switch (first->op_type)
4728 if (k2 && k2->op_type == OP_READLINE
4729 && (k2->op_flags & OPf_STACKED)
4730 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4732 warnop = k2->op_type;
4737 if (k1->op_type == OP_READDIR
4738 || k1->op_type == OP_GLOB
4739 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4740 || k1->op_type == OP_EACH)
4742 warnop = ((k1->op_type == OP_NULL)
4743 ? (OPCODE)k1->op_targ : k1->op_type);
4748 const line_t oldline = CopLINE(PL_curcop);
4749 CopLINE_set(PL_curcop, PL_parser->copline);
4750 Perl_warner(aTHX_ packWARN(WARN_MISC),
4751 "Value of %s%s can be \"0\"; test with defined()",
4753 ((warnop == OP_READLINE || warnop == OP_GLOB)
4754 ? " construct" : "() operator"));
4755 CopLINE_set(PL_curcop, oldline);
4762 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4763 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4765 NewOp(1101, logop, 1, LOGOP);
4767 logop->op_type = (OPCODE)type;
4768 logop->op_ppaddr = PL_ppaddr[type];
4769 logop->op_first = first;
4770 logop->op_flags = (U8)(flags | OPf_KIDS);
4771 logop->op_other = LINKLIST(other);
4772 logop->op_private = (U8)(1 | (flags >> 8));
4774 /* establish postfix order */
4775 logop->op_next = LINKLIST(first);
4776 first->op_next = (OP*)logop;
4777 first->op_sibling = other;
4779 CHECKOP(type,logop);
4781 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4788 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4796 PERL_ARGS_ASSERT_NEWCONDOP;
4799 return newLOGOP(OP_AND, 0, first, trueop);
4801 return newLOGOP(OP_OR, 0, first, falseop);
4803 scalarboolean(first);
4804 if ((cstop = search_const(first))) {
4805 /* Left or right arm of the conditional? */
4806 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4807 OP *live = left ? trueop : falseop;
4808 OP *const dead = left ? falseop : trueop;
4809 if (cstop->op_private & OPpCONST_BARE &&
4810 cstop->op_private & OPpCONST_STRICT) {
4811 no_bareword_allowed(cstop);
4814 /* This is all dead code when PERL_MAD is not defined. */
4815 live = newUNOP(OP_NULL, 0, live);
4816 op_getmad(first, live, 'C');
4817 op_getmad(dead, live, left ? 'e' : 't');
4822 if (live->op_type == OP_LEAVE)
4823 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4826 NewOp(1101, logop, 1, LOGOP);
4827 logop->op_type = OP_COND_EXPR;
4828 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4829 logop->op_first = first;
4830 logop->op_flags = (U8)(flags | OPf_KIDS);
4831 logop->op_private = (U8)(1 | (flags >> 8));
4832 logop->op_other = LINKLIST(trueop);
4833 logop->op_next = LINKLIST(falseop);
4835 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4838 /* establish postfix order */
4839 start = LINKLIST(first);
4840 first->op_next = (OP*)logop;
4842 first->op_sibling = trueop;
4843 trueop->op_sibling = falseop;
4844 o = newUNOP(OP_NULL, 0, (OP*)logop);
4846 trueop->op_next = falseop->op_next = o;
4853 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4862 PERL_ARGS_ASSERT_NEWRANGE;
4864 NewOp(1101, range, 1, LOGOP);
4866 range->op_type = OP_RANGE;
4867 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4868 range->op_first = left;
4869 range->op_flags = OPf_KIDS;
4870 leftstart = LINKLIST(left);
4871 range->op_other = LINKLIST(right);
4872 range->op_private = (U8)(1 | (flags >> 8));
4874 left->op_sibling = right;
4876 range->op_next = (OP*)range;
4877 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4878 flop = newUNOP(OP_FLOP, 0, flip);
4879 o = newUNOP(OP_NULL, 0, flop);
4881 range->op_next = leftstart;
4883 left->op_next = flip;
4884 right->op_next = flop;
4886 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4887 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4888 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4889 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4891 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4892 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4895 if (!flip->op_private || !flop->op_private)
4896 linklist(o); /* blow off optimizer unless constant */
4902 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4907 const bool once = block && block->op_flags & OPf_SPECIAL &&
4908 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4910 PERL_UNUSED_ARG(debuggable);
4913 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4914 return block; /* do {} while 0 does once */
4915 if (expr->op_type == OP_READLINE
4916 || expr->op_type == OP_READDIR
4917 || expr->op_type == OP_GLOB
4918 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4919 expr = newUNOP(OP_DEFINED, 0,
4920 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4921 } else if (expr->op_flags & OPf_KIDS) {
4922 const OP * const k1 = ((UNOP*)expr)->op_first;
4923 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4924 switch (expr->op_type) {
4926 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4927 && (k2->op_flags & OPf_STACKED)
4928 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4929 expr = newUNOP(OP_DEFINED, 0, expr);
4933 if (k1 && (k1->op_type == OP_READDIR
4934 || k1->op_type == OP_GLOB
4935 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4936 || k1->op_type == OP_EACH))
4937 expr = newUNOP(OP_DEFINED, 0, expr);
4943 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4944 * op, in listop. This is wrong. [perl #27024] */
4946 block = newOP(OP_NULL, 0);
4947 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4948 o = new_logop(OP_AND, 0, &expr, &listop);
4951 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4953 if (once && o != listop)
4954 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4957 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4959 o->op_flags |= flags;
4961 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4966 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4967 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4976 PERL_UNUSED_ARG(debuggable);
4979 if (expr->op_type == OP_READLINE
4980 || expr->op_type == OP_READDIR
4981 || expr->op_type == OP_GLOB
4982 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4983 expr = newUNOP(OP_DEFINED, 0,
4984 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4985 } else if (expr->op_flags & OPf_KIDS) {
4986 const OP * const k1 = ((UNOP*)expr)->op_first;
4987 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4988 switch (expr->op_type) {
4990 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4991 && (k2->op_flags & OPf_STACKED)
4992 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4993 expr = newUNOP(OP_DEFINED, 0, expr);
4997 if (k1 && (k1->op_type == OP_READDIR
4998 || k1->op_type == OP_GLOB
4999 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5000 || k1->op_type == OP_EACH))
5001 expr = newUNOP(OP_DEFINED, 0, expr);
5008 block = newOP(OP_NULL, 0);
5009 else if (cont || has_my) {
5010 block = scope(block);
5014 next = LINKLIST(cont);
5017 OP * const unstack = newOP(OP_UNSTACK, 0);
5020 cont = append_elem(OP_LINESEQ, cont, unstack);
5024 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
5026 redo = LINKLIST(listop);
5029 PL_parser->copline = (line_t)whileline;
5031 o = new_logop(OP_AND, 0, &expr, &listop);
5032 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5033 op_free(expr); /* oops, it's a while (0) */
5035 return NULL; /* listop already freed by new_logop */
5038 ((LISTOP*)listop)->op_last->op_next =
5039 (o == listop ? redo : LINKLIST(o));
5045 NewOp(1101,loop,1,LOOP);
5046 loop->op_type = OP_ENTERLOOP;
5047 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5048 loop->op_private = 0;
5049 loop->op_next = (OP*)loop;
5052 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5054 loop->op_redoop = redo;
5055 loop->op_lastop = o;
5056 o->op_private |= loopflags;
5059 loop->op_nextop = next;
5061 loop->op_nextop = o;
5063 o->op_flags |= flags;
5064 o->op_private |= (flags >> 8);
5069 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
5074 PADOFFSET padoff = 0;
5079 PERL_ARGS_ASSERT_NEWFOROP;
5082 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5083 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5084 sv->op_type = OP_RV2GV;
5085 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5087 /* The op_type check is needed to prevent a possible segfault
5088 * if the loop variable is undeclared and 'strict vars' is in
5089 * effect. This is illegal but is nonetheless parsed, so we
5090 * may reach this point with an OP_CONST where we're expecting
5093 if (cUNOPx(sv)->op_first->op_type == OP_GV
5094 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5095 iterpflags |= OPpITER_DEF;
5097 else if (sv->op_type == OP_PADSV) { /* private variable */
5098 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5099 padoff = sv->op_targ;
5109 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5111 SV *const namesv = PAD_COMPNAME_SV(padoff);
5113 const char *const name = SvPV_const(namesv, len);
5115 if (len == 2 && name[0] == '$' && name[1] == '_')
5116 iterpflags |= OPpITER_DEF;
5120 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5121 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5122 sv = newGVOP(OP_GV, 0, PL_defgv);
5127 iterpflags |= OPpITER_DEF;
5129 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5130 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5131 iterflags |= OPf_STACKED;
5133 else if (expr->op_type == OP_NULL &&
5134 (expr->op_flags & OPf_KIDS) &&
5135 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5137 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5138 * set the STACKED flag to indicate that these values are to be
5139 * treated as min/max values by 'pp_iterinit'.
5141 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5142 LOGOP* const range = (LOGOP*) flip->op_first;
5143 OP* const left = range->op_first;
5144 OP* const right = left->op_sibling;
5147 range->op_flags &= ~OPf_KIDS;
5148 range->op_first = NULL;
5150 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5151 listop->op_first->op_next = range->op_next;
5152 left->op_next = range->op_other;
5153 right->op_next = (OP*)listop;
5154 listop->op_next = listop->op_first;
5157 op_getmad(expr,(OP*)listop,'O');
5161 expr = (OP*)(listop);
5163 iterflags |= OPf_STACKED;
5166 expr = mod(force_list(expr), OP_GREPSTART);
5169 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5170 append_elem(OP_LIST, expr, scalar(sv))));
5171 assert(!loop->op_next);
5172 /* for my $x () sets OPpLVAL_INTRO;
5173 * for our $x () sets OPpOUR_INTRO */
5174 loop->op_private = (U8)iterpflags;
5175 #ifdef PL_OP_SLAB_ALLOC
5178 NewOp(1234,tmp,1,LOOP);
5179 Copy(loop,tmp,1,LISTOP);
5180 S_op_destroy(aTHX_ (OP*)loop);
5184 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5186 loop->op_targ = padoff;
5187 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5189 op_getmad(madsv, (OP*)loop, 'v');
5190 PL_parser->copline = forline;
5191 return newSTATEOP(0, label, wop);
5195 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5200 PERL_ARGS_ASSERT_NEWLOOPEX;
5202 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5204 if (type != OP_GOTO || label->op_type == OP_CONST) {
5205 /* "last()" means "last" */
5206 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5207 o = newOP(type, OPf_SPECIAL);
5209 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5210 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5214 op_getmad(label,o,'L');
5220 /* Check whether it's going to be a goto &function */
5221 if (label->op_type == OP_ENTERSUB
5222 && !(label->op_flags & OPf_STACKED))
5223 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5224 o = newUNOP(type, OPf_STACKED, label);
5226 PL_hints |= HINT_BLOCK_SCOPE;
5230 /* if the condition is a literal array or hash
5231 (or @{ ... } etc), make a reference to it.
5234 S_ref_array_or_hash(pTHX_ OP *cond)
5237 && (cond->op_type == OP_RV2AV
5238 || cond->op_type == OP_PADAV
5239 || cond->op_type == OP_RV2HV
5240 || cond->op_type == OP_PADHV))
5242 return newUNOP(OP_REFGEN,
5243 0, mod(cond, OP_REFGEN));
5249 /* These construct the optree fragments representing given()
5252 entergiven and enterwhen are LOGOPs; the op_other pointer
5253 points up to the associated leave op. We need this so we
5254 can put it in the context and make break/continue work.
5255 (Also, of course, pp_enterwhen will jump straight to
5256 op_other if the match fails.)
5260 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5261 I32 enter_opcode, I32 leave_opcode,
5262 PADOFFSET entertarg)
5268 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5270 NewOp(1101, enterop, 1, LOGOP);
5271 enterop->op_type = (Optype)enter_opcode;
5272 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5273 enterop->op_flags = (U8) OPf_KIDS;
5274 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5275 enterop->op_private = 0;
5277 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5280 enterop->op_first = scalar(cond);
5281 cond->op_sibling = block;
5283 o->op_next = LINKLIST(cond);
5284 cond->op_next = (OP *) enterop;
5287 /* This is a default {} block */
5288 enterop->op_first = block;
5289 enterop->op_flags |= OPf_SPECIAL;
5291 o->op_next = (OP *) enterop;
5294 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5295 entergiven and enterwhen both
5298 enterop->op_next = LINKLIST(block);
5299 block->op_next = enterop->op_other = o;
5304 /* Does this look like a boolean operation? For these purposes
5305 a boolean operation is:
5306 - a subroutine call [*]
5307 - a logical connective
5308 - a comparison operator
5309 - a filetest operator, with the exception of -s -M -A -C
5310 - defined(), exists() or eof()
5311 - /$re/ or $foo =~ /$re/
5313 [*] possibly surprising
5316 S_looks_like_bool(pTHX_ const OP *o)
5320 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5322 switch(o->op_type) {
5325 return looks_like_bool(cLOGOPo->op_first);
5329 looks_like_bool(cLOGOPo->op_first)
5330 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5335 o->op_flags & OPf_KIDS
5336 && looks_like_bool(cUNOPo->op_first));
5340 case OP_NOT: case OP_XOR:
5342 case OP_EQ: case OP_NE: case OP_LT:
5343 case OP_GT: case OP_LE: case OP_GE:
5345 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5346 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5348 case OP_SEQ: case OP_SNE: case OP_SLT:
5349 case OP_SGT: case OP_SLE: case OP_SGE:
5353 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5354 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5355 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5356 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5357 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5358 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5359 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5360 case OP_FTTEXT: case OP_FTBINARY:
5362 case OP_DEFINED: case OP_EXISTS:
5363 case OP_MATCH: case OP_EOF:
5370 /* Detect comparisons that have been optimized away */
5371 if (cSVOPo->op_sv == &PL_sv_yes
5372 || cSVOPo->op_sv == &PL_sv_no)
5385 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5388 PERL_ARGS_ASSERT_NEWGIVENOP;
5389 return newGIVWHENOP(
5390 ref_array_or_hash(cond),
5392 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5396 /* If cond is null, this is a default {} block */
5398 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5400 const bool cond_llb = (!cond || looks_like_bool(cond));
5403 PERL_ARGS_ASSERT_NEWWHENOP;
5408 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5410 scalar(ref_array_or_hash(cond)));
5413 return newGIVWHENOP(
5415 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5416 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5420 =for apidoc cv_undef
5422 Clear out all the active components of a CV. This can happen either
5423 by an explicit C<undef &foo>, or by the reference count going to zero.
5424 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5425 children can still follow the full lexical scope chain.
5431 Perl_cv_undef(pTHX_ CV *cv)
5435 PERL_ARGS_ASSERT_CV_UNDEF;
5437 DEBUG_X(PerlIO_printf(Perl_debug_log,
5438 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5439 PTR2UV(cv), PTR2UV(PL_comppad))
5443 if (CvFILE(cv) && !CvISXSUB(cv)) {
5444 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5445 Safefree(CvFILE(cv));
5450 if (!CvISXSUB(cv) && CvROOT(cv)) {
5451 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5452 Perl_croak(aTHX_ "Can't undef active subroutine");
5455 PAD_SAVE_SETNULLPAD();
5457 op_free(CvROOT(cv));
5462 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5467 /* remove CvOUTSIDE unless this is an undef rather than a free */
5468 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5469 if (!CvWEAKOUTSIDE(cv))
5470 SvREFCNT_dec(CvOUTSIDE(cv));
5471 CvOUTSIDE(cv) = NULL;
5474 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5477 if (CvISXSUB(cv) && CvXSUB(cv)) {
5480 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
5481 * ref status of CvOUTSIDE and CvGV */
5482 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
5486 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5489 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5491 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5492 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5493 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5494 || (p && (len != SvCUR(cv) /* Not the same length. */
5495 || memNE(p, SvPVX_const(cv), len))))
5496 && ckWARN_d(WARN_PROTOTYPE)) {
5497 SV* const msg = sv_newmortal();
5501 gv_efullname3(name = sv_newmortal(), gv, NULL);
5502 sv_setpvs(msg, "Prototype mismatch:");
5504 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5506 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5508 sv_catpvs(msg, ": none");
5509 sv_catpvs(msg, " vs ");
5511 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5513 sv_catpvs(msg, "none");
5514 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5518 static void const_sv_xsub(pTHX_ CV* cv);
5522 =head1 Optree Manipulation Functions
5524 =for apidoc cv_const_sv
5526 If C<cv> is a constant sub eligible for inlining. returns the constant
5527 value returned by the sub. Otherwise, returns NULL.
5529 Constant subs can be created with C<newCONSTSUB> or as described in
5530 L<perlsub/"Constant Functions">.
5535 Perl_cv_const_sv(pTHX_ const CV *const cv)
5537 PERL_UNUSED_CONTEXT;
5540 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5542 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5545 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5546 * Can be called in 3 ways:
5549 * look for a single OP_CONST with attached value: return the value
5551 * cv && CvCLONE(cv) && !CvCONST(cv)
5553 * examine the clone prototype, and if contains only a single
5554 * OP_CONST referencing a pad const, or a single PADSV referencing
5555 * an outer lexical, return a non-zero value to indicate the CV is
5556 * a candidate for "constizing" at clone time
5560 * We have just cloned an anon prototype that was marked as a const
5561 * candidiate. Try to grab the current value, and in the case of
5562 * PADSV, ignore it if it has multiple references. Return the value.
5566 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5577 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5578 o = cLISTOPo->op_first->op_sibling;
5580 for (; o; o = o->op_next) {
5581 const OPCODE type = o->op_type;
5583 if (sv && o->op_next == o)
5585 if (o->op_next != o) {
5586 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5588 if (type == OP_DBSTATE)
5591 if (type == OP_LEAVESUB || type == OP_RETURN)
5595 if (type == OP_CONST && cSVOPo->op_sv)
5597 else if (cv && type == OP_CONST) {
5598 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5602 else if (cv && type == OP_PADSV) {
5603 if (CvCONST(cv)) { /* newly cloned anon */
5604 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5605 /* the candidate should have 1 ref from this pad and 1 ref
5606 * from the parent */
5607 if (!sv || SvREFCNT(sv) != 2)
5614 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5615 sv = &PL_sv_undef; /* an arbitrary non-null value */
5630 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5633 /* This would be the return value, but the return cannot be reached. */
5634 OP* pegop = newOP(OP_NULL, 0);
5637 PERL_UNUSED_ARG(floor);
5647 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5649 NORETURN_FUNCTION_END;
5654 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5656 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5660 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5665 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
5666 register CV *cv = NULL;
5668 /* If the subroutine has no body, no attributes, and no builtin attributes
5669 then it's just a sub declaration, and we may be able to get away with
5670 storing with a placeholder scalar in the symbol table, rather than a
5671 full GV and CV. If anything is present then it will take a full CV to
5673 const I32 gv_fetch_flags
5674 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5676 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5677 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5681 assert(proto->op_type == OP_CONST);
5682 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5688 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5690 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5691 SV * const sv = sv_newmortal();
5692 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5693 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5694 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5695 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5697 } else if (PL_curstash) {
5698 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5701 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5705 if (!PL_madskills) {
5714 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5715 maximum a prototype before. */
5716 if (SvTYPE(gv) > SVt_NULL) {
5717 if (!SvPOK((const SV *)gv)
5718 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5720 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5722 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5725 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5727 sv_setiv(MUTABLE_SV(gv), -1);
5729 SvREFCNT_dec(PL_compcv);
5730 cv = PL_compcv = NULL;
5734 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5736 if (!block || !ps || *ps || attrs
5737 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5739 || block->op_type == OP_NULL
5744 const_sv = op_const_sv(block, NULL);
5747 const bool exists = CvROOT(cv) || CvXSUB(cv);
5749 /* if the subroutine doesn't exist and wasn't pre-declared
5750 * with a prototype, assume it will be AUTOLOADed,
5751 * skipping the prototype check
5753 if (exists || SvPOK(cv))
5754 cv_ckproto_len(cv, gv, ps, ps_len);
5755 /* already defined (or promised)? */
5756 if (exists || GvASSUMECV(gv)) {
5759 || block->op_type == OP_NULL
5762 if (CvFLAGS(PL_compcv)) {
5763 /* might have had built-in attrs applied */
5764 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
5765 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
5766 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
5768 /* just a "sub foo;" when &foo is already defined */
5769 SAVEFREESV(PL_compcv);
5774 && block->op_type != OP_NULL
5777 if (ckWARN(WARN_REDEFINE)
5779 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5781 const line_t oldline = CopLINE(PL_curcop);
5782 if (PL_parser && PL_parser->copline != NOLINE)
5783 CopLINE_set(PL_curcop, PL_parser->copline);
5784 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5785 CvCONST(cv) ? "Constant subroutine %s redefined"
5786 : "Subroutine %s redefined", name);
5787 CopLINE_set(PL_curcop, oldline);
5790 if (!PL_minus_c) /* keep old one around for madskills */
5793 /* (PL_madskills unset in used file.) */
5801 SvREFCNT_inc_simple_void_NN(const_sv);
5803 assert(!CvROOT(cv) && !CvCONST(cv));
5804 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5805 CvXSUBANY(cv).any_ptr = const_sv;
5806 CvXSUB(cv) = const_sv_xsub;
5812 cv = newCONSTSUB(NULL, name, const_sv);
5814 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5815 (CvGV(cv) && GvSTASH(CvGV(cv)))
5824 SvREFCNT_dec(PL_compcv);
5828 if (cv) { /* must reuse cv if autoloaded */
5829 /* transfer PL_compcv to cv */
5832 && block->op_type != OP_NULL
5835 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
5837 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
5838 if (!CvWEAKOUTSIDE(cv))
5839 SvREFCNT_dec(CvOUTSIDE(cv));
5840 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5841 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5842 CvOUTSIDE(PL_compcv) = 0;
5843 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5844 CvPADLIST(PL_compcv) = 0;
5845 /* inner references to PL_compcv must be fixed up ... */
5846 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5847 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5848 ++PL_sub_generation;
5850 sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
5853 /* Might have had built-in attributes applied -- propagate them. */
5854 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5856 /* ... before we throw it away */
5857 SvREFCNT_dec(PL_compcv);
5865 if (strEQ(name, "import")) {
5866 PL_formfeed = MUTABLE_SV(cv);
5867 /* diag_listed_as: SKIPME */
5868 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
5872 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5877 CvFILE_set_from_cop(cv, PL_curcop);
5878 CvSTASH(cv) = PL_curstash;
5880 Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
5883 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5884 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5885 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5889 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5891 if (PL_parser && PL_parser->error_count) {
5895 const char *s = strrchr(name, ':');
5897 if (strEQ(s, "BEGIN")) {
5898 const char not_safe[] =
5899 "BEGIN not safe after errors--compilation aborted";
5900 if (PL_in_eval & EVAL_KEEPERR)
5901 Perl_croak(aTHX_ not_safe);
5903 /* force display of errors found but not reported */
5904 sv_catpv(ERRSV, not_safe);
5905 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5914 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5915 the debugger could be able to set a breakpoint in, so signal to
5916 pp_entereval that it should not throw away any saved lines at scope
5919 PL_breakable_sub_gen++;
5921 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5922 mod(scalarseq(block), OP_LEAVESUBLV));
5923 block->op_attached = 1;
5926 /* This makes sub {}; work as expected. */
5927 if (block->op_type == OP_STUB) {
5928 OP* const newblock = newSTATEOP(0, NULL, 0);
5930 op_getmad(block,newblock,'B');
5937 block->op_attached = 1;
5938 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5940 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5941 OpREFCNT_set(CvROOT(cv), 1);
5942 CvSTART(cv) = LINKLIST(CvROOT(cv));
5943 CvROOT(cv)->op_next = 0;
5944 CALL_PEEP(CvSTART(cv));
5946 /* now that optimizer has done its work, adjust pad values */
5948 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5951 assert(!CvCONST(cv));
5952 if (ps && !*ps && op_const_sv(block, cv))
5957 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5958 SV * const tmpstr = sv_newmortal();
5959 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5960 GV_ADDMULTI, SVt_PVHV);
5962 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
5965 (long)CopLINE(PL_curcop));
5966 gv_efullname3(tmpstr, gv, NULL);
5967 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5968 SvCUR(tmpstr), sv, 0);
5969 hv = GvHVn(db_postponed);
5970 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5971 CV * const pcv = GvCV(db_postponed);
5977 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5982 if (name && ! (PL_parser && PL_parser->error_count))
5983 process_special_blocks(name, gv, cv);
5988 PL_parser->copline = NOLINE;
5994 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5997 const char *const colon = strrchr(fullname,':');
5998 const char *const name = colon ? colon + 1 : fullname;
6000 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6003 if (strEQ(name, "BEGIN")) {
6004 const I32 oldscope = PL_scopestack_ix;
6006 SAVECOPFILE(&PL_compiling);
6007 SAVECOPLINE(&PL_compiling);
6009 DEBUG_x( dump_sub(gv) );
6010 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6011 GvCV(gv) = 0; /* cv has been hijacked */
6012 call_list(oldscope, PL_beginav);
6014 PL_curcop = &PL_compiling;
6015 CopHINTS_set(&PL_compiling, PL_hints);
6022 if strEQ(name, "END") {
6023 DEBUG_x( dump_sub(gv) );
6024 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6027 } else if (*name == 'U') {
6028 if (strEQ(name, "UNITCHECK")) {
6029 /* It's never too late to run a unitcheck block */
6030 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6034 } else if (*name == 'C') {
6035 if (strEQ(name, "CHECK")) {
6037 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6038 "Too late to run CHECK block");
6039 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6043 } else if (*name == 'I') {
6044 if (strEQ(name, "INIT")) {
6046 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6047 "Too late to run INIT block");
6048 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6054 DEBUG_x( dump_sub(gv) );
6055 GvCV(gv) = 0; /* cv has been hijacked */
6060 =for apidoc newCONSTSUB
6062 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6063 eligible for inlining at compile-time.
6065 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6066 which won't be called if used as a destructor, but will suppress the overhead
6067 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6074 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6079 const char *const file = CopFILE(PL_curcop);
6081 SV *const temp_sv = CopFILESV(PL_curcop);
6082 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6087 if (IN_PERL_RUNTIME) {
6088 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6089 * an op shared between threads. Use a non-shared COP for our
6091 SAVEVPTR(PL_curcop);
6092 PL_curcop = &PL_compiling;
6094 SAVECOPLINE(PL_curcop);
6095 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6098 PL_hints &= ~HINT_BLOCK_SCOPE;
6101 SAVESPTR(PL_curstash);
6102 SAVECOPSTASH(PL_curcop);
6103 PL_curstash = stash;
6104 CopSTASH_set(PL_curcop,stash);
6107 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6108 and so doesn't get free()d. (It's expected to be from the C pre-
6109 processor __FILE__ directive). But we need a dynamically allocated one,
6110 and we need it to get freed. */
6111 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6112 XS_DYNAMIC_FILENAME);
6113 CvXSUBANY(cv).any_ptr = sv;
6118 CopSTASH_free(PL_curcop);
6126 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6127 const char *const filename, const char *const proto,
6130 CV *cv = newXS(name, subaddr, filename);
6132 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6134 if (flags & XS_DYNAMIC_FILENAME) {
6135 /* We need to "make arrangements" (ie cheat) to ensure that the
6136 filename lasts as long as the PVCV we just created, but also doesn't
6138 STRLEN filename_len = strlen(filename);
6139 STRLEN proto_and_file_len = filename_len;
6140 char *proto_and_file;
6144 proto_len = strlen(proto);
6145 proto_and_file_len += proto_len;
6147 Newx(proto_and_file, proto_and_file_len + 1, char);
6148 Copy(proto, proto_and_file, proto_len, char);
6149 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6152 proto_and_file = savepvn(filename, filename_len);
6155 /* This gets free()d. :-) */
6156 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6157 SV_HAS_TRAILING_NUL);
6159 /* This gives us the correct prototype, rather than one with the
6160 file name appended. */
6161 SvCUR_set(cv, proto_len);
6165 CvFILE(cv) = proto_and_file + proto_len;
6167 sv_setpv(MUTABLE_SV(cv), proto);
6173 =for apidoc U||newXS
6175 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6176 static storage, as it is used directly as CvFILE(), without a copy being made.
6182 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6185 GV * const gv = gv_fetchpv(name ? name :
6186 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6187 GV_ADDMULTI, SVt_PVCV);
6190 PERL_ARGS_ASSERT_NEWXS;
6193 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6195 if ((cv = (name ? GvCV(gv) : NULL))) {
6197 /* just a cached method */
6201 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6202 /* already defined (or promised) */
6203 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6204 if (ckWARN(WARN_REDEFINE)) {
6205 GV * const gvcv = CvGV(cv);
6207 HV * const stash = GvSTASH(gvcv);
6209 const char *redefined_name = HvNAME_get(stash);
6210 if ( strEQ(redefined_name,"autouse") ) {
6211 const line_t oldline = CopLINE(PL_curcop);
6212 if (PL_parser && PL_parser->copline != NOLINE)
6213 CopLINE_set(PL_curcop, PL_parser->copline);
6214 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6215 CvCONST(cv) ? "Constant subroutine %s redefined"
6216 : "Subroutine %s redefined"
6218 CopLINE_set(PL_curcop, oldline);
6228 if (cv) /* must reuse cv if autoloaded */
6231 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6235 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6241 (void)gv_fetchfile(filename);
6242 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6243 an external constant string */
6245 CvXSUB(cv) = subaddr;
6248 process_special_blocks(name, gv, cv);
6258 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6263 OP* pegop = newOP(OP_NULL, 0);
6267 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6268 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6271 if ((cv = GvFORM(gv))) {
6272 if (ckWARN(WARN_REDEFINE)) {
6273 const line_t oldline = CopLINE(PL_curcop);
6274 if (PL_parser && PL_parser->copline != NOLINE)
6275 CopLINE_set(PL_curcop, PL_parser->copline);
6277 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6278 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6280 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6281 "Format STDOUT redefined");
6283 CopLINE_set(PL_curcop, oldline);
6290 CvFILE_set_from_cop(cv, PL_curcop);
6293 pad_tidy(padtidy_FORMAT);
6294 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6295 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6296 OpREFCNT_set(CvROOT(cv), 1);
6297 CvSTART(cv) = LINKLIST(CvROOT(cv));
6298 CvROOT(cv)->op_next = 0;
6299 CALL_PEEP(CvSTART(cv));
6301 op_getmad(o,pegop,'n');
6302 op_getmad_weak(block, pegop, 'b');
6307 PL_parser->copline = NOLINE;
6315 Perl_newANONLIST(pTHX_ OP *o)
6317 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6321 Perl_newANONHASH(pTHX_ OP *o)
6323 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6327 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6329 return newANONATTRSUB(floor, proto, NULL, block);
6333 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6335 return newUNOP(OP_REFGEN, 0,
6336 newSVOP(OP_ANONCODE, 0,
6337 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6341 Perl_oopsAV(pTHX_ OP *o)
6345 PERL_ARGS_ASSERT_OOPSAV;
6347 switch (o->op_type) {
6349 o->op_type = OP_PADAV;
6350 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6351 return ref(o, OP_RV2AV);
6354 o->op_type = OP_RV2AV;
6355 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6360 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6367 Perl_oopsHV(pTHX_ OP *o)
6371 PERL_ARGS_ASSERT_OOPSHV;
6373 switch (o->op_type) {
6376 o->op_type = OP_PADHV;
6377 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6378 return ref(o, OP_RV2HV);
6382 o->op_type = OP_RV2HV;
6383 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6388 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6395 Perl_newAVREF(pTHX_ OP *o)
6399 PERL_ARGS_ASSERT_NEWAVREF;
6401 if (o->op_type == OP_PADANY) {
6402 o->op_type = OP_PADAV;
6403 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6406 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6407 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6408 "Using an array as a reference is deprecated");
6410 return newUNOP(OP_RV2AV, 0, scalar(o));
6414 Perl_newGVREF(pTHX_ I32 type, OP *o)
6416 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6417 return newUNOP(OP_NULL, 0, o);
6418 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6422 Perl_newHVREF(pTHX_ OP *o)
6426 PERL_ARGS_ASSERT_NEWHVREF;
6428 if (o->op_type == OP_PADANY) {
6429 o->op_type = OP_PADHV;
6430 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6433 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6434 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6435 "Using a hash as a reference is deprecated");
6437 return newUNOP(OP_RV2HV, 0, scalar(o));
6441 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6443 return newUNOP(OP_RV2CV, flags, scalar(o));
6447 Perl_newSVREF(pTHX_ OP *o)
6451 PERL_ARGS_ASSERT_NEWSVREF;
6453 if (o->op_type == OP_PADANY) {
6454 o->op_type = OP_PADSV;
6455 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6458 return newUNOP(OP_RV2SV, 0, scalar(o));
6461 /* Check routines. See the comments at the top of this file for details
6462 * on when these are called */
6465 Perl_ck_anoncode(pTHX_ OP *o)
6467 PERL_ARGS_ASSERT_CK_ANONCODE;
6469 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6471 cSVOPo->op_sv = NULL;
6476 Perl_ck_bitop(pTHX_ OP *o)
6480 PERL_ARGS_ASSERT_CK_BITOP;
6482 #define OP_IS_NUMCOMPARE(op) \
6483 ((op) == OP_LT || (op) == OP_I_LT || \
6484 (op) == OP_GT || (op) == OP_I_GT || \
6485 (op) == OP_LE || (op) == OP_I_LE || \
6486 (op) == OP_GE || (op) == OP_I_GE || \
6487 (op) == OP_EQ || (op) == OP_I_EQ || \
6488 (op) == OP_NE || (op) == OP_I_NE || \
6489 (op) == OP_NCMP || (op) == OP_I_NCMP)
6490 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6491 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6492 && (o->op_type == OP_BIT_OR
6493 || o->op_type == OP_BIT_AND
6494 || o->op_type == OP_BIT_XOR))
6496 const OP * const left = cBINOPo->op_first;
6497 const OP * const right = left->op_sibling;
6498 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6499 (left->op_flags & OPf_PARENS) == 0) ||
6500 (OP_IS_NUMCOMPARE(right->op_type) &&
6501 (right->op_flags & OPf_PARENS) == 0))
6502 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6503 "Possible precedence problem on bitwise %c operator",
6504 o->op_type == OP_BIT_OR ? '|'
6505 : o->op_type == OP_BIT_AND ? '&' : '^'
6512 Perl_ck_concat(pTHX_ OP *o)
6514 const OP * const kid = cUNOPo->op_first;
6516 PERL_ARGS_ASSERT_CK_CONCAT;
6517 PERL_UNUSED_CONTEXT;
6519 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6520 !(kUNOP->op_first->op_flags & OPf_MOD))
6521 o->op_flags |= OPf_STACKED;
6526 Perl_ck_spair(pTHX_ OP *o)
6530 PERL_ARGS_ASSERT_CK_SPAIR;
6532 if (o->op_flags & OPf_KIDS) {
6535 const OPCODE type = o->op_type;
6536 o = modkids(ck_fun(o), type);
6537 kid = cUNOPo->op_first;
6538 newop = kUNOP->op_first->op_sibling;
6540 const OPCODE type = newop->op_type;
6541 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6542 type == OP_PADAV || type == OP_PADHV ||
6543 type == OP_RV2AV || type == OP_RV2HV)
6547 op_getmad(kUNOP->op_first,newop,'K');
6549 op_free(kUNOP->op_first);
6551 kUNOP->op_first = newop;
6553 o->op_ppaddr = PL_ppaddr[++o->op_type];
6558 Perl_ck_delete(pTHX_ OP *o)
6560 PERL_ARGS_ASSERT_CK_DELETE;
6564 if (o->op_flags & OPf_KIDS) {
6565 OP * const kid = cUNOPo->op_first;
6566 switch (kid->op_type) {
6568 o->op_flags |= OPf_SPECIAL;
6571 o->op_private |= OPpSLICE;
6574 o->op_flags |= OPf_SPECIAL;
6579 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6582 if (kid->op_private & OPpLVAL_INTRO)
6583 o->op_private |= OPpLVAL_INTRO;
6590 Perl_ck_die(pTHX_ OP *o)
6592 PERL_ARGS_ASSERT_CK_DIE;
6595 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6601 Perl_ck_eof(pTHX_ OP *o)
6605 PERL_ARGS_ASSERT_CK_EOF;
6607 if (o->op_flags & OPf_KIDS) {
6608 if (cLISTOPo->op_first->op_type == OP_STUB) {
6610 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6612 op_getmad(o,newop,'O');
6624 Perl_ck_eval(pTHX_ OP *o)
6628 PERL_ARGS_ASSERT_CK_EVAL;
6630 PL_hints |= HINT_BLOCK_SCOPE;
6631 if (o->op_flags & OPf_KIDS) {
6632 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6635 o->op_flags &= ~OPf_KIDS;
6638 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6644 cUNOPo->op_first = 0;
6649 NewOp(1101, enter, 1, LOGOP);
6650 enter->op_type = OP_ENTERTRY;
6651 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6652 enter->op_private = 0;
6654 /* establish postfix order */
6655 enter->op_next = (OP*)enter;
6657 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6658 o->op_type = OP_LEAVETRY;
6659 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6660 enter->op_other = o;
6661 op_getmad(oldo,o,'O');
6675 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6676 op_getmad(oldo,o,'O');
6678 o->op_targ = (PADOFFSET)PL_hints;
6679 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6680 /* Store a copy of %^H that pp_entereval can pick up. */
6681 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6682 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6683 cUNOPo->op_first->op_sibling = hhop;
6684 o->op_private |= OPpEVAL_HAS_HH;
6690 Perl_ck_exit(pTHX_ OP *o)
6692 PERL_ARGS_ASSERT_CK_EXIT;
6695 HV * const table = GvHV(PL_hintgv);
6697 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6698 if (svp && *svp && SvTRUE(*svp))
6699 o->op_private |= OPpEXIT_VMSISH;
6701 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6707 Perl_ck_exec(pTHX_ OP *o)
6709 PERL_ARGS_ASSERT_CK_EXEC;
6711 if (o->op_flags & OPf_STACKED) {
6714 kid = cUNOPo->op_first->op_sibling;
6715 if (kid->op_type == OP_RV2GV)
6724 Perl_ck_exists(pTHX_ OP *o)
6728 PERL_ARGS_ASSERT_CK_EXISTS;
6731 if (o->op_flags & OPf_KIDS) {
6732 OP * const kid = cUNOPo->op_first;
6733 if (kid->op_type == OP_ENTERSUB) {
6734 (void) ref(kid, o->op_type);
6735 if (kid->op_type != OP_RV2CV
6736 && !(PL_parser && PL_parser->error_count))
6737 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6739 o->op_private |= OPpEXISTS_SUB;
6741 else if (kid->op_type == OP_AELEM)
6742 o->op_flags |= OPf_SPECIAL;
6743 else if (kid->op_type != OP_HELEM)
6744 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6752 Perl_ck_rvconst(pTHX_ register OP *o)
6755 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6757 PERL_ARGS_ASSERT_CK_RVCONST;
6759 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6760 if (o->op_type == OP_RV2CV)
6761 o->op_private &= ~1;
6763 if (kid->op_type == OP_CONST) {
6766 SV * const kidsv = kid->op_sv;
6768 /* Is it a constant from cv_const_sv()? */
6769 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6770 SV * const rsv = SvRV(kidsv);
6771 const svtype type = SvTYPE(rsv);
6772 const char *badtype = NULL;
6774 switch (o->op_type) {
6776 if (type > SVt_PVMG)
6777 badtype = "a SCALAR";
6780 if (type != SVt_PVAV)
6781 badtype = "an ARRAY";
6784 if (type != SVt_PVHV)
6788 if (type != SVt_PVCV)
6793 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6796 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6797 const char *badthing;
6798 switch (o->op_type) {
6800 badthing = "a SCALAR";
6803 badthing = "an ARRAY";
6806 badthing = "a HASH";
6814 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6815 SVfARG(kidsv), badthing);
6818 * This is a little tricky. We only want to add the symbol if we
6819 * didn't add it in the lexer. Otherwise we get duplicate strict
6820 * warnings. But if we didn't add it in the lexer, we must at
6821 * least pretend like we wanted to add it even if it existed before,
6822 * or we get possible typo warnings. OPpCONST_ENTERED says
6823 * whether the lexer already added THIS instance of this symbol.
6825 iscv = (o->op_type == OP_RV2CV) * 2;
6827 gv = gv_fetchsv(kidsv,
6828 iscv | !(kid->op_private & OPpCONST_ENTERED),
6831 : o->op_type == OP_RV2SV
6833 : o->op_type == OP_RV2AV
6835 : o->op_type == OP_RV2HV
6838 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6840 kid->op_type = OP_GV;
6841 SvREFCNT_dec(kid->op_sv);
6843 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6844 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6845 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6847 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6849 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6851 kid->op_private = 0;
6852 kid->op_ppaddr = PL_ppaddr[OP_GV];
6859 Perl_ck_ftst(pTHX_ OP *o)
6862 const I32 type = o->op_type;
6864 PERL_ARGS_ASSERT_CK_FTST;
6866 if (o->op_flags & OPf_REF) {
6869 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6870 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6871 const OPCODE kidtype = kid->op_type;
6873 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6874 OP * const newop = newGVOP(type, OPf_REF,
6875 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6877 op_getmad(o,newop,'O');
6883 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6884 o->op_private |= OPpFT_ACCESS;
6885 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6886 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6887 o->op_private |= OPpFT_STACKED;
6895 if (type == OP_FTTTY)
6896 o = newGVOP(type, OPf_REF, PL_stdingv);
6898 o = newUNOP(type, 0, newDEFSVOP());
6899 op_getmad(oldo,o,'O');
6905 Perl_ck_fun(pTHX_ OP *o)
6908 const int type = o->op_type;
6909 register I32 oa = PL_opargs[type] >> OASHIFT;
6911 PERL_ARGS_ASSERT_CK_FUN;
6913 if (o->op_flags & OPf_STACKED) {
6914 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6917 return no_fh_allowed(o);
6920 if (o->op_flags & OPf_KIDS) {
6921 OP **tokid = &cLISTOPo->op_first;
6922 register OP *kid = cLISTOPo->op_first;
6926 if (kid->op_type == OP_PUSHMARK ||
6927 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6929 tokid = &kid->op_sibling;
6930 kid = kid->op_sibling;
6932 if (!kid && PL_opargs[type] & OA_DEFGV)
6933 *tokid = kid = newDEFSVOP();
6937 sibl = kid->op_sibling;
6939 if (!sibl && kid->op_type == OP_STUB) {
6946 /* list seen where single (scalar) arg expected? */
6947 if (numargs == 1 && !(oa >> 4)
6948 && kid->op_type == OP_LIST && type != OP_SCALAR)
6950 return too_many_arguments(o,PL_op_desc[type]);
6963 if ((type == OP_PUSH || type == OP_UNSHIFT)
6964 && !kid->op_sibling)
6965 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6966 "Useless use of %s with no values",
6969 if (kid->op_type == OP_CONST &&
6970 (kid->op_private & OPpCONST_BARE))
6972 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6973 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6974 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6975 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6976 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6978 op_getmad(kid,newop,'K');
6983 kid->op_sibling = sibl;
6986 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6987 bad_type(numargs, "array", PL_op_desc[type], kid);
6991 if (kid->op_type == OP_CONST &&
6992 (kid->op_private & OPpCONST_BARE))
6994 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6995 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6996 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6997 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6998 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7000 op_getmad(kid,newop,'K');
7005 kid->op_sibling = sibl;
7008 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7009 bad_type(numargs, "hash", PL_op_desc[type], kid);
7014 OP * const newop = newUNOP(OP_NULL, 0, kid);
7015 kid->op_sibling = 0;
7017 newop->op_next = newop;
7019 kid->op_sibling = sibl;
7024 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7025 if (kid->op_type == OP_CONST &&
7026 (kid->op_private & OPpCONST_BARE))
7028 OP * const newop = newGVOP(OP_GV, 0,
7029 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7030 if (!(o->op_private & 1) && /* if not unop */
7031 kid == cLISTOPo->op_last)
7032 cLISTOPo->op_last = newop;
7034 op_getmad(kid,newop,'K');
7040 else if (kid->op_type == OP_READLINE) {
7041 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7042 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7045 I32 flags = OPf_SPECIAL;
7049 /* is this op a FH constructor? */
7050 if (is_handle_constructor(o,numargs)) {
7051 const char *name = NULL;
7055 /* Set a flag to tell rv2gv to vivify
7056 * need to "prove" flag does not mean something
7057 * else already - NI-S 1999/05/07
7060 if (kid->op_type == OP_PADSV) {
7062 = PAD_COMPNAME_SV(kid->op_targ);
7063 name = SvPV_const(namesv, len);
7065 else if (kid->op_type == OP_RV2SV
7066 && kUNOP->op_first->op_type == OP_GV)
7068 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7070 len = GvNAMELEN(gv);
7072 else if (kid->op_type == OP_AELEM
7073 || kid->op_type == OP_HELEM)
7076 OP *op = ((BINOP*)kid)->op_first;
7080 const char * const a =
7081 kid->op_type == OP_AELEM ?
7083 if (((op->op_type == OP_RV2AV) ||
7084 (op->op_type == OP_RV2HV)) &&
7085 (firstop = ((UNOP*)op)->op_first) &&
7086 (firstop->op_type == OP_GV)) {
7087 /* packagevar $a[] or $h{} */
7088 GV * const gv = cGVOPx_gv(firstop);
7096 else if (op->op_type == OP_PADAV
7097 || op->op_type == OP_PADHV) {
7098 /* lexicalvar $a[] or $h{} */
7099 const char * const padname =
7100 PAD_COMPNAME_PV(op->op_targ);
7109 name = SvPV_const(tmpstr, len);
7114 name = "__ANONIO__";
7121 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7122 namesv = PAD_SVl(targ);
7123 SvUPGRADE(namesv, SVt_PV);
7125 sv_setpvs(namesv, "$");
7126 sv_catpvn(namesv, name, len);
7129 kid->op_sibling = 0;
7130 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7131 kid->op_targ = targ;
7132 kid->op_private |= priv;
7134 kid->op_sibling = sibl;
7140 mod(scalar(kid), type);
7144 tokid = &kid->op_sibling;
7145 kid = kid->op_sibling;
7148 if (kid && kid->op_type != OP_STUB)
7149 return too_many_arguments(o,OP_DESC(o));
7150 o->op_private |= numargs;
7152 /* FIXME - should the numargs move as for the PERL_MAD case? */
7153 o->op_private |= numargs;
7155 return too_many_arguments(o,OP_DESC(o));
7159 else if (PL_opargs[type] & OA_DEFGV) {
7161 OP *newop = newUNOP(type, 0, newDEFSVOP());
7162 op_getmad(o,newop,'O');
7165 /* Ordering of these two is important to keep f_map.t passing. */
7167 return newUNOP(type, 0, newDEFSVOP());
7172 while (oa & OA_OPTIONAL)
7174 if (oa && oa != OA_LIST)
7175 return too_few_arguments(o,OP_DESC(o));
7181 Perl_ck_glob(pTHX_ OP *o)
7186 PERL_ARGS_ASSERT_CK_GLOB;
7189 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7190 append_elem(OP_GLOB, o, newDEFSVOP());
7192 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7193 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7195 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7198 #if !defined(PERL_EXTERNAL_GLOB)
7199 /* XXX this can be tightened up and made more failsafe. */
7200 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7203 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7204 newSVpvs("File::Glob"), NULL, NULL, NULL);
7205 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7206 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7207 GvCV(gv) = GvCV(glob_gv);
7208 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7209 GvIMPORTED_CV_on(gv);
7213 #endif /* PERL_EXTERNAL_GLOB */
7215 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7216 append_elem(OP_GLOB, o,
7217 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7218 o->op_type = OP_LIST;
7219 o->op_ppaddr = PL_ppaddr[OP_LIST];
7220 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7221 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7222 cLISTOPo->op_first->op_targ = 0;
7223 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7224 append_elem(OP_LIST, o,
7225 scalar(newUNOP(OP_RV2CV, 0,
7226 newGVOP(OP_GV, 0, gv)))));
7227 o = newUNOP(OP_NULL, 0, ck_subr(o));
7228 o->op_targ = OP_GLOB; /* hint at what it used to be */
7231 gv = newGVgen("main");
7233 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7239 Perl_ck_grep(pTHX_ OP *o)
7244 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7247 PERL_ARGS_ASSERT_CK_GREP;
7249 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7250 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7252 if (o->op_flags & OPf_STACKED) {
7255 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7256 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7257 return no_fh_allowed(o);
7258 for (k = kid; k; k = k->op_next) {
7261 NewOp(1101, gwop, 1, LOGOP);
7262 kid->op_next = (OP*)gwop;
7263 o->op_flags &= ~OPf_STACKED;
7265 kid = cLISTOPo->op_first->op_sibling;
7266 if (type == OP_MAPWHILE)
7271 if (PL_parser && PL_parser->error_count)
7273 kid = cLISTOPo->op_first->op_sibling;
7274 if (kid->op_type != OP_NULL)
7275 Perl_croak(aTHX_ "panic: ck_grep");
7276 kid = kUNOP->op_first;
7279 NewOp(1101, gwop, 1, LOGOP);
7280 gwop->op_type = type;
7281 gwop->op_ppaddr = PL_ppaddr[type];
7282 gwop->op_first = listkids(o);
7283 gwop->op_flags |= OPf_KIDS;
7284 gwop->op_other = LINKLIST(kid);
7285 kid->op_next = (OP*)gwop;
7286 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7287 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7288 o->op_private = gwop->op_private = 0;
7289 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7292 o->op_private = gwop->op_private = OPpGREP_LEX;
7293 gwop->op_targ = o->op_targ = offset;
7296 kid = cLISTOPo->op_first->op_sibling;
7297 if (!kid || !kid->op_sibling)
7298 return too_few_arguments(o,OP_DESC(o));
7299 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7300 mod(kid, OP_GREPSTART);
7306 Perl_ck_index(pTHX_ OP *o)
7308 PERL_ARGS_ASSERT_CK_INDEX;
7310 if (o->op_flags & OPf_KIDS) {
7311 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7313 kid = kid->op_sibling; /* get past "big" */
7314 if (kid && kid->op_type == OP_CONST)
7315 fbm_compile(((SVOP*)kid)->op_sv, 0);
7321 Perl_ck_lfun(pTHX_ OP *o)
7323 const OPCODE type = o->op_type;
7325 PERL_ARGS_ASSERT_CK_LFUN;
7327 return modkids(ck_fun(o), type);
7331 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7333 PERL_ARGS_ASSERT_CK_DEFINED;
7335 if ((o->op_flags & OPf_KIDS)) {
7336 switch (cUNOPo->op_first->op_type) {
7338 /* This is needed for
7339 if (defined %stash::)
7340 to work. Do not break Tk.
7342 break; /* Globals via GV can be undef */
7344 case OP_AASSIGN: /* Is this a good idea? */
7345 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7346 "defined(@array) is deprecated");
7347 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7348 "\t(Maybe you should just omit the defined()?)\n");
7352 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7353 "defined(%%hash) is deprecated");
7354 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7355 "\t(Maybe you should just omit the defined()?)\n");
7366 Perl_ck_readline(pTHX_ OP *o)
7368 PERL_ARGS_ASSERT_CK_READLINE;
7370 if (!(o->op_flags & OPf_KIDS)) {
7372 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7374 op_getmad(o,newop,'O');
7384 Perl_ck_rfun(pTHX_ OP *o)
7386 const OPCODE type = o->op_type;
7388 PERL_ARGS_ASSERT_CK_RFUN;
7390 return refkids(ck_fun(o), type);
7394 Perl_ck_listiob(pTHX_ OP *o)
7398 PERL_ARGS_ASSERT_CK_LISTIOB;
7400 kid = cLISTOPo->op_first;
7403 kid = cLISTOPo->op_first;
7405 if (kid->op_type == OP_PUSHMARK)
7406 kid = kid->op_sibling;
7407 if (kid && o->op_flags & OPf_STACKED)
7408 kid = kid->op_sibling;
7409 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7410 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7411 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7412 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7413 cLISTOPo->op_first->op_sibling = kid;
7414 cLISTOPo->op_last = kid;
7415 kid = kid->op_sibling;
7420 append_elem(o->op_type, o, newDEFSVOP());
7426 Perl_ck_smartmatch(pTHX_ OP *o)
7429 if (0 == (o->op_flags & OPf_SPECIAL)) {
7430 OP *first = cBINOPo->op_first;
7431 OP *second = first->op_sibling;
7433 /* Implicitly take a reference to an array or hash */
7434 first->op_sibling = NULL;
7435 first = cBINOPo->op_first = ref_array_or_hash(first);
7436 second = first->op_sibling = ref_array_or_hash(second);
7438 /* Implicitly take a reference to a regular expression */
7439 if (first->op_type == OP_MATCH) {
7440 first->op_type = OP_QR;
7441 first->op_ppaddr = PL_ppaddr[OP_QR];
7443 if (second->op_type == OP_MATCH) {
7444 second->op_type = OP_QR;
7445 second->op_ppaddr = PL_ppaddr[OP_QR];
7454 Perl_ck_sassign(pTHX_ OP *o)
7457 OP * const kid = cLISTOPo->op_first;
7459 PERL_ARGS_ASSERT_CK_SASSIGN;
7461 /* has a disposable target? */
7462 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7463 && !(kid->op_flags & OPf_STACKED)
7464 /* Cannot steal the second time! */
7465 && !(kid->op_private & OPpTARGET_MY)
7466 /* Keep the full thing for madskills */
7470 OP * const kkid = kid->op_sibling;
7472 /* Can just relocate the target. */
7473 if (kkid && kkid->op_type == OP_PADSV
7474 && !(kkid->op_private & OPpLVAL_INTRO))
7476 kid->op_targ = kkid->op_targ;
7478 /* Now we do not need PADSV and SASSIGN. */
7479 kid->op_sibling = o->op_sibling; /* NULL */
7480 cLISTOPo->op_first = NULL;
7483 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7487 if (kid->op_sibling) {
7488 OP *kkid = kid->op_sibling;
7489 if (kkid->op_type == OP_PADSV
7490 && (kkid->op_private & OPpLVAL_INTRO)
7491 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7492 const PADOFFSET target = kkid->op_targ;
7493 OP *const other = newOP(OP_PADSV,
7495 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7496 OP *const first = newOP(OP_NULL, 0);
7497 OP *const nullop = newCONDOP(0, first, o, other);
7498 OP *const condop = first->op_next;
7499 /* hijacking PADSTALE for uninitialized state variables */
7500 SvPADSTALE_on(PAD_SVl(target));
7502 condop->op_type = OP_ONCE;
7503 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7504 condop->op_targ = target;
7505 other->op_targ = target;
7507 /* Because we change the type of the op here, we will skip the
7508 assinment binop->op_last = binop->op_first->op_sibling; at the
7509 end of Perl_newBINOP(). So need to do it here. */
7510 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7519 Perl_ck_match(pTHX_ OP *o)
7523 PERL_ARGS_ASSERT_CK_MATCH;
7525 if (o->op_type != OP_QR && PL_compcv) {
7526 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7527 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7528 o->op_targ = offset;
7529 o->op_private |= OPpTARGET_MY;
7532 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7533 o->op_private |= OPpRUNTIME;
7538 Perl_ck_method(pTHX_ OP *o)
7540 OP * const kid = cUNOPo->op_first;
7542 PERL_ARGS_ASSERT_CK_METHOD;
7544 if (kid->op_type == OP_CONST) {
7545 SV* sv = kSVOP->op_sv;
7546 const char * const method = SvPVX_const(sv);
7547 if (!(strchr(method, ':') || strchr(method, '\''))) {
7549 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7550 sv = newSVpvn_share(method, SvCUR(sv), 0);
7553 kSVOP->op_sv = NULL;
7555 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7557 op_getmad(o,cmop,'O');
7568 Perl_ck_null(pTHX_ OP *o)
7570 PERL_ARGS_ASSERT_CK_NULL;
7571 PERL_UNUSED_CONTEXT;
7576 Perl_ck_open(pTHX_ OP *o)
7579 HV * const table = GvHV(PL_hintgv);
7581 PERL_ARGS_ASSERT_CK_OPEN;
7584 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7587 const char *d = SvPV_const(*svp, len);
7588 const I32 mode = mode_from_discipline(d, len);
7589 if (mode & O_BINARY)
7590 o->op_private |= OPpOPEN_IN_RAW;
7591 else if (mode & O_TEXT)
7592 o->op_private |= OPpOPEN_IN_CRLF;
7595 svp = hv_fetchs(table, "open_OUT", FALSE);
7598 const char *d = SvPV_const(*svp, len);
7599 const I32 mode = mode_from_discipline(d, len);
7600 if (mode & O_BINARY)
7601 o->op_private |= OPpOPEN_OUT_RAW;
7602 else if (mode & O_TEXT)
7603 o->op_private |= OPpOPEN_OUT_CRLF;
7606 if (o->op_type == OP_BACKTICK) {
7607 if (!(o->op_flags & OPf_KIDS)) {
7608 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7610 op_getmad(o,newop,'O');
7619 /* In case of three-arg dup open remove strictness
7620 * from the last arg if it is a bareword. */
7621 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7622 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7626 if ((last->op_type == OP_CONST) && /* The bareword. */
7627 (last->op_private & OPpCONST_BARE) &&
7628 (last->op_private & OPpCONST_STRICT) &&
7629 (oa = first->op_sibling) && /* The fh. */
7630 (oa = oa->op_sibling) && /* The mode. */
7631 (oa->op_type == OP_CONST) &&
7632 SvPOK(((SVOP*)oa)->op_sv) &&
7633 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7634 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7635 (last == oa->op_sibling)) /* The bareword. */
7636 last->op_private &= ~OPpCONST_STRICT;
7642 Perl_ck_repeat(pTHX_ OP *o)
7644 PERL_ARGS_ASSERT_CK_REPEAT;
7646 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7647 o->op_private |= OPpREPEAT_DOLIST;
7648 cBINOPo->op_first = force_list(cBINOPo->op_first);
7656 Perl_ck_require(pTHX_ OP *o)
7661 PERL_ARGS_ASSERT_CK_REQUIRE;
7663 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7664 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7666 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7667 SV * const sv = kid->op_sv;
7668 U32 was_readonly = SvREADONLY(sv);
7675 sv_force_normal_flags(sv, 0);
7676 assert(!SvREADONLY(sv));
7686 for (; s < end; s++) {
7687 if (*s == ':' && s[1] == ':') {
7689 Move(s+2, s+1, end - s - 1, char);
7694 sv_catpvs(sv, ".pm");
7695 SvFLAGS(sv) |= was_readonly;
7699 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7700 /* handle override, if any */
7701 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7702 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7703 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7704 gv = gvp ? *gvp : NULL;
7708 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7709 OP * const kid = cUNOPo->op_first;
7712 cUNOPo->op_first = 0;
7716 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7717 append_elem(OP_LIST, kid,
7718 scalar(newUNOP(OP_RV2CV, 0,
7721 op_getmad(o,newop,'O');
7725 return scalar(ck_fun(o));
7729 Perl_ck_return(pTHX_ OP *o)
7734 PERL_ARGS_ASSERT_CK_RETURN;
7736 kid = cLISTOPo->op_first->op_sibling;
7737 if (CvLVALUE(PL_compcv)) {
7738 for (; kid; kid = kid->op_sibling)
7739 mod(kid, OP_LEAVESUBLV);
7741 for (; kid; kid = kid->op_sibling)
7742 if ((kid->op_type == OP_NULL)
7743 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7744 /* This is a do block */
7745 OP *op = kUNOP->op_first;
7746 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7747 op = cUNOPx(op)->op_first;
7748 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7749 /* Force the use of the caller's context */
7750 op->op_flags |= OPf_SPECIAL;
7759 Perl_ck_select(pTHX_ OP *o)
7764 PERL_ARGS_ASSERT_CK_SELECT;
7766 if (o->op_flags & OPf_KIDS) {
7767 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7768 if (kid && kid->op_sibling) {
7769 o->op_type = OP_SSELECT;
7770 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7772 return fold_constants(o);
7776 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7777 if (kid && kid->op_type == OP_RV2GV)
7778 kid->op_private &= ~HINT_STRICT_REFS;
7783 Perl_ck_shift(pTHX_ OP *o)
7786 const I32 type = o->op_type;
7788 PERL_ARGS_ASSERT_CK_SHIFT;
7790 if (!(o->op_flags & OPf_KIDS)) {
7793 if (!CvUNIQUE(PL_compcv)) {
7794 o->op_flags |= OPf_SPECIAL;
7798 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
7800 OP * const oldo = o;
7801 o = newUNOP(type, 0, scalar(argop));
7802 op_getmad(oldo,o,'O');
7806 return newUNOP(type, 0, scalar(argop));
7809 return scalar(modkids(ck_fun(o), type));
7813 Perl_ck_sort(pTHX_ OP *o)
7818 PERL_ARGS_ASSERT_CK_SORT;
7820 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7821 HV * const hinthv = GvHV(PL_hintgv);
7823 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7825 const I32 sorthints = (I32)SvIV(*svp);
7826 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7827 o->op_private |= OPpSORT_QSORT;
7828 if ((sorthints & HINT_SORT_STABLE) != 0)
7829 o->op_private |= OPpSORT_STABLE;
7834 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7836 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7837 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7839 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7841 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7843 if (kid->op_type == OP_SCOPE) {
7847 else if (kid->op_type == OP_LEAVE) {
7848 if (o->op_type == OP_SORT) {
7849 op_null(kid); /* wipe out leave */
7852 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7853 if (k->op_next == kid)
7855 /* don't descend into loops */
7856 else if (k->op_type == OP_ENTERLOOP
7857 || k->op_type == OP_ENTERITER)
7859 k = cLOOPx(k)->op_lastop;
7864 kid->op_next = 0; /* just disconnect the leave */
7865 k = kLISTOP->op_first;
7870 if (o->op_type == OP_SORT) {
7871 /* provide scalar context for comparison function/block */
7877 o->op_flags |= OPf_SPECIAL;
7879 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7882 firstkid = firstkid->op_sibling;
7885 /* provide list context for arguments */
7886 if (o->op_type == OP_SORT)
7893 S_simplify_sort(pTHX_ OP *o)
7896 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7902 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7904 if (!(o->op_flags & OPf_STACKED))
7906 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7907 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7908 kid = kUNOP->op_first; /* get past null */
7909 if (kid->op_type != OP_SCOPE)
7911 kid = kLISTOP->op_last; /* get past scope */
7912 switch(kid->op_type) {
7920 k = kid; /* remember this node*/
7921 if (kBINOP->op_first->op_type != OP_RV2SV)
7923 kid = kBINOP->op_first; /* get past cmp */
7924 if (kUNOP->op_first->op_type != OP_GV)
7926 kid = kUNOP->op_first; /* get past rv2sv */
7928 if (GvSTASH(gv) != PL_curstash)
7930 gvname = GvNAME(gv);
7931 if (*gvname == 'a' && gvname[1] == '\0')
7933 else if (*gvname == 'b' && gvname[1] == '\0')
7938 kid = k; /* back to cmp */
7939 if (kBINOP->op_last->op_type != OP_RV2SV)
7941 kid = kBINOP->op_last; /* down to 2nd arg */
7942 if (kUNOP->op_first->op_type != OP_GV)
7944 kid = kUNOP->op_first; /* get past rv2sv */
7946 if (GvSTASH(gv) != PL_curstash)
7948 gvname = GvNAME(gv);
7950 ? !(*gvname == 'a' && gvname[1] == '\0')
7951 : !(*gvname == 'b' && gvname[1] == '\0'))
7953 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7955 o->op_private |= OPpSORT_DESCEND;
7956 if (k->op_type == OP_NCMP)
7957 o->op_private |= OPpSORT_NUMERIC;
7958 if (k->op_type == OP_I_NCMP)
7959 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7960 kid = cLISTOPo->op_first->op_sibling;
7961 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7963 op_getmad(kid,o,'S'); /* then delete it */
7965 op_free(kid); /* then delete it */
7970 Perl_ck_split(pTHX_ OP *o)
7975 PERL_ARGS_ASSERT_CK_SPLIT;
7977 if (o->op_flags & OPf_STACKED)
7978 return no_fh_allowed(o);
7980 kid = cLISTOPo->op_first;
7981 if (kid->op_type != OP_NULL)
7982 Perl_croak(aTHX_ "panic: ck_split");
7983 kid = kid->op_sibling;
7984 op_free(cLISTOPo->op_first);
7985 cLISTOPo->op_first = kid;
7987 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7988 cLISTOPo->op_last = kid; /* There was only one element previously */
7991 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7992 OP * const sibl = kid->op_sibling;
7993 kid->op_sibling = 0;
7994 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7995 if (cLISTOPo->op_first == cLISTOPo->op_last)
7996 cLISTOPo->op_last = kid;
7997 cLISTOPo->op_first = kid;
7998 kid->op_sibling = sibl;
8001 kid->op_type = OP_PUSHRE;
8002 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8004 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8005 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8006 "Use of /g modifier is meaningless in split");
8009 if (!kid->op_sibling)
8010 append_elem(OP_SPLIT, o, newDEFSVOP());
8012 kid = kid->op_sibling;
8015 if (!kid->op_sibling)
8016 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8017 assert(kid->op_sibling);
8019 kid = kid->op_sibling;
8022 if (kid->op_sibling)
8023 return too_many_arguments(o,OP_DESC(o));
8029 Perl_ck_join(pTHX_ OP *o)
8031 const OP * const kid = cLISTOPo->op_first->op_sibling;
8033 PERL_ARGS_ASSERT_CK_JOIN;
8035 if (kid && kid->op_type == OP_MATCH) {
8036 if (ckWARN(WARN_SYNTAX)) {
8037 const REGEXP *re = PM_GETRE(kPMOP);
8038 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8039 const STRLEN len = re ? RX_PRELEN(re) : 6;
8040 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8041 "/%.*s/ should probably be written as \"%.*s\"",
8042 (int)len, pmstr, (int)len, pmstr);
8049 Perl_ck_subr(pTHX_ OP *o)
8052 OP *prev = ((cUNOPo->op_first->op_sibling)
8053 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
8054 OP *o2 = prev->op_sibling;
8056 const char *proto = NULL;
8057 const char *proto_end = NULL;
8062 I32 contextclass = 0;
8063 const char *e = NULL;
8066 PERL_ARGS_ASSERT_CK_SUBR;
8068 o->op_private |= OPpENTERSUB_HASTARG;
8069 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
8070 if (cvop->op_type == OP_RV2CV) {
8071 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
8072 op_null(cvop); /* disable rv2cv */
8073 if (!(o->op_private & OPpENTERSUB_AMPER)) {
8074 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
8076 switch (tmpop->op_type) {
8078 gv = cGVOPx_gv(tmpop);
8081 tmpop->op_private |= OPpEARLY_CV;
8084 SV *sv = cSVOPx_sv(tmpop);
8085 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8089 if (cv && SvPOK(cv)) {
8091 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8092 proto = SvPV(MUTABLE_SV(cv), len);
8093 proto_end = proto + len;
8097 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8098 if (o2->op_type == OP_CONST)
8099 o2->op_private &= ~OPpCONST_STRICT;
8100 else if (o2->op_type == OP_LIST) {
8101 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8102 if (sib && sib->op_type == OP_CONST)
8103 sib->op_private &= ~OPpCONST_STRICT;
8106 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8107 if (PERLDB_SUB && PL_curstash != PL_debstash)
8108 o->op_private |= OPpENTERSUB_DB;
8109 while (o2 != cvop) {
8111 if (PL_madskills && o2->op_type == OP_STUB) {
8112 o2 = o2->op_sibling;
8115 if (PL_madskills && o2->op_type == OP_NULL)
8116 o3 = ((UNOP*)o2)->op_first;
8120 if (proto >= proto_end)
8121 return too_many_arguments(o, gv_ename(namegv));
8129 /* _ must be at the end */
8130 if (proto[1] && proto[1] != ';')
8145 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8147 arg == 1 ? "block or sub {}" : "sub {}",
8148 gv_ename(namegv), o3);
8151 /* '*' allows any scalar type, including bareword */
8154 if (o3->op_type == OP_RV2GV)
8155 goto wrapref; /* autoconvert GLOB -> GLOBref */
8156 else if (o3->op_type == OP_CONST)
8157 o3->op_private &= ~OPpCONST_STRICT;
8158 else if (o3->op_type == OP_ENTERSUB) {
8159 /* accidental subroutine, revert to bareword */
8160 OP *gvop = ((UNOP*)o3)->op_first;
8161 if (gvop && gvop->op_type == OP_NULL) {
8162 gvop = ((UNOP*)gvop)->op_first;
8164 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8167 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8168 (gvop = ((UNOP*)gvop)->op_first) &&
8169 gvop->op_type == OP_GV)
8171 GV * const gv = cGVOPx_gv(gvop);
8172 OP * const sibling = o2->op_sibling;
8173 SV * const n = newSVpvs("");
8175 OP * const oldo2 = o2;
8179 gv_fullname4(n, gv, "", FALSE);
8180 o2 = newSVOP(OP_CONST, 0, n);
8181 op_getmad(oldo2,o2,'O');
8182 prev->op_sibling = o2;
8183 o2->op_sibling = sibling;
8199 if (contextclass++ == 0) {
8200 e = strchr(proto, ']');
8201 if (!e || e == proto)
8210 const char *p = proto;
8211 const char *const end = proto;
8213 while (*--p != '[') {}
8214 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8216 gv_ename(namegv), o3);
8221 if (o3->op_type == OP_RV2GV)
8224 bad_type(arg, "symbol", gv_ename(namegv), o3);
8227 if (o3->op_type == OP_ENTERSUB)
8230 bad_type(arg, "subroutine entry", gv_ename(namegv),
8234 if (o3->op_type == OP_RV2SV ||
8235 o3->op_type == OP_PADSV ||
8236 o3->op_type == OP_HELEM ||
8237 o3->op_type == OP_AELEM)
8240 bad_type(arg, "scalar", gv_ename(namegv), o3);
8243 if (o3->op_type == OP_RV2AV ||
8244 o3->op_type == OP_PADAV)
8247 bad_type(arg, "array", gv_ename(namegv), o3);
8250 if (o3->op_type == OP_RV2HV ||
8251 o3->op_type == OP_PADHV)
8254 bad_type(arg, "hash", gv_ename(namegv), o3);
8259 OP* const sib = kid->op_sibling;
8260 kid->op_sibling = 0;
8261 o2 = newUNOP(OP_REFGEN, 0, kid);
8262 o2->op_sibling = sib;
8263 prev->op_sibling = o2;
8265 if (contextclass && e) {
8280 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8281 gv_ename(namegv), SVfARG(cv));
8286 mod(o2, OP_ENTERSUB);
8288 o2 = o2->op_sibling;
8290 if (o2 == cvop && proto && *proto == '_') {
8291 /* generate an access to $_ */
8293 o2->op_sibling = prev->op_sibling;
8294 prev->op_sibling = o2; /* instead of cvop */
8296 if (proto && !optional && proto_end > proto &&
8297 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8298 return too_few_arguments(o, gv_ename(namegv));
8301 OP * const oldo = o;
8305 o=newSVOP(OP_CONST, 0, newSViv(0));
8306 op_getmad(oldo,o,'O');
8312 Perl_ck_svconst(pTHX_ OP *o)
8314 PERL_ARGS_ASSERT_CK_SVCONST;
8315 PERL_UNUSED_CONTEXT;
8316 SvREADONLY_on(cSVOPo->op_sv);
8321 Perl_ck_chdir(pTHX_ OP *o)
8323 if (o->op_flags & OPf_KIDS) {
8324 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8326 if (kid && kid->op_type == OP_CONST &&
8327 (kid->op_private & OPpCONST_BARE))
8329 o->op_flags |= OPf_SPECIAL;
8330 kid->op_private &= ~OPpCONST_STRICT;
8337 Perl_ck_trunc(pTHX_ OP *o)
8339 PERL_ARGS_ASSERT_CK_TRUNC;
8341 if (o->op_flags & OPf_KIDS) {
8342 SVOP *kid = (SVOP*)cUNOPo->op_first;
8344 if (kid->op_type == OP_NULL)
8345 kid = (SVOP*)kid->op_sibling;
8346 if (kid && kid->op_type == OP_CONST &&
8347 (kid->op_private & OPpCONST_BARE))
8349 o->op_flags |= OPf_SPECIAL;
8350 kid->op_private &= ~OPpCONST_STRICT;
8357 Perl_ck_unpack(pTHX_ OP *o)
8359 OP *kid = cLISTOPo->op_first;
8361 PERL_ARGS_ASSERT_CK_UNPACK;
8363 if (kid->op_sibling) {
8364 kid = kid->op_sibling;
8365 if (!kid->op_sibling)
8366 kid->op_sibling = newDEFSVOP();
8372 Perl_ck_substr(pTHX_ OP *o)
8374 PERL_ARGS_ASSERT_CK_SUBSTR;
8377 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8378 OP *kid = cLISTOPo->op_first;
8380 if (kid->op_type == OP_NULL)
8381 kid = kid->op_sibling;
8383 kid->op_flags |= OPf_MOD;
8390 Perl_ck_each(pTHX_ OP *o)
8393 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8395 PERL_ARGS_ASSERT_CK_EACH;
8398 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8399 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8400 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8401 o->op_type = new_type;
8402 o->op_ppaddr = PL_ppaddr[new_type];
8404 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8405 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8407 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8414 /* caller is supposed to assign the return to the
8415 container of the rep_op var */
8417 S_opt_scalarhv(pTHX_ OP *rep_op) {
8421 PERL_ARGS_ASSERT_OPT_SCALARHV;
8423 NewOp(1101, unop, 1, UNOP);
8424 unop->op_type = (OPCODE)OP_BOOLKEYS;
8425 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8426 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8427 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8428 unop->op_first = rep_op;
8429 unop->op_next = rep_op->op_next;
8430 rep_op->op_next = (OP*)unop;
8431 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8432 unop->op_sibling = rep_op->op_sibling;
8433 rep_op->op_sibling = NULL;
8434 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8435 if (rep_op->op_type == OP_PADHV) {
8436 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8437 rep_op->op_flags |= OPf_WANT_LIST;
8442 /* Checks if o acts as an in-place operator on an array. oright points to the
8443 * beginning of the right-hand side. Returns the left-hand side of the
8444 * assignment if o acts in-place, or NULL otherwise. */
8447 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8451 PERL_ARGS_ASSERT_IS_INPLACE_AV;
8454 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8455 || oright->op_next != o
8456 || (oright->op_private & OPpLVAL_INTRO)
8460 /* o2 follows the chain of op_nexts through the LHS of the
8461 * assign (if any) to the aassign op itself */
8463 if (!o2 || o2->op_type != OP_NULL)
8466 if (!o2 || o2->op_type != OP_PUSHMARK)
8469 if (o2 && o2->op_type == OP_GV)
8472 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8473 || (o2->op_private & OPpLVAL_INTRO)
8478 if (!o2 || o2->op_type != OP_NULL)
8481 if (!o2 || o2->op_type != OP_AASSIGN
8482 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8485 /* check that the sort is the first arg on RHS of assign */
8487 o2 = cUNOPx(o2)->op_first;
8488 if (!o2 || o2->op_type != OP_NULL)
8490 o2 = cUNOPx(o2)->op_first;
8491 if (!o2 || o2->op_type != OP_PUSHMARK)
8493 if (o2->op_sibling != o)
8496 /* check the array is the same on both sides */
8497 if (oleft->op_type == OP_RV2AV) {
8498 if (oright->op_type != OP_RV2AV
8499 || !cUNOPx(oright)->op_first
8500 || cUNOPx(oright)->op_first->op_type != OP_GV
8501 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8502 cGVOPx_gv(cUNOPx(oright)->op_first)
8506 else if (oright->op_type != OP_PADAV
8507 || oright->op_targ != oleft->op_targ
8514 /* A peephole optimizer. We visit the ops in the order they're to execute.
8515 * See the comments at the top of this file for more details about when
8516 * peep() is called */
8519 Perl_peep(pTHX_ register OP *o)
8522 register OP* oldop = NULL;
8524 if (!o || o->op_opt)
8528 SAVEVPTR(PL_curcop);
8529 for (; o; o = o->op_next) {
8532 /* By default, this op has now been optimised. A couple of cases below
8533 clear this again. */
8536 switch (o->op_type) {
8539 PL_curcop = ((COP*)o); /* for warnings */
8543 if (cSVOPo->op_private & OPpCONST_STRICT)
8544 no_bareword_allowed(o);
8547 case OP_METHOD_NAMED:
8548 /* Relocate sv to the pad for thread safety.
8549 * Despite being a "constant", the SV is written to,
8550 * for reference counts, sv_upgrade() etc. */
8552 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8553 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8554 /* If op_sv is already a PADTMP then it is being used by
8555 * some pad, so make a copy. */
8556 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8557 SvREADONLY_on(PAD_SVl(ix));
8558 SvREFCNT_dec(cSVOPo->op_sv);
8560 else if (o->op_type != OP_METHOD_NAMED
8561 && cSVOPo->op_sv == &PL_sv_undef) {
8562 /* PL_sv_undef is hack - it's unsafe to store it in the
8563 AV that is the pad, because av_fetch treats values of
8564 PL_sv_undef as a "free" AV entry and will merrily
8565 replace them with a new SV, causing pad_alloc to think
8566 that this pad slot is free. (When, clearly, it is not)
8568 SvOK_off(PAD_SVl(ix));
8569 SvPADTMP_on(PAD_SVl(ix));
8570 SvREADONLY_on(PAD_SVl(ix));
8573 SvREFCNT_dec(PAD_SVl(ix));
8574 SvPADTMP_on(cSVOPo->op_sv);
8575 PAD_SETSV(ix, cSVOPo->op_sv);
8576 /* XXX I don't know how this isn't readonly already. */
8577 SvREADONLY_on(PAD_SVl(ix));
8579 cSVOPo->op_sv = NULL;
8586 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8587 if (o->op_next->op_private & OPpTARGET_MY) {
8588 if (o->op_flags & OPf_STACKED) /* chained concats */
8589 break; /* ignore_optimization */
8591 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8592 o->op_targ = o->op_next->op_targ;
8593 o->op_next->op_targ = 0;
8594 o->op_private |= OPpTARGET_MY;
8597 op_null(o->op_next);
8601 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8602 break; /* Scalar stub must produce undef. List stub is noop */
8606 if (o->op_targ == OP_NEXTSTATE
8607 || o->op_targ == OP_DBSTATE)
8609 PL_curcop = ((COP*)o);
8611 /* XXX: We avoid setting op_seq here to prevent later calls
8612 to peep() from mistakenly concluding that optimisation
8613 has already occurred. This doesn't fix the real problem,
8614 though (See 20010220.007). AMS 20010719 */
8615 /* op_seq functionality is now replaced by op_opt */
8622 if (oldop && o->op_next) {
8623 oldop->op_next = o->op_next;
8631 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8632 OP* const pop = (o->op_type == OP_PADAV) ?
8633 o->op_next : o->op_next->op_next;
8635 if (pop && pop->op_type == OP_CONST &&
8636 ((PL_op = pop->op_next)) &&
8637 pop->op_next->op_type == OP_AELEM &&
8638 !(pop->op_next->op_private &
8639 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8640 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8645 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8646 no_bareword_allowed(pop);
8647 if (o->op_type == OP_GV)
8648 op_null(o->op_next);
8649 op_null(pop->op_next);
8651 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8652 o->op_next = pop->op_next->op_next;
8653 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8654 o->op_private = (U8)i;
8655 if (o->op_type == OP_GV) {
8660 o->op_flags |= OPf_SPECIAL;
8661 o->op_type = OP_AELEMFAST;
8666 if (o->op_next->op_type == OP_RV2SV) {
8667 if (!(o->op_next->op_private & OPpDEREF)) {
8668 op_null(o->op_next);
8669 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8671 o->op_next = o->op_next->op_next;
8672 o->op_type = OP_GVSV;
8673 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8676 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8677 GV * const gv = cGVOPo_gv;
8678 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8679 /* XXX could check prototype here instead of just carping */
8680 SV * const sv = sv_newmortal();
8681 gv_efullname3(sv, gv, NULL);
8682 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8683 "%"SVf"() called too early to check prototype",
8687 else if (o->op_next->op_type == OP_READLINE
8688 && o->op_next->op_next->op_type == OP_CONCAT
8689 && (o->op_next->op_next->op_flags & OPf_STACKED))
8691 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8692 o->op_type = OP_RCATLINE;
8693 o->op_flags |= OPf_STACKED;
8694 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8695 op_null(o->op_next->op_next);
8696 op_null(o->op_next);
8706 fop = cUNOP->op_first;
8714 fop = cLOGOP->op_first;
8715 sop = fop->op_sibling;
8716 while (cLOGOP->op_other->op_type == OP_NULL)
8717 cLOGOP->op_other = cLOGOP->op_other->op_next;
8718 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8722 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8724 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8729 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
8730 while (nop && nop->op_next) {
8731 switch (nop->op_next->op_type) {
8736 lop = nop = nop->op_next;
8747 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
8748 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8749 cLOGOP->op_first = opt_scalarhv(fop);
8750 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8751 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8767 while (cLOGOP->op_other->op_type == OP_NULL)
8768 cLOGOP->op_other = cLOGOP->op_other->op_next;
8769 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8774 while (cLOOP->op_redoop->op_type == OP_NULL)
8775 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8776 peep(cLOOP->op_redoop);
8777 while (cLOOP->op_nextop->op_type == OP_NULL)
8778 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8779 peep(cLOOP->op_nextop);
8780 while (cLOOP->op_lastop->op_type == OP_NULL)
8781 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8782 peep(cLOOP->op_lastop);
8786 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8787 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8788 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8789 cPMOP->op_pmstashstartu.op_pmreplstart
8790 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8791 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8795 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8796 && ckWARN(WARN_SYNTAX))
8798 if (o->op_next->op_sibling) {
8799 const OPCODE type = o->op_next->op_sibling->op_type;
8800 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8801 const line_t oldline = CopLINE(PL_curcop);
8802 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8803 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8804 "Statement unlikely to be reached");
8805 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8806 "\t(Maybe you meant system() when you said exec()?)\n");
8807 CopLINE_set(PL_curcop, oldline);
8818 const char *key = NULL;
8821 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8824 /* Make the CONST have a shared SV */
8825 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8826 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8827 key = SvPV_const(sv, keylen);
8828 lexname = newSVpvn_share(key,
8829 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8835 if ((o->op_private & (OPpLVAL_INTRO)))
8838 rop = (UNOP*)((BINOP*)o)->op_first;
8839 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8841 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8842 if (!SvPAD_TYPED(lexname))
8844 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8845 if (!fields || !GvHV(*fields))
8847 key = SvPV_const(*svp, keylen);
8848 if (!hv_fetch(GvHV(*fields), key,
8849 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8851 Perl_croak(aTHX_ "No such class field \"%s\" "
8852 "in variable %s of type %s",
8853 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8866 SVOP *first_key_op, *key_op;
8868 if ((o->op_private & (OPpLVAL_INTRO))
8869 /* I bet there's always a pushmark... */
8870 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8871 /* hmmm, no optimization if list contains only one key. */
8873 rop = (UNOP*)((LISTOP*)o)->op_last;
8874 if (rop->op_type != OP_RV2HV)
8876 if (rop->op_first->op_type == OP_PADSV)
8877 /* @$hash{qw(keys here)} */
8878 rop = (UNOP*)rop->op_first;
8880 /* @{$hash}{qw(keys here)} */
8881 if (rop->op_first->op_type == OP_SCOPE
8882 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8884 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8890 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8891 if (!SvPAD_TYPED(lexname))
8893 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8894 if (!fields || !GvHV(*fields))
8896 /* Again guessing that the pushmark can be jumped over.... */
8897 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8898 ->op_first->op_sibling;
8899 for (key_op = first_key_op; key_op;
8900 key_op = (SVOP*)key_op->op_sibling) {
8901 if (key_op->op_type != OP_CONST)
8903 svp = cSVOPx_svp(key_op);
8904 key = SvPV_const(*svp, keylen);
8905 if (!hv_fetch(GvHV(*fields), key,
8906 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8908 Perl_croak(aTHX_ "No such class field \"%s\" "
8909 "in variable %s of type %s",
8910 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8919 && ( oldop->op_type == OP_AELEM
8920 || oldop->op_type == OP_PADSV
8921 || oldop->op_type == OP_RV2SV
8922 || oldop->op_type == OP_RV2GV
8923 || oldop->op_type == OP_HELEM
8925 && (oldop->op_private & OPpDEREF)
8927 o->op_private |= OPpDEREFed;
8931 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8935 /* check that RHS of sort is a single plain array */
8936 OP *oright = cUNOPo->op_first;
8937 if (!oright || oright->op_type != OP_PUSHMARK)
8940 /* reverse sort ... can be optimised. */
8941 if (!cUNOPo->op_sibling) {
8942 /* Nothing follows us on the list. */
8943 OP * const reverse = o->op_next;
8945 if (reverse->op_type == OP_REVERSE &&
8946 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8947 OP * const pushmark = cUNOPx(reverse)->op_first;
8948 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8949 && (cUNOPx(pushmark)->op_sibling == o)) {
8950 /* reverse -> pushmark -> sort */
8951 o->op_private |= OPpSORT_REVERSE;
8953 pushmark->op_next = oright->op_next;
8959 /* make @a = sort @a act in-place */
8961 oright = cUNOPx(oright)->op_sibling;
8964 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8965 oright = cUNOPx(oright)->op_sibling;
8968 oleft = is_inplace_av(o, oright);
8972 /* transfer MODishness etc from LHS arg to RHS arg */
8973 oright->op_flags = oleft->op_flags;
8974 o->op_private |= OPpSORT_INPLACE;
8976 /* excise push->gv->rv2av->null->aassign */
8977 o2 = o->op_next->op_next;
8978 op_null(o2); /* PUSHMARK */
8980 if (o2->op_type == OP_GV) {
8981 op_null(o2); /* GV */
8984 op_null(o2); /* RV2AV or PADAV */
8985 o2 = o2->op_next->op_next;
8986 op_null(o2); /* AASSIGN */
8988 o->op_next = o2->op_next;
8994 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8997 LISTOP *enter, *exlist;
8999 /* @a = reverse @a */
9000 if ((oright = cLISTOPo->op_first)
9001 && (oright->op_type == OP_PUSHMARK)
9002 && (oright = oright->op_sibling)
9003 && (oleft = is_inplace_av(o, oright))) {
9006 /* transfer MODishness etc from LHS arg to RHS arg */
9007 oright->op_flags = oleft->op_flags;
9008 o->op_private |= OPpREVERSE_INPLACE;
9010 /* excise push->gv->rv2av->null->aassign */
9011 o2 = o->op_next->op_next;
9012 op_null(o2); /* PUSHMARK */
9014 if (o2->op_type == OP_GV) {
9015 op_null(o2); /* GV */
9018 op_null(o2); /* RV2AV or PADAV */
9019 o2 = o2->op_next->op_next;
9020 op_null(o2); /* AASSIGN */
9022 o->op_next = o2->op_next;
9026 enter = (LISTOP *) o->op_next;
9029 if (enter->op_type == OP_NULL) {
9030 enter = (LISTOP *) enter->op_next;
9034 /* for $a (...) will have OP_GV then OP_RV2GV here.
9035 for (...) just has an OP_GV. */
9036 if (enter->op_type == OP_GV) {
9037 gvop = (OP *) enter;
9038 enter = (LISTOP *) enter->op_next;
9041 if (enter->op_type == OP_RV2GV) {
9042 enter = (LISTOP *) enter->op_next;
9048 if (enter->op_type != OP_ENTERITER)
9051 iter = enter->op_next;
9052 if (!iter || iter->op_type != OP_ITER)
9055 expushmark = enter->op_first;
9056 if (!expushmark || expushmark->op_type != OP_NULL
9057 || expushmark->op_targ != OP_PUSHMARK)
9060 exlist = (LISTOP *) expushmark->op_sibling;
9061 if (!exlist || exlist->op_type != OP_NULL
9062 || exlist->op_targ != OP_LIST)
9065 if (exlist->op_last != o) {
9066 /* Mmm. Was expecting to point back to this op. */
9069 theirmark = exlist->op_first;
9070 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9073 if (theirmark->op_sibling != o) {
9074 /* There's something between the mark and the reverse, eg
9075 for (1, reverse (...))
9080 ourmark = ((LISTOP *)o)->op_first;
9081 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9084 ourlast = ((LISTOP *)o)->op_last;
9085 if (!ourlast || ourlast->op_next != o)
9088 rv2av = ourmark->op_sibling;
9089 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9090 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9091 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9092 /* We're just reversing a single array. */
9093 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9094 enter->op_flags |= OPf_STACKED;
9097 /* We don't have control over who points to theirmark, so sacrifice
9099 theirmark->op_next = ourmark->op_next;
9100 theirmark->op_flags = ourmark->op_flags;
9101 ourlast->op_next = gvop ? gvop : (OP *) enter;
9104 enter->op_private |= OPpITER_REVERSED;
9105 iter->op_private |= OPpITER_REVERSED;
9112 UNOP *refgen, *rv2cv;
9115 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9118 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9121 rv2gv = ((BINOP *)o)->op_last;
9122 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9125 refgen = (UNOP *)((BINOP *)o)->op_first;
9127 if (!refgen || refgen->op_type != OP_REFGEN)
9130 exlist = (LISTOP *)refgen->op_first;
9131 if (!exlist || exlist->op_type != OP_NULL
9132 || exlist->op_targ != OP_LIST)
9135 if (exlist->op_first->op_type != OP_PUSHMARK)
9138 rv2cv = (UNOP*)exlist->op_last;
9140 if (rv2cv->op_type != OP_RV2CV)
9143 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9144 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9145 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9147 o->op_private |= OPpASSIGN_CV_TO_GV;
9148 rv2gv->op_private |= OPpDONT_INIT_GV;
9149 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9157 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9158 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9168 Perl_custom_op_name(pTHX_ const OP* o)
9171 const IV index = PTR2IV(o->op_ppaddr);
9175 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9177 if (!PL_custom_op_names) /* This probably shouldn't happen */
9178 return (char *)PL_op_name[OP_CUSTOM];
9180 keysv = sv_2mortal(newSViv(index));
9182 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9184 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9186 return SvPV_nolen(HeVAL(he));
9190 Perl_custom_op_desc(pTHX_ const OP* o)
9193 const IV index = PTR2IV(o->op_ppaddr);
9197 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9199 if (!PL_custom_op_descs)
9200 return (char *)PL_op_desc[OP_CUSTOM];
9202 keysv = sv_2mortal(newSViv(index));
9204 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9206 return (char *)PL_op_desc[OP_CUSTOM];
9208 return SvPV_nolen(HeVAL(he));
9213 /* Efficient sub that returns a constant scalar value. */
9215 const_sv_xsub(pTHX_ CV* cv)
9219 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9223 /* diag_listed_as: SKIPME */
9224 Perl_croak(aTHX_ "usage: %s::%s()",
9225 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9238 * c-indentation-style: bsd
9240 * indent-tabs-mode: t
9243 * ex: set ts=8 sts=4 sw=4 noet: