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;
565 case OP_ENTEREVAL: /* Was holding hints. */
569 if (!(o->op_flags & OPf_REF)
570 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
576 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
577 /* not an OP_PADAV replacement */
578 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
583 /* It's possible during global destruction that the GV is freed
584 before the optree. Whilst the SvREFCNT_inc is happy to bump from
585 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
586 will trigger an assertion failure, because the entry to sv_clear
587 checks that the scalar is not already freed. A check of for
588 !SvIS_FREED(gv) turns out to be invalid, because during global
589 destruction the reference count can be forced down to zero
590 (with SVf_BREAK set). In which case raising to 1 and then
591 dropping to 0 triggers cleanup before it should happen. I
592 *think* that this might actually be a general, systematic,
593 weakness of the whole idea of SVf_BREAK, in that code *is*
594 allowed to raise and lower references during global destruction,
595 so any *valid* code that happens to do this during global
596 destruction might well trigger premature cleanup. */
597 bool still_valid = gv && SvREFCNT(gv);
600 SvREFCNT_inc_simple_void(gv);
602 if (cPADOPo->op_padix > 0) {
603 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
604 * may still exist on the pad */
605 pad_swipe(cPADOPo->op_padix, TRUE);
606 cPADOPo->op_padix = 0;
609 SvREFCNT_dec(cSVOPo->op_sv);
610 cSVOPo->op_sv = NULL;
613 int try_downgrade = SvREFCNT(gv) == 2;
616 gv_try_downgrade(gv);
620 case OP_METHOD_NAMED:
623 SvREFCNT_dec(cSVOPo->op_sv);
624 cSVOPo->op_sv = NULL;
627 Even if op_clear does a pad_free for the target of the op,
628 pad_free doesn't actually remove the sv that exists in the pad;
629 instead it lives on. This results in that it could be reused as
630 a target later on when the pad was reallocated.
633 pad_swipe(o->op_targ,1);
642 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
646 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
648 if (cPADOPo->op_padix > 0) {
649 pad_swipe(cPADOPo->op_padix, TRUE);
650 cPADOPo->op_padix = 0;
653 SvREFCNT_dec(cSVOPo->op_sv);
654 cSVOPo->op_sv = NULL;
658 PerlMemShared_free(cPVOPo->op_pv);
659 cPVOPo->op_pv = NULL;
663 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
667 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
668 /* No GvIN_PAD_off here, because other references may still
669 * exist on the pad */
670 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
673 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
679 forget_pmop(cPMOPo, 1);
680 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
681 /* we use the same protection as the "SAFE" version of the PM_ macros
682 * here since sv_clean_all might release some PMOPs
683 * after PL_regex_padav has been cleared
684 * and the clearing of PL_regex_padav needs to
685 * happen before sv_clean_all
688 if(PL_regex_pad) { /* We could be in destruction */
689 const IV offset = (cPMOPo)->op_pmoffset;
690 ReREFCNT_dec(PM_GETRE(cPMOPo));
691 PL_regex_pad[offset] = &PL_sv_undef;
692 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
696 ReREFCNT_dec(PM_GETRE(cPMOPo));
697 PM_SETRE(cPMOPo, NULL);
703 if (o->op_targ > 0) {
704 pad_free(o->op_targ);
710 S_cop_free(pTHX_ COP* cop)
712 PERL_ARGS_ASSERT_COP_FREE;
716 if (! specialWARN(cop->cop_warnings))
717 PerlMemShared_free(cop->cop_warnings);
718 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
722 S_forget_pmop(pTHX_ PMOP *const o
728 HV * const pmstash = PmopSTASH(o);
730 PERL_ARGS_ASSERT_FORGET_PMOP;
732 if (pmstash && !SvIS_FREED(pmstash)) {
733 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
735 PMOP **const array = (PMOP**) mg->mg_ptr;
736 U32 count = mg->mg_len / sizeof(PMOP**);
741 /* Found it. Move the entry at the end to overwrite it. */
742 array[i] = array[--count];
743 mg->mg_len = count * sizeof(PMOP**);
744 /* Could realloc smaller at this point always, but probably
745 not worth it. Probably worth free()ing if we're the
748 Safefree(mg->mg_ptr);
765 S_find_and_forget_pmops(pTHX_ OP *o)
767 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
769 if (o->op_flags & OPf_KIDS) {
770 OP *kid = cUNOPo->op_first;
772 switch (kid->op_type) {
777 forget_pmop((PMOP*)kid, 0);
779 find_and_forget_pmops(kid);
780 kid = kid->op_sibling;
786 Perl_op_null(pTHX_ OP *o)
790 PERL_ARGS_ASSERT_OP_NULL;
792 if (o->op_type == OP_NULL)
796 o->op_targ = o->op_type;
797 o->op_type = OP_NULL;
798 o->op_ppaddr = PL_ppaddr[OP_NULL];
802 Perl_op_refcnt_lock(pTHX)
810 Perl_op_refcnt_unlock(pTHX)
817 /* Contextualizers */
819 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
822 S_linklist(pTHX_ OP *o)
826 PERL_ARGS_ASSERT_LINKLIST;
831 /* establish postfix order */
832 first = cUNOPo->op_first;
835 o->op_next = LINKLIST(first);
838 if (kid->op_sibling) {
839 kid->op_next = LINKLIST(kid->op_sibling);
840 kid = kid->op_sibling;
854 S_scalarkids(pTHX_ OP *o)
856 if (o && o->op_flags & OPf_KIDS) {
858 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
865 S_scalarboolean(pTHX_ OP *o)
869 PERL_ARGS_ASSERT_SCALARBOOLEAN;
871 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
872 if (ckWARN(WARN_SYNTAX)) {
873 const line_t oldline = CopLINE(PL_curcop);
875 if (PL_parser && PL_parser->copline != NOLINE)
876 CopLINE_set(PL_curcop, PL_parser->copline);
877 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
878 CopLINE_set(PL_curcop, oldline);
885 Perl_scalar(pTHX_ OP *o)
890 /* assumes no premature commitment */
891 if (!o || (PL_parser && PL_parser->error_count)
892 || (o->op_flags & OPf_WANT)
893 || o->op_type == OP_RETURN)
898 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
900 switch (o->op_type) {
902 scalar(cBINOPo->op_first);
907 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
917 if (o->op_flags & OPf_KIDS) {
918 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
924 kid = cLISTOPo->op_first;
926 while ((kid = kid->op_sibling)) {
932 PL_curcop = &PL_compiling;
937 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
943 PL_curcop = &PL_compiling;
946 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
953 Perl_scalarvoid(pTHX_ OP *o)
957 const char* useless = NULL;
961 PERL_ARGS_ASSERT_SCALARVOID;
963 /* trailing mad null ops don't count as "there" for void processing */
965 o->op_type != OP_NULL &&
967 o->op_sibling->op_type == OP_NULL)
970 for (sib = o->op_sibling;
971 sib && sib->op_type == OP_NULL;
972 sib = sib->op_sibling) ;
978 if (o->op_type == OP_NEXTSTATE
979 || o->op_type == OP_DBSTATE
980 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
981 || o->op_targ == OP_DBSTATE)))
982 PL_curcop = (COP*)o; /* for warning below */
984 /* assumes no premature commitment */
985 want = o->op_flags & OPf_WANT;
986 if ((want && want != OPf_WANT_SCALAR)
987 || (PL_parser && PL_parser->error_count)
988 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE)
993 if ((o->op_private & OPpTARGET_MY)
994 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
996 return scalar(o); /* As if inside SASSIGN */
999 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1001 switch (o->op_type) {
1003 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1007 if (o->op_flags & OPf_STACKED)
1011 if (o->op_private == 4)
1054 case OP_GETSOCKNAME:
1055 case OP_GETPEERNAME:
1060 case OP_GETPRIORITY:
1084 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1085 /* Otherwise it's "Useless use of grep iterator" */
1086 useless = OP_DESC(o);
1090 kid = cUNOPo->op_first;
1091 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1092 kid->op_type != OP_TRANS) {
1095 useless = "negative pattern binding (!~)";
1102 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1103 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1104 useless = "a variable";
1109 if (cSVOPo->op_private & OPpCONST_STRICT)
1110 no_bareword_allowed(o);
1112 if (ckWARN(WARN_VOID)) {
1114 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1115 "a constant (%"SVf")", sv));
1116 useless = SvPV_nolen(msv);
1119 useless = "a constant (undef)";
1120 if (o->op_private & OPpCONST_ARYBASE)
1122 /* don't warn on optimised away booleans, eg
1123 * use constant Foo, 5; Foo || print; */
1124 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1126 /* the constants 0 and 1 are permitted as they are
1127 conventionally used as dummies in constructs like
1128 1 while some_condition_with_side_effects; */
1129 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1131 else if (SvPOK(sv)) {
1132 /* perl4's way of mixing documentation and code
1133 (before the invention of POD) was based on a
1134 trick to mix nroff and perl code. The trick was
1135 built upon these three nroff macros being used in
1136 void context. The pink camel has the details in
1137 the script wrapman near page 319. */
1138 const char * const maybe_macro = SvPVX_const(sv);
1139 if (strnEQ(maybe_macro, "di", 2) ||
1140 strnEQ(maybe_macro, "ds", 2) ||
1141 strnEQ(maybe_macro, "ig", 2))
1146 op_null(o); /* don't execute or even remember it */
1150 o->op_type = OP_PREINC; /* pre-increment is faster */
1151 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1155 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1156 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1160 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1161 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1165 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1166 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1171 kid = cLOGOPo->op_first;
1172 if (kid->op_type == OP_NOT
1173 && (kid->op_flags & OPf_KIDS)
1175 if (o->op_type == OP_AND) {
1177 o->op_ppaddr = PL_ppaddr[OP_OR];
1179 o->op_type = OP_AND;
1180 o->op_ppaddr = PL_ppaddr[OP_AND];
1189 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1194 if (o->op_flags & OPf_STACKED)
1201 if (!(o->op_flags & OPf_KIDS))
1212 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1222 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1227 S_listkids(pTHX_ OP *o)
1229 if (o && o->op_flags & OPf_KIDS) {
1231 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1238 Perl_list(pTHX_ OP *o)
1243 /* assumes no premature commitment */
1244 if (!o || (o->op_flags & OPf_WANT)
1245 || (PL_parser && PL_parser->error_count)
1246 || o->op_type == OP_RETURN)
1251 if ((o->op_private & OPpTARGET_MY)
1252 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1254 return o; /* As if inside SASSIGN */
1257 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1259 switch (o->op_type) {
1262 list(cBINOPo->op_first);
1267 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1275 if (!(o->op_flags & OPf_KIDS))
1277 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1278 list(cBINOPo->op_first);
1279 return gen_constant_list(o);
1286 kid = cLISTOPo->op_first;
1288 while ((kid = kid->op_sibling)) {
1289 if (kid->op_sibling)
1294 PL_curcop = &PL_compiling;
1298 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1299 if (kid->op_sibling)
1304 PL_curcop = &PL_compiling;
1311 S_scalarseq(pTHX_ OP *o)
1315 const OPCODE type = o->op_type;
1317 if (type == OP_LINESEQ || type == OP_SCOPE ||
1318 type == OP_LEAVE || type == OP_LEAVETRY)
1321 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1322 if (kid->op_sibling) {
1326 PL_curcop = &PL_compiling;
1328 o->op_flags &= ~OPf_PARENS;
1329 if (PL_hints & HINT_BLOCK_SCOPE)
1330 o->op_flags |= OPf_PARENS;
1333 o = newOP(OP_STUB, 0);
1338 S_modkids(pTHX_ OP *o, I32 type)
1340 if (o && o->op_flags & OPf_KIDS) {
1342 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1348 /* Propagate lvalue ("modifiable") context to an op and its children.
1349 * 'type' represents the context type, roughly based on the type of op that
1350 * would do the modifying, although local() is represented by OP_NULL.
1351 * It's responsible for detecting things that can't be modified, flag
1352 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1353 * might have to vivify a reference in $x), and so on.
1355 * For example, "$a+1 = 2" would cause mod() to be called with o being
1356 * OP_ADD and type being OP_SASSIGN, and would output an error.
1360 Perl_mod(pTHX_ OP *o, I32 type)
1364 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1367 if (!o || (PL_parser && PL_parser->error_count))
1370 if ((o->op_private & OPpTARGET_MY)
1371 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1376 switch (o->op_type) {
1382 if (!(o->op_private & OPpCONST_ARYBASE))
1385 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1386 CopARYBASE_set(&PL_compiling,
1387 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1391 SAVECOPARYBASE(&PL_compiling);
1392 CopARYBASE_set(&PL_compiling, 0);
1394 else if (type == OP_REFGEN)
1397 Perl_croak(aTHX_ "That use of $[ is unsupported");
1400 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1404 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1405 !(o->op_flags & OPf_STACKED)) {
1406 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1407 /* The default is to set op_private to the number of children,
1408 which for a UNOP such as RV2CV is always 1. And w're using
1409 the bit for a flag in RV2CV, so we need it clear. */
1410 o->op_private &= ~1;
1411 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1412 assert(cUNOPo->op_first->op_type == OP_NULL);
1413 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1416 else if (o->op_private & OPpENTERSUB_NOMOD)
1418 else { /* lvalue subroutine call */
1419 o->op_private |= OPpLVAL_INTRO;
1420 PL_modcount = RETURN_UNLIMITED_NUMBER;
1421 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1422 /* Backward compatibility mode: */
1423 o->op_private |= OPpENTERSUB_INARGS;
1426 else { /* Compile-time error message: */
1427 OP *kid = cUNOPo->op_first;
1431 if (kid->op_type != OP_PUSHMARK) {
1432 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1434 "panic: unexpected lvalue entersub "
1435 "args: type/targ %ld:%"UVuf,
1436 (long)kid->op_type, (UV)kid->op_targ);
1437 kid = kLISTOP->op_first;
1439 while (kid->op_sibling)
1440 kid = kid->op_sibling;
1441 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1443 if (kid->op_type == OP_METHOD_NAMED
1444 || kid->op_type == OP_METHOD)
1448 NewOp(1101, newop, 1, UNOP);
1449 newop->op_type = OP_RV2CV;
1450 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1451 newop->op_first = NULL;
1452 newop->op_next = (OP*)newop;
1453 kid->op_sibling = (OP*)newop;
1454 newop->op_private |= OPpLVAL_INTRO;
1455 newop->op_private &= ~1;
1459 if (kid->op_type != OP_RV2CV)
1461 "panic: unexpected lvalue entersub "
1462 "entry via type/targ %ld:%"UVuf,
1463 (long)kid->op_type, (UV)kid->op_targ);
1464 kid->op_private |= OPpLVAL_INTRO;
1465 break; /* Postpone until runtime */
1469 kid = kUNOP->op_first;
1470 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1471 kid = kUNOP->op_first;
1472 if (kid->op_type == OP_NULL)
1474 "Unexpected constant lvalue entersub "
1475 "entry via type/targ %ld:%"UVuf,
1476 (long)kid->op_type, (UV)kid->op_targ);
1477 if (kid->op_type != OP_GV) {
1478 /* Restore RV2CV to check lvalueness */
1480 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1481 okid->op_next = kid->op_next;
1482 kid->op_next = okid;
1485 okid->op_next = NULL;
1486 okid->op_type = OP_RV2CV;
1488 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1489 okid->op_private |= OPpLVAL_INTRO;
1490 okid->op_private &= ~1;
1494 cv = GvCV(kGVOP_gv);
1504 /* grep, foreach, subcalls, refgen */
1505 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1507 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1508 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1510 : (o->op_type == OP_ENTERSUB
1511 ? "non-lvalue subroutine call"
1513 type ? PL_op_desc[type] : "local"));
1527 case OP_RIGHT_SHIFT:
1536 if (!(o->op_flags & OPf_STACKED))
1543 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1549 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1550 PL_modcount = RETURN_UNLIMITED_NUMBER;
1551 return o; /* Treat \(@foo) like ordinary list. */
1555 if (scalar_mod_type(o, type))
1557 ref(cUNOPo->op_first, o->op_type);
1561 if (type == OP_LEAVESUBLV)
1562 o->op_private |= OPpMAYBE_LVSUB;
1568 PL_modcount = RETURN_UNLIMITED_NUMBER;
1571 PL_hints |= HINT_BLOCK_SCOPE;
1572 if (type == OP_LEAVESUBLV)
1573 o->op_private |= OPpMAYBE_LVSUB;
1577 ref(cUNOPo->op_first, o->op_type);
1581 PL_hints |= HINT_BLOCK_SCOPE;
1596 PL_modcount = RETURN_UNLIMITED_NUMBER;
1597 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1598 return o; /* Treat \(@foo) like ordinary list. */
1599 if (scalar_mod_type(o, type))
1601 if (type == OP_LEAVESUBLV)
1602 o->op_private |= OPpMAYBE_LVSUB;
1606 if (!type) /* local() */
1607 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1608 PAD_COMPNAME_PV(o->op_targ));
1616 if (type != OP_SASSIGN)
1620 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1625 if (type == OP_LEAVESUBLV)
1626 o->op_private |= OPpMAYBE_LVSUB;
1628 pad_free(o->op_targ);
1629 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1630 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1631 if (o->op_flags & OPf_KIDS)
1632 mod(cBINOPo->op_first->op_sibling, type);
1637 ref(cBINOPo->op_first, o->op_type);
1638 if (type == OP_ENTERSUB &&
1639 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1640 o->op_private |= OPpLVAL_DEFER;
1641 if (type == OP_LEAVESUBLV)
1642 o->op_private |= OPpMAYBE_LVSUB;
1652 if (o->op_flags & OPf_KIDS)
1653 mod(cLISTOPo->op_last, type);
1658 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1660 else if (!(o->op_flags & OPf_KIDS))
1662 if (o->op_targ != OP_LIST) {
1663 mod(cBINOPo->op_first, type);
1669 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1674 if (type != OP_LEAVESUBLV)
1676 break; /* mod()ing was handled by ck_return() */
1679 /* [20011101.069] File test operators interpret OPf_REF to mean that
1680 their argument is a filehandle; thus \stat(".") should not set
1682 if (type == OP_REFGEN &&
1683 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1686 if (type != OP_LEAVESUBLV)
1687 o->op_flags |= OPf_MOD;
1689 if (type == OP_AASSIGN || type == OP_SASSIGN)
1690 o->op_flags |= OPf_SPECIAL|OPf_REF;
1691 else if (!type) { /* local() */
1694 o->op_private |= OPpLVAL_INTRO;
1695 o->op_flags &= ~OPf_SPECIAL;
1696 PL_hints |= HINT_BLOCK_SCOPE;
1701 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1702 "Useless localization of %s", OP_DESC(o));
1705 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1706 && type != OP_LEAVESUBLV)
1707 o->op_flags |= OPf_REF;
1712 S_scalar_mod_type(const OP *o, I32 type)
1714 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1718 if (o->op_type == OP_RV2GV)
1742 case OP_RIGHT_SHIFT:
1762 S_is_handle_constructor(const OP *o, I32 numargs)
1764 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1766 switch (o->op_type) {
1774 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1787 S_refkids(pTHX_ OP *o, I32 type)
1789 if (o && o->op_flags & OPf_KIDS) {
1791 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1798 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1803 PERL_ARGS_ASSERT_DOREF;
1805 if (!o || (PL_parser && PL_parser->error_count))
1808 switch (o->op_type) {
1810 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1811 !(o->op_flags & OPf_STACKED)) {
1812 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1813 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1814 assert(cUNOPo->op_first->op_type == OP_NULL);
1815 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1816 o->op_flags |= OPf_SPECIAL;
1817 o->op_private &= ~1;
1822 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1823 doref(kid, type, set_op_ref);
1826 if (type == OP_DEFINED)
1827 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1828 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1831 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1832 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1833 : type == OP_RV2HV ? OPpDEREF_HV
1835 o->op_flags |= OPf_MOD;
1842 o->op_flags |= OPf_REF;
1845 if (type == OP_DEFINED)
1846 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1847 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1853 o->op_flags |= OPf_REF;
1858 if (!(o->op_flags & OPf_KIDS))
1860 doref(cBINOPo->op_first, type, set_op_ref);
1864 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1865 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1866 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1867 : type == OP_RV2HV ? OPpDEREF_HV
1869 o->op_flags |= OPf_MOD;
1879 if (!(o->op_flags & OPf_KIDS))
1881 doref(cLISTOPo->op_last, type, set_op_ref);
1891 S_dup_attrlist(pTHX_ OP *o)
1896 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1898 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1899 * where the first kid is OP_PUSHMARK and the remaining ones
1900 * are OP_CONST. We need to push the OP_CONST values.
1902 if (o->op_type == OP_CONST)
1903 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1905 else if (o->op_type == OP_NULL)
1909 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1911 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1912 if (o->op_type == OP_CONST)
1913 rop = append_elem(OP_LIST, rop,
1914 newSVOP(OP_CONST, o->op_flags,
1915 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1922 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1927 PERL_ARGS_ASSERT_APPLY_ATTRS;
1929 /* fake up C<use attributes $pkg,$rv,@attrs> */
1930 ENTER; /* need to protect against side-effects of 'use' */
1931 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1933 #define ATTRSMODULE "attributes"
1934 #define ATTRSMODULE_PM "attributes.pm"
1937 /* Don't force the C<use> if we don't need it. */
1938 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1939 if (svp && *svp != &PL_sv_undef)
1940 NOOP; /* already in %INC */
1942 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1943 newSVpvs(ATTRSMODULE), NULL);
1946 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1947 newSVpvs(ATTRSMODULE),
1949 prepend_elem(OP_LIST,
1950 newSVOP(OP_CONST, 0, stashsv),
1951 prepend_elem(OP_LIST,
1952 newSVOP(OP_CONST, 0,
1954 dup_attrlist(attrs))));
1960 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1963 OP *pack, *imop, *arg;
1966 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1971 assert(target->op_type == OP_PADSV ||
1972 target->op_type == OP_PADHV ||
1973 target->op_type == OP_PADAV);
1975 /* Ensure that attributes.pm is loaded. */
1976 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1978 /* Need package name for method call. */
1979 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1981 /* Build up the real arg-list. */
1982 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1984 arg = newOP(OP_PADSV, 0);
1985 arg->op_targ = target->op_targ;
1986 arg = prepend_elem(OP_LIST,
1987 newSVOP(OP_CONST, 0, stashsv),
1988 prepend_elem(OP_LIST,
1989 newUNOP(OP_REFGEN, 0,
1990 mod(arg, OP_REFGEN)),
1991 dup_attrlist(attrs)));
1993 /* Fake up a method call to import */
1994 meth = newSVpvs_share("import");
1995 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1996 append_elem(OP_LIST,
1997 prepend_elem(OP_LIST, pack, list(arg)),
1998 newSVOP(OP_METHOD_NAMED, 0, meth)));
1999 imop->op_private |= OPpENTERSUB_NOMOD;
2001 /* Combine the ops. */
2002 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2006 =notfor apidoc apply_attrs_string
2008 Attempts to apply a list of attributes specified by the C<attrstr> and
2009 C<len> arguments to the subroutine identified by the C<cv> argument which
2010 is expected to be associated with the package identified by the C<stashpv>
2011 argument (see L<attributes>). It gets this wrong, though, in that it
2012 does not correctly identify the boundaries of the individual attribute
2013 specifications within C<attrstr>. This is not really intended for the
2014 public API, but has to be listed here for systems such as AIX which
2015 need an explicit export list for symbols. (It's called from XS code
2016 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2017 to respect attribute syntax properly would be welcome.
2023 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2024 const char *attrstr, STRLEN len)
2028 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2031 len = strlen(attrstr);
2035 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2037 const char * const sstr = attrstr;
2038 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2039 attrs = append_elem(OP_LIST, attrs,
2040 newSVOP(OP_CONST, 0,
2041 newSVpvn(sstr, attrstr-sstr)));
2045 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2046 newSVpvs(ATTRSMODULE),
2047 NULL, prepend_elem(OP_LIST,
2048 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2049 prepend_elem(OP_LIST,
2050 newSVOP(OP_CONST, 0,
2051 newRV(MUTABLE_SV(cv))),
2056 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2061 PERL_ARGS_ASSERT_MY_KID;
2063 if (!o || (PL_parser && PL_parser->error_count))
2067 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2068 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2072 if (type == OP_LIST) {
2074 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2075 my_kid(kid, attrs, imopsp);
2076 } else if (type == OP_UNDEF
2082 } else if (type == OP_RV2SV || /* "our" declaration */
2084 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2085 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2086 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2088 PL_parser->in_my == KEY_our
2090 : PL_parser->in_my == KEY_state ? "state" : "my"));
2092 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2093 PL_parser->in_my = FALSE;
2094 PL_parser->in_my_stash = NULL;
2095 apply_attrs(GvSTASH(gv),
2096 (type == OP_RV2SV ? GvSV(gv) :
2097 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2098 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2101 o->op_private |= OPpOUR_INTRO;
2104 else if (type != OP_PADSV &&
2107 type != OP_PUSHMARK)
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"));
2116 else if (attrs && type != OP_PUSHMARK) {
2119 PL_parser->in_my = FALSE;
2120 PL_parser->in_my_stash = NULL;
2122 /* check for C<my Dog $spot> when deciding package */
2123 stash = PAD_COMPNAME_TYPE(o->op_targ);
2125 stash = PL_curstash;
2126 apply_attrs_my(stash, o, attrs, imopsp);
2128 o->op_flags |= OPf_MOD;
2129 o->op_private |= OPpLVAL_INTRO;
2130 if (PL_parser->in_my == KEY_state)
2131 o->op_private |= OPpPAD_STATE;
2136 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2140 int maybe_scalar = 0;
2142 PERL_ARGS_ASSERT_MY_ATTRS;
2144 /* [perl #17376]: this appears to be premature, and results in code such as
2145 C< our(%x); > executing in list mode rather than void mode */
2147 if (o->op_flags & OPf_PARENS)
2157 o = my_kid(o, attrs, &rops);
2159 if (maybe_scalar && o->op_type == OP_PADSV) {
2160 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2161 o->op_private |= OPpLVAL_INTRO;
2164 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2166 PL_parser->in_my = FALSE;
2167 PL_parser->in_my_stash = NULL;
2172 Perl_sawparens(pTHX_ OP *o)
2174 PERL_UNUSED_CONTEXT;
2176 o->op_flags |= OPf_PARENS;
2181 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2185 const OPCODE ltype = left->op_type;
2186 const OPCODE rtype = right->op_type;
2188 PERL_ARGS_ASSERT_BIND_MATCH;
2190 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2191 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2193 const char * const desc
2194 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2195 ? (int)rtype : OP_MATCH];
2196 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2197 ? "@array" : "%hash");
2198 Perl_warner(aTHX_ packWARN(WARN_MISC),
2199 "Applying %s to %s will act on scalar(%s)",
2200 desc, sample, sample);
2203 if (rtype == OP_CONST &&
2204 cSVOPx(right)->op_private & OPpCONST_BARE &&
2205 cSVOPx(right)->op_private & OPpCONST_STRICT)
2207 no_bareword_allowed(right);
2210 ismatchop = rtype == OP_MATCH ||
2211 rtype == OP_SUBST ||
2213 if (ismatchop && right->op_private & OPpTARGET_MY) {
2215 right->op_private &= ~OPpTARGET_MY;
2217 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2220 right->op_flags |= OPf_STACKED;
2221 if (rtype != OP_MATCH &&
2222 ! (rtype == OP_TRANS &&
2223 right->op_private & OPpTRANS_IDENTICAL))
2224 newleft = mod(left, rtype);
2227 if (right->op_type == OP_TRANS)
2228 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2230 o = prepend_elem(rtype, scalar(newleft), right);
2232 return newUNOP(OP_NOT, 0, scalar(o));
2236 return bind_match(type, left,
2237 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2241 Perl_invert(pTHX_ OP *o)
2245 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2249 Perl_scope(pTHX_ OP *o)
2253 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2254 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2255 o->op_type = OP_LEAVE;
2256 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2258 else if (o->op_type == OP_LINESEQ) {
2260 o->op_type = OP_SCOPE;
2261 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2262 kid = ((LISTOP*)o)->op_first;
2263 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2266 /* The following deals with things like 'do {1 for 1}' */
2267 kid = kid->op_sibling;
2269 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2274 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2280 Perl_block_start(pTHX_ int full)
2283 const int retval = PL_savestack_ix;
2284 pad_block_start(full);
2286 PL_hints &= ~HINT_BLOCK_SCOPE;
2287 SAVECOMPILEWARNINGS();
2288 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2293 Perl_block_end(pTHX_ I32 floor, OP *seq)
2296 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2297 OP* const retval = scalarseq(seq);
2299 CopHINTS_set(&PL_compiling, PL_hints);
2301 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2310 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2311 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2312 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2315 OP * const o = newOP(OP_PADSV, 0);
2316 o->op_targ = offset;
2322 Perl_newPROG(pTHX_ OP *o)
2326 PERL_ARGS_ASSERT_NEWPROG;
2331 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2332 ((PL_in_eval & EVAL_KEEPERR)
2333 ? OPf_SPECIAL : 0), o);
2334 PL_eval_start = linklist(PL_eval_root);
2335 PL_eval_root->op_private |= OPpREFCOUNTED;
2336 OpREFCNT_set(PL_eval_root, 1);
2337 PL_eval_root->op_next = 0;
2338 CALL_PEEP(PL_eval_start);
2341 if (o->op_type == OP_STUB) {
2342 PL_comppad_name = 0;
2344 S_op_destroy(aTHX_ o);
2347 PL_main_root = scope(sawparens(scalarvoid(o)));
2348 PL_curcop = &PL_compiling;
2349 PL_main_start = LINKLIST(PL_main_root);
2350 PL_main_root->op_private |= OPpREFCOUNTED;
2351 OpREFCNT_set(PL_main_root, 1);
2352 PL_main_root->op_next = 0;
2353 CALL_PEEP(PL_main_start);
2356 /* Register with debugger */
2358 CV * const cv = get_cvs("DB::postponed", 0);
2362 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2364 call_sv(MUTABLE_SV(cv), G_DISCARD);
2371 Perl_localize(pTHX_ OP *o, I32 lex)
2375 PERL_ARGS_ASSERT_LOCALIZE;
2377 if (o->op_flags & OPf_PARENS)
2378 /* [perl #17376]: this appears to be premature, and results in code such as
2379 C< our(%x); > executing in list mode rather than void mode */
2386 if ( PL_parser->bufptr > PL_parser->oldbufptr
2387 && PL_parser->bufptr[-1] == ','
2388 && ckWARN(WARN_PARENTHESIS))
2390 char *s = PL_parser->bufptr;
2393 /* some heuristics to detect a potential error */
2394 while (*s && (strchr(", \t\n", *s)))
2398 if (*s && strchr("@$%*", *s) && *++s
2399 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2402 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2404 while (*s && (strchr(", \t\n", *s)))
2410 if (sigil && (*s == ';' || *s == '=')) {
2411 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2412 "Parentheses missing around \"%s\" list",
2414 ? (PL_parser->in_my == KEY_our
2416 : PL_parser->in_my == KEY_state
2426 o = mod(o, OP_NULL); /* a bit kludgey */
2427 PL_parser->in_my = FALSE;
2428 PL_parser->in_my_stash = NULL;
2433 Perl_jmaybe(pTHX_ OP *o)
2435 PERL_ARGS_ASSERT_JMAYBE;
2437 if (o->op_type == OP_LIST) {
2439 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2440 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2446 S_fold_constants(pTHX_ register OP *o)
2449 register OP * VOL curop;
2451 VOL I32 type = o->op_type;
2456 SV * const oldwarnhook = PL_warnhook;
2457 SV * const olddiehook = PL_diehook;
2461 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2463 if (PL_opargs[type] & OA_RETSCALAR)
2465 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2466 o->op_targ = pad_alloc(type, SVs_PADTMP);
2468 /* integerize op, unless it happens to be C<-foo>.
2469 * XXX should pp_i_negate() do magic string negation instead? */
2470 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2471 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2472 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2474 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2477 if (!(PL_opargs[type] & OA_FOLDCONST))
2482 /* XXX might want a ck_negate() for this */
2483 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2494 /* XXX what about the numeric ops? */
2495 if (PL_hints & HINT_LOCALE)
2500 if (PL_parser && PL_parser->error_count)
2501 goto nope; /* Don't try to run w/ errors */
2503 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2504 const OPCODE type = curop->op_type;
2505 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2507 type != OP_SCALAR &&
2509 type != OP_PUSHMARK)
2515 curop = LINKLIST(o);
2516 old_next = o->op_next;
2520 oldscope = PL_scopestack_ix;
2521 create_eval_scope(G_FAKINGEVAL);
2523 /* Verify that we don't need to save it: */
2524 assert(PL_curcop == &PL_compiling);
2525 StructCopy(&PL_compiling, ¬_compiling, COP);
2526 PL_curcop = ¬_compiling;
2527 /* The above ensures that we run with all the correct hints of the
2528 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2529 assert(IN_PERL_RUNTIME);
2530 PL_warnhook = PERL_WARNHOOK_FATAL;
2537 sv = *(PL_stack_sp--);
2538 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2539 pad_swipe(o->op_targ, FALSE);
2540 else if (SvTEMP(sv)) { /* grab mortal temp? */
2541 SvREFCNT_inc_simple_void(sv);
2546 /* Something tried to die. Abandon constant folding. */
2547 /* Pretend the error never happened. */
2549 o->op_next = old_next;
2553 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2554 PL_warnhook = oldwarnhook;
2555 PL_diehook = olddiehook;
2556 /* XXX note that this croak may fail as we've already blown away
2557 * the stack - eg any nested evals */
2558 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2561 PL_warnhook = oldwarnhook;
2562 PL_diehook = olddiehook;
2563 PL_curcop = &PL_compiling;
2565 if (PL_scopestack_ix > oldscope)
2566 delete_eval_scope();
2575 if (type == OP_RV2GV)
2576 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2578 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2579 op_getmad(o,newop,'f');
2587 S_gen_constant_list(pTHX_ register OP *o)
2591 const I32 oldtmps_floor = PL_tmps_floor;
2594 if (PL_parser && PL_parser->error_count)
2595 return o; /* Don't attempt to run with errors */
2597 PL_op = curop = LINKLIST(o);
2603 assert (!(curop->op_flags & OPf_SPECIAL));
2604 assert(curop->op_type == OP_RANGE);
2606 PL_tmps_floor = oldtmps_floor;
2608 o->op_type = OP_RV2AV;
2609 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2610 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2611 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2612 o->op_opt = 0; /* needs to be revisited in peep() */
2613 curop = ((UNOP*)o)->op_first;
2614 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2616 op_getmad(curop,o,'O');
2625 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2628 if (!o || o->op_type != OP_LIST)
2629 o = newLISTOP(OP_LIST, 0, o, NULL);
2631 o->op_flags &= ~OPf_WANT;
2633 if (!(PL_opargs[type] & OA_MARK))
2634 op_null(cLISTOPo->op_first);
2636 o->op_type = (OPCODE)type;
2637 o->op_ppaddr = PL_ppaddr[type];
2638 o->op_flags |= flags;
2640 o = CHECKOP(type, o);
2641 if (o->op_type != (unsigned)type)
2644 return fold_constants(o);
2647 /* List constructors */
2650 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2658 if (first->op_type != (unsigned)type
2659 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2661 return newLISTOP(type, 0, first, last);
2664 if (first->op_flags & OPf_KIDS)
2665 ((LISTOP*)first)->op_last->op_sibling = last;
2667 first->op_flags |= OPf_KIDS;
2668 ((LISTOP*)first)->op_first = last;
2670 ((LISTOP*)first)->op_last = last;
2675 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2683 if (first->op_type != (unsigned)type)
2684 return prepend_elem(type, (OP*)first, (OP*)last);
2686 if (last->op_type != (unsigned)type)
2687 return append_elem(type, (OP*)first, (OP*)last);
2689 first->op_last->op_sibling = last->op_first;
2690 first->op_last = last->op_last;
2691 first->op_flags |= (last->op_flags & OPf_KIDS);
2694 if (last->op_first && first->op_madprop) {
2695 MADPROP *mp = last->op_first->op_madprop;
2697 while (mp->mad_next)
2699 mp->mad_next = first->op_madprop;
2702 last->op_first->op_madprop = first->op_madprop;
2705 first->op_madprop = last->op_madprop;
2706 last->op_madprop = 0;
2709 S_op_destroy(aTHX_ (OP*)last);
2715 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2723 if (last->op_type == (unsigned)type) {
2724 if (type == OP_LIST) { /* already a PUSHMARK there */
2725 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2726 ((LISTOP*)last)->op_first->op_sibling = first;
2727 if (!(first->op_flags & OPf_PARENS))
2728 last->op_flags &= ~OPf_PARENS;
2731 if (!(last->op_flags & OPf_KIDS)) {
2732 ((LISTOP*)last)->op_last = first;
2733 last->op_flags |= OPf_KIDS;
2735 first->op_sibling = ((LISTOP*)last)->op_first;
2736 ((LISTOP*)last)->op_first = first;
2738 last->op_flags |= OPf_KIDS;
2742 return newLISTOP(type, 0, first, last);
2750 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2753 Newxz(tk, 1, TOKEN);
2754 tk->tk_type = (OPCODE)optype;
2755 tk->tk_type = 12345;
2757 tk->tk_mad = madprop;
2762 Perl_token_free(pTHX_ TOKEN* tk)
2764 PERL_ARGS_ASSERT_TOKEN_FREE;
2766 if (tk->tk_type != 12345)
2768 mad_free(tk->tk_mad);
2773 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2778 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2780 if (tk->tk_type != 12345) {
2781 Perl_warner(aTHX_ packWARN(WARN_MISC),
2782 "Invalid TOKEN object ignored");
2789 /* faked up qw list? */
2791 tm->mad_type == MAD_SV &&
2792 SvPVX((SV *)tm->mad_val)[0] == 'q')
2799 /* pretend constant fold didn't happen? */
2800 if (mp->mad_key == 'f' &&
2801 (o->op_type == OP_CONST ||
2802 o->op_type == OP_GV) )
2804 token_getmad(tk,(OP*)mp->mad_val,slot);
2818 if (mp->mad_key == 'X')
2819 mp->mad_key = slot; /* just change the first one */
2829 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2838 /* pretend constant fold didn't happen? */
2839 if (mp->mad_key == 'f' &&
2840 (o->op_type == OP_CONST ||
2841 o->op_type == OP_GV) )
2843 op_getmad(from,(OP*)mp->mad_val,slot);
2850 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2853 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2859 Perl_op_getmad(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,1);
2883 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2887 PerlIO_printf(PerlIO_stderr(),
2888 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2894 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2912 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2916 addmad(tm, &(o->op_madprop), slot);
2920 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2941 Perl_newMADsv(pTHX_ char key, SV* sv)
2943 PERL_ARGS_ASSERT_NEWMADSV;
2945 return newMADPROP(key, MAD_SV, sv, 0);
2949 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2952 Newxz(mp, 1, MADPROP);
2955 mp->mad_vlen = vlen;
2956 mp->mad_type = type;
2958 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2963 Perl_mad_free(pTHX_ MADPROP* mp)
2965 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2969 mad_free(mp->mad_next);
2970 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2971 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2972 switch (mp->mad_type) {
2976 Safefree((char*)mp->mad_val);
2979 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2980 op_free((OP*)mp->mad_val);
2983 sv_free(MUTABLE_SV(mp->mad_val));
2986 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2995 Perl_newNULLLIST(pTHX)
2997 return newOP(OP_STUB, 0);
3001 S_force_list(pTHX_ OP *o)
3003 if (!o || o->op_type != OP_LIST)
3004 o = newLISTOP(OP_LIST, 0, o, NULL);
3010 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3015 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3017 NewOp(1101, listop, 1, LISTOP);
3019 listop->op_type = (OPCODE)type;
3020 listop->op_ppaddr = PL_ppaddr[type];
3023 listop->op_flags = (U8)flags;
3027 else if (!first && last)
3030 first->op_sibling = last;
3031 listop->op_first = first;
3032 listop->op_last = last;
3033 if (type == OP_LIST) {
3034 OP* const pushop = newOP(OP_PUSHMARK, 0);
3035 pushop->op_sibling = first;
3036 listop->op_first = pushop;
3037 listop->op_flags |= OPf_KIDS;
3039 listop->op_last = pushop;
3042 return CHECKOP(type, listop);
3046 Perl_newOP(pTHX_ I32 type, I32 flags)
3051 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3052 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3053 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3054 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3056 NewOp(1101, o, 1, OP);
3057 o->op_type = (OPCODE)type;
3058 o->op_ppaddr = PL_ppaddr[type];
3059 o->op_flags = (U8)flags;
3061 o->op_latefreed = 0;
3065 o->op_private = (U8)(0 | (flags >> 8));
3066 if (PL_opargs[type] & OA_RETSCALAR)
3068 if (PL_opargs[type] & OA_TARGET)
3069 o->op_targ = pad_alloc(type, SVs_PADTMP);
3070 return CHECKOP(type, o);
3074 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3079 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3080 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3081 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3082 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3083 || type == OP_SASSIGN
3084 || type == OP_NULL );
3087 first = newOP(OP_STUB, 0);
3088 if (PL_opargs[type] & OA_MARK)
3089 first = force_list(first);
3091 NewOp(1101, unop, 1, UNOP);
3092 unop->op_type = (OPCODE)type;
3093 unop->op_ppaddr = PL_ppaddr[type];
3094 unop->op_first = first;
3095 unop->op_flags = (U8)(flags | OPf_KIDS);
3096 unop->op_private = (U8)(1 | (flags >> 8));
3097 unop = (UNOP*) CHECKOP(type, unop);
3101 return fold_constants((OP *) unop);
3105 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3110 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3111 || type == OP_SASSIGN || type == OP_NULL );
3113 NewOp(1101, binop, 1, BINOP);
3116 first = newOP(OP_NULL, 0);
3118 binop->op_type = (OPCODE)type;
3119 binop->op_ppaddr = PL_ppaddr[type];
3120 binop->op_first = first;
3121 binop->op_flags = (U8)(flags | OPf_KIDS);
3124 binop->op_private = (U8)(1 | (flags >> 8));
3127 binop->op_private = (U8)(2 | (flags >> 8));
3128 first->op_sibling = last;
3131 binop = (BINOP*)CHECKOP(type, binop);
3132 if (binop->op_next || binop->op_type != (OPCODE)type)
3135 binop->op_last = binop->op_first->op_sibling;
3137 return fold_constants((OP *)binop);
3140 static int uvcompare(const void *a, const void *b)
3141 __attribute__nonnull__(1)
3142 __attribute__nonnull__(2)
3143 __attribute__pure__;
3144 static int uvcompare(const void *a, const void *b)
3146 if (*((const UV *)a) < (*(const UV *)b))
3148 if (*((const UV *)a) > (*(const UV *)b))
3150 if (*((const UV *)a+1) < (*(const UV *)b+1))
3152 if (*((const UV *)a+1) > (*(const UV *)b+1))
3158 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3161 SV * const tstr = ((SVOP*)expr)->op_sv;
3164 (repl->op_type == OP_NULL)
3165 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3167 ((SVOP*)repl)->op_sv;
3170 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3171 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3175 register short *tbl;
3177 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3178 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3179 I32 del = o->op_private & OPpTRANS_DELETE;
3182 PERL_ARGS_ASSERT_PMTRANS;
3184 PL_hints |= HINT_BLOCK_SCOPE;
3187 o->op_private |= OPpTRANS_FROM_UTF;
3190 o->op_private |= OPpTRANS_TO_UTF;
3192 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3193 SV* const listsv = newSVpvs("# comment\n");
3195 const U8* tend = t + tlen;
3196 const U8* rend = r + rlen;
3210 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3211 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3214 const U32 flags = UTF8_ALLOW_DEFAULT;
3218 t = tsave = bytes_to_utf8(t, &len);
3221 if (!to_utf && rlen) {
3223 r = rsave = bytes_to_utf8(r, &len);
3227 /* There are several snags with this code on EBCDIC:
3228 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3229 2. scan_const() in toke.c has encoded chars in native encoding which makes
3230 ranges at least in EBCDIC 0..255 range the bottom odd.
3234 U8 tmpbuf[UTF8_MAXBYTES+1];
3237 Newx(cp, 2*tlen, UV);
3239 transv = newSVpvs("");
3241 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3243 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3245 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3249 cp[2*i+1] = cp[2*i];
3253 qsort(cp, i, 2*sizeof(UV), uvcompare);
3254 for (j = 0; j < i; j++) {
3256 diff = val - nextmin;
3258 t = uvuni_to_utf8(tmpbuf,nextmin);
3259 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3261 U8 range_mark = UTF_TO_NATIVE(0xff);
3262 t = uvuni_to_utf8(tmpbuf, val - 1);
3263 sv_catpvn(transv, (char *)&range_mark, 1);
3264 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3271 t = uvuni_to_utf8(tmpbuf,nextmin);
3272 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3274 U8 range_mark = UTF_TO_NATIVE(0xff);
3275 sv_catpvn(transv, (char *)&range_mark, 1);
3277 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3278 UNICODE_ALLOW_SUPER);
3279 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3280 t = (const U8*)SvPVX_const(transv);
3281 tlen = SvCUR(transv);
3285 else if (!rlen && !del) {
3286 r = t; rlen = tlen; rend = tend;
3289 if ((!rlen && !del) || t == r ||
3290 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3292 o->op_private |= OPpTRANS_IDENTICAL;
3296 while (t < tend || tfirst <= tlast) {
3297 /* see if we need more "t" chars */
3298 if (tfirst > tlast) {
3299 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3301 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3303 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3310 /* now see if we need more "r" chars */
3311 if (rfirst > rlast) {
3313 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3315 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3317 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3326 rfirst = rlast = 0xffffffff;
3330 /* now see which range will peter our first, if either. */
3331 tdiff = tlast - tfirst;
3332 rdiff = rlast - rfirst;
3339 if (rfirst == 0xffffffff) {
3340 diff = tdiff; /* oops, pretend rdiff is infinite */
3342 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3343 (long)tfirst, (long)tlast);
3345 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3349 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3350 (long)tfirst, (long)(tfirst + diff),
3353 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3354 (long)tfirst, (long)rfirst);
3356 if (rfirst + diff > max)
3357 max = rfirst + diff;
3359 grows = (tfirst < rfirst &&
3360 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3372 else if (max > 0xff)
3377 PerlMemShared_free(cPVOPo->op_pv);
3378 cPVOPo->op_pv = NULL;
3380 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3382 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3383 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3384 PAD_SETSV(cPADOPo->op_padix, swash);
3386 SvREADONLY_on(swash);
3388 cSVOPo->op_sv = swash;
3390 SvREFCNT_dec(listsv);
3391 SvREFCNT_dec(transv);
3393 if (!del && havefinal && rlen)
3394 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3395 newSVuv((UV)final), 0);
3398 o->op_private |= OPpTRANS_GROWS;
3404 op_getmad(expr,o,'e');
3405 op_getmad(repl,o,'r');
3413 tbl = (short*)cPVOPo->op_pv;
3415 Zero(tbl, 256, short);
3416 for (i = 0; i < (I32)tlen; i++)
3418 for (i = 0, j = 0; i < 256; i++) {
3420 if (j >= (I32)rlen) {
3429 if (i < 128 && r[j] >= 128)
3439 o->op_private |= OPpTRANS_IDENTICAL;
3441 else if (j >= (I32)rlen)
3446 PerlMemShared_realloc(tbl,
3447 (0x101+rlen-j) * sizeof(short));
3448 cPVOPo->op_pv = (char*)tbl;
3450 tbl[0x100] = (short)(rlen - j);
3451 for (i=0; i < (I32)rlen - j; i++)
3452 tbl[0x101+i] = r[j+i];
3456 if (!rlen && !del) {
3459 o->op_private |= OPpTRANS_IDENTICAL;
3461 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3462 o->op_private |= OPpTRANS_IDENTICAL;
3464 for (i = 0; i < 256; i++)
3466 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3467 if (j >= (I32)rlen) {
3469 if (tbl[t[i]] == -1)
3475 if (tbl[t[i]] == -1) {
3476 if (t[i] < 128 && r[j] >= 128)
3483 if(del && rlen == tlen) {
3484 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3485 } else if(rlen > tlen) {
3486 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3490 o->op_private |= OPpTRANS_GROWS;
3492 op_getmad(expr,o,'e');
3493 op_getmad(repl,o,'r');
3503 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3508 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3510 NewOp(1101, pmop, 1, PMOP);
3511 pmop->op_type = (OPCODE)type;
3512 pmop->op_ppaddr = PL_ppaddr[type];
3513 pmop->op_flags = (U8)flags;
3514 pmop->op_private = (U8)(0 | (flags >> 8));
3516 if (PL_hints & HINT_RE_TAINT)
3517 pmop->op_pmflags |= PMf_RETAINT;
3518 if (PL_hints & HINT_LOCALE)
3519 pmop->op_pmflags |= PMf_LOCALE;
3523 assert(SvPOK(PL_regex_pad[0]));
3524 if (SvCUR(PL_regex_pad[0])) {
3525 /* Pop off the "packed" IV from the end. */
3526 SV *const repointer_list = PL_regex_pad[0];
3527 const char *p = SvEND(repointer_list) - sizeof(IV);
3528 const IV offset = *((IV*)p);
3530 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3532 SvEND_set(repointer_list, p);
3534 pmop->op_pmoffset = offset;
3535 /* This slot should be free, so assert this: */
3536 assert(PL_regex_pad[offset] == &PL_sv_undef);
3538 SV * const repointer = &PL_sv_undef;
3539 av_push(PL_regex_padav, repointer);
3540 pmop->op_pmoffset = av_len(PL_regex_padav);
3541 PL_regex_pad = AvARRAY(PL_regex_padav);
3545 return CHECKOP(type, pmop);
3548 /* Given some sort of match op o, and an expression expr containing a
3549 * pattern, either compile expr into a regex and attach it to o (if it's
3550 * constant), or convert expr into a runtime regcomp op sequence (if it's
3553 * isreg indicates that the pattern is part of a regex construct, eg
3554 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3555 * split "pattern", which aren't. In the former case, expr will be a list
3556 * if the pattern contains more than one term (eg /a$b/) or if it contains
3557 * a replacement, ie s/// or tr///.
3561 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3566 I32 repl_has_vars = 0;
3570 PERL_ARGS_ASSERT_PMRUNTIME;
3572 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3573 /* last element in list is the replacement; pop it */
3575 repl = cLISTOPx(expr)->op_last;
3576 kid = cLISTOPx(expr)->op_first;
3577 while (kid->op_sibling != repl)
3578 kid = kid->op_sibling;
3579 kid->op_sibling = NULL;
3580 cLISTOPx(expr)->op_last = kid;
3583 if (isreg && expr->op_type == OP_LIST &&
3584 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3586 /* convert single element list to element */
3587 OP* const oe = expr;
3588 expr = cLISTOPx(oe)->op_first->op_sibling;
3589 cLISTOPx(oe)->op_first->op_sibling = NULL;
3590 cLISTOPx(oe)->op_last = NULL;
3594 if (o->op_type == OP_TRANS) {
3595 return pmtrans(o, expr, repl);
3598 reglist = isreg && expr->op_type == OP_LIST;
3602 PL_hints |= HINT_BLOCK_SCOPE;
3605 if (expr->op_type == OP_CONST) {
3606 SV *pat = ((SVOP*)expr)->op_sv;
3607 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3609 if (o->op_flags & OPf_SPECIAL)
3610 pm_flags |= RXf_SPLIT;
3613 assert (SvUTF8(pat));
3614 } else if (SvUTF8(pat)) {
3615 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3616 trapped in use 'bytes'? */
3617 /* Make a copy of the octet sequence, but without the flag on, as
3618 the compiler now honours the SvUTF8 flag on pat. */
3620 const char *const p = SvPV(pat, len);
3621 pat = newSVpvn_flags(p, len, SVs_TEMP);
3624 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3627 op_getmad(expr,(OP*)pm,'e');
3633 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3634 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3636 : OP_REGCMAYBE),0,expr);
3638 NewOp(1101, rcop, 1, LOGOP);
3639 rcop->op_type = OP_REGCOMP;
3640 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3641 rcop->op_first = scalar(expr);
3642 rcop->op_flags |= OPf_KIDS
3643 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3644 | (reglist ? OPf_STACKED : 0);
3645 rcop->op_private = 1;
3648 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3650 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3653 /* establish postfix order */
3654 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3656 rcop->op_next = expr;
3657 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3660 rcop->op_next = LINKLIST(expr);
3661 expr->op_next = (OP*)rcop;
3664 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3669 if (pm->op_pmflags & PMf_EVAL) {
3671 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3672 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3674 else if (repl->op_type == OP_CONST)
3678 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3679 if (curop->op_type == OP_SCOPE
3680 || curop->op_type == OP_LEAVE
3681 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3682 if (curop->op_type == OP_GV) {
3683 GV * const gv = cGVOPx_gv(curop);
3685 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3688 else if (curop->op_type == OP_RV2CV)
3690 else if (curop->op_type == OP_RV2SV ||
3691 curop->op_type == OP_RV2AV ||
3692 curop->op_type == OP_RV2HV ||
3693 curop->op_type == OP_RV2GV) {
3694 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3697 else if (curop->op_type == OP_PADSV ||
3698 curop->op_type == OP_PADAV ||
3699 curop->op_type == OP_PADHV ||
3700 curop->op_type == OP_PADANY)
3704 else if (curop->op_type == OP_PUSHRE)
3705 NOOP; /* Okay here, dangerous in newASSIGNOP */
3715 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3717 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3718 prepend_elem(o->op_type, scalar(repl), o);
3721 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3722 pm->op_pmflags |= PMf_MAYBE_CONST;
3724 NewOp(1101, rcop, 1, LOGOP);
3725 rcop->op_type = OP_SUBSTCONT;
3726 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3727 rcop->op_first = scalar(repl);
3728 rcop->op_flags |= OPf_KIDS;
3729 rcop->op_private = 1;
3732 /* establish postfix order */
3733 rcop->op_next = LINKLIST(repl);
3734 repl->op_next = (OP*)rcop;
3736 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3737 assert(!(pm->op_pmflags & PMf_ONCE));
3738 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3747 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3752 PERL_ARGS_ASSERT_NEWSVOP;
3754 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3755 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3756 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3758 NewOp(1101, svop, 1, SVOP);
3759 svop->op_type = (OPCODE)type;
3760 svop->op_ppaddr = PL_ppaddr[type];
3762 svop->op_next = (OP*)svop;
3763 svop->op_flags = (U8)flags;
3764 if (PL_opargs[type] & OA_RETSCALAR)
3766 if (PL_opargs[type] & OA_TARGET)
3767 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3768 return CHECKOP(type, svop);
3773 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3778 PERL_ARGS_ASSERT_NEWPADOP;
3780 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3781 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3782 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3784 NewOp(1101, padop, 1, PADOP);
3785 padop->op_type = (OPCODE)type;
3786 padop->op_ppaddr = PL_ppaddr[type];
3787 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3788 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3789 PAD_SETSV(padop->op_padix, sv);
3792 padop->op_next = (OP*)padop;
3793 padop->op_flags = (U8)flags;
3794 if (PL_opargs[type] & OA_RETSCALAR)
3796 if (PL_opargs[type] & OA_TARGET)
3797 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3798 return CHECKOP(type, padop);
3803 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3807 PERL_ARGS_ASSERT_NEWGVOP;
3811 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3813 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3818 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3823 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3824 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3826 NewOp(1101, pvop, 1, PVOP);
3827 pvop->op_type = (OPCODE)type;
3828 pvop->op_ppaddr = PL_ppaddr[type];
3830 pvop->op_next = (OP*)pvop;
3831 pvop->op_flags = (U8)flags;
3832 if (PL_opargs[type] & OA_RETSCALAR)
3834 if (PL_opargs[type] & OA_TARGET)
3835 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3836 return CHECKOP(type, pvop);
3844 Perl_package(pTHX_ OP *o)
3847 SV *const sv = cSVOPo->op_sv;
3852 PERL_ARGS_ASSERT_PACKAGE;
3854 save_hptr(&PL_curstash);
3855 save_item(PL_curstname);
3857 PL_curstash = gv_stashsv(sv, GV_ADD);
3859 sv_setsv(PL_curstname, sv);
3861 PL_hints |= HINT_BLOCK_SCOPE;
3862 PL_parser->copline = NOLINE;
3863 PL_parser->expect = XSTATE;
3868 if (!PL_madskills) {
3873 pegop = newOP(OP_NULL,0);
3874 op_getmad(o,pegop,'P');
3880 Perl_package_version( pTHX_ OP *v )
3883 U32 savehints = PL_hints;
3884 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3885 PL_hints &= ~HINT_STRICT_VARS;
3886 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3887 PL_hints = savehints;
3896 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3903 OP *pegop = newOP(OP_NULL,0);
3906 PERL_ARGS_ASSERT_UTILIZE;
3908 if (idop->op_type != OP_CONST)
3909 Perl_croak(aTHX_ "Module name must be constant");
3912 op_getmad(idop,pegop,'U');
3917 SV * const vesv = ((SVOP*)version)->op_sv;
3920 op_getmad(version,pegop,'V');
3921 if (!arg && !SvNIOKp(vesv)) {
3928 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3929 Perl_croak(aTHX_ "Version number must be a constant number");
3931 /* Make copy of idop so we don't free it twice */
3932 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3934 /* Fake up a method call to VERSION */
3935 meth = newSVpvs_share("VERSION");
3936 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3937 append_elem(OP_LIST,
3938 prepend_elem(OP_LIST, pack, list(version)),
3939 newSVOP(OP_METHOD_NAMED, 0, meth)));
3943 /* Fake up an import/unimport */
3944 if (arg && arg->op_type == OP_STUB) {
3946 op_getmad(arg,pegop,'S');
3947 imop = arg; /* no import on explicit () */
3949 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3950 imop = NULL; /* use 5.0; */
3952 idop->op_private |= OPpCONST_NOVER;
3958 op_getmad(arg,pegop,'A');
3960 /* Make copy of idop so we don't free it twice */
3961 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3963 /* Fake up a method call to import/unimport */
3965 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3966 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3967 append_elem(OP_LIST,
3968 prepend_elem(OP_LIST, pack, list(arg)),
3969 newSVOP(OP_METHOD_NAMED, 0, meth)));
3972 /* Fake up the BEGIN {}, which does its thing immediately. */
3974 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3977 append_elem(OP_LINESEQ,
3978 append_elem(OP_LINESEQ,
3979 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3980 newSTATEOP(0, NULL, veop)),
3981 newSTATEOP(0, NULL, imop) ));
3983 /* The "did you use incorrect case?" warning used to be here.
3984 * The problem is that on case-insensitive filesystems one
3985 * might get false positives for "use" (and "require"):
3986 * "use Strict" or "require CARP" will work. This causes
3987 * portability problems for the script: in case-strict
3988 * filesystems the script will stop working.
3990 * The "incorrect case" warning checked whether "use Foo"
3991 * imported "Foo" to your namespace, but that is wrong, too:
3992 * there is no requirement nor promise in the language that
3993 * a Foo.pm should or would contain anything in package "Foo".
3995 * There is very little Configure-wise that can be done, either:
3996 * the case-sensitivity of the build filesystem of Perl does not
3997 * help in guessing the case-sensitivity of the runtime environment.
4000 PL_hints |= HINT_BLOCK_SCOPE;
4001 PL_parser->copline = NOLINE;
4002 PL_parser->expect = XSTATE;
4003 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4006 if (!PL_madskills) {
4007 /* FIXME - don't allocate pegop if !PL_madskills */
4016 =head1 Embedding Functions
4018 =for apidoc load_module
4020 Loads the module whose name is pointed to by the string part of name.
4021 Note that the actual module name, not its filename, should be given.
4022 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4023 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4024 (or 0 for no flags). ver, if specified, provides version semantics
4025 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4026 arguments can be used to specify arguments to the module's import()
4027 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4028 terminated with a final NULL pointer. Note that this list can only
4029 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4030 Otherwise at least a single NULL pointer to designate the default
4031 import list is required.
4036 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4040 PERL_ARGS_ASSERT_LOAD_MODULE;
4042 va_start(args, ver);
4043 vload_module(flags, name, ver, &args);
4047 #ifdef PERL_IMPLICIT_CONTEXT
4049 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4053 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4054 va_start(args, ver);
4055 vload_module(flags, name, ver, &args);
4061 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4065 OP * const modname = newSVOP(OP_CONST, 0, name);
4067 PERL_ARGS_ASSERT_VLOAD_MODULE;
4069 modname->op_private |= OPpCONST_BARE;
4071 veop = newSVOP(OP_CONST, 0, ver);
4075 if (flags & PERL_LOADMOD_NOIMPORT) {
4076 imop = sawparens(newNULLLIST());
4078 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4079 imop = va_arg(*args, OP*);
4084 sv = va_arg(*args, SV*);
4086 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4087 sv = va_arg(*args, SV*);
4091 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4092 * that it has a PL_parser to play with while doing that, and also
4093 * that it doesn't mess with any existing parser, by creating a tmp
4094 * new parser with lex_start(). This won't actually be used for much,
4095 * since pp_require() will create another parser for the real work. */
4098 SAVEVPTR(PL_curcop);
4099 lex_start(NULL, NULL, FALSE);
4100 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4101 veop, modname, imop);
4106 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4112 PERL_ARGS_ASSERT_DOFILE;
4114 if (!force_builtin) {
4115 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4116 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4117 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4118 gv = gvp ? *gvp : NULL;
4122 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4123 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4124 append_elem(OP_LIST, term,
4125 scalar(newUNOP(OP_RV2CV, 0,
4126 newGVOP(OP_GV, 0, gv))))));
4129 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4135 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4137 return newBINOP(OP_LSLICE, flags,
4138 list(force_list(subscript)),
4139 list(force_list(listval)) );
4143 S_is_list_assignment(pTHX_ register const OP *o)
4151 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4152 o = cUNOPo->op_first;
4154 flags = o->op_flags;
4156 if (type == OP_COND_EXPR) {
4157 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4158 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4163 yyerror("Assignment to both a list and a scalar");
4167 if (type == OP_LIST &&
4168 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4169 o->op_private & OPpLVAL_INTRO)
4172 if (type == OP_LIST || flags & OPf_PARENS ||
4173 type == OP_RV2AV || type == OP_RV2HV ||
4174 type == OP_ASLICE || type == OP_HSLICE)
4177 if (type == OP_PADAV || type == OP_PADHV)
4180 if (type == OP_RV2SV)
4187 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4193 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4194 return newLOGOP(optype, 0,
4195 mod(scalar(left), optype),
4196 newUNOP(OP_SASSIGN, 0, scalar(right)));
4199 return newBINOP(optype, OPf_STACKED,
4200 mod(scalar(left), optype), scalar(right));
4204 if (is_list_assignment(left)) {
4205 static const char no_list_state[] = "Initialization of state variables"
4206 " in list context currently forbidden";
4208 bool maybe_common_vars = TRUE;
4211 /* Grandfathering $[ assignment here. Bletch.*/
4212 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4213 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4214 left = mod(left, OP_AASSIGN);
4217 else if (left->op_type == OP_CONST) {
4219 /* Result of assignment is always 1 (or we'd be dead already) */
4220 return newSVOP(OP_CONST, 0, newSViv(1));
4222 curop = list(force_list(left));
4223 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4224 o->op_private = (U8)(0 | (flags >> 8));
4226 if ((left->op_type == OP_LIST
4227 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4229 OP* lop = ((LISTOP*)left)->op_first;
4230 maybe_common_vars = FALSE;
4232 if (lop->op_type == OP_PADSV ||
4233 lop->op_type == OP_PADAV ||
4234 lop->op_type == OP_PADHV ||
4235 lop->op_type == OP_PADANY) {
4236 if (!(lop->op_private & OPpLVAL_INTRO))
4237 maybe_common_vars = TRUE;
4239 if (lop->op_private & OPpPAD_STATE) {
4240 if (left->op_private & OPpLVAL_INTRO) {
4241 /* Each variable in state($a, $b, $c) = ... */
4244 /* Each state variable in
4245 (state $a, my $b, our $c, $d, undef) = ... */
4247 yyerror(no_list_state);
4249 /* Each my variable in
4250 (state $a, my $b, our $c, $d, undef) = ... */
4252 } else if (lop->op_type == OP_UNDEF ||
4253 lop->op_type == OP_PUSHMARK) {
4254 /* undef may be interesting in
4255 (state $a, undef, state $c) */
4257 /* Other ops in the list. */
4258 maybe_common_vars = TRUE;
4260 lop = lop->op_sibling;
4263 else if ((left->op_private & OPpLVAL_INTRO)
4264 && ( left->op_type == OP_PADSV
4265 || left->op_type == OP_PADAV
4266 || left->op_type == OP_PADHV
4267 || left->op_type == OP_PADANY))
4269 maybe_common_vars = FALSE;
4270 if (left->op_private & OPpPAD_STATE) {
4271 /* All single variable list context state assignments, hence
4281 yyerror(no_list_state);
4285 /* PL_generation sorcery:
4286 * an assignment like ($a,$b) = ($c,$d) is easier than
4287 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4288 * To detect whether there are common vars, the global var
4289 * PL_generation is incremented for each assign op we compile.
4290 * Then, while compiling the assign op, we run through all the
4291 * variables on both sides of the assignment, setting a spare slot
4292 * in each of them to PL_generation. If any of them already have
4293 * that value, we know we've got commonality. We could use a
4294 * single bit marker, but then we'd have to make 2 passes, first
4295 * to clear the flag, then to test and set it. To find somewhere
4296 * to store these values, evil chicanery is done with SvUVX().
4299 if (maybe_common_vars) {
4302 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4303 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4304 if (curop->op_type == OP_GV) {
4305 GV *gv = cGVOPx_gv(curop);
4307 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4309 GvASSIGN_GENERATION_set(gv, PL_generation);
4311 else if (curop->op_type == OP_PADSV ||
4312 curop->op_type == OP_PADAV ||
4313 curop->op_type == OP_PADHV ||
4314 curop->op_type == OP_PADANY)
4316 if (PAD_COMPNAME_GEN(curop->op_targ)
4317 == (STRLEN)PL_generation)
4319 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4322 else if (curop->op_type == OP_RV2CV)
4324 else if (curop->op_type == OP_RV2SV ||
4325 curop->op_type == OP_RV2AV ||
4326 curop->op_type == OP_RV2HV ||
4327 curop->op_type == OP_RV2GV) {
4328 if (lastop->op_type != OP_GV) /* funny deref? */
4331 else if (curop->op_type == OP_PUSHRE) {
4333 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4334 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4336 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4338 GvASSIGN_GENERATION_set(gv, PL_generation);
4342 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4345 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4347 GvASSIGN_GENERATION_set(gv, PL_generation);
4357 o->op_private |= OPpASSIGN_COMMON;
4360 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4361 OP* tmpop = ((LISTOP*)right)->op_first;
4362 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4363 PMOP * const pm = (PMOP*)tmpop;
4364 if (left->op_type == OP_RV2AV &&
4365 !(left->op_private & OPpLVAL_INTRO) &&
4366 !(o->op_private & OPpASSIGN_COMMON) )
4368 tmpop = ((UNOP*)left)->op_first;
4369 if (tmpop->op_type == OP_GV
4371 && !pm->op_pmreplrootu.op_pmtargetoff
4373 && !pm->op_pmreplrootu.op_pmtargetgv
4377 pm->op_pmreplrootu.op_pmtargetoff
4378 = cPADOPx(tmpop)->op_padix;
4379 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4381 pm->op_pmreplrootu.op_pmtargetgv
4382 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4383 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4385 pm->op_pmflags |= PMf_ONCE;
4386 tmpop = cUNOPo->op_first; /* to list (nulled) */
4387 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4388 tmpop->op_sibling = NULL; /* don't free split */
4389 right->op_next = tmpop->op_next; /* fix starting loc */
4390 op_free(o); /* blow off assign */
4391 right->op_flags &= ~OPf_WANT;
4392 /* "I don't know and I don't care." */
4397 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4398 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4400 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4401 if (SvIOK(sv) && SvIVX(sv) == 0)
4402 sv_setiv(sv, PL_modcount+1);
4410 right = newOP(OP_UNDEF, 0);
4411 if (right->op_type == OP_READLINE) {
4412 right->op_flags |= OPf_STACKED;
4413 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4416 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4417 o = newBINOP(OP_SASSIGN, flags,
4418 scalar(right), mod(scalar(left), OP_SASSIGN) );
4422 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4423 deprecate("assignment to $[");
4425 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4426 o->op_private |= OPpCONST_ARYBASE;
4434 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4437 const U32 seq = intro_my();
4440 NewOp(1101, cop, 1, COP);
4441 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4442 cop->op_type = OP_DBSTATE;
4443 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4446 cop->op_type = OP_NEXTSTATE;
4447 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4449 cop->op_flags = (U8)flags;
4450 CopHINTS_set(cop, PL_hints);
4452 cop->op_private |= NATIVE_HINTS;
4454 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4455 cop->op_next = (OP*)cop;
4458 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4459 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4461 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4462 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4463 if (cop->cop_hints_hash) {
4465 cop->cop_hints_hash->refcounted_he_refcnt++;
4466 HINTS_REFCNT_UNLOCK;
4470 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4472 PL_hints |= HINT_BLOCK_SCOPE;
4473 /* It seems that we need to defer freeing this pointer, as other parts
4474 of the grammar end up wanting to copy it after this op has been
4479 if (PL_parser && PL_parser->copline == NOLINE)
4480 CopLINE_set(cop, CopLINE(PL_curcop));
4482 CopLINE_set(cop, PL_parser->copline);
4484 PL_parser->copline = NOLINE;
4487 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4489 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4491 CopSTASH_set(cop, PL_curstash);
4493 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4494 /* this line can have a breakpoint - store the cop in IV */
4495 AV *av = CopFILEAVx(PL_curcop);
4497 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4498 if (svp && *svp != &PL_sv_undef ) {
4499 (void)SvIOK_on(*svp);
4500 SvIV_set(*svp, PTR2IV(cop));
4505 if (flags & OPf_SPECIAL)
4507 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4512 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4516 PERL_ARGS_ASSERT_NEWLOGOP;
4518 return new_logop(type, flags, &first, &other);
4522 S_search_const(pTHX_ OP *o)
4524 PERL_ARGS_ASSERT_SEARCH_CONST;
4526 switch (o->op_type) {
4530 if (o->op_flags & OPf_KIDS)
4531 return search_const(cUNOPo->op_first);
4538 if (!(o->op_flags & OPf_KIDS))
4540 kid = cLISTOPo->op_first;
4542 switch (kid->op_type) {
4546 kid = kid->op_sibling;
4549 if (kid != cLISTOPo->op_last)
4555 kid = cLISTOPo->op_last;
4557 return search_const(kid);
4565 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4573 int prepend_not = 0;
4575 PERL_ARGS_ASSERT_NEW_LOGOP;
4580 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4581 return newBINOP(type, flags, scalar(first), scalar(other));
4583 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4585 scalarboolean(first);
4586 /* optimize AND and OR ops that have NOTs as children */
4587 if (first->op_type == OP_NOT
4588 && (first->op_flags & OPf_KIDS)
4589 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4590 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4592 if (type == OP_AND || type == OP_OR) {
4598 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4600 prepend_not = 1; /* prepend a NOT op later */
4604 /* search for a constant op that could let us fold the test */
4605 if ((cstop = search_const(first))) {
4606 if (cstop->op_private & OPpCONST_STRICT)
4607 no_bareword_allowed(cstop);
4608 else if ((cstop->op_private & OPpCONST_BARE))
4609 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4610 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4611 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4612 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4614 if (other->op_type == OP_CONST)
4615 other->op_private |= OPpCONST_SHORTCIRCUIT;
4617 OP *newop = newUNOP(OP_NULL, 0, other);
4618 op_getmad(first, newop, '1');
4619 newop->op_targ = type; /* set "was" field */
4623 if (other->op_type == OP_LEAVE)
4624 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4628 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4629 const OP *o2 = other;
4630 if ( ! (o2->op_type == OP_LIST
4631 && (( o2 = cUNOPx(o2)->op_first))
4632 && o2->op_type == OP_PUSHMARK
4633 && (( o2 = o2->op_sibling)) )
4636 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4637 || o2->op_type == OP_PADHV)
4638 && o2->op_private & OPpLVAL_INTRO
4639 && !(o2->op_private & OPpPAD_STATE))
4641 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4642 "Deprecated use of my() in false conditional");
4646 if (first->op_type == OP_CONST)
4647 first->op_private |= OPpCONST_SHORTCIRCUIT;
4649 first = newUNOP(OP_NULL, 0, first);
4650 op_getmad(other, first, '2');
4651 first->op_targ = type; /* set "was" field */
4658 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4659 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4661 const OP * const k1 = ((UNOP*)first)->op_first;
4662 const OP * const k2 = k1->op_sibling;
4664 switch (first->op_type)
4667 if (k2 && k2->op_type == OP_READLINE
4668 && (k2->op_flags & OPf_STACKED)
4669 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4671 warnop = k2->op_type;
4676 if (k1->op_type == OP_READDIR
4677 || k1->op_type == OP_GLOB
4678 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4679 || k1->op_type == OP_EACH)
4681 warnop = ((k1->op_type == OP_NULL)
4682 ? (OPCODE)k1->op_targ : k1->op_type);
4687 const line_t oldline = CopLINE(PL_curcop);
4688 CopLINE_set(PL_curcop, PL_parser->copline);
4689 Perl_warner(aTHX_ packWARN(WARN_MISC),
4690 "Value of %s%s can be \"0\"; test with defined()",
4692 ((warnop == OP_READLINE || warnop == OP_GLOB)
4693 ? " construct" : "() operator"));
4694 CopLINE_set(PL_curcop, oldline);
4701 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4702 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4704 NewOp(1101, logop, 1, LOGOP);
4706 logop->op_type = (OPCODE)type;
4707 logop->op_ppaddr = PL_ppaddr[type];
4708 logop->op_first = first;
4709 logop->op_flags = (U8)(flags | OPf_KIDS);
4710 logop->op_other = LINKLIST(other);
4711 logop->op_private = (U8)(1 | (flags >> 8));
4713 /* establish postfix order */
4714 logop->op_next = LINKLIST(first);
4715 first->op_next = (OP*)logop;
4716 first->op_sibling = other;
4718 CHECKOP(type,logop);
4720 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4727 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4735 PERL_ARGS_ASSERT_NEWCONDOP;
4738 return newLOGOP(OP_AND, 0, first, trueop);
4740 return newLOGOP(OP_OR, 0, first, falseop);
4742 scalarboolean(first);
4743 if ((cstop = search_const(first))) {
4744 /* Left or right arm of the conditional? */
4745 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4746 OP *live = left ? trueop : falseop;
4747 OP *const dead = left ? falseop : trueop;
4748 if (cstop->op_private & OPpCONST_BARE &&
4749 cstop->op_private & OPpCONST_STRICT) {
4750 no_bareword_allowed(cstop);
4753 /* This is all dead code when PERL_MAD is not defined. */
4754 live = newUNOP(OP_NULL, 0, live);
4755 op_getmad(first, live, 'C');
4756 op_getmad(dead, live, left ? 'e' : 't');
4761 if (live->op_type == OP_LEAVE)
4762 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4765 NewOp(1101, logop, 1, LOGOP);
4766 logop->op_type = OP_COND_EXPR;
4767 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4768 logop->op_first = first;
4769 logop->op_flags = (U8)(flags | OPf_KIDS);
4770 logop->op_private = (U8)(1 | (flags >> 8));
4771 logop->op_other = LINKLIST(trueop);
4772 logop->op_next = LINKLIST(falseop);
4774 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4777 /* establish postfix order */
4778 start = LINKLIST(first);
4779 first->op_next = (OP*)logop;
4781 first->op_sibling = trueop;
4782 trueop->op_sibling = falseop;
4783 o = newUNOP(OP_NULL, 0, (OP*)logop);
4785 trueop->op_next = falseop->op_next = o;
4792 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4801 PERL_ARGS_ASSERT_NEWRANGE;
4803 NewOp(1101, range, 1, LOGOP);
4805 range->op_type = OP_RANGE;
4806 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4807 range->op_first = left;
4808 range->op_flags = OPf_KIDS;
4809 leftstart = LINKLIST(left);
4810 range->op_other = LINKLIST(right);
4811 range->op_private = (U8)(1 | (flags >> 8));
4813 left->op_sibling = right;
4815 range->op_next = (OP*)range;
4816 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4817 flop = newUNOP(OP_FLOP, 0, flip);
4818 o = newUNOP(OP_NULL, 0, flop);
4820 range->op_next = leftstart;
4822 left->op_next = flip;
4823 right->op_next = flop;
4825 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4826 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4827 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4828 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4830 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4831 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4834 if (!flip->op_private || !flop->op_private)
4835 linklist(o); /* blow off optimizer unless constant */
4841 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4846 const bool once = block && block->op_flags & OPf_SPECIAL &&
4847 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4849 PERL_UNUSED_ARG(debuggable);
4852 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4853 return block; /* do {} while 0 does once */
4854 if (expr->op_type == OP_READLINE
4855 || expr->op_type == OP_READDIR
4856 || expr->op_type == OP_GLOB
4857 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4858 expr = newUNOP(OP_DEFINED, 0,
4859 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4860 } else if (expr->op_flags & OPf_KIDS) {
4861 const OP * const k1 = ((UNOP*)expr)->op_first;
4862 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4863 switch (expr->op_type) {
4865 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4866 && (k2->op_flags & OPf_STACKED)
4867 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4868 expr = newUNOP(OP_DEFINED, 0, expr);
4872 if (k1 && (k1->op_type == OP_READDIR
4873 || k1->op_type == OP_GLOB
4874 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4875 || k1->op_type == OP_EACH))
4876 expr = newUNOP(OP_DEFINED, 0, expr);
4882 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4883 * op, in listop. This is wrong. [perl #27024] */
4885 block = newOP(OP_NULL, 0);
4886 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4887 o = new_logop(OP_AND, 0, &expr, &listop);
4890 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4892 if (once && o != listop)
4893 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4896 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4898 o->op_flags |= flags;
4900 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4905 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4906 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4915 PERL_UNUSED_ARG(debuggable);
4918 if (expr->op_type == OP_READLINE
4919 || expr->op_type == OP_READDIR
4920 || expr->op_type == OP_GLOB
4921 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4922 expr = newUNOP(OP_DEFINED, 0,
4923 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4924 } else if (expr->op_flags & OPf_KIDS) {
4925 const OP * const k1 = ((UNOP*)expr)->op_first;
4926 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4927 switch (expr->op_type) {
4929 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4930 && (k2->op_flags & OPf_STACKED)
4931 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4932 expr = newUNOP(OP_DEFINED, 0, expr);
4936 if (k1 && (k1->op_type == OP_READDIR
4937 || k1->op_type == OP_GLOB
4938 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4939 || k1->op_type == OP_EACH))
4940 expr = newUNOP(OP_DEFINED, 0, expr);
4947 block = newOP(OP_NULL, 0);
4948 else if (cont || has_my) {
4949 block = scope(block);
4953 next = LINKLIST(cont);
4956 OP * const unstack = newOP(OP_UNSTACK, 0);
4959 cont = append_elem(OP_LINESEQ, cont, unstack);
4963 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4965 redo = LINKLIST(listop);
4968 PL_parser->copline = (line_t)whileline;
4970 o = new_logop(OP_AND, 0, &expr, &listop);
4971 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4972 op_free(expr); /* oops, it's a while (0) */
4974 return NULL; /* listop already freed by new_logop */
4977 ((LISTOP*)listop)->op_last->op_next =
4978 (o == listop ? redo : LINKLIST(o));
4984 NewOp(1101,loop,1,LOOP);
4985 loop->op_type = OP_ENTERLOOP;
4986 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4987 loop->op_private = 0;
4988 loop->op_next = (OP*)loop;
4991 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4993 loop->op_redoop = redo;
4994 loop->op_lastop = o;
4995 o->op_private |= loopflags;
4998 loop->op_nextop = next;
5000 loop->op_nextop = o;
5002 o->op_flags |= flags;
5003 o->op_private |= (flags >> 8);
5008 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
5013 PADOFFSET padoff = 0;
5018 PERL_ARGS_ASSERT_NEWFOROP;
5021 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5022 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5023 sv->op_type = OP_RV2GV;
5024 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5026 /* The op_type check is needed to prevent a possible segfault
5027 * if the loop variable is undeclared and 'strict vars' is in
5028 * effect. This is illegal but is nonetheless parsed, so we
5029 * may reach this point with an OP_CONST where we're expecting
5032 if (cUNOPx(sv)->op_first->op_type == OP_GV
5033 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5034 iterpflags |= OPpITER_DEF;
5036 else if (sv->op_type == OP_PADSV) { /* private variable */
5037 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5038 padoff = sv->op_targ;
5048 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5050 SV *const namesv = PAD_COMPNAME_SV(padoff);
5052 const char *const name = SvPV_const(namesv, len);
5054 if (len == 2 && name[0] == '$' && name[1] == '_')
5055 iterpflags |= OPpITER_DEF;
5059 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5060 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5061 sv = newGVOP(OP_GV, 0, PL_defgv);
5066 iterpflags |= OPpITER_DEF;
5068 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5069 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5070 iterflags |= OPf_STACKED;
5072 else if (expr->op_type == OP_NULL &&
5073 (expr->op_flags & OPf_KIDS) &&
5074 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5076 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5077 * set the STACKED flag to indicate that these values are to be
5078 * treated as min/max values by 'pp_iterinit'.
5080 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5081 LOGOP* const range = (LOGOP*) flip->op_first;
5082 OP* const left = range->op_first;
5083 OP* const right = left->op_sibling;
5086 range->op_flags &= ~OPf_KIDS;
5087 range->op_first = NULL;
5089 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5090 listop->op_first->op_next = range->op_next;
5091 left->op_next = range->op_other;
5092 right->op_next = (OP*)listop;
5093 listop->op_next = listop->op_first;
5096 op_getmad(expr,(OP*)listop,'O');
5100 expr = (OP*)(listop);
5102 iterflags |= OPf_STACKED;
5105 expr = mod(force_list(expr), OP_GREPSTART);
5108 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5109 append_elem(OP_LIST, expr, scalar(sv))));
5110 assert(!loop->op_next);
5111 /* for my $x () sets OPpLVAL_INTRO;
5112 * for our $x () sets OPpOUR_INTRO */
5113 loop->op_private = (U8)iterpflags;
5114 #ifdef PL_OP_SLAB_ALLOC
5117 NewOp(1234,tmp,1,LOOP);
5118 Copy(loop,tmp,1,LISTOP);
5119 S_op_destroy(aTHX_ (OP*)loop);
5123 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5125 loop->op_targ = padoff;
5126 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5128 op_getmad(madsv, (OP*)loop, 'v');
5129 PL_parser->copline = forline;
5130 return newSTATEOP(0, label, wop);
5134 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5139 PERL_ARGS_ASSERT_NEWLOOPEX;
5141 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5143 if (type != OP_GOTO || label->op_type == OP_CONST) {
5144 /* "last()" means "last" */
5145 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5146 o = newOP(type, OPf_SPECIAL);
5148 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5149 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5153 op_getmad(label,o,'L');
5159 /* Check whether it's going to be a goto &function */
5160 if (label->op_type == OP_ENTERSUB
5161 && !(label->op_flags & OPf_STACKED))
5162 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5163 o = newUNOP(type, OPf_STACKED, label);
5165 PL_hints |= HINT_BLOCK_SCOPE;
5169 /* if the condition is a literal array or hash
5170 (or @{ ... } etc), make a reference to it.
5173 S_ref_array_or_hash(pTHX_ OP *cond)
5176 && (cond->op_type == OP_RV2AV
5177 || cond->op_type == OP_PADAV
5178 || cond->op_type == OP_RV2HV
5179 || cond->op_type == OP_PADHV))
5181 return newUNOP(OP_REFGEN,
5182 0, mod(cond, OP_REFGEN));
5188 /* These construct the optree fragments representing given()
5191 entergiven and enterwhen are LOGOPs; the op_other pointer
5192 points up to the associated leave op. We need this so we
5193 can put it in the context and make break/continue work.
5194 (Also, of course, pp_enterwhen will jump straight to
5195 op_other if the match fails.)
5199 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5200 I32 enter_opcode, I32 leave_opcode,
5201 PADOFFSET entertarg)
5207 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5209 NewOp(1101, enterop, 1, LOGOP);
5210 enterop->op_type = (Optype)enter_opcode;
5211 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5212 enterop->op_flags = (U8) OPf_KIDS;
5213 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5214 enterop->op_private = 0;
5216 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5219 enterop->op_first = scalar(cond);
5220 cond->op_sibling = block;
5222 o->op_next = LINKLIST(cond);
5223 cond->op_next = (OP *) enterop;
5226 /* This is a default {} block */
5227 enterop->op_first = block;
5228 enterop->op_flags |= OPf_SPECIAL;
5230 o->op_next = (OP *) enterop;
5233 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5234 entergiven and enterwhen both
5237 enterop->op_next = LINKLIST(block);
5238 block->op_next = enterop->op_other = o;
5243 /* Does this look like a boolean operation? For these purposes
5244 a boolean operation is:
5245 - a subroutine call [*]
5246 - a logical connective
5247 - a comparison operator
5248 - a filetest operator, with the exception of -s -M -A -C
5249 - defined(), exists() or eof()
5250 - /$re/ or $foo =~ /$re/
5252 [*] possibly surprising
5255 S_looks_like_bool(pTHX_ const OP *o)
5259 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5261 switch(o->op_type) {
5264 return looks_like_bool(cLOGOPo->op_first);
5268 looks_like_bool(cLOGOPo->op_first)
5269 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5273 o->op_flags & OPf_KIDS
5274 && looks_like_bool(cUNOPo->op_first));
5277 return looks_like_bool(cUNOPo->op_first);
5282 case OP_NOT: case OP_XOR:
5284 case OP_EQ: case OP_NE: case OP_LT:
5285 case OP_GT: case OP_LE: case OP_GE:
5287 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5288 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5290 case OP_SEQ: case OP_SNE: case OP_SLT:
5291 case OP_SGT: case OP_SLE: case OP_SGE:
5295 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5296 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5297 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5298 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5299 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5300 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5301 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5302 case OP_FTTEXT: case OP_FTBINARY:
5304 case OP_DEFINED: case OP_EXISTS:
5305 case OP_MATCH: case OP_EOF:
5312 /* Detect comparisons that have been optimized away */
5313 if (cSVOPo->op_sv == &PL_sv_yes
5314 || cSVOPo->op_sv == &PL_sv_no)
5327 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5330 PERL_ARGS_ASSERT_NEWGIVENOP;
5331 return newGIVWHENOP(
5332 ref_array_or_hash(cond),
5334 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5338 /* If cond is null, this is a default {} block */
5340 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5342 const bool cond_llb = (!cond || looks_like_bool(cond));
5345 PERL_ARGS_ASSERT_NEWWHENOP;
5350 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5352 scalar(ref_array_or_hash(cond)));
5355 return newGIVWHENOP(
5357 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5358 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5362 =for apidoc cv_undef
5364 Clear out all the active components of a CV. This can happen either
5365 by an explicit C<undef &foo>, or by the reference count going to zero.
5366 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5367 children can still follow the full lexical scope chain.
5373 Perl_cv_undef(pTHX_ CV *cv)
5377 PERL_ARGS_ASSERT_CV_UNDEF;
5379 DEBUG_X(PerlIO_printf(Perl_debug_log,
5380 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5381 PTR2UV(cv), PTR2UV(PL_comppad))
5385 if (CvFILE(cv) && !CvISXSUB(cv)) {
5386 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5387 Safefree(CvFILE(cv));
5392 if (!CvISXSUB(cv) && CvROOT(cv)) {
5393 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5394 Perl_croak(aTHX_ "Can't undef active subroutine");
5397 PAD_SAVE_SETNULLPAD();
5399 op_free(CvROOT(cv));
5404 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5409 /* remove CvOUTSIDE unless this is an undef rather than a free */
5410 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5411 if (!CvWEAKOUTSIDE(cv))
5412 SvREFCNT_dec(CvOUTSIDE(cv));
5413 CvOUTSIDE(cv) = NULL;
5416 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5419 if (CvISXSUB(cv) && CvXSUB(cv)) {
5422 /* delete all flags except WEAKOUTSIDE */
5423 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5427 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5430 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5432 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5433 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5434 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5435 || (p && (len != SvCUR(cv) /* Not the same length. */
5436 || memNE(p, SvPVX_const(cv), len))))
5437 && ckWARN_d(WARN_PROTOTYPE)) {
5438 SV* const msg = sv_newmortal();
5442 gv_efullname3(name = sv_newmortal(), gv, NULL);
5443 sv_setpvs(msg, "Prototype mismatch:");
5445 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5447 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5449 sv_catpvs(msg, ": none");
5450 sv_catpvs(msg, " vs ");
5452 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5454 sv_catpvs(msg, "none");
5455 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5459 static void const_sv_xsub(pTHX_ CV* cv);
5463 =head1 Optree Manipulation Functions
5465 =for apidoc cv_const_sv
5467 If C<cv> is a constant sub eligible for inlining. returns the constant
5468 value returned by the sub. Otherwise, returns NULL.
5470 Constant subs can be created with C<newCONSTSUB> or as described in
5471 L<perlsub/"Constant Functions">.
5476 Perl_cv_const_sv(pTHX_ const CV *const cv)
5478 PERL_UNUSED_CONTEXT;
5481 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5483 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5486 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5487 * Can be called in 3 ways:
5490 * look for a single OP_CONST with attached value: return the value
5492 * cv && CvCLONE(cv) && !CvCONST(cv)
5494 * examine the clone prototype, and if contains only a single
5495 * OP_CONST referencing a pad const, or a single PADSV referencing
5496 * an outer lexical, return a non-zero value to indicate the CV is
5497 * a candidate for "constizing" at clone time
5501 * We have just cloned an anon prototype that was marked as a const
5502 * candidiate. Try to grab the current value, and in the case of
5503 * PADSV, ignore it if it has multiple references. Return the value.
5507 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5518 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5519 o = cLISTOPo->op_first->op_sibling;
5521 for (; o; o = o->op_next) {
5522 const OPCODE type = o->op_type;
5524 if (sv && o->op_next == o)
5526 if (o->op_next != o) {
5527 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5529 if (type == OP_DBSTATE)
5532 if (type == OP_LEAVESUB || type == OP_RETURN)
5536 if (type == OP_CONST && cSVOPo->op_sv)
5538 else if (cv && type == OP_CONST) {
5539 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5543 else if (cv && type == OP_PADSV) {
5544 if (CvCONST(cv)) { /* newly cloned anon */
5545 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5546 /* the candidate should have 1 ref from this pad and 1 ref
5547 * from the parent */
5548 if (!sv || SvREFCNT(sv) != 2)
5555 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5556 sv = &PL_sv_undef; /* an arbitrary non-null value */
5571 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5574 /* This would be the return value, but the return cannot be reached. */
5575 OP* pegop = newOP(OP_NULL, 0);
5578 PERL_UNUSED_ARG(floor);
5588 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5590 NORETURN_FUNCTION_END;
5595 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5597 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5601 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5607 register CV *cv = NULL;
5609 /* If the subroutine has no body, no attributes, and no builtin attributes
5610 then it's just a sub declaration, and we may be able to get away with
5611 storing with a placeholder scalar in the symbol table, rather than a
5612 full GV and CV. If anything is present then it will take a full CV to
5614 const I32 gv_fetch_flags
5615 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5617 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5618 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5622 assert(proto->op_type == OP_CONST);
5623 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5629 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5631 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5632 SV * const sv = sv_newmortal();
5633 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5634 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5635 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5636 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5638 } else if (PL_curstash) {
5639 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5642 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5646 if (!PL_madskills) {
5655 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5656 maximum a prototype before. */
5657 if (SvTYPE(gv) > SVt_NULL) {
5658 if (!SvPOK((const SV *)gv)
5659 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5661 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5663 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5666 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5668 sv_setiv(MUTABLE_SV(gv), -1);
5670 SvREFCNT_dec(PL_compcv);
5671 cv = PL_compcv = NULL;
5675 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5677 if (!block || !ps || *ps || attrs
5678 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5680 || block->op_type == OP_NULL
5685 const_sv = op_const_sv(block, NULL);
5688 const bool exists = CvROOT(cv) || CvXSUB(cv);
5690 /* if the subroutine doesn't exist and wasn't pre-declared
5691 * with a prototype, assume it will be AUTOLOADed,
5692 * skipping the prototype check
5694 if (exists || SvPOK(cv))
5695 cv_ckproto_len(cv, gv, ps, ps_len);
5696 /* already defined (or promised)? */
5697 if (exists || GvASSUMECV(gv)) {
5700 || block->op_type == OP_NULL
5703 if (CvFLAGS(PL_compcv)) {
5704 /* might have had built-in attrs applied */
5705 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5707 /* just a "sub foo;" when &foo is already defined */
5708 SAVEFREESV(PL_compcv);
5713 && block->op_type != OP_NULL
5716 if (ckWARN(WARN_REDEFINE)
5718 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5720 const line_t oldline = CopLINE(PL_curcop);
5721 if (PL_parser && PL_parser->copline != NOLINE)
5722 CopLINE_set(PL_curcop, PL_parser->copline);
5723 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5724 CvCONST(cv) ? "Constant subroutine %s redefined"
5725 : "Subroutine %s redefined", name);
5726 CopLINE_set(PL_curcop, oldline);
5729 if (!PL_minus_c) /* keep old one around for madskills */
5732 /* (PL_madskills unset in used file.) */
5740 SvREFCNT_inc_simple_void_NN(const_sv);
5742 assert(!CvROOT(cv) && !CvCONST(cv));
5743 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5744 CvXSUBANY(cv).any_ptr = const_sv;
5745 CvXSUB(cv) = const_sv_xsub;
5751 cv = newCONSTSUB(NULL, name, const_sv);
5753 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5754 (CvGV(cv) && GvSTASH(CvGV(cv)))
5763 SvREFCNT_dec(PL_compcv);
5767 if (cv) { /* must reuse cv if autoloaded */
5768 /* transfer PL_compcv to cv */
5771 && block->op_type != OP_NULL
5775 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5776 if (!CvWEAKOUTSIDE(cv))
5777 SvREFCNT_dec(CvOUTSIDE(cv));
5778 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5779 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5780 CvOUTSIDE(PL_compcv) = 0;
5781 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5782 CvPADLIST(PL_compcv) = 0;
5783 /* inner references to PL_compcv must be fixed up ... */
5784 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5785 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5786 ++PL_sub_generation;
5789 /* Might have had built-in attributes applied -- propagate them. */
5790 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5792 /* ... before we throw it away */
5793 SvREFCNT_dec(PL_compcv);
5801 if (strEQ(name, "import")) {
5802 PL_formfeed = MUTABLE_SV(cv);
5803 /* diag_listed_as: SKIPME */
5804 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
5808 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5813 CvFILE_set_from_cop(cv, PL_curcop);
5814 CvSTASH(cv) = PL_curstash;
5817 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5818 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5819 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5823 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5825 if (PL_parser && PL_parser->error_count) {
5829 const char *s = strrchr(name, ':');
5831 if (strEQ(s, "BEGIN")) {
5832 const char not_safe[] =
5833 "BEGIN not safe after errors--compilation aborted";
5834 if (PL_in_eval & EVAL_KEEPERR)
5835 Perl_croak(aTHX_ not_safe);
5837 /* force display of errors found but not reported */
5838 sv_catpv(ERRSV, not_safe);
5839 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5848 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5849 the debugger could be able to set a breakpoint in, so signal to
5850 pp_entereval that it should not throw away any saved lines at scope
5853 PL_breakable_sub_gen++;
5855 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5856 mod(scalarseq(block), OP_LEAVESUBLV));
5857 block->op_attached = 1;
5860 /* This makes sub {}; work as expected. */
5861 if (block->op_type == OP_STUB) {
5862 OP* const newblock = newSTATEOP(0, NULL, 0);
5864 op_getmad(block,newblock,'B');
5871 block->op_attached = 1;
5872 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5874 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5875 OpREFCNT_set(CvROOT(cv), 1);
5876 CvSTART(cv) = LINKLIST(CvROOT(cv));
5877 CvROOT(cv)->op_next = 0;
5878 CALL_PEEP(CvSTART(cv));
5880 /* now that optimizer has done its work, adjust pad values */
5882 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5885 assert(!CvCONST(cv));
5886 if (ps && !*ps && op_const_sv(block, cv))
5891 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5892 SV * const sv = newSV(0);
5893 SV * const tmpstr = sv_newmortal();
5894 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5895 GV_ADDMULTI, SVt_PVHV);
5898 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5900 (long)PL_subline, (long)CopLINE(PL_curcop));
5901 gv_efullname3(tmpstr, gv, NULL);
5902 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5903 SvCUR(tmpstr), sv, 0);
5904 hv = GvHVn(db_postponed);
5905 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5906 CV * const pcv = GvCV(db_postponed);
5912 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5917 if (name && ! (PL_parser && PL_parser->error_count))
5918 process_special_blocks(name, gv, cv);
5923 PL_parser->copline = NOLINE;
5929 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5932 const char *const colon = strrchr(fullname,':');
5933 const char *const name = colon ? colon + 1 : fullname;
5935 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5938 if (strEQ(name, "BEGIN")) {
5939 const I32 oldscope = PL_scopestack_ix;
5941 SAVECOPFILE(&PL_compiling);
5942 SAVECOPLINE(&PL_compiling);
5944 DEBUG_x( dump_sub(gv) );
5945 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5946 GvCV(gv) = 0; /* cv has been hijacked */
5947 call_list(oldscope, PL_beginav);
5949 PL_curcop = &PL_compiling;
5950 CopHINTS_set(&PL_compiling, PL_hints);
5957 if strEQ(name, "END") {
5958 DEBUG_x( dump_sub(gv) );
5959 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5962 } else if (*name == 'U') {
5963 if (strEQ(name, "UNITCHECK")) {
5964 /* It's never too late to run a unitcheck block */
5965 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5969 } else if (*name == 'C') {
5970 if (strEQ(name, "CHECK")) {
5972 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5973 "Too late to run CHECK block");
5974 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5978 } else if (*name == 'I') {
5979 if (strEQ(name, "INIT")) {
5981 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5982 "Too late to run INIT block");
5983 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5989 DEBUG_x( dump_sub(gv) );
5990 GvCV(gv) = 0; /* cv has been hijacked */
5995 =for apidoc newCONSTSUB
5997 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5998 eligible for inlining at compile-time.
6000 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6001 which won't be called if used as a destructor, but will suppress the overhead
6002 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6009 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6014 const char *const file = CopFILE(PL_curcop);
6016 SV *const temp_sv = CopFILESV(PL_curcop);
6017 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6022 if (IN_PERL_RUNTIME) {
6023 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6024 * an op shared between threads. Use a non-shared COP for our
6026 SAVEVPTR(PL_curcop);
6027 PL_curcop = &PL_compiling;
6029 SAVECOPLINE(PL_curcop);
6030 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6033 PL_hints &= ~HINT_BLOCK_SCOPE;
6036 SAVESPTR(PL_curstash);
6037 SAVECOPSTASH(PL_curcop);
6038 PL_curstash = stash;
6039 CopSTASH_set(PL_curcop,stash);
6042 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6043 and so doesn't get free()d. (It's expected to be from the C pre-
6044 processor __FILE__ directive). But we need a dynamically allocated one,
6045 and we need it to get freed. */
6046 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6047 XS_DYNAMIC_FILENAME);
6048 CvXSUBANY(cv).any_ptr = sv;
6053 CopSTASH_free(PL_curcop);
6061 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6062 const char *const filename, const char *const proto,
6065 CV *cv = newXS(name, subaddr, filename);
6067 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6069 if (flags & XS_DYNAMIC_FILENAME) {
6070 /* We need to "make arrangements" (ie cheat) to ensure that the
6071 filename lasts as long as the PVCV we just created, but also doesn't
6073 STRLEN filename_len = strlen(filename);
6074 STRLEN proto_and_file_len = filename_len;
6075 char *proto_and_file;
6079 proto_len = strlen(proto);
6080 proto_and_file_len += proto_len;
6082 Newx(proto_and_file, proto_and_file_len + 1, char);
6083 Copy(proto, proto_and_file, proto_len, char);
6084 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6087 proto_and_file = savepvn(filename, filename_len);
6090 /* This gets free()d. :-) */
6091 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6092 SV_HAS_TRAILING_NUL);
6094 /* This gives us the correct prototype, rather than one with the
6095 file name appended. */
6096 SvCUR_set(cv, proto_len);
6100 CvFILE(cv) = proto_and_file + proto_len;
6102 sv_setpv(MUTABLE_SV(cv), proto);
6108 =for apidoc U||newXS
6110 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6111 static storage, as it is used directly as CvFILE(), without a copy being made.
6117 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6120 GV * const gv = gv_fetchpv(name ? name :
6121 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6122 GV_ADDMULTI, SVt_PVCV);
6125 PERL_ARGS_ASSERT_NEWXS;
6128 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6130 if ((cv = (name ? GvCV(gv) : NULL))) {
6132 /* just a cached method */
6136 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6137 /* already defined (or promised) */
6138 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6139 if (ckWARN(WARN_REDEFINE)) {
6140 GV * const gvcv = CvGV(cv);
6142 HV * const stash = GvSTASH(gvcv);
6144 const char *redefined_name = HvNAME_get(stash);
6145 if ( strEQ(redefined_name,"autouse") ) {
6146 const line_t oldline = CopLINE(PL_curcop);
6147 if (PL_parser && PL_parser->copline != NOLINE)
6148 CopLINE_set(PL_curcop, PL_parser->copline);
6149 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6150 CvCONST(cv) ? "Constant subroutine %s redefined"
6151 : "Subroutine %s redefined"
6153 CopLINE_set(PL_curcop, oldline);
6163 if (cv) /* must reuse cv if autoloaded */
6166 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6170 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6174 (void)gv_fetchfile(filename);
6175 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6176 an external constant string */
6178 CvXSUB(cv) = subaddr;
6181 process_special_blocks(name, gv, cv);
6193 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6198 OP* pegop = newOP(OP_NULL, 0);
6202 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6203 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6206 if ((cv = GvFORM(gv))) {
6207 if (ckWARN(WARN_REDEFINE)) {
6208 const line_t oldline = CopLINE(PL_curcop);
6209 if (PL_parser && PL_parser->copline != NOLINE)
6210 CopLINE_set(PL_curcop, PL_parser->copline);
6212 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6213 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6215 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6216 "Format STDOUT redefined");
6218 CopLINE_set(PL_curcop, oldline);
6225 CvFILE_set_from_cop(cv, PL_curcop);
6228 pad_tidy(padtidy_FORMAT);
6229 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6230 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6231 OpREFCNT_set(CvROOT(cv), 1);
6232 CvSTART(cv) = LINKLIST(CvROOT(cv));
6233 CvROOT(cv)->op_next = 0;
6234 CALL_PEEP(CvSTART(cv));
6236 op_getmad(o,pegop,'n');
6237 op_getmad_weak(block, pegop, 'b');
6242 PL_parser->copline = NOLINE;
6250 Perl_newANONLIST(pTHX_ OP *o)
6252 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6256 Perl_newANONHASH(pTHX_ OP *o)
6258 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6262 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6264 return newANONATTRSUB(floor, proto, NULL, block);
6268 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6270 return newUNOP(OP_REFGEN, 0,
6271 newSVOP(OP_ANONCODE, 0,
6272 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6276 Perl_oopsAV(pTHX_ OP *o)
6280 PERL_ARGS_ASSERT_OOPSAV;
6282 switch (o->op_type) {
6284 o->op_type = OP_PADAV;
6285 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6286 return ref(o, OP_RV2AV);
6289 o->op_type = OP_RV2AV;
6290 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6295 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6302 Perl_oopsHV(pTHX_ OP *o)
6306 PERL_ARGS_ASSERT_OOPSHV;
6308 switch (o->op_type) {
6311 o->op_type = OP_PADHV;
6312 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6313 return ref(o, OP_RV2HV);
6317 o->op_type = OP_RV2HV;
6318 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6323 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6330 Perl_newAVREF(pTHX_ OP *o)
6334 PERL_ARGS_ASSERT_NEWAVREF;
6336 if (o->op_type == OP_PADANY) {
6337 o->op_type = OP_PADAV;
6338 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6341 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6342 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6343 "Using an array as a reference is deprecated");
6345 return newUNOP(OP_RV2AV, 0, scalar(o));
6349 Perl_newGVREF(pTHX_ I32 type, OP *o)
6351 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6352 return newUNOP(OP_NULL, 0, o);
6353 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6357 Perl_newHVREF(pTHX_ OP *o)
6361 PERL_ARGS_ASSERT_NEWHVREF;
6363 if (o->op_type == OP_PADANY) {
6364 o->op_type = OP_PADHV;
6365 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6368 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6369 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6370 "Using a hash as a reference is deprecated");
6372 return newUNOP(OP_RV2HV, 0, scalar(o));
6376 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6378 return newUNOP(OP_RV2CV, flags, scalar(o));
6382 Perl_newSVREF(pTHX_ OP *o)
6386 PERL_ARGS_ASSERT_NEWSVREF;
6388 if (o->op_type == OP_PADANY) {
6389 o->op_type = OP_PADSV;
6390 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6393 return newUNOP(OP_RV2SV, 0, scalar(o));
6396 /* Check routines. See the comments at the top of this file for details
6397 * on when these are called */
6400 Perl_ck_anoncode(pTHX_ OP *o)
6402 PERL_ARGS_ASSERT_CK_ANONCODE;
6404 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6406 cSVOPo->op_sv = NULL;
6411 Perl_ck_bitop(pTHX_ OP *o)
6415 PERL_ARGS_ASSERT_CK_BITOP;
6417 #define OP_IS_NUMCOMPARE(op) \
6418 ((op) == OP_LT || (op) == OP_I_LT || \
6419 (op) == OP_GT || (op) == OP_I_GT || \
6420 (op) == OP_LE || (op) == OP_I_LE || \
6421 (op) == OP_GE || (op) == OP_I_GE || \
6422 (op) == OP_EQ || (op) == OP_I_EQ || \
6423 (op) == OP_NE || (op) == OP_I_NE || \
6424 (op) == OP_NCMP || (op) == OP_I_NCMP)
6425 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6426 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6427 && (o->op_type == OP_BIT_OR
6428 || o->op_type == OP_BIT_AND
6429 || o->op_type == OP_BIT_XOR))
6431 const OP * const left = cBINOPo->op_first;
6432 const OP * const right = left->op_sibling;
6433 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6434 (left->op_flags & OPf_PARENS) == 0) ||
6435 (OP_IS_NUMCOMPARE(right->op_type) &&
6436 (right->op_flags & OPf_PARENS) == 0))
6437 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6438 "Possible precedence problem on bitwise %c operator",
6439 o->op_type == OP_BIT_OR ? '|'
6440 : o->op_type == OP_BIT_AND ? '&' : '^'
6447 Perl_ck_concat(pTHX_ OP *o)
6449 const OP * const kid = cUNOPo->op_first;
6451 PERL_ARGS_ASSERT_CK_CONCAT;
6452 PERL_UNUSED_CONTEXT;
6454 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6455 !(kUNOP->op_first->op_flags & OPf_MOD))
6456 o->op_flags |= OPf_STACKED;
6461 Perl_ck_spair(pTHX_ OP *o)
6465 PERL_ARGS_ASSERT_CK_SPAIR;
6467 if (o->op_flags & OPf_KIDS) {
6470 const OPCODE type = o->op_type;
6471 o = modkids(ck_fun(o), type);
6472 kid = cUNOPo->op_first;
6473 newop = kUNOP->op_first->op_sibling;
6475 const OPCODE type = newop->op_type;
6476 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6477 type == OP_PADAV || type == OP_PADHV ||
6478 type == OP_RV2AV || type == OP_RV2HV)
6482 op_getmad(kUNOP->op_first,newop,'K');
6484 op_free(kUNOP->op_first);
6486 kUNOP->op_first = newop;
6488 o->op_ppaddr = PL_ppaddr[++o->op_type];
6493 Perl_ck_delete(pTHX_ OP *o)
6495 PERL_ARGS_ASSERT_CK_DELETE;
6499 if (o->op_flags & OPf_KIDS) {
6500 OP * const kid = cUNOPo->op_first;
6501 switch (kid->op_type) {
6503 o->op_flags |= OPf_SPECIAL;
6506 o->op_private |= OPpSLICE;
6509 o->op_flags |= OPf_SPECIAL;
6514 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6517 if (kid->op_private & OPpLVAL_INTRO)
6518 o->op_private |= OPpLVAL_INTRO;
6525 Perl_ck_die(pTHX_ OP *o)
6527 PERL_ARGS_ASSERT_CK_DIE;
6530 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6536 Perl_ck_eof(pTHX_ OP *o)
6540 PERL_ARGS_ASSERT_CK_EOF;
6542 if (o->op_flags & OPf_KIDS) {
6543 if (cLISTOPo->op_first->op_type == OP_STUB) {
6545 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6547 op_getmad(o,newop,'O');
6559 Perl_ck_eval(pTHX_ OP *o)
6563 PERL_ARGS_ASSERT_CK_EVAL;
6565 PL_hints |= HINT_BLOCK_SCOPE;
6566 if (o->op_flags & OPf_KIDS) {
6567 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6570 o->op_flags &= ~OPf_KIDS;
6573 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6579 cUNOPo->op_first = 0;
6584 NewOp(1101, enter, 1, LOGOP);
6585 enter->op_type = OP_ENTERTRY;
6586 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6587 enter->op_private = 0;
6589 /* establish postfix order */
6590 enter->op_next = (OP*)enter;
6592 CHECKOP(OP_ENTERTRY, enter);
6594 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6595 o->op_type = OP_LEAVETRY;
6596 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6597 enter->op_other = o;
6598 op_getmad(oldo,o,'O');
6612 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6613 op_getmad(oldo,o,'O');
6615 o->op_targ = (PADOFFSET)PL_hints;
6616 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6617 /* Store a copy of %^H that pp_entereval can pick up. */
6618 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6619 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6620 cUNOPo->op_first->op_sibling = hhop;
6621 o->op_private |= OPpEVAL_HAS_HH;
6627 Perl_ck_exit(pTHX_ OP *o)
6629 PERL_ARGS_ASSERT_CK_EXIT;
6632 HV * const table = GvHV(PL_hintgv);
6634 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6635 if (svp && *svp && SvTRUE(*svp))
6636 o->op_private |= OPpEXIT_VMSISH;
6638 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6644 Perl_ck_exec(pTHX_ OP *o)
6646 PERL_ARGS_ASSERT_CK_EXEC;
6648 if (o->op_flags & OPf_STACKED) {
6651 kid = cUNOPo->op_first->op_sibling;
6652 if (kid->op_type == OP_RV2GV)
6661 Perl_ck_exists(pTHX_ OP *o)
6665 PERL_ARGS_ASSERT_CK_EXISTS;
6668 if (o->op_flags & OPf_KIDS) {
6669 OP * const kid = cUNOPo->op_first;
6670 if (kid->op_type == OP_ENTERSUB) {
6671 (void) ref(kid, o->op_type);
6672 if (kid->op_type != OP_RV2CV
6673 && !(PL_parser && PL_parser->error_count))
6674 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6676 o->op_private |= OPpEXISTS_SUB;
6678 else if (kid->op_type == OP_AELEM)
6679 o->op_flags |= OPf_SPECIAL;
6680 else if (kid->op_type != OP_HELEM)
6681 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6689 Perl_ck_rvconst(pTHX_ register OP *o)
6692 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6694 PERL_ARGS_ASSERT_CK_RVCONST;
6696 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6697 if (o->op_type == OP_RV2CV)
6698 o->op_private &= ~1;
6700 if (kid->op_type == OP_CONST) {
6703 SV * const kidsv = kid->op_sv;
6705 /* Is it a constant from cv_const_sv()? */
6706 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6707 SV * const rsv = SvRV(kidsv);
6708 const svtype type = SvTYPE(rsv);
6709 const char *badtype = NULL;
6711 switch (o->op_type) {
6713 if (type > SVt_PVMG)
6714 badtype = "a SCALAR";
6717 if (type != SVt_PVAV)
6718 badtype = "an ARRAY";
6721 if (type != SVt_PVHV)
6725 if (type != SVt_PVCV)
6730 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6733 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6734 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6735 /* If this is an access to a stash, disable "strict refs", because
6736 * stashes aren't auto-vivified at compile-time (unless we store
6737 * symbols in them), and we don't want to produce a run-time
6738 * stricture error when auto-vivifying the stash. */
6739 const char *s = SvPV_nolen(kidsv);
6740 const STRLEN l = SvCUR(kidsv);
6741 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6742 o->op_private &= ~HINT_STRICT_REFS;
6744 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6745 const char *badthing;
6746 switch (o->op_type) {
6748 badthing = "a SCALAR";
6751 badthing = "an ARRAY";
6754 badthing = "a HASH";
6762 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6763 SVfARG(kidsv), badthing);
6766 * This is a little tricky. We only want to add the symbol if we
6767 * didn't add it in the lexer. Otherwise we get duplicate strict
6768 * warnings. But if we didn't add it in the lexer, we must at
6769 * least pretend like we wanted to add it even if it existed before,
6770 * or we get possible typo warnings. OPpCONST_ENTERED says
6771 * whether the lexer already added THIS instance of this symbol.
6773 iscv = (o->op_type == OP_RV2CV) * 2;
6775 gv = gv_fetchsv(kidsv,
6776 iscv | !(kid->op_private & OPpCONST_ENTERED),
6779 : o->op_type == OP_RV2SV
6781 : o->op_type == OP_RV2AV
6783 : o->op_type == OP_RV2HV
6786 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6788 kid->op_type = OP_GV;
6789 SvREFCNT_dec(kid->op_sv);
6791 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6792 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6793 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6795 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6797 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6799 kid->op_private = 0;
6800 kid->op_ppaddr = PL_ppaddr[OP_GV];
6807 Perl_ck_ftst(pTHX_ OP *o)
6810 const I32 type = o->op_type;
6812 PERL_ARGS_ASSERT_CK_FTST;
6814 if (o->op_flags & OPf_REF) {
6817 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6818 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6819 const OPCODE kidtype = kid->op_type;
6821 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6822 OP * const newop = newGVOP(type, OPf_REF,
6823 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6825 op_getmad(o,newop,'O');
6831 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6832 o->op_private |= OPpFT_ACCESS;
6833 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6834 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6835 o->op_private |= OPpFT_STACKED;
6843 if (type == OP_FTTTY)
6844 o = newGVOP(type, OPf_REF, PL_stdingv);
6846 o = newUNOP(type, 0, newDEFSVOP());
6847 op_getmad(oldo,o,'O');
6853 Perl_ck_fun(pTHX_ OP *o)
6856 const int type = o->op_type;
6857 register I32 oa = PL_opargs[type] >> OASHIFT;
6859 PERL_ARGS_ASSERT_CK_FUN;
6861 if (o->op_flags & OPf_STACKED) {
6862 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6865 return no_fh_allowed(o);
6868 if (o->op_flags & OPf_KIDS) {
6869 OP **tokid = &cLISTOPo->op_first;
6870 register OP *kid = cLISTOPo->op_first;
6874 if (kid->op_type == OP_PUSHMARK ||
6875 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6877 tokid = &kid->op_sibling;
6878 kid = kid->op_sibling;
6880 if (!kid && PL_opargs[type] & OA_DEFGV)
6881 *tokid = kid = newDEFSVOP();
6885 sibl = kid->op_sibling;
6887 if (!sibl && kid->op_type == OP_STUB) {
6894 /* list seen where single (scalar) arg expected? */
6895 if (numargs == 1 && !(oa >> 4)
6896 && kid->op_type == OP_LIST && type != OP_SCALAR)
6898 return too_many_arguments(o,PL_op_desc[type]);
6911 if ((type == OP_PUSH || type == OP_UNSHIFT)
6912 && !kid->op_sibling)
6913 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6914 "Useless use of %s with no values",
6917 if (kid->op_type == OP_CONST &&
6918 (kid->op_private & OPpCONST_BARE))
6920 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6921 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6922 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6923 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6924 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6926 op_getmad(kid,newop,'K');
6931 kid->op_sibling = sibl;
6934 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6935 bad_type(numargs, "array", PL_op_desc[type], kid);
6939 if (kid->op_type == OP_CONST &&
6940 (kid->op_private & OPpCONST_BARE))
6942 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6943 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6944 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6945 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6946 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6948 op_getmad(kid,newop,'K');
6953 kid->op_sibling = sibl;
6956 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6957 bad_type(numargs, "hash", PL_op_desc[type], kid);
6962 OP * const newop = newUNOP(OP_NULL, 0, kid);
6963 kid->op_sibling = 0;
6965 newop->op_next = newop;
6967 kid->op_sibling = sibl;
6972 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6973 if (kid->op_type == OP_CONST &&
6974 (kid->op_private & OPpCONST_BARE))
6976 OP * const newop = newGVOP(OP_GV, 0,
6977 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6978 if (!(o->op_private & 1) && /* if not unop */
6979 kid == cLISTOPo->op_last)
6980 cLISTOPo->op_last = newop;
6982 op_getmad(kid,newop,'K');
6988 else if (kid->op_type == OP_READLINE) {
6989 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6990 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6993 I32 flags = OPf_SPECIAL;
6997 /* is this op a FH constructor? */
6998 if (is_handle_constructor(o,numargs)) {
6999 const char *name = NULL;
7003 /* Set a flag to tell rv2gv to vivify
7004 * need to "prove" flag does not mean something
7005 * else already - NI-S 1999/05/07
7008 if (kid->op_type == OP_PADSV) {
7010 = PAD_COMPNAME_SV(kid->op_targ);
7011 name = SvPV_const(namesv, len);
7013 else if (kid->op_type == OP_RV2SV
7014 && kUNOP->op_first->op_type == OP_GV)
7016 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7018 len = GvNAMELEN(gv);
7020 else if (kid->op_type == OP_AELEM
7021 || kid->op_type == OP_HELEM)
7024 OP *op = ((BINOP*)kid)->op_first;
7028 const char * const a =
7029 kid->op_type == OP_AELEM ?
7031 if (((op->op_type == OP_RV2AV) ||
7032 (op->op_type == OP_RV2HV)) &&
7033 (firstop = ((UNOP*)op)->op_first) &&
7034 (firstop->op_type == OP_GV)) {
7035 /* packagevar $a[] or $h{} */
7036 GV * const gv = cGVOPx_gv(firstop);
7044 else if (op->op_type == OP_PADAV
7045 || op->op_type == OP_PADHV) {
7046 /* lexicalvar $a[] or $h{} */
7047 const char * const padname =
7048 PAD_COMPNAME_PV(op->op_targ);
7057 name = SvPV_const(tmpstr, len);
7062 name = "__ANONIO__";
7069 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7070 namesv = PAD_SVl(targ);
7071 SvUPGRADE(namesv, SVt_PV);
7073 sv_setpvs(namesv, "$");
7074 sv_catpvn(namesv, name, len);
7077 kid->op_sibling = 0;
7078 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7079 kid->op_targ = targ;
7080 kid->op_private |= priv;
7082 kid->op_sibling = sibl;
7088 mod(scalar(kid), type);
7092 tokid = &kid->op_sibling;
7093 kid = kid->op_sibling;
7096 if (kid && kid->op_type != OP_STUB)
7097 return too_many_arguments(o,OP_DESC(o));
7098 o->op_private |= numargs;
7100 /* FIXME - should the numargs move as for the PERL_MAD case? */
7101 o->op_private |= numargs;
7103 return too_many_arguments(o,OP_DESC(o));
7107 else if (PL_opargs[type] & OA_DEFGV) {
7109 OP *newop = newUNOP(type, 0, newDEFSVOP());
7110 op_getmad(o,newop,'O');
7113 /* Ordering of these two is important to keep f_map.t passing. */
7115 return newUNOP(type, 0, newDEFSVOP());
7120 while (oa & OA_OPTIONAL)
7122 if (oa && oa != OA_LIST)
7123 return too_few_arguments(o,OP_DESC(o));
7129 Perl_ck_glob(pTHX_ OP *o)
7134 PERL_ARGS_ASSERT_CK_GLOB;
7137 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7138 append_elem(OP_GLOB, o, newDEFSVOP());
7140 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7141 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7143 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7146 #if !defined(PERL_EXTERNAL_GLOB)
7147 /* XXX this can be tightened up and made more failsafe. */
7148 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7151 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7152 newSVpvs("File::Glob"), NULL, NULL, NULL);
7153 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7154 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7155 GvCV(gv) = GvCV(glob_gv);
7156 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7157 GvIMPORTED_CV_on(gv);
7160 #endif /* PERL_EXTERNAL_GLOB */
7162 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7163 append_elem(OP_GLOB, o,
7164 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7165 o->op_type = OP_LIST;
7166 o->op_ppaddr = PL_ppaddr[OP_LIST];
7167 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7168 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7169 cLISTOPo->op_first->op_targ = 0;
7170 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7171 append_elem(OP_LIST, o,
7172 scalar(newUNOP(OP_RV2CV, 0,
7173 newGVOP(OP_GV, 0, gv)))));
7174 o = newUNOP(OP_NULL, 0, ck_subr(o));
7175 o->op_targ = OP_GLOB; /* hint at what it used to be */
7178 gv = newGVgen("main");
7180 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7186 Perl_ck_grep(pTHX_ OP *o)
7191 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7194 PERL_ARGS_ASSERT_CK_GREP;
7196 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7197 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7199 if (o->op_flags & OPf_STACKED) {
7202 kid = cLISTOPo->op_first->op_sibling;
7203 if (!cUNOPx(kid)->op_next)
7204 Perl_croak(aTHX_ "panic: ck_grep");
7205 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7208 NewOp(1101, gwop, 1, LOGOP);
7209 kid->op_next = (OP*)gwop;
7210 o->op_flags &= ~OPf_STACKED;
7212 kid = cLISTOPo->op_first->op_sibling;
7213 if (type == OP_MAPWHILE)
7218 if (PL_parser && PL_parser->error_count)
7220 kid = cLISTOPo->op_first->op_sibling;
7221 if (kid->op_type != OP_NULL)
7222 Perl_croak(aTHX_ "panic: ck_grep");
7223 kid = kUNOP->op_first;
7226 NewOp(1101, gwop, 1, LOGOP);
7227 gwop->op_type = type;
7228 gwop->op_ppaddr = PL_ppaddr[type];
7229 gwop->op_first = listkids(o);
7230 gwop->op_flags |= OPf_KIDS;
7231 gwop->op_other = LINKLIST(kid);
7232 kid->op_next = (OP*)gwop;
7233 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7234 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7235 o->op_private = gwop->op_private = 0;
7236 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7239 o->op_private = gwop->op_private = OPpGREP_LEX;
7240 gwop->op_targ = o->op_targ = offset;
7243 kid = cLISTOPo->op_first->op_sibling;
7244 if (!kid || !kid->op_sibling)
7245 return too_few_arguments(o,OP_DESC(o));
7246 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7247 mod(kid, OP_GREPSTART);
7253 Perl_ck_index(pTHX_ OP *o)
7255 PERL_ARGS_ASSERT_CK_INDEX;
7257 if (o->op_flags & OPf_KIDS) {
7258 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7260 kid = kid->op_sibling; /* get past "big" */
7261 if (kid && kid->op_type == OP_CONST)
7262 fbm_compile(((SVOP*)kid)->op_sv, 0);
7268 Perl_ck_lfun(pTHX_ OP *o)
7270 const OPCODE type = o->op_type;
7272 PERL_ARGS_ASSERT_CK_LFUN;
7274 return modkids(ck_fun(o), type);
7278 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7280 PERL_ARGS_ASSERT_CK_DEFINED;
7282 if ((o->op_flags & OPf_KIDS)) {
7283 switch (cUNOPo->op_first->op_type) {
7285 /* This is needed for
7286 if (defined %stash::)
7287 to work. Do not break Tk.
7289 break; /* Globals via GV can be undef */
7291 case OP_AASSIGN: /* Is this a good idea? */
7292 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7293 "defined(@array) is deprecated");
7294 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7295 "\t(Maybe you should just omit the defined()?)\n");
7299 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7300 "defined(%%hash) is deprecated");
7301 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7302 "\t(Maybe you should just omit the defined()?)\n");
7313 Perl_ck_readline(pTHX_ OP *o)
7315 PERL_ARGS_ASSERT_CK_READLINE;
7317 if (!(o->op_flags & OPf_KIDS)) {
7319 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7321 op_getmad(o,newop,'O');
7331 Perl_ck_rfun(pTHX_ OP *o)
7333 const OPCODE type = o->op_type;
7335 PERL_ARGS_ASSERT_CK_RFUN;
7337 return refkids(ck_fun(o), type);
7341 Perl_ck_listiob(pTHX_ OP *o)
7345 PERL_ARGS_ASSERT_CK_LISTIOB;
7347 kid = cLISTOPo->op_first;
7350 kid = cLISTOPo->op_first;
7352 if (kid->op_type == OP_PUSHMARK)
7353 kid = kid->op_sibling;
7354 if (kid && o->op_flags & OPf_STACKED)
7355 kid = kid->op_sibling;
7356 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7357 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7358 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7359 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7360 cLISTOPo->op_first->op_sibling = kid;
7361 cLISTOPo->op_last = kid;
7362 kid = kid->op_sibling;
7367 append_elem(o->op_type, o, newDEFSVOP());
7373 Perl_ck_smartmatch(pTHX_ OP *o)
7376 if (0 == (o->op_flags & OPf_SPECIAL)) {
7377 OP *first = cBINOPo->op_first;
7378 OP *second = first->op_sibling;
7380 /* Implicitly take a reference to an array or hash */
7381 first->op_sibling = NULL;
7382 first = cBINOPo->op_first = ref_array_or_hash(first);
7383 second = first->op_sibling = ref_array_or_hash(second);
7385 /* Implicitly take a reference to a regular expression */
7386 if (first->op_type == OP_MATCH) {
7387 first->op_type = OP_QR;
7388 first->op_ppaddr = PL_ppaddr[OP_QR];
7390 if (second->op_type == OP_MATCH) {
7391 second->op_type = OP_QR;
7392 second->op_ppaddr = PL_ppaddr[OP_QR];
7401 Perl_ck_sassign(pTHX_ OP *o)
7404 OP * const kid = cLISTOPo->op_first;
7406 PERL_ARGS_ASSERT_CK_SASSIGN;
7408 /* has a disposable target? */
7409 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7410 && !(kid->op_flags & OPf_STACKED)
7411 /* Cannot steal the second time! */
7412 && !(kid->op_private & OPpTARGET_MY)
7413 /* Keep the full thing for madskills */
7417 OP * const kkid = kid->op_sibling;
7419 /* Can just relocate the target. */
7420 if (kkid && kkid->op_type == OP_PADSV
7421 && !(kkid->op_private & OPpLVAL_INTRO))
7423 kid->op_targ = kkid->op_targ;
7425 /* Now we do not need PADSV and SASSIGN. */
7426 kid->op_sibling = o->op_sibling; /* NULL */
7427 cLISTOPo->op_first = NULL;
7430 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7434 if (kid->op_sibling) {
7435 OP *kkid = kid->op_sibling;
7436 if (kkid->op_type == OP_PADSV
7437 && (kkid->op_private & OPpLVAL_INTRO)
7438 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7439 const PADOFFSET target = kkid->op_targ;
7440 OP *const other = newOP(OP_PADSV,
7442 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7443 OP *const first = newOP(OP_NULL, 0);
7444 OP *const nullop = newCONDOP(0, first, o, other);
7445 OP *const condop = first->op_next;
7446 /* hijacking PADSTALE for uninitialized state variables */
7447 SvPADSTALE_on(PAD_SVl(target));
7449 condop->op_type = OP_ONCE;
7450 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7451 condop->op_targ = target;
7452 other->op_targ = target;
7454 /* Because we change the type of the op here, we will skip the
7455 assinment binop->op_last = binop->op_first->op_sibling; at the
7456 end of Perl_newBINOP(). So need to do it here. */
7457 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7466 Perl_ck_match(pTHX_ OP *o)
7470 PERL_ARGS_ASSERT_CK_MATCH;
7472 if (o->op_type != OP_QR && PL_compcv) {
7473 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7474 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7475 o->op_targ = offset;
7476 o->op_private |= OPpTARGET_MY;
7479 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7480 o->op_private |= OPpRUNTIME;
7485 Perl_ck_method(pTHX_ OP *o)
7487 OP * const kid = cUNOPo->op_first;
7489 PERL_ARGS_ASSERT_CK_METHOD;
7491 if (kid->op_type == OP_CONST) {
7492 SV* sv = kSVOP->op_sv;
7493 const char * const method = SvPVX_const(sv);
7494 if (!(strchr(method, ':') || strchr(method, '\''))) {
7496 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7497 sv = newSVpvn_share(method, SvCUR(sv), 0);
7500 kSVOP->op_sv = NULL;
7502 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7504 op_getmad(o,cmop,'O');
7515 Perl_ck_null(pTHX_ OP *o)
7517 PERL_ARGS_ASSERT_CK_NULL;
7518 PERL_UNUSED_CONTEXT;
7523 Perl_ck_open(pTHX_ OP *o)
7526 HV * const table = GvHV(PL_hintgv);
7528 PERL_ARGS_ASSERT_CK_OPEN;
7531 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7534 const char *d = SvPV_const(*svp, len);
7535 const I32 mode = mode_from_discipline(d, len);
7536 if (mode & O_BINARY)
7537 o->op_private |= OPpOPEN_IN_RAW;
7538 else if (mode & O_TEXT)
7539 o->op_private |= OPpOPEN_IN_CRLF;
7542 svp = hv_fetchs(table, "open_OUT", FALSE);
7545 const char *d = SvPV_const(*svp, len);
7546 const I32 mode = mode_from_discipline(d, len);
7547 if (mode & O_BINARY)
7548 o->op_private |= OPpOPEN_OUT_RAW;
7549 else if (mode & O_TEXT)
7550 o->op_private |= OPpOPEN_OUT_CRLF;
7553 if (o->op_type == OP_BACKTICK) {
7554 if (!(o->op_flags & OPf_KIDS)) {
7555 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7557 op_getmad(o,newop,'O');
7566 /* In case of three-arg dup open remove strictness
7567 * from the last arg if it is a bareword. */
7568 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7569 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7573 if ((last->op_type == OP_CONST) && /* The bareword. */
7574 (last->op_private & OPpCONST_BARE) &&
7575 (last->op_private & OPpCONST_STRICT) &&
7576 (oa = first->op_sibling) && /* The fh. */
7577 (oa = oa->op_sibling) && /* The mode. */
7578 (oa->op_type == OP_CONST) &&
7579 SvPOK(((SVOP*)oa)->op_sv) &&
7580 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7581 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7582 (last == oa->op_sibling)) /* The bareword. */
7583 last->op_private &= ~OPpCONST_STRICT;
7589 Perl_ck_repeat(pTHX_ OP *o)
7591 PERL_ARGS_ASSERT_CK_REPEAT;
7593 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7594 o->op_private |= OPpREPEAT_DOLIST;
7595 cBINOPo->op_first = force_list(cBINOPo->op_first);
7603 Perl_ck_require(pTHX_ OP *o)
7608 PERL_ARGS_ASSERT_CK_REQUIRE;
7610 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7611 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7613 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7614 SV * const sv = kid->op_sv;
7615 U32 was_readonly = SvREADONLY(sv);
7622 sv_force_normal_flags(sv, 0);
7623 assert(!SvREADONLY(sv));
7633 for (; s < end; s++) {
7634 if (*s == ':' && s[1] == ':') {
7636 Move(s+2, s+1, end - s - 1, char);
7641 sv_catpvs(sv, ".pm");
7642 SvFLAGS(sv) |= was_readonly;
7646 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7647 /* handle override, if any */
7648 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7649 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7650 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7651 gv = gvp ? *gvp : NULL;
7655 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7656 OP * const kid = cUNOPo->op_first;
7659 cUNOPo->op_first = 0;
7663 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7664 append_elem(OP_LIST, kid,
7665 scalar(newUNOP(OP_RV2CV, 0,
7668 op_getmad(o,newop,'O');
7672 return scalar(ck_fun(o));
7676 Perl_ck_return(pTHX_ OP *o)
7681 PERL_ARGS_ASSERT_CK_RETURN;
7683 kid = cLISTOPo->op_first->op_sibling;
7684 if (CvLVALUE(PL_compcv)) {
7685 for (; kid; kid = kid->op_sibling)
7686 mod(kid, OP_LEAVESUBLV);
7688 for (; kid; kid = kid->op_sibling)
7689 if ((kid->op_type == OP_NULL)
7690 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7691 /* This is a do block */
7692 OP *op = kUNOP->op_first;
7693 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7694 op = cUNOPx(op)->op_first;
7695 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7696 /* Force the use of the caller's context */
7697 op->op_flags |= OPf_SPECIAL;
7706 Perl_ck_select(pTHX_ OP *o)
7711 PERL_ARGS_ASSERT_CK_SELECT;
7713 if (o->op_flags & OPf_KIDS) {
7714 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7715 if (kid && kid->op_sibling) {
7716 o->op_type = OP_SSELECT;
7717 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7719 return fold_constants(o);
7723 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7724 if (kid && kid->op_type == OP_RV2GV)
7725 kid->op_private &= ~HINT_STRICT_REFS;
7730 Perl_ck_shift(pTHX_ OP *o)
7733 const I32 type = o->op_type;
7735 PERL_ARGS_ASSERT_CK_SHIFT;
7737 if (!(o->op_flags & OPf_KIDS)) {
7738 OP *argop = newUNOP(OP_RV2AV, 0,
7739 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7741 OP * const oldo = o;
7742 o = newUNOP(type, 0, scalar(argop));
7743 op_getmad(oldo,o,'O');
7747 return newUNOP(type, 0, scalar(argop));
7750 return scalar(modkids(ck_fun(o), type));
7754 Perl_ck_sort(pTHX_ OP *o)
7759 PERL_ARGS_ASSERT_CK_SORT;
7761 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7762 HV * const hinthv = GvHV(PL_hintgv);
7764 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7766 const I32 sorthints = (I32)SvIV(*svp);
7767 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7768 o->op_private |= OPpSORT_QSORT;
7769 if ((sorthints & HINT_SORT_STABLE) != 0)
7770 o->op_private |= OPpSORT_STABLE;
7775 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7777 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7778 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7780 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7782 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7784 if (kid->op_type == OP_SCOPE) {
7788 else if (kid->op_type == OP_LEAVE) {
7789 if (o->op_type == OP_SORT) {
7790 op_null(kid); /* wipe out leave */
7793 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7794 if (k->op_next == kid)
7796 /* don't descend into loops */
7797 else if (k->op_type == OP_ENTERLOOP
7798 || k->op_type == OP_ENTERITER)
7800 k = cLOOPx(k)->op_lastop;
7805 kid->op_next = 0; /* just disconnect the leave */
7806 k = kLISTOP->op_first;
7811 if (o->op_type == OP_SORT) {
7812 /* provide scalar context for comparison function/block */
7818 o->op_flags |= OPf_SPECIAL;
7820 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7823 firstkid = firstkid->op_sibling;
7826 /* provide list context for arguments */
7827 if (o->op_type == OP_SORT)
7834 S_simplify_sort(pTHX_ OP *o)
7837 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7843 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7845 if (!(o->op_flags & OPf_STACKED))
7847 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7848 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7849 kid = kUNOP->op_first; /* get past null */
7850 if (kid->op_type != OP_SCOPE)
7852 kid = kLISTOP->op_last; /* get past scope */
7853 switch(kid->op_type) {
7861 k = kid; /* remember this node*/
7862 if (kBINOP->op_first->op_type != OP_RV2SV)
7864 kid = kBINOP->op_first; /* get past cmp */
7865 if (kUNOP->op_first->op_type != OP_GV)
7867 kid = kUNOP->op_first; /* get past rv2sv */
7869 if (GvSTASH(gv) != PL_curstash)
7871 gvname = GvNAME(gv);
7872 if (*gvname == 'a' && gvname[1] == '\0')
7874 else if (*gvname == 'b' && gvname[1] == '\0')
7879 kid = k; /* back to cmp */
7880 if (kBINOP->op_last->op_type != OP_RV2SV)
7882 kid = kBINOP->op_last; /* down to 2nd arg */
7883 if (kUNOP->op_first->op_type != OP_GV)
7885 kid = kUNOP->op_first; /* get past rv2sv */
7887 if (GvSTASH(gv) != PL_curstash)
7889 gvname = GvNAME(gv);
7891 ? !(*gvname == 'a' && gvname[1] == '\0')
7892 : !(*gvname == 'b' && gvname[1] == '\0'))
7894 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7896 o->op_private |= OPpSORT_DESCEND;
7897 if (k->op_type == OP_NCMP)
7898 o->op_private |= OPpSORT_NUMERIC;
7899 if (k->op_type == OP_I_NCMP)
7900 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7901 kid = cLISTOPo->op_first->op_sibling;
7902 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7904 op_getmad(kid,o,'S'); /* then delete it */
7906 op_free(kid); /* then delete it */
7911 Perl_ck_split(pTHX_ OP *o)
7916 PERL_ARGS_ASSERT_CK_SPLIT;
7918 if (o->op_flags & OPf_STACKED)
7919 return no_fh_allowed(o);
7921 kid = cLISTOPo->op_first;
7922 if (kid->op_type != OP_NULL)
7923 Perl_croak(aTHX_ "panic: ck_split");
7924 kid = kid->op_sibling;
7925 op_free(cLISTOPo->op_first);
7926 cLISTOPo->op_first = kid;
7928 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7929 cLISTOPo->op_last = kid; /* There was only one element previously */
7932 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7933 OP * const sibl = kid->op_sibling;
7934 kid->op_sibling = 0;
7935 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7936 if (cLISTOPo->op_first == cLISTOPo->op_last)
7937 cLISTOPo->op_last = kid;
7938 cLISTOPo->op_first = kid;
7939 kid->op_sibling = sibl;
7942 kid->op_type = OP_PUSHRE;
7943 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7945 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7946 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7947 "Use of /g modifier is meaningless in split");
7950 if (!kid->op_sibling)
7951 append_elem(OP_SPLIT, o, newDEFSVOP());
7953 kid = kid->op_sibling;
7956 if (!kid->op_sibling)
7957 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7958 assert(kid->op_sibling);
7960 kid = kid->op_sibling;
7963 if (kid->op_sibling)
7964 return too_many_arguments(o,OP_DESC(o));
7970 Perl_ck_join(pTHX_ OP *o)
7972 const OP * const kid = cLISTOPo->op_first->op_sibling;
7974 PERL_ARGS_ASSERT_CK_JOIN;
7976 if (kid && kid->op_type == OP_MATCH) {
7977 if (ckWARN(WARN_SYNTAX)) {
7978 const REGEXP *re = PM_GETRE(kPMOP);
7979 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7980 const STRLEN len = re ? RX_PRELEN(re) : 6;
7981 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7982 "/%.*s/ should probably be written as \"%.*s\"",
7983 (int)len, pmstr, (int)len, pmstr);
7990 Perl_ck_subr(pTHX_ OP *o)
7993 OP *prev = ((cUNOPo->op_first->op_sibling)
7994 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7995 OP *o2 = prev->op_sibling;
7997 const char *proto = NULL;
7998 const char *proto_end = NULL;
8003 I32 contextclass = 0;
8004 const char *e = NULL;
8007 PERL_ARGS_ASSERT_CK_SUBR;
8009 o->op_private |= OPpENTERSUB_HASTARG;
8010 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
8011 if (cvop->op_type == OP_RV2CV) {
8012 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
8013 op_null(cvop); /* disable rv2cv */
8014 if (!(o->op_private & OPpENTERSUB_AMPER)) {
8015 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
8017 switch (tmpop->op_type) {
8019 gv = cGVOPx_gv(tmpop);
8022 tmpop->op_private |= OPpEARLY_CV;
8025 SV *sv = cSVOPx_sv(tmpop);
8026 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8030 if (cv && SvPOK(cv)) {
8032 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8033 proto = SvPV(MUTABLE_SV(cv), len);
8034 proto_end = proto + len;
8038 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8039 if (o2->op_type == OP_CONST)
8040 o2->op_private &= ~OPpCONST_STRICT;
8041 else if (o2->op_type == OP_LIST) {
8042 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8043 if (sib && sib->op_type == OP_CONST)
8044 sib->op_private &= ~OPpCONST_STRICT;
8047 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8048 if (PERLDB_SUB && PL_curstash != PL_debstash)
8049 o->op_private |= OPpENTERSUB_DB;
8050 while (o2 != cvop) {
8052 if (PL_madskills && o2->op_type == OP_STUB) {
8053 o2 = o2->op_sibling;
8056 if (PL_madskills && o2->op_type == OP_NULL)
8057 o3 = ((UNOP*)o2)->op_first;
8061 if (proto >= proto_end)
8062 return too_many_arguments(o, gv_ename(namegv));
8070 /* _ must be at the end */
8071 if (proto[1] && proto[1] != ';')
8086 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8088 arg == 1 ? "block or sub {}" : "sub {}",
8089 gv_ename(namegv), o3);
8092 /* '*' allows any scalar type, including bareword */
8095 if (o3->op_type == OP_RV2GV)
8096 goto wrapref; /* autoconvert GLOB -> GLOBref */
8097 else if (o3->op_type == OP_CONST)
8098 o3->op_private &= ~OPpCONST_STRICT;
8099 else if (o3->op_type == OP_ENTERSUB) {
8100 /* accidental subroutine, revert to bareword */
8101 OP *gvop = ((UNOP*)o3)->op_first;
8102 if (gvop && gvop->op_type == OP_NULL) {
8103 gvop = ((UNOP*)gvop)->op_first;
8105 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8108 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8109 (gvop = ((UNOP*)gvop)->op_first) &&
8110 gvop->op_type == OP_GV)
8112 GV * const gv = cGVOPx_gv(gvop);
8113 OP * const sibling = o2->op_sibling;
8114 SV * const n = newSVpvs("");
8116 OP * const oldo2 = o2;
8120 gv_fullname4(n, gv, "", FALSE);
8121 o2 = newSVOP(OP_CONST, 0, n);
8122 op_getmad(oldo2,o2,'O');
8123 prev->op_sibling = o2;
8124 o2->op_sibling = sibling;
8140 if (contextclass++ == 0) {
8141 e = strchr(proto, ']');
8142 if (!e || e == proto)
8151 const char *p = proto;
8152 const char *const end = proto;
8154 while (*--p != '[') {}
8155 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8157 gv_ename(namegv), o3);
8162 if (o3->op_type == OP_RV2GV)
8165 bad_type(arg, "symbol", gv_ename(namegv), o3);
8168 if (o3->op_type == OP_ENTERSUB)
8171 bad_type(arg, "subroutine entry", gv_ename(namegv),
8175 if (o3->op_type == OP_RV2SV ||
8176 o3->op_type == OP_PADSV ||
8177 o3->op_type == OP_HELEM ||
8178 o3->op_type == OP_AELEM)
8181 bad_type(arg, "scalar", gv_ename(namegv), o3);
8184 if (o3->op_type == OP_RV2AV ||
8185 o3->op_type == OP_PADAV)
8188 bad_type(arg, "array", gv_ename(namegv), o3);
8191 if (o3->op_type == OP_RV2HV ||
8192 o3->op_type == OP_PADHV)
8195 bad_type(arg, "hash", gv_ename(namegv), o3);
8200 OP* const sib = kid->op_sibling;
8201 kid->op_sibling = 0;
8202 o2 = newUNOP(OP_REFGEN, 0, kid);
8203 o2->op_sibling = sib;
8204 prev->op_sibling = o2;
8206 if (contextclass && e) {
8221 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8222 gv_ename(namegv), SVfARG(cv));
8227 mod(o2, OP_ENTERSUB);
8229 o2 = o2->op_sibling;
8231 if (o2 == cvop && proto && *proto == '_') {
8232 /* generate an access to $_ */
8234 o2->op_sibling = prev->op_sibling;
8235 prev->op_sibling = o2; /* instead of cvop */
8237 if (proto && !optional && proto_end > proto &&
8238 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8239 return too_few_arguments(o, gv_ename(namegv));
8242 OP * const oldo = o;
8246 o=newSVOP(OP_CONST, 0, newSViv(0));
8247 op_getmad(oldo,o,'O');
8253 Perl_ck_svconst(pTHX_ OP *o)
8255 PERL_ARGS_ASSERT_CK_SVCONST;
8256 PERL_UNUSED_CONTEXT;
8257 SvREADONLY_on(cSVOPo->op_sv);
8262 Perl_ck_chdir(pTHX_ OP *o)
8264 if (o->op_flags & OPf_KIDS) {
8265 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8267 if (kid && kid->op_type == OP_CONST &&
8268 (kid->op_private & OPpCONST_BARE))
8270 o->op_flags |= OPf_SPECIAL;
8271 kid->op_private &= ~OPpCONST_STRICT;
8278 Perl_ck_trunc(pTHX_ OP *o)
8280 PERL_ARGS_ASSERT_CK_TRUNC;
8282 if (o->op_flags & OPf_KIDS) {
8283 SVOP *kid = (SVOP*)cUNOPo->op_first;
8285 if (kid->op_type == OP_NULL)
8286 kid = (SVOP*)kid->op_sibling;
8287 if (kid && kid->op_type == OP_CONST &&
8288 (kid->op_private & OPpCONST_BARE))
8290 o->op_flags |= OPf_SPECIAL;
8291 kid->op_private &= ~OPpCONST_STRICT;
8298 Perl_ck_unpack(pTHX_ OP *o)
8300 OP *kid = cLISTOPo->op_first;
8302 PERL_ARGS_ASSERT_CK_UNPACK;
8304 if (kid->op_sibling) {
8305 kid = kid->op_sibling;
8306 if (!kid->op_sibling)
8307 kid->op_sibling = newDEFSVOP();
8313 Perl_ck_substr(pTHX_ OP *o)
8315 PERL_ARGS_ASSERT_CK_SUBSTR;
8318 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8319 OP *kid = cLISTOPo->op_first;
8321 if (kid->op_type == OP_NULL)
8322 kid = kid->op_sibling;
8324 kid->op_flags |= OPf_MOD;
8331 Perl_ck_each(pTHX_ OP *o)
8334 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8336 PERL_ARGS_ASSERT_CK_EACH;
8339 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8340 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8341 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8342 o->op_type = new_type;
8343 o->op_ppaddr = PL_ppaddr[new_type];
8345 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8346 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8348 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8355 /* caller is supposed to assign the return to the
8356 container of the rep_op var */
8358 S_opt_scalarhv(pTHX_ OP *rep_op) {
8361 PERL_ARGS_ASSERT_OPT_SCALARHV;
8363 NewOp(1101, unop, 1, UNOP);
8364 unop->op_type = (OPCODE)OP_BOOLKEYS;
8365 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8366 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8367 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8368 unop->op_first = rep_op;
8369 unop->op_next = rep_op->op_next;
8370 rep_op->op_next = (OP*)unop;
8371 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8372 unop->op_sibling = rep_op->op_sibling;
8373 rep_op->op_sibling = NULL;
8374 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8375 if (rep_op->op_type == OP_PADHV) {
8376 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8377 rep_op->op_flags |= OPf_WANT_LIST;
8382 /* Checks if o acts as an in-place operator on an array. oright points to the
8383 * beginning of the right-hand side. Returns the left-hand side of the
8384 * assignment if o acts in-place, or NULL otherwise. */
8387 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8391 PERL_ARGS_ASSERT_IS_INPLACE_AV;
8394 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8395 || oright->op_next != o
8396 || (oright->op_private & OPpLVAL_INTRO)
8400 /* o2 follows the chain of op_nexts through the LHS of the
8401 * assign (if any) to the aassign op itself */
8403 if (!o2 || o2->op_type != OP_NULL)
8406 if (!o2 || o2->op_type != OP_PUSHMARK)
8409 if (o2 && o2->op_type == OP_GV)
8412 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8413 || (o2->op_private & OPpLVAL_INTRO)
8418 if (!o2 || o2->op_type != OP_NULL)
8421 if (!o2 || o2->op_type != OP_AASSIGN
8422 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8425 /* check that the sort is the first arg on RHS of assign */
8427 o2 = cUNOPx(o2)->op_first;
8428 if (!o2 || o2->op_type != OP_NULL)
8430 o2 = cUNOPx(o2)->op_first;
8431 if (!o2 || o2->op_type != OP_PUSHMARK)
8433 if (o2->op_sibling != o)
8436 /* check the array is the same on both sides */
8437 if (oleft->op_type == OP_RV2AV) {
8438 if (oright->op_type != OP_RV2AV
8439 || !cUNOPx(oright)->op_first
8440 || cUNOPx(oright)->op_first->op_type != OP_GV
8441 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8442 cGVOPx_gv(cUNOPx(oright)->op_first)
8446 else if (oright->op_type != OP_PADAV
8447 || oright->op_targ != oleft->op_targ
8454 /* A peephole optimizer. We visit the ops in the order they're to execute.
8455 * See the comments at the top of this file for more details about when
8456 * peep() is called */
8459 Perl_peep(pTHX_ register OP *o)
8462 register OP* oldop = NULL;
8464 if (!o || o->op_opt)
8468 SAVEVPTR(PL_curcop);
8469 for (; o; o = o->op_next) {
8472 /* By default, this op has now been optimised. A couple of cases below
8473 clear this again. */
8476 switch (o->op_type) {
8479 PL_curcop = ((COP*)o); /* for warnings */
8483 if (cSVOPo->op_private & OPpCONST_STRICT)
8484 no_bareword_allowed(o);
8487 case OP_METHOD_NAMED:
8488 /* Relocate sv to the pad for thread safety.
8489 * Despite being a "constant", the SV is written to,
8490 * for reference counts, sv_upgrade() etc. */
8492 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8493 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8494 /* If op_sv is already a PADTMP then it is being used by
8495 * some pad, so make a copy. */
8496 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8497 SvREADONLY_on(PAD_SVl(ix));
8498 SvREFCNT_dec(cSVOPo->op_sv);
8500 else if (o->op_type != OP_METHOD_NAMED
8501 && cSVOPo->op_sv == &PL_sv_undef) {
8502 /* PL_sv_undef is hack - it's unsafe to store it in the
8503 AV that is the pad, because av_fetch treats values of
8504 PL_sv_undef as a "free" AV entry and will merrily
8505 replace them with a new SV, causing pad_alloc to think
8506 that this pad slot is free. (When, clearly, it is not)
8508 SvOK_off(PAD_SVl(ix));
8509 SvPADTMP_on(PAD_SVl(ix));
8510 SvREADONLY_on(PAD_SVl(ix));
8513 SvREFCNT_dec(PAD_SVl(ix));
8514 SvPADTMP_on(cSVOPo->op_sv);
8515 PAD_SETSV(ix, cSVOPo->op_sv);
8516 /* XXX I don't know how this isn't readonly already. */
8517 SvREADONLY_on(PAD_SVl(ix));
8519 cSVOPo->op_sv = NULL;
8526 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8527 if (o->op_next->op_private & OPpTARGET_MY) {
8528 if (o->op_flags & OPf_STACKED) /* chained concats */
8529 break; /* ignore_optimization */
8531 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8532 o->op_targ = o->op_next->op_targ;
8533 o->op_next->op_targ = 0;
8534 o->op_private |= OPpTARGET_MY;
8537 op_null(o->op_next);
8541 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8542 break; /* Scalar stub must produce undef. List stub is noop */
8546 if (o->op_targ == OP_NEXTSTATE
8547 || o->op_targ == OP_DBSTATE)
8549 PL_curcop = ((COP*)o);
8551 /* XXX: We avoid setting op_seq here to prevent later calls
8552 to peep() from mistakenly concluding that optimisation
8553 has already occurred. This doesn't fix the real problem,
8554 though (See 20010220.007). AMS 20010719 */
8555 /* op_seq functionality is now replaced by op_opt */
8562 if (oldop && o->op_next) {
8563 oldop->op_next = o->op_next;
8571 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8572 OP* const pop = (o->op_type == OP_PADAV) ?
8573 o->op_next : o->op_next->op_next;
8575 if (pop && pop->op_type == OP_CONST &&
8576 ((PL_op = pop->op_next)) &&
8577 pop->op_next->op_type == OP_AELEM &&
8578 !(pop->op_next->op_private &
8579 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8580 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8585 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8586 no_bareword_allowed(pop);
8587 if (o->op_type == OP_GV)
8588 op_null(o->op_next);
8589 op_null(pop->op_next);
8591 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8592 o->op_next = pop->op_next->op_next;
8593 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8594 o->op_private = (U8)i;
8595 if (o->op_type == OP_GV) {
8600 o->op_flags |= OPf_SPECIAL;
8601 o->op_type = OP_AELEMFAST;
8606 if (o->op_next->op_type == OP_RV2SV) {
8607 if (!(o->op_next->op_private & OPpDEREF)) {
8608 op_null(o->op_next);
8609 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8611 o->op_next = o->op_next->op_next;
8612 o->op_type = OP_GVSV;
8613 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8616 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8617 GV * const gv = cGVOPo_gv;
8618 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8619 /* XXX could check prototype here instead of just carping */
8620 SV * const sv = sv_newmortal();
8621 gv_efullname3(sv, gv, NULL);
8622 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8623 "%"SVf"() called too early to check prototype",
8627 else if (o->op_next->op_type == OP_READLINE
8628 && o->op_next->op_next->op_type == OP_CONCAT
8629 && (o->op_next->op_next->op_flags & OPf_STACKED))
8631 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8632 o->op_type = OP_RCATLINE;
8633 o->op_flags |= OPf_STACKED;
8634 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8635 op_null(o->op_next->op_next);
8636 op_null(o->op_next);
8646 fop = cUNOP->op_first;
8654 fop = cLOGOP->op_first;
8655 sop = fop->op_sibling;
8656 while (cLOGOP->op_other->op_type == OP_NULL)
8657 cLOGOP->op_other = cLOGOP->op_other->op_next;
8658 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8662 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8664 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8669 if (!(nop->op_flags && OPf_WANT_VOID)) {
8670 while (nop && nop->op_next) {
8671 switch (nop->op_next->op_type) {
8676 lop = nop = nop->op_next;
8687 if (lop->op_flags && OPf_WANT_VOID) {
8688 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8689 cLOGOP->op_first = opt_scalarhv(fop);
8690 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8691 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8707 while (cLOGOP->op_other->op_type == OP_NULL)
8708 cLOGOP->op_other = cLOGOP->op_other->op_next;
8709 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8714 while (cLOOP->op_redoop->op_type == OP_NULL)
8715 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8716 peep(cLOOP->op_redoop);
8717 while (cLOOP->op_nextop->op_type == OP_NULL)
8718 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8719 peep(cLOOP->op_nextop);
8720 while (cLOOP->op_lastop->op_type == OP_NULL)
8721 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8722 peep(cLOOP->op_lastop);
8726 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8727 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8728 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8729 cPMOP->op_pmstashstartu.op_pmreplstart
8730 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8731 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8735 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8736 && ckWARN(WARN_SYNTAX))
8738 if (o->op_next->op_sibling) {
8739 const OPCODE type = o->op_next->op_sibling->op_type;
8740 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8741 const line_t oldline = CopLINE(PL_curcop);
8742 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8743 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8744 "Statement unlikely to be reached");
8745 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8746 "\t(Maybe you meant system() when you said exec()?)\n");
8747 CopLINE_set(PL_curcop, oldline);
8758 const char *key = NULL;
8761 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8764 /* Make the CONST have a shared SV */
8765 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8766 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8767 key = SvPV_const(sv, keylen);
8768 lexname = newSVpvn_share(key,
8769 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8775 if ((o->op_private & (OPpLVAL_INTRO)))
8778 rop = (UNOP*)((BINOP*)o)->op_first;
8779 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8781 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8782 if (!SvPAD_TYPED(lexname))
8784 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8785 if (!fields || !GvHV(*fields))
8787 key = SvPV_const(*svp, keylen);
8788 if (!hv_fetch(GvHV(*fields), key,
8789 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8791 Perl_croak(aTHX_ "No such class field \"%s\" "
8792 "in variable %s of type %s",
8793 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8806 SVOP *first_key_op, *key_op;
8808 if ((o->op_private & (OPpLVAL_INTRO))
8809 /* I bet there's always a pushmark... */
8810 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8811 /* hmmm, no optimization if list contains only one key. */
8813 rop = (UNOP*)((LISTOP*)o)->op_last;
8814 if (rop->op_type != OP_RV2HV)
8816 if (rop->op_first->op_type == OP_PADSV)
8817 /* @$hash{qw(keys here)} */
8818 rop = (UNOP*)rop->op_first;
8820 /* @{$hash}{qw(keys here)} */
8821 if (rop->op_first->op_type == OP_SCOPE
8822 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8824 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8830 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8831 if (!SvPAD_TYPED(lexname))
8833 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8834 if (!fields || !GvHV(*fields))
8836 /* Again guessing that the pushmark can be jumped over.... */
8837 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8838 ->op_first->op_sibling;
8839 for (key_op = first_key_op; key_op;
8840 key_op = (SVOP*)key_op->op_sibling) {
8841 if (key_op->op_type != OP_CONST)
8843 svp = cSVOPx_svp(key_op);
8844 key = SvPV_const(*svp, keylen);
8845 if (!hv_fetch(GvHV(*fields), key,
8846 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8848 Perl_croak(aTHX_ "No such class field \"%s\" "
8849 "in variable %s of type %s",
8850 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8857 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8861 /* check that RHS of sort is a single plain array */
8862 OP *oright = cUNOPo->op_first;
8863 if (!oright || oright->op_type != OP_PUSHMARK)
8866 /* reverse sort ... can be optimised. */
8867 if (!cUNOPo->op_sibling) {
8868 /* Nothing follows us on the list. */
8869 OP * const reverse = o->op_next;
8871 if (reverse->op_type == OP_REVERSE &&
8872 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8873 OP * const pushmark = cUNOPx(reverse)->op_first;
8874 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8875 && (cUNOPx(pushmark)->op_sibling == o)) {
8876 /* reverse -> pushmark -> sort */
8877 o->op_private |= OPpSORT_REVERSE;
8879 pushmark->op_next = oright->op_next;
8885 /* make @a = sort @a act in-place */
8887 oright = cUNOPx(oright)->op_sibling;
8890 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8891 oright = cUNOPx(oright)->op_sibling;
8894 oleft = is_inplace_av(o, oright);
8898 /* transfer MODishness etc from LHS arg to RHS arg */
8899 oright->op_flags = oleft->op_flags;
8900 o->op_private |= OPpSORT_INPLACE;
8902 /* excise push->gv->rv2av->null->aassign */
8903 o2 = o->op_next->op_next;
8904 op_null(o2); /* PUSHMARK */
8906 if (o2->op_type == OP_GV) {
8907 op_null(o2); /* GV */
8910 op_null(o2); /* RV2AV or PADAV */
8911 o2 = o2->op_next->op_next;
8912 op_null(o2); /* AASSIGN */
8914 o->op_next = o2->op_next;
8920 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8923 LISTOP *enter, *exlist;
8925 /* @a = reverse @a */
8926 if ((oright = cLISTOPo->op_first)
8927 && (oright->op_type == OP_PUSHMARK)
8928 && (oright = oright->op_sibling)
8929 && (oleft = is_inplace_av(o, oright))) {
8932 /* transfer MODishness etc from LHS arg to RHS arg */
8933 oright->op_flags = oleft->op_flags;
8934 o->op_private |= OPpREVERSE_INPLACE;
8936 /* excise push->gv->rv2av->null->aassign */
8937 o2 = o->op_next->op_next;
8938 op_null(o2); /* PUSHMARK */
8940 if (o2->op_type == OP_GV) {
8941 op_null(o2); /* GV */
8944 op_null(o2); /* RV2AV or PADAV */
8945 o2 = o2->op_next->op_next;
8946 op_null(o2); /* AASSIGN */
8948 o->op_next = o2->op_next;
8952 enter = (LISTOP *) o->op_next;
8955 if (enter->op_type == OP_NULL) {
8956 enter = (LISTOP *) enter->op_next;
8960 /* for $a (...) will have OP_GV then OP_RV2GV here.
8961 for (...) just has an OP_GV. */
8962 if (enter->op_type == OP_GV) {
8963 gvop = (OP *) enter;
8964 enter = (LISTOP *) enter->op_next;
8967 if (enter->op_type == OP_RV2GV) {
8968 enter = (LISTOP *) enter->op_next;
8974 if (enter->op_type != OP_ENTERITER)
8977 iter = enter->op_next;
8978 if (!iter || iter->op_type != OP_ITER)
8981 expushmark = enter->op_first;
8982 if (!expushmark || expushmark->op_type != OP_NULL
8983 || expushmark->op_targ != OP_PUSHMARK)
8986 exlist = (LISTOP *) expushmark->op_sibling;
8987 if (!exlist || exlist->op_type != OP_NULL
8988 || exlist->op_targ != OP_LIST)
8991 if (exlist->op_last != o) {
8992 /* Mmm. Was expecting to point back to this op. */
8995 theirmark = exlist->op_first;
8996 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8999 if (theirmark->op_sibling != o) {
9000 /* There's something between the mark and the reverse, eg
9001 for (1, reverse (...))
9006 ourmark = ((LISTOP *)o)->op_first;
9007 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9010 ourlast = ((LISTOP *)o)->op_last;
9011 if (!ourlast || ourlast->op_next != o)
9014 rv2av = ourmark->op_sibling;
9015 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9016 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9017 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9018 /* We're just reversing a single array. */
9019 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9020 enter->op_flags |= OPf_STACKED;
9023 /* We don't have control over who points to theirmark, so sacrifice
9025 theirmark->op_next = ourmark->op_next;
9026 theirmark->op_flags = ourmark->op_flags;
9027 ourlast->op_next = gvop ? gvop : (OP *) enter;
9030 enter->op_private |= OPpITER_REVERSED;
9031 iter->op_private |= OPpITER_REVERSED;
9038 UNOP *refgen, *rv2cv;
9041 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9044 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9047 rv2gv = ((BINOP *)o)->op_last;
9048 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9051 refgen = (UNOP *)((BINOP *)o)->op_first;
9053 if (!refgen || refgen->op_type != OP_REFGEN)
9056 exlist = (LISTOP *)refgen->op_first;
9057 if (!exlist || exlist->op_type != OP_NULL
9058 || exlist->op_targ != OP_LIST)
9061 if (exlist->op_first->op_type != OP_PUSHMARK)
9064 rv2cv = (UNOP*)exlist->op_last;
9066 if (rv2cv->op_type != OP_RV2CV)
9069 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9070 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9071 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9073 o->op_private |= OPpASSIGN_CV_TO_GV;
9074 rv2gv->op_private |= OPpDONT_INIT_GV;
9075 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9083 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9084 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9094 Perl_custom_op_name(pTHX_ const OP* o)
9097 const IV index = PTR2IV(o->op_ppaddr);
9101 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9103 if (!PL_custom_op_names) /* This probably shouldn't happen */
9104 return (char *)PL_op_name[OP_CUSTOM];
9106 keysv = sv_2mortal(newSViv(index));
9108 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9110 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9112 return SvPV_nolen(HeVAL(he));
9116 Perl_custom_op_desc(pTHX_ const OP* o)
9119 const IV index = PTR2IV(o->op_ppaddr);
9123 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9125 if (!PL_custom_op_descs)
9126 return (char *)PL_op_desc[OP_CUSTOM];
9128 keysv = sv_2mortal(newSViv(index));
9130 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9132 return (char *)PL_op_desc[OP_CUSTOM];
9134 return SvPV_nolen(HeVAL(he));
9139 /* Efficient sub that returns a constant scalar value. */
9141 const_sv_xsub(pTHX_ CV* cv)
9145 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9149 /* diag_listed_as: SKIPME */
9150 Perl_croak(aTHX_ "usage: %s::%s()",
9151 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9164 * c-indentation-style: bsd
9166 * indent-tabs-mode: t
9169 * ex: set ts=8 sts=4 sw=4 noet: