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;
2314 pad_block_start(full);
2316 PL_hints &= ~HINT_BLOCK_SCOPE;
2317 SAVECOMPILEWARNINGS();
2318 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2323 Perl_block_end(pTHX_ I32 floor, OP *seq)
2326 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2327 OP* const retval = scalarseq(seq);
2329 CopHINTS_set(&PL_compiling, PL_hints);
2331 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2340 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2341 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2342 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2345 OP * const o = newOP(OP_PADSV, 0);
2346 o->op_targ = offset;
2352 Perl_newPROG(pTHX_ OP *o)
2356 PERL_ARGS_ASSERT_NEWPROG;
2361 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2362 ((PL_in_eval & EVAL_KEEPERR)
2363 ? OPf_SPECIAL : 0), o);
2364 PL_eval_start = linklist(PL_eval_root);
2365 PL_eval_root->op_private |= OPpREFCOUNTED;
2366 OpREFCNT_set(PL_eval_root, 1);
2367 PL_eval_root->op_next = 0;
2368 CALL_PEEP(PL_eval_start);
2371 if (o->op_type == OP_STUB) {
2372 PL_comppad_name = 0;
2374 S_op_destroy(aTHX_ o);
2377 PL_main_root = scope(sawparens(scalarvoid(o)));
2378 PL_curcop = &PL_compiling;
2379 PL_main_start = LINKLIST(PL_main_root);
2380 PL_main_root->op_private |= OPpREFCOUNTED;
2381 OpREFCNT_set(PL_main_root, 1);
2382 PL_main_root->op_next = 0;
2383 CALL_PEEP(PL_main_start);
2386 /* Register with debugger */
2388 CV * const cv = get_cvs("DB::postponed", 0);
2392 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2394 call_sv(MUTABLE_SV(cv), G_DISCARD);
2401 Perl_localize(pTHX_ OP *o, I32 lex)
2405 PERL_ARGS_ASSERT_LOCALIZE;
2407 if (o->op_flags & OPf_PARENS)
2408 /* [perl #17376]: this appears to be premature, and results in code such as
2409 C< our(%x); > executing in list mode rather than void mode */
2416 if ( PL_parser->bufptr > PL_parser->oldbufptr
2417 && PL_parser->bufptr[-1] == ','
2418 && ckWARN(WARN_PARENTHESIS))
2420 char *s = PL_parser->bufptr;
2423 /* some heuristics to detect a potential error */
2424 while (*s && (strchr(", \t\n", *s)))
2428 if (*s && strchr("@$%*", *s) && *++s
2429 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2432 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2434 while (*s && (strchr(", \t\n", *s)))
2440 if (sigil && (*s == ';' || *s == '=')) {
2441 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2442 "Parentheses missing around \"%s\" list",
2444 ? (PL_parser->in_my == KEY_our
2446 : PL_parser->in_my == KEY_state
2456 o = mod(o, OP_NULL); /* a bit kludgey */
2457 PL_parser->in_my = FALSE;
2458 PL_parser->in_my_stash = NULL;
2463 Perl_jmaybe(pTHX_ OP *o)
2465 PERL_ARGS_ASSERT_JMAYBE;
2467 if (o->op_type == OP_LIST) {
2469 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2470 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2476 S_fold_constants(pTHX_ register OP *o)
2479 register OP * VOL curop;
2481 VOL I32 type = o->op_type;
2486 SV * const oldwarnhook = PL_warnhook;
2487 SV * const olddiehook = PL_diehook;
2491 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2493 if (PL_opargs[type] & OA_RETSCALAR)
2495 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2496 o->op_targ = pad_alloc(type, SVs_PADTMP);
2498 /* integerize op, unless it happens to be C<-foo>.
2499 * XXX should pp_i_negate() do magic string negation instead? */
2500 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2501 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2502 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2504 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2507 if (!(PL_opargs[type] & OA_FOLDCONST))
2512 /* XXX might want a ck_negate() for this */
2513 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2524 /* XXX what about the numeric ops? */
2525 if (PL_hints & HINT_LOCALE)
2530 if (PL_parser && PL_parser->error_count)
2531 goto nope; /* Don't try to run w/ errors */
2533 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2534 const OPCODE type = curop->op_type;
2535 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2537 type != OP_SCALAR &&
2539 type != OP_PUSHMARK)
2545 curop = LINKLIST(o);
2546 old_next = o->op_next;
2550 oldscope = PL_scopestack_ix;
2551 create_eval_scope(G_FAKINGEVAL);
2553 /* Verify that we don't need to save it: */
2554 assert(PL_curcop == &PL_compiling);
2555 StructCopy(&PL_compiling, ¬_compiling, COP);
2556 PL_curcop = ¬_compiling;
2557 /* The above ensures that we run with all the correct hints of the
2558 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2559 assert(IN_PERL_RUNTIME);
2560 PL_warnhook = PERL_WARNHOOK_FATAL;
2567 sv = *(PL_stack_sp--);
2568 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2569 pad_swipe(o->op_targ, FALSE);
2570 else if (SvTEMP(sv)) { /* grab mortal temp? */
2571 SvREFCNT_inc_simple_void(sv);
2576 /* Something tried to die. Abandon constant folding. */
2577 /* Pretend the error never happened. */
2579 o->op_next = old_next;
2583 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2584 PL_warnhook = oldwarnhook;
2585 PL_diehook = olddiehook;
2586 /* XXX note that this croak may fail as we've already blown away
2587 * the stack - eg any nested evals */
2588 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2591 PL_warnhook = oldwarnhook;
2592 PL_diehook = olddiehook;
2593 PL_curcop = &PL_compiling;
2595 if (PL_scopestack_ix > oldscope)
2596 delete_eval_scope();
2605 if (type == OP_RV2GV)
2606 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2608 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2609 op_getmad(o,newop,'f');
2617 S_gen_constant_list(pTHX_ register OP *o)
2621 const I32 oldtmps_floor = PL_tmps_floor;
2624 if (PL_parser && PL_parser->error_count)
2625 return o; /* Don't attempt to run with errors */
2627 PL_op = curop = LINKLIST(o);
2633 assert (!(curop->op_flags & OPf_SPECIAL));
2634 assert(curop->op_type == OP_RANGE);
2636 PL_tmps_floor = oldtmps_floor;
2638 o->op_type = OP_RV2AV;
2639 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2640 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2641 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2642 o->op_opt = 0; /* needs to be revisited in peep() */
2643 curop = ((UNOP*)o)->op_first;
2644 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2646 op_getmad(curop,o,'O');
2655 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2658 if (!o || o->op_type != OP_LIST)
2659 o = newLISTOP(OP_LIST, 0, o, NULL);
2661 o->op_flags &= ~OPf_WANT;
2663 if (!(PL_opargs[type] & OA_MARK))
2664 op_null(cLISTOPo->op_first);
2666 o->op_type = (OPCODE)type;
2667 o->op_ppaddr = PL_ppaddr[type];
2668 o->op_flags |= flags;
2670 o = CHECKOP(type, o);
2671 if (o->op_type != (unsigned)type)
2674 return fold_constants(o);
2677 /* List constructors */
2680 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2688 if (first->op_type != (unsigned)type
2689 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2691 return newLISTOP(type, 0, first, last);
2694 if (first->op_flags & OPf_KIDS)
2695 ((LISTOP*)first)->op_last->op_sibling = last;
2697 first->op_flags |= OPf_KIDS;
2698 ((LISTOP*)first)->op_first = last;
2700 ((LISTOP*)first)->op_last = last;
2705 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2713 if (first->op_type != (unsigned)type)
2714 return prepend_elem(type, (OP*)first, (OP*)last);
2716 if (last->op_type != (unsigned)type)
2717 return append_elem(type, (OP*)first, (OP*)last);
2719 first->op_last->op_sibling = last->op_first;
2720 first->op_last = last->op_last;
2721 first->op_flags |= (last->op_flags & OPf_KIDS);
2724 if (last->op_first && first->op_madprop) {
2725 MADPROP *mp = last->op_first->op_madprop;
2727 while (mp->mad_next)
2729 mp->mad_next = first->op_madprop;
2732 last->op_first->op_madprop = first->op_madprop;
2735 first->op_madprop = last->op_madprop;
2736 last->op_madprop = 0;
2739 S_op_destroy(aTHX_ (OP*)last);
2745 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2753 if (last->op_type == (unsigned)type) {
2754 if (type == OP_LIST) { /* already a PUSHMARK there */
2755 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2756 ((LISTOP*)last)->op_first->op_sibling = first;
2757 if (!(first->op_flags & OPf_PARENS))
2758 last->op_flags &= ~OPf_PARENS;
2761 if (!(last->op_flags & OPf_KIDS)) {
2762 ((LISTOP*)last)->op_last = first;
2763 last->op_flags |= OPf_KIDS;
2765 first->op_sibling = ((LISTOP*)last)->op_first;
2766 ((LISTOP*)last)->op_first = first;
2768 last->op_flags |= OPf_KIDS;
2772 return newLISTOP(type, 0, first, last);
2780 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2783 Newxz(tk, 1, TOKEN);
2784 tk->tk_type = (OPCODE)optype;
2785 tk->tk_type = 12345;
2787 tk->tk_mad = madprop;
2792 Perl_token_free(pTHX_ TOKEN* tk)
2794 PERL_ARGS_ASSERT_TOKEN_FREE;
2796 if (tk->tk_type != 12345)
2798 mad_free(tk->tk_mad);
2803 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2808 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2810 if (tk->tk_type != 12345) {
2811 Perl_warner(aTHX_ packWARN(WARN_MISC),
2812 "Invalid TOKEN object ignored");
2819 /* faked up qw list? */
2821 tm->mad_type == MAD_SV &&
2822 SvPVX((SV *)tm->mad_val)[0] == 'q')
2829 /* pretend constant fold didn't happen? */
2830 if (mp->mad_key == 'f' &&
2831 (o->op_type == OP_CONST ||
2832 o->op_type == OP_GV) )
2834 token_getmad(tk,(OP*)mp->mad_val,slot);
2848 if (mp->mad_key == 'X')
2849 mp->mad_key = slot; /* just change the first one */
2859 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2868 /* pretend constant fold didn't happen? */
2869 if (mp->mad_key == 'f' &&
2870 (o->op_type == OP_CONST ||
2871 o->op_type == OP_GV) )
2873 op_getmad(from,(OP*)mp->mad_val,slot);
2880 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2883 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2889 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2898 /* pretend constant fold didn't happen? */
2899 if (mp->mad_key == 'f' &&
2900 (o->op_type == OP_CONST ||
2901 o->op_type == OP_GV) )
2903 op_getmad(from,(OP*)mp->mad_val,slot);
2910 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2913 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2917 PerlIO_printf(PerlIO_stderr(),
2918 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2924 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2942 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2946 addmad(tm, &(o->op_madprop), slot);
2950 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2971 Perl_newMADsv(pTHX_ char key, SV* sv)
2973 PERL_ARGS_ASSERT_NEWMADSV;
2975 return newMADPROP(key, MAD_SV, sv, 0);
2979 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2982 Newxz(mp, 1, MADPROP);
2985 mp->mad_vlen = vlen;
2986 mp->mad_type = type;
2988 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2993 Perl_mad_free(pTHX_ MADPROP* mp)
2995 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2999 mad_free(mp->mad_next);
3000 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3001 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3002 switch (mp->mad_type) {
3006 Safefree((char*)mp->mad_val);
3009 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3010 op_free((OP*)mp->mad_val);
3013 sv_free(MUTABLE_SV(mp->mad_val));
3016 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3025 Perl_newNULLLIST(pTHX)
3027 return newOP(OP_STUB, 0);
3031 S_force_list(pTHX_ OP *o)
3033 if (!o || o->op_type != OP_LIST)
3034 o = newLISTOP(OP_LIST, 0, o, NULL);
3040 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3045 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3047 NewOp(1101, listop, 1, LISTOP);
3049 listop->op_type = (OPCODE)type;
3050 listop->op_ppaddr = PL_ppaddr[type];
3053 listop->op_flags = (U8)flags;
3057 else if (!first && last)
3060 first->op_sibling = last;
3061 listop->op_first = first;
3062 listop->op_last = last;
3063 if (type == OP_LIST) {
3064 OP* const pushop = newOP(OP_PUSHMARK, 0);
3065 pushop->op_sibling = first;
3066 listop->op_first = pushop;
3067 listop->op_flags |= OPf_KIDS;
3069 listop->op_last = pushop;
3072 return CHECKOP(type, listop);
3076 Perl_newOP(pTHX_ I32 type, I32 flags)
3081 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3082 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3083 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3084 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3086 NewOp(1101, o, 1, OP);
3087 o->op_type = (OPCODE)type;
3088 o->op_ppaddr = PL_ppaddr[type];
3089 o->op_flags = (U8)flags;
3091 o->op_latefreed = 0;
3095 o->op_private = (U8)(0 | (flags >> 8));
3096 if (PL_opargs[type] & OA_RETSCALAR)
3098 if (PL_opargs[type] & OA_TARGET)
3099 o->op_targ = pad_alloc(type, SVs_PADTMP);
3100 return CHECKOP(type, o);
3104 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3109 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3110 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3111 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3112 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3113 || type == OP_SASSIGN
3114 || type == OP_ENTERTRY
3115 || type == OP_NULL );
3118 first = newOP(OP_STUB, 0);
3119 if (PL_opargs[type] & OA_MARK)
3120 first = force_list(first);
3122 NewOp(1101, unop, 1, UNOP);
3123 unop->op_type = (OPCODE)type;
3124 unop->op_ppaddr = PL_ppaddr[type];
3125 unop->op_first = first;
3126 unop->op_flags = (U8)(flags | OPf_KIDS);
3127 unop->op_private = (U8)(1 | (flags >> 8));
3128 unop = (UNOP*) CHECKOP(type, unop);
3132 return fold_constants((OP *) unop);
3136 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3141 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3142 || type == OP_SASSIGN || type == OP_NULL );
3144 NewOp(1101, binop, 1, BINOP);
3147 first = newOP(OP_NULL, 0);
3149 binop->op_type = (OPCODE)type;
3150 binop->op_ppaddr = PL_ppaddr[type];
3151 binop->op_first = first;
3152 binop->op_flags = (U8)(flags | OPf_KIDS);
3155 binop->op_private = (U8)(1 | (flags >> 8));
3158 binop->op_private = (U8)(2 | (flags >> 8));
3159 first->op_sibling = last;
3162 binop = (BINOP*)CHECKOP(type, binop);
3163 if (binop->op_next || binop->op_type != (OPCODE)type)
3166 binop->op_last = binop->op_first->op_sibling;
3168 return fold_constants((OP *)binop);
3171 static int uvcompare(const void *a, const void *b)
3172 __attribute__nonnull__(1)
3173 __attribute__nonnull__(2)
3174 __attribute__pure__;
3175 static int uvcompare(const void *a, const void *b)
3177 if (*((const UV *)a) < (*(const UV *)b))
3179 if (*((const UV *)a) > (*(const UV *)b))
3181 if (*((const UV *)a+1) < (*(const UV *)b+1))
3183 if (*((const UV *)a+1) > (*(const UV *)b+1))
3189 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3192 SV * const tstr = ((SVOP*)expr)->op_sv;
3195 (repl->op_type == OP_NULL)
3196 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3198 ((SVOP*)repl)->op_sv;
3201 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3202 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3206 register short *tbl;
3208 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3209 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3210 I32 del = o->op_private & OPpTRANS_DELETE;
3213 PERL_ARGS_ASSERT_PMTRANS;
3215 PL_hints |= HINT_BLOCK_SCOPE;
3218 o->op_private |= OPpTRANS_FROM_UTF;
3221 o->op_private |= OPpTRANS_TO_UTF;
3223 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3224 SV* const listsv = newSVpvs("# comment\n");
3226 const U8* tend = t + tlen;
3227 const U8* rend = r + rlen;
3241 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3242 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3245 const U32 flags = UTF8_ALLOW_DEFAULT;
3249 t = tsave = bytes_to_utf8(t, &len);
3252 if (!to_utf && rlen) {
3254 r = rsave = bytes_to_utf8(r, &len);
3258 /* There are several snags with this code on EBCDIC:
3259 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3260 2. scan_const() in toke.c has encoded chars in native encoding which makes
3261 ranges at least in EBCDIC 0..255 range the bottom odd.
3265 U8 tmpbuf[UTF8_MAXBYTES+1];
3268 Newx(cp, 2*tlen, UV);
3270 transv = newSVpvs("");
3272 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3274 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3276 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3280 cp[2*i+1] = cp[2*i];
3284 qsort(cp, i, 2*sizeof(UV), uvcompare);
3285 for (j = 0; j < i; j++) {
3287 diff = val - nextmin;
3289 t = uvuni_to_utf8(tmpbuf,nextmin);
3290 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3292 U8 range_mark = UTF_TO_NATIVE(0xff);
3293 t = uvuni_to_utf8(tmpbuf, val - 1);
3294 sv_catpvn(transv, (char *)&range_mark, 1);
3295 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3302 t = uvuni_to_utf8(tmpbuf,nextmin);
3303 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3305 U8 range_mark = UTF_TO_NATIVE(0xff);
3306 sv_catpvn(transv, (char *)&range_mark, 1);
3308 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3309 UNICODE_ALLOW_SUPER);
3310 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3311 t = (const U8*)SvPVX_const(transv);
3312 tlen = SvCUR(transv);
3316 else if (!rlen && !del) {
3317 r = t; rlen = tlen; rend = tend;
3320 if ((!rlen && !del) || t == r ||
3321 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3323 o->op_private |= OPpTRANS_IDENTICAL;
3327 while (t < tend || tfirst <= tlast) {
3328 /* see if we need more "t" chars */
3329 if (tfirst > tlast) {
3330 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3332 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3334 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3341 /* now see if we need more "r" chars */
3342 if (rfirst > rlast) {
3344 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3346 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3348 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3357 rfirst = rlast = 0xffffffff;
3361 /* now see which range will peter our first, if either. */
3362 tdiff = tlast - tfirst;
3363 rdiff = rlast - rfirst;
3370 if (rfirst == 0xffffffff) {
3371 diff = tdiff; /* oops, pretend rdiff is infinite */
3373 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3374 (long)tfirst, (long)tlast);
3376 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3380 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3381 (long)tfirst, (long)(tfirst + diff),
3384 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3385 (long)tfirst, (long)rfirst);
3387 if (rfirst + diff > max)
3388 max = rfirst + diff;
3390 grows = (tfirst < rfirst &&
3391 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3403 else if (max > 0xff)
3408 PerlMemShared_free(cPVOPo->op_pv);
3409 cPVOPo->op_pv = NULL;
3411 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3413 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3414 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3415 PAD_SETSV(cPADOPo->op_padix, swash);
3417 SvREADONLY_on(swash);
3419 cSVOPo->op_sv = swash;
3421 SvREFCNT_dec(listsv);
3422 SvREFCNT_dec(transv);
3424 if (!del && havefinal && rlen)
3425 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3426 newSVuv((UV)final), 0);
3429 o->op_private |= OPpTRANS_GROWS;
3435 op_getmad(expr,o,'e');
3436 op_getmad(repl,o,'r');
3444 tbl = (short*)cPVOPo->op_pv;
3446 Zero(tbl, 256, short);
3447 for (i = 0; i < (I32)tlen; i++)
3449 for (i = 0, j = 0; i < 256; i++) {
3451 if (j >= (I32)rlen) {
3460 if (i < 128 && r[j] >= 128)
3470 o->op_private |= OPpTRANS_IDENTICAL;
3472 else if (j >= (I32)rlen)
3477 PerlMemShared_realloc(tbl,
3478 (0x101+rlen-j) * sizeof(short));
3479 cPVOPo->op_pv = (char*)tbl;
3481 tbl[0x100] = (short)(rlen - j);
3482 for (i=0; i < (I32)rlen - j; i++)
3483 tbl[0x101+i] = r[j+i];
3487 if (!rlen && !del) {
3490 o->op_private |= OPpTRANS_IDENTICAL;
3492 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3493 o->op_private |= OPpTRANS_IDENTICAL;
3495 for (i = 0; i < 256; i++)
3497 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3498 if (j >= (I32)rlen) {
3500 if (tbl[t[i]] == -1)
3506 if (tbl[t[i]] == -1) {
3507 if (t[i] < 128 && r[j] >= 128)
3514 if(del && rlen == tlen) {
3515 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3516 } else if(rlen > tlen) {
3517 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3521 o->op_private |= OPpTRANS_GROWS;
3523 op_getmad(expr,o,'e');
3524 op_getmad(repl,o,'r');
3534 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3539 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3541 NewOp(1101, pmop, 1, PMOP);
3542 pmop->op_type = (OPCODE)type;
3543 pmop->op_ppaddr = PL_ppaddr[type];
3544 pmop->op_flags = (U8)flags;
3545 pmop->op_private = (U8)(0 | (flags >> 8));
3547 if (PL_hints & HINT_RE_TAINT)
3548 pmop->op_pmflags |= PMf_RETAINT;
3549 if (PL_hints & HINT_LOCALE)
3550 pmop->op_pmflags |= PMf_LOCALE;
3554 assert(SvPOK(PL_regex_pad[0]));
3555 if (SvCUR(PL_regex_pad[0])) {
3556 /* Pop off the "packed" IV from the end. */
3557 SV *const repointer_list = PL_regex_pad[0];
3558 const char *p = SvEND(repointer_list) - sizeof(IV);
3559 const IV offset = *((IV*)p);
3561 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3563 SvEND_set(repointer_list, p);
3565 pmop->op_pmoffset = offset;
3566 /* This slot should be free, so assert this: */
3567 assert(PL_regex_pad[offset] == &PL_sv_undef);
3569 SV * const repointer = &PL_sv_undef;
3570 av_push(PL_regex_padav, repointer);
3571 pmop->op_pmoffset = av_len(PL_regex_padav);
3572 PL_regex_pad = AvARRAY(PL_regex_padav);
3576 return CHECKOP(type, pmop);
3579 /* Given some sort of match op o, and an expression expr containing a
3580 * pattern, either compile expr into a regex and attach it to o (if it's
3581 * constant), or convert expr into a runtime regcomp op sequence (if it's
3584 * isreg indicates that the pattern is part of a regex construct, eg
3585 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3586 * split "pattern", which aren't. In the former case, expr will be a list
3587 * if the pattern contains more than one term (eg /a$b/) or if it contains
3588 * a replacement, ie s/// or tr///.
3592 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3597 I32 repl_has_vars = 0;
3601 PERL_ARGS_ASSERT_PMRUNTIME;
3603 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3604 /* last element in list is the replacement; pop it */
3606 repl = cLISTOPx(expr)->op_last;
3607 kid = cLISTOPx(expr)->op_first;
3608 while (kid->op_sibling != repl)
3609 kid = kid->op_sibling;
3610 kid->op_sibling = NULL;
3611 cLISTOPx(expr)->op_last = kid;
3614 if (isreg && expr->op_type == OP_LIST &&
3615 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3617 /* convert single element list to element */
3618 OP* const oe = expr;
3619 expr = cLISTOPx(oe)->op_first->op_sibling;
3620 cLISTOPx(oe)->op_first->op_sibling = NULL;
3621 cLISTOPx(oe)->op_last = NULL;
3625 if (o->op_type == OP_TRANS) {
3626 return pmtrans(o, expr, repl);
3629 reglist = isreg && expr->op_type == OP_LIST;
3633 PL_hints |= HINT_BLOCK_SCOPE;
3636 if (expr->op_type == OP_CONST) {
3637 SV *pat = ((SVOP*)expr)->op_sv;
3638 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3640 if (o->op_flags & OPf_SPECIAL)
3641 pm_flags |= RXf_SPLIT;
3644 assert (SvUTF8(pat));
3645 } else if (SvUTF8(pat)) {
3646 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3647 trapped in use 'bytes'? */
3648 /* Make a copy of the octet sequence, but without the flag on, as
3649 the compiler now honours the SvUTF8 flag on pat. */
3651 const char *const p = SvPV(pat, len);
3652 pat = newSVpvn_flags(p, len, SVs_TEMP);
3655 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3658 op_getmad(expr,(OP*)pm,'e');
3664 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3665 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3667 : OP_REGCMAYBE),0,expr);
3669 NewOp(1101, rcop, 1, LOGOP);
3670 rcop->op_type = OP_REGCOMP;
3671 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3672 rcop->op_first = scalar(expr);
3673 rcop->op_flags |= OPf_KIDS
3674 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3675 | (reglist ? OPf_STACKED : 0);
3676 rcop->op_private = 1;
3679 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3681 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3684 /* establish postfix order */
3685 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3687 rcop->op_next = expr;
3688 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3691 rcop->op_next = LINKLIST(expr);
3692 expr->op_next = (OP*)rcop;
3695 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3700 if (pm->op_pmflags & PMf_EVAL) {
3702 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3703 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3705 else if (repl->op_type == OP_CONST)
3709 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3710 if (curop->op_type == OP_SCOPE
3711 || curop->op_type == OP_LEAVE
3712 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3713 if (curop->op_type == OP_GV) {
3714 GV * const gv = cGVOPx_gv(curop);
3716 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3719 else if (curop->op_type == OP_RV2CV)
3721 else if (curop->op_type == OP_RV2SV ||
3722 curop->op_type == OP_RV2AV ||
3723 curop->op_type == OP_RV2HV ||
3724 curop->op_type == OP_RV2GV) {
3725 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3728 else if (curop->op_type == OP_PADSV ||
3729 curop->op_type == OP_PADAV ||
3730 curop->op_type == OP_PADHV ||
3731 curop->op_type == OP_PADANY)
3735 else if (curop->op_type == OP_PUSHRE)
3736 NOOP; /* Okay here, dangerous in newASSIGNOP */
3746 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3748 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3749 prepend_elem(o->op_type, scalar(repl), o);
3752 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3753 pm->op_pmflags |= PMf_MAYBE_CONST;
3755 NewOp(1101, rcop, 1, LOGOP);
3756 rcop->op_type = OP_SUBSTCONT;
3757 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3758 rcop->op_first = scalar(repl);
3759 rcop->op_flags |= OPf_KIDS;
3760 rcop->op_private = 1;
3763 /* establish postfix order */
3764 rcop->op_next = LINKLIST(repl);
3765 repl->op_next = (OP*)rcop;
3767 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3768 assert(!(pm->op_pmflags & PMf_ONCE));
3769 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3778 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3783 PERL_ARGS_ASSERT_NEWSVOP;
3785 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3786 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3787 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3789 NewOp(1101, svop, 1, SVOP);
3790 svop->op_type = (OPCODE)type;
3791 svop->op_ppaddr = PL_ppaddr[type];
3793 svop->op_next = (OP*)svop;
3794 svop->op_flags = (U8)flags;
3795 if (PL_opargs[type] & OA_RETSCALAR)
3797 if (PL_opargs[type] & OA_TARGET)
3798 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3799 return CHECKOP(type, svop);
3804 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3809 PERL_ARGS_ASSERT_NEWPADOP;
3811 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3812 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3813 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3815 NewOp(1101, padop, 1, PADOP);
3816 padop->op_type = (OPCODE)type;
3817 padop->op_ppaddr = PL_ppaddr[type];
3818 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3819 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3820 PAD_SETSV(padop->op_padix, sv);
3823 padop->op_next = (OP*)padop;
3824 padop->op_flags = (U8)flags;
3825 if (PL_opargs[type] & OA_RETSCALAR)
3827 if (PL_opargs[type] & OA_TARGET)
3828 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3829 return CHECKOP(type, padop);
3834 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3838 PERL_ARGS_ASSERT_NEWGVOP;
3842 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3844 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3849 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3854 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3855 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3857 NewOp(1101, pvop, 1, PVOP);
3858 pvop->op_type = (OPCODE)type;
3859 pvop->op_ppaddr = PL_ppaddr[type];
3861 pvop->op_next = (OP*)pvop;
3862 pvop->op_flags = (U8)flags;
3863 if (PL_opargs[type] & OA_RETSCALAR)
3865 if (PL_opargs[type] & OA_TARGET)
3866 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3867 return CHECKOP(type, pvop);
3875 Perl_package(pTHX_ OP *o)
3878 SV *const sv = cSVOPo->op_sv;
3883 PERL_ARGS_ASSERT_PACKAGE;
3885 save_hptr(&PL_curstash);
3886 save_item(PL_curstname);
3888 PL_curstash = gv_stashsv(sv, GV_ADD);
3890 sv_setsv(PL_curstname, sv);
3892 PL_hints |= HINT_BLOCK_SCOPE;
3893 PL_parser->copline = NOLINE;
3894 PL_parser->expect = XSTATE;
3899 if (!PL_madskills) {
3904 pegop = newOP(OP_NULL,0);
3905 op_getmad(o,pegop,'P');
3911 Perl_package_version( pTHX_ OP *v )
3914 U32 savehints = PL_hints;
3915 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3916 PL_hints &= ~HINT_STRICT_VARS;
3917 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3918 PL_hints = savehints;
3927 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3934 OP *pegop = newOP(OP_NULL,0);
3937 PERL_ARGS_ASSERT_UTILIZE;
3939 if (idop->op_type != OP_CONST)
3940 Perl_croak(aTHX_ "Module name must be constant");
3943 op_getmad(idop,pegop,'U');
3948 SV * const vesv = ((SVOP*)version)->op_sv;
3951 op_getmad(version,pegop,'V');
3952 if (!arg && !SvNIOKp(vesv)) {
3959 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3960 Perl_croak(aTHX_ "Version number must be a constant number");
3962 /* Make copy of idop so we don't free it twice */
3963 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3965 /* Fake up a method call to VERSION */
3966 meth = newSVpvs_share("VERSION");
3967 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3968 append_elem(OP_LIST,
3969 prepend_elem(OP_LIST, pack, list(version)),
3970 newSVOP(OP_METHOD_NAMED, 0, meth)));
3974 /* Fake up an import/unimport */
3975 if (arg && arg->op_type == OP_STUB) {
3977 op_getmad(arg,pegop,'S');
3978 imop = arg; /* no import on explicit () */
3980 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3981 imop = NULL; /* use 5.0; */
3983 idop->op_private |= OPpCONST_NOVER;
3989 op_getmad(arg,pegop,'A');
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 import/unimport */
3996 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3997 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3998 append_elem(OP_LIST,
3999 prepend_elem(OP_LIST, pack, list(arg)),
4000 newSVOP(OP_METHOD_NAMED, 0, meth)));
4003 /* Fake up the BEGIN {}, which does its thing immediately. */
4005 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4008 append_elem(OP_LINESEQ,
4009 append_elem(OP_LINESEQ,
4010 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4011 newSTATEOP(0, NULL, veop)),
4012 newSTATEOP(0, NULL, imop) ));
4014 /* The "did you use incorrect case?" warning used to be here.
4015 * The problem is that on case-insensitive filesystems one
4016 * might get false positives for "use" (and "require"):
4017 * "use Strict" or "require CARP" will work. This causes
4018 * portability problems for the script: in case-strict
4019 * filesystems the script will stop working.
4021 * The "incorrect case" warning checked whether "use Foo"
4022 * imported "Foo" to your namespace, but that is wrong, too:
4023 * there is no requirement nor promise in the language that
4024 * a Foo.pm should or would contain anything in package "Foo".
4026 * There is very little Configure-wise that can be done, either:
4027 * the case-sensitivity of the build filesystem of Perl does not
4028 * help in guessing the case-sensitivity of the runtime environment.
4031 PL_hints |= HINT_BLOCK_SCOPE;
4032 PL_parser->copline = NOLINE;
4033 PL_parser->expect = XSTATE;
4034 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4037 if (!PL_madskills) {
4038 /* FIXME - don't allocate pegop if !PL_madskills */
4047 =head1 Embedding Functions
4049 =for apidoc load_module
4051 Loads the module whose name is pointed to by the string part of name.
4052 Note that the actual module name, not its filename, should be given.
4053 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4054 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4055 (or 0 for no flags). ver, if specified, provides version semantics
4056 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4057 arguments can be used to specify arguments to the module's import()
4058 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4059 terminated with a final NULL pointer. Note that this list can only
4060 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4061 Otherwise at least a single NULL pointer to designate the default
4062 import list is required.
4067 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4071 PERL_ARGS_ASSERT_LOAD_MODULE;
4073 va_start(args, ver);
4074 vload_module(flags, name, ver, &args);
4078 #ifdef PERL_IMPLICIT_CONTEXT
4080 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4084 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4085 va_start(args, ver);
4086 vload_module(flags, name, ver, &args);
4092 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4096 OP * const modname = newSVOP(OP_CONST, 0, name);
4098 PERL_ARGS_ASSERT_VLOAD_MODULE;
4100 modname->op_private |= OPpCONST_BARE;
4102 veop = newSVOP(OP_CONST, 0, ver);
4106 if (flags & PERL_LOADMOD_NOIMPORT) {
4107 imop = sawparens(newNULLLIST());
4109 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4110 imop = va_arg(*args, OP*);
4115 sv = va_arg(*args, SV*);
4117 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4118 sv = va_arg(*args, SV*);
4122 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4123 * that it has a PL_parser to play with while doing that, and also
4124 * that it doesn't mess with any existing parser, by creating a tmp
4125 * new parser with lex_start(). This won't actually be used for much,
4126 * since pp_require() will create another parser for the real work. */
4129 SAVEVPTR(PL_curcop);
4130 lex_start(NULL, NULL, FALSE);
4131 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4132 veop, modname, imop);
4137 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4143 PERL_ARGS_ASSERT_DOFILE;
4145 if (!force_builtin) {
4146 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4147 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4148 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4149 gv = gvp ? *gvp : NULL;
4153 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4154 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4155 append_elem(OP_LIST, term,
4156 scalar(newUNOP(OP_RV2CV, 0,
4157 newGVOP(OP_GV, 0, gv))))));
4160 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4166 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4168 return newBINOP(OP_LSLICE, flags,
4169 list(force_list(subscript)),
4170 list(force_list(listval)) );
4174 S_is_list_assignment(pTHX_ register const OP *o)
4182 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4183 o = cUNOPo->op_first;
4185 flags = o->op_flags;
4187 if (type == OP_COND_EXPR) {
4188 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4189 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4194 yyerror("Assignment to both a list and a scalar");
4198 if (type == OP_LIST &&
4199 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4200 o->op_private & OPpLVAL_INTRO)
4203 if (type == OP_LIST || flags & OPf_PARENS ||
4204 type == OP_RV2AV || type == OP_RV2HV ||
4205 type == OP_ASLICE || type == OP_HSLICE)
4208 if (type == OP_PADAV || type == OP_PADHV)
4211 if (type == OP_RV2SV)
4218 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4224 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4225 return newLOGOP(optype, 0,
4226 mod(scalar(left), optype),
4227 newUNOP(OP_SASSIGN, 0, scalar(right)));
4230 return newBINOP(optype, OPf_STACKED,
4231 mod(scalar(left), optype), scalar(right));
4235 if (is_list_assignment(left)) {
4236 static const char no_list_state[] = "Initialization of state variables"
4237 " in list context currently forbidden";
4239 bool maybe_common_vars = TRUE;
4242 /* Grandfathering $[ assignment here. Bletch.*/
4243 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4244 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4245 left = mod(left, OP_AASSIGN);
4248 else if (left->op_type == OP_CONST) {
4250 /* Result of assignment is always 1 (or we'd be dead already) */
4251 return newSVOP(OP_CONST, 0, newSViv(1));
4253 curop = list(force_list(left));
4254 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4255 o->op_private = (U8)(0 | (flags >> 8));
4257 if ((left->op_type == OP_LIST
4258 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4260 OP* lop = ((LISTOP*)left)->op_first;
4261 maybe_common_vars = FALSE;
4263 if (lop->op_type == OP_PADSV ||
4264 lop->op_type == OP_PADAV ||
4265 lop->op_type == OP_PADHV ||
4266 lop->op_type == OP_PADANY) {
4267 if (!(lop->op_private & OPpLVAL_INTRO))
4268 maybe_common_vars = TRUE;
4270 if (lop->op_private & OPpPAD_STATE) {
4271 if (left->op_private & OPpLVAL_INTRO) {
4272 /* Each variable in state($a, $b, $c) = ... */
4275 /* Each state variable in
4276 (state $a, my $b, our $c, $d, undef) = ... */
4278 yyerror(no_list_state);
4280 /* Each my variable in
4281 (state $a, my $b, our $c, $d, undef) = ... */
4283 } else if (lop->op_type == OP_UNDEF ||
4284 lop->op_type == OP_PUSHMARK) {
4285 /* undef may be interesting in
4286 (state $a, undef, state $c) */
4288 /* Other ops in the list. */
4289 maybe_common_vars = TRUE;
4291 lop = lop->op_sibling;
4294 else if ((left->op_private & OPpLVAL_INTRO)
4295 && ( left->op_type == OP_PADSV
4296 || left->op_type == OP_PADAV
4297 || left->op_type == OP_PADHV
4298 || left->op_type == OP_PADANY))
4300 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4301 if (left->op_private & OPpPAD_STATE) {
4302 /* All single variable list context state assignments, hence
4312 yyerror(no_list_state);
4316 /* PL_generation sorcery:
4317 * an assignment like ($a,$b) = ($c,$d) is easier than
4318 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4319 * To detect whether there are common vars, the global var
4320 * PL_generation is incremented for each assign op we compile.
4321 * Then, while compiling the assign op, we run through all the
4322 * variables on both sides of the assignment, setting a spare slot
4323 * in each of them to PL_generation. If any of them already have
4324 * that value, we know we've got commonality. We could use a
4325 * single bit marker, but then we'd have to make 2 passes, first
4326 * to clear the flag, then to test and set it. To find somewhere
4327 * to store these values, evil chicanery is done with SvUVX().
4330 if (maybe_common_vars) {
4333 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4334 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4335 if (curop->op_type == OP_GV) {
4336 GV *gv = cGVOPx_gv(curop);
4338 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4340 GvASSIGN_GENERATION_set(gv, PL_generation);
4342 else if (curop->op_type == OP_PADSV ||
4343 curop->op_type == OP_PADAV ||
4344 curop->op_type == OP_PADHV ||
4345 curop->op_type == OP_PADANY)
4347 if (PAD_COMPNAME_GEN(curop->op_targ)
4348 == (STRLEN)PL_generation)
4350 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4353 else if (curop->op_type == OP_RV2CV)
4355 else if (curop->op_type == OP_RV2SV ||
4356 curop->op_type == OP_RV2AV ||
4357 curop->op_type == OP_RV2HV ||
4358 curop->op_type == OP_RV2GV) {
4359 if (lastop->op_type != OP_GV) /* funny deref? */
4362 else if (curop->op_type == OP_PUSHRE) {
4364 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4365 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4367 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4369 GvASSIGN_GENERATION_set(gv, PL_generation);
4373 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4376 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4378 GvASSIGN_GENERATION_set(gv, PL_generation);
4388 o->op_private |= OPpASSIGN_COMMON;
4391 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4392 OP* tmpop = ((LISTOP*)right)->op_first;
4393 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4394 PMOP * const pm = (PMOP*)tmpop;
4395 if (left->op_type == OP_RV2AV &&
4396 !(left->op_private & OPpLVAL_INTRO) &&
4397 !(o->op_private & OPpASSIGN_COMMON) )
4399 tmpop = ((UNOP*)left)->op_first;
4400 if (tmpop->op_type == OP_GV
4402 && !pm->op_pmreplrootu.op_pmtargetoff
4404 && !pm->op_pmreplrootu.op_pmtargetgv
4408 pm->op_pmreplrootu.op_pmtargetoff
4409 = cPADOPx(tmpop)->op_padix;
4410 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4412 pm->op_pmreplrootu.op_pmtargetgv
4413 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4414 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4416 pm->op_pmflags |= PMf_ONCE;
4417 tmpop = cUNOPo->op_first; /* to list (nulled) */
4418 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4419 tmpop->op_sibling = NULL; /* don't free split */
4420 right->op_next = tmpop->op_next; /* fix starting loc */
4421 op_free(o); /* blow off assign */
4422 right->op_flags &= ~OPf_WANT;
4423 /* "I don't know and I don't care." */
4428 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4429 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4431 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4432 if (SvIOK(sv) && SvIVX(sv) == 0)
4433 sv_setiv(sv, PL_modcount+1);
4441 right = newOP(OP_UNDEF, 0);
4442 if (right->op_type == OP_READLINE) {
4443 right->op_flags |= OPf_STACKED;
4444 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4447 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4448 o = newBINOP(OP_SASSIGN, flags,
4449 scalar(right), mod(scalar(left), OP_SASSIGN) );
4453 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4454 deprecate("assignment to $[");
4456 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4457 o->op_private |= OPpCONST_ARYBASE;
4465 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4468 const U32 seq = intro_my();
4471 NewOp(1101, cop, 1, COP);
4472 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4473 cop->op_type = OP_DBSTATE;
4474 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4477 cop->op_type = OP_NEXTSTATE;
4478 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4480 cop->op_flags = (U8)flags;
4481 CopHINTS_set(cop, PL_hints);
4483 cop->op_private |= NATIVE_HINTS;
4485 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4486 cop->op_next = (OP*)cop;
4489 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4490 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4492 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4493 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4494 if (cop->cop_hints_hash) {
4496 cop->cop_hints_hash->refcounted_he_refcnt++;
4497 HINTS_REFCNT_UNLOCK;
4501 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4503 PL_hints |= HINT_BLOCK_SCOPE;
4504 /* It seems that we need to defer freeing this pointer, as other parts
4505 of the grammar end up wanting to copy it after this op has been
4510 if (PL_parser && PL_parser->copline == NOLINE)
4511 CopLINE_set(cop, CopLINE(PL_curcop));
4513 CopLINE_set(cop, PL_parser->copline);
4515 PL_parser->copline = NOLINE;
4518 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4520 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4522 CopSTASH_set(cop, PL_curstash);
4524 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4525 /* this line can have a breakpoint - store the cop in IV */
4526 AV *av = CopFILEAVx(PL_curcop);
4528 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4529 if (svp && *svp != &PL_sv_undef ) {
4530 (void)SvIOK_on(*svp);
4531 SvIV_set(*svp, PTR2IV(cop));
4536 if (flags & OPf_SPECIAL)
4538 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4543 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4547 PERL_ARGS_ASSERT_NEWLOGOP;
4549 return new_logop(type, flags, &first, &other);
4553 S_search_const(pTHX_ OP *o)
4555 PERL_ARGS_ASSERT_SEARCH_CONST;
4557 switch (o->op_type) {
4561 if (o->op_flags & OPf_KIDS)
4562 return search_const(cUNOPo->op_first);
4569 if (!(o->op_flags & OPf_KIDS))
4571 kid = cLISTOPo->op_first;
4573 switch (kid->op_type) {
4577 kid = kid->op_sibling;
4580 if (kid != cLISTOPo->op_last)
4586 kid = cLISTOPo->op_last;
4588 return search_const(kid);
4596 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4604 int prepend_not = 0;
4606 PERL_ARGS_ASSERT_NEW_LOGOP;
4611 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4612 return newBINOP(type, flags, scalar(first), scalar(other));
4614 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4616 scalarboolean(first);
4617 /* optimize AND and OR ops that have NOTs as children */
4618 if (first->op_type == OP_NOT
4619 && (first->op_flags & OPf_KIDS)
4620 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4621 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4623 if (type == OP_AND || type == OP_OR) {
4629 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4631 prepend_not = 1; /* prepend a NOT op later */
4635 /* search for a constant op that could let us fold the test */
4636 if ((cstop = search_const(first))) {
4637 if (cstop->op_private & OPpCONST_STRICT)
4638 no_bareword_allowed(cstop);
4639 else if ((cstop->op_private & OPpCONST_BARE))
4640 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4641 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4642 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4643 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4645 if (other->op_type == OP_CONST)
4646 other->op_private |= OPpCONST_SHORTCIRCUIT;
4648 OP *newop = newUNOP(OP_NULL, 0, other);
4649 op_getmad(first, newop, '1');
4650 newop->op_targ = type; /* set "was" field */
4654 if (other->op_type == OP_LEAVE)
4655 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4659 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4660 const OP *o2 = other;
4661 if ( ! (o2->op_type == OP_LIST
4662 && (( o2 = cUNOPx(o2)->op_first))
4663 && o2->op_type == OP_PUSHMARK
4664 && (( o2 = o2->op_sibling)) )
4667 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4668 || o2->op_type == OP_PADHV)
4669 && o2->op_private & OPpLVAL_INTRO
4670 && !(o2->op_private & OPpPAD_STATE))
4672 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4673 "Deprecated use of my() in false conditional");
4677 if (first->op_type == OP_CONST)
4678 first->op_private |= OPpCONST_SHORTCIRCUIT;
4680 first = newUNOP(OP_NULL, 0, first);
4681 op_getmad(other, first, '2');
4682 first->op_targ = type; /* set "was" field */
4689 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4690 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4692 const OP * const k1 = ((UNOP*)first)->op_first;
4693 const OP * const k2 = k1->op_sibling;
4695 switch (first->op_type)
4698 if (k2 && k2->op_type == OP_READLINE
4699 && (k2->op_flags & OPf_STACKED)
4700 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4702 warnop = k2->op_type;
4707 if (k1->op_type == OP_READDIR
4708 || k1->op_type == OP_GLOB
4709 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4710 || k1->op_type == OP_EACH)
4712 warnop = ((k1->op_type == OP_NULL)
4713 ? (OPCODE)k1->op_targ : k1->op_type);
4718 const line_t oldline = CopLINE(PL_curcop);
4719 CopLINE_set(PL_curcop, PL_parser->copline);
4720 Perl_warner(aTHX_ packWARN(WARN_MISC),
4721 "Value of %s%s can be \"0\"; test with defined()",
4723 ((warnop == OP_READLINE || warnop == OP_GLOB)
4724 ? " construct" : "() operator"));
4725 CopLINE_set(PL_curcop, oldline);
4732 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4733 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4735 NewOp(1101, logop, 1, LOGOP);
4737 logop->op_type = (OPCODE)type;
4738 logop->op_ppaddr = PL_ppaddr[type];
4739 logop->op_first = first;
4740 logop->op_flags = (U8)(flags | OPf_KIDS);
4741 logop->op_other = LINKLIST(other);
4742 logop->op_private = (U8)(1 | (flags >> 8));
4744 /* establish postfix order */
4745 logop->op_next = LINKLIST(first);
4746 first->op_next = (OP*)logop;
4747 first->op_sibling = other;
4749 CHECKOP(type,logop);
4751 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4758 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4766 PERL_ARGS_ASSERT_NEWCONDOP;
4769 return newLOGOP(OP_AND, 0, first, trueop);
4771 return newLOGOP(OP_OR, 0, first, falseop);
4773 scalarboolean(first);
4774 if ((cstop = search_const(first))) {
4775 /* Left or right arm of the conditional? */
4776 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4777 OP *live = left ? trueop : falseop;
4778 OP *const dead = left ? falseop : trueop;
4779 if (cstop->op_private & OPpCONST_BARE &&
4780 cstop->op_private & OPpCONST_STRICT) {
4781 no_bareword_allowed(cstop);
4784 /* This is all dead code when PERL_MAD is not defined. */
4785 live = newUNOP(OP_NULL, 0, live);
4786 op_getmad(first, live, 'C');
4787 op_getmad(dead, live, left ? 'e' : 't');
4792 if (live->op_type == OP_LEAVE)
4793 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4796 NewOp(1101, logop, 1, LOGOP);
4797 logop->op_type = OP_COND_EXPR;
4798 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4799 logop->op_first = first;
4800 logop->op_flags = (U8)(flags | OPf_KIDS);
4801 logop->op_private = (U8)(1 | (flags >> 8));
4802 logop->op_other = LINKLIST(trueop);
4803 logop->op_next = LINKLIST(falseop);
4805 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4808 /* establish postfix order */
4809 start = LINKLIST(first);
4810 first->op_next = (OP*)logop;
4812 first->op_sibling = trueop;
4813 trueop->op_sibling = falseop;
4814 o = newUNOP(OP_NULL, 0, (OP*)logop);
4816 trueop->op_next = falseop->op_next = o;
4823 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4832 PERL_ARGS_ASSERT_NEWRANGE;
4834 NewOp(1101, range, 1, LOGOP);
4836 range->op_type = OP_RANGE;
4837 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4838 range->op_first = left;
4839 range->op_flags = OPf_KIDS;
4840 leftstart = LINKLIST(left);
4841 range->op_other = LINKLIST(right);
4842 range->op_private = (U8)(1 | (flags >> 8));
4844 left->op_sibling = right;
4846 range->op_next = (OP*)range;
4847 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4848 flop = newUNOP(OP_FLOP, 0, flip);
4849 o = newUNOP(OP_NULL, 0, flop);
4851 range->op_next = leftstart;
4853 left->op_next = flip;
4854 right->op_next = flop;
4856 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4857 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4858 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4859 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4861 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4862 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4865 if (!flip->op_private || !flop->op_private)
4866 linklist(o); /* blow off optimizer unless constant */
4872 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4877 const bool once = block && block->op_flags & OPf_SPECIAL &&
4878 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4880 PERL_UNUSED_ARG(debuggable);
4883 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4884 return block; /* do {} while 0 does once */
4885 if (expr->op_type == OP_READLINE
4886 || expr->op_type == OP_READDIR
4887 || expr->op_type == OP_GLOB
4888 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4889 expr = newUNOP(OP_DEFINED, 0,
4890 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4891 } else if (expr->op_flags & OPf_KIDS) {
4892 const OP * const k1 = ((UNOP*)expr)->op_first;
4893 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4894 switch (expr->op_type) {
4896 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4897 && (k2->op_flags & OPf_STACKED)
4898 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4899 expr = newUNOP(OP_DEFINED, 0, expr);
4903 if (k1 && (k1->op_type == OP_READDIR
4904 || k1->op_type == OP_GLOB
4905 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4906 || k1->op_type == OP_EACH))
4907 expr = newUNOP(OP_DEFINED, 0, expr);
4913 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4914 * op, in listop. This is wrong. [perl #27024] */
4916 block = newOP(OP_NULL, 0);
4917 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4918 o = new_logop(OP_AND, 0, &expr, &listop);
4921 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4923 if (once && o != listop)
4924 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4927 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4929 o->op_flags |= flags;
4931 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4936 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4937 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4946 PERL_UNUSED_ARG(debuggable);
4949 if (expr->op_type == OP_READLINE
4950 || expr->op_type == OP_READDIR
4951 || expr->op_type == OP_GLOB
4952 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4953 expr = newUNOP(OP_DEFINED, 0,
4954 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4955 } else if (expr->op_flags & OPf_KIDS) {
4956 const OP * const k1 = ((UNOP*)expr)->op_first;
4957 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4958 switch (expr->op_type) {
4960 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4961 && (k2->op_flags & OPf_STACKED)
4962 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4963 expr = newUNOP(OP_DEFINED, 0, expr);
4967 if (k1 && (k1->op_type == OP_READDIR
4968 || k1->op_type == OP_GLOB
4969 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4970 || k1->op_type == OP_EACH))
4971 expr = newUNOP(OP_DEFINED, 0, expr);
4978 block = newOP(OP_NULL, 0);
4979 else if (cont || has_my) {
4980 block = scope(block);
4984 next = LINKLIST(cont);
4987 OP * const unstack = newOP(OP_UNSTACK, 0);
4990 cont = append_elem(OP_LINESEQ, cont, unstack);
4994 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4996 redo = LINKLIST(listop);
4999 PL_parser->copline = (line_t)whileline;
5001 o = new_logop(OP_AND, 0, &expr, &listop);
5002 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5003 op_free(expr); /* oops, it's a while (0) */
5005 return NULL; /* listop already freed by new_logop */
5008 ((LISTOP*)listop)->op_last->op_next =
5009 (o == listop ? redo : LINKLIST(o));
5015 NewOp(1101,loop,1,LOOP);
5016 loop->op_type = OP_ENTERLOOP;
5017 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5018 loop->op_private = 0;
5019 loop->op_next = (OP*)loop;
5022 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5024 loop->op_redoop = redo;
5025 loop->op_lastop = o;
5026 o->op_private |= loopflags;
5029 loop->op_nextop = next;
5031 loop->op_nextop = o;
5033 o->op_flags |= flags;
5034 o->op_private |= (flags >> 8);
5039 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
5044 PADOFFSET padoff = 0;
5049 PERL_ARGS_ASSERT_NEWFOROP;
5052 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5053 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5054 sv->op_type = OP_RV2GV;
5055 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5057 /* The op_type check is needed to prevent a possible segfault
5058 * if the loop variable is undeclared and 'strict vars' is in
5059 * effect. This is illegal but is nonetheless parsed, so we
5060 * may reach this point with an OP_CONST where we're expecting
5063 if (cUNOPx(sv)->op_first->op_type == OP_GV
5064 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5065 iterpflags |= OPpITER_DEF;
5067 else if (sv->op_type == OP_PADSV) { /* private variable */
5068 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5069 padoff = sv->op_targ;
5079 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5081 SV *const namesv = PAD_COMPNAME_SV(padoff);
5083 const char *const name = SvPV_const(namesv, len);
5085 if (len == 2 && name[0] == '$' && name[1] == '_')
5086 iterpflags |= OPpITER_DEF;
5090 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5091 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5092 sv = newGVOP(OP_GV, 0, PL_defgv);
5097 iterpflags |= OPpITER_DEF;
5099 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5100 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5101 iterflags |= OPf_STACKED;
5103 else if (expr->op_type == OP_NULL &&
5104 (expr->op_flags & OPf_KIDS) &&
5105 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5107 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5108 * set the STACKED flag to indicate that these values are to be
5109 * treated as min/max values by 'pp_iterinit'.
5111 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5112 LOGOP* const range = (LOGOP*) flip->op_first;
5113 OP* const left = range->op_first;
5114 OP* const right = left->op_sibling;
5117 range->op_flags &= ~OPf_KIDS;
5118 range->op_first = NULL;
5120 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5121 listop->op_first->op_next = range->op_next;
5122 left->op_next = range->op_other;
5123 right->op_next = (OP*)listop;
5124 listop->op_next = listop->op_first;
5127 op_getmad(expr,(OP*)listop,'O');
5131 expr = (OP*)(listop);
5133 iterflags |= OPf_STACKED;
5136 expr = mod(force_list(expr), OP_GREPSTART);
5139 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5140 append_elem(OP_LIST, expr, scalar(sv))));
5141 assert(!loop->op_next);
5142 /* for my $x () sets OPpLVAL_INTRO;
5143 * for our $x () sets OPpOUR_INTRO */
5144 loop->op_private = (U8)iterpflags;
5145 #ifdef PL_OP_SLAB_ALLOC
5148 NewOp(1234,tmp,1,LOOP);
5149 Copy(loop,tmp,1,LISTOP);
5150 S_op_destroy(aTHX_ (OP*)loop);
5154 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5156 loop->op_targ = padoff;
5157 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5159 op_getmad(madsv, (OP*)loop, 'v');
5160 PL_parser->copline = forline;
5161 return newSTATEOP(0, label, wop);
5165 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5170 PERL_ARGS_ASSERT_NEWLOOPEX;
5172 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5174 if (type != OP_GOTO || label->op_type == OP_CONST) {
5175 /* "last()" means "last" */
5176 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5177 o = newOP(type, OPf_SPECIAL);
5179 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5180 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5184 op_getmad(label,o,'L');
5190 /* Check whether it's going to be a goto &function */
5191 if (label->op_type == OP_ENTERSUB
5192 && !(label->op_flags & OPf_STACKED))
5193 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5194 o = newUNOP(type, OPf_STACKED, label);
5196 PL_hints |= HINT_BLOCK_SCOPE;
5200 /* if the condition is a literal array or hash
5201 (or @{ ... } etc), make a reference to it.
5204 S_ref_array_or_hash(pTHX_ OP *cond)
5207 && (cond->op_type == OP_RV2AV
5208 || cond->op_type == OP_PADAV
5209 || cond->op_type == OP_RV2HV
5210 || cond->op_type == OP_PADHV))
5212 return newUNOP(OP_REFGEN,
5213 0, mod(cond, OP_REFGEN));
5219 /* These construct the optree fragments representing given()
5222 entergiven and enterwhen are LOGOPs; the op_other pointer
5223 points up to the associated leave op. We need this so we
5224 can put it in the context and make break/continue work.
5225 (Also, of course, pp_enterwhen will jump straight to
5226 op_other if the match fails.)
5230 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5231 I32 enter_opcode, I32 leave_opcode,
5232 PADOFFSET entertarg)
5238 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5240 NewOp(1101, enterop, 1, LOGOP);
5241 enterop->op_type = (Optype)enter_opcode;
5242 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5243 enterop->op_flags = (U8) OPf_KIDS;
5244 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5245 enterop->op_private = 0;
5247 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5250 enterop->op_first = scalar(cond);
5251 cond->op_sibling = block;
5253 o->op_next = LINKLIST(cond);
5254 cond->op_next = (OP *) enterop;
5257 /* This is a default {} block */
5258 enterop->op_first = block;
5259 enterop->op_flags |= OPf_SPECIAL;
5261 o->op_next = (OP *) enterop;
5264 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5265 entergiven and enterwhen both
5268 enterop->op_next = LINKLIST(block);
5269 block->op_next = enterop->op_other = o;
5274 /* Does this look like a boolean operation? For these purposes
5275 a boolean operation is:
5276 - a subroutine call [*]
5277 - a logical connective
5278 - a comparison operator
5279 - a filetest operator, with the exception of -s -M -A -C
5280 - defined(), exists() or eof()
5281 - /$re/ or $foo =~ /$re/
5283 [*] possibly surprising
5286 S_looks_like_bool(pTHX_ const OP *o)
5290 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5292 switch(o->op_type) {
5295 return looks_like_bool(cLOGOPo->op_first);
5299 looks_like_bool(cLOGOPo->op_first)
5300 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5305 o->op_flags & OPf_KIDS
5306 && looks_like_bool(cUNOPo->op_first));
5310 case OP_NOT: case OP_XOR:
5312 case OP_EQ: case OP_NE: case OP_LT:
5313 case OP_GT: case OP_LE: case OP_GE:
5315 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5316 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5318 case OP_SEQ: case OP_SNE: case OP_SLT:
5319 case OP_SGT: case OP_SLE: case OP_SGE:
5323 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5324 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5325 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5326 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5327 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5328 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5329 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5330 case OP_FTTEXT: case OP_FTBINARY:
5332 case OP_DEFINED: case OP_EXISTS:
5333 case OP_MATCH: case OP_EOF:
5340 /* Detect comparisons that have been optimized away */
5341 if (cSVOPo->op_sv == &PL_sv_yes
5342 || cSVOPo->op_sv == &PL_sv_no)
5355 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5358 PERL_ARGS_ASSERT_NEWGIVENOP;
5359 return newGIVWHENOP(
5360 ref_array_or_hash(cond),
5362 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5366 /* If cond is null, this is a default {} block */
5368 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5370 const bool cond_llb = (!cond || looks_like_bool(cond));
5373 PERL_ARGS_ASSERT_NEWWHENOP;
5378 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5380 scalar(ref_array_or_hash(cond)));
5383 return newGIVWHENOP(
5385 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5386 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5390 =for apidoc cv_undef
5392 Clear out all the active components of a CV. This can happen either
5393 by an explicit C<undef &foo>, or by the reference count going to zero.
5394 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5395 children can still follow the full lexical scope chain.
5401 Perl_cv_undef(pTHX_ CV *cv)
5405 PERL_ARGS_ASSERT_CV_UNDEF;
5407 DEBUG_X(PerlIO_printf(Perl_debug_log,
5408 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5409 PTR2UV(cv), PTR2UV(PL_comppad))
5413 if (CvFILE(cv) && !CvISXSUB(cv)) {
5414 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5415 Safefree(CvFILE(cv));
5420 if (!CvISXSUB(cv) && CvROOT(cv)) {
5421 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5422 Perl_croak(aTHX_ "Can't undef active subroutine");
5425 PAD_SAVE_SETNULLPAD();
5427 op_free(CvROOT(cv));
5432 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5437 /* remove CvOUTSIDE unless this is an undef rather than a free */
5438 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5439 if (!CvWEAKOUTSIDE(cv))
5440 SvREFCNT_dec(CvOUTSIDE(cv));
5441 CvOUTSIDE(cv) = NULL;
5444 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5447 if (CvISXSUB(cv) && CvXSUB(cv)) {
5450 /* delete all flags except WEAKOUTSIDE */
5451 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5455 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5458 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5460 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5461 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5462 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5463 || (p && (len != SvCUR(cv) /* Not the same length. */
5464 || memNE(p, SvPVX_const(cv), len))))
5465 && ckWARN_d(WARN_PROTOTYPE)) {
5466 SV* const msg = sv_newmortal();
5470 gv_efullname3(name = sv_newmortal(), gv, NULL);
5471 sv_setpvs(msg, "Prototype mismatch:");
5473 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5475 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5477 sv_catpvs(msg, ": none");
5478 sv_catpvs(msg, " vs ");
5480 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5482 sv_catpvs(msg, "none");
5483 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5487 static void const_sv_xsub(pTHX_ CV* cv);
5491 =head1 Optree Manipulation Functions
5493 =for apidoc cv_const_sv
5495 If C<cv> is a constant sub eligible for inlining. returns the constant
5496 value returned by the sub. Otherwise, returns NULL.
5498 Constant subs can be created with C<newCONSTSUB> or as described in
5499 L<perlsub/"Constant Functions">.
5504 Perl_cv_const_sv(pTHX_ const CV *const cv)
5506 PERL_UNUSED_CONTEXT;
5509 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5511 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5514 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5515 * Can be called in 3 ways:
5518 * look for a single OP_CONST with attached value: return the value
5520 * cv && CvCLONE(cv) && !CvCONST(cv)
5522 * examine the clone prototype, and if contains only a single
5523 * OP_CONST referencing a pad const, or a single PADSV referencing
5524 * an outer lexical, return a non-zero value to indicate the CV is
5525 * a candidate for "constizing" at clone time
5529 * We have just cloned an anon prototype that was marked as a const
5530 * candidiate. Try to grab the current value, and in the case of
5531 * PADSV, ignore it if it has multiple references. Return the value.
5535 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5546 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5547 o = cLISTOPo->op_first->op_sibling;
5549 for (; o; o = o->op_next) {
5550 const OPCODE type = o->op_type;
5552 if (sv && o->op_next == o)
5554 if (o->op_next != o) {
5555 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5557 if (type == OP_DBSTATE)
5560 if (type == OP_LEAVESUB || type == OP_RETURN)
5564 if (type == OP_CONST && cSVOPo->op_sv)
5566 else if (cv && type == OP_CONST) {
5567 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5571 else if (cv && type == OP_PADSV) {
5572 if (CvCONST(cv)) { /* newly cloned anon */
5573 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5574 /* the candidate should have 1 ref from this pad and 1 ref
5575 * from the parent */
5576 if (!sv || SvREFCNT(sv) != 2)
5583 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5584 sv = &PL_sv_undef; /* an arbitrary non-null value */
5599 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5602 /* This would be the return value, but the return cannot be reached. */
5603 OP* pegop = newOP(OP_NULL, 0);
5606 PERL_UNUSED_ARG(floor);
5616 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5618 NORETURN_FUNCTION_END;
5623 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5625 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5629 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5635 register CV *cv = NULL;
5637 /* If the subroutine has no body, no attributes, and no builtin attributes
5638 then it's just a sub declaration, and we may be able to get away with
5639 storing with a placeholder scalar in the symbol table, rather than a
5640 full GV and CV. If anything is present then it will take a full CV to
5642 const I32 gv_fetch_flags
5643 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5645 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5646 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5650 assert(proto->op_type == OP_CONST);
5651 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5657 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5659 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5660 SV * const sv = sv_newmortal();
5661 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5662 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5663 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5664 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5666 } else if (PL_curstash) {
5667 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5670 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5674 if (!PL_madskills) {
5683 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5684 maximum a prototype before. */
5685 if (SvTYPE(gv) > SVt_NULL) {
5686 if (!SvPOK((const SV *)gv)
5687 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5689 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5691 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5694 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5696 sv_setiv(MUTABLE_SV(gv), -1);
5698 SvREFCNT_dec(PL_compcv);
5699 cv = PL_compcv = NULL;
5703 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5705 if (!block || !ps || *ps || attrs
5706 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5708 || block->op_type == OP_NULL
5713 const_sv = op_const_sv(block, NULL);
5716 const bool exists = CvROOT(cv) || CvXSUB(cv);
5718 /* if the subroutine doesn't exist and wasn't pre-declared
5719 * with a prototype, assume it will be AUTOLOADed,
5720 * skipping the prototype check
5722 if (exists || SvPOK(cv))
5723 cv_ckproto_len(cv, gv, ps, ps_len);
5724 /* already defined (or promised)? */
5725 if (exists || GvASSUMECV(gv)) {
5728 || block->op_type == OP_NULL
5731 if (CvFLAGS(PL_compcv)) {
5732 /* might have had built-in attrs applied */
5733 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
5734 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
5735 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
5737 /* just a "sub foo;" when &foo is already defined */
5738 SAVEFREESV(PL_compcv);
5743 && block->op_type != OP_NULL
5746 if (ckWARN(WARN_REDEFINE)
5748 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5750 const line_t oldline = CopLINE(PL_curcop);
5751 if (PL_parser && PL_parser->copline != NOLINE)
5752 CopLINE_set(PL_curcop, PL_parser->copline);
5753 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5754 CvCONST(cv) ? "Constant subroutine %s redefined"
5755 : "Subroutine %s redefined", name);
5756 CopLINE_set(PL_curcop, oldline);
5759 if (!PL_minus_c) /* keep old one around for madskills */
5762 /* (PL_madskills unset in used file.) */
5770 SvREFCNT_inc_simple_void_NN(const_sv);
5772 assert(!CvROOT(cv) && !CvCONST(cv));
5773 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5774 CvXSUBANY(cv).any_ptr = const_sv;
5775 CvXSUB(cv) = const_sv_xsub;
5781 cv = newCONSTSUB(NULL, name, const_sv);
5783 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5784 (CvGV(cv) && GvSTASH(CvGV(cv)))
5793 SvREFCNT_dec(PL_compcv);
5797 if (cv) { /* must reuse cv if autoloaded */
5798 /* transfer PL_compcv to cv */
5801 && block->op_type != OP_NULL
5804 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
5806 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
5807 if (!CvWEAKOUTSIDE(cv))
5808 SvREFCNT_dec(CvOUTSIDE(cv));
5809 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5810 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5811 CvOUTSIDE(PL_compcv) = 0;
5812 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5813 CvPADLIST(PL_compcv) = 0;
5814 /* inner references to PL_compcv must be fixed up ... */
5815 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5816 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5817 ++PL_sub_generation;
5820 /* Might have had built-in attributes applied -- propagate them. */
5821 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5823 /* ... before we throw it away */
5824 SvREFCNT_dec(PL_compcv);
5832 if (strEQ(name, "import")) {
5833 PL_formfeed = MUTABLE_SV(cv);
5834 /* diag_listed_as: SKIPME */
5835 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
5839 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5844 CvFILE_set_from_cop(cv, PL_curcop);
5845 CvSTASH(cv) = PL_curstash;
5848 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5849 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5850 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5854 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5856 if (PL_parser && PL_parser->error_count) {
5860 const char *s = strrchr(name, ':');
5862 if (strEQ(s, "BEGIN")) {
5863 const char not_safe[] =
5864 "BEGIN not safe after errors--compilation aborted";
5865 if (PL_in_eval & EVAL_KEEPERR)
5866 Perl_croak(aTHX_ not_safe);
5868 /* force display of errors found but not reported */
5869 sv_catpv(ERRSV, not_safe);
5870 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5879 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5880 the debugger could be able to set a breakpoint in, so signal to
5881 pp_entereval that it should not throw away any saved lines at scope
5884 PL_breakable_sub_gen++;
5886 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5887 mod(scalarseq(block), OP_LEAVESUBLV));
5888 block->op_attached = 1;
5891 /* This makes sub {}; work as expected. */
5892 if (block->op_type == OP_STUB) {
5893 OP* const newblock = newSTATEOP(0, NULL, 0);
5895 op_getmad(block,newblock,'B');
5902 block->op_attached = 1;
5903 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5905 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5906 OpREFCNT_set(CvROOT(cv), 1);
5907 CvSTART(cv) = LINKLIST(CvROOT(cv));
5908 CvROOT(cv)->op_next = 0;
5909 CALL_PEEP(CvSTART(cv));
5911 /* now that optimizer has done its work, adjust pad values */
5913 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5916 assert(!CvCONST(cv));
5917 if (ps && !*ps && op_const_sv(block, cv))
5922 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5923 SV * const tmpstr = sv_newmortal();
5924 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5925 GV_ADDMULTI, SVt_PVHV);
5927 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
5930 (long)CopLINE(PL_curcop));
5931 gv_efullname3(tmpstr, gv, NULL);
5932 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5933 SvCUR(tmpstr), sv, 0);
5934 hv = GvHVn(db_postponed);
5935 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5936 CV * const pcv = GvCV(db_postponed);
5942 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5947 if (name && ! (PL_parser && PL_parser->error_count))
5948 process_special_blocks(name, gv, cv);
5953 PL_parser->copline = NOLINE;
5959 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5962 const char *const colon = strrchr(fullname,':');
5963 const char *const name = colon ? colon + 1 : fullname;
5965 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5968 if (strEQ(name, "BEGIN")) {
5969 const I32 oldscope = PL_scopestack_ix;
5971 SAVECOPFILE(&PL_compiling);
5972 SAVECOPLINE(&PL_compiling);
5974 DEBUG_x( dump_sub(gv) );
5975 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5976 GvCV(gv) = 0; /* cv has been hijacked */
5977 call_list(oldscope, PL_beginav);
5979 PL_curcop = &PL_compiling;
5980 CopHINTS_set(&PL_compiling, PL_hints);
5987 if strEQ(name, "END") {
5988 DEBUG_x( dump_sub(gv) );
5989 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5992 } else if (*name == 'U') {
5993 if (strEQ(name, "UNITCHECK")) {
5994 /* It's never too late to run a unitcheck block */
5995 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5999 } else if (*name == 'C') {
6000 if (strEQ(name, "CHECK")) {
6002 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6003 "Too late to run CHECK block");
6004 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6008 } else if (*name == 'I') {
6009 if (strEQ(name, "INIT")) {
6011 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6012 "Too late to run INIT block");
6013 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6019 DEBUG_x( dump_sub(gv) );
6020 GvCV(gv) = 0; /* cv has been hijacked */
6025 =for apidoc newCONSTSUB
6027 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6028 eligible for inlining at compile-time.
6030 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6031 which won't be called if used as a destructor, but will suppress the overhead
6032 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6039 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6044 const char *const file = CopFILE(PL_curcop);
6046 SV *const temp_sv = CopFILESV(PL_curcop);
6047 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6052 if (IN_PERL_RUNTIME) {
6053 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6054 * an op shared between threads. Use a non-shared COP for our
6056 SAVEVPTR(PL_curcop);
6057 PL_curcop = &PL_compiling;
6059 SAVECOPLINE(PL_curcop);
6060 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6063 PL_hints &= ~HINT_BLOCK_SCOPE;
6066 SAVESPTR(PL_curstash);
6067 SAVECOPSTASH(PL_curcop);
6068 PL_curstash = stash;
6069 CopSTASH_set(PL_curcop,stash);
6072 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6073 and so doesn't get free()d. (It's expected to be from the C pre-
6074 processor __FILE__ directive). But we need a dynamically allocated one,
6075 and we need it to get freed. */
6076 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6077 XS_DYNAMIC_FILENAME);
6078 CvXSUBANY(cv).any_ptr = sv;
6083 CopSTASH_free(PL_curcop);
6091 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6092 const char *const filename, const char *const proto,
6095 CV *cv = newXS(name, subaddr, filename);
6097 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6099 if (flags & XS_DYNAMIC_FILENAME) {
6100 /* We need to "make arrangements" (ie cheat) to ensure that the
6101 filename lasts as long as the PVCV we just created, but also doesn't
6103 STRLEN filename_len = strlen(filename);
6104 STRLEN proto_and_file_len = filename_len;
6105 char *proto_and_file;
6109 proto_len = strlen(proto);
6110 proto_and_file_len += proto_len;
6112 Newx(proto_and_file, proto_and_file_len + 1, char);
6113 Copy(proto, proto_and_file, proto_len, char);
6114 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6117 proto_and_file = savepvn(filename, filename_len);
6120 /* This gets free()d. :-) */
6121 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6122 SV_HAS_TRAILING_NUL);
6124 /* This gives us the correct prototype, rather than one with the
6125 file name appended. */
6126 SvCUR_set(cv, proto_len);
6130 CvFILE(cv) = proto_and_file + proto_len;
6132 sv_setpv(MUTABLE_SV(cv), proto);
6138 =for apidoc U||newXS
6140 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6141 static storage, as it is used directly as CvFILE(), without a copy being made.
6147 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6150 GV * const gv = gv_fetchpv(name ? name :
6151 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6152 GV_ADDMULTI, SVt_PVCV);
6155 PERL_ARGS_ASSERT_NEWXS;
6158 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6160 if ((cv = (name ? GvCV(gv) : NULL))) {
6162 /* just a cached method */
6166 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6167 /* already defined (or promised) */
6168 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6169 if (ckWARN(WARN_REDEFINE)) {
6170 GV * const gvcv = CvGV(cv);
6172 HV * const stash = GvSTASH(gvcv);
6174 const char *redefined_name = HvNAME_get(stash);
6175 if ( strEQ(redefined_name,"autouse") ) {
6176 const line_t oldline = CopLINE(PL_curcop);
6177 if (PL_parser && PL_parser->copline != NOLINE)
6178 CopLINE_set(PL_curcop, PL_parser->copline);
6179 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6180 CvCONST(cv) ? "Constant subroutine %s redefined"
6181 : "Subroutine %s redefined"
6183 CopLINE_set(PL_curcop, oldline);
6193 if (cv) /* must reuse cv if autoloaded */
6196 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6200 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6204 (void)gv_fetchfile(filename);
6205 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6206 an external constant string */
6208 CvXSUB(cv) = subaddr;
6211 process_special_blocks(name, gv, cv);
6223 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6228 OP* pegop = newOP(OP_NULL, 0);
6232 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6233 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6236 if ((cv = GvFORM(gv))) {
6237 if (ckWARN(WARN_REDEFINE)) {
6238 const line_t oldline = CopLINE(PL_curcop);
6239 if (PL_parser && PL_parser->copline != NOLINE)
6240 CopLINE_set(PL_curcop, PL_parser->copline);
6242 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6243 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6245 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6246 "Format STDOUT redefined");
6248 CopLINE_set(PL_curcop, oldline);
6255 CvFILE_set_from_cop(cv, PL_curcop);
6258 pad_tidy(padtidy_FORMAT);
6259 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6260 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6261 OpREFCNT_set(CvROOT(cv), 1);
6262 CvSTART(cv) = LINKLIST(CvROOT(cv));
6263 CvROOT(cv)->op_next = 0;
6264 CALL_PEEP(CvSTART(cv));
6266 op_getmad(o,pegop,'n');
6267 op_getmad_weak(block, pegop, 'b');
6272 PL_parser->copline = NOLINE;
6280 Perl_newANONLIST(pTHX_ OP *o)
6282 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6286 Perl_newANONHASH(pTHX_ OP *o)
6288 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6292 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6294 return newANONATTRSUB(floor, proto, NULL, block);
6298 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6300 return newUNOP(OP_REFGEN, 0,
6301 newSVOP(OP_ANONCODE, 0,
6302 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6306 Perl_oopsAV(pTHX_ OP *o)
6310 PERL_ARGS_ASSERT_OOPSAV;
6312 switch (o->op_type) {
6314 o->op_type = OP_PADAV;
6315 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6316 return ref(o, OP_RV2AV);
6319 o->op_type = OP_RV2AV;
6320 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6325 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6332 Perl_oopsHV(pTHX_ OP *o)
6336 PERL_ARGS_ASSERT_OOPSHV;
6338 switch (o->op_type) {
6341 o->op_type = OP_PADHV;
6342 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6343 return ref(o, OP_RV2HV);
6347 o->op_type = OP_RV2HV;
6348 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6353 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6360 Perl_newAVREF(pTHX_ OP *o)
6364 PERL_ARGS_ASSERT_NEWAVREF;
6366 if (o->op_type == OP_PADANY) {
6367 o->op_type = OP_PADAV;
6368 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6371 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6372 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6373 "Using an array as a reference is deprecated");
6375 return newUNOP(OP_RV2AV, 0, scalar(o));
6379 Perl_newGVREF(pTHX_ I32 type, OP *o)
6381 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6382 return newUNOP(OP_NULL, 0, o);
6383 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6387 Perl_newHVREF(pTHX_ OP *o)
6391 PERL_ARGS_ASSERT_NEWHVREF;
6393 if (o->op_type == OP_PADANY) {
6394 o->op_type = OP_PADHV;
6395 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6398 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6399 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6400 "Using a hash as a reference is deprecated");
6402 return newUNOP(OP_RV2HV, 0, scalar(o));
6406 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6408 return newUNOP(OP_RV2CV, flags, scalar(o));
6412 Perl_newSVREF(pTHX_ OP *o)
6416 PERL_ARGS_ASSERT_NEWSVREF;
6418 if (o->op_type == OP_PADANY) {
6419 o->op_type = OP_PADSV;
6420 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6423 return newUNOP(OP_RV2SV, 0, scalar(o));
6426 /* Check routines. See the comments at the top of this file for details
6427 * on when these are called */
6430 Perl_ck_anoncode(pTHX_ OP *o)
6432 PERL_ARGS_ASSERT_CK_ANONCODE;
6434 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6436 cSVOPo->op_sv = NULL;
6441 Perl_ck_bitop(pTHX_ OP *o)
6445 PERL_ARGS_ASSERT_CK_BITOP;
6447 #define OP_IS_NUMCOMPARE(op) \
6448 ((op) == OP_LT || (op) == OP_I_LT || \
6449 (op) == OP_GT || (op) == OP_I_GT || \
6450 (op) == OP_LE || (op) == OP_I_LE || \
6451 (op) == OP_GE || (op) == OP_I_GE || \
6452 (op) == OP_EQ || (op) == OP_I_EQ || \
6453 (op) == OP_NE || (op) == OP_I_NE || \
6454 (op) == OP_NCMP || (op) == OP_I_NCMP)
6455 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6456 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6457 && (o->op_type == OP_BIT_OR
6458 || o->op_type == OP_BIT_AND
6459 || o->op_type == OP_BIT_XOR))
6461 const OP * const left = cBINOPo->op_first;
6462 const OP * const right = left->op_sibling;
6463 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6464 (left->op_flags & OPf_PARENS) == 0) ||
6465 (OP_IS_NUMCOMPARE(right->op_type) &&
6466 (right->op_flags & OPf_PARENS) == 0))
6467 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6468 "Possible precedence problem on bitwise %c operator",
6469 o->op_type == OP_BIT_OR ? '|'
6470 : o->op_type == OP_BIT_AND ? '&' : '^'
6477 Perl_ck_concat(pTHX_ OP *o)
6479 const OP * const kid = cUNOPo->op_first;
6481 PERL_ARGS_ASSERT_CK_CONCAT;
6482 PERL_UNUSED_CONTEXT;
6484 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6485 !(kUNOP->op_first->op_flags & OPf_MOD))
6486 o->op_flags |= OPf_STACKED;
6491 Perl_ck_spair(pTHX_ OP *o)
6495 PERL_ARGS_ASSERT_CK_SPAIR;
6497 if (o->op_flags & OPf_KIDS) {
6500 const OPCODE type = o->op_type;
6501 o = modkids(ck_fun(o), type);
6502 kid = cUNOPo->op_first;
6503 newop = kUNOP->op_first->op_sibling;
6505 const OPCODE type = newop->op_type;
6506 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6507 type == OP_PADAV || type == OP_PADHV ||
6508 type == OP_RV2AV || type == OP_RV2HV)
6512 op_getmad(kUNOP->op_first,newop,'K');
6514 op_free(kUNOP->op_first);
6516 kUNOP->op_first = newop;
6518 o->op_ppaddr = PL_ppaddr[++o->op_type];
6523 Perl_ck_delete(pTHX_ OP *o)
6525 PERL_ARGS_ASSERT_CK_DELETE;
6529 if (o->op_flags & OPf_KIDS) {
6530 OP * const kid = cUNOPo->op_first;
6531 switch (kid->op_type) {
6533 o->op_flags |= OPf_SPECIAL;
6536 o->op_private |= OPpSLICE;
6539 o->op_flags |= OPf_SPECIAL;
6544 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6547 if (kid->op_private & OPpLVAL_INTRO)
6548 o->op_private |= OPpLVAL_INTRO;
6555 Perl_ck_die(pTHX_ OP *o)
6557 PERL_ARGS_ASSERT_CK_DIE;
6560 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6566 Perl_ck_eof(pTHX_ OP *o)
6570 PERL_ARGS_ASSERT_CK_EOF;
6572 if (o->op_flags & OPf_KIDS) {
6573 if (cLISTOPo->op_first->op_type == OP_STUB) {
6575 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6577 op_getmad(o,newop,'O');
6589 Perl_ck_eval(pTHX_ OP *o)
6593 PERL_ARGS_ASSERT_CK_EVAL;
6595 PL_hints |= HINT_BLOCK_SCOPE;
6596 if (o->op_flags & OPf_KIDS) {
6597 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6600 o->op_flags &= ~OPf_KIDS;
6603 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6609 cUNOPo->op_first = 0;
6614 NewOp(1101, enter, 1, LOGOP);
6615 enter->op_type = OP_ENTERTRY;
6616 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6617 enter->op_private = 0;
6619 /* establish postfix order */
6620 enter->op_next = (OP*)enter;
6622 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6623 o->op_type = OP_LEAVETRY;
6624 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6625 enter->op_other = o;
6626 op_getmad(oldo,o,'O');
6640 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6641 op_getmad(oldo,o,'O');
6643 o->op_targ = (PADOFFSET)PL_hints;
6644 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6645 /* Store a copy of %^H that pp_entereval can pick up. */
6646 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6647 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6648 cUNOPo->op_first->op_sibling = hhop;
6649 o->op_private |= OPpEVAL_HAS_HH;
6655 Perl_ck_exit(pTHX_ OP *o)
6657 PERL_ARGS_ASSERT_CK_EXIT;
6660 HV * const table = GvHV(PL_hintgv);
6662 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6663 if (svp && *svp && SvTRUE(*svp))
6664 o->op_private |= OPpEXIT_VMSISH;
6666 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6672 Perl_ck_exec(pTHX_ OP *o)
6674 PERL_ARGS_ASSERT_CK_EXEC;
6676 if (o->op_flags & OPf_STACKED) {
6679 kid = cUNOPo->op_first->op_sibling;
6680 if (kid->op_type == OP_RV2GV)
6689 Perl_ck_exists(pTHX_ OP *o)
6693 PERL_ARGS_ASSERT_CK_EXISTS;
6696 if (o->op_flags & OPf_KIDS) {
6697 OP * const kid = cUNOPo->op_first;
6698 if (kid->op_type == OP_ENTERSUB) {
6699 (void) ref(kid, o->op_type);
6700 if (kid->op_type != OP_RV2CV
6701 && !(PL_parser && PL_parser->error_count))
6702 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6704 o->op_private |= OPpEXISTS_SUB;
6706 else if (kid->op_type == OP_AELEM)
6707 o->op_flags |= OPf_SPECIAL;
6708 else if (kid->op_type != OP_HELEM)
6709 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6717 Perl_ck_rvconst(pTHX_ register OP *o)
6720 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6722 PERL_ARGS_ASSERT_CK_RVCONST;
6724 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6725 if (o->op_type == OP_RV2CV)
6726 o->op_private &= ~1;
6728 if (kid->op_type == OP_CONST) {
6731 SV * const kidsv = kid->op_sv;
6733 /* Is it a constant from cv_const_sv()? */
6734 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6735 SV * const rsv = SvRV(kidsv);
6736 const svtype type = SvTYPE(rsv);
6737 const char *badtype = NULL;
6739 switch (o->op_type) {
6741 if (type > SVt_PVMG)
6742 badtype = "a SCALAR";
6745 if (type != SVt_PVAV)
6746 badtype = "an ARRAY";
6749 if (type != SVt_PVHV)
6753 if (type != SVt_PVCV)
6758 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6761 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6762 const char *badthing;
6763 switch (o->op_type) {
6765 badthing = "a SCALAR";
6768 badthing = "an ARRAY";
6771 badthing = "a HASH";
6779 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6780 SVfARG(kidsv), badthing);
6783 * This is a little tricky. We only want to add the symbol if we
6784 * didn't add it in the lexer. Otherwise we get duplicate strict
6785 * warnings. But if we didn't add it in the lexer, we must at
6786 * least pretend like we wanted to add it even if it existed before,
6787 * or we get possible typo warnings. OPpCONST_ENTERED says
6788 * whether the lexer already added THIS instance of this symbol.
6790 iscv = (o->op_type == OP_RV2CV) * 2;
6792 gv = gv_fetchsv(kidsv,
6793 iscv | !(kid->op_private & OPpCONST_ENTERED),
6796 : o->op_type == OP_RV2SV
6798 : o->op_type == OP_RV2AV
6800 : o->op_type == OP_RV2HV
6803 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6805 kid->op_type = OP_GV;
6806 SvREFCNT_dec(kid->op_sv);
6808 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6809 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6810 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6812 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6814 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6816 kid->op_private = 0;
6817 kid->op_ppaddr = PL_ppaddr[OP_GV];
6824 Perl_ck_ftst(pTHX_ OP *o)
6827 const I32 type = o->op_type;
6829 PERL_ARGS_ASSERT_CK_FTST;
6831 if (o->op_flags & OPf_REF) {
6834 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6835 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6836 const OPCODE kidtype = kid->op_type;
6838 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6839 OP * const newop = newGVOP(type, OPf_REF,
6840 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6842 op_getmad(o,newop,'O');
6848 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6849 o->op_private |= OPpFT_ACCESS;
6850 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6851 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6852 o->op_private |= OPpFT_STACKED;
6860 if (type == OP_FTTTY)
6861 o = newGVOP(type, OPf_REF, PL_stdingv);
6863 o = newUNOP(type, 0, newDEFSVOP());
6864 op_getmad(oldo,o,'O');
6870 Perl_ck_fun(pTHX_ OP *o)
6873 const int type = o->op_type;
6874 register I32 oa = PL_opargs[type] >> OASHIFT;
6876 PERL_ARGS_ASSERT_CK_FUN;
6878 if (o->op_flags & OPf_STACKED) {
6879 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6882 return no_fh_allowed(o);
6885 if (o->op_flags & OPf_KIDS) {
6886 OP **tokid = &cLISTOPo->op_first;
6887 register OP *kid = cLISTOPo->op_first;
6891 if (kid->op_type == OP_PUSHMARK ||
6892 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6894 tokid = &kid->op_sibling;
6895 kid = kid->op_sibling;
6897 if (!kid && PL_opargs[type] & OA_DEFGV)
6898 *tokid = kid = newDEFSVOP();
6902 sibl = kid->op_sibling;
6904 if (!sibl && kid->op_type == OP_STUB) {
6911 /* list seen where single (scalar) arg expected? */
6912 if (numargs == 1 && !(oa >> 4)
6913 && kid->op_type == OP_LIST && type != OP_SCALAR)
6915 return too_many_arguments(o,PL_op_desc[type]);
6928 if ((type == OP_PUSH || type == OP_UNSHIFT)
6929 && !kid->op_sibling)
6930 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6931 "Useless use of %s with no values",
6934 if (kid->op_type == OP_CONST &&
6935 (kid->op_private & OPpCONST_BARE))
6937 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6938 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6939 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6940 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6941 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6943 op_getmad(kid,newop,'K');
6948 kid->op_sibling = sibl;
6951 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6952 bad_type(numargs, "array", PL_op_desc[type], kid);
6956 if (kid->op_type == OP_CONST &&
6957 (kid->op_private & OPpCONST_BARE))
6959 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6960 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6961 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6962 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6963 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6965 op_getmad(kid,newop,'K');
6970 kid->op_sibling = sibl;
6973 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6974 bad_type(numargs, "hash", PL_op_desc[type], kid);
6979 OP * const newop = newUNOP(OP_NULL, 0, kid);
6980 kid->op_sibling = 0;
6982 newop->op_next = newop;
6984 kid->op_sibling = sibl;
6989 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6990 if (kid->op_type == OP_CONST &&
6991 (kid->op_private & OPpCONST_BARE))
6993 OP * const newop = newGVOP(OP_GV, 0,
6994 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6995 if (!(o->op_private & 1) && /* if not unop */
6996 kid == cLISTOPo->op_last)
6997 cLISTOPo->op_last = newop;
6999 op_getmad(kid,newop,'K');
7005 else if (kid->op_type == OP_READLINE) {
7006 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7007 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7010 I32 flags = OPf_SPECIAL;
7014 /* is this op a FH constructor? */
7015 if (is_handle_constructor(o,numargs)) {
7016 const char *name = NULL;
7020 /* Set a flag to tell rv2gv to vivify
7021 * need to "prove" flag does not mean something
7022 * else already - NI-S 1999/05/07
7025 if (kid->op_type == OP_PADSV) {
7027 = PAD_COMPNAME_SV(kid->op_targ);
7028 name = SvPV_const(namesv, len);
7030 else if (kid->op_type == OP_RV2SV
7031 && kUNOP->op_first->op_type == OP_GV)
7033 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7035 len = GvNAMELEN(gv);
7037 else if (kid->op_type == OP_AELEM
7038 || kid->op_type == OP_HELEM)
7041 OP *op = ((BINOP*)kid)->op_first;
7045 const char * const a =
7046 kid->op_type == OP_AELEM ?
7048 if (((op->op_type == OP_RV2AV) ||
7049 (op->op_type == OP_RV2HV)) &&
7050 (firstop = ((UNOP*)op)->op_first) &&
7051 (firstop->op_type == OP_GV)) {
7052 /* packagevar $a[] or $h{} */
7053 GV * const gv = cGVOPx_gv(firstop);
7061 else if (op->op_type == OP_PADAV
7062 || op->op_type == OP_PADHV) {
7063 /* lexicalvar $a[] or $h{} */
7064 const char * const padname =
7065 PAD_COMPNAME_PV(op->op_targ);
7074 name = SvPV_const(tmpstr, len);
7079 name = "__ANONIO__";
7086 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7087 namesv = PAD_SVl(targ);
7088 SvUPGRADE(namesv, SVt_PV);
7090 sv_setpvs(namesv, "$");
7091 sv_catpvn(namesv, name, len);
7094 kid->op_sibling = 0;
7095 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7096 kid->op_targ = targ;
7097 kid->op_private |= priv;
7099 kid->op_sibling = sibl;
7105 mod(scalar(kid), type);
7109 tokid = &kid->op_sibling;
7110 kid = kid->op_sibling;
7113 if (kid && kid->op_type != OP_STUB)
7114 return too_many_arguments(o,OP_DESC(o));
7115 o->op_private |= numargs;
7117 /* FIXME - should the numargs move as for the PERL_MAD case? */
7118 o->op_private |= numargs;
7120 return too_many_arguments(o,OP_DESC(o));
7124 else if (PL_opargs[type] & OA_DEFGV) {
7126 OP *newop = newUNOP(type, 0, newDEFSVOP());
7127 op_getmad(o,newop,'O');
7130 /* Ordering of these two is important to keep f_map.t passing. */
7132 return newUNOP(type, 0, newDEFSVOP());
7137 while (oa & OA_OPTIONAL)
7139 if (oa && oa != OA_LIST)
7140 return too_few_arguments(o,OP_DESC(o));
7146 Perl_ck_glob(pTHX_ OP *o)
7151 PERL_ARGS_ASSERT_CK_GLOB;
7154 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7155 append_elem(OP_GLOB, o, newDEFSVOP());
7157 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7158 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7160 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7163 #if !defined(PERL_EXTERNAL_GLOB)
7164 /* XXX this can be tightened up and made more failsafe. */
7165 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7168 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7169 newSVpvs("File::Glob"), NULL, NULL, NULL);
7170 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7171 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7172 GvCV(gv) = GvCV(glob_gv);
7173 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7174 GvIMPORTED_CV_on(gv);
7177 #endif /* PERL_EXTERNAL_GLOB */
7179 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7180 append_elem(OP_GLOB, o,
7181 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7182 o->op_type = OP_LIST;
7183 o->op_ppaddr = PL_ppaddr[OP_LIST];
7184 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7185 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7186 cLISTOPo->op_first->op_targ = 0;
7187 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7188 append_elem(OP_LIST, o,
7189 scalar(newUNOP(OP_RV2CV, 0,
7190 newGVOP(OP_GV, 0, gv)))));
7191 o = newUNOP(OP_NULL, 0, ck_subr(o));
7192 o->op_targ = OP_GLOB; /* hint at what it used to be */
7195 gv = newGVgen("main");
7197 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7203 Perl_ck_grep(pTHX_ OP *o)
7208 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7211 PERL_ARGS_ASSERT_CK_GREP;
7213 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7214 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7216 if (o->op_flags & OPf_STACKED) {
7219 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7220 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7221 return no_fh_allowed(o);
7222 for (k = kid; k; k = k->op_next) {
7225 NewOp(1101, gwop, 1, LOGOP);
7226 kid->op_next = (OP*)gwop;
7227 o->op_flags &= ~OPf_STACKED;
7229 kid = cLISTOPo->op_first->op_sibling;
7230 if (type == OP_MAPWHILE)
7235 if (PL_parser && PL_parser->error_count)
7237 kid = cLISTOPo->op_first->op_sibling;
7238 if (kid->op_type != OP_NULL)
7239 Perl_croak(aTHX_ "panic: ck_grep");
7240 kid = kUNOP->op_first;
7243 NewOp(1101, gwop, 1, LOGOP);
7244 gwop->op_type = type;
7245 gwop->op_ppaddr = PL_ppaddr[type];
7246 gwop->op_first = listkids(o);
7247 gwop->op_flags |= OPf_KIDS;
7248 gwop->op_other = LINKLIST(kid);
7249 kid->op_next = (OP*)gwop;
7250 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7251 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7252 o->op_private = gwop->op_private = 0;
7253 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7256 o->op_private = gwop->op_private = OPpGREP_LEX;
7257 gwop->op_targ = o->op_targ = offset;
7260 kid = cLISTOPo->op_first->op_sibling;
7261 if (!kid || !kid->op_sibling)
7262 return too_few_arguments(o,OP_DESC(o));
7263 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7264 mod(kid, OP_GREPSTART);
7270 Perl_ck_index(pTHX_ OP *o)
7272 PERL_ARGS_ASSERT_CK_INDEX;
7274 if (o->op_flags & OPf_KIDS) {
7275 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7277 kid = kid->op_sibling; /* get past "big" */
7278 if (kid && kid->op_type == OP_CONST)
7279 fbm_compile(((SVOP*)kid)->op_sv, 0);
7285 Perl_ck_lfun(pTHX_ OP *o)
7287 const OPCODE type = o->op_type;
7289 PERL_ARGS_ASSERT_CK_LFUN;
7291 return modkids(ck_fun(o), type);
7295 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7297 PERL_ARGS_ASSERT_CK_DEFINED;
7299 if ((o->op_flags & OPf_KIDS)) {
7300 switch (cUNOPo->op_first->op_type) {
7302 /* This is needed for
7303 if (defined %stash::)
7304 to work. Do not break Tk.
7306 break; /* Globals via GV can be undef */
7308 case OP_AASSIGN: /* Is this a good idea? */
7309 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7310 "defined(@array) is deprecated");
7311 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7312 "\t(Maybe you should just omit the defined()?)\n");
7316 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7317 "defined(%%hash) is deprecated");
7318 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7319 "\t(Maybe you should just omit the defined()?)\n");
7330 Perl_ck_readline(pTHX_ OP *o)
7332 PERL_ARGS_ASSERT_CK_READLINE;
7334 if (!(o->op_flags & OPf_KIDS)) {
7336 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7338 op_getmad(o,newop,'O');
7348 Perl_ck_rfun(pTHX_ OP *o)
7350 const OPCODE type = o->op_type;
7352 PERL_ARGS_ASSERT_CK_RFUN;
7354 return refkids(ck_fun(o), type);
7358 Perl_ck_listiob(pTHX_ OP *o)
7362 PERL_ARGS_ASSERT_CK_LISTIOB;
7364 kid = cLISTOPo->op_first;
7367 kid = cLISTOPo->op_first;
7369 if (kid->op_type == OP_PUSHMARK)
7370 kid = kid->op_sibling;
7371 if (kid && o->op_flags & OPf_STACKED)
7372 kid = kid->op_sibling;
7373 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7374 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7375 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7376 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7377 cLISTOPo->op_first->op_sibling = kid;
7378 cLISTOPo->op_last = kid;
7379 kid = kid->op_sibling;
7384 append_elem(o->op_type, o, newDEFSVOP());
7390 Perl_ck_smartmatch(pTHX_ OP *o)
7393 if (0 == (o->op_flags & OPf_SPECIAL)) {
7394 OP *first = cBINOPo->op_first;
7395 OP *second = first->op_sibling;
7397 /* Implicitly take a reference to an array or hash */
7398 first->op_sibling = NULL;
7399 first = cBINOPo->op_first = ref_array_or_hash(first);
7400 second = first->op_sibling = ref_array_or_hash(second);
7402 /* Implicitly take a reference to a regular expression */
7403 if (first->op_type == OP_MATCH) {
7404 first->op_type = OP_QR;
7405 first->op_ppaddr = PL_ppaddr[OP_QR];
7407 if (second->op_type == OP_MATCH) {
7408 second->op_type = OP_QR;
7409 second->op_ppaddr = PL_ppaddr[OP_QR];
7418 Perl_ck_sassign(pTHX_ OP *o)
7421 OP * const kid = cLISTOPo->op_first;
7423 PERL_ARGS_ASSERT_CK_SASSIGN;
7425 /* has a disposable target? */
7426 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7427 && !(kid->op_flags & OPf_STACKED)
7428 /* Cannot steal the second time! */
7429 && !(kid->op_private & OPpTARGET_MY)
7430 /* Keep the full thing for madskills */
7434 OP * const kkid = kid->op_sibling;
7436 /* Can just relocate the target. */
7437 if (kkid && kkid->op_type == OP_PADSV
7438 && !(kkid->op_private & OPpLVAL_INTRO))
7440 kid->op_targ = kkid->op_targ;
7442 /* Now we do not need PADSV and SASSIGN. */
7443 kid->op_sibling = o->op_sibling; /* NULL */
7444 cLISTOPo->op_first = NULL;
7447 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7451 if (kid->op_sibling) {
7452 OP *kkid = kid->op_sibling;
7453 if (kkid->op_type == OP_PADSV
7454 && (kkid->op_private & OPpLVAL_INTRO)
7455 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7456 const PADOFFSET target = kkid->op_targ;
7457 OP *const other = newOP(OP_PADSV,
7459 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7460 OP *const first = newOP(OP_NULL, 0);
7461 OP *const nullop = newCONDOP(0, first, o, other);
7462 OP *const condop = first->op_next;
7463 /* hijacking PADSTALE for uninitialized state variables */
7464 SvPADSTALE_on(PAD_SVl(target));
7466 condop->op_type = OP_ONCE;
7467 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7468 condop->op_targ = target;
7469 other->op_targ = target;
7471 /* Because we change the type of the op here, we will skip the
7472 assinment binop->op_last = binop->op_first->op_sibling; at the
7473 end of Perl_newBINOP(). So need to do it here. */
7474 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7483 Perl_ck_match(pTHX_ OP *o)
7487 PERL_ARGS_ASSERT_CK_MATCH;
7489 if (o->op_type != OP_QR && PL_compcv) {
7490 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7491 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7492 o->op_targ = offset;
7493 o->op_private |= OPpTARGET_MY;
7496 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7497 o->op_private |= OPpRUNTIME;
7502 Perl_ck_method(pTHX_ OP *o)
7504 OP * const kid = cUNOPo->op_first;
7506 PERL_ARGS_ASSERT_CK_METHOD;
7508 if (kid->op_type == OP_CONST) {
7509 SV* sv = kSVOP->op_sv;
7510 const char * const method = SvPVX_const(sv);
7511 if (!(strchr(method, ':') || strchr(method, '\''))) {
7513 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7514 sv = newSVpvn_share(method, SvCUR(sv), 0);
7517 kSVOP->op_sv = NULL;
7519 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7521 op_getmad(o,cmop,'O');
7532 Perl_ck_null(pTHX_ OP *o)
7534 PERL_ARGS_ASSERT_CK_NULL;
7535 PERL_UNUSED_CONTEXT;
7540 Perl_ck_open(pTHX_ OP *o)
7543 HV * const table = GvHV(PL_hintgv);
7545 PERL_ARGS_ASSERT_CK_OPEN;
7548 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7551 const char *d = SvPV_const(*svp, len);
7552 const I32 mode = mode_from_discipline(d, len);
7553 if (mode & O_BINARY)
7554 o->op_private |= OPpOPEN_IN_RAW;
7555 else if (mode & O_TEXT)
7556 o->op_private |= OPpOPEN_IN_CRLF;
7559 svp = hv_fetchs(table, "open_OUT", FALSE);
7562 const char *d = SvPV_const(*svp, len);
7563 const I32 mode = mode_from_discipline(d, len);
7564 if (mode & O_BINARY)
7565 o->op_private |= OPpOPEN_OUT_RAW;
7566 else if (mode & O_TEXT)
7567 o->op_private |= OPpOPEN_OUT_CRLF;
7570 if (o->op_type == OP_BACKTICK) {
7571 if (!(o->op_flags & OPf_KIDS)) {
7572 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7574 op_getmad(o,newop,'O');
7583 /* In case of three-arg dup open remove strictness
7584 * from the last arg if it is a bareword. */
7585 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7586 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7590 if ((last->op_type == OP_CONST) && /* The bareword. */
7591 (last->op_private & OPpCONST_BARE) &&
7592 (last->op_private & OPpCONST_STRICT) &&
7593 (oa = first->op_sibling) && /* The fh. */
7594 (oa = oa->op_sibling) && /* The mode. */
7595 (oa->op_type == OP_CONST) &&
7596 SvPOK(((SVOP*)oa)->op_sv) &&
7597 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7598 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7599 (last == oa->op_sibling)) /* The bareword. */
7600 last->op_private &= ~OPpCONST_STRICT;
7606 Perl_ck_repeat(pTHX_ OP *o)
7608 PERL_ARGS_ASSERT_CK_REPEAT;
7610 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7611 o->op_private |= OPpREPEAT_DOLIST;
7612 cBINOPo->op_first = force_list(cBINOPo->op_first);
7620 Perl_ck_require(pTHX_ OP *o)
7625 PERL_ARGS_ASSERT_CK_REQUIRE;
7627 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7628 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7630 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7631 SV * const sv = kid->op_sv;
7632 U32 was_readonly = SvREADONLY(sv);
7639 sv_force_normal_flags(sv, 0);
7640 assert(!SvREADONLY(sv));
7650 for (; s < end; s++) {
7651 if (*s == ':' && s[1] == ':') {
7653 Move(s+2, s+1, end - s - 1, char);
7658 sv_catpvs(sv, ".pm");
7659 SvFLAGS(sv) |= was_readonly;
7663 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7664 /* handle override, if any */
7665 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7666 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7667 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7668 gv = gvp ? *gvp : NULL;
7672 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7673 OP * const kid = cUNOPo->op_first;
7676 cUNOPo->op_first = 0;
7680 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7681 append_elem(OP_LIST, kid,
7682 scalar(newUNOP(OP_RV2CV, 0,
7685 op_getmad(o,newop,'O');
7689 return scalar(ck_fun(o));
7693 Perl_ck_return(pTHX_ OP *o)
7698 PERL_ARGS_ASSERT_CK_RETURN;
7700 kid = cLISTOPo->op_first->op_sibling;
7701 if (CvLVALUE(PL_compcv)) {
7702 for (; kid; kid = kid->op_sibling)
7703 mod(kid, OP_LEAVESUBLV);
7705 for (; kid; kid = kid->op_sibling)
7706 if ((kid->op_type == OP_NULL)
7707 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7708 /* This is a do block */
7709 OP *op = kUNOP->op_first;
7710 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7711 op = cUNOPx(op)->op_first;
7712 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7713 /* Force the use of the caller's context */
7714 op->op_flags |= OPf_SPECIAL;
7723 Perl_ck_select(pTHX_ OP *o)
7728 PERL_ARGS_ASSERT_CK_SELECT;
7730 if (o->op_flags & OPf_KIDS) {
7731 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7732 if (kid && kid->op_sibling) {
7733 o->op_type = OP_SSELECT;
7734 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7736 return fold_constants(o);
7740 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7741 if (kid && kid->op_type == OP_RV2GV)
7742 kid->op_private &= ~HINT_STRICT_REFS;
7747 Perl_ck_shift(pTHX_ OP *o)
7750 const I32 type = o->op_type;
7752 PERL_ARGS_ASSERT_CK_SHIFT;
7754 if (!(o->op_flags & OPf_KIDS)) {
7757 if (!CvUNIQUE(PL_compcv)) {
7758 o->op_flags |= OPf_SPECIAL;
7762 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
7764 OP * const oldo = o;
7765 o = newUNOP(type, 0, scalar(argop));
7766 op_getmad(oldo,o,'O');
7770 return newUNOP(type, 0, scalar(argop));
7773 return scalar(modkids(ck_fun(o), type));
7777 Perl_ck_sort(pTHX_ OP *o)
7782 PERL_ARGS_ASSERT_CK_SORT;
7784 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7785 HV * const hinthv = GvHV(PL_hintgv);
7787 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7789 const I32 sorthints = (I32)SvIV(*svp);
7790 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7791 o->op_private |= OPpSORT_QSORT;
7792 if ((sorthints & HINT_SORT_STABLE) != 0)
7793 o->op_private |= OPpSORT_STABLE;
7798 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7800 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7801 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7803 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7805 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7807 if (kid->op_type == OP_SCOPE) {
7811 else if (kid->op_type == OP_LEAVE) {
7812 if (o->op_type == OP_SORT) {
7813 op_null(kid); /* wipe out leave */
7816 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7817 if (k->op_next == kid)
7819 /* don't descend into loops */
7820 else if (k->op_type == OP_ENTERLOOP
7821 || k->op_type == OP_ENTERITER)
7823 k = cLOOPx(k)->op_lastop;
7828 kid->op_next = 0; /* just disconnect the leave */
7829 k = kLISTOP->op_first;
7834 if (o->op_type == OP_SORT) {
7835 /* provide scalar context for comparison function/block */
7841 o->op_flags |= OPf_SPECIAL;
7843 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7846 firstkid = firstkid->op_sibling;
7849 /* provide list context for arguments */
7850 if (o->op_type == OP_SORT)
7857 S_simplify_sort(pTHX_ OP *o)
7860 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7866 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7868 if (!(o->op_flags & OPf_STACKED))
7870 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7871 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7872 kid = kUNOP->op_first; /* get past null */
7873 if (kid->op_type != OP_SCOPE)
7875 kid = kLISTOP->op_last; /* get past scope */
7876 switch(kid->op_type) {
7884 k = kid; /* remember this node*/
7885 if (kBINOP->op_first->op_type != OP_RV2SV)
7887 kid = kBINOP->op_first; /* get past cmp */
7888 if (kUNOP->op_first->op_type != OP_GV)
7890 kid = kUNOP->op_first; /* get past rv2sv */
7892 if (GvSTASH(gv) != PL_curstash)
7894 gvname = GvNAME(gv);
7895 if (*gvname == 'a' && gvname[1] == '\0')
7897 else if (*gvname == 'b' && gvname[1] == '\0')
7902 kid = k; /* back to cmp */
7903 if (kBINOP->op_last->op_type != OP_RV2SV)
7905 kid = kBINOP->op_last; /* down to 2nd arg */
7906 if (kUNOP->op_first->op_type != OP_GV)
7908 kid = kUNOP->op_first; /* get past rv2sv */
7910 if (GvSTASH(gv) != PL_curstash)
7912 gvname = GvNAME(gv);
7914 ? !(*gvname == 'a' && gvname[1] == '\0')
7915 : !(*gvname == 'b' && gvname[1] == '\0'))
7917 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7919 o->op_private |= OPpSORT_DESCEND;
7920 if (k->op_type == OP_NCMP)
7921 o->op_private |= OPpSORT_NUMERIC;
7922 if (k->op_type == OP_I_NCMP)
7923 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7924 kid = cLISTOPo->op_first->op_sibling;
7925 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7927 op_getmad(kid,o,'S'); /* then delete it */
7929 op_free(kid); /* then delete it */
7934 Perl_ck_split(pTHX_ OP *o)
7939 PERL_ARGS_ASSERT_CK_SPLIT;
7941 if (o->op_flags & OPf_STACKED)
7942 return no_fh_allowed(o);
7944 kid = cLISTOPo->op_first;
7945 if (kid->op_type != OP_NULL)
7946 Perl_croak(aTHX_ "panic: ck_split");
7947 kid = kid->op_sibling;
7948 op_free(cLISTOPo->op_first);
7949 cLISTOPo->op_first = kid;
7951 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7952 cLISTOPo->op_last = kid; /* There was only one element previously */
7955 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7956 OP * const sibl = kid->op_sibling;
7957 kid->op_sibling = 0;
7958 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7959 if (cLISTOPo->op_first == cLISTOPo->op_last)
7960 cLISTOPo->op_last = kid;
7961 cLISTOPo->op_first = kid;
7962 kid->op_sibling = sibl;
7965 kid->op_type = OP_PUSHRE;
7966 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7968 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7969 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7970 "Use of /g modifier is meaningless in split");
7973 if (!kid->op_sibling)
7974 append_elem(OP_SPLIT, o, newDEFSVOP());
7976 kid = kid->op_sibling;
7979 if (!kid->op_sibling)
7980 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7981 assert(kid->op_sibling);
7983 kid = kid->op_sibling;
7986 if (kid->op_sibling)
7987 return too_many_arguments(o,OP_DESC(o));
7993 Perl_ck_join(pTHX_ OP *o)
7995 const OP * const kid = cLISTOPo->op_first->op_sibling;
7997 PERL_ARGS_ASSERT_CK_JOIN;
7999 if (kid && kid->op_type == OP_MATCH) {
8000 if (ckWARN(WARN_SYNTAX)) {
8001 const REGEXP *re = PM_GETRE(kPMOP);
8002 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8003 const STRLEN len = re ? RX_PRELEN(re) : 6;
8004 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8005 "/%.*s/ should probably be written as \"%.*s\"",
8006 (int)len, pmstr, (int)len, pmstr);
8013 Perl_ck_subr(pTHX_ OP *o)
8016 OP *prev = ((cUNOPo->op_first->op_sibling)
8017 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
8018 OP *o2 = prev->op_sibling;
8020 const char *proto = NULL;
8021 const char *proto_end = NULL;
8026 I32 contextclass = 0;
8027 const char *e = NULL;
8030 PERL_ARGS_ASSERT_CK_SUBR;
8032 o->op_private |= OPpENTERSUB_HASTARG;
8033 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
8034 if (cvop->op_type == OP_RV2CV) {
8035 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
8036 op_null(cvop); /* disable rv2cv */
8037 if (!(o->op_private & OPpENTERSUB_AMPER)) {
8038 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
8040 switch (tmpop->op_type) {
8042 gv = cGVOPx_gv(tmpop);
8045 tmpop->op_private |= OPpEARLY_CV;
8048 SV *sv = cSVOPx_sv(tmpop);
8049 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8053 if (cv && SvPOK(cv)) {
8055 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8056 proto = SvPV(MUTABLE_SV(cv), len);
8057 proto_end = proto + len;
8061 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8062 if (o2->op_type == OP_CONST)
8063 o2->op_private &= ~OPpCONST_STRICT;
8064 else if (o2->op_type == OP_LIST) {
8065 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8066 if (sib && sib->op_type == OP_CONST)
8067 sib->op_private &= ~OPpCONST_STRICT;
8070 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8071 if (PERLDB_SUB && PL_curstash != PL_debstash)
8072 o->op_private |= OPpENTERSUB_DB;
8073 while (o2 != cvop) {
8075 if (PL_madskills && o2->op_type == OP_STUB) {
8076 o2 = o2->op_sibling;
8079 if (PL_madskills && o2->op_type == OP_NULL)
8080 o3 = ((UNOP*)o2)->op_first;
8084 if (proto >= proto_end)
8085 return too_many_arguments(o, gv_ename(namegv));
8093 /* _ must be at the end */
8094 if (proto[1] && proto[1] != ';')
8109 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8111 arg == 1 ? "block or sub {}" : "sub {}",
8112 gv_ename(namegv), o3);
8115 /* '*' allows any scalar type, including bareword */
8118 if (o3->op_type == OP_RV2GV)
8119 goto wrapref; /* autoconvert GLOB -> GLOBref */
8120 else if (o3->op_type == OP_CONST)
8121 o3->op_private &= ~OPpCONST_STRICT;
8122 else if (o3->op_type == OP_ENTERSUB) {
8123 /* accidental subroutine, revert to bareword */
8124 OP *gvop = ((UNOP*)o3)->op_first;
8125 if (gvop && gvop->op_type == OP_NULL) {
8126 gvop = ((UNOP*)gvop)->op_first;
8128 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8131 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8132 (gvop = ((UNOP*)gvop)->op_first) &&
8133 gvop->op_type == OP_GV)
8135 GV * const gv = cGVOPx_gv(gvop);
8136 OP * const sibling = o2->op_sibling;
8137 SV * const n = newSVpvs("");
8139 OP * const oldo2 = o2;
8143 gv_fullname4(n, gv, "", FALSE);
8144 o2 = newSVOP(OP_CONST, 0, n);
8145 op_getmad(oldo2,o2,'O');
8146 prev->op_sibling = o2;
8147 o2->op_sibling = sibling;
8163 if (contextclass++ == 0) {
8164 e = strchr(proto, ']');
8165 if (!e || e == proto)
8174 const char *p = proto;
8175 const char *const end = proto;
8177 while (*--p != '[') {}
8178 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8180 gv_ename(namegv), o3);
8185 if (o3->op_type == OP_RV2GV)
8188 bad_type(arg, "symbol", gv_ename(namegv), o3);
8191 if (o3->op_type == OP_ENTERSUB)
8194 bad_type(arg, "subroutine entry", gv_ename(namegv),
8198 if (o3->op_type == OP_RV2SV ||
8199 o3->op_type == OP_PADSV ||
8200 o3->op_type == OP_HELEM ||
8201 o3->op_type == OP_AELEM)
8204 bad_type(arg, "scalar", gv_ename(namegv), o3);
8207 if (o3->op_type == OP_RV2AV ||
8208 o3->op_type == OP_PADAV)
8211 bad_type(arg, "array", gv_ename(namegv), o3);
8214 if (o3->op_type == OP_RV2HV ||
8215 o3->op_type == OP_PADHV)
8218 bad_type(arg, "hash", gv_ename(namegv), o3);
8223 OP* const sib = kid->op_sibling;
8224 kid->op_sibling = 0;
8225 o2 = newUNOP(OP_REFGEN, 0, kid);
8226 o2->op_sibling = sib;
8227 prev->op_sibling = o2;
8229 if (contextclass && e) {
8244 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8245 gv_ename(namegv), SVfARG(cv));
8250 mod(o2, OP_ENTERSUB);
8252 o2 = o2->op_sibling;
8254 if (o2 == cvop && proto && *proto == '_') {
8255 /* generate an access to $_ */
8257 o2->op_sibling = prev->op_sibling;
8258 prev->op_sibling = o2; /* instead of cvop */
8260 if (proto && !optional && proto_end > proto &&
8261 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8262 return too_few_arguments(o, gv_ename(namegv));
8265 OP * const oldo = o;
8269 o=newSVOP(OP_CONST, 0, newSViv(0));
8270 op_getmad(oldo,o,'O');
8276 Perl_ck_svconst(pTHX_ OP *o)
8278 PERL_ARGS_ASSERT_CK_SVCONST;
8279 PERL_UNUSED_CONTEXT;
8280 SvREADONLY_on(cSVOPo->op_sv);
8285 Perl_ck_chdir(pTHX_ OP *o)
8287 if (o->op_flags & OPf_KIDS) {
8288 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8290 if (kid && kid->op_type == OP_CONST &&
8291 (kid->op_private & OPpCONST_BARE))
8293 o->op_flags |= OPf_SPECIAL;
8294 kid->op_private &= ~OPpCONST_STRICT;
8301 Perl_ck_trunc(pTHX_ OP *o)
8303 PERL_ARGS_ASSERT_CK_TRUNC;
8305 if (o->op_flags & OPf_KIDS) {
8306 SVOP *kid = (SVOP*)cUNOPo->op_first;
8308 if (kid->op_type == OP_NULL)
8309 kid = (SVOP*)kid->op_sibling;
8310 if (kid && kid->op_type == OP_CONST &&
8311 (kid->op_private & OPpCONST_BARE))
8313 o->op_flags |= OPf_SPECIAL;
8314 kid->op_private &= ~OPpCONST_STRICT;
8321 Perl_ck_unpack(pTHX_ OP *o)
8323 OP *kid = cLISTOPo->op_first;
8325 PERL_ARGS_ASSERT_CK_UNPACK;
8327 if (kid->op_sibling) {
8328 kid = kid->op_sibling;
8329 if (!kid->op_sibling)
8330 kid->op_sibling = newDEFSVOP();
8336 Perl_ck_substr(pTHX_ OP *o)
8338 PERL_ARGS_ASSERT_CK_SUBSTR;
8341 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8342 OP *kid = cLISTOPo->op_first;
8344 if (kid->op_type == OP_NULL)
8345 kid = kid->op_sibling;
8347 kid->op_flags |= OPf_MOD;
8354 Perl_ck_each(pTHX_ OP *o)
8357 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8359 PERL_ARGS_ASSERT_CK_EACH;
8362 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8363 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8364 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8365 o->op_type = new_type;
8366 o->op_ppaddr = PL_ppaddr[new_type];
8368 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8369 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8371 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8378 /* caller is supposed to assign the return to the
8379 container of the rep_op var */
8381 S_opt_scalarhv(pTHX_ OP *rep_op) {
8385 PERL_ARGS_ASSERT_OPT_SCALARHV;
8387 NewOp(1101, unop, 1, UNOP);
8388 unop->op_type = (OPCODE)OP_BOOLKEYS;
8389 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8390 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8391 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8392 unop->op_first = rep_op;
8393 unop->op_next = rep_op->op_next;
8394 rep_op->op_next = (OP*)unop;
8395 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8396 unop->op_sibling = rep_op->op_sibling;
8397 rep_op->op_sibling = NULL;
8398 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8399 if (rep_op->op_type == OP_PADHV) {
8400 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8401 rep_op->op_flags |= OPf_WANT_LIST;
8406 /* Checks if o acts as an in-place operator on an array. oright points to the
8407 * beginning of the right-hand side. Returns the left-hand side of the
8408 * assignment if o acts in-place, or NULL otherwise. */
8411 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8415 PERL_ARGS_ASSERT_IS_INPLACE_AV;
8418 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8419 || oright->op_next != o
8420 || (oright->op_private & OPpLVAL_INTRO)
8424 /* o2 follows the chain of op_nexts through the LHS of the
8425 * assign (if any) to the aassign op itself */
8427 if (!o2 || o2->op_type != OP_NULL)
8430 if (!o2 || o2->op_type != OP_PUSHMARK)
8433 if (o2 && o2->op_type == OP_GV)
8436 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8437 || (o2->op_private & OPpLVAL_INTRO)
8442 if (!o2 || o2->op_type != OP_NULL)
8445 if (!o2 || o2->op_type != OP_AASSIGN
8446 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8449 /* check that the sort is the first arg on RHS of assign */
8451 o2 = cUNOPx(o2)->op_first;
8452 if (!o2 || o2->op_type != OP_NULL)
8454 o2 = cUNOPx(o2)->op_first;
8455 if (!o2 || o2->op_type != OP_PUSHMARK)
8457 if (o2->op_sibling != o)
8460 /* check the array is the same on both sides */
8461 if (oleft->op_type == OP_RV2AV) {
8462 if (oright->op_type != OP_RV2AV
8463 || !cUNOPx(oright)->op_first
8464 || cUNOPx(oright)->op_first->op_type != OP_GV
8465 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8466 cGVOPx_gv(cUNOPx(oright)->op_first)
8470 else if (oright->op_type != OP_PADAV
8471 || oright->op_targ != oleft->op_targ
8478 /* A peephole optimizer. We visit the ops in the order they're to execute.
8479 * See the comments at the top of this file for more details about when
8480 * peep() is called */
8483 Perl_peep(pTHX_ register OP *o)
8486 register OP* oldop = NULL;
8488 if (!o || o->op_opt)
8492 SAVEVPTR(PL_curcop);
8493 for (; o; o = o->op_next) {
8496 /* By default, this op has now been optimised. A couple of cases below
8497 clear this again. */
8500 switch (o->op_type) {
8503 PL_curcop = ((COP*)o); /* for warnings */
8507 if (cSVOPo->op_private & OPpCONST_STRICT)
8508 no_bareword_allowed(o);
8511 case OP_METHOD_NAMED:
8512 /* Relocate sv to the pad for thread safety.
8513 * Despite being a "constant", the SV is written to,
8514 * for reference counts, sv_upgrade() etc. */
8516 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8517 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8518 /* If op_sv is already a PADTMP then it is being used by
8519 * some pad, so make a copy. */
8520 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8521 SvREADONLY_on(PAD_SVl(ix));
8522 SvREFCNT_dec(cSVOPo->op_sv);
8524 else if (o->op_type != OP_METHOD_NAMED
8525 && cSVOPo->op_sv == &PL_sv_undef) {
8526 /* PL_sv_undef is hack - it's unsafe to store it in the
8527 AV that is the pad, because av_fetch treats values of
8528 PL_sv_undef as a "free" AV entry and will merrily
8529 replace them with a new SV, causing pad_alloc to think
8530 that this pad slot is free. (When, clearly, it is not)
8532 SvOK_off(PAD_SVl(ix));
8533 SvPADTMP_on(PAD_SVl(ix));
8534 SvREADONLY_on(PAD_SVl(ix));
8537 SvREFCNT_dec(PAD_SVl(ix));
8538 SvPADTMP_on(cSVOPo->op_sv);
8539 PAD_SETSV(ix, cSVOPo->op_sv);
8540 /* XXX I don't know how this isn't readonly already. */
8541 SvREADONLY_on(PAD_SVl(ix));
8543 cSVOPo->op_sv = NULL;
8550 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8551 if (o->op_next->op_private & OPpTARGET_MY) {
8552 if (o->op_flags & OPf_STACKED) /* chained concats */
8553 break; /* ignore_optimization */
8555 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8556 o->op_targ = o->op_next->op_targ;
8557 o->op_next->op_targ = 0;
8558 o->op_private |= OPpTARGET_MY;
8561 op_null(o->op_next);
8565 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8566 break; /* Scalar stub must produce undef. List stub is noop */
8570 if (o->op_targ == OP_NEXTSTATE
8571 || o->op_targ == OP_DBSTATE)
8573 PL_curcop = ((COP*)o);
8575 /* XXX: We avoid setting op_seq here to prevent later calls
8576 to peep() from mistakenly concluding that optimisation
8577 has already occurred. This doesn't fix the real problem,
8578 though (See 20010220.007). AMS 20010719 */
8579 /* op_seq functionality is now replaced by op_opt */
8586 if (oldop && o->op_next) {
8587 oldop->op_next = o->op_next;
8595 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8596 OP* const pop = (o->op_type == OP_PADAV) ?
8597 o->op_next : o->op_next->op_next;
8599 if (pop && pop->op_type == OP_CONST &&
8600 ((PL_op = pop->op_next)) &&
8601 pop->op_next->op_type == OP_AELEM &&
8602 !(pop->op_next->op_private &
8603 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8604 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8609 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8610 no_bareword_allowed(pop);
8611 if (o->op_type == OP_GV)
8612 op_null(o->op_next);
8613 op_null(pop->op_next);
8615 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8616 o->op_next = pop->op_next->op_next;
8617 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8618 o->op_private = (U8)i;
8619 if (o->op_type == OP_GV) {
8624 o->op_flags |= OPf_SPECIAL;
8625 o->op_type = OP_AELEMFAST;
8630 if (o->op_next->op_type == OP_RV2SV) {
8631 if (!(o->op_next->op_private & OPpDEREF)) {
8632 op_null(o->op_next);
8633 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8635 o->op_next = o->op_next->op_next;
8636 o->op_type = OP_GVSV;
8637 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8640 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8641 GV * const gv = cGVOPo_gv;
8642 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8643 /* XXX could check prototype here instead of just carping */
8644 SV * const sv = sv_newmortal();
8645 gv_efullname3(sv, gv, NULL);
8646 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8647 "%"SVf"() called too early to check prototype",
8651 else if (o->op_next->op_type == OP_READLINE
8652 && o->op_next->op_next->op_type == OP_CONCAT
8653 && (o->op_next->op_next->op_flags & OPf_STACKED))
8655 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8656 o->op_type = OP_RCATLINE;
8657 o->op_flags |= OPf_STACKED;
8658 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8659 op_null(o->op_next->op_next);
8660 op_null(o->op_next);
8670 fop = cUNOP->op_first;
8678 fop = cLOGOP->op_first;
8679 sop = fop->op_sibling;
8680 while (cLOGOP->op_other->op_type == OP_NULL)
8681 cLOGOP->op_other = cLOGOP->op_other->op_next;
8682 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8686 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8688 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8693 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
8694 while (nop && nop->op_next) {
8695 switch (nop->op_next->op_type) {
8700 lop = nop = nop->op_next;
8711 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
8712 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8713 cLOGOP->op_first = opt_scalarhv(fop);
8714 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8715 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8731 while (cLOGOP->op_other->op_type == OP_NULL)
8732 cLOGOP->op_other = cLOGOP->op_other->op_next;
8733 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8738 while (cLOOP->op_redoop->op_type == OP_NULL)
8739 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8740 peep(cLOOP->op_redoop);
8741 while (cLOOP->op_nextop->op_type == OP_NULL)
8742 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8743 peep(cLOOP->op_nextop);
8744 while (cLOOP->op_lastop->op_type == OP_NULL)
8745 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8746 peep(cLOOP->op_lastop);
8750 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8751 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8752 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8753 cPMOP->op_pmstashstartu.op_pmreplstart
8754 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8755 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8759 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8760 && ckWARN(WARN_SYNTAX))
8762 if (o->op_next->op_sibling) {
8763 const OPCODE type = o->op_next->op_sibling->op_type;
8764 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8765 const line_t oldline = CopLINE(PL_curcop);
8766 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8767 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8768 "Statement unlikely to be reached");
8769 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8770 "\t(Maybe you meant system() when you said exec()?)\n");
8771 CopLINE_set(PL_curcop, oldline);
8782 const char *key = NULL;
8785 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8788 /* Make the CONST have a shared SV */
8789 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8790 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8791 key = SvPV_const(sv, keylen);
8792 lexname = newSVpvn_share(key,
8793 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8799 if ((o->op_private & (OPpLVAL_INTRO)))
8802 rop = (UNOP*)((BINOP*)o)->op_first;
8803 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8805 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8806 if (!SvPAD_TYPED(lexname))
8808 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8809 if (!fields || !GvHV(*fields))
8811 key = SvPV_const(*svp, keylen);
8812 if (!hv_fetch(GvHV(*fields), key,
8813 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8815 Perl_croak(aTHX_ "No such class field \"%s\" "
8816 "in variable %s of type %s",
8817 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8830 SVOP *first_key_op, *key_op;
8832 if ((o->op_private & (OPpLVAL_INTRO))
8833 /* I bet there's always a pushmark... */
8834 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8835 /* hmmm, no optimization if list contains only one key. */
8837 rop = (UNOP*)((LISTOP*)o)->op_last;
8838 if (rop->op_type != OP_RV2HV)
8840 if (rop->op_first->op_type == OP_PADSV)
8841 /* @$hash{qw(keys here)} */
8842 rop = (UNOP*)rop->op_first;
8844 /* @{$hash}{qw(keys here)} */
8845 if (rop->op_first->op_type == OP_SCOPE
8846 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8848 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8854 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8855 if (!SvPAD_TYPED(lexname))
8857 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8858 if (!fields || !GvHV(*fields))
8860 /* Again guessing that the pushmark can be jumped over.... */
8861 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8862 ->op_first->op_sibling;
8863 for (key_op = first_key_op; key_op;
8864 key_op = (SVOP*)key_op->op_sibling) {
8865 if (key_op->op_type != OP_CONST)
8867 svp = cSVOPx_svp(key_op);
8868 key = SvPV_const(*svp, keylen);
8869 if (!hv_fetch(GvHV(*fields), key,
8870 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8872 Perl_croak(aTHX_ "No such class field \"%s\" "
8873 "in variable %s of type %s",
8874 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8883 && ( oldop->op_type == OP_AELEM
8884 || oldop->op_type == OP_PADSV
8885 || oldop->op_type == OP_RV2SV
8886 || oldop->op_type == OP_RV2GV
8887 || oldop->op_type == OP_HELEM
8889 && (oldop->op_private & OPpDEREF)
8891 o->op_private |= OPpDEREFed;
8895 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8899 /* check that RHS of sort is a single plain array */
8900 OP *oright = cUNOPo->op_first;
8901 if (!oright || oright->op_type != OP_PUSHMARK)
8904 /* reverse sort ... can be optimised. */
8905 if (!cUNOPo->op_sibling) {
8906 /* Nothing follows us on the list. */
8907 OP * const reverse = o->op_next;
8909 if (reverse->op_type == OP_REVERSE &&
8910 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8911 OP * const pushmark = cUNOPx(reverse)->op_first;
8912 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8913 && (cUNOPx(pushmark)->op_sibling == o)) {
8914 /* reverse -> pushmark -> sort */
8915 o->op_private |= OPpSORT_REVERSE;
8917 pushmark->op_next = oright->op_next;
8923 /* make @a = sort @a act in-place */
8925 oright = cUNOPx(oright)->op_sibling;
8928 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8929 oright = cUNOPx(oright)->op_sibling;
8932 oleft = is_inplace_av(o, oright);
8936 /* transfer MODishness etc from LHS arg to RHS arg */
8937 oright->op_flags = oleft->op_flags;
8938 o->op_private |= OPpSORT_INPLACE;
8940 /* excise push->gv->rv2av->null->aassign */
8941 o2 = o->op_next->op_next;
8942 op_null(o2); /* PUSHMARK */
8944 if (o2->op_type == OP_GV) {
8945 op_null(o2); /* GV */
8948 op_null(o2); /* RV2AV or PADAV */
8949 o2 = o2->op_next->op_next;
8950 op_null(o2); /* AASSIGN */
8952 o->op_next = o2->op_next;
8958 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8961 LISTOP *enter, *exlist;
8963 /* @a = reverse @a */
8964 if ((oright = cLISTOPo->op_first)
8965 && (oright->op_type == OP_PUSHMARK)
8966 && (oright = oright->op_sibling)
8967 && (oleft = is_inplace_av(o, oright))) {
8970 /* transfer MODishness etc from LHS arg to RHS arg */
8971 oright->op_flags = oleft->op_flags;
8972 o->op_private |= OPpREVERSE_INPLACE;
8974 /* excise push->gv->rv2av->null->aassign */
8975 o2 = o->op_next->op_next;
8976 op_null(o2); /* PUSHMARK */
8978 if (o2->op_type == OP_GV) {
8979 op_null(o2); /* GV */
8982 op_null(o2); /* RV2AV or PADAV */
8983 o2 = o2->op_next->op_next;
8984 op_null(o2); /* AASSIGN */
8986 o->op_next = o2->op_next;
8990 enter = (LISTOP *) o->op_next;
8993 if (enter->op_type == OP_NULL) {
8994 enter = (LISTOP *) enter->op_next;
8998 /* for $a (...) will have OP_GV then OP_RV2GV here.
8999 for (...) just has an OP_GV. */
9000 if (enter->op_type == OP_GV) {
9001 gvop = (OP *) enter;
9002 enter = (LISTOP *) enter->op_next;
9005 if (enter->op_type == OP_RV2GV) {
9006 enter = (LISTOP *) enter->op_next;
9012 if (enter->op_type != OP_ENTERITER)
9015 iter = enter->op_next;
9016 if (!iter || iter->op_type != OP_ITER)
9019 expushmark = enter->op_first;
9020 if (!expushmark || expushmark->op_type != OP_NULL
9021 || expushmark->op_targ != OP_PUSHMARK)
9024 exlist = (LISTOP *) expushmark->op_sibling;
9025 if (!exlist || exlist->op_type != OP_NULL
9026 || exlist->op_targ != OP_LIST)
9029 if (exlist->op_last != o) {
9030 /* Mmm. Was expecting to point back to this op. */
9033 theirmark = exlist->op_first;
9034 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9037 if (theirmark->op_sibling != o) {
9038 /* There's something between the mark and the reverse, eg
9039 for (1, reverse (...))
9044 ourmark = ((LISTOP *)o)->op_first;
9045 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9048 ourlast = ((LISTOP *)o)->op_last;
9049 if (!ourlast || ourlast->op_next != o)
9052 rv2av = ourmark->op_sibling;
9053 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9054 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9055 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9056 /* We're just reversing a single array. */
9057 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9058 enter->op_flags |= OPf_STACKED;
9061 /* We don't have control over who points to theirmark, so sacrifice
9063 theirmark->op_next = ourmark->op_next;
9064 theirmark->op_flags = ourmark->op_flags;
9065 ourlast->op_next = gvop ? gvop : (OP *) enter;
9068 enter->op_private |= OPpITER_REVERSED;
9069 iter->op_private |= OPpITER_REVERSED;
9076 UNOP *refgen, *rv2cv;
9079 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9082 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9085 rv2gv = ((BINOP *)o)->op_last;
9086 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9089 refgen = (UNOP *)((BINOP *)o)->op_first;
9091 if (!refgen || refgen->op_type != OP_REFGEN)
9094 exlist = (LISTOP *)refgen->op_first;
9095 if (!exlist || exlist->op_type != OP_NULL
9096 || exlist->op_targ != OP_LIST)
9099 if (exlist->op_first->op_type != OP_PUSHMARK)
9102 rv2cv = (UNOP*)exlist->op_last;
9104 if (rv2cv->op_type != OP_RV2CV)
9107 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9108 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9109 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9111 o->op_private |= OPpASSIGN_CV_TO_GV;
9112 rv2gv->op_private |= OPpDONT_INIT_GV;
9113 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9121 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9122 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9132 Perl_custom_op_name(pTHX_ const OP* o)
9135 const IV index = PTR2IV(o->op_ppaddr);
9139 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9141 if (!PL_custom_op_names) /* This probably shouldn't happen */
9142 return (char *)PL_op_name[OP_CUSTOM];
9144 keysv = sv_2mortal(newSViv(index));
9146 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9148 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9150 return SvPV_nolen(HeVAL(he));
9154 Perl_custom_op_desc(pTHX_ const OP* o)
9157 const IV index = PTR2IV(o->op_ppaddr);
9161 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9163 if (!PL_custom_op_descs)
9164 return (char *)PL_op_desc[OP_CUSTOM];
9166 keysv = sv_2mortal(newSViv(index));
9168 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9170 return (char *)PL_op_desc[OP_CUSTOM];
9172 return SvPV_nolen(HeVAL(he));
9177 /* Efficient sub that returns a constant scalar value. */
9179 const_sv_xsub(pTHX_ CV* cv)
9183 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9187 /* diag_listed_as: SKIPME */
9188 Perl_croak(aTHX_ "usage: %s::%s()",
9189 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9202 * c-indentation-style: bsd
9204 * indent-tabs-mode: t
9207 * ex: set ts=8 sts=4 sw=4 noet: