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 = cLISTOPo->op_first;
1091 if (kid && kid->op_type == OP_PUSHRE
1093 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1095 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1097 useless = OP_DESC(o);
1101 kid = cUNOPo->op_first;
1102 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1103 kid->op_type != OP_TRANS) {
1106 useless = "negative pattern binding (!~)";
1113 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1114 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1115 useless = "a variable";
1120 if (cSVOPo->op_private & OPpCONST_STRICT)
1121 no_bareword_allowed(o);
1123 if (ckWARN(WARN_VOID)) {
1125 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1126 "a constant (%"SVf")", sv));
1127 useless = SvPV_nolen(msv);
1130 useless = "a constant (undef)";
1131 if (o->op_private & OPpCONST_ARYBASE)
1133 /* don't warn on optimised away booleans, eg
1134 * use constant Foo, 5; Foo || print; */
1135 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1137 /* the constants 0 and 1 are permitted as they are
1138 conventionally used as dummies in constructs like
1139 1 while some_condition_with_side_effects; */
1140 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1142 else if (SvPOK(sv)) {
1143 /* perl4's way of mixing documentation and code
1144 (before the invention of POD) was based on a
1145 trick to mix nroff and perl code. The trick was
1146 built upon these three nroff macros being used in
1147 void context. The pink camel has the details in
1148 the script wrapman near page 319. */
1149 const char * const maybe_macro = SvPVX_const(sv);
1150 if (strnEQ(maybe_macro, "di", 2) ||
1151 strnEQ(maybe_macro, "ds", 2) ||
1152 strnEQ(maybe_macro, "ig", 2))
1157 op_null(o); /* don't execute or even remember it */
1161 o->op_type = OP_PREINC; /* pre-increment is faster */
1162 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1166 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1167 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1171 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1172 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1176 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1177 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1182 kid = cLOGOPo->op_first;
1183 if (kid->op_type == OP_NOT
1184 && (kid->op_flags & OPf_KIDS)
1186 if (o->op_type == OP_AND) {
1188 o->op_ppaddr = PL_ppaddr[OP_OR];
1190 o->op_type = OP_AND;
1191 o->op_ppaddr = PL_ppaddr[OP_AND];
1200 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1205 if (o->op_flags & OPf_STACKED)
1212 if (!(o->op_flags & OPf_KIDS))
1223 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1233 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1238 S_listkids(pTHX_ OP *o)
1240 if (o && o->op_flags & OPf_KIDS) {
1242 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1249 Perl_list(pTHX_ OP *o)
1254 /* assumes no premature commitment */
1255 if (!o || (o->op_flags & OPf_WANT)
1256 || (PL_parser && PL_parser->error_count)
1257 || o->op_type == OP_RETURN)
1262 if ((o->op_private & OPpTARGET_MY)
1263 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1265 return o; /* As if inside SASSIGN */
1268 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1270 switch (o->op_type) {
1273 list(cBINOPo->op_first);
1278 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1286 if (!(o->op_flags & OPf_KIDS))
1288 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1289 list(cBINOPo->op_first);
1290 return gen_constant_list(o);
1297 kid = cLISTOPo->op_first;
1299 while ((kid = kid->op_sibling)) {
1300 if (kid->op_sibling)
1305 PL_curcop = &PL_compiling;
1309 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1310 if (kid->op_sibling)
1315 PL_curcop = &PL_compiling;
1322 S_scalarseq(pTHX_ OP *o)
1326 const OPCODE type = o->op_type;
1328 if (type == OP_LINESEQ || type == OP_SCOPE ||
1329 type == OP_LEAVE || type == OP_LEAVETRY)
1332 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1333 if (kid->op_sibling) {
1337 PL_curcop = &PL_compiling;
1339 o->op_flags &= ~OPf_PARENS;
1340 if (PL_hints & HINT_BLOCK_SCOPE)
1341 o->op_flags |= OPf_PARENS;
1344 o = newOP(OP_STUB, 0);
1349 S_modkids(pTHX_ OP *o, I32 type)
1351 if (o && o->op_flags & OPf_KIDS) {
1353 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1359 /* Propagate lvalue ("modifiable") context to an op and its children.
1360 * 'type' represents the context type, roughly based on the type of op that
1361 * would do the modifying, although local() is represented by OP_NULL.
1362 * It's responsible for detecting things that can't be modified, flag
1363 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1364 * might have to vivify a reference in $x), and so on.
1366 * For example, "$a+1 = 2" would cause mod() to be called with o being
1367 * OP_ADD and type being OP_SASSIGN, and would output an error.
1371 Perl_mod(pTHX_ OP *o, I32 type)
1375 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1378 if (!o || (PL_parser && PL_parser->error_count))
1381 if ((o->op_private & OPpTARGET_MY)
1382 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1387 switch (o->op_type) {
1393 if (!(o->op_private & OPpCONST_ARYBASE))
1396 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1397 CopARYBASE_set(&PL_compiling,
1398 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1402 SAVECOPARYBASE(&PL_compiling);
1403 CopARYBASE_set(&PL_compiling, 0);
1405 else if (type == OP_REFGEN)
1408 Perl_croak(aTHX_ "That use of $[ is unsupported");
1411 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1415 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1416 !(o->op_flags & OPf_STACKED)) {
1417 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1418 /* The default is to set op_private to the number of children,
1419 which for a UNOP such as RV2CV is always 1. And w're using
1420 the bit for a flag in RV2CV, so we need it clear. */
1421 o->op_private &= ~1;
1422 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1423 assert(cUNOPo->op_first->op_type == OP_NULL);
1424 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1427 else if (o->op_private & OPpENTERSUB_NOMOD)
1429 else { /* lvalue subroutine call */
1430 o->op_private |= OPpLVAL_INTRO;
1431 PL_modcount = RETURN_UNLIMITED_NUMBER;
1432 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1433 /* Backward compatibility mode: */
1434 o->op_private |= OPpENTERSUB_INARGS;
1437 else { /* Compile-time error message: */
1438 OP *kid = cUNOPo->op_first;
1442 if (kid->op_type != OP_PUSHMARK) {
1443 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1445 "panic: unexpected lvalue entersub "
1446 "args: type/targ %ld:%"UVuf,
1447 (long)kid->op_type, (UV)kid->op_targ);
1448 kid = kLISTOP->op_first;
1450 while (kid->op_sibling)
1451 kid = kid->op_sibling;
1452 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1454 if (kid->op_type == OP_METHOD_NAMED
1455 || kid->op_type == OP_METHOD)
1459 NewOp(1101, newop, 1, UNOP);
1460 newop->op_type = OP_RV2CV;
1461 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1462 newop->op_first = NULL;
1463 newop->op_next = (OP*)newop;
1464 kid->op_sibling = (OP*)newop;
1465 newop->op_private |= OPpLVAL_INTRO;
1466 newop->op_private &= ~1;
1470 if (kid->op_type != OP_RV2CV)
1472 "panic: unexpected lvalue entersub "
1473 "entry via type/targ %ld:%"UVuf,
1474 (long)kid->op_type, (UV)kid->op_targ);
1475 kid->op_private |= OPpLVAL_INTRO;
1476 break; /* Postpone until runtime */
1480 kid = kUNOP->op_first;
1481 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1482 kid = kUNOP->op_first;
1483 if (kid->op_type == OP_NULL)
1485 "Unexpected constant lvalue entersub "
1486 "entry via type/targ %ld:%"UVuf,
1487 (long)kid->op_type, (UV)kid->op_targ);
1488 if (kid->op_type != OP_GV) {
1489 /* Restore RV2CV to check lvalueness */
1491 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1492 okid->op_next = kid->op_next;
1493 kid->op_next = okid;
1496 okid->op_next = NULL;
1497 okid->op_type = OP_RV2CV;
1499 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1500 okid->op_private |= OPpLVAL_INTRO;
1501 okid->op_private &= ~1;
1505 cv = GvCV(kGVOP_gv);
1515 /* grep, foreach, subcalls, refgen */
1516 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1518 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1519 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1521 : (o->op_type == OP_ENTERSUB
1522 ? "non-lvalue subroutine call"
1524 type ? PL_op_desc[type] : "local"));
1538 case OP_RIGHT_SHIFT:
1547 if (!(o->op_flags & OPf_STACKED))
1554 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1560 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1561 PL_modcount = RETURN_UNLIMITED_NUMBER;
1562 return o; /* Treat \(@foo) like ordinary list. */
1566 if (scalar_mod_type(o, type))
1568 ref(cUNOPo->op_first, o->op_type);
1572 if (type == OP_LEAVESUBLV)
1573 o->op_private |= OPpMAYBE_LVSUB;
1579 PL_modcount = RETURN_UNLIMITED_NUMBER;
1582 PL_hints |= HINT_BLOCK_SCOPE;
1583 if (type == OP_LEAVESUBLV)
1584 o->op_private |= OPpMAYBE_LVSUB;
1588 ref(cUNOPo->op_first, o->op_type);
1592 PL_hints |= HINT_BLOCK_SCOPE;
1607 PL_modcount = RETURN_UNLIMITED_NUMBER;
1608 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1609 return o; /* Treat \(@foo) like ordinary list. */
1610 if (scalar_mod_type(o, type))
1612 if (type == OP_LEAVESUBLV)
1613 o->op_private |= OPpMAYBE_LVSUB;
1617 if (!type) /* local() */
1618 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1619 PAD_COMPNAME_PV(o->op_targ));
1627 if (type != OP_SASSIGN)
1631 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1636 if (type == OP_LEAVESUBLV)
1637 o->op_private |= OPpMAYBE_LVSUB;
1639 pad_free(o->op_targ);
1640 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1641 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1642 if (o->op_flags & OPf_KIDS)
1643 mod(cBINOPo->op_first->op_sibling, type);
1648 ref(cBINOPo->op_first, o->op_type);
1649 if (type == OP_ENTERSUB &&
1650 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1651 o->op_private |= OPpLVAL_DEFER;
1652 if (type == OP_LEAVESUBLV)
1653 o->op_private |= OPpMAYBE_LVSUB;
1663 if (o->op_flags & OPf_KIDS)
1664 mod(cLISTOPo->op_last, type);
1669 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1671 else if (!(o->op_flags & OPf_KIDS))
1673 if (o->op_targ != OP_LIST) {
1674 mod(cBINOPo->op_first, type);
1680 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1685 if (type != OP_LEAVESUBLV)
1687 break; /* mod()ing was handled by ck_return() */
1690 /* [20011101.069] File test operators interpret OPf_REF to mean that
1691 their argument is a filehandle; thus \stat(".") should not set
1693 if (type == OP_REFGEN &&
1694 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1697 if (type != OP_LEAVESUBLV)
1698 o->op_flags |= OPf_MOD;
1700 if (type == OP_AASSIGN || type == OP_SASSIGN)
1701 o->op_flags |= OPf_SPECIAL|OPf_REF;
1702 else if (!type) { /* local() */
1705 o->op_private |= OPpLVAL_INTRO;
1706 o->op_flags &= ~OPf_SPECIAL;
1707 PL_hints |= HINT_BLOCK_SCOPE;
1712 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1713 "Useless localization of %s", OP_DESC(o));
1716 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1717 && type != OP_LEAVESUBLV)
1718 o->op_flags |= OPf_REF;
1723 S_scalar_mod_type(const OP *o, I32 type)
1725 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1729 if (o->op_type == OP_RV2GV)
1753 case OP_RIGHT_SHIFT:
1773 S_is_handle_constructor(const OP *o, I32 numargs)
1775 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1777 switch (o->op_type) {
1785 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1798 S_refkids(pTHX_ OP *o, I32 type)
1800 if (o && o->op_flags & OPf_KIDS) {
1802 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1809 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1814 PERL_ARGS_ASSERT_DOREF;
1816 if (!o || (PL_parser && PL_parser->error_count))
1819 switch (o->op_type) {
1821 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1822 !(o->op_flags & OPf_STACKED)) {
1823 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1824 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1825 assert(cUNOPo->op_first->op_type == OP_NULL);
1826 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1827 o->op_flags |= OPf_SPECIAL;
1828 o->op_private &= ~1;
1833 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1834 doref(kid, type, set_op_ref);
1837 if (type == OP_DEFINED)
1838 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1839 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1842 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1843 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1844 : type == OP_RV2HV ? OPpDEREF_HV
1846 o->op_flags |= OPf_MOD;
1853 o->op_flags |= OPf_REF;
1856 if (type == OP_DEFINED)
1857 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1858 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1864 o->op_flags |= OPf_REF;
1869 if (!(o->op_flags & OPf_KIDS))
1871 doref(cBINOPo->op_first, type, set_op_ref);
1875 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1876 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1877 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1878 : type == OP_RV2HV ? OPpDEREF_HV
1880 o->op_flags |= OPf_MOD;
1890 if (!(o->op_flags & OPf_KIDS))
1892 doref(cLISTOPo->op_last, type, set_op_ref);
1902 S_dup_attrlist(pTHX_ OP *o)
1907 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1909 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1910 * where the first kid is OP_PUSHMARK and the remaining ones
1911 * are OP_CONST. We need to push the OP_CONST values.
1913 if (o->op_type == OP_CONST)
1914 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1916 else if (o->op_type == OP_NULL)
1920 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1922 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1923 if (o->op_type == OP_CONST)
1924 rop = append_elem(OP_LIST, rop,
1925 newSVOP(OP_CONST, o->op_flags,
1926 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1933 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1938 PERL_ARGS_ASSERT_APPLY_ATTRS;
1940 /* fake up C<use attributes $pkg,$rv,@attrs> */
1941 ENTER; /* need to protect against side-effects of 'use' */
1942 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1944 #define ATTRSMODULE "attributes"
1945 #define ATTRSMODULE_PM "attributes.pm"
1948 /* Don't force the C<use> if we don't need it. */
1949 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1950 if (svp && *svp != &PL_sv_undef)
1951 NOOP; /* already in %INC */
1953 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1954 newSVpvs(ATTRSMODULE), NULL);
1957 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1958 newSVpvs(ATTRSMODULE),
1960 prepend_elem(OP_LIST,
1961 newSVOP(OP_CONST, 0, stashsv),
1962 prepend_elem(OP_LIST,
1963 newSVOP(OP_CONST, 0,
1965 dup_attrlist(attrs))));
1971 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1974 OP *pack, *imop, *arg;
1977 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1982 assert(target->op_type == OP_PADSV ||
1983 target->op_type == OP_PADHV ||
1984 target->op_type == OP_PADAV);
1986 /* Ensure that attributes.pm is loaded. */
1987 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1989 /* Need package name for method call. */
1990 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1992 /* Build up the real arg-list. */
1993 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1995 arg = newOP(OP_PADSV, 0);
1996 arg->op_targ = target->op_targ;
1997 arg = prepend_elem(OP_LIST,
1998 newSVOP(OP_CONST, 0, stashsv),
1999 prepend_elem(OP_LIST,
2000 newUNOP(OP_REFGEN, 0,
2001 mod(arg, OP_REFGEN)),
2002 dup_attrlist(attrs)));
2004 /* Fake up a method call to import */
2005 meth = newSVpvs_share("import");
2006 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2007 append_elem(OP_LIST,
2008 prepend_elem(OP_LIST, pack, list(arg)),
2009 newSVOP(OP_METHOD_NAMED, 0, meth)));
2010 imop->op_private |= OPpENTERSUB_NOMOD;
2012 /* Combine the ops. */
2013 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2017 =notfor apidoc apply_attrs_string
2019 Attempts to apply a list of attributes specified by the C<attrstr> and
2020 C<len> arguments to the subroutine identified by the C<cv> argument which
2021 is expected to be associated with the package identified by the C<stashpv>
2022 argument (see L<attributes>). It gets this wrong, though, in that it
2023 does not correctly identify the boundaries of the individual attribute
2024 specifications within C<attrstr>. This is not really intended for the
2025 public API, but has to be listed here for systems such as AIX which
2026 need an explicit export list for symbols. (It's called from XS code
2027 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2028 to respect attribute syntax properly would be welcome.
2034 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2035 const char *attrstr, STRLEN len)
2039 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2042 len = strlen(attrstr);
2046 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2048 const char * const sstr = attrstr;
2049 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2050 attrs = append_elem(OP_LIST, attrs,
2051 newSVOP(OP_CONST, 0,
2052 newSVpvn(sstr, attrstr-sstr)));
2056 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2057 newSVpvs(ATTRSMODULE),
2058 NULL, prepend_elem(OP_LIST,
2059 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2060 prepend_elem(OP_LIST,
2061 newSVOP(OP_CONST, 0,
2062 newRV(MUTABLE_SV(cv))),
2067 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2072 PERL_ARGS_ASSERT_MY_KID;
2074 if (!o || (PL_parser && PL_parser->error_count))
2078 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2079 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2083 if (type == OP_LIST) {
2085 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2086 my_kid(kid, attrs, imopsp);
2087 } else if (type == OP_UNDEF
2093 } else if (type == OP_RV2SV || /* "our" declaration */
2095 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2096 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2097 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2099 PL_parser->in_my == KEY_our
2101 : PL_parser->in_my == KEY_state ? "state" : "my"));
2103 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2104 PL_parser->in_my = FALSE;
2105 PL_parser->in_my_stash = NULL;
2106 apply_attrs(GvSTASH(gv),
2107 (type == OP_RV2SV ? GvSV(gv) :
2108 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2109 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2112 o->op_private |= OPpOUR_INTRO;
2115 else if (type != OP_PADSV &&
2118 type != OP_PUSHMARK)
2120 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2122 PL_parser->in_my == KEY_our
2124 : PL_parser->in_my == KEY_state ? "state" : "my"));
2127 else if (attrs && type != OP_PUSHMARK) {
2130 PL_parser->in_my = FALSE;
2131 PL_parser->in_my_stash = NULL;
2133 /* check for C<my Dog $spot> when deciding package */
2134 stash = PAD_COMPNAME_TYPE(o->op_targ);
2136 stash = PL_curstash;
2137 apply_attrs_my(stash, o, attrs, imopsp);
2139 o->op_flags |= OPf_MOD;
2140 o->op_private |= OPpLVAL_INTRO;
2141 if (PL_parser->in_my == KEY_state)
2142 o->op_private |= OPpPAD_STATE;
2147 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2151 int maybe_scalar = 0;
2153 PERL_ARGS_ASSERT_MY_ATTRS;
2155 /* [perl #17376]: this appears to be premature, and results in code such as
2156 C< our(%x); > executing in list mode rather than void mode */
2158 if (o->op_flags & OPf_PARENS)
2168 o = my_kid(o, attrs, &rops);
2170 if (maybe_scalar && o->op_type == OP_PADSV) {
2171 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2172 o->op_private |= OPpLVAL_INTRO;
2175 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2177 PL_parser->in_my = FALSE;
2178 PL_parser->in_my_stash = NULL;
2183 Perl_sawparens(pTHX_ OP *o)
2185 PERL_UNUSED_CONTEXT;
2187 o->op_flags |= OPf_PARENS;
2192 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2196 const OPCODE ltype = left->op_type;
2197 const OPCODE rtype = right->op_type;
2199 PERL_ARGS_ASSERT_BIND_MATCH;
2201 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2202 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2204 const char * const desc
2205 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2206 ? (int)rtype : OP_MATCH];
2207 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2208 ? "@array" : "%hash");
2209 Perl_warner(aTHX_ packWARN(WARN_MISC),
2210 "Applying %s to %s will act on scalar(%s)",
2211 desc, sample, sample);
2214 if (rtype == OP_CONST &&
2215 cSVOPx(right)->op_private & OPpCONST_BARE &&
2216 cSVOPx(right)->op_private & OPpCONST_STRICT)
2218 no_bareword_allowed(right);
2221 ismatchop = rtype == OP_MATCH ||
2222 rtype == OP_SUBST ||
2224 if (ismatchop && right->op_private & OPpTARGET_MY) {
2226 right->op_private &= ~OPpTARGET_MY;
2228 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2231 right->op_flags |= OPf_STACKED;
2232 if (rtype != OP_MATCH &&
2233 ! (rtype == OP_TRANS &&
2234 right->op_private & OPpTRANS_IDENTICAL))
2235 newleft = mod(left, rtype);
2238 if (right->op_type == OP_TRANS)
2239 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2241 o = prepend_elem(rtype, scalar(newleft), right);
2243 return newUNOP(OP_NOT, 0, scalar(o));
2247 return bind_match(type, left,
2248 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2252 Perl_invert(pTHX_ OP *o)
2256 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2260 Perl_scope(pTHX_ OP *o)
2264 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2265 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2266 o->op_type = OP_LEAVE;
2267 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2269 else if (o->op_type == OP_LINESEQ) {
2271 o->op_type = OP_SCOPE;
2272 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2273 kid = ((LISTOP*)o)->op_first;
2274 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2277 /* The following deals with things like 'do {1 for 1}' */
2278 kid = kid->op_sibling;
2280 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2285 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2291 Perl_block_start(pTHX_ int full)
2294 const int retval = PL_savestack_ix;
2295 pad_block_start(full);
2297 PL_hints &= ~HINT_BLOCK_SCOPE;
2298 SAVECOMPILEWARNINGS();
2299 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2304 Perl_block_end(pTHX_ I32 floor, OP *seq)
2307 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2308 OP* const retval = scalarseq(seq);
2310 CopHINTS_set(&PL_compiling, PL_hints);
2312 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2321 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2322 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2323 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2326 OP * const o = newOP(OP_PADSV, 0);
2327 o->op_targ = offset;
2333 Perl_newPROG(pTHX_ OP *o)
2337 PERL_ARGS_ASSERT_NEWPROG;
2342 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2343 ((PL_in_eval & EVAL_KEEPERR)
2344 ? OPf_SPECIAL : 0), o);
2345 PL_eval_start = linklist(PL_eval_root);
2346 PL_eval_root->op_private |= OPpREFCOUNTED;
2347 OpREFCNT_set(PL_eval_root, 1);
2348 PL_eval_root->op_next = 0;
2349 CALL_PEEP(PL_eval_start);
2352 if (o->op_type == OP_STUB) {
2353 PL_comppad_name = 0;
2355 S_op_destroy(aTHX_ o);
2358 PL_main_root = scope(sawparens(scalarvoid(o)));
2359 PL_curcop = &PL_compiling;
2360 PL_main_start = LINKLIST(PL_main_root);
2361 PL_main_root->op_private |= OPpREFCOUNTED;
2362 OpREFCNT_set(PL_main_root, 1);
2363 PL_main_root->op_next = 0;
2364 CALL_PEEP(PL_main_start);
2367 /* Register with debugger */
2369 CV * const cv = get_cvs("DB::postponed", 0);
2373 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2375 call_sv(MUTABLE_SV(cv), G_DISCARD);
2382 Perl_localize(pTHX_ OP *o, I32 lex)
2386 PERL_ARGS_ASSERT_LOCALIZE;
2388 if (o->op_flags & OPf_PARENS)
2389 /* [perl #17376]: this appears to be premature, and results in code such as
2390 C< our(%x); > executing in list mode rather than void mode */
2397 if ( PL_parser->bufptr > PL_parser->oldbufptr
2398 && PL_parser->bufptr[-1] == ','
2399 && ckWARN(WARN_PARENTHESIS))
2401 char *s = PL_parser->bufptr;
2404 /* some heuristics to detect a potential error */
2405 while (*s && (strchr(", \t\n", *s)))
2409 if (*s && strchr("@$%*", *s) && *++s
2410 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2413 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2415 while (*s && (strchr(", \t\n", *s)))
2421 if (sigil && (*s == ';' || *s == '=')) {
2422 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2423 "Parentheses missing around \"%s\" list",
2425 ? (PL_parser->in_my == KEY_our
2427 : PL_parser->in_my == KEY_state
2437 o = mod(o, OP_NULL); /* a bit kludgey */
2438 PL_parser->in_my = FALSE;
2439 PL_parser->in_my_stash = NULL;
2444 Perl_jmaybe(pTHX_ OP *o)
2446 PERL_ARGS_ASSERT_JMAYBE;
2448 if (o->op_type == OP_LIST) {
2450 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2451 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2457 S_fold_constants(pTHX_ register OP *o)
2460 register OP * VOL curop;
2462 VOL I32 type = o->op_type;
2467 SV * const oldwarnhook = PL_warnhook;
2468 SV * const olddiehook = PL_diehook;
2472 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2474 if (PL_opargs[type] & OA_RETSCALAR)
2476 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2477 o->op_targ = pad_alloc(type, SVs_PADTMP);
2479 /* integerize op, unless it happens to be C<-foo>.
2480 * XXX should pp_i_negate() do magic string negation instead? */
2481 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2482 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2483 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2485 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2488 if (!(PL_opargs[type] & OA_FOLDCONST))
2493 /* XXX might want a ck_negate() for this */
2494 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2505 /* XXX what about the numeric ops? */
2506 if (PL_hints & HINT_LOCALE)
2511 if (PL_parser && PL_parser->error_count)
2512 goto nope; /* Don't try to run w/ errors */
2514 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2515 const OPCODE type = curop->op_type;
2516 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2518 type != OP_SCALAR &&
2520 type != OP_PUSHMARK)
2526 curop = LINKLIST(o);
2527 old_next = o->op_next;
2531 oldscope = PL_scopestack_ix;
2532 create_eval_scope(G_FAKINGEVAL);
2534 /* Verify that we don't need to save it: */
2535 assert(PL_curcop == &PL_compiling);
2536 StructCopy(&PL_compiling, ¬_compiling, COP);
2537 PL_curcop = ¬_compiling;
2538 /* The above ensures that we run with all the correct hints of the
2539 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2540 assert(IN_PERL_RUNTIME);
2541 PL_warnhook = PERL_WARNHOOK_FATAL;
2548 sv = *(PL_stack_sp--);
2549 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2550 pad_swipe(o->op_targ, FALSE);
2551 else if (SvTEMP(sv)) { /* grab mortal temp? */
2552 SvREFCNT_inc_simple_void(sv);
2557 /* Something tried to die. Abandon constant folding. */
2558 /* Pretend the error never happened. */
2560 o->op_next = old_next;
2564 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2565 PL_warnhook = oldwarnhook;
2566 PL_diehook = olddiehook;
2567 /* XXX note that this croak may fail as we've already blown away
2568 * the stack - eg any nested evals */
2569 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2572 PL_warnhook = oldwarnhook;
2573 PL_diehook = olddiehook;
2574 PL_curcop = &PL_compiling;
2576 if (PL_scopestack_ix > oldscope)
2577 delete_eval_scope();
2586 if (type == OP_RV2GV)
2587 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2589 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2590 op_getmad(o,newop,'f');
2598 S_gen_constant_list(pTHX_ register OP *o)
2602 const I32 oldtmps_floor = PL_tmps_floor;
2605 if (PL_parser && PL_parser->error_count)
2606 return o; /* Don't attempt to run with errors */
2608 PL_op = curop = LINKLIST(o);
2614 assert (!(curop->op_flags & OPf_SPECIAL));
2615 assert(curop->op_type == OP_RANGE);
2617 PL_tmps_floor = oldtmps_floor;
2619 o->op_type = OP_RV2AV;
2620 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2621 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2622 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2623 o->op_opt = 0; /* needs to be revisited in peep() */
2624 curop = ((UNOP*)o)->op_first;
2625 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2627 op_getmad(curop,o,'O');
2636 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2639 if (!o || o->op_type != OP_LIST)
2640 o = newLISTOP(OP_LIST, 0, o, NULL);
2642 o->op_flags &= ~OPf_WANT;
2644 if (!(PL_opargs[type] & OA_MARK))
2645 op_null(cLISTOPo->op_first);
2647 o->op_type = (OPCODE)type;
2648 o->op_ppaddr = PL_ppaddr[type];
2649 o->op_flags |= flags;
2651 o = CHECKOP(type, o);
2652 if (o->op_type != (unsigned)type)
2655 return fold_constants(o);
2658 /* List constructors */
2661 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2669 if (first->op_type != (unsigned)type
2670 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2672 return newLISTOP(type, 0, first, last);
2675 if (first->op_flags & OPf_KIDS)
2676 ((LISTOP*)first)->op_last->op_sibling = last;
2678 first->op_flags |= OPf_KIDS;
2679 ((LISTOP*)first)->op_first = last;
2681 ((LISTOP*)first)->op_last = last;
2686 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2694 if (first->op_type != (unsigned)type)
2695 return prepend_elem(type, (OP*)first, (OP*)last);
2697 if (last->op_type != (unsigned)type)
2698 return append_elem(type, (OP*)first, (OP*)last);
2700 first->op_last->op_sibling = last->op_first;
2701 first->op_last = last->op_last;
2702 first->op_flags |= (last->op_flags & OPf_KIDS);
2705 if (last->op_first && first->op_madprop) {
2706 MADPROP *mp = last->op_first->op_madprop;
2708 while (mp->mad_next)
2710 mp->mad_next = first->op_madprop;
2713 last->op_first->op_madprop = first->op_madprop;
2716 first->op_madprop = last->op_madprop;
2717 last->op_madprop = 0;
2720 S_op_destroy(aTHX_ (OP*)last);
2726 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2734 if (last->op_type == (unsigned)type) {
2735 if (type == OP_LIST) { /* already a PUSHMARK there */
2736 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2737 ((LISTOP*)last)->op_first->op_sibling = first;
2738 if (!(first->op_flags & OPf_PARENS))
2739 last->op_flags &= ~OPf_PARENS;
2742 if (!(last->op_flags & OPf_KIDS)) {
2743 ((LISTOP*)last)->op_last = first;
2744 last->op_flags |= OPf_KIDS;
2746 first->op_sibling = ((LISTOP*)last)->op_first;
2747 ((LISTOP*)last)->op_first = first;
2749 last->op_flags |= OPf_KIDS;
2753 return newLISTOP(type, 0, first, last);
2761 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2764 Newxz(tk, 1, TOKEN);
2765 tk->tk_type = (OPCODE)optype;
2766 tk->tk_type = 12345;
2768 tk->tk_mad = madprop;
2773 Perl_token_free(pTHX_ TOKEN* tk)
2775 PERL_ARGS_ASSERT_TOKEN_FREE;
2777 if (tk->tk_type != 12345)
2779 mad_free(tk->tk_mad);
2784 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2789 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2791 if (tk->tk_type != 12345) {
2792 Perl_warner(aTHX_ packWARN(WARN_MISC),
2793 "Invalid TOKEN object ignored");
2800 /* faked up qw list? */
2802 tm->mad_type == MAD_SV &&
2803 SvPVX((SV *)tm->mad_val)[0] == 'q')
2810 /* pretend constant fold didn't happen? */
2811 if (mp->mad_key == 'f' &&
2812 (o->op_type == OP_CONST ||
2813 o->op_type == OP_GV) )
2815 token_getmad(tk,(OP*)mp->mad_val,slot);
2829 if (mp->mad_key == 'X')
2830 mp->mad_key = slot; /* just change the first one */
2840 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2849 /* pretend constant fold didn't happen? */
2850 if (mp->mad_key == 'f' &&
2851 (o->op_type == OP_CONST ||
2852 o->op_type == OP_GV) )
2854 op_getmad(from,(OP*)mp->mad_val,slot);
2861 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2864 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2870 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2879 /* pretend constant fold didn't happen? */
2880 if (mp->mad_key == 'f' &&
2881 (o->op_type == OP_CONST ||
2882 o->op_type == OP_GV) )
2884 op_getmad(from,(OP*)mp->mad_val,slot);
2891 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2894 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2898 PerlIO_printf(PerlIO_stderr(),
2899 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2905 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2923 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2927 addmad(tm, &(o->op_madprop), slot);
2931 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2952 Perl_newMADsv(pTHX_ char key, SV* sv)
2954 PERL_ARGS_ASSERT_NEWMADSV;
2956 return newMADPROP(key, MAD_SV, sv, 0);
2960 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2963 Newxz(mp, 1, MADPROP);
2966 mp->mad_vlen = vlen;
2967 mp->mad_type = type;
2969 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2974 Perl_mad_free(pTHX_ MADPROP* mp)
2976 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2980 mad_free(mp->mad_next);
2981 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2982 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2983 switch (mp->mad_type) {
2987 Safefree((char*)mp->mad_val);
2990 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2991 op_free((OP*)mp->mad_val);
2994 sv_free(MUTABLE_SV(mp->mad_val));
2997 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3006 Perl_newNULLLIST(pTHX)
3008 return newOP(OP_STUB, 0);
3012 S_force_list(pTHX_ OP *o)
3014 if (!o || o->op_type != OP_LIST)
3015 o = newLISTOP(OP_LIST, 0, o, NULL);
3021 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3026 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3028 NewOp(1101, listop, 1, LISTOP);
3030 listop->op_type = (OPCODE)type;
3031 listop->op_ppaddr = PL_ppaddr[type];
3034 listop->op_flags = (U8)flags;
3038 else if (!first && last)
3041 first->op_sibling = last;
3042 listop->op_first = first;
3043 listop->op_last = last;
3044 if (type == OP_LIST) {
3045 OP* const pushop = newOP(OP_PUSHMARK, 0);
3046 pushop->op_sibling = first;
3047 listop->op_first = pushop;
3048 listop->op_flags |= OPf_KIDS;
3050 listop->op_last = pushop;
3053 return CHECKOP(type, listop);
3057 Perl_newOP(pTHX_ I32 type, I32 flags)
3062 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3063 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3064 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3065 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3067 NewOp(1101, o, 1, OP);
3068 o->op_type = (OPCODE)type;
3069 o->op_ppaddr = PL_ppaddr[type];
3070 o->op_flags = (U8)flags;
3072 o->op_latefreed = 0;
3076 o->op_private = (U8)(0 | (flags >> 8));
3077 if (PL_opargs[type] & OA_RETSCALAR)
3079 if (PL_opargs[type] & OA_TARGET)
3080 o->op_targ = pad_alloc(type, SVs_PADTMP);
3081 return CHECKOP(type, o);
3085 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3090 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3091 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3092 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3093 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3094 || type == OP_SASSIGN
3095 || type == OP_NULL );
3098 first = newOP(OP_STUB, 0);
3099 if (PL_opargs[type] & OA_MARK)
3100 first = force_list(first);
3102 NewOp(1101, unop, 1, UNOP);
3103 unop->op_type = (OPCODE)type;
3104 unop->op_ppaddr = PL_ppaddr[type];
3105 unop->op_first = first;
3106 unop->op_flags = (U8)(flags | OPf_KIDS);
3107 unop->op_private = (U8)(1 | (flags >> 8));
3108 unop = (UNOP*) CHECKOP(type, unop);
3112 return fold_constants((OP *) unop);
3116 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3121 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3122 || type == OP_SASSIGN || type == OP_NULL );
3124 NewOp(1101, binop, 1, BINOP);
3127 first = newOP(OP_NULL, 0);
3129 binop->op_type = (OPCODE)type;
3130 binop->op_ppaddr = PL_ppaddr[type];
3131 binop->op_first = first;
3132 binop->op_flags = (U8)(flags | OPf_KIDS);
3135 binop->op_private = (U8)(1 | (flags >> 8));
3138 binop->op_private = (U8)(2 | (flags >> 8));
3139 first->op_sibling = last;
3142 binop = (BINOP*)CHECKOP(type, binop);
3143 if (binop->op_next || binop->op_type != (OPCODE)type)
3146 binop->op_last = binop->op_first->op_sibling;
3148 return fold_constants((OP *)binop);
3151 static int uvcompare(const void *a, const void *b)
3152 __attribute__nonnull__(1)
3153 __attribute__nonnull__(2)
3154 __attribute__pure__;
3155 static int uvcompare(const void *a, const void *b)
3157 if (*((const UV *)a) < (*(const UV *)b))
3159 if (*((const UV *)a) > (*(const UV *)b))
3161 if (*((const UV *)a+1) < (*(const UV *)b+1))
3163 if (*((const UV *)a+1) > (*(const UV *)b+1))
3169 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3172 SV * const tstr = ((SVOP*)expr)->op_sv;
3175 (repl->op_type == OP_NULL)
3176 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3178 ((SVOP*)repl)->op_sv;
3181 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3182 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3186 register short *tbl;
3188 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3189 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3190 I32 del = o->op_private & OPpTRANS_DELETE;
3193 PERL_ARGS_ASSERT_PMTRANS;
3195 PL_hints |= HINT_BLOCK_SCOPE;
3198 o->op_private |= OPpTRANS_FROM_UTF;
3201 o->op_private |= OPpTRANS_TO_UTF;
3203 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3204 SV* const listsv = newSVpvs("# comment\n");
3206 const U8* tend = t + tlen;
3207 const U8* rend = r + rlen;
3221 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3222 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3225 const U32 flags = UTF8_ALLOW_DEFAULT;
3229 t = tsave = bytes_to_utf8(t, &len);
3232 if (!to_utf && rlen) {
3234 r = rsave = bytes_to_utf8(r, &len);
3238 /* There are several snags with this code on EBCDIC:
3239 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3240 2. scan_const() in toke.c has encoded chars in native encoding which makes
3241 ranges at least in EBCDIC 0..255 range the bottom odd.
3245 U8 tmpbuf[UTF8_MAXBYTES+1];
3248 Newx(cp, 2*tlen, UV);
3250 transv = newSVpvs("");
3252 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3254 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3256 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3260 cp[2*i+1] = cp[2*i];
3264 qsort(cp, i, 2*sizeof(UV), uvcompare);
3265 for (j = 0; j < i; j++) {
3267 diff = val - nextmin;
3269 t = uvuni_to_utf8(tmpbuf,nextmin);
3270 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3272 U8 range_mark = UTF_TO_NATIVE(0xff);
3273 t = uvuni_to_utf8(tmpbuf, val - 1);
3274 sv_catpvn(transv, (char *)&range_mark, 1);
3275 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3282 t = uvuni_to_utf8(tmpbuf,nextmin);
3283 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3285 U8 range_mark = UTF_TO_NATIVE(0xff);
3286 sv_catpvn(transv, (char *)&range_mark, 1);
3288 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3289 UNICODE_ALLOW_SUPER);
3290 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3291 t = (const U8*)SvPVX_const(transv);
3292 tlen = SvCUR(transv);
3296 else if (!rlen && !del) {
3297 r = t; rlen = tlen; rend = tend;
3300 if ((!rlen && !del) || t == r ||
3301 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3303 o->op_private |= OPpTRANS_IDENTICAL;
3307 while (t < tend || tfirst <= tlast) {
3308 /* see if we need more "t" chars */
3309 if (tfirst > tlast) {
3310 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3312 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3314 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3321 /* now see if we need more "r" chars */
3322 if (rfirst > rlast) {
3324 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3326 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3328 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3337 rfirst = rlast = 0xffffffff;
3341 /* now see which range will peter our first, if either. */
3342 tdiff = tlast - tfirst;
3343 rdiff = rlast - rfirst;
3350 if (rfirst == 0xffffffff) {
3351 diff = tdiff; /* oops, pretend rdiff is infinite */
3353 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3354 (long)tfirst, (long)tlast);
3356 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3360 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3361 (long)tfirst, (long)(tfirst + diff),
3364 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3365 (long)tfirst, (long)rfirst);
3367 if (rfirst + diff > max)
3368 max = rfirst + diff;
3370 grows = (tfirst < rfirst &&
3371 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3383 else if (max > 0xff)
3388 PerlMemShared_free(cPVOPo->op_pv);
3389 cPVOPo->op_pv = NULL;
3391 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3393 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3394 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3395 PAD_SETSV(cPADOPo->op_padix, swash);
3397 SvREADONLY_on(swash);
3399 cSVOPo->op_sv = swash;
3401 SvREFCNT_dec(listsv);
3402 SvREFCNT_dec(transv);
3404 if (!del && havefinal && rlen)
3405 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3406 newSVuv((UV)final), 0);
3409 o->op_private |= OPpTRANS_GROWS;
3415 op_getmad(expr,o,'e');
3416 op_getmad(repl,o,'r');
3424 tbl = (short*)cPVOPo->op_pv;
3426 Zero(tbl, 256, short);
3427 for (i = 0; i < (I32)tlen; i++)
3429 for (i = 0, j = 0; i < 256; i++) {
3431 if (j >= (I32)rlen) {
3440 if (i < 128 && r[j] >= 128)
3450 o->op_private |= OPpTRANS_IDENTICAL;
3452 else if (j >= (I32)rlen)
3457 PerlMemShared_realloc(tbl,
3458 (0x101+rlen-j) * sizeof(short));
3459 cPVOPo->op_pv = (char*)tbl;
3461 tbl[0x100] = (short)(rlen - j);
3462 for (i=0; i < (I32)rlen - j; i++)
3463 tbl[0x101+i] = r[j+i];
3467 if (!rlen && !del) {
3470 o->op_private |= OPpTRANS_IDENTICAL;
3472 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3473 o->op_private |= OPpTRANS_IDENTICAL;
3475 for (i = 0; i < 256; i++)
3477 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3478 if (j >= (I32)rlen) {
3480 if (tbl[t[i]] == -1)
3486 if (tbl[t[i]] == -1) {
3487 if (t[i] < 128 && r[j] >= 128)
3494 if(del && rlen == tlen) {
3495 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3496 } else if(rlen > tlen) {
3497 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3501 o->op_private |= OPpTRANS_GROWS;
3503 op_getmad(expr,o,'e');
3504 op_getmad(repl,o,'r');
3514 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3519 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3521 NewOp(1101, pmop, 1, PMOP);
3522 pmop->op_type = (OPCODE)type;
3523 pmop->op_ppaddr = PL_ppaddr[type];
3524 pmop->op_flags = (U8)flags;
3525 pmop->op_private = (U8)(0 | (flags >> 8));
3527 if (PL_hints & HINT_RE_TAINT)
3528 pmop->op_pmflags |= PMf_RETAINT;
3529 if (PL_hints & HINT_LOCALE)
3530 pmop->op_pmflags |= PMf_LOCALE;
3534 assert(SvPOK(PL_regex_pad[0]));
3535 if (SvCUR(PL_regex_pad[0])) {
3536 /* Pop off the "packed" IV from the end. */
3537 SV *const repointer_list = PL_regex_pad[0];
3538 const char *p = SvEND(repointer_list) - sizeof(IV);
3539 const IV offset = *((IV*)p);
3541 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3543 SvEND_set(repointer_list, p);
3545 pmop->op_pmoffset = offset;
3546 /* This slot should be free, so assert this: */
3547 assert(PL_regex_pad[offset] == &PL_sv_undef);
3549 SV * const repointer = &PL_sv_undef;
3550 av_push(PL_regex_padav, repointer);
3551 pmop->op_pmoffset = av_len(PL_regex_padav);
3552 PL_regex_pad = AvARRAY(PL_regex_padav);
3556 return CHECKOP(type, pmop);
3559 /* Given some sort of match op o, and an expression expr containing a
3560 * pattern, either compile expr into a regex and attach it to o (if it's
3561 * constant), or convert expr into a runtime regcomp op sequence (if it's
3564 * isreg indicates that the pattern is part of a regex construct, eg
3565 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3566 * split "pattern", which aren't. In the former case, expr will be a list
3567 * if the pattern contains more than one term (eg /a$b/) or if it contains
3568 * a replacement, ie s/// or tr///.
3572 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3577 I32 repl_has_vars = 0;
3581 PERL_ARGS_ASSERT_PMRUNTIME;
3583 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3584 /* last element in list is the replacement; pop it */
3586 repl = cLISTOPx(expr)->op_last;
3587 kid = cLISTOPx(expr)->op_first;
3588 while (kid->op_sibling != repl)
3589 kid = kid->op_sibling;
3590 kid->op_sibling = NULL;
3591 cLISTOPx(expr)->op_last = kid;
3594 if (isreg && expr->op_type == OP_LIST &&
3595 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3597 /* convert single element list to element */
3598 OP* const oe = expr;
3599 expr = cLISTOPx(oe)->op_first->op_sibling;
3600 cLISTOPx(oe)->op_first->op_sibling = NULL;
3601 cLISTOPx(oe)->op_last = NULL;
3605 if (o->op_type == OP_TRANS) {
3606 return pmtrans(o, expr, repl);
3609 reglist = isreg && expr->op_type == OP_LIST;
3613 PL_hints |= HINT_BLOCK_SCOPE;
3616 if (expr->op_type == OP_CONST) {
3617 SV *pat = ((SVOP*)expr)->op_sv;
3618 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3620 if (o->op_flags & OPf_SPECIAL)
3621 pm_flags |= RXf_SPLIT;
3624 assert (SvUTF8(pat));
3625 } else if (SvUTF8(pat)) {
3626 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3627 trapped in use 'bytes'? */
3628 /* Make a copy of the octet sequence, but without the flag on, as
3629 the compiler now honours the SvUTF8 flag on pat. */
3631 const char *const p = SvPV(pat, len);
3632 pat = newSVpvn_flags(p, len, SVs_TEMP);
3635 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3638 op_getmad(expr,(OP*)pm,'e');
3644 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3645 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3647 : OP_REGCMAYBE),0,expr);
3649 NewOp(1101, rcop, 1, LOGOP);
3650 rcop->op_type = OP_REGCOMP;
3651 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3652 rcop->op_first = scalar(expr);
3653 rcop->op_flags |= OPf_KIDS
3654 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3655 | (reglist ? OPf_STACKED : 0);
3656 rcop->op_private = 1;
3659 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3661 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3664 /* establish postfix order */
3665 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3667 rcop->op_next = expr;
3668 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3671 rcop->op_next = LINKLIST(expr);
3672 expr->op_next = (OP*)rcop;
3675 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3680 if (pm->op_pmflags & PMf_EVAL) {
3682 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3683 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3685 else if (repl->op_type == OP_CONST)
3689 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3690 if (curop->op_type == OP_SCOPE
3691 || curop->op_type == OP_LEAVE
3692 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3693 if (curop->op_type == OP_GV) {
3694 GV * const gv = cGVOPx_gv(curop);
3696 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3699 else if (curop->op_type == OP_RV2CV)
3701 else if (curop->op_type == OP_RV2SV ||
3702 curop->op_type == OP_RV2AV ||
3703 curop->op_type == OP_RV2HV ||
3704 curop->op_type == OP_RV2GV) {
3705 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3708 else if (curop->op_type == OP_PADSV ||
3709 curop->op_type == OP_PADAV ||
3710 curop->op_type == OP_PADHV ||
3711 curop->op_type == OP_PADANY)
3715 else if (curop->op_type == OP_PUSHRE)
3716 NOOP; /* Okay here, dangerous in newASSIGNOP */
3726 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3728 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3729 prepend_elem(o->op_type, scalar(repl), o);
3732 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3733 pm->op_pmflags |= PMf_MAYBE_CONST;
3735 NewOp(1101, rcop, 1, LOGOP);
3736 rcop->op_type = OP_SUBSTCONT;
3737 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3738 rcop->op_first = scalar(repl);
3739 rcop->op_flags |= OPf_KIDS;
3740 rcop->op_private = 1;
3743 /* establish postfix order */
3744 rcop->op_next = LINKLIST(repl);
3745 repl->op_next = (OP*)rcop;
3747 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3748 assert(!(pm->op_pmflags & PMf_ONCE));
3749 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3758 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3763 PERL_ARGS_ASSERT_NEWSVOP;
3765 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3766 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3767 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3769 NewOp(1101, svop, 1, SVOP);
3770 svop->op_type = (OPCODE)type;
3771 svop->op_ppaddr = PL_ppaddr[type];
3773 svop->op_next = (OP*)svop;
3774 svop->op_flags = (U8)flags;
3775 if (PL_opargs[type] & OA_RETSCALAR)
3777 if (PL_opargs[type] & OA_TARGET)
3778 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3779 return CHECKOP(type, svop);
3784 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3789 PERL_ARGS_ASSERT_NEWPADOP;
3791 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3792 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3793 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3795 NewOp(1101, padop, 1, PADOP);
3796 padop->op_type = (OPCODE)type;
3797 padop->op_ppaddr = PL_ppaddr[type];
3798 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3799 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3800 PAD_SETSV(padop->op_padix, sv);
3803 padop->op_next = (OP*)padop;
3804 padop->op_flags = (U8)flags;
3805 if (PL_opargs[type] & OA_RETSCALAR)
3807 if (PL_opargs[type] & OA_TARGET)
3808 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3809 return CHECKOP(type, padop);
3814 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3818 PERL_ARGS_ASSERT_NEWGVOP;
3822 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3824 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3829 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3834 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3835 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3837 NewOp(1101, pvop, 1, PVOP);
3838 pvop->op_type = (OPCODE)type;
3839 pvop->op_ppaddr = PL_ppaddr[type];
3841 pvop->op_next = (OP*)pvop;
3842 pvop->op_flags = (U8)flags;
3843 if (PL_opargs[type] & OA_RETSCALAR)
3845 if (PL_opargs[type] & OA_TARGET)
3846 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3847 return CHECKOP(type, pvop);
3855 Perl_package(pTHX_ OP *o)
3858 SV *const sv = cSVOPo->op_sv;
3863 PERL_ARGS_ASSERT_PACKAGE;
3865 save_hptr(&PL_curstash);
3866 save_item(PL_curstname);
3868 PL_curstash = gv_stashsv(sv, GV_ADD);
3870 sv_setsv(PL_curstname, sv);
3872 PL_hints |= HINT_BLOCK_SCOPE;
3873 PL_parser->copline = NOLINE;
3874 PL_parser->expect = XSTATE;
3879 if (!PL_madskills) {
3884 pegop = newOP(OP_NULL,0);
3885 op_getmad(o,pegop,'P');
3891 Perl_package_version( pTHX_ OP *v )
3894 U32 savehints = PL_hints;
3895 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3896 PL_hints &= ~HINT_STRICT_VARS;
3897 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3898 PL_hints = savehints;
3907 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3914 OP *pegop = newOP(OP_NULL,0);
3917 PERL_ARGS_ASSERT_UTILIZE;
3919 if (idop->op_type != OP_CONST)
3920 Perl_croak(aTHX_ "Module name must be constant");
3923 op_getmad(idop,pegop,'U');
3928 SV * const vesv = ((SVOP*)version)->op_sv;
3931 op_getmad(version,pegop,'V');
3932 if (!arg && !SvNIOKp(vesv)) {
3939 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3940 Perl_croak(aTHX_ "Version number must be a constant number");
3942 /* Make copy of idop so we don't free it twice */
3943 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3945 /* Fake up a method call to VERSION */
3946 meth = newSVpvs_share("VERSION");
3947 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3948 append_elem(OP_LIST,
3949 prepend_elem(OP_LIST, pack, list(version)),
3950 newSVOP(OP_METHOD_NAMED, 0, meth)));
3954 /* Fake up an import/unimport */
3955 if (arg && arg->op_type == OP_STUB) {
3957 op_getmad(arg,pegop,'S');
3958 imop = arg; /* no import on explicit () */
3960 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3961 imop = NULL; /* use 5.0; */
3963 idop->op_private |= OPpCONST_NOVER;
3969 op_getmad(arg,pegop,'A');
3971 /* Make copy of idop so we don't free it twice */
3972 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3974 /* Fake up a method call to import/unimport */
3976 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3977 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3978 append_elem(OP_LIST,
3979 prepend_elem(OP_LIST, pack, list(arg)),
3980 newSVOP(OP_METHOD_NAMED, 0, meth)));
3983 /* Fake up the BEGIN {}, which does its thing immediately. */
3985 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3988 append_elem(OP_LINESEQ,
3989 append_elem(OP_LINESEQ,
3990 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3991 newSTATEOP(0, NULL, veop)),
3992 newSTATEOP(0, NULL, imop) ));
3994 /* The "did you use incorrect case?" warning used to be here.
3995 * The problem is that on case-insensitive filesystems one
3996 * might get false positives for "use" (and "require"):
3997 * "use Strict" or "require CARP" will work. This causes
3998 * portability problems for the script: in case-strict
3999 * filesystems the script will stop working.
4001 * The "incorrect case" warning checked whether "use Foo"
4002 * imported "Foo" to your namespace, but that is wrong, too:
4003 * there is no requirement nor promise in the language that
4004 * a Foo.pm should or would contain anything in package "Foo".
4006 * There is very little Configure-wise that can be done, either:
4007 * the case-sensitivity of the build filesystem of Perl does not
4008 * help in guessing the case-sensitivity of the runtime environment.
4011 PL_hints |= HINT_BLOCK_SCOPE;
4012 PL_parser->copline = NOLINE;
4013 PL_parser->expect = XSTATE;
4014 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4017 if (!PL_madskills) {
4018 /* FIXME - don't allocate pegop if !PL_madskills */
4027 =head1 Embedding Functions
4029 =for apidoc load_module
4031 Loads the module whose name is pointed to by the string part of name.
4032 Note that the actual module name, not its filename, should be given.
4033 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4034 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4035 (or 0 for no flags). ver, if specified, provides version semantics
4036 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4037 arguments can be used to specify arguments to the module's import()
4038 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4039 terminated with a final NULL pointer. Note that this list can only
4040 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4041 Otherwise at least a single NULL pointer to designate the default
4042 import list is required.
4047 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4051 PERL_ARGS_ASSERT_LOAD_MODULE;
4053 va_start(args, ver);
4054 vload_module(flags, name, ver, &args);
4058 #ifdef PERL_IMPLICIT_CONTEXT
4060 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4064 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4065 va_start(args, ver);
4066 vload_module(flags, name, ver, &args);
4072 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4076 OP * const modname = newSVOP(OP_CONST, 0, name);
4078 PERL_ARGS_ASSERT_VLOAD_MODULE;
4080 modname->op_private |= OPpCONST_BARE;
4082 veop = newSVOP(OP_CONST, 0, ver);
4086 if (flags & PERL_LOADMOD_NOIMPORT) {
4087 imop = sawparens(newNULLLIST());
4089 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4090 imop = va_arg(*args, OP*);
4095 sv = va_arg(*args, SV*);
4097 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4098 sv = va_arg(*args, SV*);
4102 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4103 * that it has a PL_parser to play with while doing that, and also
4104 * that it doesn't mess with any existing parser, by creating a tmp
4105 * new parser with lex_start(). This won't actually be used for much,
4106 * since pp_require() will create another parser for the real work. */
4109 SAVEVPTR(PL_curcop);
4110 lex_start(NULL, NULL, FALSE);
4111 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4112 veop, modname, imop);
4117 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4123 PERL_ARGS_ASSERT_DOFILE;
4125 if (!force_builtin) {
4126 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4127 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4128 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4129 gv = gvp ? *gvp : NULL;
4133 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4134 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4135 append_elem(OP_LIST, term,
4136 scalar(newUNOP(OP_RV2CV, 0,
4137 newGVOP(OP_GV, 0, gv))))));
4140 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4146 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4148 return newBINOP(OP_LSLICE, flags,
4149 list(force_list(subscript)),
4150 list(force_list(listval)) );
4154 S_is_list_assignment(pTHX_ register const OP *o)
4162 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4163 o = cUNOPo->op_first;
4165 flags = o->op_flags;
4167 if (type == OP_COND_EXPR) {
4168 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4169 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4174 yyerror("Assignment to both a list and a scalar");
4178 if (type == OP_LIST &&
4179 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4180 o->op_private & OPpLVAL_INTRO)
4183 if (type == OP_LIST || flags & OPf_PARENS ||
4184 type == OP_RV2AV || type == OP_RV2HV ||
4185 type == OP_ASLICE || type == OP_HSLICE)
4188 if (type == OP_PADAV || type == OP_PADHV)
4191 if (type == OP_RV2SV)
4198 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4204 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4205 return newLOGOP(optype, 0,
4206 mod(scalar(left), optype),
4207 newUNOP(OP_SASSIGN, 0, scalar(right)));
4210 return newBINOP(optype, OPf_STACKED,
4211 mod(scalar(left), optype), scalar(right));
4215 if (is_list_assignment(left)) {
4216 static const char no_list_state[] = "Initialization of state variables"
4217 " in list context currently forbidden";
4219 bool maybe_common_vars = TRUE;
4222 /* Grandfathering $[ assignment here. Bletch.*/
4223 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4224 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4225 left = mod(left, OP_AASSIGN);
4228 else if (left->op_type == OP_CONST) {
4230 /* Result of assignment is always 1 (or we'd be dead already) */
4231 return newSVOP(OP_CONST, 0, newSViv(1));
4233 curop = list(force_list(left));
4234 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4235 o->op_private = (U8)(0 | (flags >> 8));
4237 if ((left->op_type == OP_LIST
4238 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4240 OP* lop = ((LISTOP*)left)->op_first;
4241 maybe_common_vars = FALSE;
4243 if (lop->op_type == OP_PADSV ||
4244 lop->op_type == OP_PADAV ||
4245 lop->op_type == OP_PADHV ||
4246 lop->op_type == OP_PADANY) {
4247 if (!(lop->op_private & OPpLVAL_INTRO))
4248 maybe_common_vars = TRUE;
4250 if (lop->op_private & OPpPAD_STATE) {
4251 if (left->op_private & OPpLVAL_INTRO) {
4252 /* Each variable in state($a, $b, $c) = ... */
4255 /* Each state variable in
4256 (state $a, my $b, our $c, $d, undef) = ... */
4258 yyerror(no_list_state);
4260 /* Each my variable in
4261 (state $a, my $b, our $c, $d, undef) = ... */
4263 } else if (lop->op_type == OP_UNDEF ||
4264 lop->op_type == OP_PUSHMARK) {
4265 /* undef may be interesting in
4266 (state $a, undef, state $c) */
4268 /* Other ops in the list. */
4269 maybe_common_vars = TRUE;
4271 lop = lop->op_sibling;
4274 else if ((left->op_private & OPpLVAL_INTRO)
4275 && ( left->op_type == OP_PADSV
4276 || left->op_type == OP_PADAV
4277 || left->op_type == OP_PADHV
4278 || left->op_type == OP_PADANY))
4280 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4281 if (left->op_private & OPpPAD_STATE) {
4282 /* All single variable list context state assignments, hence
4292 yyerror(no_list_state);
4296 /* PL_generation sorcery:
4297 * an assignment like ($a,$b) = ($c,$d) is easier than
4298 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4299 * To detect whether there are common vars, the global var
4300 * PL_generation is incremented for each assign op we compile.
4301 * Then, while compiling the assign op, we run through all the
4302 * variables on both sides of the assignment, setting a spare slot
4303 * in each of them to PL_generation. If any of them already have
4304 * that value, we know we've got commonality. We could use a
4305 * single bit marker, but then we'd have to make 2 passes, first
4306 * to clear the flag, then to test and set it. To find somewhere
4307 * to store these values, evil chicanery is done with SvUVX().
4310 if (maybe_common_vars) {
4313 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4314 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4315 if (curop->op_type == OP_GV) {
4316 GV *gv = cGVOPx_gv(curop);
4318 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4320 GvASSIGN_GENERATION_set(gv, PL_generation);
4322 else if (curop->op_type == OP_PADSV ||
4323 curop->op_type == OP_PADAV ||
4324 curop->op_type == OP_PADHV ||
4325 curop->op_type == OP_PADANY)
4327 if (PAD_COMPNAME_GEN(curop->op_targ)
4328 == (STRLEN)PL_generation)
4330 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4333 else if (curop->op_type == OP_RV2CV)
4335 else if (curop->op_type == OP_RV2SV ||
4336 curop->op_type == OP_RV2AV ||
4337 curop->op_type == OP_RV2HV ||
4338 curop->op_type == OP_RV2GV) {
4339 if (lastop->op_type != OP_GV) /* funny deref? */
4342 else if (curop->op_type == OP_PUSHRE) {
4344 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4345 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4347 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4349 GvASSIGN_GENERATION_set(gv, PL_generation);
4353 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4356 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4358 GvASSIGN_GENERATION_set(gv, PL_generation);
4368 o->op_private |= OPpASSIGN_COMMON;
4371 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4372 OP* tmpop = ((LISTOP*)right)->op_first;
4373 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4374 PMOP * const pm = (PMOP*)tmpop;
4375 if (left->op_type == OP_RV2AV &&
4376 !(left->op_private & OPpLVAL_INTRO) &&
4377 !(o->op_private & OPpASSIGN_COMMON) )
4379 tmpop = ((UNOP*)left)->op_first;
4380 if (tmpop->op_type == OP_GV
4382 && !pm->op_pmreplrootu.op_pmtargetoff
4384 && !pm->op_pmreplrootu.op_pmtargetgv
4388 pm->op_pmreplrootu.op_pmtargetoff
4389 = cPADOPx(tmpop)->op_padix;
4390 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4392 pm->op_pmreplrootu.op_pmtargetgv
4393 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4394 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4396 pm->op_pmflags |= PMf_ONCE;
4397 tmpop = cUNOPo->op_first; /* to list (nulled) */
4398 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4399 tmpop->op_sibling = NULL; /* don't free split */
4400 right->op_next = tmpop->op_next; /* fix starting loc */
4401 op_free(o); /* blow off assign */
4402 right->op_flags &= ~OPf_WANT;
4403 /* "I don't know and I don't care." */
4408 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4409 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4411 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4412 if (SvIOK(sv) && SvIVX(sv) == 0)
4413 sv_setiv(sv, PL_modcount+1);
4421 right = newOP(OP_UNDEF, 0);
4422 if (right->op_type == OP_READLINE) {
4423 right->op_flags |= OPf_STACKED;
4424 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4427 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4428 o = newBINOP(OP_SASSIGN, flags,
4429 scalar(right), mod(scalar(left), OP_SASSIGN) );
4433 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4434 deprecate("assignment to $[");
4436 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4437 o->op_private |= OPpCONST_ARYBASE;
4445 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4448 const U32 seq = intro_my();
4451 NewOp(1101, cop, 1, COP);
4452 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4453 cop->op_type = OP_DBSTATE;
4454 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4457 cop->op_type = OP_NEXTSTATE;
4458 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4460 cop->op_flags = (U8)flags;
4461 CopHINTS_set(cop, PL_hints);
4463 cop->op_private |= NATIVE_HINTS;
4465 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4466 cop->op_next = (OP*)cop;
4469 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4470 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4472 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4473 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4474 if (cop->cop_hints_hash) {
4476 cop->cop_hints_hash->refcounted_he_refcnt++;
4477 HINTS_REFCNT_UNLOCK;
4481 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4483 PL_hints |= HINT_BLOCK_SCOPE;
4484 /* It seems that we need to defer freeing this pointer, as other parts
4485 of the grammar end up wanting to copy it after this op has been
4490 if (PL_parser && PL_parser->copline == NOLINE)
4491 CopLINE_set(cop, CopLINE(PL_curcop));
4493 CopLINE_set(cop, PL_parser->copline);
4495 PL_parser->copline = NOLINE;
4498 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4500 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4502 CopSTASH_set(cop, PL_curstash);
4504 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4505 /* this line can have a breakpoint - store the cop in IV */
4506 AV *av = CopFILEAVx(PL_curcop);
4508 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4509 if (svp && *svp != &PL_sv_undef ) {
4510 (void)SvIOK_on(*svp);
4511 SvIV_set(*svp, PTR2IV(cop));
4516 if (flags & OPf_SPECIAL)
4518 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4523 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4527 PERL_ARGS_ASSERT_NEWLOGOP;
4529 return new_logop(type, flags, &first, &other);
4533 S_search_const(pTHX_ OP *o)
4535 PERL_ARGS_ASSERT_SEARCH_CONST;
4537 switch (o->op_type) {
4541 if (o->op_flags & OPf_KIDS)
4542 return search_const(cUNOPo->op_first);
4549 if (!(o->op_flags & OPf_KIDS))
4551 kid = cLISTOPo->op_first;
4553 switch (kid->op_type) {
4557 kid = kid->op_sibling;
4560 if (kid != cLISTOPo->op_last)
4566 kid = cLISTOPo->op_last;
4568 return search_const(kid);
4576 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4584 int prepend_not = 0;
4586 PERL_ARGS_ASSERT_NEW_LOGOP;
4591 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4592 return newBINOP(type, flags, scalar(first), scalar(other));
4594 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4596 scalarboolean(first);
4597 /* optimize AND and OR ops that have NOTs as children */
4598 if (first->op_type == OP_NOT
4599 && (first->op_flags & OPf_KIDS)
4600 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4601 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4603 if (type == OP_AND || type == OP_OR) {
4609 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4611 prepend_not = 1; /* prepend a NOT op later */
4615 /* search for a constant op that could let us fold the test */
4616 if ((cstop = search_const(first))) {
4617 if (cstop->op_private & OPpCONST_STRICT)
4618 no_bareword_allowed(cstop);
4619 else if ((cstop->op_private & OPpCONST_BARE))
4620 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4621 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4622 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4623 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4625 if (other->op_type == OP_CONST)
4626 other->op_private |= OPpCONST_SHORTCIRCUIT;
4628 OP *newop = newUNOP(OP_NULL, 0, other);
4629 op_getmad(first, newop, '1');
4630 newop->op_targ = type; /* set "was" field */
4634 if (other->op_type == OP_LEAVE)
4635 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4639 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4640 const OP *o2 = other;
4641 if ( ! (o2->op_type == OP_LIST
4642 && (( o2 = cUNOPx(o2)->op_first))
4643 && o2->op_type == OP_PUSHMARK
4644 && (( o2 = o2->op_sibling)) )
4647 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4648 || o2->op_type == OP_PADHV)
4649 && o2->op_private & OPpLVAL_INTRO
4650 && !(o2->op_private & OPpPAD_STATE))
4652 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4653 "Deprecated use of my() in false conditional");
4657 if (first->op_type == OP_CONST)
4658 first->op_private |= OPpCONST_SHORTCIRCUIT;
4660 first = newUNOP(OP_NULL, 0, first);
4661 op_getmad(other, first, '2');
4662 first->op_targ = type; /* set "was" field */
4669 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4670 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4672 const OP * const k1 = ((UNOP*)first)->op_first;
4673 const OP * const k2 = k1->op_sibling;
4675 switch (first->op_type)
4678 if (k2 && k2->op_type == OP_READLINE
4679 && (k2->op_flags & OPf_STACKED)
4680 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4682 warnop = k2->op_type;
4687 if (k1->op_type == OP_READDIR
4688 || k1->op_type == OP_GLOB
4689 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4690 || k1->op_type == OP_EACH)
4692 warnop = ((k1->op_type == OP_NULL)
4693 ? (OPCODE)k1->op_targ : k1->op_type);
4698 const line_t oldline = CopLINE(PL_curcop);
4699 CopLINE_set(PL_curcop, PL_parser->copline);
4700 Perl_warner(aTHX_ packWARN(WARN_MISC),
4701 "Value of %s%s can be \"0\"; test with defined()",
4703 ((warnop == OP_READLINE || warnop == OP_GLOB)
4704 ? " construct" : "() operator"));
4705 CopLINE_set(PL_curcop, oldline);
4712 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4713 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4715 NewOp(1101, logop, 1, LOGOP);
4717 logop->op_type = (OPCODE)type;
4718 logop->op_ppaddr = PL_ppaddr[type];
4719 logop->op_first = first;
4720 logop->op_flags = (U8)(flags | OPf_KIDS);
4721 logop->op_other = LINKLIST(other);
4722 logop->op_private = (U8)(1 | (flags >> 8));
4724 /* establish postfix order */
4725 logop->op_next = LINKLIST(first);
4726 first->op_next = (OP*)logop;
4727 first->op_sibling = other;
4729 CHECKOP(type,logop);
4731 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4738 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4746 PERL_ARGS_ASSERT_NEWCONDOP;
4749 return newLOGOP(OP_AND, 0, first, trueop);
4751 return newLOGOP(OP_OR, 0, first, falseop);
4753 scalarboolean(first);
4754 if ((cstop = search_const(first))) {
4755 /* Left or right arm of the conditional? */
4756 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4757 OP *live = left ? trueop : falseop;
4758 OP *const dead = left ? falseop : trueop;
4759 if (cstop->op_private & OPpCONST_BARE &&
4760 cstop->op_private & OPpCONST_STRICT) {
4761 no_bareword_allowed(cstop);
4764 /* This is all dead code when PERL_MAD is not defined. */
4765 live = newUNOP(OP_NULL, 0, live);
4766 op_getmad(first, live, 'C');
4767 op_getmad(dead, live, left ? 'e' : 't');
4772 if (live->op_type == OP_LEAVE)
4773 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4776 NewOp(1101, logop, 1, LOGOP);
4777 logop->op_type = OP_COND_EXPR;
4778 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4779 logop->op_first = first;
4780 logop->op_flags = (U8)(flags | OPf_KIDS);
4781 logop->op_private = (U8)(1 | (flags >> 8));
4782 logop->op_other = LINKLIST(trueop);
4783 logop->op_next = LINKLIST(falseop);
4785 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4788 /* establish postfix order */
4789 start = LINKLIST(first);
4790 first->op_next = (OP*)logop;
4792 first->op_sibling = trueop;
4793 trueop->op_sibling = falseop;
4794 o = newUNOP(OP_NULL, 0, (OP*)logop);
4796 trueop->op_next = falseop->op_next = o;
4803 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4812 PERL_ARGS_ASSERT_NEWRANGE;
4814 NewOp(1101, range, 1, LOGOP);
4816 range->op_type = OP_RANGE;
4817 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4818 range->op_first = left;
4819 range->op_flags = OPf_KIDS;
4820 leftstart = LINKLIST(left);
4821 range->op_other = LINKLIST(right);
4822 range->op_private = (U8)(1 | (flags >> 8));
4824 left->op_sibling = right;
4826 range->op_next = (OP*)range;
4827 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4828 flop = newUNOP(OP_FLOP, 0, flip);
4829 o = newUNOP(OP_NULL, 0, flop);
4831 range->op_next = leftstart;
4833 left->op_next = flip;
4834 right->op_next = flop;
4836 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4837 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4838 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4839 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4841 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4842 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4845 if (!flip->op_private || !flop->op_private)
4846 linklist(o); /* blow off optimizer unless constant */
4852 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4857 const bool once = block && block->op_flags & OPf_SPECIAL &&
4858 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4860 PERL_UNUSED_ARG(debuggable);
4863 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4864 return block; /* do {} while 0 does once */
4865 if (expr->op_type == OP_READLINE
4866 || expr->op_type == OP_READDIR
4867 || expr->op_type == OP_GLOB
4868 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4869 expr = newUNOP(OP_DEFINED, 0,
4870 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4871 } else if (expr->op_flags & OPf_KIDS) {
4872 const OP * const k1 = ((UNOP*)expr)->op_first;
4873 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4874 switch (expr->op_type) {
4876 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4877 && (k2->op_flags & OPf_STACKED)
4878 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4879 expr = newUNOP(OP_DEFINED, 0, expr);
4883 if (k1 && (k1->op_type == OP_READDIR
4884 || k1->op_type == OP_GLOB
4885 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4886 || k1->op_type == OP_EACH))
4887 expr = newUNOP(OP_DEFINED, 0, expr);
4893 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4894 * op, in listop. This is wrong. [perl #27024] */
4896 block = newOP(OP_NULL, 0);
4897 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4898 o = new_logop(OP_AND, 0, &expr, &listop);
4901 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4903 if (once && o != listop)
4904 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4907 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4909 o->op_flags |= flags;
4911 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4916 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4917 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4926 PERL_UNUSED_ARG(debuggable);
4929 if (expr->op_type == OP_READLINE
4930 || expr->op_type == OP_READDIR
4931 || expr->op_type == OP_GLOB
4932 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4933 expr = newUNOP(OP_DEFINED, 0,
4934 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4935 } else if (expr->op_flags & OPf_KIDS) {
4936 const OP * const k1 = ((UNOP*)expr)->op_first;
4937 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4938 switch (expr->op_type) {
4940 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4941 && (k2->op_flags & OPf_STACKED)
4942 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4943 expr = newUNOP(OP_DEFINED, 0, expr);
4947 if (k1 && (k1->op_type == OP_READDIR
4948 || k1->op_type == OP_GLOB
4949 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4950 || k1->op_type == OP_EACH))
4951 expr = newUNOP(OP_DEFINED, 0, expr);
4958 block = newOP(OP_NULL, 0);
4959 else if (cont || has_my) {
4960 block = scope(block);
4964 next = LINKLIST(cont);
4967 OP * const unstack = newOP(OP_UNSTACK, 0);
4970 cont = append_elem(OP_LINESEQ, cont, unstack);
4974 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4976 redo = LINKLIST(listop);
4979 PL_parser->copline = (line_t)whileline;
4981 o = new_logop(OP_AND, 0, &expr, &listop);
4982 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4983 op_free(expr); /* oops, it's a while (0) */
4985 return NULL; /* listop already freed by new_logop */
4988 ((LISTOP*)listop)->op_last->op_next =
4989 (o == listop ? redo : LINKLIST(o));
4995 NewOp(1101,loop,1,LOOP);
4996 loop->op_type = OP_ENTERLOOP;
4997 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4998 loop->op_private = 0;
4999 loop->op_next = (OP*)loop;
5002 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5004 loop->op_redoop = redo;
5005 loop->op_lastop = o;
5006 o->op_private |= loopflags;
5009 loop->op_nextop = next;
5011 loop->op_nextop = o;
5013 o->op_flags |= flags;
5014 o->op_private |= (flags >> 8);
5019 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
5024 PADOFFSET padoff = 0;
5029 PERL_ARGS_ASSERT_NEWFOROP;
5032 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5033 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5034 sv->op_type = OP_RV2GV;
5035 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5037 /* The op_type check is needed to prevent a possible segfault
5038 * if the loop variable is undeclared and 'strict vars' is in
5039 * effect. This is illegal but is nonetheless parsed, so we
5040 * may reach this point with an OP_CONST where we're expecting
5043 if (cUNOPx(sv)->op_first->op_type == OP_GV
5044 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5045 iterpflags |= OPpITER_DEF;
5047 else if (sv->op_type == OP_PADSV) { /* private variable */
5048 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5049 padoff = sv->op_targ;
5059 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5061 SV *const namesv = PAD_COMPNAME_SV(padoff);
5063 const char *const name = SvPV_const(namesv, len);
5065 if (len == 2 && name[0] == '$' && name[1] == '_')
5066 iterpflags |= OPpITER_DEF;
5070 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5071 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5072 sv = newGVOP(OP_GV, 0, PL_defgv);
5077 iterpflags |= OPpITER_DEF;
5079 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5080 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5081 iterflags |= OPf_STACKED;
5083 else if (expr->op_type == OP_NULL &&
5084 (expr->op_flags & OPf_KIDS) &&
5085 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5087 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5088 * set the STACKED flag to indicate that these values are to be
5089 * treated as min/max values by 'pp_iterinit'.
5091 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5092 LOGOP* const range = (LOGOP*) flip->op_first;
5093 OP* const left = range->op_first;
5094 OP* const right = left->op_sibling;
5097 range->op_flags &= ~OPf_KIDS;
5098 range->op_first = NULL;
5100 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5101 listop->op_first->op_next = range->op_next;
5102 left->op_next = range->op_other;
5103 right->op_next = (OP*)listop;
5104 listop->op_next = listop->op_first;
5107 op_getmad(expr,(OP*)listop,'O');
5111 expr = (OP*)(listop);
5113 iterflags |= OPf_STACKED;
5116 expr = mod(force_list(expr), OP_GREPSTART);
5119 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5120 append_elem(OP_LIST, expr, scalar(sv))));
5121 assert(!loop->op_next);
5122 /* for my $x () sets OPpLVAL_INTRO;
5123 * for our $x () sets OPpOUR_INTRO */
5124 loop->op_private = (U8)iterpflags;
5125 #ifdef PL_OP_SLAB_ALLOC
5128 NewOp(1234,tmp,1,LOOP);
5129 Copy(loop,tmp,1,LISTOP);
5130 S_op_destroy(aTHX_ (OP*)loop);
5134 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5136 loop->op_targ = padoff;
5137 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5139 op_getmad(madsv, (OP*)loop, 'v');
5140 PL_parser->copline = forline;
5141 return newSTATEOP(0, label, wop);
5145 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5150 PERL_ARGS_ASSERT_NEWLOOPEX;
5152 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5154 if (type != OP_GOTO || label->op_type == OP_CONST) {
5155 /* "last()" means "last" */
5156 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5157 o = newOP(type, OPf_SPECIAL);
5159 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5160 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5164 op_getmad(label,o,'L');
5170 /* Check whether it's going to be a goto &function */
5171 if (label->op_type == OP_ENTERSUB
5172 && !(label->op_flags & OPf_STACKED))
5173 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5174 o = newUNOP(type, OPf_STACKED, label);
5176 PL_hints |= HINT_BLOCK_SCOPE;
5180 /* if the condition is a literal array or hash
5181 (or @{ ... } etc), make a reference to it.
5184 S_ref_array_or_hash(pTHX_ OP *cond)
5187 && (cond->op_type == OP_RV2AV
5188 || cond->op_type == OP_PADAV
5189 || cond->op_type == OP_RV2HV
5190 || cond->op_type == OP_PADHV))
5192 return newUNOP(OP_REFGEN,
5193 0, mod(cond, OP_REFGEN));
5199 /* These construct the optree fragments representing given()
5202 entergiven and enterwhen are LOGOPs; the op_other pointer
5203 points up to the associated leave op. We need this so we
5204 can put it in the context and make break/continue work.
5205 (Also, of course, pp_enterwhen will jump straight to
5206 op_other if the match fails.)
5210 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5211 I32 enter_opcode, I32 leave_opcode,
5212 PADOFFSET entertarg)
5218 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5220 NewOp(1101, enterop, 1, LOGOP);
5221 enterop->op_type = (Optype)enter_opcode;
5222 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5223 enterop->op_flags = (U8) OPf_KIDS;
5224 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5225 enterop->op_private = 0;
5227 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5230 enterop->op_first = scalar(cond);
5231 cond->op_sibling = block;
5233 o->op_next = LINKLIST(cond);
5234 cond->op_next = (OP *) enterop;
5237 /* This is a default {} block */
5238 enterop->op_first = block;
5239 enterop->op_flags |= OPf_SPECIAL;
5241 o->op_next = (OP *) enterop;
5244 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5245 entergiven and enterwhen both
5248 enterop->op_next = LINKLIST(block);
5249 block->op_next = enterop->op_other = o;
5254 /* Does this look like a boolean operation? For these purposes
5255 a boolean operation is:
5256 - a subroutine call [*]
5257 - a logical connective
5258 - a comparison operator
5259 - a filetest operator, with the exception of -s -M -A -C
5260 - defined(), exists() or eof()
5261 - /$re/ or $foo =~ /$re/
5263 [*] possibly surprising
5266 S_looks_like_bool(pTHX_ const OP *o)
5270 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5272 switch(o->op_type) {
5275 return looks_like_bool(cLOGOPo->op_first);
5279 looks_like_bool(cLOGOPo->op_first)
5280 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5284 o->op_flags & OPf_KIDS
5285 && looks_like_bool(cUNOPo->op_first));
5288 return looks_like_bool(cUNOPo->op_first);
5293 case OP_NOT: case OP_XOR:
5295 case OP_EQ: case OP_NE: case OP_LT:
5296 case OP_GT: case OP_LE: case OP_GE:
5298 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5299 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5301 case OP_SEQ: case OP_SNE: case OP_SLT:
5302 case OP_SGT: case OP_SLE: case OP_SGE:
5306 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5307 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5308 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5309 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5310 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5311 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5312 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5313 case OP_FTTEXT: case OP_FTBINARY:
5315 case OP_DEFINED: case OP_EXISTS:
5316 case OP_MATCH: case OP_EOF:
5323 /* Detect comparisons that have been optimized away */
5324 if (cSVOPo->op_sv == &PL_sv_yes
5325 || cSVOPo->op_sv == &PL_sv_no)
5338 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5341 PERL_ARGS_ASSERT_NEWGIVENOP;
5342 return newGIVWHENOP(
5343 ref_array_or_hash(cond),
5345 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5349 /* If cond is null, this is a default {} block */
5351 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5353 const bool cond_llb = (!cond || looks_like_bool(cond));
5356 PERL_ARGS_ASSERT_NEWWHENOP;
5361 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5363 scalar(ref_array_or_hash(cond)));
5366 return newGIVWHENOP(
5368 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5369 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5373 =for apidoc cv_undef
5375 Clear out all the active components of a CV. This can happen either
5376 by an explicit C<undef &foo>, or by the reference count going to zero.
5377 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5378 children can still follow the full lexical scope chain.
5384 Perl_cv_undef(pTHX_ CV *cv)
5388 PERL_ARGS_ASSERT_CV_UNDEF;
5390 DEBUG_X(PerlIO_printf(Perl_debug_log,
5391 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5392 PTR2UV(cv), PTR2UV(PL_comppad))
5396 if (CvFILE(cv) && !CvISXSUB(cv)) {
5397 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5398 Safefree(CvFILE(cv));
5403 if (!CvISXSUB(cv) && CvROOT(cv)) {
5404 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5405 Perl_croak(aTHX_ "Can't undef active subroutine");
5408 PAD_SAVE_SETNULLPAD();
5410 op_free(CvROOT(cv));
5415 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5420 /* remove CvOUTSIDE unless this is an undef rather than a free */
5421 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5422 if (!CvWEAKOUTSIDE(cv))
5423 SvREFCNT_dec(CvOUTSIDE(cv));
5424 CvOUTSIDE(cv) = NULL;
5427 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5430 if (CvISXSUB(cv) && CvXSUB(cv)) {
5433 /* delete all flags except WEAKOUTSIDE */
5434 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5438 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5441 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5443 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5444 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5445 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5446 || (p && (len != SvCUR(cv) /* Not the same length. */
5447 || memNE(p, SvPVX_const(cv), len))))
5448 && ckWARN_d(WARN_PROTOTYPE)) {
5449 SV* const msg = sv_newmortal();
5453 gv_efullname3(name = sv_newmortal(), gv, NULL);
5454 sv_setpvs(msg, "Prototype mismatch:");
5456 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5458 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5460 sv_catpvs(msg, ": none");
5461 sv_catpvs(msg, " vs ");
5463 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5465 sv_catpvs(msg, "none");
5466 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5470 static void const_sv_xsub(pTHX_ CV* cv);
5474 =head1 Optree Manipulation Functions
5476 =for apidoc cv_const_sv
5478 If C<cv> is a constant sub eligible for inlining. returns the constant
5479 value returned by the sub. Otherwise, returns NULL.
5481 Constant subs can be created with C<newCONSTSUB> or as described in
5482 L<perlsub/"Constant Functions">.
5487 Perl_cv_const_sv(pTHX_ const CV *const cv)
5489 PERL_UNUSED_CONTEXT;
5492 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5494 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5497 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5498 * Can be called in 3 ways:
5501 * look for a single OP_CONST with attached value: return the value
5503 * cv && CvCLONE(cv) && !CvCONST(cv)
5505 * examine the clone prototype, and if contains only a single
5506 * OP_CONST referencing a pad const, or a single PADSV referencing
5507 * an outer lexical, return a non-zero value to indicate the CV is
5508 * a candidate for "constizing" at clone time
5512 * We have just cloned an anon prototype that was marked as a const
5513 * candidiate. Try to grab the current value, and in the case of
5514 * PADSV, ignore it if it has multiple references. Return the value.
5518 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5529 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5530 o = cLISTOPo->op_first->op_sibling;
5532 for (; o; o = o->op_next) {
5533 const OPCODE type = o->op_type;
5535 if (sv && o->op_next == o)
5537 if (o->op_next != o) {
5538 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5540 if (type == OP_DBSTATE)
5543 if (type == OP_LEAVESUB || type == OP_RETURN)
5547 if (type == OP_CONST && cSVOPo->op_sv)
5549 else if (cv && type == OP_CONST) {
5550 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5554 else if (cv && type == OP_PADSV) {
5555 if (CvCONST(cv)) { /* newly cloned anon */
5556 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5557 /* the candidate should have 1 ref from this pad and 1 ref
5558 * from the parent */
5559 if (!sv || SvREFCNT(sv) != 2)
5566 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5567 sv = &PL_sv_undef; /* an arbitrary non-null value */
5582 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5585 /* This would be the return value, but the return cannot be reached. */
5586 OP* pegop = newOP(OP_NULL, 0);
5589 PERL_UNUSED_ARG(floor);
5599 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5601 NORETURN_FUNCTION_END;
5606 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5608 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5612 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5618 register CV *cv = NULL;
5620 /* If the subroutine has no body, no attributes, and no builtin attributes
5621 then it's just a sub declaration, and we may be able to get away with
5622 storing with a placeholder scalar in the symbol table, rather than a
5623 full GV and CV. If anything is present then it will take a full CV to
5625 const I32 gv_fetch_flags
5626 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5628 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5629 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5633 assert(proto->op_type == OP_CONST);
5634 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5640 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5642 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5643 SV * const sv = sv_newmortal();
5644 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5645 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5646 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5647 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5649 } else if (PL_curstash) {
5650 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5653 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5657 if (!PL_madskills) {
5666 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5667 maximum a prototype before. */
5668 if (SvTYPE(gv) > SVt_NULL) {
5669 if (!SvPOK((const SV *)gv)
5670 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5672 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5674 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5677 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5679 sv_setiv(MUTABLE_SV(gv), -1);
5681 SvREFCNT_dec(PL_compcv);
5682 cv = PL_compcv = NULL;
5686 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5688 if (!block || !ps || *ps || attrs
5689 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5691 || block->op_type == OP_NULL
5696 const_sv = op_const_sv(block, NULL);
5699 const bool exists = CvROOT(cv) || CvXSUB(cv);
5701 /* if the subroutine doesn't exist and wasn't pre-declared
5702 * with a prototype, assume it will be AUTOLOADed,
5703 * skipping the prototype check
5705 if (exists || SvPOK(cv))
5706 cv_ckproto_len(cv, gv, ps, ps_len);
5707 /* already defined (or promised)? */
5708 if (exists || GvASSUMECV(gv)) {
5711 || block->op_type == OP_NULL
5714 if (CvFLAGS(PL_compcv)) {
5715 /* might have had built-in attrs applied */
5716 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5718 /* just a "sub foo;" when &foo is already defined */
5719 SAVEFREESV(PL_compcv);
5724 && block->op_type != OP_NULL
5727 if (ckWARN(WARN_REDEFINE)
5729 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5731 const line_t oldline = CopLINE(PL_curcop);
5732 if (PL_parser && PL_parser->copline != NOLINE)
5733 CopLINE_set(PL_curcop, PL_parser->copline);
5734 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5735 CvCONST(cv) ? "Constant subroutine %s redefined"
5736 : "Subroutine %s redefined", name);
5737 CopLINE_set(PL_curcop, oldline);
5740 if (!PL_minus_c) /* keep old one around for madskills */
5743 /* (PL_madskills unset in used file.) */
5751 SvREFCNT_inc_simple_void_NN(const_sv);
5753 assert(!CvROOT(cv) && !CvCONST(cv));
5754 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5755 CvXSUBANY(cv).any_ptr = const_sv;
5756 CvXSUB(cv) = const_sv_xsub;
5762 cv = newCONSTSUB(NULL, name, const_sv);
5764 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5765 (CvGV(cv) && GvSTASH(CvGV(cv)))
5774 SvREFCNT_dec(PL_compcv);
5778 if (cv) { /* must reuse cv if autoloaded */
5779 /* transfer PL_compcv to cv */
5782 && block->op_type != OP_NULL
5786 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5787 if (!CvWEAKOUTSIDE(cv))
5788 SvREFCNT_dec(CvOUTSIDE(cv));
5789 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5790 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5791 CvOUTSIDE(PL_compcv) = 0;
5792 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5793 CvPADLIST(PL_compcv) = 0;
5794 /* inner references to PL_compcv must be fixed up ... */
5795 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5796 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5797 ++PL_sub_generation;
5800 /* Might have had built-in attributes applied -- propagate them. */
5801 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5803 /* ... before we throw it away */
5804 SvREFCNT_dec(PL_compcv);
5812 if (strEQ(name, "import")) {
5813 PL_formfeed = MUTABLE_SV(cv);
5814 /* diag_listed_as: SKIPME */
5815 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
5819 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5824 CvFILE_set_from_cop(cv, PL_curcop);
5825 CvSTASH(cv) = PL_curstash;
5828 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5829 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5830 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5834 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5836 if (PL_parser && PL_parser->error_count) {
5840 const char *s = strrchr(name, ':');
5842 if (strEQ(s, "BEGIN")) {
5843 const char not_safe[] =
5844 "BEGIN not safe after errors--compilation aborted";
5845 if (PL_in_eval & EVAL_KEEPERR)
5846 Perl_croak(aTHX_ not_safe);
5848 /* force display of errors found but not reported */
5849 sv_catpv(ERRSV, not_safe);
5850 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5859 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5860 the debugger could be able to set a breakpoint in, so signal to
5861 pp_entereval that it should not throw away any saved lines at scope
5864 PL_breakable_sub_gen++;
5866 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5867 mod(scalarseq(block), OP_LEAVESUBLV));
5868 block->op_attached = 1;
5871 /* This makes sub {}; work as expected. */
5872 if (block->op_type == OP_STUB) {
5873 OP* const newblock = newSTATEOP(0, NULL, 0);
5875 op_getmad(block,newblock,'B');
5882 block->op_attached = 1;
5883 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5885 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5886 OpREFCNT_set(CvROOT(cv), 1);
5887 CvSTART(cv) = LINKLIST(CvROOT(cv));
5888 CvROOT(cv)->op_next = 0;
5889 CALL_PEEP(CvSTART(cv));
5891 /* now that optimizer has done its work, adjust pad values */
5893 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5896 assert(!CvCONST(cv));
5897 if (ps && !*ps && op_const_sv(block, cv))
5902 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5903 SV * const sv = newSV(0);
5904 SV * const tmpstr = sv_newmortal();
5905 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5906 GV_ADDMULTI, SVt_PVHV);
5909 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5911 (long)PL_subline, (long)CopLINE(PL_curcop));
5912 gv_efullname3(tmpstr, gv, NULL);
5913 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5914 SvCUR(tmpstr), sv, 0);
5915 hv = GvHVn(db_postponed);
5916 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5917 CV * const pcv = GvCV(db_postponed);
5923 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5928 if (name && ! (PL_parser && PL_parser->error_count))
5929 process_special_blocks(name, gv, cv);
5934 PL_parser->copline = NOLINE;
5940 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5943 const char *const colon = strrchr(fullname,':');
5944 const char *const name = colon ? colon + 1 : fullname;
5946 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5949 if (strEQ(name, "BEGIN")) {
5950 const I32 oldscope = PL_scopestack_ix;
5952 SAVECOPFILE(&PL_compiling);
5953 SAVECOPLINE(&PL_compiling);
5955 DEBUG_x( dump_sub(gv) );
5956 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5957 GvCV(gv) = 0; /* cv has been hijacked */
5958 call_list(oldscope, PL_beginav);
5960 PL_curcop = &PL_compiling;
5961 CopHINTS_set(&PL_compiling, PL_hints);
5968 if strEQ(name, "END") {
5969 DEBUG_x( dump_sub(gv) );
5970 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5973 } else if (*name == 'U') {
5974 if (strEQ(name, "UNITCHECK")) {
5975 /* It's never too late to run a unitcheck block */
5976 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5980 } else if (*name == 'C') {
5981 if (strEQ(name, "CHECK")) {
5983 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5984 "Too late to run CHECK block");
5985 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5989 } else if (*name == 'I') {
5990 if (strEQ(name, "INIT")) {
5992 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5993 "Too late to run INIT block");
5994 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6000 DEBUG_x( dump_sub(gv) );
6001 GvCV(gv) = 0; /* cv has been hijacked */
6006 =for apidoc newCONSTSUB
6008 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6009 eligible for inlining at compile-time.
6011 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6012 which won't be called if used as a destructor, but will suppress the overhead
6013 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6020 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6025 const char *const file = CopFILE(PL_curcop);
6027 SV *const temp_sv = CopFILESV(PL_curcop);
6028 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6033 if (IN_PERL_RUNTIME) {
6034 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6035 * an op shared between threads. Use a non-shared COP for our
6037 SAVEVPTR(PL_curcop);
6038 PL_curcop = &PL_compiling;
6040 SAVECOPLINE(PL_curcop);
6041 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6044 PL_hints &= ~HINT_BLOCK_SCOPE;
6047 SAVESPTR(PL_curstash);
6048 SAVECOPSTASH(PL_curcop);
6049 PL_curstash = stash;
6050 CopSTASH_set(PL_curcop,stash);
6053 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6054 and so doesn't get free()d. (It's expected to be from the C pre-
6055 processor __FILE__ directive). But we need a dynamically allocated one,
6056 and we need it to get freed. */
6057 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6058 XS_DYNAMIC_FILENAME);
6059 CvXSUBANY(cv).any_ptr = sv;
6064 CopSTASH_free(PL_curcop);
6072 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6073 const char *const filename, const char *const proto,
6076 CV *cv = newXS(name, subaddr, filename);
6078 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6080 if (flags & XS_DYNAMIC_FILENAME) {
6081 /* We need to "make arrangements" (ie cheat) to ensure that the
6082 filename lasts as long as the PVCV we just created, but also doesn't
6084 STRLEN filename_len = strlen(filename);
6085 STRLEN proto_and_file_len = filename_len;
6086 char *proto_and_file;
6090 proto_len = strlen(proto);
6091 proto_and_file_len += proto_len;
6093 Newx(proto_and_file, proto_and_file_len + 1, char);
6094 Copy(proto, proto_and_file, proto_len, char);
6095 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6098 proto_and_file = savepvn(filename, filename_len);
6101 /* This gets free()d. :-) */
6102 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6103 SV_HAS_TRAILING_NUL);
6105 /* This gives us the correct prototype, rather than one with the
6106 file name appended. */
6107 SvCUR_set(cv, proto_len);
6111 CvFILE(cv) = proto_and_file + proto_len;
6113 sv_setpv(MUTABLE_SV(cv), proto);
6119 =for apidoc U||newXS
6121 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6122 static storage, as it is used directly as CvFILE(), without a copy being made.
6128 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6131 GV * const gv = gv_fetchpv(name ? name :
6132 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6133 GV_ADDMULTI, SVt_PVCV);
6136 PERL_ARGS_ASSERT_NEWXS;
6139 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6141 if ((cv = (name ? GvCV(gv) : NULL))) {
6143 /* just a cached method */
6147 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6148 /* already defined (or promised) */
6149 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6150 if (ckWARN(WARN_REDEFINE)) {
6151 GV * const gvcv = CvGV(cv);
6153 HV * const stash = GvSTASH(gvcv);
6155 const char *redefined_name = HvNAME_get(stash);
6156 if ( strEQ(redefined_name,"autouse") ) {
6157 const line_t oldline = CopLINE(PL_curcop);
6158 if (PL_parser && PL_parser->copline != NOLINE)
6159 CopLINE_set(PL_curcop, PL_parser->copline);
6160 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6161 CvCONST(cv) ? "Constant subroutine %s redefined"
6162 : "Subroutine %s redefined"
6164 CopLINE_set(PL_curcop, oldline);
6174 if (cv) /* must reuse cv if autoloaded */
6177 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6181 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6185 (void)gv_fetchfile(filename);
6186 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6187 an external constant string */
6189 CvXSUB(cv) = subaddr;
6192 process_special_blocks(name, gv, cv);
6204 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6209 OP* pegop = newOP(OP_NULL, 0);
6213 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6214 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6217 if ((cv = GvFORM(gv))) {
6218 if (ckWARN(WARN_REDEFINE)) {
6219 const line_t oldline = CopLINE(PL_curcop);
6220 if (PL_parser && PL_parser->copline != NOLINE)
6221 CopLINE_set(PL_curcop, PL_parser->copline);
6223 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6224 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6226 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6227 "Format STDOUT redefined");
6229 CopLINE_set(PL_curcop, oldline);
6236 CvFILE_set_from_cop(cv, PL_curcop);
6239 pad_tidy(padtidy_FORMAT);
6240 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6241 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6242 OpREFCNT_set(CvROOT(cv), 1);
6243 CvSTART(cv) = LINKLIST(CvROOT(cv));
6244 CvROOT(cv)->op_next = 0;
6245 CALL_PEEP(CvSTART(cv));
6247 op_getmad(o,pegop,'n');
6248 op_getmad_weak(block, pegop, 'b');
6253 PL_parser->copline = NOLINE;
6261 Perl_newANONLIST(pTHX_ OP *o)
6263 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6267 Perl_newANONHASH(pTHX_ OP *o)
6269 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6273 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6275 return newANONATTRSUB(floor, proto, NULL, block);
6279 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6281 return newUNOP(OP_REFGEN, 0,
6282 newSVOP(OP_ANONCODE, 0,
6283 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6287 Perl_oopsAV(pTHX_ OP *o)
6291 PERL_ARGS_ASSERT_OOPSAV;
6293 switch (o->op_type) {
6295 o->op_type = OP_PADAV;
6296 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6297 return ref(o, OP_RV2AV);
6300 o->op_type = OP_RV2AV;
6301 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6306 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6313 Perl_oopsHV(pTHX_ OP *o)
6317 PERL_ARGS_ASSERT_OOPSHV;
6319 switch (o->op_type) {
6322 o->op_type = OP_PADHV;
6323 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6324 return ref(o, OP_RV2HV);
6328 o->op_type = OP_RV2HV;
6329 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6334 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6341 Perl_newAVREF(pTHX_ OP *o)
6345 PERL_ARGS_ASSERT_NEWAVREF;
6347 if (o->op_type == OP_PADANY) {
6348 o->op_type = OP_PADAV;
6349 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6352 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6353 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6354 "Using an array as a reference is deprecated");
6356 return newUNOP(OP_RV2AV, 0, scalar(o));
6360 Perl_newGVREF(pTHX_ I32 type, OP *o)
6362 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6363 return newUNOP(OP_NULL, 0, o);
6364 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6368 Perl_newHVREF(pTHX_ OP *o)
6372 PERL_ARGS_ASSERT_NEWHVREF;
6374 if (o->op_type == OP_PADANY) {
6375 o->op_type = OP_PADHV;
6376 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6379 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6380 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6381 "Using a hash as a reference is deprecated");
6383 return newUNOP(OP_RV2HV, 0, scalar(o));
6387 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6389 return newUNOP(OP_RV2CV, flags, scalar(o));
6393 Perl_newSVREF(pTHX_ OP *o)
6397 PERL_ARGS_ASSERT_NEWSVREF;
6399 if (o->op_type == OP_PADANY) {
6400 o->op_type = OP_PADSV;
6401 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6404 return newUNOP(OP_RV2SV, 0, scalar(o));
6407 /* Check routines. See the comments at the top of this file for details
6408 * on when these are called */
6411 Perl_ck_anoncode(pTHX_ OP *o)
6413 PERL_ARGS_ASSERT_CK_ANONCODE;
6415 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6417 cSVOPo->op_sv = NULL;
6422 Perl_ck_bitop(pTHX_ OP *o)
6426 PERL_ARGS_ASSERT_CK_BITOP;
6428 #define OP_IS_NUMCOMPARE(op) \
6429 ((op) == OP_LT || (op) == OP_I_LT || \
6430 (op) == OP_GT || (op) == OP_I_GT || \
6431 (op) == OP_LE || (op) == OP_I_LE || \
6432 (op) == OP_GE || (op) == OP_I_GE || \
6433 (op) == OP_EQ || (op) == OP_I_EQ || \
6434 (op) == OP_NE || (op) == OP_I_NE || \
6435 (op) == OP_NCMP || (op) == OP_I_NCMP)
6436 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6437 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6438 && (o->op_type == OP_BIT_OR
6439 || o->op_type == OP_BIT_AND
6440 || o->op_type == OP_BIT_XOR))
6442 const OP * const left = cBINOPo->op_first;
6443 const OP * const right = left->op_sibling;
6444 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6445 (left->op_flags & OPf_PARENS) == 0) ||
6446 (OP_IS_NUMCOMPARE(right->op_type) &&
6447 (right->op_flags & OPf_PARENS) == 0))
6448 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6449 "Possible precedence problem on bitwise %c operator",
6450 o->op_type == OP_BIT_OR ? '|'
6451 : o->op_type == OP_BIT_AND ? '&' : '^'
6458 Perl_ck_concat(pTHX_ OP *o)
6460 const OP * const kid = cUNOPo->op_first;
6462 PERL_ARGS_ASSERT_CK_CONCAT;
6463 PERL_UNUSED_CONTEXT;
6465 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6466 !(kUNOP->op_first->op_flags & OPf_MOD))
6467 o->op_flags |= OPf_STACKED;
6472 Perl_ck_spair(pTHX_ OP *o)
6476 PERL_ARGS_ASSERT_CK_SPAIR;
6478 if (o->op_flags & OPf_KIDS) {
6481 const OPCODE type = o->op_type;
6482 o = modkids(ck_fun(o), type);
6483 kid = cUNOPo->op_first;
6484 newop = kUNOP->op_first->op_sibling;
6486 const OPCODE type = newop->op_type;
6487 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6488 type == OP_PADAV || type == OP_PADHV ||
6489 type == OP_RV2AV || type == OP_RV2HV)
6493 op_getmad(kUNOP->op_first,newop,'K');
6495 op_free(kUNOP->op_first);
6497 kUNOP->op_first = newop;
6499 o->op_ppaddr = PL_ppaddr[++o->op_type];
6504 Perl_ck_delete(pTHX_ OP *o)
6506 PERL_ARGS_ASSERT_CK_DELETE;
6510 if (o->op_flags & OPf_KIDS) {
6511 OP * const kid = cUNOPo->op_first;
6512 switch (kid->op_type) {
6514 o->op_flags |= OPf_SPECIAL;
6517 o->op_private |= OPpSLICE;
6520 o->op_flags |= OPf_SPECIAL;
6525 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6528 if (kid->op_private & OPpLVAL_INTRO)
6529 o->op_private |= OPpLVAL_INTRO;
6536 Perl_ck_die(pTHX_ OP *o)
6538 PERL_ARGS_ASSERT_CK_DIE;
6541 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6547 Perl_ck_eof(pTHX_ OP *o)
6551 PERL_ARGS_ASSERT_CK_EOF;
6553 if (o->op_flags & OPf_KIDS) {
6554 if (cLISTOPo->op_first->op_type == OP_STUB) {
6556 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6558 op_getmad(o,newop,'O');
6570 Perl_ck_eval(pTHX_ OP *o)
6574 PERL_ARGS_ASSERT_CK_EVAL;
6576 PL_hints |= HINT_BLOCK_SCOPE;
6577 if (o->op_flags & OPf_KIDS) {
6578 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6581 o->op_flags &= ~OPf_KIDS;
6584 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6590 cUNOPo->op_first = 0;
6595 NewOp(1101, enter, 1, LOGOP);
6596 enter->op_type = OP_ENTERTRY;
6597 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6598 enter->op_private = 0;
6600 /* establish postfix order */
6601 enter->op_next = (OP*)enter;
6603 CHECKOP(OP_ENTERTRY, enter);
6605 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6606 o->op_type = OP_LEAVETRY;
6607 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6608 enter->op_other = o;
6609 op_getmad(oldo,o,'O');
6623 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6624 op_getmad(oldo,o,'O');
6626 o->op_targ = (PADOFFSET)PL_hints;
6627 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6628 /* Store a copy of %^H that pp_entereval can pick up. */
6629 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6630 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6631 cUNOPo->op_first->op_sibling = hhop;
6632 o->op_private |= OPpEVAL_HAS_HH;
6638 Perl_ck_exit(pTHX_ OP *o)
6640 PERL_ARGS_ASSERT_CK_EXIT;
6643 HV * const table = GvHV(PL_hintgv);
6645 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6646 if (svp && *svp && SvTRUE(*svp))
6647 o->op_private |= OPpEXIT_VMSISH;
6649 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6655 Perl_ck_exec(pTHX_ OP *o)
6657 PERL_ARGS_ASSERT_CK_EXEC;
6659 if (o->op_flags & OPf_STACKED) {
6662 kid = cUNOPo->op_first->op_sibling;
6663 if (kid->op_type == OP_RV2GV)
6672 Perl_ck_exists(pTHX_ OP *o)
6676 PERL_ARGS_ASSERT_CK_EXISTS;
6679 if (o->op_flags & OPf_KIDS) {
6680 OP * const kid = cUNOPo->op_first;
6681 if (kid->op_type == OP_ENTERSUB) {
6682 (void) ref(kid, o->op_type);
6683 if (kid->op_type != OP_RV2CV
6684 && !(PL_parser && PL_parser->error_count))
6685 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6687 o->op_private |= OPpEXISTS_SUB;
6689 else if (kid->op_type == OP_AELEM)
6690 o->op_flags |= OPf_SPECIAL;
6691 else if (kid->op_type != OP_HELEM)
6692 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6700 Perl_ck_rvconst(pTHX_ register OP *o)
6703 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6705 PERL_ARGS_ASSERT_CK_RVCONST;
6707 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6708 if (o->op_type == OP_RV2CV)
6709 o->op_private &= ~1;
6711 if (kid->op_type == OP_CONST) {
6714 SV * const kidsv = kid->op_sv;
6716 /* Is it a constant from cv_const_sv()? */
6717 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6718 SV * const rsv = SvRV(kidsv);
6719 const svtype type = SvTYPE(rsv);
6720 const char *badtype = NULL;
6722 switch (o->op_type) {
6724 if (type > SVt_PVMG)
6725 badtype = "a SCALAR";
6728 if (type != SVt_PVAV)
6729 badtype = "an ARRAY";
6732 if (type != SVt_PVHV)
6736 if (type != SVt_PVCV)
6741 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6744 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6745 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6746 /* If this is an access to a stash, disable "strict refs", because
6747 * stashes aren't auto-vivified at compile-time (unless we store
6748 * symbols in them), and we don't want to produce a run-time
6749 * stricture error when auto-vivifying the stash. */
6750 const char *s = SvPV_nolen(kidsv);
6751 const STRLEN l = SvCUR(kidsv);
6752 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6753 o->op_private &= ~HINT_STRICT_REFS;
6755 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6756 const char *badthing;
6757 switch (o->op_type) {
6759 badthing = "a SCALAR";
6762 badthing = "an ARRAY";
6765 badthing = "a HASH";
6773 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6774 SVfARG(kidsv), badthing);
6777 * This is a little tricky. We only want to add the symbol if we
6778 * didn't add it in the lexer. Otherwise we get duplicate strict
6779 * warnings. But if we didn't add it in the lexer, we must at
6780 * least pretend like we wanted to add it even if it existed before,
6781 * or we get possible typo warnings. OPpCONST_ENTERED says
6782 * whether the lexer already added THIS instance of this symbol.
6784 iscv = (o->op_type == OP_RV2CV) * 2;
6786 gv = gv_fetchsv(kidsv,
6787 iscv | !(kid->op_private & OPpCONST_ENTERED),
6790 : o->op_type == OP_RV2SV
6792 : o->op_type == OP_RV2AV
6794 : o->op_type == OP_RV2HV
6797 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6799 kid->op_type = OP_GV;
6800 SvREFCNT_dec(kid->op_sv);
6802 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6803 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6804 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6806 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6808 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6810 kid->op_private = 0;
6811 kid->op_ppaddr = PL_ppaddr[OP_GV];
6818 Perl_ck_ftst(pTHX_ OP *o)
6821 const I32 type = o->op_type;
6823 PERL_ARGS_ASSERT_CK_FTST;
6825 if (o->op_flags & OPf_REF) {
6828 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6829 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6830 const OPCODE kidtype = kid->op_type;
6832 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6833 OP * const newop = newGVOP(type, OPf_REF,
6834 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6836 op_getmad(o,newop,'O');
6842 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6843 o->op_private |= OPpFT_ACCESS;
6844 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6845 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6846 o->op_private |= OPpFT_STACKED;
6854 if (type == OP_FTTTY)
6855 o = newGVOP(type, OPf_REF, PL_stdingv);
6857 o = newUNOP(type, 0, newDEFSVOP());
6858 op_getmad(oldo,o,'O');
6864 Perl_ck_fun(pTHX_ OP *o)
6867 const int type = o->op_type;
6868 register I32 oa = PL_opargs[type] >> OASHIFT;
6870 PERL_ARGS_ASSERT_CK_FUN;
6872 if (o->op_flags & OPf_STACKED) {
6873 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6876 return no_fh_allowed(o);
6879 if (o->op_flags & OPf_KIDS) {
6880 OP **tokid = &cLISTOPo->op_first;
6881 register OP *kid = cLISTOPo->op_first;
6885 if (kid->op_type == OP_PUSHMARK ||
6886 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6888 tokid = &kid->op_sibling;
6889 kid = kid->op_sibling;
6891 if (!kid && PL_opargs[type] & OA_DEFGV)
6892 *tokid = kid = newDEFSVOP();
6896 sibl = kid->op_sibling;
6898 if (!sibl && kid->op_type == OP_STUB) {
6905 /* list seen where single (scalar) arg expected? */
6906 if (numargs == 1 && !(oa >> 4)
6907 && kid->op_type == OP_LIST && type != OP_SCALAR)
6909 return too_many_arguments(o,PL_op_desc[type]);
6922 if ((type == OP_PUSH || type == OP_UNSHIFT)
6923 && !kid->op_sibling)
6924 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6925 "Useless use of %s with no values",
6928 if (kid->op_type == OP_CONST &&
6929 (kid->op_private & OPpCONST_BARE))
6931 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6932 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6933 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6934 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6935 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6937 op_getmad(kid,newop,'K');
6942 kid->op_sibling = sibl;
6945 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6946 bad_type(numargs, "array", PL_op_desc[type], kid);
6950 if (kid->op_type == OP_CONST &&
6951 (kid->op_private & OPpCONST_BARE))
6953 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6954 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6955 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6956 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6957 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6959 op_getmad(kid,newop,'K');
6964 kid->op_sibling = sibl;
6967 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6968 bad_type(numargs, "hash", PL_op_desc[type], kid);
6973 OP * const newop = newUNOP(OP_NULL, 0, kid);
6974 kid->op_sibling = 0;
6976 newop->op_next = newop;
6978 kid->op_sibling = sibl;
6983 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6984 if (kid->op_type == OP_CONST &&
6985 (kid->op_private & OPpCONST_BARE))
6987 OP * const newop = newGVOP(OP_GV, 0,
6988 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6989 if (!(o->op_private & 1) && /* if not unop */
6990 kid == cLISTOPo->op_last)
6991 cLISTOPo->op_last = newop;
6993 op_getmad(kid,newop,'K');
6999 else if (kid->op_type == OP_READLINE) {
7000 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7001 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7004 I32 flags = OPf_SPECIAL;
7008 /* is this op a FH constructor? */
7009 if (is_handle_constructor(o,numargs)) {
7010 const char *name = NULL;
7014 /* Set a flag to tell rv2gv to vivify
7015 * need to "prove" flag does not mean something
7016 * else already - NI-S 1999/05/07
7019 if (kid->op_type == OP_PADSV) {
7021 = PAD_COMPNAME_SV(kid->op_targ);
7022 name = SvPV_const(namesv, len);
7024 else if (kid->op_type == OP_RV2SV
7025 && kUNOP->op_first->op_type == OP_GV)
7027 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7029 len = GvNAMELEN(gv);
7031 else if (kid->op_type == OP_AELEM
7032 || kid->op_type == OP_HELEM)
7035 OP *op = ((BINOP*)kid)->op_first;
7039 const char * const a =
7040 kid->op_type == OP_AELEM ?
7042 if (((op->op_type == OP_RV2AV) ||
7043 (op->op_type == OP_RV2HV)) &&
7044 (firstop = ((UNOP*)op)->op_first) &&
7045 (firstop->op_type == OP_GV)) {
7046 /* packagevar $a[] or $h{} */
7047 GV * const gv = cGVOPx_gv(firstop);
7055 else if (op->op_type == OP_PADAV
7056 || op->op_type == OP_PADHV) {
7057 /* lexicalvar $a[] or $h{} */
7058 const char * const padname =
7059 PAD_COMPNAME_PV(op->op_targ);
7068 name = SvPV_const(tmpstr, len);
7073 name = "__ANONIO__";
7080 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7081 namesv = PAD_SVl(targ);
7082 SvUPGRADE(namesv, SVt_PV);
7084 sv_setpvs(namesv, "$");
7085 sv_catpvn(namesv, name, len);
7088 kid->op_sibling = 0;
7089 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7090 kid->op_targ = targ;
7091 kid->op_private |= priv;
7093 kid->op_sibling = sibl;
7099 mod(scalar(kid), type);
7103 tokid = &kid->op_sibling;
7104 kid = kid->op_sibling;
7107 if (kid && kid->op_type != OP_STUB)
7108 return too_many_arguments(o,OP_DESC(o));
7109 o->op_private |= numargs;
7111 /* FIXME - should the numargs move as for the PERL_MAD case? */
7112 o->op_private |= numargs;
7114 return too_many_arguments(o,OP_DESC(o));
7118 else if (PL_opargs[type] & OA_DEFGV) {
7120 OP *newop = newUNOP(type, 0, newDEFSVOP());
7121 op_getmad(o,newop,'O');
7124 /* Ordering of these two is important to keep f_map.t passing. */
7126 return newUNOP(type, 0, newDEFSVOP());
7131 while (oa & OA_OPTIONAL)
7133 if (oa && oa != OA_LIST)
7134 return too_few_arguments(o,OP_DESC(o));
7140 Perl_ck_glob(pTHX_ OP *o)
7145 PERL_ARGS_ASSERT_CK_GLOB;
7148 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7149 append_elem(OP_GLOB, o, newDEFSVOP());
7151 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7152 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7154 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7157 #if !defined(PERL_EXTERNAL_GLOB)
7158 /* XXX this can be tightened up and made more failsafe. */
7159 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7162 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7163 newSVpvs("File::Glob"), NULL, NULL, NULL);
7164 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7165 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7166 GvCV(gv) = GvCV(glob_gv);
7167 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7168 GvIMPORTED_CV_on(gv);
7171 #endif /* PERL_EXTERNAL_GLOB */
7173 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7174 append_elem(OP_GLOB, o,
7175 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7176 o->op_type = OP_LIST;
7177 o->op_ppaddr = PL_ppaddr[OP_LIST];
7178 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7179 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7180 cLISTOPo->op_first->op_targ = 0;
7181 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7182 append_elem(OP_LIST, o,
7183 scalar(newUNOP(OP_RV2CV, 0,
7184 newGVOP(OP_GV, 0, gv)))));
7185 o = newUNOP(OP_NULL, 0, ck_subr(o));
7186 o->op_targ = OP_GLOB; /* hint at what it used to be */
7189 gv = newGVgen("main");
7191 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7197 Perl_ck_grep(pTHX_ OP *o)
7202 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7205 PERL_ARGS_ASSERT_CK_GREP;
7207 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7208 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7210 if (o->op_flags & OPf_STACKED) {
7213 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7214 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7215 return no_fh_allowed(o);
7216 for (k = kid; k; k = k->op_next) {
7219 NewOp(1101, gwop, 1, LOGOP);
7220 kid->op_next = (OP*)gwop;
7221 o->op_flags &= ~OPf_STACKED;
7223 kid = cLISTOPo->op_first->op_sibling;
7224 if (type == OP_MAPWHILE)
7229 if (PL_parser && PL_parser->error_count)
7231 kid = cLISTOPo->op_first->op_sibling;
7232 if (kid->op_type != OP_NULL)
7233 Perl_croak(aTHX_ "panic: ck_grep");
7234 kid = kUNOP->op_first;
7237 NewOp(1101, gwop, 1, LOGOP);
7238 gwop->op_type = type;
7239 gwop->op_ppaddr = PL_ppaddr[type];
7240 gwop->op_first = listkids(o);
7241 gwop->op_flags |= OPf_KIDS;
7242 gwop->op_other = LINKLIST(kid);
7243 kid->op_next = (OP*)gwop;
7244 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7245 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7246 o->op_private = gwop->op_private = 0;
7247 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7250 o->op_private = gwop->op_private = OPpGREP_LEX;
7251 gwop->op_targ = o->op_targ = offset;
7254 kid = cLISTOPo->op_first->op_sibling;
7255 if (!kid || !kid->op_sibling)
7256 return too_few_arguments(o,OP_DESC(o));
7257 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7258 mod(kid, OP_GREPSTART);
7264 Perl_ck_index(pTHX_ OP *o)
7266 PERL_ARGS_ASSERT_CK_INDEX;
7268 if (o->op_flags & OPf_KIDS) {
7269 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7271 kid = kid->op_sibling; /* get past "big" */
7272 if (kid && kid->op_type == OP_CONST)
7273 fbm_compile(((SVOP*)kid)->op_sv, 0);
7279 Perl_ck_lfun(pTHX_ OP *o)
7281 const OPCODE type = o->op_type;
7283 PERL_ARGS_ASSERT_CK_LFUN;
7285 return modkids(ck_fun(o), type);
7289 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7291 PERL_ARGS_ASSERT_CK_DEFINED;
7293 if ((o->op_flags & OPf_KIDS)) {
7294 switch (cUNOPo->op_first->op_type) {
7296 /* This is needed for
7297 if (defined %stash::)
7298 to work. Do not break Tk.
7300 break; /* Globals via GV can be undef */
7302 case OP_AASSIGN: /* Is this a good idea? */
7303 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7304 "defined(@array) is deprecated");
7305 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7306 "\t(Maybe you should just omit the defined()?)\n");
7310 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7311 "defined(%%hash) is deprecated");
7312 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7313 "\t(Maybe you should just omit the defined()?)\n");
7324 Perl_ck_readline(pTHX_ OP *o)
7326 PERL_ARGS_ASSERT_CK_READLINE;
7328 if (!(o->op_flags & OPf_KIDS)) {
7330 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7332 op_getmad(o,newop,'O');
7342 Perl_ck_rfun(pTHX_ OP *o)
7344 const OPCODE type = o->op_type;
7346 PERL_ARGS_ASSERT_CK_RFUN;
7348 return refkids(ck_fun(o), type);
7352 Perl_ck_listiob(pTHX_ OP *o)
7356 PERL_ARGS_ASSERT_CK_LISTIOB;
7358 kid = cLISTOPo->op_first;
7361 kid = cLISTOPo->op_first;
7363 if (kid->op_type == OP_PUSHMARK)
7364 kid = kid->op_sibling;
7365 if (kid && o->op_flags & OPf_STACKED)
7366 kid = kid->op_sibling;
7367 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7368 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7369 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7370 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7371 cLISTOPo->op_first->op_sibling = kid;
7372 cLISTOPo->op_last = kid;
7373 kid = kid->op_sibling;
7378 append_elem(o->op_type, o, newDEFSVOP());
7384 Perl_ck_smartmatch(pTHX_ OP *o)
7387 if (0 == (o->op_flags & OPf_SPECIAL)) {
7388 OP *first = cBINOPo->op_first;
7389 OP *second = first->op_sibling;
7391 /* Implicitly take a reference to an array or hash */
7392 first->op_sibling = NULL;
7393 first = cBINOPo->op_first = ref_array_or_hash(first);
7394 second = first->op_sibling = ref_array_or_hash(second);
7396 /* Implicitly take a reference to a regular expression */
7397 if (first->op_type == OP_MATCH) {
7398 first->op_type = OP_QR;
7399 first->op_ppaddr = PL_ppaddr[OP_QR];
7401 if (second->op_type == OP_MATCH) {
7402 second->op_type = OP_QR;
7403 second->op_ppaddr = PL_ppaddr[OP_QR];
7412 Perl_ck_sassign(pTHX_ OP *o)
7415 OP * const kid = cLISTOPo->op_first;
7417 PERL_ARGS_ASSERT_CK_SASSIGN;
7419 /* has a disposable target? */
7420 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7421 && !(kid->op_flags & OPf_STACKED)
7422 /* Cannot steal the second time! */
7423 && !(kid->op_private & OPpTARGET_MY)
7424 /* Keep the full thing for madskills */
7428 OP * const kkid = kid->op_sibling;
7430 /* Can just relocate the target. */
7431 if (kkid && kkid->op_type == OP_PADSV
7432 && !(kkid->op_private & OPpLVAL_INTRO))
7434 kid->op_targ = kkid->op_targ;
7436 /* Now we do not need PADSV and SASSIGN. */
7437 kid->op_sibling = o->op_sibling; /* NULL */
7438 cLISTOPo->op_first = NULL;
7441 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7445 if (kid->op_sibling) {
7446 OP *kkid = kid->op_sibling;
7447 if (kkid->op_type == OP_PADSV
7448 && (kkid->op_private & OPpLVAL_INTRO)
7449 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7450 const PADOFFSET target = kkid->op_targ;
7451 OP *const other = newOP(OP_PADSV,
7453 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7454 OP *const first = newOP(OP_NULL, 0);
7455 OP *const nullop = newCONDOP(0, first, o, other);
7456 OP *const condop = first->op_next;
7457 /* hijacking PADSTALE for uninitialized state variables */
7458 SvPADSTALE_on(PAD_SVl(target));
7460 condop->op_type = OP_ONCE;
7461 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7462 condop->op_targ = target;
7463 other->op_targ = target;
7465 /* Because we change the type of the op here, we will skip the
7466 assinment binop->op_last = binop->op_first->op_sibling; at the
7467 end of Perl_newBINOP(). So need to do it here. */
7468 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7477 Perl_ck_match(pTHX_ OP *o)
7481 PERL_ARGS_ASSERT_CK_MATCH;
7483 if (o->op_type != OP_QR && PL_compcv) {
7484 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7485 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7486 o->op_targ = offset;
7487 o->op_private |= OPpTARGET_MY;
7490 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7491 o->op_private |= OPpRUNTIME;
7496 Perl_ck_method(pTHX_ OP *o)
7498 OP * const kid = cUNOPo->op_first;
7500 PERL_ARGS_ASSERT_CK_METHOD;
7502 if (kid->op_type == OP_CONST) {
7503 SV* sv = kSVOP->op_sv;
7504 const char * const method = SvPVX_const(sv);
7505 if (!(strchr(method, ':') || strchr(method, '\''))) {
7507 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7508 sv = newSVpvn_share(method, SvCUR(sv), 0);
7511 kSVOP->op_sv = NULL;
7513 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7515 op_getmad(o,cmop,'O');
7526 Perl_ck_null(pTHX_ OP *o)
7528 PERL_ARGS_ASSERT_CK_NULL;
7529 PERL_UNUSED_CONTEXT;
7534 Perl_ck_open(pTHX_ OP *o)
7537 HV * const table = GvHV(PL_hintgv);
7539 PERL_ARGS_ASSERT_CK_OPEN;
7542 SV **svp = hv_fetchs(table, "open_IN", 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_IN_RAW;
7549 else if (mode & O_TEXT)
7550 o->op_private |= OPpOPEN_IN_CRLF;
7553 svp = hv_fetchs(table, "open_OUT", FALSE);
7556 const char *d = SvPV_const(*svp, len);
7557 const I32 mode = mode_from_discipline(d, len);
7558 if (mode & O_BINARY)
7559 o->op_private |= OPpOPEN_OUT_RAW;
7560 else if (mode & O_TEXT)
7561 o->op_private |= OPpOPEN_OUT_CRLF;
7564 if (o->op_type == OP_BACKTICK) {
7565 if (!(o->op_flags & OPf_KIDS)) {
7566 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7568 op_getmad(o,newop,'O');
7577 /* In case of three-arg dup open remove strictness
7578 * from the last arg if it is a bareword. */
7579 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7580 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7584 if ((last->op_type == OP_CONST) && /* The bareword. */
7585 (last->op_private & OPpCONST_BARE) &&
7586 (last->op_private & OPpCONST_STRICT) &&
7587 (oa = first->op_sibling) && /* The fh. */
7588 (oa = oa->op_sibling) && /* The mode. */
7589 (oa->op_type == OP_CONST) &&
7590 SvPOK(((SVOP*)oa)->op_sv) &&
7591 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7592 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7593 (last == oa->op_sibling)) /* The bareword. */
7594 last->op_private &= ~OPpCONST_STRICT;
7600 Perl_ck_repeat(pTHX_ OP *o)
7602 PERL_ARGS_ASSERT_CK_REPEAT;
7604 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7605 o->op_private |= OPpREPEAT_DOLIST;
7606 cBINOPo->op_first = force_list(cBINOPo->op_first);
7614 Perl_ck_require(pTHX_ OP *o)
7619 PERL_ARGS_ASSERT_CK_REQUIRE;
7621 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7622 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7624 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7625 SV * const sv = kid->op_sv;
7626 U32 was_readonly = SvREADONLY(sv);
7633 sv_force_normal_flags(sv, 0);
7634 assert(!SvREADONLY(sv));
7644 for (; s < end; s++) {
7645 if (*s == ':' && s[1] == ':') {
7647 Move(s+2, s+1, end - s - 1, char);
7652 sv_catpvs(sv, ".pm");
7653 SvFLAGS(sv) |= was_readonly;
7657 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7658 /* handle override, if any */
7659 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7660 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7661 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7662 gv = gvp ? *gvp : NULL;
7666 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7667 OP * const kid = cUNOPo->op_first;
7670 cUNOPo->op_first = 0;
7674 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7675 append_elem(OP_LIST, kid,
7676 scalar(newUNOP(OP_RV2CV, 0,
7679 op_getmad(o,newop,'O');
7683 return scalar(ck_fun(o));
7687 Perl_ck_return(pTHX_ OP *o)
7692 PERL_ARGS_ASSERT_CK_RETURN;
7694 kid = cLISTOPo->op_first->op_sibling;
7695 if (CvLVALUE(PL_compcv)) {
7696 for (; kid; kid = kid->op_sibling)
7697 mod(kid, OP_LEAVESUBLV);
7699 for (; kid; kid = kid->op_sibling)
7700 if ((kid->op_type == OP_NULL)
7701 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7702 /* This is a do block */
7703 OP *op = kUNOP->op_first;
7704 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7705 op = cUNOPx(op)->op_first;
7706 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7707 /* Force the use of the caller's context */
7708 op->op_flags |= OPf_SPECIAL;
7717 Perl_ck_select(pTHX_ OP *o)
7722 PERL_ARGS_ASSERT_CK_SELECT;
7724 if (o->op_flags & OPf_KIDS) {
7725 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7726 if (kid && kid->op_sibling) {
7727 o->op_type = OP_SSELECT;
7728 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7730 return fold_constants(o);
7734 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7735 if (kid && kid->op_type == OP_RV2GV)
7736 kid->op_private &= ~HINT_STRICT_REFS;
7741 Perl_ck_shift(pTHX_ OP *o)
7744 const I32 type = o->op_type;
7746 PERL_ARGS_ASSERT_CK_SHIFT;
7748 if (!(o->op_flags & OPf_KIDS)) {
7749 OP *argop = newUNOP(OP_RV2AV, 0,
7750 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7752 OP * const oldo = o;
7753 o = newUNOP(type, 0, scalar(argop));
7754 op_getmad(oldo,o,'O');
7758 return newUNOP(type, 0, scalar(argop));
7761 return scalar(modkids(ck_fun(o), type));
7765 Perl_ck_sort(pTHX_ OP *o)
7770 PERL_ARGS_ASSERT_CK_SORT;
7772 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7773 HV * const hinthv = GvHV(PL_hintgv);
7775 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7777 const I32 sorthints = (I32)SvIV(*svp);
7778 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7779 o->op_private |= OPpSORT_QSORT;
7780 if ((sorthints & HINT_SORT_STABLE) != 0)
7781 o->op_private |= OPpSORT_STABLE;
7786 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7788 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7789 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7791 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7793 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7795 if (kid->op_type == OP_SCOPE) {
7799 else if (kid->op_type == OP_LEAVE) {
7800 if (o->op_type == OP_SORT) {
7801 op_null(kid); /* wipe out leave */
7804 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7805 if (k->op_next == kid)
7807 /* don't descend into loops */
7808 else if (k->op_type == OP_ENTERLOOP
7809 || k->op_type == OP_ENTERITER)
7811 k = cLOOPx(k)->op_lastop;
7816 kid->op_next = 0; /* just disconnect the leave */
7817 k = kLISTOP->op_first;
7822 if (o->op_type == OP_SORT) {
7823 /* provide scalar context for comparison function/block */
7829 o->op_flags |= OPf_SPECIAL;
7831 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7834 firstkid = firstkid->op_sibling;
7837 /* provide list context for arguments */
7838 if (o->op_type == OP_SORT)
7845 S_simplify_sort(pTHX_ OP *o)
7848 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7854 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7856 if (!(o->op_flags & OPf_STACKED))
7858 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7859 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7860 kid = kUNOP->op_first; /* get past null */
7861 if (kid->op_type != OP_SCOPE)
7863 kid = kLISTOP->op_last; /* get past scope */
7864 switch(kid->op_type) {
7872 k = kid; /* remember this node*/
7873 if (kBINOP->op_first->op_type != OP_RV2SV)
7875 kid = kBINOP->op_first; /* get past cmp */
7876 if (kUNOP->op_first->op_type != OP_GV)
7878 kid = kUNOP->op_first; /* get past rv2sv */
7880 if (GvSTASH(gv) != PL_curstash)
7882 gvname = GvNAME(gv);
7883 if (*gvname == 'a' && gvname[1] == '\0')
7885 else if (*gvname == 'b' && gvname[1] == '\0')
7890 kid = k; /* back to cmp */
7891 if (kBINOP->op_last->op_type != OP_RV2SV)
7893 kid = kBINOP->op_last; /* down to 2nd arg */
7894 if (kUNOP->op_first->op_type != OP_GV)
7896 kid = kUNOP->op_first; /* get past rv2sv */
7898 if (GvSTASH(gv) != PL_curstash)
7900 gvname = GvNAME(gv);
7902 ? !(*gvname == 'a' && gvname[1] == '\0')
7903 : !(*gvname == 'b' && gvname[1] == '\0'))
7905 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7907 o->op_private |= OPpSORT_DESCEND;
7908 if (k->op_type == OP_NCMP)
7909 o->op_private |= OPpSORT_NUMERIC;
7910 if (k->op_type == OP_I_NCMP)
7911 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7912 kid = cLISTOPo->op_first->op_sibling;
7913 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7915 op_getmad(kid,o,'S'); /* then delete it */
7917 op_free(kid); /* then delete it */
7922 Perl_ck_split(pTHX_ OP *o)
7927 PERL_ARGS_ASSERT_CK_SPLIT;
7929 if (o->op_flags & OPf_STACKED)
7930 return no_fh_allowed(o);
7932 kid = cLISTOPo->op_first;
7933 if (kid->op_type != OP_NULL)
7934 Perl_croak(aTHX_ "panic: ck_split");
7935 kid = kid->op_sibling;
7936 op_free(cLISTOPo->op_first);
7937 cLISTOPo->op_first = kid;
7939 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7940 cLISTOPo->op_last = kid; /* There was only one element previously */
7943 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7944 OP * const sibl = kid->op_sibling;
7945 kid->op_sibling = 0;
7946 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7947 if (cLISTOPo->op_first == cLISTOPo->op_last)
7948 cLISTOPo->op_last = kid;
7949 cLISTOPo->op_first = kid;
7950 kid->op_sibling = sibl;
7953 kid->op_type = OP_PUSHRE;
7954 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7956 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7957 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7958 "Use of /g modifier is meaningless in split");
7961 if (!kid->op_sibling)
7962 append_elem(OP_SPLIT, o, newDEFSVOP());
7964 kid = kid->op_sibling;
7967 if (!kid->op_sibling)
7968 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7969 assert(kid->op_sibling);
7971 kid = kid->op_sibling;
7974 if (kid->op_sibling)
7975 return too_many_arguments(o,OP_DESC(o));
7981 Perl_ck_join(pTHX_ OP *o)
7983 const OP * const kid = cLISTOPo->op_first->op_sibling;
7985 PERL_ARGS_ASSERT_CK_JOIN;
7987 if (kid && kid->op_type == OP_MATCH) {
7988 if (ckWARN(WARN_SYNTAX)) {
7989 const REGEXP *re = PM_GETRE(kPMOP);
7990 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7991 const STRLEN len = re ? RX_PRELEN(re) : 6;
7992 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7993 "/%.*s/ should probably be written as \"%.*s\"",
7994 (int)len, pmstr, (int)len, pmstr);
8001 Perl_ck_subr(pTHX_ OP *o)
8004 OP *prev = ((cUNOPo->op_first->op_sibling)
8005 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
8006 OP *o2 = prev->op_sibling;
8008 const char *proto = NULL;
8009 const char *proto_end = NULL;
8014 I32 contextclass = 0;
8015 const char *e = NULL;
8018 PERL_ARGS_ASSERT_CK_SUBR;
8020 o->op_private |= OPpENTERSUB_HASTARG;
8021 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
8022 if (cvop->op_type == OP_RV2CV) {
8023 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
8024 op_null(cvop); /* disable rv2cv */
8025 if (!(o->op_private & OPpENTERSUB_AMPER)) {
8026 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
8028 switch (tmpop->op_type) {
8030 gv = cGVOPx_gv(tmpop);
8033 tmpop->op_private |= OPpEARLY_CV;
8036 SV *sv = cSVOPx_sv(tmpop);
8037 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8041 if (cv && SvPOK(cv)) {
8043 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8044 proto = SvPV(MUTABLE_SV(cv), len);
8045 proto_end = proto + len;
8049 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8050 if (o2->op_type == OP_CONST)
8051 o2->op_private &= ~OPpCONST_STRICT;
8052 else if (o2->op_type == OP_LIST) {
8053 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8054 if (sib && sib->op_type == OP_CONST)
8055 sib->op_private &= ~OPpCONST_STRICT;
8058 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8059 if (PERLDB_SUB && PL_curstash != PL_debstash)
8060 o->op_private |= OPpENTERSUB_DB;
8061 while (o2 != cvop) {
8063 if (PL_madskills && o2->op_type == OP_STUB) {
8064 o2 = o2->op_sibling;
8067 if (PL_madskills && o2->op_type == OP_NULL)
8068 o3 = ((UNOP*)o2)->op_first;
8072 if (proto >= proto_end)
8073 return too_many_arguments(o, gv_ename(namegv));
8081 /* _ must be at the end */
8082 if (proto[1] && proto[1] != ';')
8097 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8099 arg == 1 ? "block or sub {}" : "sub {}",
8100 gv_ename(namegv), o3);
8103 /* '*' allows any scalar type, including bareword */
8106 if (o3->op_type == OP_RV2GV)
8107 goto wrapref; /* autoconvert GLOB -> GLOBref */
8108 else if (o3->op_type == OP_CONST)
8109 o3->op_private &= ~OPpCONST_STRICT;
8110 else if (o3->op_type == OP_ENTERSUB) {
8111 /* accidental subroutine, revert to bareword */
8112 OP *gvop = ((UNOP*)o3)->op_first;
8113 if (gvop && gvop->op_type == OP_NULL) {
8114 gvop = ((UNOP*)gvop)->op_first;
8116 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8119 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8120 (gvop = ((UNOP*)gvop)->op_first) &&
8121 gvop->op_type == OP_GV)
8123 GV * const gv = cGVOPx_gv(gvop);
8124 OP * const sibling = o2->op_sibling;
8125 SV * const n = newSVpvs("");
8127 OP * const oldo2 = o2;
8131 gv_fullname4(n, gv, "", FALSE);
8132 o2 = newSVOP(OP_CONST, 0, n);
8133 op_getmad(oldo2,o2,'O');
8134 prev->op_sibling = o2;
8135 o2->op_sibling = sibling;
8151 if (contextclass++ == 0) {
8152 e = strchr(proto, ']');
8153 if (!e || e == proto)
8162 const char *p = proto;
8163 const char *const end = proto;
8165 while (*--p != '[') {}
8166 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8168 gv_ename(namegv), o3);
8173 if (o3->op_type == OP_RV2GV)
8176 bad_type(arg, "symbol", gv_ename(namegv), o3);
8179 if (o3->op_type == OP_ENTERSUB)
8182 bad_type(arg, "subroutine entry", gv_ename(namegv),
8186 if (o3->op_type == OP_RV2SV ||
8187 o3->op_type == OP_PADSV ||
8188 o3->op_type == OP_HELEM ||
8189 o3->op_type == OP_AELEM)
8192 bad_type(arg, "scalar", gv_ename(namegv), o3);
8195 if (o3->op_type == OP_RV2AV ||
8196 o3->op_type == OP_PADAV)
8199 bad_type(arg, "array", gv_ename(namegv), o3);
8202 if (o3->op_type == OP_RV2HV ||
8203 o3->op_type == OP_PADHV)
8206 bad_type(arg, "hash", gv_ename(namegv), o3);
8211 OP* const sib = kid->op_sibling;
8212 kid->op_sibling = 0;
8213 o2 = newUNOP(OP_REFGEN, 0, kid);
8214 o2->op_sibling = sib;
8215 prev->op_sibling = o2;
8217 if (contextclass && e) {
8232 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8233 gv_ename(namegv), SVfARG(cv));
8238 mod(o2, OP_ENTERSUB);
8240 o2 = o2->op_sibling;
8242 if (o2 == cvop && proto && *proto == '_') {
8243 /* generate an access to $_ */
8245 o2->op_sibling = prev->op_sibling;
8246 prev->op_sibling = o2; /* instead of cvop */
8248 if (proto && !optional && proto_end > proto &&
8249 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8250 return too_few_arguments(o, gv_ename(namegv));
8253 OP * const oldo = o;
8257 o=newSVOP(OP_CONST, 0, newSViv(0));
8258 op_getmad(oldo,o,'O');
8264 Perl_ck_svconst(pTHX_ OP *o)
8266 PERL_ARGS_ASSERT_CK_SVCONST;
8267 PERL_UNUSED_CONTEXT;
8268 SvREADONLY_on(cSVOPo->op_sv);
8273 Perl_ck_chdir(pTHX_ OP *o)
8275 if (o->op_flags & OPf_KIDS) {
8276 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8278 if (kid && kid->op_type == OP_CONST &&
8279 (kid->op_private & OPpCONST_BARE))
8281 o->op_flags |= OPf_SPECIAL;
8282 kid->op_private &= ~OPpCONST_STRICT;
8289 Perl_ck_trunc(pTHX_ OP *o)
8291 PERL_ARGS_ASSERT_CK_TRUNC;
8293 if (o->op_flags & OPf_KIDS) {
8294 SVOP *kid = (SVOP*)cUNOPo->op_first;
8296 if (kid->op_type == OP_NULL)
8297 kid = (SVOP*)kid->op_sibling;
8298 if (kid && kid->op_type == OP_CONST &&
8299 (kid->op_private & OPpCONST_BARE))
8301 o->op_flags |= OPf_SPECIAL;
8302 kid->op_private &= ~OPpCONST_STRICT;
8309 Perl_ck_unpack(pTHX_ OP *o)
8311 OP *kid = cLISTOPo->op_first;
8313 PERL_ARGS_ASSERT_CK_UNPACK;
8315 if (kid->op_sibling) {
8316 kid = kid->op_sibling;
8317 if (!kid->op_sibling)
8318 kid->op_sibling = newDEFSVOP();
8324 Perl_ck_substr(pTHX_ OP *o)
8326 PERL_ARGS_ASSERT_CK_SUBSTR;
8329 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8330 OP *kid = cLISTOPo->op_first;
8332 if (kid->op_type == OP_NULL)
8333 kid = kid->op_sibling;
8335 kid->op_flags |= OPf_MOD;
8342 Perl_ck_each(pTHX_ OP *o)
8345 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8347 PERL_ARGS_ASSERT_CK_EACH;
8350 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8351 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8352 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8353 o->op_type = new_type;
8354 o->op_ppaddr = PL_ppaddr[new_type];
8356 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8357 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8359 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8366 /* caller is supposed to assign the return to the
8367 container of the rep_op var */
8369 S_opt_scalarhv(pTHX_ OP *rep_op) {
8372 PERL_ARGS_ASSERT_OPT_SCALARHV;
8374 NewOp(1101, unop, 1, UNOP);
8375 unop->op_type = (OPCODE)OP_BOOLKEYS;
8376 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8377 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8378 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8379 unop->op_first = rep_op;
8380 unop->op_next = rep_op->op_next;
8381 rep_op->op_next = (OP*)unop;
8382 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8383 unop->op_sibling = rep_op->op_sibling;
8384 rep_op->op_sibling = NULL;
8385 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8386 if (rep_op->op_type == OP_PADHV) {
8387 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8388 rep_op->op_flags |= OPf_WANT_LIST;
8393 /* Checks if o acts as an in-place operator on an array. oright points to the
8394 * beginning of the right-hand side. Returns the left-hand side of the
8395 * assignment if o acts in-place, or NULL otherwise. */
8398 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8402 PERL_ARGS_ASSERT_IS_INPLACE_AV;
8405 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8406 || oright->op_next != o
8407 || (oright->op_private & OPpLVAL_INTRO)
8411 /* o2 follows the chain of op_nexts through the LHS of the
8412 * assign (if any) to the aassign op itself */
8414 if (!o2 || o2->op_type != OP_NULL)
8417 if (!o2 || o2->op_type != OP_PUSHMARK)
8420 if (o2 && o2->op_type == OP_GV)
8423 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8424 || (o2->op_private & OPpLVAL_INTRO)
8429 if (!o2 || o2->op_type != OP_NULL)
8432 if (!o2 || o2->op_type != OP_AASSIGN
8433 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8436 /* check that the sort is the first arg on RHS of assign */
8438 o2 = cUNOPx(o2)->op_first;
8439 if (!o2 || o2->op_type != OP_NULL)
8441 o2 = cUNOPx(o2)->op_first;
8442 if (!o2 || o2->op_type != OP_PUSHMARK)
8444 if (o2->op_sibling != o)
8447 /* check the array is the same on both sides */
8448 if (oleft->op_type == OP_RV2AV) {
8449 if (oright->op_type != OP_RV2AV
8450 || !cUNOPx(oright)->op_first
8451 || cUNOPx(oright)->op_first->op_type != OP_GV
8452 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8453 cGVOPx_gv(cUNOPx(oright)->op_first)
8457 else if (oright->op_type != OP_PADAV
8458 || oright->op_targ != oleft->op_targ
8465 /* A peephole optimizer. We visit the ops in the order they're to execute.
8466 * See the comments at the top of this file for more details about when
8467 * peep() is called */
8470 Perl_peep(pTHX_ register OP *o)
8473 register OP* oldop = NULL;
8475 if (!o || o->op_opt)
8479 SAVEVPTR(PL_curcop);
8480 for (; o; o = o->op_next) {
8483 /* By default, this op has now been optimised. A couple of cases below
8484 clear this again. */
8487 switch (o->op_type) {
8490 PL_curcop = ((COP*)o); /* for warnings */
8494 if (cSVOPo->op_private & OPpCONST_STRICT)
8495 no_bareword_allowed(o);
8498 case OP_METHOD_NAMED:
8499 /* Relocate sv to the pad for thread safety.
8500 * Despite being a "constant", the SV is written to,
8501 * for reference counts, sv_upgrade() etc. */
8503 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8504 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8505 /* If op_sv is already a PADTMP then it is being used by
8506 * some pad, so make a copy. */
8507 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8508 SvREADONLY_on(PAD_SVl(ix));
8509 SvREFCNT_dec(cSVOPo->op_sv);
8511 else if (o->op_type != OP_METHOD_NAMED
8512 && cSVOPo->op_sv == &PL_sv_undef) {
8513 /* PL_sv_undef is hack - it's unsafe to store it in the
8514 AV that is the pad, because av_fetch treats values of
8515 PL_sv_undef as a "free" AV entry and will merrily
8516 replace them with a new SV, causing pad_alloc to think
8517 that this pad slot is free. (When, clearly, it is not)
8519 SvOK_off(PAD_SVl(ix));
8520 SvPADTMP_on(PAD_SVl(ix));
8521 SvREADONLY_on(PAD_SVl(ix));
8524 SvREFCNT_dec(PAD_SVl(ix));
8525 SvPADTMP_on(cSVOPo->op_sv);
8526 PAD_SETSV(ix, cSVOPo->op_sv);
8527 /* XXX I don't know how this isn't readonly already. */
8528 SvREADONLY_on(PAD_SVl(ix));
8530 cSVOPo->op_sv = NULL;
8537 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8538 if (o->op_next->op_private & OPpTARGET_MY) {
8539 if (o->op_flags & OPf_STACKED) /* chained concats */
8540 break; /* ignore_optimization */
8542 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8543 o->op_targ = o->op_next->op_targ;
8544 o->op_next->op_targ = 0;
8545 o->op_private |= OPpTARGET_MY;
8548 op_null(o->op_next);
8552 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8553 break; /* Scalar stub must produce undef. List stub is noop */
8557 if (o->op_targ == OP_NEXTSTATE
8558 || o->op_targ == OP_DBSTATE)
8560 PL_curcop = ((COP*)o);
8562 /* XXX: We avoid setting op_seq here to prevent later calls
8563 to peep() from mistakenly concluding that optimisation
8564 has already occurred. This doesn't fix the real problem,
8565 though (See 20010220.007). AMS 20010719 */
8566 /* op_seq functionality is now replaced by op_opt */
8573 if (oldop && o->op_next) {
8574 oldop->op_next = o->op_next;
8582 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8583 OP* const pop = (o->op_type == OP_PADAV) ?
8584 o->op_next : o->op_next->op_next;
8586 if (pop && pop->op_type == OP_CONST &&
8587 ((PL_op = pop->op_next)) &&
8588 pop->op_next->op_type == OP_AELEM &&
8589 !(pop->op_next->op_private &
8590 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8591 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8596 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8597 no_bareword_allowed(pop);
8598 if (o->op_type == OP_GV)
8599 op_null(o->op_next);
8600 op_null(pop->op_next);
8602 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8603 o->op_next = pop->op_next->op_next;
8604 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8605 o->op_private = (U8)i;
8606 if (o->op_type == OP_GV) {
8611 o->op_flags |= OPf_SPECIAL;
8612 o->op_type = OP_AELEMFAST;
8617 if (o->op_next->op_type == OP_RV2SV) {
8618 if (!(o->op_next->op_private & OPpDEREF)) {
8619 op_null(o->op_next);
8620 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8622 o->op_next = o->op_next->op_next;
8623 o->op_type = OP_GVSV;
8624 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8627 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8628 GV * const gv = cGVOPo_gv;
8629 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8630 /* XXX could check prototype here instead of just carping */
8631 SV * const sv = sv_newmortal();
8632 gv_efullname3(sv, gv, NULL);
8633 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8634 "%"SVf"() called too early to check prototype",
8638 else if (o->op_next->op_type == OP_READLINE
8639 && o->op_next->op_next->op_type == OP_CONCAT
8640 && (o->op_next->op_next->op_flags & OPf_STACKED))
8642 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8643 o->op_type = OP_RCATLINE;
8644 o->op_flags |= OPf_STACKED;
8645 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8646 op_null(o->op_next->op_next);
8647 op_null(o->op_next);
8657 fop = cUNOP->op_first;
8665 fop = cLOGOP->op_first;
8666 sop = fop->op_sibling;
8667 while (cLOGOP->op_other->op_type == OP_NULL)
8668 cLOGOP->op_other = cLOGOP->op_other->op_next;
8669 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8673 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8675 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8680 if (!(nop->op_flags && OPf_WANT_VOID)) {
8681 while (nop && nop->op_next) {
8682 switch (nop->op_next->op_type) {
8687 lop = nop = nop->op_next;
8698 if (lop->op_flags && OPf_WANT_VOID) {
8699 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8700 cLOGOP->op_first = opt_scalarhv(fop);
8701 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8702 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8718 while (cLOGOP->op_other->op_type == OP_NULL)
8719 cLOGOP->op_other = cLOGOP->op_other->op_next;
8720 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8725 while (cLOOP->op_redoop->op_type == OP_NULL)
8726 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8727 peep(cLOOP->op_redoop);
8728 while (cLOOP->op_nextop->op_type == OP_NULL)
8729 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8730 peep(cLOOP->op_nextop);
8731 while (cLOOP->op_lastop->op_type == OP_NULL)
8732 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8733 peep(cLOOP->op_lastop);
8737 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8738 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8739 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8740 cPMOP->op_pmstashstartu.op_pmreplstart
8741 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8742 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8746 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8747 && ckWARN(WARN_SYNTAX))
8749 if (o->op_next->op_sibling) {
8750 const OPCODE type = o->op_next->op_sibling->op_type;
8751 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8752 const line_t oldline = CopLINE(PL_curcop);
8753 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8754 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8755 "Statement unlikely to be reached");
8756 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8757 "\t(Maybe you meant system() when you said exec()?)\n");
8758 CopLINE_set(PL_curcop, oldline);
8769 const char *key = NULL;
8772 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8775 /* Make the CONST have a shared SV */
8776 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8777 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8778 key = SvPV_const(sv, keylen);
8779 lexname = newSVpvn_share(key,
8780 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8786 if ((o->op_private & (OPpLVAL_INTRO)))
8789 rop = (UNOP*)((BINOP*)o)->op_first;
8790 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8792 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8793 if (!SvPAD_TYPED(lexname))
8795 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8796 if (!fields || !GvHV(*fields))
8798 key = SvPV_const(*svp, keylen);
8799 if (!hv_fetch(GvHV(*fields), key,
8800 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8802 Perl_croak(aTHX_ "No such class field \"%s\" "
8803 "in variable %s of type %s",
8804 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8817 SVOP *first_key_op, *key_op;
8819 if ((o->op_private & (OPpLVAL_INTRO))
8820 /* I bet there's always a pushmark... */
8821 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8822 /* hmmm, no optimization if list contains only one key. */
8824 rop = (UNOP*)((LISTOP*)o)->op_last;
8825 if (rop->op_type != OP_RV2HV)
8827 if (rop->op_first->op_type == OP_PADSV)
8828 /* @$hash{qw(keys here)} */
8829 rop = (UNOP*)rop->op_first;
8831 /* @{$hash}{qw(keys here)} */
8832 if (rop->op_first->op_type == OP_SCOPE
8833 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8835 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8841 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8842 if (!SvPAD_TYPED(lexname))
8844 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8845 if (!fields || !GvHV(*fields))
8847 /* Again guessing that the pushmark can be jumped over.... */
8848 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8849 ->op_first->op_sibling;
8850 for (key_op = first_key_op; key_op;
8851 key_op = (SVOP*)key_op->op_sibling) {
8852 if (key_op->op_type != OP_CONST)
8854 svp = cSVOPx_svp(key_op);
8855 key = SvPV_const(*svp, keylen);
8856 if (!hv_fetch(GvHV(*fields), key,
8857 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8859 Perl_croak(aTHX_ "No such class field \"%s\" "
8860 "in variable %s of type %s",
8861 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8868 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8872 /* check that RHS of sort is a single plain array */
8873 OP *oright = cUNOPo->op_first;
8874 if (!oright || oright->op_type != OP_PUSHMARK)
8877 /* reverse sort ... can be optimised. */
8878 if (!cUNOPo->op_sibling) {
8879 /* Nothing follows us on the list. */
8880 OP * const reverse = o->op_next;
8882 if (reverse->op_type == OP_REVERSE &&
8883 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8884 OP * const pushmark = cUNOPx(reverse)->op_first;
8885 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8886 && (cUNOPx(pushmark)->op_sibling == o)) {
8887 /* reverse -> pushmark -> sort */
8888 o->op_private |= OPpSORT_REVERSE;
8890 pushmark->op_next = oright->op_next;
8896 /* make @a = sort @a act in-place */
8898 oright = cUNOPx(oright)->op_sibling;
8901 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8902 oright = cUNOPx(oright)->op_sibling;
8905 oleft = is_inplace_av(o, oright);
8909 /* transfer MODishness etc from LHS arg to RHS arg */
8910 oright->op_flags = oleft->op_flags;
8911 o->op_private |= OPpSORT_INPLACE;
8913 /* excise push->gv->rv2av->null->aassign */
8914 o2 = o->op_next->op_next;
8915 op_null(o2); /* PUSHMARK */
8917 if (o2->op_type == OP_GV) {
8918 op_null(o2); /* GV */
8921 op_null(o2); /* RV2AV or PADAV */
8922 o2 = o2->op_next->op_next;
8923 op_null(o2); /* AASSIGN */
8925 o->op_next = o2->op_next;
8931 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8934 LISTOP *enter, *exlist;
8936 /* @a = reverse @a */
8937 if ((oright = cLISTOPo->op_first)
8938 && (oright->op_type == OP_PUSHMARK)
8939 && (oright = oright->op_sibling)
8940 && (oleft = is_inplace_av(o, oright))) {
8943 /* transfer MODishness etc from LHS arg to RHS arg */
8944 oright->op_flags = oleft->op_flags;
8945 o->op_private |= OPpREVERSE_INPLACE;
8947 /* excise push->gv->rv2av->null->aassign */
8948 o2 = o->op_next->op_next;
8949 op_null(o2); /* PUSHMARK */
8951 if (o2->op_type == OP_GV) {
8952 op_null(o2); /* GV */
8955 op_null(o2); /* RV2AV or PADAV */
8956 o2 = o2->op_next->op_next;
8957 op_null(o2); /* AASSIGN */
8959 o->op_next = o2->op_next;
8963 enter = (LISTOP *) o->op_next;
8966 if (enter->op_type == OP_NULL) {
8967 enter = (LISTOP *) enter->op_next;
8971 /* for $a (...) will have OP_GV then OP_RV2GV here.
8972 for (...) just has an OP_GV. */
8973 if (enter->op_type == OP_GV) {
8974 gvop = (OP *) enter;
8975 enter = (LISTOP *) enter->op_next;
8978 if (enter->op_type == OP_RV2GV) {
8979 enter = (LISTOP *) enter->op_next;
8985 if (enter->op_type != OP_ENTERITER)
8988 iter = enter->op_next;
8989 if (!iter || iter->op_type != OP_ITER)
8992 expushmark = enter->op_first;
8993 if (!expushmark || expushmark->op_type != OP_NULL
8994 || expushmark->op_targ != OP_PUSHMARK)
8997 exlist = (LISTOP *) expushmark->op_sibling;
8998 if (!exlist || exlist->op_type != OP_NULL
8999 || exlist->op_targ != OP_LIST)
9002 if (exlist->op_last != o) {
9003 /* Mmm. Was expecting to point back to this op. */
9006 theirmark = exlist->op_first;
9007 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9010 if (theirmark->op_sibling != o) {
9011 /* There's something between the mark and the reverse, eg
9012 for (1, reverse (...))
9017 ourmark = ((LISTOP *)o)->op_first;
9018 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9021 ourlast = ((LISTOP *)o)->op_last;
9022 if (!ourlast || ourlast->op_next != o)
9025 rv2av = ourmark->op_sibling;
9026 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9027 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9028 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9029 /* We're just reversing a single array. */
9030 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9031 enter->op_flags |= OPf_STACKED;
9034 /* We don't have control over who points to theirmark, so sacrifice
9036 theirmark->op_next = ourmark->op_next;
9037 theirmark->op_flags = ourmark->op_flags;
9038 ourlast->op_next = gvop ? gvop : (OP *) enter;
9041 enter->op_private |= OPpITER_REVERSED;
9042 iter->op_private |= OPpITER_REVERSED;
9049 UNOP *refgen, *rv2cv;
9052 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9055 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9058 rv2gv = ((BINOP *)o)->op_last;
9059 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9062 refgen = (UNOP *)((BINOP *)o)->op_first;
9064 if (!refgen || refgen->op_type != OP_REFGEN)
9067 exlist = (LISTOP *)refgen->op_first;
9068 if (!exlist || exlist->op_type != OP_NULL
9069 || exlist->op_targ != OP_LIST)
9072 if (exlist->op_first->op_type != OP_PUSHMARK)
9075 rv2cv = (UNOP*)exlist->op_last;
9077 if (rv2cv->op_type != OP_RV2CV)
9080 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9081 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9082 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9084 o->op_private |= OPpASSIGN_CV_TO_GV;
9085 rv2gv->op_private |= OPpDONT_INIT_GV;
9086 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9094 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9095 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9105 Perl_custom_op_name(pTHX_ const OP* o)
9108 const IV index = PTR2IV(o->op_ppaddr);
9112 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9114 if (!PL_custom_op_names) /* This probably shouldn't happen */
9115 return (char *)PL_op_name[OP_CUSTOM];
9117 keysv = sv_2mortal(newSViv(index));
9119 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9121 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9123 return SvPV_nolen(HeVAL(he));
9127 Perl_custom_op_desc(pTHX_ const OP* o)
9130 const IV index = PTR2IV(o->op_ppaddr);
9134 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9136 if (!PL_custom_op_descs)
9137 return (char *)PL_op_desc[OP_CUSTOM];
9139 keysv = sv_2mortal(newSViv(index));
9141 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9143 return (char *)PL_op_desc[OP_CUSTOM];
9145 return SvPV_nolen(HeVAL(he));
9150 /* Efficient sub that returns a constant scalar value. */
9152 const_sv_xsub(pTHX_ CV* cv)
9156 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9160 /* diag_listed_as: SKIPME */
9161 Perl_croak(aTHX_ "usage: %s::%s()",
9162 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9175 * c-indentation-style: bsd
9177 * indent-tabs-mode: t
9180 * ex: set ts=8 sts=4 sw=4 noet: