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)
379 const bool is_our = (PL_parser->in_my == KEY_our);
381 PERL_ARGS_ASSERT_ALLOCMY;
383 /* complain about "my $<special_var>" etc etc */
387 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
388 (name[1] == '_' && (*name == '$' || name[2]))))
390 /* name[2] is true if strlen(name) > 2 */
391 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
392 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
393 name[0], toCTRL(name[1]), name + 2,
394 PL_parser->in_my == KEY_state ? "state" : "my"));
396 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
397 PL_parser->in_my == KEY_state ? "state" : "my"));
401 /* check for duplicate declaration */
402 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
404 /* allocate a spare slot and store the name in that slot */
406 off = pad_add_name(name,
407 PL_parser->in_my_stash,
409 /* $_ is always in main::, even with our */
410 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
414 PL_parser->in_my == KEY_state
416 /* anon sub prototypes contains state vars should always be cloned,
417 * otherwise the state var would be shared between anon subs */
419 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
420 CvCLONE_on(PL_compcv);
425 /* free the body of an op without examining its contents.
426 * Always use this rather than FreeOp directly */
429 S_op_destroy(pTHX_ OP *o)
431 if (o->op_latefree) {
439 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
441 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
447 Perl_op_free(pTHX_ OP *o)
454 if (o->op_latefreed) {
461 if (o->op_private & OPpREFCOUNTED) {
472 refcnt = OpREFCNT_dec(o);
475 /* Need to find and remove any pattern match ops from the list
476 we maintain for reset(). */
477 find_and_forget_pmops(o);
487 /* Call the op_free hook if it has been set. Do it now so that it's called
488 * at the right time for refcounted ops, but still before all of the kids
492 if (o->op_flags & OPf_KIDS) {
493 register OP *kid, *nextkid;
494 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
495 nextkid = kid->op_sibling; /* Get before next freeing kid */
500 #ifdef PERL_DEBUG_READONLY_OPS
504 /* COP* is not cleared by op_clear() so that we may track line
505 * numbers etc even after null() */
506 if (type == OP_NEXTSTATE || type == OP_DBSTATE
507 || (type == OP_NULL /* the COP might have been null'ed */
508 && ((OPCODE)o->op_targ == OP_NEXTSTATE
509 || (OPCODE)o->op_targ == OP_DBSTATE))) {
514 type = (OPCODE)o->op_targ;
517 if (o->op_latefree) {
523 #ifdef DEBUG_LEAKING_SCALARS
530 Perl_op_clear(pTHX_ OP *o)
535 PERL_ARGS_ASSERT_OP_CLEAR;
538 /* if (o->op_madprop && o->op_madprop->mad_next)
540 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
541 "modification of a read only value" for a reason I can't fathom why.
542 It's the "" stringification of $_, where $_ was set to '' in a foreach
543 loop, but it defies simplification into a small test case.
544 However, commenting them out has caused ext/List/Util/t/weak.t to fail
547 mad_free(o->op_madprop);
553 switch (o->op_type) {
554 case OP_NULL: /* Was holding old type, if any. */
555 if (PL_madskills && o->op_targ != OP_NULL) {
556 o->op_type = (Optype)o->op_targ;
560 case OP_ENTEREVAL: /* Was holding hints. */
564 if (!(o->op_flags & OPf_REF)
565 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
571 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
572 /* not an OP_PADAV replacement */
573 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
581 if (cPADOPo->op_padix > 0) {
582 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
583 * may still exist on the pad */
584 pad_swipe(cPADOPo->op_padix, TRUE);
585 cPADOPo->op_padix = 0;
588 SvREFCNT_dec(cSVOPo->op_sv);
589 cSVOPo->op_sv = NULL;
592 int try_downgrade = SvREFCNT(gv) == 2;
595 gv_try_downgrade(gv);
599 case OP_METHOD_NAMED:
602 SvREFCNT_dec(cSVOPo->op_sv);
603 cSVOPo->op_sv = NULL;
606 Even if op_clear does a pad_free for the target of the op,
607 pad_free doesn't actually remove the sv that exists in the pad;
608 instead it lives on. This results in that it could be reused as
609 a target later on when the pad was reallocated.
612 pad_swipe(o->op_targ,1);
621 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
625 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
627 if (cPADOPo->op_padix > 0) {
628 pad_swipe(cPADOPo->op_padix, TRUE);
629 cPADOPo->op_padix = 0;
632 SvREFCNT_dec(cSVOPo->op_sv);
633 cSVOPo->op_sv = NULL;
637 PerlMemShared_free(cPVOPo->op_pv);
638 cPVOPo->op_pv = NULL;
642 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
646 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
647 /* No GvIN_PAD_off here, because other references may still
648 * exist on the pad */
649 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
652 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
658 forget_pmop(cPMOPo, 1);
659 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
660 /* we use the same protection as the "SAFE" version of the PM_ macros
661 * here since sv_clean_all might release some PMOPs
662 * after PL_regex_padav has been cleared
663 * and the clearing of PL_regex_padav needs to
664 * happen before sv_clean_all
667 if(PL_regex_pad) { /* We could be in destruction */
668 const IV offset = (cPMOPo)->op_pmoffset;
669 ReREFCNT_dec(PM_GETRE(cPMOPo));
670 PL_regex_pad[offset] = &PL_sv_undef;
671 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
675 ReREFCNT_dec(PM_GETRE(cPMOPo));
676 PM_SETRE(cPMOPo, NULL);
682 if (o->op_targ > 0) {
683 pad_free(o->op_targ);
689 S_cop_free(pTHX_ COP* cop)
691 PERL_ARGS_ASSERT_COP_FREE;
695 if (! specialWARN(cop->cop_warnings))
696 PerlMemShared_free(cop->cop_warnings);
697 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
701 S_forget_pmop(pTHX_ PMOP *const o
707 HV * const pmstash = PmopSTASH(o);
709 PERL_ARGS_ASSERT_FORGET_PMOP;
711 if (pmstash && !SvIS_FREED(pmstash)) {
712 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
714 PMOP **const array = (PMOP**) mg->mg_ptr;
715 U32 count = mg->mg_len / sizeof(PMOP**);
720 /* Found it. Move the entry at the end to overwrite it. */
721 array[i] = array[--count];
722 mg->mg_len = count * sizeof(PMOP**);
723 /* Could realloc smaller at this point always, but probably
724 not worth it. Probably worth free()ing if we're the
727 Safefree(mg->mg_ptr);
744 S_find_and_forget_pmops(pTHX_ OP *o)
746 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
748 if (o->op_flags & OPf_KIDS) {
749 OP *kid = cUNOPo->op_first;
751 switch (kid->op_type) {
756 forget_pmop((PMOP*)kid, 0);
758 find_and_forget_pmops(kid);
759 kid = kid->op_sibling;
765 Perl_op_null(pTHX_ OP *o)
769 PERL_ARGS_ASSERT_OP_NULL;
771 if (o->op_type == OP_NULL)
775 o->op_targ = o->op_type;
776 o->op_type = OP_NULL;
777 o->op_ppaddr = PL_ppaddr[OP_NULL];
781 Perl_op_refcnt_lock(pTHX)
789 Perl_op_refcnt_unlock(pTHX)
796 /* Contextualizers */
798 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
801 S_linklist(pTHX_ OP *o)
805 PERL_ARGS_ASSERT_LINKLIST;
810 /* establish postfix order */
811 first = cUNOPo->op_first;
814 o->op_next = LINKLIST(first);
817 if (kid->op_sibling) {
818 kid->op_next = LINKLIST(kid->op_sibling);
819 kid = kid->op_sibling;
833 S_scalarkids(pTHX_ OP *o)
835 if (o && o->op_flags & OPf_KIDS) {
837 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
844 S_scalarboolean(pTHX_ OP *o)
848 PERL_ARGS_ASSERT_SCALARBOOLEAN;
850 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
851 if (ckWARN(WARN_SYNTAX)) {
852 const line_t oldline = CopLINE(PL_curcop);
854 if (PL_parser && PL_parser->copline != NOLINE)
855 CopLINE_set(PL_curcop, PL_parser->copline);
856 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
857 CopLINE_set(PL_curcop, oldline);
864 Perl_scalar(pTHX_ OP *o)
869 /* assumes no premature commitment */
870 if (!o || (PL_parser && PL_parser->error_count)
871 || (o->op_flags & OPf_WANT)
872 || o->op_type == OP_RETURN)
877 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
879 switch (o->op_type) {
881 scalar(cBINOPo->op_first);
886 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
896 if (o->op_flags & OPf_KIDS) {
897 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
903 kid = cLISTOPo->op_first;
905 while ((kid = kid->op_sibling)) {
911 PL_curcop = &PL_compiling;
916 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
922 PL_curcop = &PL_compiling;
925 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
932 Perl_scalarvoid(pTHX_ OP *o)
936 const char* useless = NULL;
940 PERL_ARGS_ASSERT_SCALARVOID;
942 /* trailing mad null ops don't count as "there" for void processing */
944 o->op_type != OP_NULL &&
946 o->op_sibling->op_type == OP_NULL)
949 for (sib = o->op_sibling;
950 sib && sib->op_type == OP_NULL;
951 sib = sib->op_sibling) ;
957 if (o->op_type == OP_NEXTSTATE
958 || o->op_type == OP_DBSTATE
959 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
960 || o->op_targ == OP_DBSTATE)))
961 PL_curcop = (COP*)o; /* for warning below */
963 /* assumes no premature commitment */
964 want = o->op_flags & OPf_WANT;
965 if ((want && want != OPf_WANT_SCALAR)
966 || (PL_parser && PL_parser->error_count)
967 || o->op_type == OP_RETURN)
972 if ((o->op_private & OPpTARGET_MY)
973 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
975 return scalar(o); /* As if inside SASSIGN */
978 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
980 switch (o->op_type) {
982 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
986 if (o->op_flags & OPf_STACKED)
990 if (o->op_private == 4)
1033 case OP_GETSOCKNAME:
1034 case OP_GETPEERNAME:
1039 case OP_GETPRIORITY:
1063 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1064 /* Otherwise it's "Useless use of grep iterator" */
1065 useless = OP_DESC(o);
1069 kid = cUNOPo->op_first;
1070 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1071 kid->op_type != OP_TRANS) {
1074 useless = "negative pattern binding (!~)";
1081 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1082 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1083 useless = "a variable";
1088 if (cSVOPo->op_private & OPpCONST_STRICT)
1089 no_bareword_allowed(o);
1091 if (ckWARN(WARN_VOID)) {
1093 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1094 "a constant (%"SVf")", sv));
1095 useless = SvPV_nolen(msv);
1098 useless = "a constant (undef)";
1099 if (o->op_private & OPpCONST_ARYBASE)
1101 /* don't warn on optimised away booleans, eg
1102 * use constant Foo, 5; Foo || print; */
1103 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1105 /* the constants 0 and 1 are permitted as they are
1106 conventionally used as dummies in constructs like
1107 1 while some_condition_with_side_effects; */
1108 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1110 else if (SvPOK(sv)) {
1111 /* perl4's way of mixing documentation and code
1112 (before the invention of POD) was based on a
1113 trick to mix nroff and perl code. The trick was
1114 built upon these three nroff macros being used in
1115 void context. The pink camel has the details in
1116 the script wrapman near page 319. */
1117 const char * const maybe_macro = SvPVX_const(sv);
1118 if (strnEQ(maybe_macro, "di", 2) ||
1119 strnEQ(maybe_macro, "ds", 2) ||
1120 strnEQ(maybe_macro, "ig", 2))
1125 op_null(o); /* don't execute or even remember it */
1129 o->op_type = OP_PREINC; /* pre-increment is faster */
1130 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1134 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1135 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1139 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1140 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1144 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1145 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1150 kid = cLOGOPo->op_first;
1151 if (kid->op_type == OP_NOT
1152 && (kid->op_flags & OPf_KIDS)
1154 if (o->op_type == OP_AND) {
1156 o->op_ppaddr = PL_ppaddr[OP_OR];
1158 o->op_type = OP_AND;
1159 o->op_ppaddr = PL_ppaddr[OP_AND];
1168 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1173 if (o->op_flags & OPf_STACKED)
1180 if (!(o->op_flags & OPf_KIDS))
1191 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1198 /* all requires must return a boolean value */
1199 o->op_flags &= ~OPf_WANT;
1205 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1210 S_listkids(pTHX_ OP *o)
1212 if (o && o->op_flags & OPf_KIDS) {
1214 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1221 Perl_list(pTHX_ OP *o)
1226 /* assumes no premature commitment */
1227 if (!o || (o->op_flags & OPf_WANT)
1228 || (PL_parser && PL_parser->error_count)
1229 || o->op_type == OP_RETURN)
1234 if ((o->op_private & OPpTARGET_MY)
1235 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1237 return o; /* As if inside SASSIGN */
1240 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1242 switch (o->op_type) {
1245 list(cBINOPo->op_first);
1250 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1258 if (!(o->op_flags & OPf_KIDS))
1260 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1261 list(cBINOPo->op_first);
1262 return gen_constant_list(o);
1269 kid = cLISTOPo->op_first;
1271 while ((kid = kid->op_sibling)) {
1272 if (kid->op_sibling)
1277 PL_curcop = &PL_compiling;
1281 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1282 if (kid->op_sibling)
1287 PL_curcop = &PL_compiling;
1290 /* all requires must return a boolean value */
1291 o->op_flags &= ~OPf_WANT;
1298 S_scalarseq(pTHX_ OP *o)
1302 const OPCODE type = o->op_type;
1304 if (type == OP_LINESEQ || type == OP_SCOPE ||
1305 type == OP_LEAVE || type == OP_LEAVETRY)
1308 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1309 if (kid->op_sibling) {
1313 PL_curcop = &PL_compiling;
1315 o->op_flags &= ~OPf_PARENS;
1316 if (PL_hints & HINT_BLOCK_SCOPE)
1317 o->op_flags |= OPf_PARENS;
1320 o = newOP(OP_STUB, 0);
1325 S_modkids(pTHX_ OP *o, I32 type)
1327 if (o && o->op_flags & OPf_KIDS) {
1329 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1335 /* Propagate lvalue ("modifiable") context to an op and its children.
1336 * 'type' represents the context type, roughly based on the type of op that
1337 * would do the modifying, although local() is represented by OP_NULL.
1338 * It's responsible for detecting things that can't be modified, flag
1339 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1340 * might have to vivify a reference in $x), and so on.
1342 * For example, "$a+1 = 2" would cause mod() to be called with o being
1343 * OP_ADD and type being OP_SASSIGN, and would output an error.
1347 Perl_mod(pTHX_ OP *o, I32 type)
1351 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1354 if (!o || (PL_parser && PL_parser->error_count))
1357 if ((o->op_private & OPpTARGET_MY)
1358 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1363 switch (o->op_type) {
1369 if (!(o->op_private & OPpCONST_ARYBASE))
1372 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1373 CopARYBASE_set(&PL_compiling,
1374 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1378 SAVECOPARYBASE(&PL_compiling);
1379 CopARYBASE_set(&PL_compiling, 0);
1381 else if (type == OP_REFGEN)
1384 Perl_croak(aTHX_ "That use of $[ is unsupported");
1387 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1391 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1392 !(o->op_flags & OPf_STACKED)) {
1393 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1394 /* The default is to set op_private to the number of children,
1395 which for a UNOP such as RV2CV is always 1. And w're using
1396 the bit for a flag in RV2CV, so we need it clear. */
1397 o->op_private &= ~1;
1398 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1399 assert(cUNOPo->op_first->op_type == OP_NULL);
1400 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1403 else if (o->op_private & OPpENTERSUB_NOMOD)
1405 else { /* lvalue subroutine call */
1406 o->op_private |= OPpLVAL_INTRO;
1407 PL_modcount = RETURN_UNLIMITED_NUMBER;
1408 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1409 /* Backward compatibility mode: */
1410 o->op_private |= OPpENTERSUB_INARGS;
1413 else { /* Compile-time error message: */
1414 OP *kid = cUNOPo->op_first;
1418 if (kid->op_type != OP_PUSHMARK) {
1419 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1421 "panic: unexpected lvalue entersub "
1422 "args: type/targ %ld:%"UVuf,
1423 (long)kid->op_type, (UV)kid->op_targ);
1424 kid = kLISTOP->op_first;
1426 while (kid->op_sibling)
1427 kid = kid->op_sibling;
1428 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1430 if (kid->op_type == OP_METHOD_NAMED
1431 || kid->op_type == OP_METHOD)
1435 NewOp(1101, newop, 1, UNOP);
1436 newop->op_type = OP_RV2CV;
1437 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1438 newop->op_first = NULL;
1439 newop->op_next = (OP*)newop;
1440 kid->op_sibling = (OP*)newop;
1441 newop->op_private |= OPpLVAL_INTRO;
1442 newop->op_private &= ~1;
1446 if (kid->op_type != OP_RV2CV)
1448 "panic: unexpected lvalue entersub "
1449 "entry via type/targ %ld:%"UVuf,
1450 (long)kid->op_type, (UV)kid->op_targ);
1451 kid->op_private |= OPpLVAL_INTRO;
1452 break; /* Postpone until runtime */
1456 kid = kUNOP->op_first;
1457 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1458 kid = kUNOP->op_first;
1459 if (kid->op_type == OP_NULL)
1461 "Unexpected constant lvalue entersub "
1462 "entry via type/targ %ld:%"UVuf,
1463 (long)kid->op_type, (UV)kid->op_targ);
1464 if (kid->op_type != OP_GV) {
1465 /* Restore RV2CV to check lvalueness */
1467 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1468 okid->op_next = kid->op_next;
1469 kid->op_next = okid;
1472 okid->op_next = NULL;
1473 okid->op_type = OP_RV2CV;
1475 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1476 okid->op_private |= OPpLVAL_INTRO;
1477 okid->op_private &= ~1;
1481 cv = GvCV(kGVOP_gv);
1491 /* grep, foreach, subcalls, refgen */
1492 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1494 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1495 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1497 : (o->op_type == OP_ENTERSUB
1498 ? "non-lvalue subroutine call"
1500 type ? PL_op_desc[type] : "local"));
1514 case OP_RIGHT_SHIFT:
1523 if (!(o->op_flags & OPf_STACKED))
1530 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1536 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1537 PL_modcount = RETURN_UNLIMITED_NUMBER;
1538 return o; /* Treat \(@foo) like ordinary list. */
1542 if (scalar_mod_type(o, type))
1544 ref(cUNOPo->op_first, o->op_type);
1548 if (type == OP_LEAVESUBLV)
1549 o->op_private |= OPpMAYBE_LVSUB;
1555 PL_modcount = RETURN_UNLIMITED_NUMBER;
1558 PL_hints |= HINT_BLOCK_SCOPE;
1559 if (type == OP_LEAVESUBLV)
1560 o->op_private |= OPpMAYBE_LVSUB;
1564 ref(cUNOPo->op_first, o->op_type);
1568 PL_hints |= HINT_BLOCK_SCOPE;
1583 PL_modcount = RETURN_UNLIMITED_NUMBER;
1584 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1585 return o; /* Treat \(@foo) like ordinary list. */
1586 if (scalar_mod_type(o, type))
1588 if (type == OP_LEAVESUBLV)
1589 o->op_private |= OPpMAYBE_LVSUB;
1593 if (!type) /* local() */
1594 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1595 PAD_COMPNAME_PV(o->op_targ));
1603 if (type != OP_SASSIGN)
1607 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1612 if (type == OP_LEAVESUBLV)
1613 o->op_private |= OPpMAYBE_LVSUB;
1615 pad_free(o->op_targ);
1616 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1617 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1618 if (o->op_flags & OPf_KIDS)
1619 mod(cBINOPo->op_first->op_sibling, type);
1624 ref(cBINOPo->op_first, o->op_type);
1625 if (type == OP_ENTERSUB &&
1626 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1627 o->op_private |= OPpLVAL_DEFER;
1628 if (type == OP_LEAVESUBLV)
1629 o->op_private |= OPpMAYBE_LVSUB;
1639 if (o->op_flags & OPf_KIDS)
1640 mod(cLISTOPo->op_last, type);
1645 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1647 else if (!(o->op_flags & OPf_KIDS))
1649 if (o->op_targ != OP_LIST) {
1650 mod(cBINOPo->op_first, type);
1656 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1661 if (type != OP_LEAVESUBLV)
1663 break; /* mod()ing was handled by ck_return() */
1666 /* [20011101.069] File test operators interpret OPf_REF to mean that
1667 their argument is a filehandle; thus \stat(".") should not set
1669 if (type == OP_REFGEN &&
1670 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1673 if (type != OP_LEAVESUBLV)
1674 o->op_flags |= OPf_MOD;
1676 if (type == OP_AASSIGN || type == OP_SASSIGN)
1677 o->op_flags |= OPf_SPECIAL|OPf_REF;
1678 else if (!type) { /* local() */
1681 o->op_private |= OPpLVAL_INTRO;
1682 o->op_flags &= ~OPf_SPECIAL;
1683 PL_hints |= HINT_BLOCK_SCOPE;
1688 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1689 "Useless localization of %s", OP_DESC(o));
1692 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1693 && type != OP_LEAVESUBLV)
1694 o->op_flags |= OPf_REF;
1699 S_scalar_mod_type(const OP *o, I32 type)
1701 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1705 if (o->op_type == OP_RV2GV)
1729 case OP_RIGHT_SHIFT:
1749 S_is_handle_constructor(const OP *o, I32 numargs)
1751 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1753 switch (o->op_type) {
1761 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1774 S_refkids(pTHX_ OP *o, I32 type)
1776 if (o && o->op_flags & OPf_KIDS) {
1778 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1785 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1790 PERL_ARGS_ASSERT_DOREF;
1792 if (!o || (PL_parser && PL_parser->error_count))
1795 switch (o->op_type) {
1797 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1798 !(o->op_flags & OPf_STACKED)) {
1799 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1800 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1801 assert(cUNOPo->op_first->op_type == OP_NULL);
1802 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1803 o->op_flags |= OPf_SPECIAL;
1804 o->op_private &= ~1;
1809 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1810 doref(kid, type, set_op_ref);
1813 if (type == OP_DEFINED)
1814 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1815 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1818 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1819 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1820 : type == OP_RV2HV ? OPpDEREF_HV
1822 o->op_flags |= OPf_MOD;
1829 o->op_flags |= OPf_REF;
1832 if (type == OP_DEFINED)
1833 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1834 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1840 o->op_flags |= OPf_REF;
1845 if (!(o->op_flags & OPf_KIDS))
1847 doref(cBINOPo->op_first, type, set_op_ref);
1851 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1852 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1853 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1854 : type == OP_RV2HV ? OPpDEREF_HV
1856 o->op_flags |= OPf_MOD;
1866 if (!(o->op_flags & OPf_KIDS))
1868 doref(cLISTOPo->op_last, type, set_op_ref);
1878 S_dup_attrlist(pTHX_ OP *o)
1883 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1885 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1886 * where the first kid is OP_PUSHMARK and the remaining ones
1887 * are OP_CONST. We need to push the OP_CONST values.
1889 if (o->op_type == OP_CONST)
1890 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1892 else if (o->op_type == OP_NULL)
1896 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1898 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1899 if (o->op_type == OP_CONST)
1900 rop = append_elem(OP_LIST, rop,
1901 newSVOP(OP_CONST, o->op_flags,
1902 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1909 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1914 PERL_ARGS_ASSERT_APPLY_ATTRS;
1916 /* fake up C<use attributes $pkg,$rv,@attrs> */
1917 ENTER; /* need to protect against side-effects of 'use' */
1918 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1920 #define ATTRSMODULE "attributes"
1921 #define ATTRSMODULE_PM "attributes.pm"
1924 /* Don't force the C<use> if we don't need it. */
1925 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1926 if (svp && *svp != &PL_sv_undef)
1927 NOOP; /* already in %INC */
1929 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1930 newSVpvs(ATTRSMODULE), NULL);
1933 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1934 newSVpvs(ATTRSMODULE),
1936 prepend_elem(OP_LIST,
1937 newSVOP(OP_CONST, 0, stashsv),
1938 prepend_elem(OP_LIST,
1939 newSVOP(OP_CONST, 0,
1941 dup_attrlist(attrs))));
1947 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1950 OP *pack, *imop, *arg;
1953 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1958 assert(target->op_type == OP_PADSV ||
1959 target->op_type == OP_PADHV ||
1960 target->op_type == OP_PADAV);
1962 /* Ensure that attributes.pm is loaded. */
1963 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1965 /* Need package name for method call. */
1966 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1968 /* Build up the real arg-list. */
1969 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1971 arg = newOP(OP_PADSV, 0);
1972 arg->op_targ = target->op_targ;
1973 arg = prepend_elem(OP_LIST,
1974 newSVOP(OP_CONST, 0, stashsv),
1975 prepend_elem(OP_LIST,
1976 newUNOP(OP_REFGEN, 0,
1977 mod(arg, OP_REFGEN)),
1978 dup_attrlist(attrs)));
1980 /* Fake up a method call to import */
1981 meth = newSVpvs_share("import");
1982 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1983 append_elem(OP_LIST,
1984 prepend_elem(OP_LIST, pack, list(arg)),
1985 newSVOP(OP_METHOD_NAMED, 0, meth)));
1986 imop->op_private |= OPpENTERSUB_NOMOD;
1988 /* Combine the ops. */
1989 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1993 =notfor apidoc apply_attrs_string
1995 Attempts to apply a list of attributes specified by the C<attrstr> and
1996 C<len> arguments to the subroutine identified by the C<cv> argument which
1997 is expected to be associated with the package identified by the C<stashpv>
1998 argument (see L<attributes>). It gets this wrong, though, in that it
1999 does not correctly identify the boundaries of the individual attribute
2000 specifications within C<attrstr>. This is not really intended for the
2001 public API, but has to be listed here for systems such as AIX which
2002 need an explicit export list for symbols. (It's called from XS code
2003 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2004 to respect attribute syntax properly would be welcome.
2010 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2011 const char *attrstr, STRLEN len)
2015 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2018 len = strlen(attrstr);
2022 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2024 const char * const sstr = attrstr;
2025 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2026 attrs = append_elem(OP_LIST, attrs,
2027 newSVOP(OP_CONST, 0,
2028 newSVpvn(sstr, attrstr-sstr)));
2032 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2033 newSVpvs(ATTRSMODULE),
2034 NULL, prepend_elem(OP_LIST,
2035 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2036 prepend_elem(OP_LIST,
2037 newSVOP(OP_CONST, 0,
2038 newRV(MUTABLE_SV(cv))),
2043 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2048 PERL_ARGS_ASSERT_MY_KID;
2050 if (!o || (PL_parser && PL_parser->error_count))
2054 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2055 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2059 if (type == OP_LIST) {
2061 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2062 my_kid(kid, attrs, imopsp);
2063 } else if (type == OP_UNDEF
2069 } else if (type == OP_RV2SV || /* "our" declaration */
2071 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2072 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2073 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2075 PL_parser->in_my == KEY_our
2077 : PL_parser->in_my == KEY_state ? "state" : "my"));
2079 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2080 PL_parser->in_my = FALSE;
2081 PL_parser->in_my_stash = NULL;
2082 apply_attrs(GvSTASH(gv),
2083 (type == OP_RV2SV ? GvSV(gv) :
2084 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2085 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2088 o->op_private |= OPpOUR_INTRO;
2091 else if (type != OP_PADSV &&
2094 type != OP_PUSHMARK)
2096 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2098 PL_parser->in_my == KEY_our
2100 : PL_parser->in_my == KEY_state ? "state" : "my"));
2103 else if (attrs && type != OP_PUSHMARK) {
2106 PL_parser->in_my = FALSE;
2107 PL_parser->in_my_stash = NULL;
2109 /* check for C<my Dog $spot> when deciding package */
2110 stash = PAD_COMPNAME_TYPE(o->op_targ);
2112 stash = PL_curstash;
2113 apply_attrs_my(stash, o, attrs, imopsp);
2115 o->op_flags |= OPf_MOD;
2116 o->op_private |= OPpLVAL_INTRO;
2117 if (PL_parser->in_my == KEY_state)
2118 o->op_private |= OPpPAD_STATE;
2123 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2127 int maybe_scalar = 0;
2129 PERL_ARGS_ASSERT_MY_ATTRS;
2131 /* [perl #17376]: this appears to be premature, and results in code such as
2132 C< our(%x); > executing in list mode rather than void mode */
2134 if (o->op_flags & OPf_PARENS)
2144 o = my_kid(o, attrs, &rops);
2146 if (maybe_scalar && o->op_type == OP_PADSV) {
2147 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2148 o->op_private |= OPpLVAL_INTRO;
2151 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2153 PL_parser->in_my = FALSE;
2154 PL_parser->in_my_stash = NULL;
2159 Perl_sawparens(pTHX_ OP *o)
2161 PERL_UNUSED_CONTEXT;
2163 o->op_flags |= OPf_PARENS;
2168 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2172 const OPCODE ltype = left->op_type;
2173 const OPCODE rtype = right->op_type;
2175 PERL_ARGS_ASSERT_BIND_MATCH;
2177 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2178 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2180 const char * const desc
2181 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2182 ? (int)rtype : OP_MATCH];
2183 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2184 ? "@array" : "%hash");
2185 Perl_warner(aTHX_ packWARN(WARN_MISC),
2186 "Applying %s to %s will act on scalar(%s)",
2187 desc, sample, sample);
2190 if (rtype == OP_CONST &&
2191 cSVOPx(right)->op_private & OPpCONST_BARE &&
2192 cSVOPx(right)->op_private & OPpCONST_STRICT)
2194 no_bareword_allowed(right);
2197 ismatchop = rtype == OP_MATCH ||
2198 rtype == OP_SUBST ||
2200 if (ismatchop && right->op_private & OPpTARGET_MY) {
2202 right->op_private &= ~OPpTARGET_MY;
2204 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2207 right->op_flags |= OPf_STACKED;
2208 if (rtype != OP_MATCH &&
2209 ! (rtype == OP_TRANS &&
2210 right->op_private & OPpTRANS_IDENTICAL))
2211 newleft = mod(left, rtype);
2214 if (right->op_type == OP_TRANS)
2215 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2217 o = prepend_elem(rtype, scalar(newleft), right);
2219 return newUNOP(OP_NOT, 0, scalar(o));
2223 return bind_match(type, left,
2224 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2228 Perl_invert(pTHX_ OP *o)
2232 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2236 Perl_scope(pTHX_ OP *o)
2240 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2241 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2242 o->op_type = OP_LEAVE;
2243 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2245 else if (o->op_type == OP_LINESEQ) {
2247 o->op_type = OP_SCOPE;
2248 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2249 kid = ((LISTOP*)o)->op_first;
2250 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2253 /* The following deals with things like 'do {1 for 1}' */
2254 kid = kid->op_sibling;
2256 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2261 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2267 Perl_block_start(pTHX_ int full)
2270 const int retval = PL_savestack_ix;
2271 pad_block_start(full);
2273 PL_hints &= ~HINT_BLOCK_SCOPE;
2274 SAVECOMPILEWARNINGS();
2275 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2280 Perl_block_end(pTHX_ I32 floor, OP *seq)
2283 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2284 OP* const retval = scalarseq(seq);
2286 CopHINTS_set(&PL_compiling, PL_hints);
2288 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2297 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2298 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2299 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2302 OP * const o = newOP(OP_PADSV, 0);
2303 o->op_targ = offset;
2309 Perl_newPROG(pTHX_ OP *o)
2313 PERL_ARGS_ASSERT_NEWPROG;
2318 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2319 ((PL_in_eval & EVAL_KEEPERR)
2320 ? OPf_SPECIAL : 0), o);
2321 PL_eval_start = linklist(PL_eval_root);
2322 PL_eval_root->op_private |= OPpREFCOUNTED;
2323 OpREFCNT_set(PL_eval_root, 1);
2324 PL_eval_root->op_next = 0;
2325 CALL_PEEP(PL_eval_start);
2328 if (o->op_type == OP_STUB) {
2329 PL_comppad_name = 0;
2331 S_op_destroy(aTHX_ o);
2334 PL_main_root = scope(sawparens(scalarvoid(o)));
2335 PL_curcop = &PL_compiling;
2336 PL_main_start = LINKLIST(PL_main_root);
2337 PL_main_root->op_private |= OPpREFCOUNTED;
2338 OpREFCNT_set(PL_main_root, 1);
2339 PL_main_root->op_next = 0;
2340 CALL_PEEP(PL_main_start);
2343 /* Register with debugger */
2345 CV * const cv = get_cvs("DB::postponed", 0);
2349 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2351 call_sv(MUTABLE_SV(cv), G_DISCARD);
2358 Perl_localize(pTHX_ OP *o, I32 lex)
2362 PERL_ARGS_ASSERT_LOCALIZE;
2364 if (o->op_flags & OPf_PARENS)
2365 /* [perl #17376]: this appears to be premature, and results in code such as
2366 C< our(%x); > executing in list mode rather than void mode */
2373 if ( PL_parser->bufptr > PL_parser->oldbufptr
2374 && PL_parser->bufptr[-1] == ','
2375 && ckWARN(WARN_PARENTHESIS))
2377 char *s = PL_parser->bufptr;
2380 /* some heuristics to detect a potential error */
2381 while (*s && (strchr(", \t\n", *s)))
2385 if (*s && strchr("@$%*", *s) && *++s
2386 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2389 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2391 while (*s && (strchr(", \t\n", *s)))
2397 if (sigil && (*s == ';' || *s == '=')) {
2398 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2399 "Parentheses missing around \"%s\" list",
2401 ? (PL_parser->in_my == KEY_our
2403 : PL_parser->in_my == KEY_state
2413 o = mod(o, OP_NULL); /* a bit kludgey */
2414 PL_parser->in_my = FALSE;
2415 PL_parser->in_my_stash = NULL;
2420 Perl_jmaybe(pTHX_ OP *o)
2422 PERL_ARGS_ASSERT_JMAYBE;
2424 if (o->op_type == OP_LIST) {
2426 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2427 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2433 S_fold_constants(pTHX_ register OP *o)
2436 register OP * VOL curop;
2438 VOL I32 type = o->op_type;
2443 SV * const oldwarnhook = PL_warnhook;
2444 SV * const olddiehook = PL_diehook;
2448 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2450 if (PL_opargs[type] & OA_RETSCALAR)
2452 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2453 o->op_targ = pad_alloc(type, SVs_PADTMP);
2455 /* integerize op, unless it happens to be C<-foo>.
2456 * XXX should pp_i_negate() do magic string negation instead? */
2457 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2458 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2459 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2461 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2464 if (!(PL_opargs[type] & OA_FOLDCONST))
2469 /* XXX might want a ck_negate() for this */
2470 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2481 /* XXX what about the numeric ops? */
2482 if (PL_hints & HINT_LOCALE)
2487 if (PL_parser && PL_parser->error_count)
2488 goto nope; /* Don't try to run w/ errors */
2490 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2491 const OPCODE type = curop->op_type;
2492 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2494 type != OP_SCALAR &&
2496 type != OP_PUSHMARK)
2502 curop = LINKLIST(o);
2503 old_next = o->op_next;
2507 oldscope = PL_scopestack_ix;
2508 create_eval_scope(G_FAKINGEVAL);
2510 /* Verify that we don't need to save it: */
2511 assert(PL_curcop == &PL_compiling);
2512 StructCopy(&PL_compiling, ¬_compiling, COP);
2513 PL_curcop = ¬_compiling;
2514 /* The above ensures that we run with all the correct hints of the
2515 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2516 assert(IN_PERL_RUNTIME);
2517 PL_warnhook = PERL_WARNHOOK_FATAL;
2524 sv = *(PL_stack_sp--);
2525 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2526 pad_swipe(o->op_targ, FALSE);
2527 else if (SvTEMP(sv)) { /* grab mortal temp? */
2528 SvREFCNT_inc_simple_void(sv);
2533 /* Something tried to die. Abandon constant folding. */
2534 /* Pretend the error never happened. */
2536 o->op_next = old_next;
2540 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2541 PL_warnhook = oldwarnhook;
2542 PL_diehook = olddiehook;
2543 /* XXX note that this croak may fail as we've already blown away
2544 * the stack - eg any nested evals */
2545 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2548 PL_warnhook = oldwarnhook;
2549 PL_diehook = olddiehook;
2550 PL_curcop = &PL_compiling;
2552 if (PL_scopestack_ix > oldscope)
2553 delete_eval_scope();
2562 if (type == OP_RV2GV)
2563 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2565 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2566 op_getmad(o,newop,'f');
2574 S_gen_constant_list(pTHX_ register OP *o)
2578 const I32 oldtmps_floor = PL_tmps_floor;
2581 if (PL_parser && PL_parser->error_count)
2582 return o; /* Don't attempt to run with errors */
2584 PL_op = curop = LINKLIST(o);
2590 assert (!(curop->op_flags & OPf_SPECIAL));
2591 assert(curop->op_type == OP_RANGE);
2593 PL_tmps_floor = oldtmps_floor;
2595 o->op_type = OP_RV2AV;
2596 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2597 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2598 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2599 o->op_opt = 0; /* needs to be revisited in peep() */
2600 curop = ((UNOP*)o)->op_first;
2601 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2603 op_getmad(curop,o,'O');
2612 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2615 if (!o || o->op_type != OP_LIST)
2616 o = newLISTOP(OP_LIST, 0, o, NULL);
2618 o->op_flags &= ~OPf_WANT;
2620 if (!(PL_opargs[type] & OA_MARK))
2621 op_null(cLISTOPo->op_first);
2623 o->op_type = (OPCODE)type;
2624 o->op_ppaddr = PL_ppaddr[type];
2625 o->op_flags |= flags;
2627 o = CHECKOP(type, o);
2628 if (o->op_type != (unsigned)type)
2631 return fold_constants(o);
2634 /* List constructors */
2637 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2645 if (first->op_type != (unsigned)type
2646 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2648 return newLISTOP(type, 0, first, last);
2651 if (first->op_flags & OPf_KIDS)
2652 ((LISTOP*)first)->op_last->op_sibling = last;
2654 first->op_flags |= OPf_KIDS;
2655 ((LISTOP*)first)->op_first = last;
2657 ((LISTOP*)first)->op_last = last;
2662 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2670 if (first->op_type != (unsigned)type)
2671 return prepend_elem(type, (OP*)first, (OP*)last);
2673 if (last->op_type != (unsigned)type)
2674 return append_elem(type, (OP*)first, (OP*)last);
2676 first->op_last->op_sibling = last->op_first;
2677 first->op_last = last->op_last;
2678 first->op_flags |= (last->op_flags & OPf_KIDS);
2681 if (last->op_first && first->op_madprop) {
2682 MADPROP *mp = last->op_first->op_madprop;
2684 while (mp->mad_next)
2686 mp->mad_next = first->op_madprop;
2689 last->op_first->op_madprop = first->op_madprop;
2692 first->op_madprop = last->op_madprop;
2693 last->op_madprop = 0;
2696 S_op_destroy(aTHX_ (OP*)last);
2702 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2710 if (last->op_type == (unsigned)type) {
2711 if (type == OP_LIST) { /* already a PUSHMARK there */
2712 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2713 ((LISTOP*)last)->op_first->op_sibling = first;
2714 if (!(first->op_flags & OPf_PARENS))
2715 last->op_flags &= ~OPf_PARENS;
2718 if (!(last->op_flags & OPf_KIDS)) {
2719 ((LISTOP*)last)->op_last = first;
2720 last->op_flags |= OPf_KIDS;
2722 first->op_sibling = ((LISTOP*)last)->op_first;
2723 ((LISTOP*)last)->op_first = first;
2725 last->op_flags |= OPf_KIDS;
2729 return newLISTOP(type, 0, first, last);
2737 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2740 Newxz(tk, 1, TOKEN);
2741 tk->tk_type = (OPCODE)optype;
2742 tk->tk_type = 12345;
2744 tk->tk_mad = madprop;
2749 Perl_token_free(pTHX_ TOKEN* tk)
2751 PERL_ARGS_ASSERT_TOKEN_FREE;
2753 if (tk->tk_type != 12345)
2755 mad_free(tk->tk_mad);
2760 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2765 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2767 if (tk->tk_type != 12345) {
2768 Perl_warner(aTHX_ packWARN(WARN_MISC),
2769 "Invalid TOKEN object ignored");
2776 /* faked up qw list? */
2778 tm->mad_type == MAD_SV &&
2779 SvPVX((SV *)tm->mad_val)[0] == 'q')
2786 /* pretend constant fold didn't happen? */
2787 if (mp->mad_key == 'f' &&
2788 (o->op_type == OP_CONST ||
2789 o->op_type == OP_GV) )
2791 token_getmad(tk,(OP*)mp->mad_val,slot);
2805 if (mp->mad_key == 'X')
2806 mp->mad_key = slot; /* just change the first one */
2816 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2825 /* pretend constant fold didn't happen? */
2826 if (mp->mad_key == 'f' &&
2827 (o->op_type == OP_CONST ||
2828 o->op_type == OP_GV) )
2830 op_getmad(from,(OP*)mp->mad_val,slot);
2837 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2840 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2846 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2855 /* pretend constant fold didn't happen? */
2856 if (mp->mad_key == 'f' &&
2857 (o->op_type == OP_CONST ||
2858 o->op_type == OP_GV) )
2860 op_getmad(from,(OP*)mp->mad_val,slot);
2867 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2870 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2874 PerlIO_printf(PerlIO_stderr(),
2875 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2881 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2899 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2903 addmad(tm, &(o->op_madprop), slot);
2907 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2928 Perl_newMADsv(pTHX_ char key, SV* sv)
2930 PERL_ARGS_ASSERT_NEWMADSV;
2932 return newMADPROP(key, MAD_SV, sv, 0);
2936 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2939 Newxz(mp, 1, MADPROP);
2942 mp->mad_vlen = vlen;
2943 mp->mad_type = type;
2945 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2950 Perl_mad_free(pTHX_ MADPROP* mp)
2952 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2956 mad_free(mp->mad_next);
2957 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2958 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2959 switch (mp->mad_type) {
2963 Safefree((char*)mp->mad_val);
2966 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2967 op_free((OP*)mp->mad_val);
2970 sv_free(MUTABLE_SV(mp->mad_val));
2973 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2982 Perl_newNULLLIST(pTHX)
2984 return newOP(OP_STUB, 0);
2988 S_force_list(pTHX_ OP *o)
2990 if (!o || o->op_type != OP_LIST)
2991 o = newLISTOP(OP_LIST, 0, o, NULL);
2997 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3002 NewOp(1101, listop, 1, LISTOP);
3004 listop->op_type = (OPCODE)type;
3005 listop->op_ppaddr = PL_ppaddr[type];
3008 listop->op_flags = (U8)flags;
3012 else if (!first && last)
3015 first->op_sibling = last;
3016 listop->op_first = first;
3017 listop->op_last = last;
3018 if (type == OP_LIST) {
3019 OP* const pushop = newOP(OP_PUSHMARK, 0);
3020 pushop->op_sibling = first;
3021 listop->op_first = pushop;
3022 listop->op_flags |= OPf_KIDS;
3024 listop->op_last = pushop;
3027 return CHECKOP(type, listop);
3031 Perl_newOP(pTHX_ I32 type, I32 flags)
3035 NewOp(1101, o, 1, OP);
3036 o->op_type = (OPCODE)type;
3037 o->op_ppaddr = PL_ppaddr[type];
3038 o->op_flags = (U8)flags;
3040 o->op_latefreed = 0;
3044 o->op_private = (U8)(0 | (flags >> 8));
3045 if (PL_opargs[type] & OA_RETSCALAR)
3047 if (PL_opargs[type] & OA_TARGET)
3048 o->op_targ = pad_alloc(type, SVs_PADTMP);
3049 return CHECKOP(type, o);
3053 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3059 first = newOP(OP_STUB, 0);
3060 if (PL_opargs[type] & OA_MARK)
3061 first = force_list(first);
3063 NewOp(1101, unop, 1, UNOP);
3064 unop->op_type = (OPCODE)type;
3065 unop->op_ppaddr = PL_ppaddr[type];
3066 unop->op_first = first;
3067 unop->op_flags = (U8)(flags | OPf_KIDS);
3068 unop->op_private = (U8)(1 | (flags >> 8));
3069 unop = (UNOP*) CHECKOP(type, unop);
3073 return fold_constants((OP *) unop);
3077 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3081 NewOp(1101, binop, 1, BINOP);
3084 first = newOP(OP_NULL, 0);
3086 binop->op_type = (OPCODE)type;
3087 binop->op_ppaddr = PL_ppaddr[type];
3088 binop->op_first = first;
3089 binop->op_flags = (U8)(flags | OPf_KIDS);
3092 binop->op_private = (U8)(1 | (flags >> 8));
3095 binop->op_private = (U8)(2 | (flags >> 8));
3096 first->op_sibling = last;
3099 binop = (BINOP*)CHECKOP(type, binop);
3100 if (binop->op_next || binop->op_type != (OPCODE)type)
3103 binop->op_last = binop->op_first->op_sibling;
3105 return fold_constants((OP *)binop);
3108 static int uvcompare(const void *a, const void *b)
3109 __attribute__nonnull__(1)
3110 __attribute__nonnull__(2)
3111 __attribute__pure__;
3112 static int uvcompare(const void *a, const void *b)
3114 if (*((const UV *)a) < (*(const UV *)b))
3116 if (*((const UV *)a) > (*(const UV *)b))
3118 if (*((const UV *)a+1) < (*(const UV *)b+1))
3120 if (*((const UV *)a+1) > (*(const UV *)b+1))
3126 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3129 SV * const tstr = ((SVOP*)expr)->op_sv;
3132 (repl->op_type == OP_NULL)
3133 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3135 ((SVOP*)repl)->op_sv;
3138 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3139 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3143 register short *tbl;
3145 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3146 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3147 I32 del = o->op_private & OPpTRANS_DELETE;
3150 PERL_ARGS_ASSERT_PMTRANS;
3152 PL_hints |= HINT_BLOCK_SCOPE;
3155 o->op_private |= OPpTRANS_FROM_UTF;
3158 o->op_private |= OPpTRANS_TO_UTF;
3160 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3161 SV* const listsv = newSVpvs("# comment\n");
3163 const U8* tend = t + tlen;
3164 const U8* rend = r + rlen;
3178 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3179 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3182 const U32 flags = UTF8_ALLOW_DEFAULT;
3186 t = tsave = bytes_to_utf8(t, &len);
3189 if (!to_utf && rlen) {
3191 r = rsave = bytes_to_utf8(r, &len);
3195 /* There are several snags with this code on EBCDIC:
3196 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3197 2. scan_const() in toke.c has encoded chars in native encoding which makes
3198 ranges at least in EBCDIC 0..255 range the bottom odd.
3202 U8 tmpbuf[UTF8_MAXBYTES+1];
3205 Newx(cp, 2*tlen, UV);
3207 transv = newSVpvs("");
3209 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3211 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3213 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3217 cp[2*i+1] = cp[2*i];
3221 qsort(cp, i, 2*sizeof(UV), uvcompare);
3222 for (j = 0; j < i; j++) {
3224 diff = val - nextmin;
3226 t = uvuni_to_utf8(tmpbuf,nextmin);
3227 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3229 U8 range_mark = UTF_TO_NATIVE(0xff);
3230 t = uvuni_to_utf8(tmpbuf, val - 1);
3231 sv_catpvn(transv, (char *)&range_mark, 1);
3232 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3239 t = uvuni_to_utf8(tmpbuf,nextmin);
3240 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3242 U8 range_mark = UTF_TO_NATIVE(0xff);
3243 sv_catpvn(transv, (char *)&range_mark, 1);
3245 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3246 UNICODE_ALLOW_SUPER);
3247 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3248 t = (const U8*)SvPVX_const(transv);
3249 tlen = SvCUR(transv);
3253 else if (!rlen && !del) {
3254 r = t; rlen = tlen; rend = tend;
3257 if ((!rlen && !del) || t == r ||
3258 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3260 o->op_private |= OPpTRANS_IDENTICAL;
3264 while (t < tend || tfirst <= tlast) {
3265 /* see if we need more "t" chars */
3266 if (tfirst > tlast) {
3267 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3269 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3271 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3278 /* now see if we need more "r" chars */
3279 if (rfirst > rlast) {
3281 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3283 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3285 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3294 rfirst = rlast = 0xffffffff;
3298 /* now see which range will peter our first, if either. */
3299 tdiff = tlast - tfirst;
3300 rdiff = rlast - rfirst;
3307 if (rfirst == 0xffffffff) {
3308 diff = tdiff; /* oops, pretend rdiff is infinite */
3310 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3311 (long)tfirst, (long)tlast);
3313 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3317 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3318 (long)tfirst, (long)(tfirst + diff),
3321 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3322 (long)tfirst, (long)rfirst);
3324 if (rfirst + diff > max)
3325 max = rfirst + diff;
3327 grows = (tfirst < rfirst &&
3328 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3340 else if (max > 0xff)
3345 PerlMemShared_free(cPVOPo->op_pv);
3346 cPVOPo->op_pv = NULL;
3348 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3350 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3351 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3352 PAD_SETSV(cPADOPo->op_padix, swash);
3354 SvREADONLY_on(swash);
3356 cSVOPo->op_sv = swash;
3358 SvREFCNT_dec(listsv);
3359 SvREFCNT_dec(transv);
3361 if (!del && havefinal && rlen)
3362 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3363 newSVuv((UV)final), 0);
3366 o->op_private |= OPpTRANS_GROWS;
3372 op_getmad(expr,o,'e');
3373 op_getmad(repl,o,'r');
3381 tbl = (short*)cPVOPo->op_pv;
3383 Zero(tbl, 256, short);
3384 for (i = 0; i < (I32)tlen; i++)
3386 for (i = 0, j = 0; i < 256; i++) {
3388 if (j >= (I32)rlen) {
3397 if (i < 128 && r[j] >= 128)
3407 o->op_private |= OPpTRANS_IDENTICAL;
3409 else if (j >= (I32)rlen)
3414 PerlMemShared_realloc(tbl,
3415 (0x101+rlen-j) * sizeof(short));
3416 cPVOPo->op_pv = (char*)tbl;
3418 tbl[0x100] = (short)(rlen - j);
3419 for (i=0; i < (I32)rlen - j; i++)
3420 tbl[0x101+i] = r[j+i];
3424 if (!rlen && !del) {
3427 o->op_private |= OPpTRANS_IDENTICAL;
3429 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3430 o->op_private |= OPpTRANS_IDENTICAL;
3432 for (i = 0; i < 256; i++)
3434 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3435 if (j >= (I32)rlen) {
3437 if (tbl[t[i]] == -1)
3443 if (tbl[t[i]] == -1) {
3444 if (t[i] < 128 && r[j] >= 128)
3451 if(del && rlen == tlen) {
3452 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3453 } else if(rlen > tlen) {
3454 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3458 o->op_private |= OPpTRANS_GROWS;
3460 op_getmad(expr,o,'e');
3461 op_getmad(repl,o,'r');
3471 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3476 NewOp(1101, pmop, 1, PMOP);
3477 pmop->op_type = (OPCODE)type;
3478 pmop->op_ppaddr = PL_ppaddr[type];
3479 pmop->op_flags = (U8)flags;
3480 pmop->op_private = (U8)(0 | (flags >> 8));
3482 if (PL_hints & HINT_RE_TAINT)
3483 pmop->op_pmflags |= PMf_RETAINT;
3484 if (PL_hints & HINT_LOCALE)
3485 pmop->op_pmflags |= PMf_LOCALE;
3489 assert(SvPOK(PL_regex_pad[0]));
3490 if (SvCUR(PL_regex_pad[0])) {
3491 /* Pop off the "packed" IV from the end. */
3492 SV *const repointer_list = PL_regex_pad[0];
3493 const char *p = SvEND(repointer_list) - sizeof(IV);
3494 const IV offset = *((IV*)p);
3496 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3498 SvEND_set(repointer_list, p);
3500 pmop->op_pmoffset = offset;
3501 /* This slot should be free, so assert this: */
3502 assert(PL_regex_pad[offset] == &PL_sv_undef);
3504 SV * const repointer = &PL_sv_undef;
3505 av_push(PL_regex_padav, repointer);
3506 pmop->op_pmoffset = av_len(PL_regex_padav);
3507 PL_regex_pad = AvARRAY(PL_regex_padav);
3511 return CHECKOP(type, pmop);
3514 /* Given some sort of match op o, and an expression expr containing a
3515 * pattern, either compile expr into a regex and attach it to o (if it's
3516 * constant), or convert expr into a runtime regcomp op sequence (if it's
3519 * isreg indicates that the pattern is part of a regex construct, eg
3520 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3521 * split "pattern", which aren't. In the former case, expr will be a list
3522 * if the pattern contains more than one term (eg /a$b/) or if it contains
3523 * a replacement, ie s/// or tr///.
3527 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3532 I32 repl_has_vars = 0;
3536 PERL_ARGS_ASSERT_PMRUNTIME;
3538 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3539 /* last element in list is the replacement; pop it */
3541 repl = cLISTOPx(expr)->op_last;
3542 kid = cLISTOPx(expr)->op_first;
3543 while (kid->op_sibling != repl)
3544 kid = kid->op_sibling;
3545 kid->op_sibling = NULL;
3546 cLISTOPx(expr)->op_last = kid;
3549 if (isreg && expr->op_type == OP_LIST &&
3550 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3552 /* convert single element list to element */
3553 OP* const oe = expr;
3554 expr = cLISTOPx(oe)->op_first->op_sibling;
3555 cLISTOPx(oe)->op_first->op_sibling = NULL;
3556 cLISTOPx(oe)->op_last = NULL;
3560 if (o->op_type == OP_TRANS) {
3561 return pmtrans(o, expr, repl);
3564 reglist = isreg && expr->op_type == OP_LIST;
3568 PL_hints |= HINT_BLOCK_SCOPE;
3571 if (expr->op_type == OP_CONST) {
3572 SV *pat = ((SVOP*)expr)->op_sv;
3573 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3575 if (o->op_flags & OPf_SPECIAL)
3576 pm_flags |= RXf_SPLIT;
3579 assert (SvUTF8(pat));
3580 } else if (SvUTF8(pat)) {
3581 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3582 trapped in use 'bytes'? */
3583 /* Make a copy of the octet sequence, but without the flag on, as
3584 the compiler now honours the SvUTF8 flag on pat. */
3586 const char *const p = SvPV(pat, len);
3587 pat = newSVpvn_flags(p, len, SVs_TEMP);
3590 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3593 op_getmad(expr,(OP*)pm,'e');
3599 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3600 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3602 : OP_REGCMAYBE),0,expr);
3604 NewOp(1101, rcop, 1, LOGOP);
3605 rcop->op_type = OP_REGCOMP;
3606 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3607 rcop->op_first = scalar(expr);
3608 rcop->op_flags |= OPf_KIDS
3609 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3610 | (reglist ? OPf_STACKED : 0);
3611 rcop->op_private = 1;
3614 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3616 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3619 /* establish postfix order */
3620 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3622 rcop->op_next = expr;
3623 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3626 rcop->op_next = LINKLIST(expr);
3627 expr->op_next = (OP*)rcop;
3630 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3635 if (pm->op_pmflags & PMf_EVAL) {
3637 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3638 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3640 else if (repl->op_type == OP_CONST)
3644 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3645 if (curop->op_type == OP_SCOPE
3646 || curop->op_type == OP_LEAVE
3647 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3648 if (curop->op_type == OP_GV) {
3649 GV * const gv = cGVOPx_gv(curop);
3651 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3654 else if (curop->op_type == OP_RV2CV)
3656 else if (curop->op_type == OP_RV2SV ||
3657 curop->op_type == OP_RV2AV ||
3658 curop->op_type == OP_RV2HV ||
3659 curop->op_type == OP_RV2GV) {
3660 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3663 else if (curop->op_type == OP_PADSV ||
3664 curop->op_type == OP_PADAV ||
3665 curop->op_type == OP_PADHV ||
3666 curop->op_type == OP_PADANY)
3670 else if (curop->op_type == OP_PUSHRE)
3671 NOOP; /* Okay here, dangerous in newASSIGNOP */
3681 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3683 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3684 prepend_elem(o->op_type, scalar(repl), o);
3687 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3688 pm->op_pmflags |= PMf_MAYBE_CONST;
3690 NewOp(1101, rcop, 1, LOGOP);
3691 rcop->op_type = OP_SUBSTCONT;
3692 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3693 rcop->op_first = scalar(repl);
3694 rcop->op_flags |= OPf_KIDS;
3695 rcop->op_private = 1;
3698 /* establish postfix order */
3699 rcop->op_next = LINKLIST(repl);
3700 repl->op_next = (OP*)rcop;
3702 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3703 assert(!(pm->op_pmflags & PMf_ONCE));
3704 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3713 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3718 PERL_ARGS_ASSERT_NEWSVOP;
3720 NewOp(1101, svop, 1, SVOP);
3721 svop->op_type = (OPCODE)type;
3722 svop->op_ppaddr = PL_ppaddr[type];
3724 svop->op_next = (OP*)svop;
3725 svop->op_flags = (U8)flags;
3726 if (PL_opargs[type] & OA_RETSCALAR)
3728 if (PL_opargs[type] & OA_TARGET)
3729 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3730 return CHECKOP(type, svop);
3735 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3740 PERL_ARGS_ASSERT_NEWPADOP;
3742 NewOp(1101, padop, 1, PADOP);
3743 padop->op_type = (OPCODE)type;
3744 padop->op_ppaddr = PL_ppaddr[type];
3745 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3746 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3747 PAD_SETSV(padop->op_padix, sv);
3750 padop->op_next = (OP*)padop;
3751 padop->op_flags = (U8)flags;
3752 if (PL_opargs[type] & OA_RETSCALAR)
3754 if (PL_opargs[type] & OA_TARGET)
3755 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3756 return CHECKOP(type, padop);
3761 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3765 PERL_ARGS_ASSERT_NEWGVOP;
3769 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3771 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3776 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3780 NewOp(1101, pvop, 1, PVOP);
3781 pvop->op_type = (OPCODE)type;
3782 pvop->op_ppaddr = PL_ppaddr[type];
3784 pvop->op_next = (OP*)pvop;
3785 pvop->op_flags = (U8)flags;
3786 if (PL_opargs[type] & OA_RETSCALAR)
3788 if (PL_opargs[type] & OA_TARGET)
3789 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3790 return CHECKOP(type, pvop);
3798 Perl_package(pTHX_ OP *o)
3801 SV *const sv = cSVOPo->op_sv;
3806 PERL_ARGS_ASSERT_PACKAGE;
3808 save_hptr(&PL_curstash);
3809 save_item(PL_curstname);
3811 PL_curstash = gv_stashsv(sv, GV_ADD);
3813 sv_setsv(PL_curstname, sv);
3815 PL_hints |= HINT_BLOCK_SCOPE;
3816 PL_parser->copline = NOLINE;
3817 PL_parser->expect = XSTATE;
3822 if (!PL_madskills) {
3827 pegop = newOP(OP_NULL,0);
3828 op_getmad(o,pegop,'P');
3834 Perl_package_version( pTHX_ OP *v )
3837 U32 savehints = PL_hints;
3838 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3839 PL_hints &= ~HINT_STRICT_VARS;
3840 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3841 PL_hints = savehints;
3850 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3857 OP *pegop = newOP(OP_NULL,0);
3860 PERL_ARGS_ASSERT_UTILIZE;
3862 if (idop->op_type != OP_CONST)
3863 Perl_croak(aTHX_ "Module name must be constant");
3866 op_getmad(idop,pegop,'U');
3871 SV * const vesv = ((SVOP*)version)->op_sv;
3874 op_getmad(version,pegop,'V');
3875 if (!arg && !SvNIOKp(vesv)) {
3882 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3883 Perl_croak(aTHX_ "Version number must be a constant number");
3885 /* Make copy of idop so we don't free it twice */
3886 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3888 /* Fake up a method call to VERSION */
3889 meth = newSVpvs_share("VERSION");
3890 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3891 append_elem(OP_LIST,
3892 prepend_elem(OP_LIST, pack, list(version)),
3893 newSVOP(OP_METHOD_NAMED, 0, meth)));
3897 /* Fake up an import/unimport */
3898 if (arg && arg->op_type == OP_STUB) {
3900 op_getmad(arg,pegop,'S');
3901 imop = arg; /* no import on explicit () */
3903 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3904 imop = NULL; /* use 5.0; */
3906 idop->op_private |= OPpCONST_NOVER;
3912 op_getmad(arg,pegop,'A');
3914 /* Make copy of idop so we don't free it twice */
3915 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3917 /* Fake up a method call to import/unimport */
3919 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3920 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3921 append_elem(OP_LIST,
3922 prepend_elem(OP_LIST, pack, list(arg)),
3923 newSVOP(OP_METHOD_NAMED, 0, meth)));
3926 /* Fake up the BEGIN {}, which does its thing immediately. */
3928 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3931 append_elem(OP_LINESEQ,
3932 append_elem(OP_LINESEQ,
3933 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3934 newSTATEOP(0, NULL, veop)),
3935 newSTATEOP(0, NULL, imop) ));
3937 /* The "did you use incorrect case?" warning used to be here.
3938 * The problem is that on case-insensitive filesystems one
3939 * might get false positives for "use" (and "require"):
3940 * "use Strict" or "require CARP" will work. This causes
3941 * portability problems for the script: in case-strict
3942 * filesystems the script will stop working.
3944 * The "incorrect case" warning checked whether "use Foo"
3945 * imported "Foo" to your namespace, but that is wrong, too:
3946 * there is no requirement nor promise in the language that
3947 * a Foo.pm should or would contain anything in package "Foo".
3949 * There is very little Configure-wise that can be done, either:
3950 * the case-sensitivity of the build filesystem of Perl does not
3951 * help in guessing the case-sensitivity of the runtime environment.
3954 PL_hints |= HINT_BLOCK_SCOPE;
3955 PL_parser->copline = NOLINE;
3956 PL_parser->expect = XSTATE;
3957 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3960 if (!PL_madskills) {
3961 /* FIXME - don't allocate pegop if !PL_madskills */
3970 =head1 Embedding Functions
3972 =for apidoc load_module
3974 Loads the module whose name is pointed to by the string part of name.
3975 Note that the actual module name, not its filename, should be given.
3976 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3977 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3978 (or 0 for no flags). ver, if specified, provides version semantics
3979 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3980 arguments can be used to specify arguments to the module's import()
3981 method, similar to C<use Foo::Bar VERSION LIST>. They must be
3982 terminated with a final NULL pointer. Note that this list can only
3983 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
3984 Otherwise at least a single NULL pointer to designate the default
3985 import list is required.
3990 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3994 PERL_ARGS_ASSERT_LOAD_MODULE;
3996 va_start(args, ver);
3997 vload_module(flags, name, ver, &args);
4001 #ifdef PERL_IMPLICIT_CONTEXT
4003 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4007 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4008 va_start(args, ver);
4009 vload_module(flags, name, ver, &args);
4015 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4019 OP * const modname = newSVOP(OP_CONST, 0, name);
4021 PERL_ARGS_ASSERT_VLOAD_MODULE;
4023 modname->op_private |= OPpCONST_BARE;
4025 veop = newSVOP(OP_CONST, 0, ver);
4029 if (flags & PERL_LOADMOD_NOIMPORT) {
4030 imop = sawparens(newNULLLIST());
4032 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4033 imop = va_arg(*args, OP*);
4038 sv = va_arg(*args, SV*);
4040 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4041 sv = va_arg(*args, SV*);
4045 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4046 * that it has a PL_parser to play with while doing that, and also
4047 * that it doesn't mess with any existing parser, by creating a tmp
4048 * new parser with lex_start(). This won't actually be used for much,
4049 * since pp_require() will create another parser for the real work. */
4052 SAVEVPTR(PL_curcop);
4053 lex_start(NULL, NULL, FALSE);
4054 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4055 veop, modname, imop);
4060 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4066 PERL_ARGS_ASSERT_DOFILE;
4068 if (!force_builtin) {
4069 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4070 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4071 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4072 gv = gvp ? *gvp : NULL;
4076 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4077 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4078 append_elem(OP_LIST, term,
4079 scalar(newUNOP(OP_RV2CV, 0,
4080 newGVOP(OP_GV, 0, gv))))));
4083 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4089 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4091 return newBINOP(OP_LSLICE, flags,
4092 list(force_list(subscript)),
4093 list(force_list(listval)) );
4097 S_is_list_assignment(pTHX_ register const OP *o)
4105 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4106 o = cUNOPo->op_first;
4108 flags = o->op_flags;
4110 if (type == OP_COND_EXPR) {
4111 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4112 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4117 yyerror("Assignment to both a list and a scalar");
4121 if (type == OP_LIST &&
4122 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4123 o->op_private & OPpLVAL_INTRO)
4126 if (type == OP_LIST || flags & OPf_PARENS ||
4127 type == OP_RV2AV || type == OP_RV2HV ||
4128 type == OP_ASLICE || type == OP_HSLICE)
4131 if (type == OP_PADAV || type == OP_PADHV)
4134 if (type == OP_RV2SV)
4141 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4147 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4148 return newLOGOP(optype, 0,
4149 mod(scalar(left), optype),
4150 newUNOP(OP_SASSIGN, 0, scalar(right)));
4153 return newBINOP(optype, OPf_STACKED,
4154 mod(scalar(left), optype), scalar(right));
4158 if (is_list_assignment(left)) {
4159 static const char no_list_state[] = "Initialization of state variables"
4160 " in list context currently forbidden";
4162 bool maybe_common_vars = TRUE;
4165 /* Grandfathering $[ assignment here. Bletch.*/
4166 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4167 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4168 left = mod(left, OP_AASSIGN);
4171 else if (left->op_type == OP_CONST) {
4173 /* Result of assignment is always 1 (or we'd be dead already) */
4174 return newSVOP(OP_CONST, 0, newSViv(1));
4176 curop = list(force_list(left));
4177 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4178 o->op_private = (U8)(0 | (flags >> 8));
4180 if ((left->op_type == OP_LIST
4181 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4183 OP* lop = ((LISTOP*)left)->op_first;
4184 maybe_common_vars = FALSE;
4186 if (lop->op_type == OP_PADSV ||
4187 lop->op_type == OP_PADAV ||
4188 lop->op_type == OP_PADHV ||
4189 lop->op_type == OP_PADANY) {
4190 if (!(lop->op_private & OPpLVAL_INTRO))
4191 maybe_common_vars = TRUE;
4193 if (lop->op_private & OPpPAD_STATE) {
4194 if (left->op_private & OPpLVAL_INTRO) {
4195 /* Each variable in state($a, $b, $c) = ... */
4198 /* Each state variable in
4199 (state $a, my $b, our $c, $d, undef) = ... */
4201 yyerror(no_list_state);
4203 /* Each my variable in
4204 (state $a, my $b, our $c, $d, undef) = ... */
4206 } else if (lop->op_type == OP_UNDEF ||
4207 lop->op_type == OP_PUSHMARK) {
4208 /* undef may be interesting in
4209 (state $a, undef, state $c) */
4211 /* Other ops in the list. */
4212 maybe_common_vars = TRUE;
4214 lop = lop->op_sibling;
4217 else if ((left->op_private & OPpLVAL_INTRO)
4218 && ( left->op_type == OP_PADSV
4219 || left->op_type == OP_PADAV
4220 || left->op_type == OP_PADHV
4221 || left->op_type == OP_PADANY))
4223 maybe_common_vars = FALSE;
4224 if (left->op_private & OPpPAD_STATE) {
4225 /* All single variable list context state assignments, hence
4235 yyerror(no_list_state);
4239 /* PL_generation sorcery:
4240 * an assignment like ($a,$b) = ($c,$d) is easier than
4241 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4242 * To detect whether there are common vars, the global var
4243 * PL_generation is incremented for each assign op we compile.
4244 * Then, while compiling the assign op, we run through all the
4245 * variables on both sides of the assignment, setting a spare slot
4246 * in each of them to PL_generation. If any of them already have
4247 * that value, we know we've got commonality. We could use a
4248 * single bit marker, but then we'd have to make 2 passes, first
4249 * to clear the flag, then to test and set it. To find somewhere
4250 * to store these values, evil chicanery is done with SvUVX().
4253 if (maybe_common_vars) {
4256 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4257 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4258 if (curop->op_type == OP_GV) {
4259 GV *gv = cGVOPx_gv(curop);
4261 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4263 GvASSIGN_GENERATION_set(gv, PL_generation);
4265 else if (curop->op_type == OP_PADSV ||
4266 curop->op_type == OP_PADAV ||
4267 curop->op_type == OP_PADHV ||
4268 curop->op_type == OP_PADANY)
4270 if (PAD_COMPNAME_GEN(curop->op_targ)
4271 == (STRLEN)PL_generation)
4273 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4276 else if (curop->op_type == OP_RV2CV)
4278 else if (curop->op_type == OP_RV2SV ||
4279 curop->op_type == OP_RV2AV ||
4280 curop->op_type == OP_RV2HV ||
4281 curop->op_type == OP_RV2GV) {
4282 if (lastop->op_type != OP_GV) /* funny deref? */
4285 else if (curop->op_type == OP_PUSHRE) {
4287 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4288 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4290 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4292 GvASSIGN_GENERATION_set(gv, PL_generation);
4296 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4299 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4301 GvASSIGN_GENERATION_set(gv, PL_generation);
4311 o->op_private |= OPpASSIGN_COMMON;
4314 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4315 OP* tmpop = ((LISTOP*)right)->op_first;
4316 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4317 PMOP * const pm = (PMOP*)tmpop;
4318 if (left->op_type == OP_RV2AV &&
4319 !(left->op_private & OPpLVAL_INTRO) &&
4320 !(o->op_private & OPpASSIGN_COMMON) )
4322 tmpop = ((UNOP*)left)->op_first;
4323 if (tmpop->op_type == OP_GV
4325 && !pm->op_pmreplrootu.op_pmtargetoff
4327 && !pm->op_pmreplrootu.op_pmtargetgv
4331 pm->op_pmreplrootu.op_pmtargetoff
4332 = cPADOPx(tmpop)->op_padix;
4333 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4335 pm->op_pmreplrootu.op_pmtargetgv
4336 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4337 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4339 pm->op_pmflags |= PMf_ONCE;
4340 tmpop = cUNOPo->op_first; /* to list (nulled) */
4341 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4342 tmpop->op_sibling = NULL; /* don't free split */
4343 right->op_next = tmpop->op_next; /* fix starting loc */
4344 op_free(o); /* blow off assign */
4345 right->op_flags &= ~OPf_WANT;
4346 /* "I don't know and I don't care." */
4351 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4352 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4354 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4355 if (SvIOK(sv) && SvIVX(sv) == 0)
4356 sv_setiv(sv, PL_modcount+1);
4364 right = newOP(OP_UNDEF, 0);
4365 if (right->op_type == OP_READLINE) {
4366 right->op_flags |= OPf_STACKED;
4367 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4370 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4371 o = newBINOP(OP_SASSIGN, flags,
4372 scalar(right), mod(scalar(left), OP_SASSIGN) );
4376 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4377 deprecate("assignment to $[");
4379 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4380 o->op_private |= OPpCONST_ARYBASE;
4388 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4391 const U32 seq = intro_my();
4394 NewOp(1101, cop, 1, COP);
4395 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4396 cop->op_type = OP_DBSTATE;
4397 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4400 cop->op_type = OP_NEXTSTATE;
4401 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4403 cop->op_flags = (U8)flags;
4404 CopHINTS_set(cop, PL_hints);
4406 cop->op_private |= NATIVE_HINTS;
4408 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4409 cop->op_next = (OP*)cop;
4412 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4413 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4415 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4416 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4417 if (cop->cop_hints_hash) {
4419 cop->cop_hints_hash->refcounted_he_refcnt++;
4420 HINTS_REFCNT_UNLOCK;
4424 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4426 PL_hints |= HINT_BLOCK_SCOPE;
4427 /* It seems that we need to defer freeing this pointer, as other parts
4428 of the grammar end up wanting to copy it after this op has been
4433 if (PL_parser && PL_parser->copline == NOLINE)
4434 CopLINE_set(cop, CopLINE(PL_curcop));
4436 CopLINE_set(cop, PL_parser->copline);
4438 PL_parser->copline = NOLINE;
4441 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4443 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4445 CopSTASH_set(cop, PL_curstash);
4447 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4448 /* this line can have a breakpoint - store the cop in IV */
4449 AV *av = CopFILEAVx(PL_curcop);
4451 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4452 if (svp && *svp != &PL_sv_undef ) {
4453 (void)SvIOK_on(*svp);
4454 SvIV_set(*svp, PTR2IV(cop));
4459 if (flags & OPf_SPECIAL)
4461 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4466 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4470 PERL_ARGS_ASSERT_NEWLOGOP;
4472 return new_logop(type, flags, &first, &other);
4476 S_search_const(pTHX_ OP *o)
4478 PERL_ARGS_ASSERT_SEARCH_CONST;
4480 switch (o->op_type) {
4484 if (o->op_flags & OPf_KIDS)
4485 return search_const(cUNOPo->op_first);
4492 if (!(o->op_flags & OPf_KIDS))
4494 kid = cLISTOPo->op_first;
4496 switch (kid->op_type) {
4500 kid = kid->op_sibling;
4503 if (kid != cLISTOPo->op_last)
4509 kid = cLISTOPo->op_last;
4511 return search_const(kid);
4519 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4527 int prepend_not = 0;
4529 PERL_ARGS_ASSERT_NEW_LOGOP;
4534 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4535 return newBINOP(type, flags, scalar(first), scalar(other));
4537 scalarboolean(first);
4538 /* optimize AND and OR ops that have NOTs as children */
4539 if (first->op_type == OP_NOT
4540 && (first->op_flags & OPf_KIDS)
4541 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4542 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4544 if (type == OP_AND || type == OP_OR) {
4550 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4552 prepend_not = 1; /* prepend a NOT op later */
4556 /* search for a constant op that could let us fold the test */
4557 if ((cstop = search_const(first))) {
4558 if (cstop->op_private & OPpCONST_STRICT)
4559 no_bareword_allowed(cstop);
4560 else if ((cstop->op_private & OPpCONST_BARE))
4561 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4562 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4563 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4564 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4566 if (other->op_type == OP_CONST)
4567 other->op_private |= OPpCONST_SHORTCIRCUIT;
4569 OP *newop = newUNOP(OP_NULL, 0, other);
4570 op_getmad(first, newop, '1');
4571 newop->op_targ = type; /* set "was" field */
4575 if (other->op_type == OP_LEAVE)
4576 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4580 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4581 const OP *o2 = other;
4582 if ( ! (o2->op_type == OP_LIST
4583 && (( o2 = cUNOPx(o2)->op_first))
4584 && o2->op_type == OP_PUSHMARK
4585 && (( o2 = o2->op_sibling)) )
4588 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4589 || o2->op_type == OP_PADHV)
4590 && o2->op_private & OPpLVAL_INTRO
4591 && !(o2->op_private & OPpPAD_STATE))
4593 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4594 "Deprecated use of my() in false conditional");
4598 if (first->op_type == OP_CONST)
4599 first->op_private |= OPpCONST_SHORTCIRCUIT;
4601 first = newUNOP(OP_NULL, 0, first);
4602 op_getmad(other, first, '2');
4603 first->op_targ = type; /* set "was" field */
4610 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4611 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4613 const OP * const k1 = ((UNOP*)first)->op_first;
4614 const OP * const k2 = k1->op_sibling;
4616 switch (first->op_type)
4619 if (k2 && k2->op_type == OP_READLINE
4620 && (k2->op_flags & OPf_STACKED)
4621 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4623 warnop = k2->op_type;
4628 if (k1->op_type == OP_READDIR
4629 || k1->op_type == OP_GLOB
4630 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4631 || k1->op_type == OP_EACH)
4633 warnop = ((k1->op_type == OP_NULL)
4634 ? (OPCODE)k1->op_targ : k1->op_type);
4639 const line_t oldline = CopLINE(PL_curcop);
4640 CopLINE_set(PL_curcop, PL_parser->copline);
4641 Perl_warner(aTHX_ packWARN(WARN_MISC),
4642 "Value of %s%s can be \"0\"; test with defined()",
4644 ((warnop == OP_READLINE || warnop == OP_GLOB)
4645 ? " construct" : "() operator"));
4646 CopLINE_set(PL_curcop, oldline);
4653 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4654 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4656 NewOp(1101, logop, 1, LOGOP);
4658 logop->op_type = (OPCODE)type;
4659 logop->op_ppaddr = PL_ppaddr[type];
4660 logop->op_first = first;
4661 logop->op_flags = (U8)(flags | OPf_KIDS);
4662 logop->op_other = LINKLIST(other);
4663 logop->op_private = (U8)(1 | (flags >> 8));
4665 /* establish postfix order */
4666 logop->op_next = LINKLIST(first);
4667 first->op_next = (OP*)logop;
4668 first->op_sibling = other;
4670 CHECKOP(type,logop);
4672 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4679 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4687 PERL_ARGS_ASSERT_NEWCONDOP;
4690 return newLOGOP(OP_AND, 0, first, trueop);
4692 return newLOGOP(OP_OR, 0, first, falseop);
4694 scalarboolean(first);
4695 if ((cstop = search_const(first))) {
4696 /* Left or right arm of the conditional? */
4697 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4698 OP *live = left ? trueop : falseop;
4699 OP *const dead = left ? falseop : trueop;
4700 if (cstop->op_private & OPpCONST_BARE &&
4701 cstop->op_private & OPpCONST_STRICT) {
4702 no_bareword_allowed(cstop);
4705 /* This is all dead code when PERL_MAD is not defined. */
4706 live = newUNOP(OP_NULL, 0, live);
4707 op_getmad(first, live, 'C');
4708 op_getmad(dead, live, left ? 'e' : 't');
4713 if (live->op_type == OP_LEAVE)
4714 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4717 NewOp(1101, logop, 1, LOGOP);
4718 logop->op_type = OP_COND_EXPR;
4719 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4720 logop->op_first = first;
4721 logop->op_flags = (U8)(flags | OPf_KIDS);
4722 logop->op_private = (U8)(1 | (flags >> 8));
4723 logop->op_other = LINKLIST(trueop);
4724 logop->op_next = LINKLIST(falseop);
4726 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4729 /* establish postfix order */
4730 start = LINKLIST(first);
4731 first->op_next = (OP*)logop;
4733 first->op_sibling = trueop;
4734 trueop->op_sibling = falseop;
4735 o = newUNOP(OP_NULL, 0, (OP*)logop);
4737 trueop->op_next = falseop->op_next = o;
4744 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4753 PERL_ARGS_ASSERT_NEWRANGE;
4755 NewOp(1101, range, 1, LOGOP);
4757 range->op_type = OP_RANGE;
4758 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4759 range->op_first = left;
4760 range->op_flags = OPf_KIDS;
4761 leftstart = LINKLIST(left);
4762 range->op_other = LINKLIST(right);
4763 range->op_private = (U8)(1 | (flags >> 8));
4765 left->op_sibling = right;
4767 range->op_next = (OP*)range;
4768 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4769 flop = newUNOP(OP_FLOP, 0, flip);
4770 o = newUNOP(OP_NULL, 0, flop);
4772 range->op_next = leftstart;
4774 left->op_next = flip;
4775 right->op_next = flop;
4777 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4778 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4779 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4780 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4782 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4783 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4786 if (!flip->op_private || !flop->op_private)
4787 linklist(o); /* blow off optimizer unless constant */
4793 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4798 const bool once = block && block->op_flags & OPf_SPECIAL &&
4799 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4801 PERL_UNUSED_ARG(debuggable);
4804 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4805 return block; /* do {} while 0 does once */
4806 if (expr->op_type == OP_READLINE
4807 || expr->op_type == OP_READDIR
4808 || expr->op_type == OP_GLOB
4809 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4810 expr = newUNOP(OP_DEFINED, 0,
4811 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4812 } else if (expr->op_flags & OPf_KIDS) {
4813 const OP * const k1 = ((UNOP*)expr)->op_first;
4814 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4815 switch (expr->op_type) {
4817 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4818 && (k2->op_flags & OPf_STACKED)
4819 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4820 expr = newUNOP(OP_DEFINED, 0, expr);
4824 if (k1 && (k1->op_type == OP_READDIR
4825 || k1->op_type == OP_GLOB
4826 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4827 || k1->op_type == OP_EACH))
4828 expr = newUNOP(OP_DEFINED, 0, expr);
4834 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4835 * op, in listop. This is wrong. [perl #27024] */
4837 block = newOP(OP_NULL, 0);
4838 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4839 o = new_logop(OP_AND, 0, &expr, &listop);
4842 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4844 if (once && o != listop)
4845 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4848 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4850 o->op_flags |= flags;
4852 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4857 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4858 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4867 PERL_UNUSED_ARG(debuggable);
4870 if (expr->op_type == OP_READLINE
4871 || expr->op_type == OP_READDIR
4872 || expr->op_type == OP_GLOB
4873 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4874 expr = newUNOP(OP_DEFINED, 0,
4875 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4876 } else if (expr->op_flags & OPf_KIDS) {
4877 const OP * const k1 = ((UNOP*)expr)->op_first;
4878 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4879 switch (expr->op_type) {
4881 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4882 && (k2->op_flags & OPf_STACKED)
4883 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4884 expr = newUNOP(OP_DEFINED, 0, expr);
4888 if (k1 && (k1->op_type == OP_READDIR
4889 || k1->op_type == OP_GLOB
4890 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4891 || k1->op_type == OP_EACH))
4892 expr = newUNOP(OP_DEFINED, 0, expr);
4899 block = newOP(OP_NULL, 0);
4900 else if (cont || has_my) {
4901 block = scope(block);
4905 next = LINKLIST(cont);
4908 OP * const unstack = newOP(OP_UNSTACK, 0);
4911 cont = append_elem(OP_LINESEQ, cont, unstack);
4915 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4917 redo = LINKLIST(listop);
4920 PL_parser->copline = (line_t)whileline;
4922 o = new_logop(OP_AND, 0, &expr, &listop);
4923 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4924 op_free(expr); /* oops, it's a while (0) */
4926 return NULL; /* listop already freed by new_logop */
4929 ((LISTOP*)listop)->op_last->op_next =
4930 (o == listop ? redo : LINKLIST(o));
4936 NewOp(1101,loop,1,LOOP);
4937 loop->op_type = OP_ENTERLOOP;
4938 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4939 loop->op_private = 0;
4940 loop->op_next = (OP*)loop;
4943 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4945 loop->op_redoop = redo;
4946 loop->op_lastop = o;
4947 o->op_private |= loopflags;
4950 loop->op_nextop = next;
4952 loop->op_nextop = o;
4954 o->op_flags |= flags;
4955 o->op_private |= (flags >> 8);
4960 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4965 PADOFFSET padoff = 0;
4970 PERL_ARGS_ASSERT_NEWFOROP;
4973 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4974 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4975 sv->op_type = OP_RV2GV;
4976 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4978 /* The op_type check is needed to prevent a possible segfault
4979 * if the loop variable is undeclared and 'strict vars' is in
4980 * effect. This is illegal but is nonetheless parsed, so we
4981 * may reach this point with an OP_CONST where we're expecting
4984 if (cUNOPx(sv)->op_first->op_type == OP_GV
4985 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4986 iterpflags |= OPpITER_DEF;
4988 else if (sv->op_type == OP_PADSV) { /* private variable */
4989 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4990 padoff = sv->op_targ;
5000 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5002 SV *const namesv = PAD_COMPNAME_SV(padoff);
5004 const char *const name = SvPV_const(namesv, len);
5006 if (len == 2 && name[0] == '$' && name[1] == '_')
5007 iterpflags |= OPpITER_DEF;
5011 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5012 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5013 sv = newGVOP(OP_GV, 0, PL_defgv);
5018 iterpflags |= OPpITER_DEF;
5020 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5021 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5022 iterflags |= OPf_STACKED;
5024 else if (expr->op_type == OP_NULL &&
5025 (expr->op_flags & OPf_KIDS) &&
5026 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5028 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5029 * set the STACKED flag to indicate that these values are to be
5030 * treated as min/max values by 'pp_iterinit'.
5032 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5033 LOGOP* const range = (LOGOP*) flip->op_first;
5034 OP* const left = range->op_first;
5035 OP* const right = left->op_sibling;
5038 range->op_flags &= ~OPf_KIDS;
5039 range->op_first = NULL;
5041 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5042 listop->op_first->op_next = range->op_next;
5043 left->op_next = range->op_other;
5044 right->op_next = (OP*)listop;
5045 listop->op_next = listop->op_first;
5048 op_getmad(expr,(OP*)listop,'O');
5052 expr = (OP*)(listop);
5054 iterflags |= OPf_STACKED;
5057 expr = mod(force_list(expr), OP_GREPSTART);
5060 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5061 append_elem(OP_LIST, expr, scalar(sv))));
5062 assert(!loop->op_next);
5063 /* for my $x () sets OPpLVAL_INTRO;
5064 * for our $x () sets OPpOUR_INTRO */
5065 loop->op_private = (U8)iterpflags;
5066 #ifdef PL_OP_SLAB_ALLOC
5069 NewOp(1234,tmp,1,LOOP);
5070 Copy(loop,tmp,1,LISTOP);
5071 S_op_destroy(aTHX_ (OP*)loop);
5075 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5077 loop->op_targ = padoff;
5078 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5080 op_getmad(madsv, (OP*)loop, 'v');
5081 PL_parser->copline = forline;
5082 return newSTATEOP(0, label, wop);
5086 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5091 PERL_ARGS_ASSERT_NEWLOOPEX;
5093 if (type != OP_GOTO || label->op_type == OP_CONST) {
5094 /* "last()" means "last" */
5095 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5096 o = newOP(type, OPf_SPECIAL);
5098 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5099 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5103 op_getmad(label,o,'L');
5109 /* Check whether it's going to be a goto &function */
5110 if (label->op_type == OP_ENTERSUB
5111 && !(label->op_flags & OPf_STACKED))
5112 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5113 o = newUNOP(type, OPf_STACKED, label);
5115 PL_hints |= HINT_BLOCK_SCOPE;
5119 /* if the condition is a literal array or hash
5120 (or @{ ... } etc), make a reference to it.
5123 S_ref_array_or_hash(pTHX_ OP *cond)
5126 && (cond->op_type == OP_RV2AV
5127 || cond->op_type == OP_PADAV
5128 || cond->op_type == OP_RV2HV
5129 || cond->op_type == OP_PADHV))
5131 return newUNOP(OP_REFGEN,
5132 0, mod(cond, OP_REFGEN));
5138 /* These construct the optree fragments representing given()
5141 entergiven and enterwhen are LOGOPs; the op_other pointer
5142 points up to the associated leave op. We need this so we
5143 can put it in the context and make break/continue work.
5144 (Also, of course, pp_enterwhen will jump straight to
5145 op_other if the match fails.)
5149 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5150 I32 enter_opcode, I32 leave_opcode,
5151 PADOFFSET entertarg)
5157 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5159 NewOp(1101, enterop, 1, LOGOP);
5160 enterop->op_type = (Optype)enter_opcode;
5161 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5162 enterop->op_flags = (U8) OPf_KIDS;
5163 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5164 enterop->op_private = 0;
5166 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5169 enterop->op_first = scalar(cond);
5170 cond->op_sibling = block;
5172 o->op_next = LINKLIST(cond);
5173 cond->op_next = (OP *) enterop;
5176 /* This is a default {} block */
5177 enterop->op_first = block;
5178 enterop->op_flags |= OPf_SPECIAL;
5180 o->op_next = (OP *) enterop;
5183 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5184 entergiven and enterwhen both
5187 enterop->op_next = LINKLIST(block);
5188 block->op_next = enterop->op_other = o;
5193 /* Does this look like a boolean operation? For these purposes
5194 a boolean operation is:
5195 - a subroutine call [*]
5196 - a logical connective
5197 - a comparison operator
5198 - a filetest operator, with the exception of -s -M -A -C
5199 - defined(), exists() or eof()
5200 - /$re/ or $foo =~ /$re/
5202 [*] possibly surprising
5205 S_looks_like_bool(pTHX_ const OP *o)
5209 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5211 switch(o->op_type) {
5214 return looks_like_bool(cLOGOPo->op_first);
5218 looks_like_bool(cLOGOPo->op_first)
5219 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5223 o->op_flags & OPf_KIDS
5224 && looks_like_bool(cUNOPo->op_first));
5227 return looks_like_bool(cUNOPo->op_first);
5232 case OP_NOT: case OP_XOR:
5234 case OP_EQ: case OP_NE: case OP_LT:
5235 case OP_GT: case OP_LE: case OP_GE:
5237 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5238 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5240 case OP_SEQ: case OP_SNE: case OP_SLT:
5241 case OP_SGT: case OP_SLE: case OP_SGE:
5245 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5246 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5247 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5248 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5249 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5250 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5251 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5252 case OP_FTTEXT: case OP_FTBINARY:
5254 case OP_DEFINED: case OP_EXISTS:
5255 case OP_MATCH: case OP_EOF:
5262 /* Detect comparisons that have been optimized away */
5263 if (cSVOPo->op_sv == &PL_sv_yes
5264 || cSVOPo->op_sv == &PL_sv_no)
5277 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5280 PERL_ARGS_ASSERT_NEWGIVENOP;
5281 return newGIVWHENOP(
5282 ref_array_or_hash(cond),
5284 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5288 /* If cond is null, this is a default {} block */
5290 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5292 const bool cond_llb = (!cond || looks_like_bool(cond));
5295 PERL_ARGS_ASSERT_NEWWHENOP;
5300 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5302 scalar(ref_array_or_hash(cond)));
5305 return newGIVWHENOP(
5307 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5308 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5312 =for apidoc cv_undef
5314 Clear out all the active components of a CV. This can happen either
5315 by an explicit C<undef &foo>, or by the reference count going to zero.
5316 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5317 children can still follow the full lexical scope chain.
5323 Perl_cv_undef(pTHX_ CV *cv)
5327 PERL_ARGS_ASSERT_CV_UNDEF;
5329 DEBUG_X(PerlIO_printf(Perl_debug_log,
5330 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5331 PTR2UV(cv), PTR2UV(PL_comppad))
5335 if (CvFILE(cv) && !CvISXSUB(cv)) {
5336 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5337 Safefree(CvFILE(cv));
5342 if (!CvISXSUB(cv) && CvROOT(cv)) {
5343 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5344 Perl_croak(aTHX_ "Can't undef active subroutine");
5347 PAD_SAVE_SETNULLPAD();
5349 op_free(CvROOT(cv));
5354 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5359 /* remove CvOUTSIDE unless this is an undef rather than a free */
5360 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5361 if (!CvWEAKOUTSIDE(cv))
5362 SvREFCNT_dec(CvOUTSIDE(cv));
5363 CvOUTSIDE(cv) = NULL;
5366 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5369 if (CvISXSUB(cv) && CvXSUB(cv)) {
5372 /* delete all flags except WEAKOUTSIDE */
5373 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5377 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5380 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5382 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5383 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5384 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5385 || (p && (len != SvCUR(cv) /* Not the same length. */
5386 || memNE(p, SvPVX_const(cv), len))))
5387 && ckWARN_d(WARN_PROTOTYPE)) {
5388 SV* const msg = sv_newmortal();
5392 gv_efullname3(name = sv_newmortal(), gv, NULL);
5393 sv_setpvs(msg, "Prototype mismatch:");
5395 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5397 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5399 sv_catpvs(msg, ": none");
5400 sv_catpvs(msg, " vs ");
5402 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5404 sv_catpvs(msg, "none");
5405 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5409 static void const_sv_xsub(pTHX_ CV* cv);
5413 =head1 Optree Manipulation Functions
5415 =for apidoc cv_const_sv
5417 If C<cv> is a constant sub eligible for inlining. returns the constant
5418 value returned by the sub. Otherwise, returns NULL.
5420 Constant subs can be created with C<newCONSTSUB> or as described in
5421 L<perlsub/"Constant Functions">.
5426 Perl_cv_const_sv(pTHX_ const CV *const cv)
5428 PERL_UNUSED_CONTEXT;
5431 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5433 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5436 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5437 * Can be called in 3 ways:
5440 * look for a single OP_CONST with attached value: return the value
5442 * cv && CvCLONE(cv) && !CvCONST(cv)
5444 * examine the clone prototype, and if contains only a single
5445 * OP_CONST referencing a pad const, or a single PADSV referencing
5446 * an outer lexical, return a non-zero value to indicate the CV is
5447 * a candidate for "constizing" at clone time
5451 * We have just cloned an anon prototype that was marked as a const
5452 * candidiate. Try to grab the current value, and in the case of
5453 * PADSV, ignore it if it has multiple references. Return the value.
5457 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5468 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5469 o = cLISTOPo->op_first->op_sibling;
5471 for (; o; o = o->op_next) {
5472 const OPCODE type = o->op_type;
5474 if (sv && o->op_next == o)
5476 if (o->op_next != o) {
5477 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5479 if (type == OP_DBSTATE)
5482 if (type == OP_LEAVESUB || type == OP_RETURN)
5486 if (type == OP_CONST && cSVOPo->op_sv)
5488 else if (cv && type == OP_CONST) {
5489 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5493 else if (cv && type == OP_PADSV) {
5494 if (CvCONST(cv)) { /* newly cloned anon */
5495 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5496 /* the candidate should have 1 ref from this pad and 1 ref
5497 * from the parent */
5498 if (!sv || SvREFCNT(sv) != 2)
5505 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5506 sv = &PL_sv_undef; /* an arbitrary non-null value */
5521 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5524 /* This would be the return value, but the return cannot be reached. */
5525 OP* pegop = newOP(OP_NULL, 0);
5528 PERL_UNUSED_ARG(floor);
5538 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5540 NORETURN_FUNCTION_END;
5545 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5547 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5551 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5557 register CV *cv = NULL;
5559 /* If the subroutine has no body, no attributes, and no builtin attributes
5560 then it's just a sub declaration, and we may be able to get away with
5561 storing with a placeholder scalar in the symbol table, rather than a
5562 full GV and CV. If anything is present then it will take a full CV to
5564 const I32 gv_fetch_flags
5565 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5567 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5568 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5572 assert(proto->op_type == OP_CONST);
5573 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5579 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5581 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5582 SV * const sv = sv_newmortal();
5583 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5584 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5585 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5586 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5588 } else if (PL_curstash) {
5589 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5592 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5596 if (!PL_madskills) {
5605 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5606 maximum a prototype before. */
5607 if (SvTYPE(gv) > SVt_NULL) {
5608 if (!SvPOK((const SV *)gv)
5609 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5611 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5613 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5616 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5618 sv_setiv(MUTABLE_SV(gv), -1);
5620 SvREFCNT_dec(PL_compcv);
5621 cv = PL_compcv = NULL;
5625 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5627 if (!block || !ps || *ps || attrs
5628 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5630 || block->op_type == OP_NULL
5635 const_sv = op_const_sv(block, NULL);
5638 const bool exists = CvROOT(cv) || CvXSUB(cv);
5640 /* if the subroutine doesn't exist and wasn't pre-declared
5641 * with a prototype, assume it will be AUTOLOADed,
5642 * skipping the prototype check
5644 if (exists || SvPOK(cv))
5645 cv_ckproto_len(cv, gv, ps, ps_len);
5646 /* already defined (or promised)? */
5647 if (exists || GvASSUMECV(gv)) {
5650 || block->op_type == OP_NULL
5653 if (CvFLAGS(PL_compcv)) {
5654 /* might have had built-in attrs applied */
5655 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5657 /* just a "sub foo;" when &foo is already defined */
5658 SAVEFREESV(PL_compcv);
5663 && block->op_type != OP_NULL
5666 if (ckWARN(WARN_REDEFINE)
5668 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5670 const line_t oldline = CopLINE(PL_curcop);
5671 if (PL_parser && PL_parser->copline != NOLINE)
5672 CopLINE_set(PL_curcop, PL_parser->copline);
5673 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5674 CvCONST(cv) ? "Constant subroutine %s redefined"
5675 : "Subroutine %s redefined", name);
5676 CopLINE_set(PL_curcop, oldline);
5679 if (!PL_minus_c) /* keep old one around for madskills */
5682 /* (PL_madskills unset in used file.) */
5690 SvREFCNT_inc_simple_void_NN(const_sv);
5692 assert(!CvROOT(cv) && !CvCONST(cv));
5693 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5694 CvXSUBANY(cv).any_ptr = const_sv;
5695 CvXSUB(cv) = const_sv_xsub;
5701 cv = newCONSTSUB(NULL, name, const_sv);
5703 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5704 (CvGV(cv) && GvSTASH(CvGV(cv)))
5713 SvREFCNT_dec(PL_compcv);
5717 if (cv) { /* must reuse cv if autoloaded */
5718 /* transfer PL_compcv to cv */
5721 && block->op_type != OP_NULL
5725 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5726 if (!CvWEAKOUTSIDE(cv))
5727 SvREFCNT_dec(CvOUTSIDE(cv));
5728 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5729 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5730 CvOUTSIDE(PL_compcv) = 0;
5731 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5732 CvPADLIST(PL_compcv) = 0;
5733 /* inner references to PL_compcv must be fixed up ... */
5734 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5735 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5736 ++PL_sub_generation;
5739 /* Might have had built-in attributes applied -- propagate them. */
5740 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5742 /* ... before we throw it away */
5743 SvREFCNT_dec(PL_compcv);
5751 if (strEQ(name, "import")) {
5752 PL_formfeed = MUTABLE_SV(cv);
5753 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5757 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5762 CvFILE_set_from_cop(cv, PL_curcop);
5763 CvSTASH(cv) = PL_curstash;
5766 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5767 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5768 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5772 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5774 if (PL_parser && PL_parser->error_count) {
5778 const char *s = strrchr(name, ':');
5780 if (strEQ(s, "BEGIN")) {
5781 const char not_safe[] =
5782 "BEGIN not safe after errors--compilation aborted";
5783 if (PL_in_eval & EVAL_KEEPERR)
5784 Perl_croak(aTHX_ not_safe);
5786 /* force display of errors found but not reported */
5787 sv_catpv(ERRSV, not_safe);
5788 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5797 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5798 the debugger could be able to set a breakpoint in, so signal to
5799 pp_entereval that it should not throw away any saved lines at scope
5802 PL_breakable_sub_gen++;
5804 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5805 mod(scalarseq(block), OP_LEAVESUBLV));
5806 block->op_attached = 1;
5809 /* This makes sub {}; work as expected. */
5810 if (block->op_type == OP_STUB) {
5811 OP* const newblock = newSTATEOP(0, NULL, 0);
5813 op_getmad(block,newblock,'B');
5820 block->op_attached = 1;
5821 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5823 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5824 OpREFCNT_set(CvROOT(cv), 1);
5825 CvSTART(cv) = LINKLIST(CvROOT(cv));
5826 CvROOT(cv)->op_next = 0;
5827 CALL_PEEP(CvSTART(cv));
5829 /* now that optimizer has done its work, adjust pad values */
5831 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5834 assert(!CvCONST(cv));
5835 if (ps && !*ps && op_const_sv(block, cv))
5840 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5841 SV * const sv = newSV(0);
5842 SV * const tmpstr = sv_newmortal();
5843 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5844 GV_ADDMULTI, SVt_PVHV);
5847 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5849 (long)PL_subline, (long)CopLINE(PL_curcop));
5850 gv_efullname3(tmpstr, gv, NULL);
5851 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5852 SvCUR(tmpstr), sv, 0);
5853 hv = GvHVn(db_postponed);
5854 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5855 CV * const pcv = GvCV(db_postponed);
5861 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5866 if (name && ! (PL_parser && PL_parser->error_count))
5867 process_special_blocks(name, gv, cv);
5872 PL_parser->copline = NOLINE;
5878 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5881 const char *const colon = strrchr(fullname,':');
5882 const char *const name = colon ? colon + 1 : fullname;
5884 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5887 if (strEQ(name, "BEGIN")) {
5888 const I32 oldscope = PL_scopestack_ix;
5890 SAVECOPFILE(&PL_compiling);
5891 SAVECOPLINE(&PL_compiling);
5893 DEBUG_x( dump_sub(gv) );
5894 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5895 GvCV(gv) = 0; /* cv has been hijacked */
5896 call_list(oldscope, PL_beginav);
5898 PL_curcop = &PL_compiling;
5899 CopHINTS_set(&PL_compiling, PL_hints);
5906 if strEQ(name, "END") {
5907 DEBUG_x( dump_sub(gv) );
5908 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5911 } else if (*name == 'U') {
5912 if (strEQ(name, "UNITCHECK")) {
5913 /* It's never too late to run a unitcheck block */
5914 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5918 } else if (*name == 'C') {
5919 if (strEQ(name, "CHECK")) {
5921 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5922 "Too late to run CHECK block");
5923 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5927 } else if (*name == 'I') {
5928 if (strEQ(name, "INIT")) {
5930 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5931 "Too late to run INIT block");
5932 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5938 DEBUG_x( dump_sub(gv) );
5939 GvCV(gv) = 0; /* cv has been hijacked */
5944 =for apidoc newCONSTSUB
5946 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5947 eligible for inlining at compile-time.
5949 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5950 which won't be called if used as a destructor, but will suppress the overhead
5951 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5958 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5963 const char *const file = CopFILE(PL_curcop);
5965 SV *const temp_sv = CopFILESV(PL_curcop);
5966 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5971 if (IN_PERL_RUNTIME) {
5972 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5973 * an op shared between threads. Use a non-shared COP for our
5975 SAVEVPTR(PL_curcop);
5976 PL_curcop = &PL_compiling;
5978 SAVECOPLINE(PL_curcop);
5979 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5982 PL_hints &= ~HINT_BLOCK_SCOPE;
5985 SAVESPTR(PL_curstash);
5986 SAVECOPSTASH(PL_curcop);
5987 PL_curstash = stash;
5988 CopSTASH_set(PL_curcop,stash);
5991 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5992 and so doesn't get free()d. (It's expected to be from the C pre-
5993 processor __FILE__ directive). But we need a dynamically allocated one,
5994 and we need it to get freed. */
5995 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
5996 XS_DYNAMIC_FILENAME);
5997 CvXSUBANY(cv).any_ptr = sv;
6002 CopSTASH_free(PL_curcop);
6010 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6011 const char *const filename, const char *const proto,
6014 CV *cv = newXS(name, subaddr, filename);
6016 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6018 if (flags & XS_DYNAMIC_FILENAME) {
6019 /* We need to "make arrangements" (ie cheat) to ensure that the
6020 filename lasts as long as the PVCV we just created, but also doesn't
6022 STRLEN filename_len = strlen(filename);
6023 STRLEN proto_and_file_len = filename_len;
6024 char *proto_and_file;
6028 proto_len = strlen(proto);
6029 proto_and_file_len += proto_len;
6031 Newx(proto_and_file, proto_and_file_len + 1, char);
6032 Copy(proto, proto_and_file, proto_len, char);
6033 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6036 proto_and_file = savepvn(filename, filename_len);
6039 /* This gets free()d. :-) */
6040 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6041 SV_HAS_TRAILING_NUL);
6043 /* This gives us the correct prototype, rather than one with the
6044 file name appended. */
6045 SvCUR_set(cv, proto_len);
6049 CvFILE(cv) = proto_and_file + proto_len;
6051 sv_setpv(MUTABLE_SV(cv), proto);
6057 =for apidoc U||newXS
6059 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6060 static storage, as it is used directly as CvFILE(), without a copy being made.
6066 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6069 GV * const gv = gv_fetchpv(name ? name :
6070 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6071 GV_ADDMULTI, SVt_PVCV);
6074 PERL_ARGS_ASSERT_NEWXS;
6077 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6079 if ((cv = (name ? GvCV(gv) : NULL))) {
6081 /* just a cached method */
6085 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6086 /* already defined (or promised) */
6087 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6088 if (ckWARN(WARN_REDEFINE)) {
6089 GV * const gvcv = CvGV(cv);
6091 HV * const stash = GvSTASH(gvcv);
6093 const char *redefined_name = HvNAME_get(stash);
6094 if ( strEQ(redefined_name,"autouse") ) {
6095 const line_t oldline = CopLINE(PL_curcop);
6096 if (PL_parser && PL_parser->copline != NOLINE)
6097 CopLINE_set(PL_curcop, PL_parser->copline);
6098 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6099 CvCONST(cv) ? "Constant subroutine %s redefined"
6100 : "Subroutine %s redefined"
6102 CopLINE_set(PL_curcop, oldline);
6112 if (cv) /* must reuse cv if autoloaded */
6115 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6119 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6123 (void)gv_fetchfile(filename);
6124 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6125 an external constant string */
6127 CvXSUB(cv) = subaddr;
6130 process_special_blocks(name, gv, cv);
6142 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6147 OP* pegop = newOP(OP_NULL, 0);
6151 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6152 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6155 if ((cv = GvFORM(gv))) {
6156 if (ckWARN(WARN_REDEFINE)) {
6157 const line_t oldline = CopLINE(PL_curcop);
6158 if (PL_parser && PL_parser->copline != NOLINE)
6159 CopLINE_set(PL_curcop, PL_parser->copline);
6161 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6162 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6164 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6165 "Format STDOUT redefined");
6167 CopLINE_set(PL_curcop, oldline);
6174 CvFILE_set_from_cop(cv, PL_curcop);
6177 pad_tidy(padtidy_FORMAT);
6178 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6179 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6180 OpREFCNT_set(CvROOT(cv), 1);
6181 CvSTART(cv) = LINKLIST(CvROOT(cv));
6182 CvROOT(cv)->op_next = 0;
6183 CALL_PEEP(CvSTART(cv));
6185 op_getmad(o,pegop,'n');
6186 op_getmad_weak(block, pegop, 'b');
6191 PL_parser->copline = NOLINE;
6199 Perl_newANONLIST(pTHX_ OP *o)
6201 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6205 Perl_newANONHASH(pTHX_ OP *o)
6207 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6211 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6213 return newANONATTRSUB(floor, proto, NULL, block);
6217 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6219 return newUNOP(OP_REFGEN, 0,
6220 newSVOP(OP_ANONCODE, 0,
6221 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6225 Perl_oopsAV(pTHX_ OP *o)
6229 PERL_ARGS_ASSERT_OOPSAV;
6231 switch (o->op_type) {
6233 o->op_type = OP_PADAV;
6234 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6235 return ref(o, OP_RV2AV);
6238 o->op_type = OP_RV2AV;
6239 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6244 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6251 Perl_oopsHV(pTHX_ OP *o)
6255 PERL_ARGS_ASSERT_OOPSHV;
6257 switch (o->op_type) {
6260 o->op_type = OP_PADHV;
6261 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6262 return ref(o, OP_RV2HV);
6266 o->op_type = OP_RV2HV;
6267 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6272 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6279 Perl_newAVREF(pTHX_ OP *o)
6283 PERL_ARGS_ASSERT_NEWAVREF;
6285 if (o->op_type == OP_PADANY) {
6286 o->op_type = OP_PADAV;
6287 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6290 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6291 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6292 "Using an array as a reference is deprecated");
6294 return newUNOP(OP_RV2AV, 0, scalar(o));
6298 Perl_newGVREF(pTHX_ I32 type, OP *o)
6300 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6301 return newUNOP(OP_NULL, 0, o);
6302 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6306 Perl_newHVREF(pTHX_ OP *o)
6310 PERL_ARGS_ASSERT_NEWHVREF;
6312 if (o->op_type == OP_PADANY) {
6313 o->op_type = OP_PADHV;
6314 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6317 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6318 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6319 "Using a hash as a reference is deprecated");
6321 return newUNOP(OP_RV2HV, 0, scalar(o));
6325 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6327 return newUNOP(OP_RV2CV, flags, scalar(o));
6331 Perl_newSVREF(pTHX_ OP *o)
6335 PERL_ARGS_ASSERT_NEWSVREF;
6337 if (o->op_type == OP_PADANY) {
6338 o->op_type = OP_PADSV;
6339 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6342 return newUNOP(OP_RV2SV, 0, scalar(o));
6345 /* Check routines. See the comments at the top of this file for details
6346 * on when these are called */
6349 Perl_ck_anoncode(pTHX_ OP *o)
6351 PERL_ARGS_ASSERT_CK_ANONCODE;
6353 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6355 cSVOPo->op_sv = NULL;
6360 Perl_ck_bitop(pTHX_ OP *o)
6364 PERL_ARGS_ASSERT_CK_BITOP;
6366 #define OP_IS_NUMCOMPARE(op) \
6367 ((op) == OP_LT || (op) == OP_I_LT || \
6368 (op) == OP_GT || (op) == OP_I_GT || \
6369 (op) == OP_LE || (op) == OP_I_LE || \
6370 (op) == OP_GE || (op) == OP_I_GE || \
6371 (op) == OP_EQ || (op) == OP_I_EQ || \
6372 (op) == OP_NE || (op) == OP_I_NE || \
6373 (op) == OP_NCMP || (op) == OP_I_NCMP)
6374 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6375 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6376 && (o->op_type == OP_BIT_OR
6377 || o->op_type == OP_BIT_AND
6378 || o->op_type == OP_BIT_XOR))
6380 const OP * const left = cBINOPo->op_first;
6381 const OP * const right = left->op_sibling;
6382 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6383 (left->op_flags & OPf_PARENS) == 0) ||
6384 (OP_IS_NUMCOMPARE(right->op_type) &&
6385 (right->op_flags & OPf_PARENS) == 0))
6386 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6387 "Possible precedence problem on bitwise %c operator",
6388 o->op_type == OP_BIT_OR ? '|'
6389 : o->op_type == OP_BIT_AND ? '&' : '^'
6396 Perl_ck_concat(pTHX_ OP *o)
6398 const OP * const kid = cUNOPo->op_first;
6400 PERL_ARGS_ASSERT_CK_CONCAT;
6401 PERL_UNUSED_CONTEXT;
6403 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6404 !(kUNOP->op_first->op_flags & OPf_MOD))
6405 o->op_flags |= OPf_STACKED;
6410 Perl_ck_spair(pTHX_ OP *o)
6414 PERL_ARGS_ASSERT_CK_SPAIR;
6416 if (o->op_flags & OPf_KIDS) {
6419 const OPCODE type = o->op_type;
6420 o = modkids(ck_fun(o), type);
6421 kid = cUNOPo->op_first;
6422 newop = kUNOP->op_first->op_sibling;
6424 const OPCODE type = newop->op_type;
6425 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6426 type == OP_PADAV || type == OP_PADHV ||
6427 type == OP_RV2AV || type == OP_RV2HV)
6431 op_getmad(kUNOP->op_first,newop,'K');
6433 op_free(kUNOP->op_first);
6435 kUNOP->op_first = newop;
6437 o->op_ppaddr = PL_ppaddr[++o->op_type];
6442 Perl_ck_delete(pTHX_ OP *o)
6444 PERL_ARGS_ASSERT_CK_DELETE;
6448 if (o->op_flags & OPf_KIDS) {
6449 OP * const kid = cUNOPo->op_first;
6450 switch (kid->op_type) {
6452 o->op_flags |= OPf_SPECIAL;
6455 o->op_private |= OPpSLICE;
6458 o->op_flags |= OPf_SPECIAL;
6463 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6466 if (kid->op_private & OPpLVAL_INTRO)
6467 o->op_private |= OPpLVAL_INTRO;
6474 Perl_ck_die(pTHX_ OP *o)
6476 PERL_ARGS_ASSERT_CK_DIE;
6479 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6485 Perl_ck_eof(pTHX_ OP *o)
6489 PERL_ARGS_ASSERT_CK_EOF;
6491 if (o->op_flags & OPf_KIDS) {
6492 if (cLISTOPo->op_first->op_type == OP_STUB) {
6494 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6496 op_getmad(o,newop,'O');
6508 Perl_ck_eval(pTHX_ OP *o)
6512 PERL_ARGS_ASSERT_CK_EVAL;
6514 PL_hints |= HINT_BLOCK_SCOPE;
6515 if (o->op_flags & OPf_KIDS) {
6516 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6519 o->op_flags &= ~OPf_KIDS;
6522 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6528 cUNOPo->op_first = 0;
6533 NewOp(1101, enter, 1, LOGOP);
6534 enter->op_type = OP_ENTERTRY;
6535 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6536 enter->op_private = 0;
6538 /* establish postfix order */
6539 enter->op_next = (OP*)enter;
6541 CHECKOP(OP_ENTERTRY, enter);
6543 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6544 o->op_type = OP_LEAVETRY;
6545 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6546 enter->op_other = o;
6547 op_getmad(oldo,o,'O');
6561 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6562 op_getmad(oldo,o,'O');
6564 o->op_targ = (PADOFFSET)PL_hints;
6565 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6566 /* Store a copy of %^H that pp_entereval can pick up. */
6567 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6568 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6569 cUNOPo->op_first->op_sibling = hhop;
6570 o->op_private |= OPpEVAL_HAS_HH;
6576 Perl_ck_exit(pTHX_ OP *o)
6578 PERL_ARGS_ASSERT_CK_EXIT;
6581 HV * const table = GvHV(PL_hintgv);
6583 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6584 if (svp && *svp && SvTRUE(*svp))
6585 o->op_private |= OPpEXIT_VMSISH;
6587 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6593 Perl_ck_exec(pTHX_ OP *o)
6595 PERL_ARGS_ASSERT_CK_EXEC;
6597 if (o->op_flags & OPf_STACKED) {
6600 kid = cUNOPo->op_first->op_sibling;
6601 if (kid->op_type == OP_RV2GV)
6610 Perl_ck_exists(pTHX_ OP *o)
6614 PERL_ARGS_ASSERT_CK_EXISTS;
6617 if (o->op_flags & OPf_KIDS) {
6618 OP * const kid = cUNOPo->op_first;
6619 if (kid->op_type == OP_ENTERSUB) {
6620 (void) ref(kid, o->op_type);
6621 if (kid->op_type != OP_RV2CV
6622 && !(PL_parser && PL_parser->error_count))
6623 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6625 o->op_private |= OPpEXISTS_SUB;
6627 else if (kid->op_type == OP_AELEM)
6628 o->op_flags |= OPf_SPECIAL;
6629 else if (kid->op_type != OP_HELEM)
6630 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6638 Perl_ck_rvconst(pTHX_ register OP *o)
6641 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6643 PERL_ARGS_ASSERT_CK_RVCONST;
6645 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6646 if (o->op_type == OP_RV2CV)
6647 o->op_private &= ~1;
6649 if (kid->op_type == OP_CONST) {
6652 SV * const kidsv = kid->op_sv;
6654 /* Is it a constant from cv_const_sv()? */
6655 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6656 SV * const rsv = SvRV(kidsv);
6657 const svtype type = SvTYPE(rsv);
6658 const char *badtype = NULL;
6660 switch (o->op_type) {
6662 if (type > SVt_PVMG)
6663 badtype = "a SCALAR";
6666 if (type != SVt_PVAV)
6667 badtype = "an ARRAY";
6670 if (type != SVt_PVHV)
6674 if (type != SVt_PVCV)
6679 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6682 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6683 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6684 /* If this is an access to a stash, disable "strict refs", because
6685 * stashes aren't auto-vivified at compile-time (unless we store
6686 * symbols in them), and we don't want to produce a run-time
6687 * stricture error when auto-vivifying the stash. */
6688 const char *s = SvPV_nolen(kidsv);
6689 const STRLEN l = SvCUR(kidsv);
6690 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6691 o->op_private &= ~HINT_STRICT_REFS;
6693 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6694 const char *badthing;
6695 switch (o->op_type) {
6697 badthing = "a SCALAR";
6700 badthing = "an ARRAY";
6703 badthing = "a HASH";
6711 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6712 SVfARG(kidsv), badthing);
6715 * This is a little tricky. We only want to add the symbol if we
6716 * didn't add it in the lexer. Otherwise we get duplicate strict
6717 * warnings. But if we didn't add it in the lexer, we must at
6718 * least pretend like we wanted to add it even if it existed before,
6719 * or we get possible typo warnings. OPpCONST_ENTERED says
6720 * whether the lexer already added THIS instance of this symbol.
6722 iscv = (o->op_type == OP_RV2CV) * 2;
6724 gv = gv_fetchsv(kidsv,
6725 iscv | !(kid->op_private & OPpCONST_ENTERED),
6728 : o->op_type == OP_RV2SV
6730 : o->op_type == OP_RV2AV
6732 : o->op_type == OP_RV2HV
6735 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6737 kid->op_type = OP_GV;
6738 SvREFCNT_dec(kid->op_sv);
6740 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6741 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6742 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6744 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6746 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6748 kid->op_private = 0;
6749 kid->op_ppaddr = PL_ppaddr[OP_GV];
6756 Perl_ck_ftst(pTHX_ OP *o)
6759 const I32 type = o->op_type;
6761 PERL_ARGS_ASSERT_CK_FTST;
6763 if (o->op_flags & OPf_REF) {
6766 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6767 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6768 const OPCODE kidtype = kid->op_type;
6770 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6771 OP * const newop = newGVOP(type, OPf_REF,
6772 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6774 op_getmad(o,newop,'O');
6780 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6781 o->op_private |= OPpFT_ACCESS;
6782 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6783 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6784 o->op_private |= OPpFT_STACKED;
6792 if (type == OP_FTTTY)
6793 o = newGVOP(type, OPf_REF, PL_stdingv);
6795 o = newUNOP(type, 0, newDEFSVOP());
6796 op_getmad(oldo,o,'O');
6802 Perl_ck_fun(pTHX_ OP *o)
6805 const int type = o->op_type;
6806 register I32 oa = PL_opargs[type] >> OASHIFT;
6808 PERL_ARGS_ASSERT_CK_FUN;
6810 if (o->op_flags & OPf_STACKED) {
6811 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6814 return no_fh_allowed(o);
6817 if (o->op_flags & OPf_KIDS) {
6818 OP **tokid = &cLISTOPo->op_first;
6819 register OP *kid = cLISTOPo->op_first;
6823 if (kid->op_type == OP_PUSHMARK ||
6824 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6826 tokid = &kid->op_sibling;
6827 kid = kid->op_sibling;
6829 if (!kid && PL_opargs[type] & OA_DEFGV)
6830 *tokid = kid = newDEFSVOP();
6834 sibl = kid->op_sibling;
6836 if (!sibl && kid->op_type == OP_STUB) {
6843 /* list seen where single (scalar) arg expected? */
6844 if (numargs == 1 && !(oa >> 4)
6845 && kid->op_type == OP_LIST && type != OP_SCALAR)
6847 return too_many_arguments(o,PL_op_desc[type]);
6860 if ((type == OP_PUSH || type == OP_UNSHIFT)
6861 && !kid->op_sibling)
6862 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6863 "Useless use of %s with no values",
6866 if (kid->op_type == OP_CONST &&
6867 (kid->op_private & OPpCONST_BARE))
6869 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6870 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6871 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6872 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6873 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6875 op_getmad(kid,newop,'K');
6880 kid->op_sibling = sibl;
6883 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6884 bad_type(numargs, "array", PL_op_desc[type], kid);
6888 if (kid->op_type == OP_CONST &&
6889 (kid->op_private & OPpCONST_BARE))
6891 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6892 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6893 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6894 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6895 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6897 op_getmad(kid,newop,'K');
6902 kid->op_sibling = sibl;
6905 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6906 bad_type(numargs, "hash", PL_op_desc[type], kid);
6911 OP * const newop = newUNOP(OP_NULL, 0, kid);
6912 kid->op_sibling = 0;
6914 newop->op_next = newop;
6916 kid->op_sibling = sibl;
6921 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6922 if (kid->op_type == OP_CONST &&
6923 (kid->op_private & OPpCONST_BARE))
6925 OP * const newop = newGVOP(OP_GV, 0,
6926 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6927 if (!(o->op_private & 1) && /* if not unop */
6928 kid == cLISTOPo->op_last)
6929 cLISTOPo->op_last = newop;
6931 op_getmad(kid,newop,'K');
6937 else if (kid->op_type == OP_READLINE) {
6938 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6939 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6942 I32 flags = OPf_SPECIAL;
6946 /* is this op a FH constructor? */
6947 if (is_handle_constructor(o,numargs)) {
6948 const char *name = NULL;
6952 /* Set a flag to tell rv2gv to vivify
6953 * need to "prove" flag does not mean something
6954 * else already - NI-S 1999/05/07
6957 if (kid->op_type == OP_PADSV) {
6959 = PAD_COMPNAME_SV(kid->op_targ);
6960 name = SvPV_const(namesv, len);
6962 else if (kid->op_type == OP_RV2SV
6963 && kUNOP->op_first->op_type == OP_GV)
6965 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6967 len = GvNAMELEN(gv);
6969 else if (kid->op_type == OP_AELEM
6970 || kid->op_type == OP_HELEM)
6973 OP *op = ((BINOP*)kid)->op_first;
6977 const char * const a =
6978 kid->op_type == OP_AELEM ?
6980 if (((op->op_type == OP_RV2AV) ||
6981 (op->op_type == OP_RV2HV)) &&
6982 (firstop = ((UNOP*)op)->op_first) &&
6983 (firstop->op_type == OP_GV)) {
6984 /* packagevar $a[] or $h{} */
6985 GV * const gv = cGVOPx_gv(firstop);
6993 else if (op->op_type == OP_PADAV
6994 || op->op_type == OP_PADHV) {
6995 /* lexicalvar $a[] or $h{} */
6996 const char * const padname =
6997 PAD_COMPNAME_PV(op->op_targ);
7006 name = SvPV_const(tmpstr, len);
7011 name = "__ANONIO__";
7018 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7019 namesv = PAD_SVl(targ);
7020 SvUPGRADE(namesv, SVt_PV);
7022 sv_setpvs(namesv, "$");
7023 sv_catpvn(namesv, name, len);
7026 kid->op_sibling = 0;
7027 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7028 kid->op_targ = targ;
7029 kid->op_private |= priv;
7031 kid->op_sibling = sibl;
7037 mod(scalar(kid), type);
7041 tokid = &kid->op_sibling;
7042 kid = kid->op_sibling;
7045 if (kid && kid->op_type != OP_STUB)
7046 return too_many_arguments(o,OP_DESC(o));
7047 o->op_private |= numargs;
7049 /* FIXME - should the numargs move as for the PERL_MAD case? */
7050 o->op_private |= numargs;
7052 return too_many_arguments(o,OP_DESC(o));
7056 else if (PL_opargs[type] & OA_DEFGV) {
7058 OP *newop = newUNOP(type, 0, newDEFSVOP());
7059 op_getmad(o,newop,'O');
7062 /* Ordering of these two is important to keep f_map.t passing. */
7064 return newUNOP(type, 0, newDEFSVOP());
7069 while (oa & OA_OPTIONAL)
7071 if (oa && oa != OA_LIST)
7072 return too_few_arguments(o,OP_DESC(o));
7078 Perl_ck_glob(pTHX_ OP *o)
7083 PERL_ARGS_ASSERT_CK_GLOB;
7086 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7087 append_elem(OP_GLOB, o, newDEFSVOP());
7089 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7090 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7092 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7095 #if !defined(PERL_EXTERNAL_GLOB)
7096 /* XXX this can be tightened up and made more failsafe. */
7097 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7100 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7101 newSVpvs("File::Glob"), NULL, NULL, NULL);
7102 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7103 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7104 GvCV(gv) = GvCV(glob_gv);
7105 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7106 GvIMPORTED_CV_on(gv);
7109 #endif /* PERL_EXTERNAL_GLOB */
7111 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7112 append_elem(OP_GLOB, o,
7113 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7114 o->op_type = OP_LIST;
7115 o->op_ppaddr = PL_ppaddr[OP_LIST];
7116 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7117 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7118 cLISTOPo->op_first->op_targ = 0;
7119 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7120 append_elem(OP_LIST, o,
7121 scalar(newUNOP(OP_RV2CV, 0,
7122 newGVOP(OP_GV, 0, gv)))));
7123 o = newUNOP(OP_NULL, 0, ck_subr(o));
7124 o->op_targ = OP_GLOB; /* hint at what it used to be */
7127 gv = newGVgen("main");
7129 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7135 Perl_ck_grep(pTHX_ OP *o)
7140 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7143 PERL_ARGS_ASSERT_CK_GREP;
7145 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7146 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7148 if (o->op_flags & OPf_STACKED) {
7151 kid = cLISTOPo->op_first->op_sibling;
7152 if (!cUNOPx(kid)->op_next)
7153 Perl_croak(aTHX_ "panic: ck_grep");
7154 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7157 NewOp(1101, gwop, 1, LOGOP);
7158 kid->op_next = (OP*)gwop;
7159 o->op_flags &= ~OPf_STACKED;
7161 kid = cLISTOPo->op_first->op_sibling;
7162 if (type == OP_MAPWHILE)
7167 if (PL_parser && PL_parser->error_count)
7169 kid = cLISTOPo->op_first->op_sibling;
7170 if (kid->op_type != OP_NULL)
7171 Perl_croak(aTHX_ "panic: ck_grep");
7172 kid = kUNOP->op_first;
7175 NewOp(1101, gwop, 1, LOGOP);
7176 gwop->op_type = type;
7177 gwop->op_ppaddr = PL_ppaddr[type];
7178 gwop->op_first = listkids(o);
7179 gwop->op_flags |= OPf_KIDS;
7180 gwop->op_other = LINKLIST(kid);
7181 kid->op_next = (OP*)gwop;
7182 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7183 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7184 o->op_private = gwop->op_private = 0;
7185 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7188 o->op_private = gwop->op_private = OPpGREP_LEX;
7189 gwop->op_targ = o->op_targ = offset;
7192 kid = cLISTOPo->op_first->op_sibling;
7193 if (!kid || !kid->op_sibling)
7194 return too_few_arguments(o,OP_DESC(o));
7195 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7196 mod(kid, OP_GREPSTART);
7202 Perl_ck_index(pTHX_ OP *o)
7204 PERL_ARGS_ASSERT_CK_INDEX;
7206 if (o->op_flags & OPf_KIDS) {
7207 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7209 kid = kid->op_sibling; /* get past "big" */
7210 if (kid && kid->op_type == OP_CONST)
7211 fbm_compile(((SVOP*)kid)->op_sv, 0);
7217 Perl_ck_lfun(pTHX_ OP *o)
7219 const OPCODE type = o->op_type;
7221 PERL_ARGS_ASSERT_CK_LFUN;
7223 return modkids(ck_fun(o), type);
7227 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7229 PERL_ARGS_ASSERT_CK_DEFINED;
7231 if ((o->op_flags & OPf_KIDS)) {
7232 switch (cUNOPo->op_first->op_type) {
7234 /* This is needed for
7235 if (defined %stash::)
7236 to work. Do not break Tk.
7238 break; /* Globals via GV can be undef */
7240 case OP_AASSIGN: /* Is this a good idea? */
7241 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7242 "defined(@array) is deprecated");
7243 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7244 "\t(Maybe you should just omit the defined()?)\n");
7248 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7249 "defined(%%hash) is deprecated");
7250 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7251 "\t(Maybe you should just omit the defined()?)\n");
7262 Perl_ck_readline(pTHX_ OP *o)
7264 PERL_ARGS_ASSERT_CK_READLINE;
7266 if (!(o->op_flags & OPf_KIDS)) {
7268 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7270 op_getmad(o,newop,'O');
7280 Perl_ck_rfun(pTHX_ OP *o)
7282 const OPCODE type = o->op_type;
7284 PERL_ARGS_ASSERT_CK_RFUN;
7286 return refkids(ck_fun(o), type);
7290 Perl_ck_listiob(pTHX_ OP *o)
7294 PERL_ARGS_ASSERT_CK_LISTIOB;
7296 kid = cLISTOPo->op_first;
7299 kid = cLISTOPo->op_first;
7301 if (kid->op_type == OP_PUSHMARK)
7302 kid = kid->op_sibling;
7303 if (kid && o->op_flags & OPf_STACKED)
7304 kid = kid->op_sibling;
7305 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7306 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7307 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7308 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7309 cLISTOPo->op_first->op_sibling = kid;
7310 cLISTOPo->op_last = kid;
7311 kid = kid->op_sibling;
7316 append_elem(o->op_type, o, newDEFSVOP());
7322 Perl_ck_smartmatch(pTHX_ OP *o)
7325 if (0 == (o->op_flags & OPf_SPECIAL)) {
7326 OP *first = cBINOPo->op_first;
7327 OP *second = first->op_sibling;
7329 /* Implicitly take a reference to an array or hash */
7330 first->op_sibling = NULL;
7331 first = cBINOPo->op_first = ref_array_or_hash(first);
7332 second = first->op_sibling = ref_array_or_hash(second);
7334 /* Implicitly take a reference to a regular expression */
7335 if (first->op_type == OP_MATCH) {
7336 first->op_type = OP_QR;
7337 first->op_ppaddr = PL_ppaddr[OP_QR];
7339 if (second->op_type == OP_MATCH) {
7340 second->op_type = OP_QR;
7341 second->op_ppaddr = PL_ppaddr[OP_QR];
7350 Perl_ck_sassign(pTHX_ OP *o)
7353 OP * const kid = cLISTOPo->op_first;
7355 PERL_ARGS_ASSERT_CK_SASSIGN;
7357 /* has a disposable target? */
7358 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7359 && !(kid->op_flags & OPf_STACKED)
7360 /* Cannot steal the second time! */
7361 && !(kid->op_private & OPpTARGET_MY)
7362 /* Keep the full thing for madskills */
7366 OP * const kkid = kid->op_sibling;
7368 /* Can just relocate the target. */
7369 if (kkid && kkid->op_type == OP_PADSV
7370 && !(kkid->op_private & OPpLVAL_INTRO))
7372 kid->op_targ = kkid->op_targ;
7374 /* Now we do not need PADSV and SASSIGN. */
7375 kid->op_sibling = o->op_sibling; /* NULL */
7376 cLISTOPo->op_first = NULL;
7379 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7383 if (kid->op_sibling) {
7384 OP *kkid = kid->op_sibling;
7385 if (kkid->op_type == OP_PADSV
7386 && (kkid->op_private & OPpLVAL_INTRO)
7387 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7388 const PADOFFSET target = kkid->op_targ;
7389 OP *const other = newOP(OP_PADSV,
7391 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7392 OP *const first = newOP(OP_NULL, 0);
7393 OP *const nullop = newCONDOP(0, first, o, other);
7394 OP *const condop = first->op_next;
7395 /* hijacking PADSTALE for uninitialized state variables */
7396 SvPADSTALE_on(PAD_SVl(target));
7398 condop->op_type = OP_ONCE;
7399 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7400 condop->op_targ = target;
7401 other->op_targ = target;
7403 /* Because we change the type of the op here, we will skip the
7404 assinment binop->op_last = binop->op_first->op_sibling; at the
7405 end of Perl_newBINOP(). So need to do it here. */
7406 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7415 Perl_ck_match(pTHX_ OP *o)
7419 PERL_ARGS_ASSERT_CK_MATCH;
7421 if (o->op_type != OP_QR && PL_compcv) {
7422 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7423 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7424 o->op_targ = offset;
7425 o->op_private |= OPpTARGET_MY;
7428 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7429 o->op_private |= OPpRUNTIME;
7434 Perl_ck_method(pTHX_ OP *o)
7436 OP * const kid = cUNOPo->op_first;
7438 PERL_ARGS_ASSERT_CK_METHOD;
7440 if (kid->op_type == OP_CONST) {
7441 SV* sv = kSVOP->op_sv;
7442 const char * const method = SvPVX_const(sv);
7443 if (!(strchr(method, ':') || strchr(method, '\''))) {
7445 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7446 sv = newSVpvn_share(method, SvCUR(sv), 0);
7449 kSVOP->op_sv = NULL;
7451 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7453 op_getmad(o,cmop,'O');
7464 Perl_ck_null(pTHX_ OP *o)
7466 PERL_ARGS_ASSERT_CK_NULL;
7467 PERL_UNUSED_CONTEXT;
7472 Perl_ck_open(pTHX_ OP *o)
7475 HV * const table = GvHV(PL_hintgv);
7477 PERL_ARGS_ASSERT_CK_OPEN;
7480 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7483 const char *d = SvPV_const(*svp, len);
7484 const I32 mode = mode_from_discipline(d, len);
7485 if (mode & O_BINARY)
7486 o->op_private |= OPpOPEN_IN_RAW;
7487 else if (mode & O_TEXT)
7488 o->op_private |= OPpOPEN_IN_CRLF;
7491 svp = hv_fetchs(table, "open_OUT", FALSE);
7494 const char *d = SvPV_const(*svp, len);
7495 const I32 mode = mode_from_discipline(d, len);
7496 if (mode & O_BINARY)
7497 o->op_private |= OPpOPEN_OUT_RAW;
7498 else if (mode & O_TEXT)
7499 o->op_private |= OPpOPEN_OUT_CRLF;
7502 if (o->op_type == OP_BACKTICK) {
7503 if (!(o->op_flags & OPf_KIDS)) {
7504 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7506 op_getmad(o,newop,'O');
7515 /* In case of three-arg dup open remove strictness
7516 * from the last arg if it is a bareword. */
7517 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7518 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7522 if ((last->op_type == OP_CONST) && /* The bareword. */
7523 (last->op_private & OPpCONST_BARE) &&
7524 (last->op_private & OPpCONST_STRICT) &&
7525 (oa = first->op_sibling) && /* The fh. */
7526 (oa = oa->op_sibling) && /* The mode. */
7527 (oa->op_type == OP_CONST) &&
7528 SvPOK(((SVOP*)oa)->op_sv) &&
7529 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7530 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7531 (last == oa->op_sibling)) /* The bareword. */
7532 last->op_private &= ~OPpCONST_STRICT;
7538 Perl_ck_repeat(pTHX_ OP *o)
7540 PERL_ARGS_ASSERT_CK_REPEAT;
7542 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7543 o->op_private |= OPpREPEAT_DOLIST;
7544 cBINOPo->op_first = force_list(cBINOPo->op_first);
7552 Perl_ck_require(pTHX_ OP *o)
7557 PERL_ARGS_ASSERT_CK_REQUIRE;
7559 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7560 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7562 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7563 SV * const sv = kid->op_sv;
7564 U32 was_readonly = SvREADONLY(sv);
7571 sv_force_normal_flags(sv, 0);
7572 assert(!SvREADONLY(sv));
7582 for (; s < end; s++) {
7583 if (*s == ':' && s[1] == ':') {
7585 Move(s+2, s+1, end - s - 1, char);
7590 sv_catpvs(sv, ".pm");
7591 SvFLAGS(sv) |= was_readonly;
7595 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7596 /* handle override, if any */
7597 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7598 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7599 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7600 gv = gvp ? *gvp : NULL;
7604 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7605 OP * const kid = cUNOPo->op_first;
7608 cUNOPo->op_first = 0;
7612 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7613 append_elem(OP_LIST, kid,
7614 scalar(newUNOP(OP_RV2CV, 0,
7617 op_getmad(o,newop,'O');
7625 Perl_ck_return(pTHX_ OP *o)
7630 PERL_ARGS_ASSERT_CK_RETURN;
7632 kid = cLISTOPo->op_first->op_sibling;
7633 if (CvLVALUE(PL_compcv)) {
7634 for (; kid; kid = kid->op_sibling)
7635 mod(kid, OP_LEAVESUBLV);
7637 for (; kid; kid = kid->op_sibling)
7638 if ((kid->op_type == OP_NULL)
7639 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7640 /* This is a do block */
7641 OP *op = kUNOP->op_first;
7642 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7643 op = cUNOPx(op)->op_first;
7644 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7645 /* Force the use of the caller's context */
7646 op->op_flags |= OPf_SPECIAL;
7655 Perl_ck_select(pTHX_ OP *o)
7660 PERL_ARGS_ASSERT_CK_SELECT;
7662 if (o->op_flags & OPf_KIDS) {
7663 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7664 if (kid && kid->op_sibling) {
7665 o->op_type = OP_SSELECT;
7666 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7668 return fold_constants(o);
7672 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7673 if (kid && kid->op_type == OP_RV2GV)
7674 kid->op_private &= ~HINT_STRICT_REFS;
7679 Perl_ck_shift(pTHX_ OP *o)
7682 const I32 type = o->op_type;
7684 PERL_ARGS_ASSERT_CK_SHIFT;
7686 if (!(o->op_flags & OPf_KIDS)) {
7687 OP *argop = newUNOP(OP_RV2AV, 0,
7688 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7690 OP * const oldo = o;
7691 o = newUNOP(type, 0, scalar(argop));
7692 op_getmad(oldo,o,'O');
7696 return newUNOP(type, 0, scalar(argop));
7699 return scalar(modkids(ck_fun(o), type));
7703 Perl_ck_sort(pTHX_ OP *o)
7708 PERL_ARGS_ASSERT_CK_SORT;
7710 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7711 HV * const hinthv = GvHV(PL_hintgv);
7713 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7715 const I32 sorthints = (I32)SvIV(*svp);
7716 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7717 o->op_private |= OPpSORT_QSORT;
7718 if ((sorthints & HINT_SORT_STABLE) != 0)
7719 o->op_private |= OPpSORT_STABLE;
7724 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7726 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7727 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7729 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7731 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7733 if (kid->op_type == OP_SCOPE) {
7737 else if (kid->op_type == OP_LEAVE) {
7738 if (o->op_type == OP_SORT) {
7739 op_null(kid); /* wipe out leave */
7742 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7743 if (k->op_next == kid)
7745 /* don't descend into loops */
7746 else if (k->op_type == OP_ENTERLOOP
7747 || k->op_type == OP_ENTERITER)
7749 k = cLOOPx(k)->op_lastop;
7754 kid->op_next = 0; /* just disconnect the leave */
7755 k = kLISTOP->op_first;
7760 if (o->op_type == OP_SORT) {
7761 /* provide scalar context for comparison function/block */
7767 o->op_flags |= OPf_SPECIAL;
7769 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7772 firstkid = firstkid->op_sibling;
7775 /* provide list context for arguments */
7776 if (o->op_type == OP_SORT)
7783 S_simplify_sort(pTHX_ OP *o)
7786 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7792 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7794 if (!(o->op_flags & OPf_STACKED))
7796 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7797 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7798 kid = kUNOP->op_first; /* get past null */
7799 if (kid->op_type != OP_SCOPE)
7801 kid = kLISTOP->op_last; /* get past scope */
7802 switch(kid->op_type) {
7810 k = kid; /* remember this node*/
7811 if (kBINOP->op_first->op_type != OP_RV2SV)
7813 kid = kBINOP->op_first; /* get past cmp */
7814 if (kUNOP->op_first->op_type != OP_GV)
7816 kid = kUNOP->op_first; /* get past rv2sv */
7818 if (GvSTASH(gv) != PL_curstash)
7820 gvname = GvNAME(gv);
7821 if (*gvname == 'a' && gvname[1] == '\0')
7823 else if (*gvname == 'b' && gvname[1] == '\0')
7828 kid = k; /* back to cmp */
7829 if (kBINOP->op_last->op_type != OP_RV2SV)
7831 kid = kBINOP->op_last; /* down to 2nd arg */
7832 if (kUNOP->op_first->op_type != OP_GV)
7834 kid = kUNOP->op_first; /* get past rv2sv */
7836 if (GvSTASH(gv) != PL_curstash)
7838 gvname = GvNAME(gv);
7840 ? !(*gvname == 'a' && gvname[1] == '\0')
7841 : !(*gvname == 'b' && gvname[1] == '\0'))
7843 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7845 o->op_private |= OPpSORT_DESCEND;
7846 if (k->op_type == OP_NCMP)
7847 o->op_private |= OPpSORT_NUMERIC;
7848 if (k->op_type == OP_I_NCMP)
7849 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7850 kid = cLISTOPo->op_first->op_sibling;
7851 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7853 op_getmad(kid,o,'S'); /* then delete it */
7855 op_free(kid); /* then delete it */
7860 Perl_ck_split(pTHX_ OP *o)
7865 PERL_ARGS_ASSERT_CK_SPLIT;
7867 if (o->op_flags & OPf_STACKED)
7868 return no_fh_allowed(o);
7870 kid = cLISTOPo->op_first;
7871 if (kid->op_type != OP_NULL)
7872 Perl_croak(aTHX_ "panic: ck_split");
7873 kid = kid->op_sibling;
7874 op_free(cLISTOPo->op_first);
7875 cLISTOPo->op_first = kid;
7877 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7878 cLISTOPo->op_last = kid; /* There was only one element previously */
7881 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7882 OP * const sibl = kid->op_sibling;
7883 kid->op_sibling = 0;
7884 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7885 if (cLISTOPo->op_first == cLISTOPo->op_last)
7886 cLISTOPo->op_last = kid;
7887 cLISTOPo->op_first = kid;
7888 kid->op_sibling = sibl;
7891 kid->op_type = OP_PUSHRE;
7892 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7894 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7895 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7896 "Use of /g modifier is meaningless in split");
7899 if (!kid->op_sibling)
7900 append_elem(OP_SPLIT, o, newDEFSVOP());
7902 kid = kid->op_sibling;
7905 if (!kid->op_sibling)
7906 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7907 assert(kid->op_sibling);
7909 kid = kid->op_sibling;
7912 if (kid->op_sibling)
7913 return too_many_arguments(o,OP_DESC(o));
7919 Perl_ck_join(pTHX_ OP *o)
7921 const OP * const kid = cLISTOPo->op_first->op_sibling;
7923 PERL_ARGS_ASSERT_CK_JOIN;
7925 if (kid && kid->op_type == OP_MATCH) {
7926 if (ckWARN(WARN_SYNTAX)) {
7927 const REGEXP *re = PM_GETRE(kPMOP);
7928 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7929 const STRLEN len = re ? RX_PRELEN(re) : 6;
7930 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7931 "/%.*s/ should probably be written as \"%.*s\"",
7932 (int)len, pmstr, (int)len, pmstr);
7939 Perl_ck_subr(pTHX_ OP *o)
7942 OP *prev = ((cUNOPo->op_first->op_sibling)
7943 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7944 OP *o2 = prev->op_sibling;
7946 const char *proto = NULL;
7947 const char *proto_end = NULL;
7952 I32 contextclass = 0;
7953 const char *e = NULL;
7956 PERL_ARGS_ASSERT_CK_SUBR;
7958 o->op_private |= OPpENTERSUB_HASTARG;
7959 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7960 if (cvop->op_type == OP_RV2CV) {
7961 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7962 op_null(cvop); /* disable rv2cv */
7963 if (!(o->op_private & OPpENTERSUB_AMPER)) {
7964 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7966 switch (tmpop->op_type) {
7968 gv = cGVOPx_gv(tmpop);
7971 tmpop->op_private |= OPpEARLY_CV;
7974 SV *sv = cSVOPx_sv(tmpop);
7975 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
7979 if (cv && SvPOK(cv)) {
7981 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
7982 proto = SvPV(MUTABLE_SV(cv), len);
7983 proto_end = proto + len;
7987 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7988 if (o2->op_type == OP_CONST)
7989 o2->op_private &= ~OPpCONST_STRICT;
7990 else if (o2->op_type == OP_LIST) {
7991 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7992 if (sib && sib->op_type == OP_CONST)
7993 sib->op_private &= ~OPpCONST_STRICT;
7996 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7997 if (PERLDB_SUB && PL_curstash != PL_debstash)
7998 o->op_private |= OPpENTERSUB_DB;
7999 while (o2 != cvop) {
8001 if (PL_madskills && o2->op_type == OP_STUB) {
8002 o2 = o2->op_sibling;
8005 if (PL_madskills && o2->op_type == OP_NULL)
8006 o3 = ((UNOP*)o2)->op_first;
8010 if (proto >= proto_end)
8011 return too_many_arguments(o, gv_ename(namegv));
8019 /* _ must be at the end */
8020 if (proto[1] && proto[1] != ';')
8035 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8037 arg == 1 ? "block or sub {}" : "sub {}",
8038 gv_ename(namegv), o3);
8041 /* '*' allows any scalar type, including bareword */
8044 if (o3->op_type == OP_RV2GV)
8045 goto wrapref; /* autoconvert GLOB -> GLOBref */
8046 else if (o3->op_type == OP_CONST)
8047 o3->op_private &= ~OPpCONST_STRICT;
8048 else if (o3->op_type == OP_ENTERSUB) {
8049 /* accidental subroutine, revert to bareword */
8050 OP *gvop = ((UNOP*)o3)->op_first;
8051 if (gvop && gvop->op_type == OP_NULL) {
8052 gvop = ((UNOP*)gvop)->op_first;
8054 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8057 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8058 (gvop = ((UNOP*)gvop)->op_first) &&
8059 gvop->op_type == OP_GV)
8061 GV * const gv = cGVOPx_gv(gvop);
8062 OP * const sibling = o2->op_sibling;
8063 SV * const n = newSVpvs("");
8065 OP * const oldo2 = o2;
8069 gv_fullname4(n, gv, "", FALSE);
8070 o2 = newSVOP(OP_CONST, 0, n);
8071 op_getmad(oldo2,o2,'O');
8072 prev->op_sibling = o2;
8073 o2->op_sibling = sibling;
8089 if (contextclass++ == 0) {
8090 e = strchr(proto, ']');
8091 if (!e || e == proto)
8100 const char *p = proto;
8101 const char *const end = proto;
8103 while (*--p != '[') {}
8104 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8106 gv_ename(namegv), o3);
8111 if (o3->op_type == OP_RV2GV)
8114 bad_type(arg, "symbol", gv_ename(namegv), o3);
8117 if (o3->op_type == OP_ENTERSUB)
8120 bad_type(arg, "subroutine entry", gv_ename(namegv),
8124 if (o3->op_type == OP_RV2SV ||
8125 o3->op_type == OP_PADSV ||
8126 o3->op_type == OP_HELEM ||
8127 o3->op_type == OP_AELEM)
8130 bad_type(arg, "scalar", gv_ename(namegv), o3);
8133 if (o3->op_type == OP_RV2AV ||
8134 o3->op_type == OP_PADAV)
8137 bad_type(arg, "array", gv_ename(namegv), o3);
8140 if (o3->op_type == OP_RV2HV ||
8141 o3->op_type == OP_PADHV)
8144 bad_type(arg, "hash", gv_ename(namegv), o3);
8149 OP* const sib = kid->op_sibling;
8150 kid->op_sibling = 0;
8151 o2 = newUNOP(OP_REFGEN, 0, kid);
8152 o2->op_sibling = sib;
8153 prev->op_sibling = o2;
8155 if (contextclass && e) {
8170 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8171 gv_ename(namegv), SVfARG(cv));
8176 mod(o2, OP_ENTERSUB);
8178 o2 = o2->op_sibling;
8180 if (o2 == cvop && proto && *proto == '_') {
8181 /* generate an access to $_ */
8183 o2->op_sibling = prev->op_sibling;
8184 prev->op_sibling = o2; /* instead of cvop */
8186 if (proto && !optional && proto_end > proto &&
8187 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8188 return too_few_arguments(o, gv_ename(namegv));
8191 OP * const oldo = o;
8195 o=newSVOP(OP_CONST, 0, newSViv(0));
8196 op_getmad(oldo,o,'O');
8202 Perl_ck_svconst(pTHX_ OP *o)
8204 PERL_ARGS_ASSERT_CK_SVCONST;
8205 PERL_UNUSED_CONTEXT;
8206 SvREADONLY_on(cSVOPo->op_sv);
8211 Perl_ck_chdir(pTHX_ OP *o)
8213 if (o->op_flags & OPf_KIDS) {
8214 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8216 if (kid && kid->op_type == OP_CONST &&
8217 (kid->op_private & OPpCONST_BARE))
8219 o->op_flags |= OPf_SPECIAL;
8220 kid->op_private &= ~OPpCONST_STRICT;
8227 Perl_ck_trunc(pTHX_ OP *o)
8229 PERL_ARGS_ASSERT_CK_TRUNC;
8231 if (o->op_flags & OPf_KIDS) {
8232 SVOP *kid = (SVOP*)cUNOPo->op_first;
8234 if (kid->op_type == OP_NULL)
8235 kid = (SVOP*)kid->op_sibling;
8236 if (kid && kid->op_type == OP_CONST &&
8237 (kid->op_private & OPpCONST_BARE))
8239 o->op_flags |= OPf_SPECIAL;
8240 kid->op_private &= ~OPpCONST_STRICT;
8247 Perl_ck_unpack(pTHX_ OP *o)
8249 OP *kid = cLISTOPo->op_first;
8251 PERL_ARGS_ASSERT_CK_UNPACK;
8253 if (kid->op_sibling) {
8254 kid = kid->op_sibling;
8255 if (!kid->op_sibling)
8256 kid->op_sibling = newDEFSVOP();
8262 Perl_ck_substr(pTHX_ OP *o)
8264 PERL_ARGS_ASSERT_CK_SUBSTR;
8267 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8268 OP *kid = cLISTOPo->op_first;
8270 if (kid->op_type == OP_NULL)
8271 kid = kid->op_sibling;
8273 kid->op_flags |= OPf_MOD;
8280 Perl_ck_each(pTHX_ OP *o)
8283 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8285 PERL_ARGS_ASSERT_CK_EACH;
8288 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8289 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8290 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8291 o->op_type = new_type;
8292 o->op_ppaddr = PL_ppaddr[new_type];
8294 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8295 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8297 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8304 /* caller is supposed to assign the return to the
8305 container of the rep_op var */
8307 S_opt_scalarhv(pTHX_ OP *rep_op) {
8310 PERL_ARGS_ASSERT_OPT_SCALARHV;
8312 NewOp(1101, unop, 1, UNOP);
8313 unop->op_type = (OPCODE)OP_BOOLKEYS;
8314 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8315 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8316 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8317 unop->op_first = rep_op;
8318 unop->op_next = rep_op->op_next;
8319 rep_op->op_next = (OP*)unop;
8320 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8321 unop->op_sibling = rep_op->op_sibling;
8322 rep_op->op_sibling = NULL;
8323 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8324 if (rep_op->op_type == OP_PADHV) {
8325 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8326 rep_op->op_flags |= OPf_WANT_LIST;
8331 /* A peephole optimizer. We visit the ops in the order they're to execute.
8332 * See the comments at the top of this file for more details about when
8333 * peep() is called */
8336 Perl_peep(pTHX_ register OP *o)
8339 register OP* oldop = NULL;
8341 if (!o || o->op_opt)
8345 SAVEVPTR(PL_curcop);
8346 for (; o; o = o->op_next) {
8349 /* By default, this op has now been optimised. A couple of cases below
8350 clear this again. */
8353 switch (o->op_type) {
8356 PL_curcop = ((COP*)o); /* for warnings */
8360 if (cSVOPo->op_private & OPpCONST_STRICT)
8361 no_bareword_allowed(o);
8364 case OP_METHOD_NAMED:
8365 /* Relocate sv to the pad for thread safety.
8366 * Despite being a "constant", the SV is written to,
8367 * for reference counts, sv_upgrade() etc. */
8369 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8370 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8371 /* If op_sv is already a PADTMP then it is being used by
8372 * some pad, so make a copy. */
8373 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8374 SvREADONLY_on(PAD_SVl(ix));
8375 SvREFCNT_dec(cSVOPo->op_sv);
8377 else if (o->op_type != OP_METHOD_NAMED
8378 && cSVOPo->op_sv == &PL_sv_undef) {
8379 /* PL_sv_undef is hack - it's unsafe to store it in the
8380 AV that is the pad, because av_fetch treats values of
8381 PL_sv_undef as a "free" AV entry and will merrily
8382 replace them with a new SV, causing pad_alloc to think
8383 that this pad slot is free. (When, clearly, it is not)
8385 SvOK_off(PAD_SVl(ix));
8386 SvPADTMP_on(PAD_SVl(ix));
8387 SvREADONLY_on(PAD_SVl(ix));
8390 SvREFCNT_dec(PAD_SVl(ix));
8391 SvPADTMP_on(cSVOPo->op_sv);
8392 PAD_SETSV(ix, cSVOPo->op_sv);
8393 /* XXX I don't know how this isn't readonly already. */
8394 SvREADONLY_on(PAD_SVl(ix));
8396 cSVOPo->op_sv = NULL;
8403 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8404 if (o->op_next->op_private & OPpTARGET_MY) {
8405 if (o->op_flags & OPf_STACKED) /* chained concats */
8406 break; /* ignore_optimization */
8408 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8409 o->op_targ = o->op_next->op_targ;
8410 o->op_next->op_targ = 0;
8411 o->op_private |= OPpTARGET_MY;
8414 op_null(o->op_next);
8418 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8419 break; /* Scalar stub must produce undef. List stub is noop */
8423 if (o->op_targ == OP_NEXTSTATE
8424 || o->op_targ == OP_DBSTATE)
8426 PL_curcop = ((COP*)o);
8428 /* XXX: We avoid setting op_seq here to prevent later calls
8429 to peep() from mistakenly concluding that optimisation
8430 has already occurred. This doesn't fix the real problem,
8431 though (See 20010220.007). AMS 20010719 */
8432 /* op_seq functionality is now replaced by op_opt */
8439 if (oldop && o->op_next) {
8440 oldop->op_next = o->op_next;
8448 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8449 OP* const pop = (o->op_type == OP_PADAV) ?
8450 o->op_next : o->op_next->op_next;
8452 if (pop && pop->op_type == OP_CONST &&
8453 ((PL_op = pop->op_next)) &&
8454 pop->op_next->op_type == OP_AELEM &&
8455 !(pop->op_next->op_private &
8456 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8457 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8462 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8463 no_bareword_allowed(pop);
8464 if (o->op_type == OP_GV)
8465 op_null(o->op_next);
8466 op_null(pop->op_next);
8468 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8469 o->op_next = pop->op_next->op_next;
8470 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8471 o->op_private = (U8)i;
8472 if (o->op_type == OP_GV) {
8477 o->op_flags |= OPf_SPECIAL;
8478 o->op_type = OP_AELEMFAST;
8483 if (o->op_next->op_type == OP_RV2SV) {
8484 if (!(o->op_next->op_private & OPpDEREF)) {
8485 op_null(o->op_next);
8486 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8488 o->op_next = o->op_next->op_next;
8489 o->op_type = OP_GVSV;
8490 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8493 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8494 GV * const gv = cGVOPo_gv;
8495 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8496 /* XXX could check prototype here instead of just carping */
8497 SV * const sv = sv_newmortal();
8498 gv_efullname3(sv, gv, NULL);
8499 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8500 "%"SVf"() called too early to check prototype",
8504 else if (o->op_next->op_type == OP_READLINE
8505 && o->op_next->op_next->op_type == OP_CONCAT
8506 && (o->op_next->op_next->op_flags & OPf_STACKED))
8508 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8509 o->op_type = OP_RCATLINE;
8510 o->op_flags |= OPf_STACKED;
8511 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8512 op_null(o->op_next->op_next);
8513 op_null(o->op_next);
8523 fop = cUNOP->op_first;
8531 fop = cLOGOP->op_first;
8532 sop = fop->op_sibling;
8533 while (cLOGOP->op_other->op_type == OP_NULL)
8534 cLOGOP->op_other = cLOGOP->op_other->op_next;
8535 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8539 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8541 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8546 if (!(nop->op_flags && OPf_WANT_VOID)) {
8547 while (nop && nop->op_next) {
8548 switch (nop->op_next->op_type) {
8553 lop = nop = nop->op_next;
8564 if (lop->op_flags && OPf_WANT_VOID) {
8565 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8566 cLOGOP->op_first = opt_scalarhv(fop);
8567 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8568 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8584 while (cLOGOP->op_other->op_type == OP_NULL)
8585 cLOGOP->op_other = cLOGOP->op_other->op_next;
8586 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8591 while (cLOOP->op_redoop->op_type == OP_NULL)
8592 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8593 peep(cLOOP->op_redoop);
8594 while (cLOOP->op_nextop->op_type == OP_NULL)
8595 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8596 peep(cLOOP->op_nextop);
8597 while (cLOOP->op_lastop->op_type == OP_NULL)
8598 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8599 peep(cLOOP->op_lastop);
8603 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8604 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8605 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8606 cPMOP->op_pmstashstartu.op_pmreplstart
8607 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8608 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8612 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8613 && ckWARN(WARN_SYNTAX))
8615 if (o->op_next->op_sibling) {
8616 const OPCODE type = o->op_next->op_sibling->op_type;
8617 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8618 const line_t oldline = CopLINE(PL_curcop);
8619 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8620 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8621 "Statement unlikely to be reached");
8622 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8623 "\t(Maybe you meant system() when you said exec()?)\n");
8624 CopLINE_set(PL_curcop, oldline);
8635 const char *key = NULL;
8638 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8641 /* Make the CONST have a shared SV */
8642 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8643 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8644 key = SvPV_const(sv, keylen);
8645 lexname = newSVpvn_share(key,
8646 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8652 if ((o->op_private & (OPpLVAL_INTRO)))
8655 rop = (UNOP*)((BINOP*)o)->op_first;
8656 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8658 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8659 if (!SvPAD_TYPED(lexname))
8661 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8662 if (!fields || !GvHV(*fields))
8664 key = SvPV_const(*svp, keylen);
8665 if (!hv_fetch(GvHV(*fields), key,
8666 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8668 Perl_croak(aTHX_ "No such class field \"%s\" "
8669 "in variable %s of type %s",
8670 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8683 SVOP *first_key_op, *key_op;
8685 if ((o->op_private & (OPpLVAL_INTRO))
8686 /* I bet there's always a pushmark... */
8687 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8688 /* hmmm, no optimization if list contains only one key. */
8690 rop = (UNOP*)((LISTOP*)o)->op_last;
8691 if (rop->op_type != OP_RV2HV)
8693 if (rop->op_first->op_type == OP_PADSV)
8694 /* @$hash{qw(keys here)} */
8695 rop = (UNOP*)rop->op_first;
8697 /* @{$hash}{qw(keys here)} */
8698 if (rop->op_first->op_type == OP_SCOPE
8699 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8701 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8707 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8708 if (!SvPAD_TYPED(lexname))
8710 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8711 if (!fields || !GvHV(*fields))
8713 /* Again guessing that the pushmark can be jumped over.... */
8714 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8715 ->op_first->op_sibling;
8716 for (key_op = first_key_op; key_op;
8717 key_op = (SVOP*)key_op->op_sibling) {
8718 if (key_op->op_type != OP_CONST)
8720 svp = cSVOPx_svp(key_op);
8721 key = SvPV_const(*svp, keylen);
8722 if (!hv_fetch(GvHV(*fields), key,
8723 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8725 Perl_croak(aTHX_ "No such class field \"%s\" "
8726 "in variable %s of type %s",
8727 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8734 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8738 /* check that RHS of sort is a single plain array */
8739 OP *oright = cUNOPo->op_first;
8740 if (!oright || oright->op_type != OP_PUSHMARK)
8743 /* reverse sort ... can be optimised. */
8744 if (!cUNOPo->op_sibling) {
8745 /* Nothing follows us on the list. */
8746 OP * const reverse = o->op_next;
8748 if (reverse->op_type == OP_REVERSE &&
8749 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8750 OP * const pushmark = cUNOPx(reverse)->op_first;
8751 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8752 && (cUNOPx(pushmark)->op_sibling == o)) {
8753 /* reverse -> pushmark -> sort */
8754 o->op_private |= OPpSORT_REVERSE;
8756 pushmark->op_next = oright->op_next;
8762 /* make @a = sort @a act in-place */
8764 oright = cUNOPx(oright)->op_sibling;
8767 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8768 oright = cUNOPx(oright)->op_sibling;
8772 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8773 || oright->op_next != o
8774 || (oright->op_private & OPpLVAL_INTRO)
8778 /* o2 follows the chain of op_nexts through the LHS of the
8779 * assign (if any) to the aassign op itself */
8781 if (!o2 || o2->op_type != OP_NULL)
8784 if (!o2 || o2->op_type != OP_PUSHMARK)
8787 if (o2 && o2->op_type == OP_GV)
8790 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8791 || (o2->op_private & OPpLVAL_INTRO)
8796 if (!o2 || o2->op_type != OP_NULL)
8799 if (!o2 || o2->op_type != OP_AASSIGN
8800 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8803 /* check that the sort is the first arg on RHS of assign */
8805 o2 = cUNOPx(o2)->op_first;
8806 if (!o2 || o2->op_type != OP_NULL)
8808 o2 = cUNOPx(o2)->op_first;
8809 if (!o2 || o2->op_type != OP_PUSHMARK)
8811 if (o2->op_sibling != o)
8814 /* check the array is the same on both sides */
8815 if (oleft->op_type == OP_RV2AV) {
8816 if (oright->op_type != OP_RV2AV
8817 || !cUNOPx(oright)->op_first
8818 || cUNOPx(oright)->op_first->op_type != OP_GV
8819 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8820 cGVOPx_gv(cUNOPx(oright)->op_first)
8824 else if (oright->op_type != OP_PADAV
8825 || oright->op_targ != oleft->op_targ
8829 /* transfer MODishness etc from LHS arg to RHS arg */
8830 oright->op_flags = oleft->op_flags;
8831 o->op_private |= OPpSORT_INPLACE;
8833 /* excise push->gv->rv2av->null->aassign */
8834 o2 = o->op_next->op_next;
8835 op_null(o2); /* PUSHMARK */
8837 if (o2->op_type == OP_GV) {
8838 op_null(o2); /* GV */
8841 op_null(o2); /* RV2AV or PADAV */
8842 o2 = o2->op_next->op_next;
8843 op_null(o2); /* AASSIGN */
8845 o->op_next = o2->op_next;
8851 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8853 LISTOP *enter, *exlist;
8855 enter = (LISTOP *) o->op_next;
8858 if (enter->op_type == OP_NULL) {
8859 enter = (LISTOP *) enter->op_next;
8863 /* for $a (...) will have OP_GV then OP_RV2GV here.
8864 for (...) just has an OP_GV. */
8865 if (enter->op_type == OP_GV) {
8866 gvop = (OP *) enter;
8867 enter = (LISTOP *) enter->op_next;
8870 if (enter->op_type == OP_RV2GV) {
8871 enter = (LISTOP *) enter->op_next;
8877 if (enter->op_type != OP_ENTERITER)
8880 iter = enter->op_next;
8881 if (!iter || iter->op_type != OP_ITER)
8884 expushmark = enter->op_first;
8885 if (!expushmark || expushmark->op_type != OP_NULL
8886 || expushmark->op_targ != OP_PUSHMARK)
8889 exlist = (LISTOP *) expushmark->op_sibling;
8890 if (!exlist || exlist->op_type != OP_NULL
8891 || exlist->op_targ != OP_LIST)
8894 if (exlist->op_last != o) {
8895 /* Mmm. Was expecting to point back to this op. */
8898 theirmark = exlist->op_first;
8899 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8902 if (theirmark->op_sibling != o) {
8903 /* There's something between the mark and the reverse, eg
8904 for (1, reverse (...))
8909 ourmark = ((LISTOP *)o)->op_first;
8910 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8913 ourlast = ((LISTOP *)o)->op_last;
8914 if (!ourlast || ourlast->op_next != o)
8917 rv2av = ourmark->op_sibling;
8918 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8919 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8920 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8921 /* We're just reversing a single array. */
8922 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8923 enter->op_flags |= OPf_STACKED;
8926 /* We don't have control over who points to theirmark, so sacrifice
8928 theirmark->op_next = ourmark->op_next;
8929 theirmark->op_flags = ourmark->op_flags;
8930 ourlast->op_next = gvop ? gvop : (OP *) enter;
8933 enter->op_private |= OPpITER_REVERSED;
8934 iter->op_private |= OPpITER_REVERSED;
8941 UNOP *refgen, *rv2cv;
8944 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8947 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8950 rv2gv = ((BINOP *)o)->op_last;
8951 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8954 refgen = (UNOP *)((BINOP *)o)->op_first;
8956 if (!refgen || refgen->op_type != OP_REFGEN)
8959 exlist = (LISTOP *)refgen->op_first;
8960 if (!exlist || exlist->op_type != OP_NULL
8961 || exlist->op_targ != OP_LIST)
8964 if (exlist->op_first->op_type != OP_PUSHMARK)
8967 rv2cv = (UNOP*)exlist->op_last;
8969 if (rv2cv->op_type != OP_RV2CV)
8972 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8973 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8974 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8976 o->op_private |= OPpASSIGN_CV_TO_GV;
8977 rv2gv->op_private |= OPpDONT_INIT_GV;
8978 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8986 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8987 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8997 Perl_custom_op_name(pTHX_ const OP* o)
9000 const IV index = PTR2IV(o->op_ppaddr);
9004 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9006 if (!PL_custom_op_names) /* This probably shouldn't happen */
9007 return (char *)PL_op_name[OP_CUSTOM];
9009 keysv = sv_2mortal(newSViv(index));
9011 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9013 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9015 return SvPV_nolen(HeVAL(he));
9019 Perl_custom_op_desc(pTHX_ const OP* o)
9022 const IV index = PTR2IV(o->op_ppaddr);
9026 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9028 if (!PL_custom_op_descs)
9029 return (char *)PL_op_desc[OP_CUSTOM];
9031 keysv = sv_2mortal(newSViv(index));
9033 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9035 return (char *)PL_op_desc[OP_CUSTOM];
9037 return SvPV_nolen(HeVAL(he));
9042 /* Efficient sub that returns a constant scalar value. */
9044 const_sv_xsub(pTHX_ CV* cv)
9048 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9052 /* diag_listed_as: SKIPME */
9053 Perl_croak(aTHX_ "usage: %s::%s()",
9054 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9067 * c-indentation-style: bsd
9069 * indent-tabs-mode: t
9072 * ex: set ts=8 sts=4 sw=4 noet: