3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me.' --the Gaffer
18 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
21 /* This file contains the functions that create, manipulate and optimize
22 * the OP structures that hold a compiled perl program.
24 * A Perl program is compiled into a tree of OPs. Each op contains
25 * structural pointers (eg to its siblings and the next op in the
26 * execution sequence), a pointer to the function that would execute the
27 * op, plus any data specific to that op. For example, an OP_CONST op
28 * points to the pp_const() function and to an SV containing the constant
29 * value. When pp_const() is executed, its job is to push that SV onto the
32 * OPs are mainly created by the newFOO() functions, which are mainly
33 * called from the parser (in perly.y) as the code is parsed. For example
34 * the Perl code $a + $b * $c would cause the equivalent of the following
35 * to be called (oversimplifying a bit):
37 * newBINOP(OP_ADD, flags,
39 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
42 * Note that during the build of miniperl, a temporary copy of this file
43 * is made, called opmini.c.
47 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
51 An execution-order pass
53 The bottom-up pass is represented by all the "newOP" routines and
54 the ck_ routines. The bottom-upness is actually driven by yacc.
55 So at the point that a ck_ routine fires, we have no idea what the
56 context is, either upward in the syntax tree, or either forward or
57 backward in the execution order. (The bottom-up parser builds that
58 part of the execution order it knows about, but if you follow the "next"
59 links around, you'll find it's actually a closed loop through the
62 Whenever the bottom-up parser gets to a node that supplies context to
63 its components, it invokes that portion of the top-down pass that applies
64 to that part of the subtree (and marks the top node as processed, so
65 if a node further up supplies context, it doesn't have to take the
66 plunge again). As a particular subcase of this, as the new node is
67 built, it takes all the closed execution loops of its subcomponents
68 and links them into a new closed loop for the higher level node. But
69 it's still not the real execution order.
71 The actual execution order is not known till we get a grammar reduction
72 to a top-level unit like a subroutine or file that will be called by
73 "name" rather than via a "next" pointer. At that point, we can call
74 into peep() to do that code's portion of the 3rd pass. It has to be
75 recursive, but it's recursive on basic blocks, not on tree nodes.
78 /* To implement user lexical pragmas, there needs to be a way at run time to
79 get the compile time state of %^H for that block. Storing %^H in every
80 block (or even COP) would be very expensive, so a different approach is
81 taken. The (running) state of %^H is serialised into a tree of HE-like
82 structs. Stores into %^H are chained onto the current leaf as a struct
83 refcounted_he * with the key and the value. Deletes from %^H are saved
84 with a value of PL_sv_placeholder. The state of %^H at any point can be
85 turned back into a regular HV by walking back up the tree from that point's
86 leaf, ignoring any key you've already seen (placeholder or not), storing
87 the rest into the HV structure, then removing the placeholders. Hence
88 memory is only used to store the %^H deltas from the enclosing COP, rather
89 than the entire %^H on each COP.
91 To cause actions on %^H to write out the serialisation records, it has
92 magic type 'H'. This magic (itself) does nothing, but its presence causes
93 the values to gain magic type 'h', which has entries for set and clear.
94 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
95 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
96 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
97 it will be correctly restored when any inner compiling scope is exited.
103 #include "keywords.h"
105 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
106 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
108 #if defined(PL_OP_SLAB_ALLOC)
110 #ifdef PERL_DEBUG_READONLY_OPS
111 # define PERL_SLAB_SIZE 4096
112 # include <sys/mman.h>
115 #ifndef PERL_SLAB_SIZE
116 #define PERL_SLAB_SIZE 2048
120 Perl_Slab_Alloc(pTHX_ size_t sz)
124 * To make incrementing use count easy PL_OpSlab is an I32 *
125 * To make inserting the link to slab PL_OpPtr is I32 **
126 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
127 * Add an overhead for pointer to slab and round up as a number of pointers
129 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
130 if ((PL_OpSpace -= sz) < 0) {
131 #ifdef PERL_DEBUG_READONLY_OPS
132 /* We need to allocate chunk by chunk so that we can control the VM
134 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
135 MAP_ANON|MAP_PRIVATE, -1, 0);
137 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
138 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
140 if(PL_OpPtr == MAP_FAILED) {
141 perror("mmap failed");
146 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
151 /* We reserve the 0'th I32 sized chunk as a use count */
152 PL_OpSlab = (I32 *) PL_OpPtr;
153 /* Reduce size by the use count word, and by the size we need.
154 * Latter is to mimic the '-=' in the if() above
156 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
157 /* Allocation pointer starts at the top.
158 Theory: because we build leaves before trunk allocating at end
159 means that at run time access is cache friendly upward
161 PL_OpPtr += PERL_SLAB_SIZE;
163 #ifdef PERL_DEBUG_READONLY_OPS
164 /* We remember this slab. */
165 /* This implementation isn't efficient, but it is simple. */
166 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
167 PL_slabs[PL_slab_count++] = PL_OpSlab;
168 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
171 assert( PL_OpSpace >= 0 );
172 /* Move the allocation pointer down */
174 assert( PL_OpPtr > (I32 **) PL_OpSlab );
175 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
176 (*PL_OpSlab)++; /* Increment use count of slab */
177 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
178 assert( *PL_OpSlab > 0 );
179 return (void *)(PL_OpPtr + 1);
182 #ifdef PERL_DEBUG_READONLY_OPS
184 Perl_pending_Slabs_to_ro(pTHX) {
185 /* Turn all the allocated op slabs read only. */
186 U32 count = PL_slab_count;
187 I32 **const slabs = PL_slabs;
189 /* Reset the array of pending OP slabs, as we're about to turn this lot
190 read only. Also, do it ahead of the loop in case the warn triggers,
191 and a warn handler has an eval */
196 /* Force a new slab for any further allocation. */
200 void *const start = slabs[count];
201 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
202 if(mprotect(start, size, PROT_READ)) {
203 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
204 start, (unsigned long) size, errno);
212 S_Slab_to_rw(pTHX_ void *op)
214 I32 * const * const ptr = (I32 **) op;
215 I32 * const slab = ptr[-1];
217 PERL_ARGS_ASSERT_SLAB_TO_RW;
219 assert( ptr-1 > (I32 **) slab );
220 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
222 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
223 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
224 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
229 Perl_op_refcnt_inc(pTHX_ OP *o)
240 Perl_op_refcnt_dec(pTHX_ OP *o)
242 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
247 # define Slab_to_rw(op)
251 Perl_Slab_Free(pTHX_ void *op)
253 I32 * const * const ptr = (I32 **) op;
254 I32 * const slab = ptr[-1];
255 PERL_ARGS_ASSERT_SLAB_FREE;
256 assert( ptr-1 > (I32 **) slab );
257 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
260 if (--(*slab) == 0) {
262 # define PerlMemShared PerlMem
265 #ifdef PERL_DEBUG_READONLY_OPS
266 U32 count = PL_slab_count;
267 /* Need to remove this slab from our list of slabs */
270 if (PL_slabs[count] == slab) {
272 /* Found it. Move the entry at the end to overwrite it. */
273 DEBUG_m(PerlIO_printf(Perl_debug_log,
274 "Deallocate %p by moving %p from %lu to %lu\n",
276 PL_slabs[PL_slab_count - 1],
277 PL_slab_count, count));
278 PL_slabs[count] = PL_slabs[--PL_slab_count];
279 /* Could realloc smaller at this point, but probably not
281 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
282 perror("munmap failed");
290 PerlMemShared_free(slab);
292 if (slab == PL_OpSlab) {
299 * In the following definition, the ", (OP*)0" is just to make the compiler
300 * think the expression is of the right type: croak actually does a Siglongjmp.
302 #define CHECKOP(type,o) \
303 ((PL_op_mask && PL_op_mask[type]) \
304 ? ( op_free((OP*)o), \
305 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
307 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
309 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
312 S_gv_ename(pTHX_ GV *gv)
314 SV* const tmpsv = sv_newmortal();
316 PERL_ARGS_ASSERT_GV_ENAME;
318 gv_efullname3(tmpsv, gv, NULL);
319 return SvPV_nolen_const(tmpsv);
323 S_no_fh_allowed(pTHX_ OP *o)
325 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
327 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
333 S_too_few_arguments(pTHX_ OP *o, const char *name)
335 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
337 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
342 S_too_many_arguments(pTHX_ OP *o, const char *name)
344 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
346 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
351 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
353 PERL_ARGS_ASSERT_BAD_TYPE;
355 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
356 (int)n, name, t, OP_DESC(kid)));
360 S_no_bareword_allowed(pTHX_ const OP *o)
362 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
365 return; /* various ok barewords are hidden in extra OP_NULL */
366 qerror(Perl_mess(aTHX_
367 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
371 /* "register" allocation */
374 Perl_allocmy(pTHX_ const char *const name)
378 const bool is_our = (PL_parser->in_my == KEY_our);
380 PERL_ARGS_ASSERT_ALLOCMY;
382 /* complain about "my $<special_var>" etc etc */
386 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
387 (name[1] == '_' && (*name == '$' || name[2]))))
389 /* name[2] is true if strlen(name) > 2 */
390 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
391 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
392 name[0], toCTRL(name[1]), name + 2,
393 PL_parser->in_my == KEY_state ? "state" : "my"));
395 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
396 PL_parser->in_my == KEY_state ? "state" : "my"));
400 /* check for duplicate declaration */
401 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
403 /* allocate a spare slot and store the name in that slot */
405 off = pad_add_name(name,
406 PL_parser->in_my_stash,
408 /* $_ is always in main::, even with our */
409 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
413 PL_parser->in_my == KEY_state
415 /* anon sub prototypes contains state vars should always be cloned,
416 * otherwise the state var would be shared between anon subs */
418 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
419 CvCLONE_on(PL_compcv);
424 /* free the body of an op without examining its contents.
425 * Always use this rather than FreeOp directly */
428 S_op_destroy(pTHX_ OP *o)
430 if (o->op_latefree) {
438 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
440 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
446 Perl_op_free(pTHX_ OP *o)
453 if (o->op_latefreed) {
460 if (o->op_private & OPpREFCOUNTED) {
471 refcnt = OpREFCNT_dec(o);
474 /* Need to find and remove any pattern match ops from the list
475 we maintain for reset(). */
476 find_and_forget_pmops(o);
486 /* Call the op_free hook if it has been set. Do it now so that it's called
487 * at the right time for refcounted ops, but still before all of the kids
491 if (o->op_flags & OPf_KIDS) {
492 register OP *kid, *nextkid;
493 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
494 nextkid = kid->op_sibling; /* Get before next freeing kid */
499 #ifdef PERL_DEBUG_READONLY_OPS
503 /* COP* is not cleared by op_clear() so that we may track line
504 * numbers etc even after null() */
505 if (type == OP_NEXTSTATE || type == OP_DBSTATE
506 || (type == OP_NULL /* the COP might have been null'ed */
507 && ((OPCODE)o->op_targ == OP_NEXTSTATE
508 || (OPCODE)o->op_targ == OP_DBSTATE))) {
513 type = (OPCODE)o->op_targ;
516 if (o->op_latefree) {
522 #ifdef DEBUG_LEAKING_SCALARS
529 Perl_op_clear(pTHX_ OP *o)
534 PERL_ARGS_ASSERT_OP_CLEAR;
537 /* if (o->op_madprop && o->op_madprop->mad_next)
539 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
540 "modification of a read only value" for a reason I can't fathom why.
541 It's the "" stringification of $_, where $_ was set to '' in a foreach
542 loop, but it defies simplification into a small test case.
543 However, commenting them out has caused ext/List/Util/t/weak.t to fail
546 mad_free(o->op_madprop);
552 switch (o->op_type) {
553 case OP_NULL: /* Was holding old type, if any. */
554 if (PL_madskills && o->op_targ != OP_NULL) {
555 o->op_type = (Optype)o->op_targ;
559 case OP_ENTEREVAL: /* Was holding hints. */
563 if (!(o->op_flags & OPf_REF)
564 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
570 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
571 /* not an OP_PADAV replacement */
573 if (cPADOPo->op_padix > 0) {
574 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
575 * may still exist on the pad */
576 pad_swipe(cPADOPo->op_padix, TRUE);
577 cPADOPo->op_padix = 0;
580 SvREFCNT_dec(cSVOPo->op_sv);
581 cSVOPo->op_sv = NULL;
585 case OP_METHOD_NAMED:
588 SvREFCNT_dec(cSVOPo->op_sv);
589 cSVOPo->op_sv = NULL;
592 Even if op_clear does a pad_free for the target of the op,
593 pad_free doesn't actually remove the sv that exists in the pad;
594 instead it lives on. This results in that it could be reused as
595 a target later on when the pad was reallocated.
598 pad_swipe(o->op_targ,1);
607 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
611 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
613 if (cPADOPo->op_padix > 0) {
614 pad_swipe(cPADOPo->op_padix, TRUE);
615 cPADOPo->op_padix = 0;
618 SvREFCNT_dec(cSVOPo->op_sv);
619 cSVOPo->op_sv = NULL;
623 PerlMemShared_free(cPVOPo->op_pv);
624 cPVOPo->op_pv = NULL;
628 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
632 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
633 /* No GvIN_PAD_off here, because other references may still
634 * exist on the pad */
635 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
638 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
644 forget_pmop(cPMOPo, 1);
645 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
646 /* we use the same protection as the "SAFE" version of the PM_ macros
647 * here since sv_clean_all might release some PMOPs
648 * after PL_regex_padav has been cleared
649 * and the clearing of PL_regex_padav needs to
650 * happen before sv_clean_all
653 if(PL_regex_pad) { /* We could be in destruction */
654 const IV offset = (cPMOPo)->op_pmoffset;
655 ReREFCNT_dec(PM_GETRE(cPMOPo));
656 PL_regex_pad[offset] = &PL_sv_undef;
657 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
661 ReREFCNT_dec(PM_GETRE(cPMOPo));
662 PM_SETRE(cPMOPo, NULL);
668 if (o->op_targ > 0) {
669 pad_free(o->op_targ);
675 S_cop_free(pTHX_ COP* cop)
677 PERL_ARGS_ASSERT_COP_FREE;
681 if (! specialWARN(cop->cop_warnings))
682 PerlMemShared_free(cop->cop_warnings);
683 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
687 S_forget_pmop(pTHX_ PMOP *const o
693 HV * const pmstash = PmopSTASH(o);
695 PERL_ARGS_ASSERT_FORGET_PMOP;
697 if (pmstash && !SvIS_FREED(pmstash)) {
698 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
700 PMOP **const array = (PMOP**) mg->mg_ptr;
701 U32 count = mg->mg_len / sizeof(PMOP**);
706 /* Found it. Move the entry at the end to overwrite it. */
707 array[i] = array[--count];
708 mg->mg_len = count * sizeof(PMOP**);
709 /* Could realloc smaller at this point always, but probably
710 not worth it. Probably worth free()ing if we're the
713 Safefree(mg->mg_ptr);
730 S_find_and_forget_pmops(pTHX_ OP *o)
732 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
734 if (o->op_flags & OPf_KIDS) {
735 OP *kid = cUNOPo->op_first;
737 switch (kid->op_type) {
742 forget_pmop((PMOP*)kid, 0);
744 find_and_forget_pmops(kid);
745 kid = kid->op_sibling;
751 Perl_op_null(pTHX_ OP *o)
755 PERL_ARGS_ASSERT_OP_NULL;
757 if (o->op_type == OP_NULL)
761 o->op_targ = o->op_type;
762 o->op_type = OP_NULL;
763 o->op_ppaddr = PL_ppaddr[OP_NULL];
767 Perl_op_refcnt_lock(pTHX)
775 Perl_op_refcnt_unlock(pTHX)
782 /* Contextualizers */
784 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
787 S_linklist(pTHX_ OP *o)
791 PERL_ARGS_ASSERT_LINKLIST;
796 /* establish postfix order */
797 first = cUNOPo->op_first;
800 o->op_next = LINKLIST(first);
803 if (kid->op_sibling) {
804 kid->op_next = LINKLIST(kid->op_sibling);
805 kid = kid->op_sibling;
819 S_scalarkids(pTHX_ OP *o)
821 if (o && o->op_flags & OPf_KIDS) {
823 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
830 S_scalarboolean(pTHX_ OP *o)
834 PERL_ARGS_ASSERT_SCALARBOOLEAN;
836 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
837 if (ckWARN(WARN_SYNTAX)) {
838 const line_t oldline = CopLINE(PL_curcop);
840 if (PL_parser && PL_parser->copline != NOLINE)
841 CopLINE_set(PL_curcop, PL_parser->copline);
842 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
843 CopLINE_set(PL_curcop, oldline);
850 Perl_scalar(pTHX_ OP *o)
855 /* assumes no premature commitment */
856 if (!o || (PL_parser && PL_parser->error_count)
857 || (o->op_flags & OPf_WANT)
858 || o->op_type == OP_RETURN)
863 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
865 switch (o->op_type) {
867 scalar(cBINOPo->op_first);
872 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
882 if (o->op_flags & OPf_KIDS) {
883 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
889 kid = cLISTOPo->op_first;
891 while ((kid = kid->op_sibling)) {
897 PL_curcop = &PL_compiling;
902 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
908 PL_curcop = &PL_compiling;
911 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
918 Perl_scalarvoid(pTHX_ OP *o)
922 const char* useless = NULL;
926 PERL_ARGS_ASSERT_SCALARVOID;
928 /* trailing mad null ops don't count as "there" for void processing */
930 o->op_type != OP_NULL &&
932 o->op_sibling->op_type == OP_NULL)
935 for (sib = o->op_sibling;
936 sib && sib->op_type == OP_NULL;
937 sib = sib->op_sibling) ;
943 if (o->op_type == OP_NEXTSTATE
944 || o->op_type == OP_DBSTATE
945 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
946 || o->op_targ == OP_DBSTATE)))
947 PL_curcop = (COP*)o; /* for warning below */
949 /* assumes no premature commitment */
950 want = o->op_flags & OPf_WANT;
951 if ((want && want != OPf_WANT_SCALAR)
952 || (PL_parser && PL_parser->error_count)
953 || o->op_type == OP_RETURN)
958 if ((o->op_private & OPpTARGET_MY)
959 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
961 return scalar(o); /* As if inside SASSIGN */
964 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
966 switch (o->op_type) {
968 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
972 if (o->op_flags & OPf_STACKED)
976 if (o->op_private == 4)
1019 case OP_GETSOCKNAME:
1020 case OP_GETPEERNAME:
1025 case OP_GETPRIORITY:
1049 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1050 /* Otherwise it's "Useless use of grep iterator" */
1051 useless = OP_DESC(o);
1055 kid = cUNOPo->op_first;
1056 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1057 kid->op_type != OP_TRANS) {
1060 useless = "negative pattern binding (!~)";
1067 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1068 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1069 useless = "a variable";
1074 if (cSVOPo->op_private & OPpCONST_STRICT)
1075 no_bareword_allowed(o);
1077 if (ckWARN(WARN_VOID)) {
1079 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1080 "a constant (%"SVf")", sv));
1081 useless = SvPV_nolen(msv);
1084 useless = "a constant (undef)";
1085 if (o->op_private & OPpCONST_ARYBASE)
1087 /* don't warn on optimised away booleans, eg
1088 * use constant Foo, 5; Foo || print; */
1089 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1091 /* the constants 0 and 1 are permitted as they are
1092 conventionally used as dummies in constructs like
1093 1 while some_condition_with_side_effects; */
1094 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1096 else if (SvPOK(sv)) {
1097 /* perl4's way of mixing documentation and code
1098 (before the invention of POD) was based on a
1099 trick to mix nroff and perl code. The trick was
1100 built upon these three nroff macros being used in
1101 void context. The pink camel has the details in
1102 the script wrapman near page 319. */
1103 const char * const maybe_macro = SvPVX_const(sv);
1104 if (strnEQ(maybe_macro, "di", 2) ||
1105 strnEQ(maybe_macro, "ds", 2) ||
1106 strnEQ(maybe_macro, "ig", 2))
1111 op_null(o); /* don't execute or even remember it */
1115 o->op_type = OP_PREINC; /* pre-increment is faster */
1116 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1120 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1121 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1125 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1126 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1130 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1131 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1136 kid = cLOGOPo->op_first;
1137 if (kid->op_type == OP_NOT
1138 && (kid->op_flags & OPf_KIDS)
1140 if (o->op_type == OP_AND) {
1142 o->op_ppaddr = PL_ppaddr[OP_OR];
1144 o->op_type = OP_AND;
1145 o->op_ppaddr = PL_ppaddr[OP_AND];
1154 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1159 if (o->op_flags & OPf_STACKED)
1166 if (!(o->op_flags & OPf_KIDS))
1177 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1184 /* all requires must return a boolean value */
1185 o->op_flags &= ~OPf_WANT;
1191 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1196 S_listkids(pTHX_ OP *o)
1198 if (o && o->op_flags & OPf_KIDS) {
1200 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1207 Perl_list(pTHX_ OP *o)
1212 /* assumes no premature commitment */
1213 if (!o || (o->op_flags & OPf_WANT)
1214 || (PL_parser && PL_parser->error_count)
1215 || o->op_type == OP_RETURN)
1220 if ((o->op_private & OPpTARGET_MY)
1221 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1223 return o; /* As if inside SASSIGN */
1226 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1228 switch (o->op_type) {
1231 list(cBINOPo->op_first);
1236 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1244 if (!(o->op_flags & OPf_KIDS))
1246 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1247 list(cBINOPo->op_first);
1248 return gen_constant_list(o);
1255 kid = cLISTOPo->op_first;
1257 while ((kid = kid->op_sibling)) {
1258 if (kid->op_sibling)
1263 PL_curcop = &PL_compiling;
1267 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1268 if (kid->op_sibling)
1273 PL_curcop = &PL_compiling;
1276 /* all requires must return a boolean value */
1277 o->op_flags &= ~OPf_WANT;
1284 S_scalarseq(pTHX_ OP *o)
1288 const OPCODE type = o->op_type;
1290 if (type == OP_LINESEQ || type == OP_SCOPE ||
1291 type == OP_LEAVE || type == OP_LEAVETRY)
1294 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1295 if (kid->op_sibling) {
1299 PL_curcop = &PL_compiling;
1301 o->op_flags &= ~OPf_PARENS;
1302 if (PL_hints & HINT_BLOCK_SCOPE)
1303 o->op_flags |= OPf_PARENS;
1306 o = newOP(OP_STUB, 0);
1311 S_modkids(pTHX_ OP *o, I32 type)
1313 if (o && o->op_flags & OPf_KIDS) {
1315 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1321 /* Propagate lvalue ("modifiable") context to an op and its children.
1322 * 'type' represents the context type, roughly based on the type of op that
1323 * would do the modifying, although local() is represented by OP_NULL.
1324 * It's responsible for detecting things that can't be modified, flag
1325 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1326 * might have to vivify a reference in $x), and so on.
1328 * For example, "$a+1 = 2" would cause mod() to be called with o being
1329 * OP_ADD and type being OP_SASSIGN, and would output an error.
1333 Perl_mod(pTHX_ OP *o, I32 type)
1337 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1340 if (!o || (PL_parser && PL_parser->error_count))
1343 if ((o->op_private & OPpTARGET_MY)
1344 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1349 switch (o->op_type) {
1355 if (!(o->op_private & OPpCONST_ARYBASE))
1358 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1359 CopARYBASE_set(&PL_compiling,
1360 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1364 SAVECOPARYBASE(&PL_compiling);
1365 CopARYBASE_set(&PL_compiling, 0);
1367 else if (type == OP_REFGEN)
1370 Perl_croak(aTHX_ "That use of $[ is unsupported");
1373 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1377 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1378 !(o->op_flags & OPf_STACKED)) {
1379 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1380 /* The default is to set op_private to the number of children,
1381 which for a UNOP such as RV2CV is always 1. And w're using
1382 the bit for a flag in RV2CV, so we need it clear. */
1383 o->op_private &= ~1;
1384 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1385 assert(cUNOPo->op_first->op_type == OP_NULL);
1386 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1389 else if (o->op_private & OPpENTERSUB_NOMOD)
1391 else { /* lvalue subroutine call */
1392 o->op_private |= OPpLVAL_INTRO;
1393 PL_modcount = RETURN_UNLIMITED_NUMBER;
1394 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1395 /* Backward compatibility mode: */
1396 o->op_private |= OPpENTERSUB_INARGS;
1399 else { /* Compile-time error message: */
1400 OP *kid = cUNOPo->op_first;
1404 if (kid->op_type != OP_PUSHMARK) {
1405 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1407 "panic: unexpected lvalue entersub "
1408 "args: type/targ %ld:%"UVuf,
1409 (long)kid->op_type, (UV)kid->op_targ);
1410 kid = kLISTOP->op_first;
1412 while (kid->op_sibling)
1413 kid = kid->op_sibling;
1414 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1416 if (kid->op_type == OP_METHOD_NAMED
1417 || kid->op_type == OP_METHOD)
1421 NewOp(1101, newop, 1, UNOP);
1422 newop->op_type = OP_RV2CV;
1423 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1424 newop->op_first = NULL;
1425 newop->op_next = (OP*)newop;
1426 kid->op_sibling = (OP*)newop;
1427 newop->op_private |= OPpLVAL_INTRO;
1428 newop->op_private &= ~1;
1432 if (kid->op_type != OP_RV2CV)
1434 "panic: unexpected lvalue entersub "
1435 "entry via type/targ %ld:%"UVuf,
1436 (long)kid->op_type, (UV)kid->op_targ);
1437 kid->op_private |= OPpLVAL_INTRO;
1438 break; /* Postpone until runtime */
1442 kid = kUNOP->op_first;
1443 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1444 kid = kUNOP->op_first;
1445 if (kid->op_type == OP_NULL)
1447 "Unexpected constant lvalue entersub "
1448 "entry via type/targ %ld:%"UVuf,
1449 (long)kid->op_type, (UV)kid->op_targ);
1450 if (kid->op_type != OP_GV) {
1451 /* Restore RV2CV to check lvalueness */
1453 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1454 okid->op_next = kid->op_next;
1455 kid->op_next = okid;
1458 okid->op_next = NULL;
1459 okid->op_type = OP_RV2CV;
1461 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1462 okid->op_private |= OPpLVAL_INTRO;
1463 okid->op_private &= ~1;
1467 cv = GvCV(kGVOP_gv);
1477 /* grep, foreach, subcalls, refgen */
1478 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1480 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1481 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1483 : (o->op_type == OP_ENTERSUB
1484 ? "non-lvalue subroutine call"
1486 type ? PL_op_desc[type] : "local"));
1500 case OP_RIGHT_SHIFT:
1509 if (!(o->op_flags & OPf_STACKED))
1516 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1522 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1523 PL_modcount = RETURN_UNLIMITED_NUMBER;
1524 return o; /* Treat \(@foo) like ordinary list. */
1528 if (scalar_mod_type(o, type))
1530 ref(cUNOPo->op_first, o->op_type);
1534 if (type == OP_LEAVESUBLV)
1535 o->op_private |= OPpMAYBE_LVSUB;
1541 PL_modcount = RETURN_UNLIMITED_NUMBER;
1544 ref(cUNOPo->op_first, o->op_type);
1549 PL_hints |= HINT_BLOCK_SCOPE;
1564 PL_modcount = RETURN_UNLIMITED_NUMBER;
1565 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1566 return o; /* Treat \(@foo) like ordinary list. */
1567 if (scalar_mod_type(o, type))
1569 if (type == OP_LEAVESUBLV)
1570 o->op_private |= OPpMAYBE_LVSUB;
1574 if (!type) /* local() */
1575 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1576 PAD_COMPNAME_PV(o->op_targ));
1584 if (type != OP_SASSIGN)
1588 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1593 if (type == OP_LEAVESUBLV)
1594 o->op_private |= OPpMAYBE_LVSUB;
1596 pad_free(o->op_targ);
1597 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1598 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1599 if (o->op_flags & OPf_KIDS)
1600 mod(cBINOPo->op_first->op_sibling, type);
1605 ref(cBINOPo->op_first, o->op_type);
1606 if (type == OP_ENTERSUB &&
1607 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1608 o->op_private |= OPpLVAL_DEFER;
1609 if (type == OP_LEAVESUBLV)
1610 o->op_private |= OPpMAYBE_LVSUB;
1620 if (o->op_flags & OPf_KIDS)
1621 mod(cLISTOPo->op_last, type);
1626 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1628 else if (!(o->op_flags & OPf_KIDS))
1630 if (o->op_targ != OP_LIST) {
1631 mod(cBINOPo->op_first, type);
1637 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1642 if (type != OP_LEAVESUBLV)
1644 break; /* mod()ing was handled by ck_return() */
1647 /* [20011101.069] File test operators interpret OPf_REF to mean that
1648 their argument is a filehandle; thus \stat(".") should not set
1650 if (type == OP_REFGEN &&
1651 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1654 if (type != OP_LEAVESUBLV)
1655 o->op_flags |= OPf_MOD;
1657 if (type == OP_AASSIGN || type == OP_SASSIGN)
1658 o->op_flags |= OPf_SPECIAL|OPf_REF;
1659 else if (!type) { /* local() */
1662 o->op_private |= OPpLVAL_INTRO;
1663 o->op_flags &= ~OPf_SPECIAL;
1664 PL_hints |= HINT_BLOCK_SCOPE;
1669 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1670 "Useless localization of %s", OP_DESC(o));
1673 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1674 && type != OP_LEAVESUBLV)
1675 o->op_flags |= OPf_REF;
1680 S_scalar_mod_type(const OP *o, I32 type)
1682 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1686 if (o->op_type == OP_RV2GV)
1710 case OP_RIGHT_SHIFT:
1730 S_is_handle_constructor(const OP *o, I32 numargs)
1732 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1734 switch (o->op_type) {
1742 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1755 S_refkids(pTHX_ OP *o, I32 type)
1757 if (o && o->op_flags & OPf_KIDS) {
1759 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1766 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1771 PERL_ARGS_ASSERT_DOREF;
1773 if (!o || (PL_parser && PL_parser->error_count))
1776 switch (o->op_type) {
1778 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1779 !(o->op_flags & OPf_STACKED)) {
1780 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1781 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1782 assert(cUNOPo->op_first->op_type == OP_NULL);
1783 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1784 o->op_flags |= OPf_SPECIAL;
1785 o->op_private &= ~1;
1790 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1791 doref(kid, type, set_op_ref);
1794 if (type == OP_DEFINED)
1795 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1796 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1799 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1800 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1801 : type == OP_RV2HV ? OPpDEREF_HV
1803 o->op_flags |= OPf_MOD;
1810 o->op_flags |= OPf_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);
1821 o->op_flags |= OPf_REF;
1826 if (!(o->op_flags & OPf_KIDS))
1828 doref(cBINOPo->op_first, type, set_op_ref);
1832 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1833 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1834 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1835 : type == OP_RV2HV ? OPpDEREF_HV
1837 o->op_flags |= OPf_MOD;
1847 if (!(o->op_flags & OPf_KIDS))
1849 doref(cLISTOPo->op_last, type, set_op_ref);
1859 S_dup_attrlist(pTHX_ OP *o)
1864 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1866 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1867 * where the first kid is OP_PUSHMARK and the remaining ones
1868 * are OP_CONST. We need to push the OP_CONST values.
1870 if (o->op_type == OP_CONST)
1871 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1873 else if (o->op_type == OP_NULL)
1877 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1879 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1880 if (o->op_type == OP_CONST)
1881 rop = append_elem(OP_LIST, rop,
1882 newSVOP(OP_CONST, o->op_flags,
1883 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1890 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1895 PERL_ARGS_ASSERT_APPLY_ATTRS;
1897 /* fake up C<use attributes $pkg,$rv,@attrs> */
1898 ENTER; /* need to protect against side-effects of 'use' */
1899 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1901 #define ATTRSMODULE "attributes"
1902 #define ATTRSMODULE_PM "attributes.pm"
1905 /* Don't force the C<use> if we don't need it. */
1906 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1907 if (svp && *svp != &PL_sv_undef)
1908 NOOP; /* already in %INC */
1910 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1911 newSVpvs(ATTRSMODULE), NULL);
1914 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1915 newSVpvs(ATTRSMODULE),
1917 prepend_elem(OP_LIST,
1918 newSVOP(OP_CONST, 0, stashsv),
1919 prepend_elem(OP_LIST,
1920 newSVOP(OP_CONST, 0,
1922 dup_attrlist(attrs))));
1928 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1931 OP *pack, *imop, *arg;
1934 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1939 assert(target->op_type == OP_PADSV ||
1940 target->op_type == OP_PADHV ||
1941 target->op_type == OP_PADAV);
1943 /* Ensure that attributes.pm is loaded. */
1944 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1946 /* Need package name for method call. */
1947 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1949 /* Build up the real arg-list. */
1950 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1952 arg = newOP(OP_PADSV, 0);
1953 arg->op_targ = target->op_targ;
1954 arg = prepend_elem(OP_LIST,
1955 newSVOP(OP_CONST, 0, stashsv),
1956 prepend_elem(OP_LIST,
1957 newUNOP(OP_REFGEN, 0,
1958 mod(arg, OP_REFGEN)),
1959 dup_attrlist(attrs)));
1961 /* Fake up a method call to import */
1962 meth = newSVpvs_share("import");
1963 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1964 append_elem(OP_LIST,
1965 prepend_elem(OP_LIST, pack, list(arg)),
1966 newSVOP(OP_METHOD_NAMED, 0, meth)));
1967 imop->op_private |= OPpENTERSUB_NOMOD;
1969 /* Combine the ops. */
1970 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1974 =notfor apidoc apply_attrs_string
1976 Attempts to apply a list of attributes specified by the C<attrstr> and
1977 C<len> arguments to the subroutine identified by the C<cv> argument which
1978 is expected to be associated with the package identified by the C<stashpv>
1979 argument (see L<attributes>). It gets this wrong, though, in that it
1980 does not correctly identify the boundaries of the individual attribute
1981 specifications within C<attrstr>. This is not really intended for the
1982 public API, but has to be listed here for systems such as AIX which
1983 need an explicit export list for symbols. (It's called from XS code
1984 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1985 to respect attribute syntax properly would be welcome.
1991 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1992 const char *attrstr, STRLEN len)
1996 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
1999 len = strlen(attrstr);
2003 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2005 const char * const sstr = attrstr;
2006 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2007 attrs = append_elem(OP_LIST, attrs,
2008 newSVOP(OP_CONST, 0,
2009 newSVpvn(sstr, attrstr-sstr)));
2013 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2014 newSVpvs(ATTRSMODULE),
2015 NULL, prepend_elem(OP_LIST,
2016 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2017 prepend_elem(OP_LIST,
2018 newSVOP(OP_CONST, 0,
2019 newRV(MUTABLE_SV(cv))),
2024 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2029 PERL_ARGS_ASSERT_MY_KID;
2031 if (!o || (PL_parser && PL_parser->error_count))
2035 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2036 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2040 if (type == OP_LIST) {
2042 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2043 my_kid(kid, attrs, imopsp);
2044 } else if (type == OP_UNDEF
2050 } else if (type == OP_RV2SV || /* "our" declaration */
2052 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2053 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2054 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2056 PL_parser->in_my == KEY_our
2058 : PL_parser->in_my == KEY_state ? "state" : "my"));
2060 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2061 PL_parser->in_my = FALSE;
2062 PL_parser->in_my_stash = NULL;
2063 apply_attrs(GvSTASH(gv),
2064 (type == OP_RV2SV ? GvSV(gv) :
2065 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2066 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2069 o->op_private |= OPpOUR_INTRO;
2072 else if (type != OP_PADSV &&
2075 type != OP_PUSHMARK)
2077 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2079 PL_parser->in_my == KEY_our
2081 : PL_parser->in_my == KEY_state ? "state" : "my"));
2084 else if (attrs && type != OP_PUSHMARK) {
2087 PL_parser->in_my = FALSE;
2088 PL_parser->in_my_stash = NULL;
2090 /* check for C<my Dog $spot> when deciding package */
2091 stash = PAD_COMPNAME_TYPE(o->op_targ);
2093 stash = PL_curstash;
2094 apply_attrs_my(stash, o, attrs, imopsp);
2096 o->op_flags |= OPf_MOD;
2097 o->op_private |= OPpLVAL_INTRO;
2098 if (PL_parser->in_my == KEY_state)
2099 o->op_private |= OPpPAD_STATE;
2104 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2108 int maybe_scalar = 0;
2110 PERL_ARGS_ASSERT_MY_ATTRS;
2112 /* [perl #17376]: this appears to be premature, and results in code such as
2113 C< our(%x); > executing in list mode rather than void mode */
2115 if (o->op_flags & OPf_PARENS)
2125 o = my_kid(o, attrs, &rops);
2127 if (maybe_scalar && o->op_type == OP_PADSV) {
2128 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2129 o->op_private |= OPpLVAL_INTRO;
2132 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2134 PL_parser->in_my = FALSE;
2135 PL_parser->in_my_stash = NULL;
2140 Perl_sawparens(pTHX_ OP *o)
2142 PERL_UNUSED_CONTEXT;
2144 o->op_flags |= OPf_PARENS;
2149 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2153 const OPCODE ltype = left->op_type;
2154 const OPCODE rtype = right->op_type;
2156 PERL_ARGS_ASSERT_BIND_MATCH;
2158 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2159 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2161 const char * const desc
2162 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2163 ? (int)rtype : OP_MATCH];
2164 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2165 ? "@array" : "%hash");
2166 Perl_warner(aTHX_ packWARN(WARN_MISC),
2167 "Applying %s to %s will act on scalar(%s)",
2168 desc, sample, sample);
2171 if (rtype == OP_CONST &&
2172 cSVOPx(right)->op_private & OPpCONST_BARE &&
2173 cSVOPx(right)->op_private & OPpCONST_STRICT)
2175 no_bareword_allowed(right);
2178 ismatchop = rtype == OP_MATCH ||
2179 rtype == OP_SUBST ||
2181 if (ismatchop && right->op_private & OPpTARGET_MY) {
2183 right->op_private &= ~OPpTARGET_MY;
2185 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2188 right->op_flags |= OPf_STACKED;
2189 if (rtype != OP_MATCH &&
2190 ! (rtype == OP_TRANS &&
2191 right->op_private & OPpTRANS_IDENTICAL))
2192 newleft = mod(left, rtype);
2195 if (right->op_type == OP_TRANS)
2196 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2198 o = prepend_elem(rtype, scalar(newleft), right);
2200 return newUNOP(OP_NOT, 0, scalar(o));
2204 return bind_match(type, left,
2205 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2209 Perl_invert(pTHX_ OP *o)
2213 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2217 Perl_scope(pTHX_ OP *o)
2221 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2222 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2223 o->op_type = OP_LEAVE;
2224 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2226 else if (o->op_type == OP_LINESEQ) {
2228 o->op_type = OP_SCOPE;
2229 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2230 kid = ((LISTOP*)o)->op_first;
2231 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2234 /* The following deals with things like 'do {1 for 1}' */
2235 kid = kid->op_sibling;
2237 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2242 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2248 Perl_block_start(pTHX_ int full)
2251 const int retval = PL_savestack_ix;
2252 pad_block_start(full);
2254 PL_hints &= ~HINT_BLOCK_SCOPE;
2255 SAVECOMPILEWARNINGS();
2256 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2261 Perl_block_end(pTHX_ I32 floor, OP *seq)
2264 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2265 OP* const retval = scalarseq(seq);
2267 CopHINTS_set(&PL_compiling, PL_hints);
2269 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2278 const PADOFFSET offset = pad_findmy("$_");
2279 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2280 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2283 OP * const o = newOP(OP_PADSV, 0);
2284 o->op_targ = offset;
2290 Perl_newPROG(pTHX_ OP *o)
2294 PERL_ARGS_ASSERT_NEWPROG;
2299 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2300 ((PL_in_eval & EVAL_KEEPERR)
2301 ? OPf_SPECIAL : 0), o);
2302 PL_eval_start = linklist(PL_eval_root);
2303 PL_eval_root->op_private |= OPpREFCOUNTED;
2304 OpREFCNT_set(PL_eval_root, 1);
2305 PL_eval_root->op_next = 0;
2306 CALL_PEEP(PL_eval_start);
2309 if (o->op_type == OP_STUB) {
2310 PL_comppad_name = 0;
2312 S_op_destroy(aTHX_ o);
2315 PL_main_root = scope(sawparens(scalarvoid(o)));
2316 PL_curcop = &PL_compiling;
2317 PL_main_start = LINKLIST(PL_main_root);
2318 PL_main_root->op_private |= OPpREFCOUNTED;
2319 OpREFCNT_set(PL_main_root, 1);
2320 PL_main_root->op_next = 0;
2321 CALL_PEEP(PL_main_start);
2324 /* Register with debugger */
2326 CV * const cv = get_cvs("DB::postponed", 0);
2330 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2332 call_sv(MUTABLE_SV(cv), G_DISCARD);
2339 Perl_localize(pTHX_ OP *o, I32 lex)
2343 PERL_ARGS_ASSERT_LOCALIZE;
2345 if (o->op_flags & OPf_PARENS)
2346 /* [perl #17376]: this appears to be premature, and results in code such as
2347 C< our(%x); > executing in list mode rather than void mode */
2354 if ( PL_parser->bufptr > PL_parser->oldbufptr
2355 && PL_parser->bufptr[-1] == ','
2356 && ckWARN(WARN_PARENTHESIS))
2358 char *s = PL_parser->bufptr;
2361 /* some heuristics to detect a potential error */
2362 while (*s && (strchr(", \t\n", *s)))
2366 if (*s && strchr("@$%*", *s) && *++s
2367 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2370 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2372 while (*s && (strchr(", \t\n", *s)))
2378 if (sigil && (*s == ';' || *s == '=')) {
2379 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2380 "Parentheses missing around \"%s\" list",
2382 ? (PL_parser->in_my == KEY_our
2384 : PL_parser->in_my == KEY_state
2394 o = mod(o, OP_NULL); /* a bit kludgey */
2395 PL_parser->in_my = FALSE;
2396 PL_parser->in_my_stash = NULL;
2401 Perl_jmaybe(pTHX_ OP *o)
2403 PERL_ARGS_ASSERT_JMAYBE;
2405 if (o->op_type == OP_LIST) {
2407 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2408 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2414 S_fold_constants(pTHX_ register OP *o)
2417 register OP * VOL curop;
2419 VOL I32 type = o->op_type;
2424 SV * const oldwarnhook = PL_warnhook;
2425 SV * const olddiehook = PL_diehook;
2429 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2431 if (PL_opargs[type] & OA_RETSCALAR)
2433 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2434 o->op_targ = pad_alloc(type, SVs_PADTMP);
2436 /* integerize op, unless it happens to be C<-foo>.
2437 * XXX should pp_i_negate() do magic string negation instead? */
2438 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2439 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2440 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2442 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2445 if (!(PL_opargs[type] & OA_FOLDCONST))
2450 /* XXX might want a ck_negate() for this */
2451 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2462 /* XXX what about the numeric ops? */
2463 if (PL_hints & HINT_LOCALE)
2468 if (PL_parser && PL_parser->error_count)
2469 goto nope; /* Don't try to run w/ errors */
2471 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2472 const OPCODE type = curop->op_type;
2473 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2475 type != OP_SCALAR &&
2477 type != OP_PUSHMARK)
2483 curop = LINKLIST(o);
2484 old_next = o->op_next;
2488 oldscope = PL_scopestack_ix;
2489 create_eval_scope(G_FAKINGEVAL);
2491 /* Verify that we don't need to save it: */
2492 assert(PL_curcop == &PL_compiling);
2493 StructCopy(&PL_compiling, ¬_compiling, COP);
2494 PL_curcop = ¬_compiling;
2495 /* The above ensures that we run with all the correct hints of the
2496 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2497 assert(IN_PERL_RUNTIME);
2498 PL_warnhook = PERL_WARNHOOK_FATAL;
2505 sv = *(PL_stack_sp--);
2506 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2507 pad_swipe(o->op_targ, FALSE);
2508 else if (SvTEMP(sv)) { /* grab mortal temp? */
2509 SvREFCNT_inc_simple_void(sv);
2514 /* Something tried to die. Abandon constant folding. */
2515 /* Pretend the error never happened. */
2517 o->op_next = old_next;
2521 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2522 PL_warnhook = oldwarnhook;
2523 PL_diehook = olddiehook;
2524 /* XXX note that this croak may fail as we've already blown away
2525 * the stack - eg any nested evals */
2526 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2529 PL_warnhook = oldwarnhook;
2530 PL_diehook = olddiehook;
2531 PL_curcop = &PL_compiling;
2533 if (PL_scopestack_ix > oldscope)
2534 delete_eval_scope();
2543 if (type == OP_RV2GV)
2544 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2546 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2547 op_getmad(o,newop,'f');
2555 S_gen_constant_list(pTHX_ register OP *o)
2559 const I32 oldtmps_floor = PL_tmps_floor;
2562 if (PL_parser && PL_parser->error_count)
2563 return o; /* Don't attempt to run with errors */
2565 PL_op = curop = LINKLIST(o);
2571 assert (!(curop->op_flags & OPf_SPECIAL));
2572 assert(curop->op_type == OP_RANGE);
2574 PL_tmps_floor = oldtmps_floor;
2576 o->op_type = OP_RV2AV;
2577 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2578 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2579 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2580 o->op_opt = 0; /* needs to be revisited in peep() */
2581 curop = ((UNOP*)o)->op_first;
2582 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2584 op_getmad(curop,o,'O');
2593 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2596 if (!o || o->op_type != OP_LIST)
2597 o = newLISTOP(OP_LIST, 0, o, NULL);
2599 o->op_flags &= ~OPf_WANT;
2601 if (!(PL_opargs[type] & OA_MARK))
2602 op_null(cLISTOPo->op_first);
2604 o->op_type = (OPCODE)type;
2605 o->op_ppaddr = PL_ppaddr[type];
2606 o->op_flags |= flags;
2608 o = CHECKOP(type, o);
2609 if (o->op_type != (unsigned)type)
2612 return fold_constants(o);
2615 /* List constructors */
2618 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2626 if (first->op_type != (unsigned)type
2627 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2629 return newLISTOP(type, 0, first, last);
2632 if (first->op_flags & OPf_KIDS)
2633 ((LISTOP*)first)->op_last->op_sibling = last;
2635 first->op_flags |= OPf_KIDS;
2636 ((LISTOP*)first)->op_first = last;
2638 ((LISTOP*)first)->op_last = last;
2643 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2651 if (first->op_type != (unsigned)type)
2652 return prepend_elem(type, (OP*)first, (OP*)last);
2654 if (last->op_type != (unsigned)type)
2655 return append_elem(type, (OP*)first, (OP*)last);
2657 first->op_last->op_sibling = last->op_first;
2658 first->op_last = last->op_last;
2659 first->op_flags |= (last->op_flags & OPf_KIDS);
2662 if (last->op_first && first->op_madprop) {
2663 MADPROP *mp = last->op_first->op_madprop;
2665 while (mp->mad_next)
2667 mp->mad_next = first->op_madprop;
2670 last->op_first->op_madprop = first->op_madprop;
2673 first->op_madprop = last->op_madprop;
2674 last->op_madprop = 0;
2677 S_op_destroy(aTHX_ (OP*)last);
2683 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2691 if (last->op_type == (unsigned)type) {
2692 if (type == OP_LIST) { /* already a PUSHMARK there */
2693 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2694 ((LISTOP*)last)->op_first->op_sibling = first;
2695 if (!(first->op_flags & OPf_PARENS))
2696 last->op_flags &= ~OPf_PARENS;
2699 if (!(last->op_flags & OPf_KIDS)) {
2700 ((LISTOP*)last)->op_last = first;
2701 last->op_flags |= OPf_KIDS;
2703 first->op_sibling = ((LISTOP*)last)->op_first;
2704 ((LISTOP*)last)->op_first = first;
2706 last->op_flags |= OPf_KIDS;
2710 return newLISTOP(type, 0, first, last);
2718 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2721 Newxz(tk, 1, TOKEN);
2722 tk->tk_type = (OPCODE)optype;
2723 tk->tk_type = 12345;
2725 tk->tk_mad = madprop;
2730 Perl_token_free(pTHX_ TOKEN* tk)
2732 PERL_ARGS_ASSERT_TOKEN_FREE;
2734 if (tk->tk_type != 12345)
2736 mad_free(tk->tk_mad);
2741 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2746 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2748 if (tk->tk_type != 12345) {
2749 Perl_warner(aTHX_ packWARN(WARN_MISC),
2750 "Invalid TOKEN object ignored");
2757 /* faked up qw list? */
2759 tm->mad_type == MAD_SV &&
2760 SvPVX((SV *)tm->mad_val)[0] == 'q')
2767 /* pretend constant fold didn't happen? */
2768 if (mp->mad_key == 'f' &&
2769 (o->op_type == OP_CONST ||
2770 o->op_type == OP_GV) )
2772 token_getmad(tk,(OP*)mp->mad_val,slot);
2786 if (mp->mad_key == 'X')
2787 mp->mad_key = slot; /* just change the first one */
2797 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2806 /* pretend constant fold didn't happen? */
2807 if (mp->mad_key == 'f' &&
2808 (o->op_type == OP_CONST ||
2809 o->op_type == OP_GV) )
2811 op_getmad(from,(OP*)mp->mad_val,slot);
2818 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2821 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2827 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2836 /* pretend constant fold didn't happen? */
2837 if (mp->mad_key == 'f' &&
2838 (o->op_type == OP_CONST ||
2839 o->op_type == OP_GV) )
2841 op_getmad(from,(OP*)mp->mad_val,slot);
2848 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2851 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2855 PerlIO_printf(PerlIO_stderr(),
2856 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2862 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2880 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2884 addmad(tm, &(o->op_madprop), slot);
2888 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2909 Perl_newMADsv(pTHX_ char key, SV* sv)
2911 PERL_ARGS_ASSERT_NEWMADSV;
2913 return newMADPROP(key, MAD_SV, sv, 0);
2917 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2920 Newxz(mp, 1, MADPROP);
2923 mp->mad_vlen = vlen;
2924 mp->mad_type = type;
2926 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2931 Perl_mad_free(pTHX_ MADPROP* mp)
2933 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2937 mad_free(mp->mad_next);
2938 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2939 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2940 switch (mp->mad_type) {
2944 Safefree((char*)mp->mad_val);
2947 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2948 op_free((OP*)mp->mad_val);
2951 sv_free(MUTABLE_SV(mp->mad_val));
2954 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2963 Perl_newNULLLIST(pTHX)
2965 return newOP(OP_STUB, 0);
2969 S_force_list(pTHX_ OP *o)
2971 if (!o || o->op_type != OP_LIST)
2972 o = newLISTOP(OP_LIST, 0, o, NULL);
2978 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2983 NewOp(1101, listop, 1, LISTOP);
2985 listop->op_type = (OPCODE)type;
2986 listop->op_ppaddr = PL_ppaddr[type];
2989 listop->op_flags = (U8)flags;
2993 else if (!first && last)
2996 first->op_sibling = last;
2997 listop->op_first = first;
2998 listop->op_last = last;
2999 if (type == OP_LIST) {
3000 OP* const pushop = newOP(OP_PUSHMARK, 0);
3001 pushop->op_sibling = first;
3002 listop->op_first = pushop;
3003 listop->op_flags |= OPf_KIDS;
3005 listop->op_last = pushop;
3008 return CHECKOP(type, listop);
3012 Perl_newOP(pTHX_ I32 type, I32 flags)
3016 NewOp(1101, o, 1, OP);
3017 o->op_type = (OPCODE)type;
3018 o->op_ppaddr = PL_ppaddr[type];
3019 o->op_flags = (U8)flags;
3021 o->op_latefreed = 0;
3025 o->op_private = (U8)(0 | (flags >> 8));
3026 if (PL_opargs[type] & OA_RETSCALAR)
3028 if (PL_opargs[type] & OA_TARGET)
3029 o->op_targ = pad_alloc(type, SVs_PADTMP);
3030 return CHECKOP(type, o);
3034 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3040 first = newOP(OP_STUB, 0);
3041 if (PL_opargs[type] & OA_MARK)
3042 first = force_list(first);
3044 NewOp(1101, unop, 1, UNOP);
3045 unop->op_type = (OPCODE)type;
3046 unop->op_ppaddr = PL_ppaddr[type];
3047 unop->op_first = first;
3048 unop->op_flags = (U8)(flags | OPf_KIDS);
3049 unop->op_private = (U8)(1 | (flags >> 8));
3050 unop = (UNOP*) CHECKOP(type, unop);
3054 return fold_constants((OP *) unop);
3058 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3062 NewOp(1101, binop, 1, BINOP);
3065 first = newOP(OP_NULL, 0);
3067 binop->op_type = (OPCODE)type;
3068 binop->op_ppaddr = PL_ppaddr[type];
3069 binop->op_first = first;
3070 binop->op_flags = (U8)(flags | OPf_KIDS);
3073 binop->op_private = (U8)(1 | (flags >> 8));
3076 binop->op_private = (U8)(2 | (flags >> 8));
3077 first->op_sibling = last;
3080 binop = (BINOP*)CHECKOP(type, binop);
3081 if (binop->op_next || binop->op_type != (OPCODE)type)
3084 binop->op_last = binop->op_first->op_sibling;
3086 return fold_constants((OP *)binop);
3089 static int uvcompare(const void *a, const void *b)
3090 __attribute__nonnull__(1)
3091 __attribute__nonnull__(2)
3092 __attribute__pure__;
3093 static int uvcompare(const void *a, const void *b)
3095 if (*((const UV *)a) < (*(const UV *)b))
3097 if (*((const UV *)a) > (*(const UV *)b))
3099 if (*((const UV *)a+1) < (*(const UV *)b+1))
3101 if (*((const UV *)a+1) > (*(const UV *)b+1))
3107 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3110 SV * const tstr = ((SVOP*)expr)->op_sv;
3113 (repl->op_type == OP_NULL)
3114 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3116 ((SVOP*)repl)->op_sv;
3119 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3120 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3124 register short *tbl;
3126 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3127 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3128 I32 del = o->op_private & OPpTRANS_DELETE;
3131 PERL_ARGS_ASSERT_PMTRANS;
3133 PL_hints |= HINT_BLOCK_SCOPE;
3136 o->op_private |= OPpTRANS_FROM_UTF;
3139 o->op_private |= OPpTRANS_TO_UTF;
3141 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3142 SV* const listsv = newSVpvs("# comment\n");
3144 const U8* tend = t + tlen;
3145 const U8* rend = r + rlen;
3159 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3160 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3163 const U32 flags = UTF8_ALLOW_DEFAULT;
3167 t = tsave = bytes_to_utf8(t, &len);
3170 if (!to_utf && rlen) {
3172 r = rsave = bytes_to_utf8(r, &len);
3176 /* There are several snags with this code on EBCDIC:
3177 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3178 2. scan_const() in toke.c has encoded chars in native encoding which makes
3179 ranges at least in EBCDIC 0..255 range the bottom odd.
3183 U8 tmpbuf[UTF8_MAXBYTES+1];
3186 Newx(cp, 2*tlen, UV);
3188 transv = newSVpvs("");
3190 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3192 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3194 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3198 cp[2*i+1] = cp[2*i];
3202 qsort(cp, i, 2*sizeof(UV), uvcompare);
3203 for (j = 0; j < i; j++) {
3205 diff = val - nextmin;
3207 t = uvuni_to_utf8(tmpbuf,nextmin);
3208 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3210 U8 range_mark = UTF_TO_NATIVE(0xff);
3211 t = uvuni_to_utf8(tmpbuf, val - 1);
3212 sv_catpvn(transv, (char *)&range_mark, 1);
3213 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3220 t = uvuni_to_utf8(tmpbuf,nextmin);
3221 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3223 U8 range_mark = UTF_TO_NATIVE(0xff);
3224 sv_catpvn(transv, (char *)&range_mark, 1);
3226 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3227 UNICODE_ALLOW_SUPER);
3228 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3229 t = (const U8*)SvPVX_const(transv);
3230 tlen = SvCUR(transv);
3234 else if (!rlen && !del) {
3235 r = t; rlen = tlen; rend = tend;
3238 if ((!rlen && !del) || t == r ||
3239 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3241 o->op_private |= OPpTRANS_IDENTICAL;
3245 while (t < tend || tfirst <= tlast) {
3246 /* see if we need more "t" chars */
3247 if (tfirst > tlast) {
3248 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3250 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3252 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3259 /* now see if we need more "r" chars */
3260 if (rfirst > rlast) {
3262 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3264 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3266 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3275 rfirst = rlast = 0xffffffff;
3279 /* now see which range will peter our first, if either. */
3280 tdiff = tlast - tfirst;
3281 rdiff = rlast - rfirst;
3288 if (rfirst == 0xffffffff) {
3289 diff = tdiff; /* oops, pretend rdiff is infinite */
3291 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3292 (long)tfirst, (long)tlast);
3294 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3298 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3299 (long)tfirst, (long)(tfirst + diff),
3302 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3303 (long)tfirst, (long)rfirst);
3305 if (rfirst + diff > max)
3306 max = rfirst + diff;
3308 grows = (tfirst < rfirst &&
3309 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3321 else if (max > 0xff)
3326 PerlMemShared_free(cPVOPo->op_pv);
3327 cPVOPo->op_pv = NULL;
3329 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3331 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3332 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3333 PAD_SETSV(cPADOPo->op_padix, swash);
3335 SvREADONLY_on(swash);
3337 cSVOPo->op_sv = swash;
3339 SvREFCNT_dec(listsv);
3340 SvREFCNT_dec(transv);
3342 if (!del && havefinal && rlen)
3343 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3344 newSVuv((UV)final), 0);
3347 o->op_private |= OPpTRANS_GROWS;
3353 op_getmad(expr,o,'e');
3354 op_getmad(repl,o,'r');
3362 tbl = (short*)cPVOPo->op_pv;
3364 Zero(tbl, 256, short);
3365 for (i = 0; i < (I32)tlen; i++)
3367 for (i = 0, j = 0; i < 256; i++) {
3369 if (j >= (I32)rlen) {
3378 if (i < 128 && r[j] >= 128)
3388 o->op_private |= OPpTRANS_IDENTICAL;
3390 else if (j >= (I32)rlen)
3395 PerlMemShared_realloc(tbl,
3396 (0x101+rlen-j) * sizeof(short));
3397 cPVOPo->op_pv = (char*)tbl;
3399 tbl[0x100] = (short)(rlen - j);
3400 for (i=0; i < (I32)rlen - j; i++)
3401 tbl[0x101+i] = r[j+i];
3405 if (!rlen && !del) {
3408 o->op_private |= OPpTRANS_IDENTICAL;
3410 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3411 o->op_private |= OPpTRANS_IDENTICAL;
3413 for (i = 0; i < 256; i++)
3415 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3416 if (j >= (I32)rlen) {
3418 if (tbl[t[i]] == -1)
3424 if (tbl[t[i]] == -1) {
3425 if (t[i] < 128 && r[j] >= 128)
3432 if(del && rlen == tlen) {
3433 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3434 } else if(rlen > tlen) {
3435 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3439 o->op_private |= OPpTRANS_GROWS;
3441 op_getmad(expr,o,'e');
3442 op_getmad(repl,o,'r');
3452 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3457 NewOp(1101, pmop, 1, PMOP);
3458 pmop->op_type = (OPCODE)type;
3459 pmop->op_ppaddr = PL_ppaddr[type];
3460 pmop->op_flags = (U8)flags;
3461 pmop->op_private = (U8)(0 | (flags >> 8));
3463 if (PL_hints & HINT_RE_TAINT)
3464 pmop->op_pmflags |= PMf_RETAINT;
3465 if (PL_hints & HINT_LOCALE)
3466 pmop->op_pmflags |= PMf_LOCALE;
3470 assert(SvPOK(PL_regex_pad[0]));
3471 if (SvCUR(PL_regex_pad[0])) {
3472 /* Pop off the "packed" IV from the end. */
3473 SV *const repointer_list = PL_regex_pad[0];
3474 const char *p = SvEND(repointer_list) - sizeof(IV);
3475 const IV offset = *((IV*)p);
3477 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3479 SvEND_set(repointer_list, p);
3481 pmop->op_pmoffset = offset;
3482 /* This slot should be free, so assert this: */
3483 assert(PL_regex_pad[offset] == &PL_sv_undef);
3485 SV * const repointer = &PL_sv_undef;
3486 av_push(PL_regex_padav, repointer);
3487 pmop->op_pmoffset = av_len(PL_regex_padav);
3488 PL_regex_pad = AvARRAY(PL_regex_padav);
3492 return CHECKOP(type, pmop);
3495 /* Given some sort of match op o, and an expression expr containing a
3496 * pattern, either compile expr into a regex and attach it to o (if it's
3497 * constant), or convert expr into a runtime regcomp op sequence (if it's
3500 * isreg indicates that the pattern is part of a regex construct, eg
3501 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3502 * split "pattern", which aren't. In the former case, expr will be a list
3503 * if the pattern contains more than one term (eg /a$b/) or if it contains
3504 * a replacement, ie s/// or tr///.
3508 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3513 I32 repl_has_vars = 0;
3517 PERL_ARGS_ASSERT_PMRUNTIME;
3519 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3520 /* last element in list is the replacement; pop it */
3522 repl = cLISTOPx(expr)->op_last;
3523 kid = cLISTOPx(expr)->op_first;
3524 while (kid->op_sibling != repl)
3525 kid = kid->op_sibling;
3526 kid->op_sibling = NULL;
3527 cLISTOPx(expr)->op_last = kid;
3530 if (isreg && expr->op_type == OP_LIST &&
3531 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3533 /* convert single element list to element */
3534 OP* const oe = expr;
3535 expr = cLISTOPx(oe)->op_first->op_sibling;
3536 cLISTOPx(oe)->op_first->op_sibling = NULL;
3537 cLISTOPx(oe)->op_last = NULL;
3541 if (o->op_type == OP_TRANS) {
3542 return pmtrans(o, expr, repl);
3545 reglist = isreg && expr->op_type == OP_LIST;
3549 PL_hints |= HINT_BLOCK_SCOPE;
3552 if (expr->op_type == OP_CONST) {
3553 SV *pat = ((SVOP*)expr)->op_sv;
3554 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3556 if (o->op_flags & OPf_SPECIAL)
3557 pm_flags |= RXf_SPLIT;
3560 assert (SvUTF8(pat));
3561 } else if (SvUTF8(pat)) {
3562 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3563 trapped in use 'bytes'? */
3564 /* Make a copy of the octet sequence, but without the flag on, as
3565 the compiler now honours the SvUTF8 flag on pat. */
3567 const char *const p = SvPV(pat, len);
3568 pat = newSVpvn_flags(p, len, SVs_TEMP);
3571 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3574 op_getmad(expr,(OP*)pm,'e');
3580 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3581 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3583 : OP_REGCMAYBE),0,expr);
3585 NewOp(1101, rcop, 1, LOGOP);
3586 rcop->op_type = OP_REGCOMP;
3587 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3588 rcop->op_first = scalar(expr);
3589 rcop->op_flags |= OPf_KIDS
3590 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3591 | (reglist ? OPf_STACKED : 0);
3592 rcop->op_private = 1;
3595 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3597 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3600 /* establish postfix order */
3601 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3603 rcop->op_next = expr;
3604 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3607 rcop->op_next = LINKLIST(expr);
3608 expr->op_next = (OP*)rcop;
3611 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3616 if (pm->op_pmflags & PMf_EVAL) {
3618 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3619 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3621 else if (repl->op_type == OP_CONST)
3625 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3626 if (curop->op_type == OP_SCOPE
3627 || curop->op_type == OP_LEAVE
3628 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3629 if (curop->op_type == OP_GV) {
3630 GV * const gv = cGVOPx_gv(curop);
3632 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3635 else if (curop->op_type == OP_RV2CV)
3637 else if (curop->op_type == OP_RV2SV ||
3638 curop->op_type == OP_RV2AV ||
3639 curop->op_type == OP_RV2HV ||
3640 curop->op_type == OP_RV2GV) {
3641 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3644 else if (curop->op_type == OP_PADSV ||
3645 curop->op_type == OP_PADAV ||
3646 curop->op_type == OP_PADHV ||
3647 curop->op_type == OP_PADANY)
3651 else if (curop->op_type == OP_PUSHRE)
3652 NOOP; /* Okay here, dangerous in newASSIGNOP */
3662 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3664 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3665 prepend_elem(o->op_type, scalar(repl), o);
3668 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3669 pm->op_pmflags |= PMf_MAYBE_CONST;
3671 NewOp(1101, rcop, 1, LOGOP);
3672 rcop->op_type = OP_SUBSTCONT;
3673 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3674 rcop->op_first = scalar(repl);
3675 rcop->op_flags |= OPf_KIDS;
3676 rcop->op_private = 1;
3679 /* establish postfix order */
3680 rcop->op_next = LINKLIST(repl);
3681 repl->op_next = (OP*)rcop;
3683 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3684 assert(!(pm->op_pmflags & PMf_ONCE));
3685 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3694 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3699 PERL_ARGS_ASSERT_NEWSVOP;
3701 NewOp(1101, svop, 1, SVOP);
3702 svop->op_type = (OPCODE)type;
3703 svop->op_ppaddr = PL_ppaddr[type];
3705 svop->op_next = (OP*)svop;
3706 svop->op_flags = (U8)flags;
3707 if (PL_opargs[type] & OA_RETSCALAR)
3709 if (PL_opargs[type] & OA_TARGET)
3710 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3711 return CHECKOP(type, svop);
3716 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3721 PERL_ARGS_ASSERT_NEWPADOP;
3723 NewOp(1101, padop, 1, PADOP);
3724 padop->op_type = (OPCODE)type;
3725 padop->op_ppaddr = PL_ppaddr[type];
3726 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3727 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3728 PAD_SETSV(padop->op_padix, sv);
3731 padop->op_next = (OP*)padop;
3732 padop->op_flags = (U8)flags;
3733 if (PL_opargs[type] & OA_RETSCALAR)
3735 if (PL_opargs[type] & OA_TARGET)
3736 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3737 return CHECKOP(type, padop);
3742 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3746 PERL_ARGS_ASSERT_NEWGVOP;
3750 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3752 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3757 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3761 NewOp(1101, pvop, 1, PVOP);
3762 pvop->op_type = (OPCODE)type;
3763 pvop->op_ppaddr = PL_ppaddr[type];
3765 pvop->op_next = (OP*)pvop;
3766 pvop->op_flags = (U8)flags;
3767 if (PL_opargs[type] & OA_RETSCALAR)
3769 if (PL_opargs[type] & OA_TARGET)
3770 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3771 return CHECKOP(type, pvop);
3779 Perl_package(pTHX_ OP *o)
3782 SV *const sv = cSVOPo->op_sv;
3787 PERL_ARGS_ASSERT_PACKAGE;
3789 save_hptr(&PL_curstash);
3790 save_item(PL_curstname);
3792 PL_curstash = gv_stashsv(sv, GV_ADD);
3794 sv_setsv(PL_curstname, sv);
3796 PL_hints |= HINT_BLOCK_SCOPE;
3797 PL_parser->copline = NOLINE;
3798 PL_parser->expect = XSTATE;
3803 if (!PL_madskills) {
3808 pegop = newOP(OP_NULL,0);
3809 op_getmad(o,pegop,'P');
3815 Perl_package_version( pTHX_ OP *v )
3818 U32 savehints = PL_hints;
3819 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3820 PL_hints &= ~HINT_STRICT_VARS;
3821 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3822 PL_hints = savehints;
3831 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3838 OP *pegop = newOP(OP_NULL,0);
3841 PERL_ARGS_ASSERT_UTILIZE;
3843 if (idop->op_type != OP_CONST)
3844 Perl_croak(aTHX_ "Module name must be constant");
3847 op_getmad(idop,pegop,'U');
3852 SV * const vesv = ((SVOP*)version)->op_sv;
3855 op_getmad(version,pegop,'V');
3856 if (!arg && !SvNIOKp(vesv)) {
3863 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3864 Perl_croak(aTHX_ "Version number must be a constant number");
3866 /* Make copy of idop so we don't free it twice */
3867 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3869 /* Fake up a method call to VERSION */
3870 meth = newSVpvs_share("VERSION");
3871 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3872 append_elem(OP_LIST,
3873 prepend_elem(OP_LIST, pack, list(version)),
3874 newSVOP(OP_METHOD_NAMED, 0, meth)));
3878 /* Fake up an import/unimport */
3879 if (arg && arg->op_type == OP_STUB) {
3881 op_getmad(arg,pegop,'S');
3882 imop = arg; /* no import on explicit () */
3884 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3885 imop = NULL; /* use 5.0; */
3887 idop->op_private |= OPpCONST_NOVER;
3893 op_getmad(arg,pegop,'A');
3895 /* Make copy of idop so we don't free it twice */
3896 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3898 /* Fake up a method call to import/unimport */
3900 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3901 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3902 append_elem(OP_LIST,
3903 prepend_elem(OP_LIST, pack, list(arg)),
3904 newSVOP(OP_METHOD_NAMED, 0, meth)));
3907 /* Fake up the BEGIN {}, which does its thing immediately. */
3909 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3912 append_elem(OP_LINESEQ,
3913 append_elem(OP_LINESEQ,
3914 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3915 newSTATEOP(0, NULL, veop)),
3916 newSTATEOP(0, NULL, imop) ));
3918 /* The "did you use incorrect case?" warning used to be here.
3919 * The problem is that on case-insensitive filesystems one
3920 * might get false positives for "use" (and "require"):
3921 * "use Strict" or "require CARP" will work. This causes
3922 * portability problems for the script: in case-strict
3923 * filesystems the script will stop working.
3925 * The "incorrect case" warning checked whether "use Foo"
3926 * imported "Foo" to your namespace, but that is wrong, too:
3927 * there is no requirement nor promise in the language that
3928 * a Foo.pm should or would contain anything in package "Foo".
3930 * There is very little Configure-wise that can be done, either:
3931 * the case-sensitivity of the build filesystem of Perl does not
3932 * help in guessing the case-sensitivity of the runtime environment.
3935 PL_hints |= HINT_BLOCK_SCOPE;
3936 PL_parser->copline = NOLINE;
3937 PL_parser->expect = XSTATE;
3938 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3941 if (!PL_madskills) {
3942 /* FIXME - don't allocate pegop if !PL_madskills */
3951 =head1 Embedding Functions
3953 =for apidoc load_module
3955 Loads the module whose name is pointed to by the string part of name.
3956 Note that the actual module name, not its filename, should be given.
3957 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3958 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3959 (or 0 for no flags). ver, if specified, provides version semantics
3960 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3961 arguments can be used to specify arguments to the module's import()
3962 method, similar to C<use Foo::Bar VERSION LIST>. They must be
3963 terminated with a final NULL pointer. Note that this list can only
3964 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
3965 Otherwise at least a single NULL pointer to designate the default
3966 import list is required.
3971 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3975 PERL_ARGS_ASSERT_LOAD_MODULE;
3977 va_start(args, ver);
3978 vload_module(flags, name, ver, &args);
3982 #ifdef PERL_IMPLICIT_CONTEXT
3984 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3988 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3989 va_start(args, ver);
3990 vload_module(flags, name, ver, &args);
3996 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4000 OP * const modname = newSVOP(OP_CONST, 0, name);
4002 PERL_ARGS_ASSERT_VLOAD_MODULE;
4004 modname->op_private |= OPpCONST_BARE;
4006 veop = newSVOP(OP_CONST, 0, ver);
4010 if (flags & PERL_LOADMOD_NOIMPORT) {
4011 imop = sawparens(newNULLLIST());
4013 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4014 imop = va_arg(*args, OP*);
4019 sv = va_arg(*args, SV*);
4021 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4022 sv = va_arg(*args, SV*);
4026 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4027 * that it has a PL_parser to play with while doing that, and also
4028 * that it doesn't mess with any existing parser, by creating a tmp
4029 * new parser with lex_start(). This won't actually be used for much,
4030 * since pp_require() will create another parser for the real work. */
4033 SAVEVPTR(PL_curcop);
4034 lex_start(NULL, NULL, FALSE);
4035 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4036 veop, modname, imop);
4041 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4047 PERL_ARGS_ASSERT_DOFILE;
4049 if (!force_builtin) {
4050 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4051 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4052 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4053 gv = gvp ? *gvp : NULL;
4057 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4058 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4059 append_elem(OP_LIST, term,
4060 scalar(newUNOP(OP_RV2CV, 0,
4061 newGVOP(OP_GV, 0, gv))))));
4064 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4070 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4072 return newBINOP(OP_LSLICE, flags,
4073 list(force_list(subscript)),
4074 list(force_list(listval)) );
4078 S_is_list_assignment(pTHX_ register const OP *o)
4086 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4087 o = cUNOPo->op_first;
4089 flags = o->op_flags;
4091 if (type == OP_COND_EXPR) {
4092 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4093 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4098 yyerror("Assignment to both a list and a scalar");
4102 if (type == OP_LIST &&
4103 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4104 o->op_private & OPpLVAL_INTRO)
4107 if (type == OP_LIST || flags & OPf_PARENS ||
4108 type == OP_RV2AV || type == OP_RV2HV ||
4109 type == OP_ASLICE || type == OP_HSLICE)
4112 if (type == OP_PADAV || type == OP_PADHV)
4115 if (type == OP_RV2SV)
4122 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4128 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4129 return newLOGOP(optype, 0,
4130 mod(scalar(left), optype),
4131 newUNOP(OP_SASSIGN, 0, scalar(right)));
4134 return newBINOP(optype, OPf_STACKED,
4135 mod(scalar(left), optype), scalar(right));
4139 if (is_list_assignment(left)) {
4140 static const char no_list_state[] = "Initialization of state variables"
4141 " in list context currently forbidden";
4143 bool maybe_common_vars = TRUE;
4146 /* Grandfathering $[ assignment here. Bletch.*/
4147 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4148 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4149 left = mod(left, OP_AASSIGN);
4152 else if (left->op_type == OP_CONST) {
4154 /* Result of assignment is always 1 (or we'd be dead already) */
4155 return newSVOP(OP_CONST, 0, newSViv(1));
4157 curop = list(force_list(left));
4158 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4159 o->op_private = (U8)(0 | (flags >> 8));
4161 if ((left->op_type == OP_LIST
4162 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4164 OP* lop = ((LISTOP*)left)->op_first;
4165 maybe_common_vars = FALSE;
4167 if (lop->op_type == OP_PADSV ||
4168 lop->op_type == OP_PADAV ||
4169 lop->op_type == OP_PADHV ||
4170 lop->op_type == OP_PADANY) {
4171 if (!(lop->op_private & OPpLVAL_INTRO))
4172 maybe_common_vars = TRUE;
4174 if (lop->op_private & OPpPAD_STATE) {
4175 if (left->op_private & OPpLVAL_INTRO) {
4176 /* Each variable in state($a, $b, $c) = ... */
4179 /* Each state variable in
4180 (state $a, my $b, our $c, $d, undef) = ... */
4182 yyerror(no_list_state);
4184 /* Each my variable in
4185 (state $a, my $b, our $c, $d, undef) = ... */
4187 } else if (lop->op_type == OP_UNDEF ||
4188 lop->op_type == OP_PUSHMARK) {
4189 /* undef may be interesting in
4190 (state $a, undef, state $c) */
4192 /* Other ops in the list. */
4193 maybe_common_vars = TRUE;
4195 lop = lop->op_sibling;
4198 else if ((left->op_private & OPpLVAL_INTRO)
4199 && ( left->op_type == OP_PADSV
4200 || left->op_type == OP_PADAV
4201 || left->op_type == OP_PADHV
4202 || left->op_type == OP_PADANY))
4204 maybe_common_vars = FALSE;
4205 if (left->op_private & OPpPAD_STATE) {
4206 /* All single variable list context state assignments, hence
4216 yyerror(no_list_state);
4220 /* PL_generation sorcery:
4221 * an assignment like ($a,$b) = ($c,$d) is easier than
4222 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4223 * To detect whether there are common vars, the global var
4224 * PL_generation is incremented for each assign op we compile.
4225 * Then, while compiling the assign op, we run through all the
4226 * variables on both sides of the assignment, setting a spare slot
4227 * in each of them to PL_generation. If any of them already have
4228 * that value, we know we've got commonality. We could use a
4229 * single bit marker, but then we'd have to make 2 passes, first
4230 * to clear the flag, then to test and set it. To find somewhere
4231 * to store these values, evil chicanery is done with SvUVX().
4234 if (maybe_common_vars) {
4237 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4238 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4239 if (curop->op_type == OP_GV) {
4240 GV *gv = cGVOPx_gv(curop);
4242 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4244 GvASSIGN_GENERATION_set(gv, PL_generation);
4246 else if (curop->op_type == OP_PADSV ||
4247 curop->op_type == OP_PADAV ||
4248 curop->op_type == OP_PADHV ||
4249 curop->op_type == OP_PADANY)
4251 if (PAD_COMPNAME_GEN(curop->op_targ)
4252 == (STRLEN)PL_generation)
4254 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4257 else if (curop->op_type == OP_RV2CV)
4259 else if (curop->op_type == OP_RV2SV ||
4260 curop->op_type == OP_RV2AV ||
4261 curop->op_type == OP_RV2HV ||
4262 curop->op_type == OP_RV2GV) {
4263 if (lastop->op_type != OP_GV) /* funny deref? */
4266 else if (curop->op_type == OP_PUSHRE) {
4268 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4269 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4271 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4273 GvASSIGN_GENERATION_set(gv, PL_generation);
4277 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4280 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4282 GvASSIGN_GENERATION_set(gv, PL_generation);
4292 o->op_private |= OPpASSIGN_COMMON;
4295 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4296 OP* tmpop = ((LISTOP*)right)->op_first;
4297 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4298 PMOP * const pm = (PMOP*)tmpop;
4299 if (left->op_type == OP_RV2AV &&
4300 !(left->op_private & OPpLVAL_INTRO) &&
4301 !(o->op_private & OPpASSIGN_COMMON) )
4303 tmpop = ((UNOP*)left)->op_first;
4304 if (tmpop->op_type == OP_GV
4306 && !pm->op_pmreplrootu.op_pmtargetoff
4308 && !pm->op_pmreplrootu.op_pmtargetgv
4312 pm->op_pmreplrootu.op_pmtargetoff
4313 = cPADOPx(tmpop)->op_padix;
4314 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4316 pm->op_pmreplrootu.op_pmtargetgv
4317 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4318 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4320 pm->op_pmflags |= PMf_ONCE;
4321 tmpop = cUNOPo->op_first; /* to list (nulled) */
4322 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4323 tmpop->op_sibling = NULL; /* don't free split */
4324 right->op_next = tmpop->op_next; /* fix starting loc */
4325 op_free(o); /* blow off assign */
4326 right->op_flags &= ~OPf_WANT;
4327 /* "I don't know and I don't care." */
4332 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4333 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4335 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4336 if (SvIOK(sv) && SvIVX(sv) == 0)
4337 sv_setiv(sv, PL_modcount+1);
4345 right = newOP(OP_UNDEF, 0);
4346 if (right->op_type == OP_READLINE) {
4347 right->op_flags |= OPf_STACKED;
4348 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4351 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4352 o = newBINOP(OP_SASSIGN, flags,
4353 scalar(right), mod(scalar(left), OP_SASSIGN) );
4357 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4358 deprecate("assignment to $[");
4360 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4361 o->op_private |= OPpCONST_ARYBASE;
4369 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4372 const U32 seq = intro_my();
4375 NewOp(1101, cop, 1, COP);
4376 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4377 cop->op_type = OP_DBSTATE;
4378 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4381 cop->op_type = OP_NEXTSTATE;
4382 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4384 cop->op_flags = (U8)flags;
4385 CopHINTS_set(cop, PL_hints);
4387 cop->op_private |= NATIVE_HINTS;
4389 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4390 cop->op_next = (OP*)cop;
4393 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4394 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4396 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4397 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4398 if (cop->cop_hints_hash) {
4400 cop->cop_hints_hash->refcounted_he_refcnt++;
4401 HINTS_REFCNT_UNLOCK;
4405 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4407 PL_hints |= HINT_BLOCK_SCOPE;
4408 /* It seems that we need to defer freeing this pointer, as other parts
4409 of the grammar end up wanting to copy it after this op has been
4414 if (PL_parser && PL_parser->copline == NOLINE)
4415 CopLINE_set(cop, CopLINE(PL_curcop));
4417 CopLINE_set(cop, PL_parser->copline);
4419 PL_parser->copline = NOLINE;
4422 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4424 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4426 CopSTASH_set(cop, PL_curstash);
4428 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4429 /* this line can have a breakpoint - store the cop in IV */
4430 AV *av = CopFILEAVx(PL_curcop);
4432 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4433 if (svp && *svp != &PL_sv_undef ) {
4434 (void)SvIOK_on(*svp);
4435 SvIV_set(*svp, PTR2IV(cop));
4440 if (flags & OPf_SPECIAL)
4442 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4447 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4451 PERL_ARGS_ASSERT_NEWLOGOP;
4453 return new_logop(type, flags, &first, &other);
4457 S_search_const(pTHX_ OP *o)
4459 PERL_ARGS_ASSERT_SEARCH_CONST;
4461 switch (o->op_type) {
4465 if (o->op_flags & OPf_KIDS)
4466 return search_const(cUNOPo->op_first);
4473 if (!(o->op_flags & OPf_KIDS))
4475 kid = cLISTOPo->op_first;
4477 switch (kid->op_type) {
4481 kid = kid->op_sibling;
4484 if (kid != cLISTOPo->op_last)
4490 kid = cLISTOPo->op_last;
4492 return search_const(kid);
4500 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4508 int prepend_not = 0;
4510 PERL_ARGS_ASSERT_NEW_LOGOP;
4515 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4516 return newBINOP(type, flags, scalar(first), scalar(other));
4518 scalarboolean(first);
4519 /* optimize AND and OR ops that have NOTs as children */
4520 if (first->op_type == OP_NOT
4521 && (first->op_flags & OPf_KIDS)
4522 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4523 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4525 if (type == OP_AND || type == OP_OR) {
4531 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4533 prepend_not = 1; /* prepend a NOT op later */
4537 /* search for a constant op that could let us fold the test */
4538 if ((cstop = search_const(first))) {
4539 if (cstop->op_private & OPpCONST_STRICT)
4540 no_bareword_allowed(cstop);
4541 else if ((cstop->op_private & OPpCONST_BARE))
4542 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4543 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4544 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4545 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4547 if (other->op_type == OP_CONST)
4548 other->op_private |= OPpCONST_SHORTCIRCUIT;
4550 OP *newop = newUNOP(OP_NULL, 0, other);
4551 op_getmad(first, newop, '1');
4552 newop->op_targ = type; /* set "was" field */
4556 if (other->op_type == OP_LEAVE)
4557 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4561 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4562 const OP *o2 = other;
4563 if ( ! (o2->op_type == OP_LIST
4564 && (( o2 = cUNOPx(o2)->op_first))
4565 && o2->op_type == OP_PUSHMARK
4566 && (( o2 = o2->op_sibling)) )
4569 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4570 || o2->op_type == OP_PADHV)
4571 && o2->op_private & OPpLVAL_INTRO
4572 && !(o2->op_private & OPpPAD_STATE))
4574 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4575 "Deprecated use of my() in false conditional");
4579 if (first->op_type == OP_CONST)
4580 first->op_private |= OPpCONST_SHORTCIRCUIT;
4582 first = newUNOP(OP_NULL, 0, first);
4583 op_getmad(other, first, '2');
4584 first->op_targ = type; /* set "was" field */
4591 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4592 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4594 const OP * const k1 = ((UNOP*)first)->op_first;
4595 const OP * const k2 = k1->op_sibling;
4597 switch (first->op_type)
4600 if (k2 && k2->op_type == OP_READLINE
4601 && (k2->op_flags & OPf_STACKED)
4602 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4604 warnop = k2->op_type;
4609 if (k1->op_type == OP_READDIR
4610 || k1->op_type == OP_GLOB
4611 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4612 || k1->op_type == OP_EACH)
4614 warnop = ((k1->op_type == OP_NULL)
4615 ? (OPCODE)k1->op_targ : k1->op_type);
4620 const line_t oldline = CopLINE(PL_curcop);
4621 CopLINE_set(PL_curcop, PL_parser->copline);
4622 Perl_warner(aTHX_ packWARN(WARN_MISC),
4623 "Value of %s%s can be \"0\"; test with defined()",
4625 ((warnop == OP_READLINE || warnop == OP_GLOB)
4626 ? " construct" : "() operator"));
4627 CopLINE_set(PL_curcop, oldline);
4634 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4635 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4637 NewOp(1101, logop, 1, LOGOP);
4639 logop->op_type = (OPCODE)type;
4640 logop->op_ppaddr = PL_ppaddr[type];
4641 logop->op_first = first;
4642 logop->op_flags = (U8)(flags | OPf_KIDS);
4643 logop->op_other = LINKLIST(other);
4644 logop->op_private = (U8)(1 | (flags >> 8));
4646 /* establish postfix order */
4647 logop->op_next = LINKLIST(first);
4648 first->op_next = (OP*)logop;
4649 first->op_sibling = other;
4651 CHECKOP(type,logop);
4653 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4660 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4668 PERL_ARGS_ASSERT_NEWCONDOP;
4671 return newLOGOP(OP_AND, 0, first, trueop);
4673 return newLOGOP(OP_OR, 0, first, falseop);
4675 scalarboolean(first);
4676 if ((cstop = search_const(first))) {
4677 /* Left or right arm of the conditional? */
4678 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4679 OP *live = left ? trueop : falseop;
4680 OP *const dead = left ? falseop : trueop;
4681 if (cstop->op_private & OPpCONST_BARE &&
4682 cstop->op_private & OPpCONST_STRICT) {
4683 no_bareword_allowed(cstop);
4686 /* This is all dead code when PERL_MAD is not defined. */
4687 live = newUNOP(OP_NULL, 0, live);
4688 op_getmad(first, live, 'C');
4689 op_getmad(dead, live, left ? 'e' : 't');
4694 if (live->op_type == OP_LEAVE)
4695 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4698 NewOp(1101, logop, 1, LOGOP);
4699 logop->op_type = OP_COND_EXPR;
4700 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4701 logop->op_first = first;
4702 logop->op_flags = (U8)(flags | OPf_KIDS);
4703 logop->op_private = (U8)(1 | (flags >> 8));
4704 logop->op_other = LINKLIST(trueop);
4705 logop->op_next = LINKLIST(falseop);
4707 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4710 /* establish postfix order */
4711 start = LINKLIST(first);
4712 first->op_next = (OP*)logop;
4714 first->op_sibling = trueop;
4715 trueop->op_sibling = falseop;
4716 o = newUNOP(OP_NULL, 0, (OP*)logop);
4718 trueop->op_next = falseop->op_next = o;
4725 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4734 PERL_ARGS_ASSERT_NEWRANGE;
4736 NewOp(1101, range, 1, LOGOP);
4738 range->op_type = OP_RANGE;
4739 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4740 range->op_first = left;
4741 range->op_flags = OPf_KIDS;
4742 leftstart = LINKLIST(left);
4743 range->op_other = LINKLIST(right);
4744 range->op_private = (U8)(1 | (flags >> 8));
4746 left->op_sibling = right;
4748 range->op_next = (OP*)range;
4749 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4750 flop = newUNOP(OP_FLOP, 0, flip);
4751 o = newUNOP(OP_NULL, 0, flop);
4753 range->op_next = leftstart;
4755 left->op_next = flip;
4756 right->op_next = flop;
4758 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4759 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4760 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4761 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4763 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4764 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4767 if (!flip->op_private || !flop->op_private)
4768 linklist(o); /* blow off optimizer unless constant */
4774 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4779 const bool once = block && block->op_flags & OPf_SPECIAL &&
4780 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4782 PERL_UNUSED_ARG(debuggable);
4785 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4786 return block; /* do {} while 0 does once */
4787 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4788 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4789 expr = newUNOP(OP_DEFINED, 0,
4790 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4791 } else if (expr->op_flags & OPf_KIDS) {
4792 const OP * const k1 = ((UNOP*)expr)->op_first;
4793 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4794 switch (expr->op_type) {
4796 if (k2 && k2->op_type == OP_READLINE
4797 && (k2->op_flags & OPf_STACKED)
4798 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4799 expr = newUNOP(OP_DEFINED, 0, expr);
4803 if (k1 && (k1->op_type == OP_READDIR
4804 || k1->op_type == OP_GLOB
4805 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4806 || k1->op_type == OP_EACH))
4807 expr = newUNOP(OP_DEFINED, 0, expr);
4813 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4814 * op, in listop. This is wrong. [perl #27024] */
4816 block = newOP(OP_NULL, 0);
4817 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4818 o = new_logop(OP_AND, 0, &expr, &listop);
4821 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4823 if (once && o != listop)
4824 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4827 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4829 o->op_flags |= flags;
4831 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4836 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4837 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4846 PERL_UNUSED_ARG(debuggable);
4849 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4850 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4851 expr = newUNOP(OP_DEFINED, 0,
4852 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4853 } else if (expr->op_flags & OPf_KIDS) {
4854 const OP * const k1 = ((UNOP*)expr)->op_first;
4855 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4856 switch (expr->op_type) {
4858 if (k2 && k2->op_type == OP_READLINE
4859 && (k2->op_flags & OPf_STACKED)
4860 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4861 expr = newUNOP(OP_DEFINED, 0, expr);
4865 if (k1 && (k1->op_type == OP_READDIR
4866 || k1->op_type == OP_GLOB
4867 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4868 || k1->op_type == OP_EACH))
4869 expr = newUNOP(OP_DEFINED, 0, expr);
4876 block = newOP(OP_NULL, 0);
4877 else if (cont || has_my) {
4878 block = scope(block);
4882 next = LINKLIST(cont);
4885 OP * const unstack = newOP(OP_UNSTACK, 0);
4888 cont = append_elem(OP_LINESEQ, cont, unstack);
4892 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4894 redo = LINKLIST(listop);
4897 PL_parser->copline = (line_t)whileline;
4899 o = new_logop(OP_AND, 0, &expr, &listop);
4900 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4901 op_free(expr); /* oops, it's a while (0) */
4903 return NULL; /* listop already freed by new_logop */
4906 ((LISTOP*)listop)->op_last->op_next =
4907 (o == listop ? redo : LINKLIST(o));
4913 NewOp(1101,loop,1,LOOP);
4914 loop->op_type = OP_ENTERLOOP;
4915 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4916 loop->op_private = 0;
4917 loop->op_next = (OP*)loop;
4920 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4922 loop->op_redoop = redo;
4923 loop->op_lastop = o;
4924 o->op_private |= loopflags;
4927 loop->op_nextop = next;
4929 loop->op_nextop = o;
4931 o->op_flags |= flags;
4932 o->op_private |= (flags >> 8);
4937 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4942 PADOFFSET padoff = 0;
4947 PERL_ARGS_ASSERT_NEWFOROP;
4950 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4951 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4952 sv->op_type = OP_RV2GV;
4953 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4955 /* The op_type check is needed to prevent a possible segfault
4956 * if the loop variable is undeclared and 'strict vars' is in
4957 * effect. This is illegal but is nonetheless parsed, so we
4958 * may reach this point with an OP_CONST where we're expecting
4961 if (cUNOPx(sv)->op_first->op_type == OP_GV
4962 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4963 iterpflags |= OPpITER_DEF;
4965 else if (sv->op_type == OP_PADSV) { /* private variable */
4966 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4967 padoff = sv->op_targ;
4977 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4979 SV *const namesv = PAD_COMPNAME_SV(padoff);
4981 const char *const name = SvPV_const(namesv, len);
4983 if (len == 2 && name[0] == '$' && name[1] == '_')
4984 iterpflags |= OPpITER_DEF;
4988 const PADOFFSET offset = pad_findmy("$_");
4989 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4990 sv = newGVOP(OP_GV, 0, PL_defgv);
4995 iterpflags |= OPpITER_DEF;
4997 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4998 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4999 iterflags |= OPf_STACKED;
5001 else if (expr->op_type == OP_NULL &&
5002 (expr->op_flags & OPf_KIDS) &&
5003 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5005 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5006 * set the STACKED flag to indicate that these values are to be
5007 * treated as min/max values by 'pp_iterinit'.
5009 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5010 LOGOP* const range = (LOGOP*) flip->op_first;
5011 OP* const left = range->op_first;
5012 OP* const right = left->op_sibling;
5015 range->op_flags &= ~OPf_KIDS;
5016 range->op_first = NULL;
5018 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5019 listop->op_first->op_next = range->op_next;
5020 left->op_next = range->op_other;
5021 right->op_next = (OP*)listop;
5022 listop->op_next = listop->op_first;
5025 op_getmad(expr,(OP*)listop,'O');
5029 expr = (OP*)(listop);
5031 iterflags |= OPf_STACKED;
5034 expr = mod(force_list(expr), OP_GREPSTART);
5037 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5038 append_elem(OP_LIST, expr, scalar(sv))));
5039 assert(!loop->op_next);
5040 /* for my $x () sets OPpLVAL_INTRO;
5041 * for our $x () sets OPpOUR_INTRO */
5042 loop->op_private = (U8)iterpflags;
5043 #ifdef PL_OP_SLAB_ALLOC
5046 NewOp(1234,tmp,1,LOOP);
5047 Copy(loop,tmp,1,LISTOP);
5048 S_op_destroy(aTHX_ (OP*)loop);
5052 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5054 loop->op_targ = padoff;
5055 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5057 op_getmad(madsv, (OP*)loop, 'v');
5058 PL_parser->copline = forline;
5059 return newSTATEOP(0, label, wop);
5063 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5068 PERL_ARGS_ASSERT_NEWLOOPEX;
5070 if (type != OP_GOTO || label->op_type == OP_CONST) {
5071 /* "last()" means "last" */
5072 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5073 o = newOP(type, OPf_SPECIAL);
5075 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5076 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5080 op_getmad(label,o,'L');
5086 /* Check whether it's going to be a goto &function */
5087 if (label->op_type == OP_ENTERSUB
5088 && !(label->op_flags & OPf_STACKED))
5089 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5090 o = newUNOP(type, OPf_STACKED, label);
5092 PL_hints |= HINT_BLOCK_SCOPE;
5096 /* if the condition is a literal array or hash
5097 (or @{ ... } etc), make a reference to it.
5100 S_ref_array_or_hash(pTHX_ OP *cond)
5103 && (cond->op_type == OP_RV2AV
5104 || cond->op_type == OP_PADAV
5105 || cond->op_type == OP_RV2HV
5106 || cond->op_type == OP_PADHV))
5108 return newUNOP(OP_REFGEN,
5109 0, mod(cond, OP_REFGEN));
5115 /* These construct the optree fragments representing given()
5118 entergiven and enterwhen are LOGOPs; the op_other pointer
5119 points up to the associated leave op. We need this so we
5120 can put it in the context and make break/continue work.
5121 (Also, of course, pp_enterwhen will jump straight to
5122 op_other if the match fails.)
5126 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5127 I32 enter_opcode, I32 leave_opcode,
5128 PADOFFSET entertarg)
5134 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5136 NewOp(1101, enterop, 1, LOGOP);
5137 enterop->op_type = (Optype)enter_opcode;
5138 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5139 enterop->op_flags = (U8) OPf_KIDS;
5140 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5141 enterop->op_private = 0;
5143 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5146 enterop->op_first = scalar(cond);
5147 cond->op_sibling = block;
5149 o->op_next = LINKLIST(cond);
5150 cond->op_next = (OP *) enterop;
5153 /* This is a default {} block */
5154 enterop->op_first = block;
5155 enterop->op_flags |= OPf_SPECIAL;
5157 o->op_next = (OP *) enterop;
5160 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5161 entergiven and enterwhen both
5164 enterop->op_next = LINKLIST(block);
5165 block->op_next = enterop->op_other = o;
5170 /* Does this look like a boolean operation? For these purposes
5171 a boolean operation is:
5172 - a subroutine call [*]
5173 - a logical connective
5174 - a comparison operator
5175 - a filetest operator, with the exception of -s -M -A -C
5176 - defined(), exists() or eof()
5177 - /$re/ or $foo =~ /$re/
5179 [*] possibly surprising
5182 S_looks_like_bool(pTHX_ const OP *o)
5186 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5188 switch(o->op_type) {
5191 return looks_like_bool(cLOGOPo->op_first);
5195 looks_like_bool(cLOGOPo->op_first)
5196 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5200 o->op_flags & OPf_KIDS
5201 && looks_like_bool(cUNOPo->op_first));
5204 return looks_like_bool(cUNOPo->op_first);
5209 case OP_NOT: case OP_XOR:
5211 case OP_EQ: case OP_NE: case OP_LT:
5212 case OP_GT: case OP_LE: case OP_GE:
5214 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5215 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5217 case OP_SEQ: case OP_SNE: case OP_SLT:
5218 case OP_SGT: case OP_SLE: case OP_SGE:
5222 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5223 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5224 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5225 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5226 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5227 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5228 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5229 case OP_FTTEXT: case OP_FTBINARY:
5231 case OP_DEFINED: case OP_EXISTS:
5232 case OP_MATCH: case OP_EOF:
5239 /* Detect comparisons that have been optimized away */
5240 if (cSVOPo->op_sv == &PL_sv_yes
5241 || cSVOPo->op_sv == &PL_sv_no)
5254 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5257 PERL_ARGS_ASSERT_NEWGIVENOP;
5258 return newGIVWHENOP(
5259 ref_array_or_hash(cond),
5261 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5265 /* If cond is null, this is a default {} block */
5267 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5269 const bool cond_llb = (!cond || looks_like_bool(cond));
5272 PERL_ARGS_ASSERT_NEWWHENOP;
5277 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5279 scalar(ref_array_or_hash(cond)));
5282 return newGIVWHENOP(
5284 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5285 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5289 =for apidoc cv_undef
5291 Clear out all the active components of a CV. This can happen either
5292 by an explicit C<undef &foo>, or by the reference count going to zero.
5293 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5294 children can still follow the full lexical scope chain.
5300 Perl_cv_undef(pTHX_ CV *cv)
5304 PERL_ARGS_ASSERT_CV_UNDEF;
5306 DEBUG_X(PerlIO_printf(Perl_debug_log,
5307 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5308 PTR2UV(cv), PTR2UV(PL_comppad))
5312 if (CvFILE(cv) && !CvISXSUB(cv)) {
5313 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5314 Safefree(CvFILE(cv));
5319 if (!CvISXSUB(cv) && CvROOT(cv)) {
5320 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5321 Perl_croak(aTHX_ "Can't undef active subroutine");
5324 PAD_SAVE_SETNULLPAD();
5326 op_free(CvROOT(cv));
5331 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5336 /* remove CvOUTSIDE unless this is an undef rather than a free */
5337 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5338 if (!CvWEAKOUTSIDE(cv))
5339 SvREFCNT_dec(CvOUTSIDE(cv));
5340 CvOUTSIDE(cv) = NULL;
5343 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5346 if (CvISXSUB(cv) && CvXSUB(cv)) {
5349 /* delete all flags except WEAKOUTSIDE */
5350 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5354 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5357 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5359 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5360 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5361 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5362 || (p && (len != SvCUR(cv) /* Not the same length. */
5363 || memNE(p, SvPVX_const(cv), len))))
5364 && ckWARN_d(WARN_PROTOTYPE)) {
5365 SV* const msg = sv_newmortal();
5369 gv_efullname3(name = sv_newmortal(), gv, NULL);
5370 sv_setpvs(msg, "Prototype mismatch:");
5372 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5374 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5376 sv_catpvs(msg, ": none");
5377 sv_catpvs(msg, " vs ");
5379 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5381 sv_catpvs(msg, "none");
5382 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5386 static void const_sv_xsub(pTHX_ CV* cv);
5390 =head1 Optree Manipulation Functions
5392 =for apidoc cv_const_sv
5394 If C<cv> is a constant sub eligible for inlining. returns the constant
5395 value returned by the sub. Otherwise, returns NULL.
5397 Constant subs can be created with C<newCONSTSUB> or as described in
5398 L<perlsub/"Constant Functions">.
5403 Perl_cv_const_sv(pTHX_ const CV *const cv)
5405 PERL_UNUSED_CONTEXT;
5408 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5410 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5413 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5414 * Can be called in 3 ways:
5417 * look for a single OP_CONST with attached value: return the value
5419 * cv && CvCLONE(cv) && !CvCONST(cv)
5421 * examine the clone prototype, and if contains only a single
5422 * OP_CONST referencing a pad const, or a single PADSV referencing
5423 * an outer lexical, return a non-zero value to indicate the CV is
5424 * a candidate for "constizing" at clone time
5428 * We have just cloned an anon prototype that was marked as a const
5429 * candidiate. Try to grab the current value, and in the case of
5430 * PADSV, ignore it if it has multiple references. Return the value.
5434 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5445 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5446 o = cLISTOPo->op_first->op_sibling;
5448 for (; o; o = o->op_next) {
5449 const OPCODE type = o->op_type;
5451 if (sv && o->op_next == o)
5453 if (o->op_next != o) {
5454 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5456 if (type == OP_DBSTATE)
5459 if (type == OP_LEAVESUB || type == OP_RETURN)
5463 if (type == OP_CONST && cSVOPo->op_sv)
5465 else if (cv && type == OP_CONST) {
5466 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5470 else if (cv && type == OP_PADSV) {
5471 if (CvCONST(cv)) { /* newly cloned anon */
5472 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5473 /* the candidate should have 1 ref from this pad and 1 ref
5474 * from the parent */
5475 if (!sv || SvREFCNT(sv) != 2)
5482 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5483 sv = &PL_sv_undef; /* an arbitrary non-null value */
5498 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5501 /* This would be the return value, but the return cannot be reached. */
5502 OP* pegop = newOP(OP_NULL, 0);
5505 PERL_UNUSED_ARG(floor);
5515 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5517 NORETURN_FUNCTION_END;
5522 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5524 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5528 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5534 register CV *cv = NULL;
5536 /* If the subroutine has no body, no attributes, and no builtin attributes
5537 then it's just a sub declaration, and we may be able to get away with
5538 storing with a placeholder scalar in the symbol table, rather than a
5539 full GV and CV. If anything is present then it will take a full CV to
5541 const I32 gv_fetch_flags
5542 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5544 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5545 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5549 assert(proto->op_type == OP_CONST);
5550 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5556 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5558 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5559 SV * const sv = sv_newmortal();
5560 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5561 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5562 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5563 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5565 } else if (PL_curstash) {
5566 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5569 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5573 if (!PL_madskills) {
5582 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5583 maximum a prototype before. */
5584 if (SvTYPE(gv) > SVt_NULL) {
5585 if (!SvPOK((const SV *)gv)
5586 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5588 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5590 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5593 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5595 sv_setiv(MUTABLE_SV(gv), -1);
5597 SvREFCNT_dec(PL_compcv);
5598 cv = PL_compcv = NULL;
5602 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5604 if (!block || !ps || *ps || attrs
5605 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5607 || block->op_type == OP_NULL
5612 const_sv = op_const_sv(block, NULL);
5615 const bool exists = CvROOT(cv) || CvXSUB(cv);
5617 /* if the subroutine doesn't exist and wasn't pre-declared
5618 * with a prototype, assume it will be AUTOLOADed,
5619 * skipping the prototype check
5621 if (exists || SvPOK(cv))
5622 cv_ckproto_len(cv, gv, ps, ps_len);
5623 /* already defined (or promised)? */
5624 if (exists || GvASSUMECV(gv)) {
5627 || block->op_type == OP_NULL
5630 if (CvFLAGS(PL_compcv)) {
5631 /* might have had built-in attrs applied */
5632 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5634 /* just a "sub foo;" when &foo is already defined */
5635 SAVEFREESV(PL_compcv);
5640 && block->op_type != OP_NULL
5643 if (ckWARN(WARN_REDEFINE)
5645 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5647 const line_t oldline = CopLINE(PL_curcop);
5648 if (PL_parser && PL_parser->copline != NOLINE)
5649 CopLINE_set(PL_curcop, PL_parser->copline);
5650 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5651 CvCONST(cv) ? "Constant subroutine %s redefined"
5652 : "Subroutine %s redefined", name);
5653 CopLINE_set(PL_curcop, oldline);
5656 if (!PL_minus_c) /* keep old one around for madskills */
5659 /* (PL_madskills unset in used file.) */
5667 SvREFCNT_inc_simple_void_NN(const_sv);
5669 assert(!CvROOT(cv) && !CvCONST(cv));
5670 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5671 CvXSUBANY(cv).any_ptr = const_sv;
5672 CvXSUB(cv) = const_sv_xsub;
5678 cv = newCONSTSUB(NULL, name, const_sv);
5680 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5681 (CvGV(cv) && GvSTASH(CvGV(cv)))
5690 SvREFCNT_dec(PL_compcv);
5694 if (cv) { /* must reuse cv if autoloaded */
5695 /* transfer PL_compcv to cv */
5698 && block->op_type != OP_NULL
5702 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5703 if (!CvWEAKOUTSIDE(cv))
5704 SvREFCNT_dec(CvOUTSIDE(cv));
5705 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5706 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5707 CvOUTSIDE(PL_compcv) = 0;
5708 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5709 CvPADLIST(PL_compcv) = 0;
5710 /* inner references to PL_compcv must be fixed up ... */
5711 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5712 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5713 ++PL_sub_generation;
5716 /* Might have had built-in attributes applied -- propagate them. */
5717 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5719 /* ... before we throw it away */
5720 SvREFCNT_dec(PL_compcv);
5728 if (strEQ(name, "import")) {
5729 PL_formfeed = MUTABLE_SV(cv);
5730 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5734 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5739 CvFILE_set_from_cop(cv, PL_curcop);
5740 CvSTASH(cv) = PL_curstash;
5743 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5744 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5745 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5749 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5751 if (PL_parser && PL_parser->error_count) {
5755 const char *s = strrchr(name, ':');
5757 if (strEQ(s, "BEGIN")) {
5758 const char not_safe[] =
5759 "BEGIN not safe after errors--compilation aborted";
5760 if (PL_in_eval & EVAL_KEEPERR)
5761 Perl_croak(aTHX_ not_safe);
5763 /* force display of errors found but not reported */
5764 sv_catpv(ERRSV, not_safe);
5765 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5774 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5775 the debugger could be able to set a breakpoint in, so signal to
5776 pp_entereval that it should not throw away any saved lines at scope
5779 PL_breakable_sub_gen++;
5781 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5782 mod(scalarseq(block), OP_LEAVESUBLV));
5783 block->op_attached = 1;
5786 /* This makes sub {}; work as expected. */
5787 if (block->op_type == OP_STUB) {
5788 OP* const newblock = newSTATEOP(0, NULL, 0);
5790 op_getmad(block,newblock,'B');
5797 block->op_attached = 1;
5798 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5800 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5801 OpREFCNT_set(CvROOT(cv), 1);
5802 CvSTART(cv) = LINKLIST(CvROOT(cv));
5803 CvROOT(cv)->op_next = 0;
5804 CALL_PEEP(CvSTART(cv));
5806 /* now that optimizer has done its work, adjust pad values */
5808 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5811 assert(!CvCONST(cv));
5812 if (ps && !*ps && op_const_sv(block, cv))
5817 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5818 SV * const sv = newSV(0);
5819 SV * const tmpstr = sv_newmortal();
5820 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5821 GV_ADDMULTI, SVt_PVHV);
5824 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5826 (long)PL_subline, (long)CopLINE(PL_curcop));
5827 gv_efullname3(tmpstr, gv, NULL);
5828 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5829 SvCUR(tmpstr), sv, 0);
5830 hv = GvHVn(db_postponed);
5831 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5832 CV * const pcv = GvCV(db_postponed);
5838 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5843 if (name && ! (PL_parser && PL_parser->error_count))
5844 process_special_blocks(name, gv, cv);
5849 PL_parser->copline = NOLINE;
5855 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5858 const char *const colon = strrchr(fullname,':');
5859 const char *const name = colon ? colon + 1 : fullname;
5861 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5864 if (strEQ(name, "BEGIN")) {
5865 const I32 oldscope = PL_scopestack_ix;
5867 SAVECOPFILE(&PL_compiling);
5868 SAVECOPLINE(&PL_compiling);
5870 DEBUG_x( dump_sub(gv) );
5871 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5872 GvCV(gv) = 0; /* cv has been hijacked */
5873 call_list(oldscope, PL_beginav);
5875 PL_curcop = &PL_compiling;
5876 CopHINTS_set(&PL_compiling, PL_hints);
5883 if strEQ(name, "END") {
5884 DEBUG_x( dump_sub(gv) );
5885 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5888 } else if (*name == 'U') {
5889 if (strEQ(name, "UNITCHECK")) {
5890 /* It's never too late to run a unitcheck block */
5891 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5895 } else if (*name == 'C') {
5896 if (strEQ(name, "CHECK")) {
5898 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5899 "Too late to run CHECK block");
5900 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5904 } else if (*name == 'I') {
5905 if (strEQ(name, "INIT")) {
5907 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5908 "Too late to run INIT block");
5909 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5915 DEBUG_x( dump_sub(gv) );
5916 GvCV(gv) = 0; /* cv has been hijacked */
5921 =for apidoc newCONSTSUB
5923 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5924 eligible for inlining at compile-time.
5926 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5927 which won't be called if used as a destructor, but will suppress the overhead
5928 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5935 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5940 const char *const file = CopFILE(PL_curcop);
5942 SV *const temp_sv = CopFILESV(PL_curcop);
5943 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5948 if (IN_PERL_RUNTIME) {
5949 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5950 * an op shared between threads. Use a non-shared COP for our
5952 SAVEVPTR(PL_curcop);
5953 PL_curcop = &PL_compiling;
5955 SAVECOPLINE(PL_curcop);
5956 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5959 PL_hints &= ~HINT_BLOCK_SCOPE;
5962 SAVESPTR(PL_curstash);
5963 SAVECOPSTASH(PL_curcop);
5964 PL_curstash = stash;
5965 CopSTASH_set(PL_curcop,stash);
5968 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5969 and so doesn't get free()d. (It's expected to be from the C pre-
5970 processor __FILE__ directive). But we need a dynamically allocated one,
5971 and we need it to get freed. */
5972 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
5973 XS_DYNAMIC_FILENAME);
5974 CvXSUBANY(cv).any_ptr = sv;
5979 CopSTASH_free(PL_curcop);
5987 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5988 const char *const filename, const char *const proto,
5991 CV *cv = newXS(name, subaddr, filename);
5993 PERL_ARGS_ASSERT_NEWXS_FLAGS;
5995 if (flags & XS_DYNAMIC_FILENAME) {
5996 /* We need to "make arrangements" (ie cheat) to ensure that the
5997 filename lasts as long as the PVCV we just created, but also doesn't
5999 STRLEN filename_len = strlen(filename);
6000 STRLEN proto_and_file_len = filename_len;
6001 char *proto_and_file;
6005 proto_len = strlen(proto);
6006 proto_and_file_len += proto_len;
6008 Newx(proto_and_file, proto_and_file_len + 1, char);
6009 Copy(proto, proto_and_file, proto_len, char);
6010 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6013 proto_and_file = savepvn(filename, filename_len);
6016 /* This gets free()d. :-) */
6017 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6018 SV_HAS_TRAILING_NUL);
6020 /* This gives us the correct prototype, rather than one with the
6021 file name appended. */
6022 SvCUR_set(cv, proto_len);
6026 CvFILE(cv) = proto_and_file + proto_len;
6028 sv_setpv(MUTABLE_SV(cv), proto);
6034 =for apidoc U||newXS
6036 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6037 static storage, as it is used directly as CvFILE(), without a copy being made.
6043 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6046 GV * const gv = gv_fetchpv(name ? name :
6047 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6048 GV_ADDMULTI, SVt_PVCV);
6051 PERL_ARGS_ASSERT_NEWXS;
6054 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6056 if ((cv = (name ? GvCV(gv) : NULL))) {
6058 /* just a cached method */
6062 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6063 /* already defined (or promised) */
6064 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6065 if (ckWARN(WARN_REDEFINE)) {
6066 GV * const gvcv = CvGV(cv);
6068 HV * const stash = GvSTASH(gvcv);
6070 const char *redefined_name = HvNAME_get(stash);
6071 if ( strEQ(redefined_name,"autouse") ) {
6072 const line_t oldline = CopLINE(PL_curcop);
6073 if (PL_parser && PL_parser->copline != NOLINE)
6074 CopLINE_set(PL_curcop, PL_parser->copline);
6075 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6076 CvCONST(cv) ? "Constant subroutine %s redefined"
6077 : "Subroutine %s redefined"
6079 CopLINE_set(PL_curcop, oldline);
6089 if (cv) /* must reuse cv if autoloaded */
6092 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6096 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6100 (void)gv_fetchfile(filename);
6101 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6102 an external constant string */
6104 CvXSUB(cv) = subaddr;
6107 process_special_blocks(name, gv, cv);
6119 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6124 OP* pegop = newOP(OP_NULL, 0);
6128 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6129 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6132 if ((cv = GvFORM(gv))) {
6133 if (ckWARN(WARN_REDEFINE)) {
6134 const line_t oldline = CopLINE(PL_curcop);
6135 if (PL_parser && PL_parser->copline != NOLINE)
6136 CopLINE_set(PL_curcop, PL_parser->copline);
6138 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6139 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6141 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6142 "Format STDOUT redefined");
6144 CopLINE_set(PL_curcop, oldline);
6151 CvFILE_set_from_cop(cv, PL_curcop);
6154 pad_tidy(padtidy_FORMAT);
6155 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6156 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6157 OpREFCNT_set(CvROOT(cv), 1);
6158 CvSTART(cv) = LINKLIST(CvROOT(cv));
6159 CvROOT(cv)->op_next = 0;
6160 CALL_PEEP(CvSTART(cv));
6162 op_getmad(o,pegop,'n');
6163 op_getmad_weak(block, pegop, 'b');
6168 PL_parser->copline = NOLINE;
6176 Perl_newANONLIST(pTHX_ OP *o)
6178 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6182 Perl_newANONHASH(pTHX_ OP *o)
6184 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6188 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6190 return newANONATTRSUB(floor, proto, NULL, block);
6194 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6196 return newUNOP(OP_REFGEN, 0,
6197 newSVOP(OP_ANONCODE, 0,
6198 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6202 Perl_oopsAV(pTHX_ OP *o)
6206 PERL_ARGS_ASSERT_OOPSAV;
6208 switch (o->op_type) {
6210 o->op_type = OP_PADAV;
6211 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6212 return ref(o, OP_RV2AV);
6215 o->op_type = OP_RV2AV;
6216 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6221 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6228 Perl_oopsHV(pTHX_ OP *o)
6232 PERL_ARGS_ASSERT_OOPSHV;
6234 switch (o->op_type) {
6237 o->op_type = OP_PADHV;
6238 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6239 return ref(o, OP_RV2HV);
6243 o->op_type = OP_RV2HV;
6244 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6249 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6256 Perl_newAVREF(pTHX_ OP *o)
6260 PERL_ARGS_ASSERT_NEWAVREF;
6262 if (o->op_type == OP_PADANY) {
6263 o->op_type = OP_PADAV;
6264 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6267 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6268 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6269 "Using an array as a reference is deprecated");
6271 return newUNOP(OP_RV2AV, 0, scalar(o));
6275 Perl_newGVREF(pTHX_ I32 type, OP *o)
6277 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6278 return newUNOP(OP_NULL, 0, o);
6279 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6283 Perl_newHVREF(pTHX_ OP *o)
6287 PERL_ARGS_ASSERT_NEWHVREF;
6289 if (o->op_type == OP_PADANY) {
6290 o->op_type = OP_PADHV;
6291 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6294 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6295 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6296 "Using a hash as a reference is deprecated");
6298 return newUNOP(OP_RV2HV, 0, scalar(o));
6302 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6304 return newUNOP(OP_RV2CV, flags, scalar(o));
6308 Perl_newSVREF(pTHX_ OP *o)
6312 PERL_ARGS_ASSERT_NEWSVREF;
6314 if (o->op_type == OP_PADANY) {
6315 o->op_type = OP_PADSV;
6316 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6319 return newUNOP(OP_RV2SV, 0, scalar(o));
6322 /* Check routines. See the comments at the top of this file for details
6323 * on when these are called */
6326 Perl_ck_anoncode(pTHX_ OP *o)
6328 PERL_ARGS_ASSERT_CK_ANONCODE;
6330 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6332 cSVOPo->op_sv = NULL;
6337 Perl_ck_bitop(pTHX_ OP *o)
6341 PERL_ARGS_ASSERT_CK_BITOP;
6343 #define OP_IS_NUMCOMPARE(op) \
6344 ((op) == OP_LT || (op) == OP_I_LT || \
6345 (op) == OP_GT || (op) == OP_I_GT || \
6346 (op) == OP_LE || (op) == OP_I_LE || \
6347 (op) == OP_GE || (op) == OP_I_GE || \
6348 (op) == OP_EQ || (op) == OP_I_EQ || \
6349 (op) == OP_NE || (op) == OP_I_NE || \
6350 (op) == OP_NCMP || (op) == OP_I_NCMP)
6351 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6352 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6353 && (o->op_type == OP_BIT_OR
6354 || o->op_type == OP_BIT_AND
6355 || o->op_type == OP_BIT_XOR))
6357 const OP * const left = cBINOPo->op_first;
6358 const OP * const right = left->op_sibling;
6359 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6360 (left->op_flags & OPf_PARENS) == 0) ||
6361 (OP_IS_NUMCOMPARE(right->op_type) &&
6362 (right->op_flags & OPf_PARENS) == 0))
6363 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6364 "Possible precedence problem on bitwise %c operator",
6365 o->op_type == OP_BIT_OR ? '|'
6366 : o->op_type == OP_BIT_AND ? '&' : '^'
6373 Perl_ck_concat(pTHX_ OP *o)
6375 const OP * const kid = cUNOPo->op_first;
6377 PERL_ARGS_ASSERT_CK_CONCAT;
6378 PERL_UNUSED_CONTEXT;
6380 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6381 !(kUNOP->op_first->op_flags & OPf_MOD))
6382 o->op_flags |= OPf_STACKED;
6387 Perl_ck_spair(pTHX_ OP *o)
6391 PERL_ARGS_ASSERT_CK_SPAIR;
6393 if (o->op_flags & OPf_KIDS) {
6396 const OPCODE type = o->op_type;
6397 o = modkids(ck_fun(o), type);
6398 kid = cUNOPo->op_first;
6399 newop = kUNOP->op_first->op_sibling;
6401 const OPCODE type = newop->op_type;
6402 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6403 type == OP_PADAV || type == OP_PADHV ||
6404 type == OP_RV2AV || type == OP_RV2HV)
6408 op_getmad(kUNOP->op_first,newop,'K');
6410 op_free(kUNOP->op_first);
6412 kUNOP->op_first = newop;
6414 o->op_ppaddr = PL_ppaddr[++o->op_type];
6419 Perl_ck_delete(pTHX_ OP *o)
6421 PERL_ARGS_ASSERT_CK_DELETE;
6425 if (o->op_flags & OPf_KIDS) {
6426 OP * const kid = cUNOPo->op_first;
6427 switch (kid->op_type) {
6429 o->op_flags |= OPf_SPECIAL;
6432 o->op_private |= OPpSLICE;
6435 o->op_flags |= OPf_SPECIAL;
6440 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6443 if (kid->op_private & OPpLVAL_INTRO)
6444 o->op_private |= OPpLVAL_INTRO;
6451 Perl_ck_die(pTHX_ OP *o)
6453 PERL_ARGS_ASSERT_CK_DIE;
6456 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6462 Perl_ck_eof(pTHX_ OP *o)
6466 PERL_ARGS_ASSERT_CK_EOF;
6468 if (o->op_flags & OPf_KIDS) {
6469 if (cLISTOPo->op_first->op_type == OP_STUB) {
6471 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6473 op_getmad(o,newop,'O');
6485 Perl_ck_eval(pTHX_ OP *o)
6489 PERL_ARGS_ASSERT_CK_EVAL;
6491 PL_hints |= HINT_BLOCK_SCOPE;
6492 if (o->op_flags & OPf_KIDS) {
6493 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6496 o->op_flags &= ~OPf_KIDS;
6499 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6505 cUNOPo->op_first = 0;
6510 NewOp(1101, enter, 1, LOGOP);
6511 enter->op_type = OP_ENTERTRY;
6512 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6513 enter->op_private = 0;
6515 /* establish postfix order */
6516 enter->op_next = (OP*)enter;
6518 CHECKOP(OP_ENTERTRY, enter);
6520 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6521 o->op_type = OP_LEAVETRY;
6522 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6523 enter->op_other = o;
6524 op_getmad(oldo,o,'O');
6538 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6539 op_getmad(oldo,o,'O');
6541 o->op_targ = (PADOFFSET)PL_hints;
6542 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6543 /* Store a copy of %^H that pp_entereval can pick up. */
6544 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6545 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6546 cUNOPo->op_first->op_sibling = hhop;
6547 o->op_private |= OPpEVAL_HAS_HH;
6553 Perl_ck_exit(pTHX_ OP *o)
6555 PERL_ARGS_ASSERT_CK_EXIT;
6558 HV * const table = GvHV(PL_hintgv);
6560 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6561 if (svp && *svp && SvTRUE(*svp))
6562 o->op_private |= OPpEXIT_VMSISH;
6564 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6570 Perl_ck_exec(pTHX_ OP *o)
6572 PERL_ARGS_ASSERT_CK_EXEC;
6574 if (o->op_flags & OPf_STACKED) {
6577 kid = cUNOPo->op_first->op_sibling;
6578 if (kid->op_type == OP_RV2GV)
6587 Perl_ck_exists(pTHX_ OP *o)
6591 PERL_ARGS_ASSERT_CK_EXISTS;
6594 if (o->op_flags & OPf_KIDS) {
6595 OP * const kid = cUNOPo->op_first;
6596 if (kid->op_type == OP_ENTERSUB) {
6597 (void) ref(kid, o->op_type);
6598 if (kid->op_type != OP_RV2CV
6599 && !(PL_parser && PL_parser->error_count))
6600 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6602 o->op_private |= OPpEXISTS_SUB;
6604 else if (kid->op_type == OP_AELEM)
6605 o->op_flags |= OPf_SPECIAL;
6606 else if (kid->op_type != OP_HELEM)
6607 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6615 Perl_ck_rvconst(pTHX_ register OP *o)
6618 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6620 PERL_ARGS_ASSERT_CK_RVCONST;
6622 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6623 if (o->op_type == OP_RV2CV)
6624 o->op_private &= ~1;
6626 if (kid->op_type == OP_CONST) {
6629 SV * const kidsv = kid->op_sv;
6631 /* Is it a constant from cv_const_sv()? */
6632 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6633 SV * const rsv = SvRV(kidsv);
6634 const svtype type = SvTYPE(rsv);
6635 const char *badtype = NULL;
6637 switch (o->op_type) {
6639 if (type > SVt_PVMG)
6640 badtype = "a SCALAR";
6643 if (type != SVt_PVAV)
6644 badtype = "an ARRAY";
6647 if (type != SVt_PVHV)
6651 if (type != SVt_PVCV)
6656 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6659 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6660 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6661 /* If this is an access to a stash, disable "strict refs", because
6662 * stashes aren't auto-vivified at compile-time (unless we store
6663 * symbols in them), and we don't want to produce a run-time
6664 * stricture error when auto-vivifying the stash. */
6665 const char *s = SvPV_nolen(kidsv);
6666 const STRLEN l = SvCUR(kidsv);
6667 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6668 o->op_private &= ~HINT_STRICT_REFS;
6670 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6671 const char *badthing;
6672 switch (o->op_type) {
6674 badthing = "a SCALAR";
6677 badthing = "an ARRAY";
6680 badthing = "a HASH";
6688 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6689 SVfARG(kidsv), badthing);
6692 * This is a little tricky. We only want to add the symbol if we
6693 * didn't add it in the lexer. Otherwise we get duplicate strict
6694 * warnings. But if we didn't add it in the lexer, we must at
6695 * least pretend like we wanted to add it even if it existed before,
6696 * or we get possible typo warnings. OPpCONST_ENTERED says
6697 * whether the lexer already added THIS instance of this symbol.
6699 iscv = (o->op_type == OP_RV2CV) * 2;
6701 gv = gv_fetchsv(kidsv,
6702 iscv | !(kid->op_private & OPpCONST_ENTERED),
6705 : o->op_type == OP_RV2SV
6707 : o->op_type == OP_RV2AV
6709 : o->op_type == OP_RV2HV
6712 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6714 kid->op_type = OP_GV;
6715 SvREFCNT_dec(kid->op_sv);
6717 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6718 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6719 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6721 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6723 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6725 kid->op_private = 0;
6726 kid->op_ppaddr = PL_ppaddr[OP_GV];
6733 Perl_ck_ftst(pTHX_ OP *o)
6736 const I32 type = o->op_type;
6738 PERL_ARGS_ASSERT_CK_FTST;
6740 if (o->op_flags & OPf_REF) {
6743 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6744 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6745 const OPCODE kidtype = kid->op_type;
6747 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6748 OP * const newop = newGVOP(type, OPf_REF,
6749 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6751 op_getmad(o,newop,'O');
6757 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6758 o->op_private |= OPpFT_ACCESS;
6759 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6760 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6761 o->op_private |= OPpFT_STACKED;
6769 if (type == OP_FTTTY)
6770 o = newGVOP(type, OPf_REF, PL_stdingv);
6772 o = newUNOP(type, 0, newDEFSVOP());
6773 op_getmad(oldo,o,'O');
6779 Perl_ck_fun(pTHX_ OP *o)
6782 const int type = o->op_type;
6783 register I32 oa = PL_opargs[type] >> OASHIFT;
6785 PERL_ARGS_ASSERT_CK_FUN;
6787 if (o->op_flags & OPf_STACKED) {
6788 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6791 return no_fh_allowed(o);
6794 if (o->op_flags & OPf_KIDS) {
6795 OP **tokid = &cLISTOPo->op_first;
6796 register OP *kid = cLISTOPo->op_first;
6800 if (kid->op_type == OP_PUSHMARK ||
6801 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6803 tokid = &kid->op_sibling;
6804 kid = kid->op_sibling;
6806 if (!kid && PL_opargs[type] & OA_DEFGV)
6807 *tokid = kid = newDEFSVOP();
6811 sibl = kid->op_sibling;
6813 if (!sibl && kid->op_type == OP_STUB) {
6820 /* list seen where single (scalar) arg expected? */
6821 if (numargs == 1 && !(oa >> 4)
6822 && kid->op_type == OP_LIST && type != OP_SCALAR)
6824 return too_many_arguments(o,PL_op_desc[type]);
6837 if ((type == OP_PUSH || type == OP_UNSHIFT)
6838 && !kid->op_sibling)
6839 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6840 "Useless use of %s with no values",
6843 if (kid->op_type == OP_CONST &&
6844 (kid->op_private & OPpCONST_BARE))
6846 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6847 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6848 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6849 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6850 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6852 op_getmad(kid,newop,'K');
6857 kid->op_sibling = sibl;
6860 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6861 bad_type(numargs, "array", PL_op_desc[type], kid);
6865 if (kid->op_type == OP_CONST &&
6866 (kid->op_private & OPpCONST_BARE))
6868 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6869 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6870 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6871 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6872 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6874 op_getmad(kid,newop,'K');
6879 kid->op_sibling = sibl;
6882 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6883 bad_type(numargs, "hash", PL_op_desc[type], kid);
6888 OP * const newop = newUNOP(OP_NULL, 0, kid);
6889 kid->op_sibling = 0;
6891 newop->op_next = newop;
6893 kid->op_sibling = sibl;
6898 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6899 if (kid->op_type == OP_CONST &&
6900 (kid->op_private & OPpCONST_BARE))
6902 OP * const newop = newGVOP(OP_GV, 0,
6903 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6904 if (!(o->op_private & 1) && /* if not unop */
6905 kid == cLISTOPo->op_last)
6906 cLISTOPo->op_last = newop;
6908 op_getmad(kid,newop,'K');
6914 else if (kid->op_type == OP_READLINE) {
6915 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6916 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6919 I32 flags = OPf_SPECIAL;
6923 /* is this op a FH constructor? */
6924 if (is_handle_constructor(o,numargs)) {
6925 const char *name = NULL;
6929 /* Set a flag to tell rv2gv to vivify
6930 * need to "prove" flag does not mean something
6931 * else already - NI-S 1999/05/07
6934 if (kid->op_type == OP_PADSV) {
6936 = PAD_COMPNAME_SV(kid->op_targ);
6937 name = SvPV_const(namesv, len);
6939 else if (kid->op_type == OP_RV2SV
6940 && kUNOP->op_first->op_type == OP_GV)
6942 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6944 len = GvNAMELEN(gv);
6946 else if (kid->op_type == OP_AELEM
6947 || kid->op_type == OP_HELEM)
6950 OP *op = ((BINOP*)kid)->op_first;
6954 const char * const a =
6955 kid->op_type == OP_AELEM ?
6957 if (((op->op_type == OP_RV2AV) ||
6958 (op->op_type == OP_RV2HV)) &&
6959 (firstop = ((UNOP*)op)->op_first) &&
6960 (firstop->op_type == OP_GV)) {
6961 /* packagevar $a[] or $h{} */
6962 GV * const gv = cGVOPx_gv(firstop);
6970 else if (op->op_type == OP_PADAV
6971 || op->op_type == OP_PADHV) {
6972 /* lexicalvar $a[] or $h{} */
6973 const char * const padname =
6974 PAD_COMPNAME_PV(op->op_targ);
6983 name = SvPV_const(tmpstr, len);
6988 name = "__ANONIO__";
6995 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6996 namesv = PAD_SVl(targ);
6997 SvUPGRADE(namesv, SVt_PV);
6999 sv_setpvs(namesv, "$");
7000 sv_catpvn(namesv, name, len);
7003 kid->op_sibling = 0;
7004 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7005 kid->op_targ = targ;
7006 kid->op_private |= priv;
7008 kid->op_sibling = sibl;
7014 mod(scalar(kid), type);
7018 tokid = &kid->op_sibling;
7019 kid = kid->op_sibling;
7022 if (kid && kid->op_type != OP_STUB)
7023 return too_many_arguments(o,OP_DESC(o));
7024 o->op_private |= numargs;
7026 /* FIXME - should the numargs move as for the PERL_MAD case? */
7027 o->op_private |= numargs;
7029 return too_many_arguments(o,OP_DESC(o));
7033 else if (PL_opargs[type] & OA_DEFGV) {
7035 OP *newop = newUNOP(type, 0, newDEFSVOP());
7036 op_getmad(o,newop,'O');
7039 /* Ordering of these two is important to keep f_map.t passing. */
7041 return newUNOP(type, 0, newDEFSVOP());
7046 while (oa & OA_OPTIONAL)
7048 if (oa && oa != OA_LIST)
7049 return too_few_arguments(o,OP_DESC(o));
7055 Perl_ck_glob(pTHX_ OP *o)
7060 PERL_ARGS_ASSERT_CK_GLOB;
7063 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7064 append_elem(OP_GLOB, o, newDEFSVOP());
7066 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7067 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7069 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7072 #if !defined(PERL_EXTERNAL_GLOB)
7073 /* XXX this can be tightened up and made more failsafe. */
7074 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7077 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7078 newSVpvs("File::Glob"), NULL, NULL, NULL);
7079 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7080 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7081 GvCV(gv) = GvCV(glob_gv);
7082 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7083 GvIMPORTED_CV_on(gv);
7086 #endif /* PERL_EXTERNAL_GLOB */
7088 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7089 append_elem(OP_GLOB, o,
7090 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7091 o->op_type = OP_LIST;
7092 o->op_ppaddr = PL_ppaddr[OP_LIST];
7093 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7094 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7095 cLISTOPo->op_first->op_targ = 0;
7096 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7097 append_elem(OP_LIST, o,
7098 scalar(newUNOP(OP_RV2CV, 0,
7099 newGVOP(OP_GV, 0, gv)))));
7100 o = newUNOP(OP_NULL, 0, ck_subr(o));
7101 o->op_targ = OP_GLOB; /* hint at what it used to be */
7104 gv = newGVgen("main");
7106 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7112 Perl_ck_grep(pTHX_ OP *o)
7117 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7120 PERL_ARGS_ASSERT_CK_GREP;
7122 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7123 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7125 if (o->op_flags & OPf_STACKED) {
7128 kid = cLISTOPo->op_first->op_sibling;
7129 if (!cUNOPx(kid)->op_next)
7130 Perl_croak(aTHX_ "panic: ck_grep");
7131 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7134 NewOp(1101, gwop, 1, LOGOP);
7135 kid->op_next = (OP*)gwop;
7136 o->op_flags &= ~OPf_STACKED;
7138 kid = cLISTOPo->op_first->op_sibling;
7139 if (type == OP_MAPWHILE)
7144 if (PL_parser && PL_parser->error_count)
7146 kid = cLISTOPo->op_first->op_sibling;
7147 if (kid->op_type != OP_NULL)
7148 Perl_croak(aTHX_ "panic: ck_grep");
7149 kid = kUNOP->op_first;
7152 NewOp(1101, gwop, 1, LOGOP);
7153 gwop->op_type = type;
7154 gwop->op_ppaddr = PL_ppaddr[type];
7155 gwop->op_first = listkids(o);
7156 gwop->op_flags |= OPf_KIDS;
7157 gwop->op_other = LINKLIST(kid);
7158 kid->op_next = (OP*)gwop;
7159 offset = pad_findmy("$_");
7160 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7161 o->op_private = gwop->op_private = 0;
7162 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7165 o->op_private = gwop->op_private = OPpGREP_LEX;
7166 gwop->op_targ = o->op_targ = offset;
7169 kid = cLISTOPo->op_first->op_sibling;
7170 if (!kid || !kid->op_sibling)
7171 return too_few_arguments(o,OP_DESC(o));
7172 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7173 mod(kid, OP_GREPSTART);
7179 Perl_ck_index(pTHX_ OP *o)
7181 PERL_ARGS_ASSERT_CK_INDEX;
7183 if (o->op_flags & OPf_KIDS) {
7184 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7186 kid = kid->op_sibling; /* get past "big" */
7187 if (kid && kid->op_type == OP_CONST)
7188 fbm_compile(((SVOP*)kid)->op_sv, 0);
7194 Perl_ck_lfun(pTHX_ OP *o)
7196 const OPCODE type = o->op_type;
7198 PERL_ARGS_ASSERT_CK_LFUN;
7200 return modkids(ck_fun(o), type);
7204 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7206 PERL_ARGS_ASSERT_CK_DEFINED;
7208 if ((o->op_flags & OPf_KIDS)) {
7209 switch (cUNOPo->op_first->op_type) {
7211 /* This is needed for
7212 if (defined %stash::)
7213 to work. Do not break Tk.
7215 break; /* Globals via GV can be undef */
7217 case OP_AASSIGN: /* Is this a good idea? */
7218 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7219 "defined(@array) is deprecated");
7220 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7221 "\t(Maybe you should just omit the defined()?)\n");
7224 /* This is needed for
7225 if (defined %stash::)
7226 to work. Do not break Tk.
7228 break; /* Globals via GV can be undef */
7230 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7231 "defined(%%hash) is deprecated");
7232 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7233 "\t(Maybe you should just omit the defined()?)\n");
7244 Perl_ck_readline(pTHX_ OP *o)
7246 PERL_ARGS_ASSERT_CK_READLINE;
7248 if (!(o->op_flags & OPf_KIDS)) {
7250 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7252 op_getmad(o,newop,'O');
7262 Perl_ck_rfun(pTHX_ OP *o)
7264 const OPCODE type = o->op_type;
7266 PERL_ARGS_ASSERT_CK_RFUN;
7268 return refkids(ck_fun(o), type);
7272 Perl_ck_listiob(pTHX_ OP *o)
7276 PERL_ARGS_ASSERT_CK_LISTIOB;
7278 kid = cLISTOPo->op_first;
7281 kid = cLISTOPo->op_first;
7283 if (kid->op_type == OP_PUSHMARK)
7284 kid = kid->op_sibling;
7285 if (kid && o->op_flags & OPf_STACKED)
7286 kid = kid->op_sibling;
7287 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7288 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7289 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7290 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7291 cLISTOPo->op_first->op_sibling = kid;
7292 cLISTOPo->op_last = kid;
7293 kid = kid->op_sibling;
7298 append_elem(o->op_type, o, newDEFSVOP());
7304 Perl_ck_smartmatch(pTHX_ OP *o)
7307 if (0 == (o->op_flags & OPf_SPECIAL)) {
7308 OP *first = cBINOPo->op_first;
7309 OP *second = first->op_sibling;
7311 /* Implicitly take a reference to an array or hash */
7312 first->op_sibling = NULL;
7313 first = cBINOPo->op_first = ref_array_or_hash(first);
7314 second = first->op_sibling = ref_array_or_hash(second);
7316 /* Implicitly take a reference to a regular expression */
7317 if (first->op_type == OP_MATCH) {
7318 first->op_type = OP_QR;
7319 first->op_ppaddr = PL_ppaddr[OP_QR];
7321 if (second->op_type == OP_MATCH) {
7322 second->op_type = OP_QR;
7323 second->op_ppaddr = PL_ppaddr[OP_QR];
7332 Perl_ck_sassign(pTHX_ OP *o)
7335 OP * const kid = cLISTOPo->op_first;
7337 PERL_ARGS_ASSERT_CK_SASSIGN;
7339 /* has a disposable target? */
7340 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7341 && !(kid->op_flags & OPf_STACKED)
7342 /* Cannot steal the second time! */
7343 && !(kid->op_private & OPpTARGET_MY)
7344 /* Keep the full thing for madskills */
7348 OP * const kkid = kid->op_sibling;
7350 /* Can just relocate the target. */
7351 if (kkid && kkid->op_type == OP_PADSV
7352 && !(kkid->op_private & OPpLVAL_INTRO))
7354 kid->op_targ = kkid->op_targ;
7356 /* Now we do not need PADSV and SASSIGN. */
7357 kid->op_sibling = o->op_sibling; /* NULL */
7358 cLISTOPo->op_first = NULL;
7361 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7365 if (kid->op_sibling) {
7366 OP *kkid = kid->op_sibling;
7367 if (kkid->op_type == OP_PADSV
7368 && (kkid->op_private & OPpLVAL_INTRO)
7369 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7370 const PADOFFSET target = kkid->op_targ;
7371 OP *const other = newOP(OP_PADSV,
7373 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7374 OP *const first = newOP(OP_NULL, 0);
7375 OP *const nullop = newCONDOP(0, first, o, other);
7376 OP *const condop = first->op_next;
7377 /* hijacking PADSTALE for uninitialized state variables */
7378 SvPADSTALE_on(PAD_SVl(target));
7380 condop->op_type = OP_ONCE;
7381 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7382 condop->op_targ = target;
7383 other->op_targ = target;
7385 /* Because we change the type of the op here, we will skip the
7386 assinment binop->op_last = binop->op_first->op_sibling; at the
7387 end of Perl_newBINOP(). So need to do it here. */
7388 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7397 Perl_ck_match(pTHX_ OP *o)
7401 PERL_ARGS_ASSERT_CK_MATCH;
7403 if (o->op_type != OP_QR && PL_compcv) {
7404 const PADOFFSET offset = pad_findmy("$_");
7405 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7406 o->op_targ = offset;
7407 o->op_private |= OPpTARGET_MY;
7410 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7411 o->op_private |= OPpRUNTIME;
7416 Perl_ck_method(pTHX_ OP *o)
7418 OP * const kid = cUNOPo->op_first;
7420 PERL_ARGS_ASSERT_CK_METHOD;
7422 if (kid->op_type == OP_CONST) {
7423 SV* sv = kSVOP->op_sv;
7424 const char * const method = SvPVX_const(sv);
7425 if (!(strchr(method, ':') || strchr(method, '\''))) {
7427 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7428 sv = newSVpvn_share(method, SvCUR(sv), 0);
7431 kSVOP->op_sv = NULL;
7433 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7435 op_getmad(o,cmop,'O');
7446 Perl_ck_null(pTHX_ OP *o)
7448 PERL_ARGS_ASSERT_CK_NULL;
7449 PERL_UNUSED_CONTEXT;
7454 Perl_ck_open(pTHX_ OP *o)
7457 HV * const table = GvHV(PL_hintgv);
7459 PERL_ARGS_ASSERT_CK_OPEN;
7462 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7465 const char *d = SvPV_const(*svp, len);
7466 const I32 mode = mode_from_discipline(d, len);
7467 if (mode & O_BINARY)
7468 o->op_private |= OPpOPEN_IN_RAW;
7469 else if (mode & O_TEXT)
7470 o->op_private |= OPpOPEN_IN_CRLF;
7473 svp = hv_fetchs(table, "open_OUT", FALSE);
7476 const char *d = SvPV_const(*svp, len);
7477 const I32 mode = mode_from_discipline(d, len);
7478 if (mode & O_BINARY)
7479 o->op_private |= OPpOPEN_OUT_RAW;
7480 else if (mode & O_TEXT)
7481 o->op_private |= OPpOPEN_OUT_CRLF;
7484 if (o->op_type == OP_BACKTICK) {
7485 if (!(o->op_flags & OPf_KIDS)) {
7486 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7488 op_getmad(o,newop,'O');
7497 /* In case of three-arg dup open remove strictness
7498 * from the last arg if it is a bareword. */
7499 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7500 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7504 if ((last->op_type == OP_CONST) && /* The bareword. */
7505 (last->op_private & OPpCONST_BARE) &&
7506 (last->op_private & OPpCONST_STRICT) &&
7507 (oa = first->op_sibling) && /* The fh. */
7508 (oa = oa->op_sibling) && /* The mode. */
7509 (oa->op_type == OP_CONST) &&
7510 SvPOK(((SVOP*)oa)->op_sv) &&
7511 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7512 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7513 (last == oa->op_sibling)) /* The bareword. */
7514 last->op_private &= ~OPpCONST_STRICT;
7520 Perl_ck_repeat(pTHX_ OP *o)
7522 PERL_ARGS_ASSERT_CK_REPEAT;
7524 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7525 o->op_private |= OPpREPEAT_DOLIST;
7526 cBINOPo->op_first = force_list(cBINOPo->op_first);
7534 Perl_ck_require(pTHX_ OP *o)
7539 PERL_ARGS_ASSERT_CK_REQUIRE;
7541 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7542 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7544 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7545 SV * const sv = kid->op_sv;
7546 U32 was_readonly = SvREADONLY(sv);
7553 sv_force_normal_flags(sv, 0);
7554 assert(!SvREADONLY(sv));
7564 for (; s < end; s++) {
7565 if (*s == ':' && s[1] == ':') {
7567 Move(s+2, s+1, end - s - 1, char);
7572 sv_catpvs(sv, ".pm");
7573 SvFLAGS(sv) |= was_readonly;
7577 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7578 /* handle override, if any */
7579 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7580 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7581 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7582 gv = gvp ? *gvp : NULL;
7586 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7587 OP * const kid = cUNOPo->op_first;
7590 cUNOPo->op_first = 0;
7594 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7595 append_elem(OP_LIST, kid,
7596 scalar(newUNOP(OP_RV2CV, 0,
7599 op_getmad(o,newop,'O');
7607 Perl_ck_return(pTHX_ OP *o)
7612 PERL_ARGS_ASSERT_CK_RETURN;
7614 kid = cLISTOPo->op_first->op_sibling;
7615 if (CvLVALUE(PL_compcv)) {
7616 for (; kid; kid = kid->op_sibling)
7617 mod(kid, OP_LEAVESUBLV);
7619 for (; kid; kid = kid->op_sibling)
7620 if ((kid->op_type == OP_NULL)
7621 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7622 /* This is a do block */
7623 OP *op = kUNOP->op_first;
7624 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7625 op = cUNOPx(op)->op_first;
7626 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7627 /* Force the use of the caller's context */
7628 op->op_flags |= OPf_SPECIAL;
7637 Perl_ck_select(pTHX_ OP *o)
7642 PERL_ARGS_ASSERT_CK_SELECT;
7644 if (o->op_flags & OPf_KIDS) {
7645 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7646 if (kid && kid->op_sibling) {
7647 o->op_type = OP_SSELECT;
7648 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7650 return fold_constants(o);
7654 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7655 if (kid && kid->op_type == OP_RV2GV)
7656 kid->op_private &= ~HINT_STRICT_REFS;
7661 Perl_ck_shift(pTHX_ OP *o)
7664 const I32 type = o->op_type;
7666 PERL_ARGS_ASSERT_CK_SHIFT;
7668 if (!(o->op_flags & OPf_KIDS)) {
7669 OP *argop = newUNOP(OP_RV2AV, 0,
7670 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7672 OP * const oldo = o;
7673 o = newUNOP(type, 0, scalar(argop));
7674 op_getmad(oldo,o,'O');
7678 return newUNOP(type, 0, scalar(argop));
7681 return scalar(modkids(ck_fun(o), type));
7685 Perl_ck_sort(pTHX_ OP *o)
7690 PERL_ARGS_ASSERT_CK_SORT;
7692 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7693 HV * const hinthv = GvHV(PL_hintgv);
7695 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7697 const I32 sorthints = (I32)SvIV(*svp);
7698 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7699 o->op_private |= OPpSORT_QSORT;
7700 if ((sorthints & HINT_SORT_STABLE) != 0)
7701 o->op_private |= OPpSORT_STABLE;
7706 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7708 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7709 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7711 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7713 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7715 if (kid->op_type == OP_SCOPE) {
7719 else if (kid->op_type == OP_LEAVE) {
7720 if (o->op_type == OP_SORT) {
7721 op_null(kid); /* wipe out leave */
7724 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7725 if (k->op_next == kid)
7727 /* don't descend into loops */
7728 else if (k->op_type == OP_ENTERLOOP
7729 || k->op_type == OP_ENTERITER)
7731 k = cLOOPx(k)->op_lastop;
7736 kid->op_next = 0; /* just disconnect the leave */
7737 k = kLISTOP->op_first;
7742 if (o->op_type == OP_SORT) {
7743 /* provide scalar context for comparison function/block */
7749 o->op_flags |= OPf_SPECIAL;
7751 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7754 firstkid = firstkid->op_sibling;
7757 /* provide list context for arguments */
7758 if (o->op_type == OP_SORT)
7765 S_simplify_sort(pTHX_ OP *o)
7768 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7774 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7776 if (!(o->op_flags & OPf_STACKED))
7778 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7779 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7780 kid = kUNOP->op_first; /* get past null */
7781 if (kid->op_type != OP_SCOPE)
7783 kid = kLISTOP->op_last; /* get past scope */
7784 switch(kid->op_type) {
7792 k = kid; /* remember this node*/
7793 if (kBINOP->op_first->op_type != OP_RV2SV)
7795 kid = kBINOP->op_first; /* get past cmp */
7796 if (kUNOP->op_first->op_type != OP_GV)
7798 kid = kUNOP->op_first; /* get past rv2sv */
7800 if (GvSTASH(gv) != PL_curstash)
7802 gvname = GvNAME(gv);
7803 if (*gvname == 'a' && gvname[1] == '\0')
7805 else if (*gvname == 'b' && gvname[1] == '\0')
7810 kid = k; /* back to cmp */
7811 if (kBINOP->op_last->op_type != OP_RV2SV)
7813 kid = kBINOP->op_last; /* down to 2nd arg */
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);
7822 ? !(*gvname == 'a' && gvname[1] == '\0')
7823 : !(*gvname == 'b' && gvname[1] == '\0'))
7825 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7827 o->op_private |= OPpSORT_DESCEND;
7828 if (k->op_type == OP_NCMP)
7829 o->op_private |= OPpSORT_NUMERIC;
7830 if (k->op_type == OP_I_NCMP)
7831 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7832 kid = cLISTOPo->op_first->op_sibling;
7833 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7835 op_getmad(kid,o,'S'); /* then delete it */
7837 op_free(kid); /* then delete it */
7842 Perl_ck_split(pTHX_ OP *o)
7847 PERL_ARGS_ASSERT_CK_SPLIT;
7849 if (o->op_flags & OPf_STACKED)
7850 return no_fh_allowed(o);
7852 kid = cLISTOPo->op_first;
7853 if (kid->op_type != OP_NULL)
7854 Perl_croak(aTHX_ "panic: ck_split");
7855 kid = kid->op_sibling;
7856 op_free(cLISTOPo->op_first);
7857 cLISTOPo->op_first = kid;
7859 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7860 cLISTOPo->op_last = kid; /* There was only one element previously */
7863 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7864 OP * const sibl = kid->op_sibling;
7865 kid->op_sibling = 0;
7866 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7867 if (cLISTOPo->op_first == cLISTOPo->op_last)
7868 cLISTOPo->op_last = kid;
7869 cLISTOPo->op_first = kid;
7870 kid->op_sibling = sibl;
7873 kid->op_type = OP_PUSHRE;
7874 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7876 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7877 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7878 "Use of /g modifier is meaningless in split");
7881 if (!kid->op_sibling)
7882 append_elem(OP_SPLIT, o, newDEFSVOP());
7884 kid = kid->op_sibling;
7887 if (!kid->op_sibling)
7888 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7889 assert(kid->op_sibling);
7891 kid = kid->op_sibling;
7894 if (kid->op_sibling)
7895 return too_many_arguments(o,OP_DESC(o));
7901 Perl_ck_join(pTHX_ OP *o)
7903 const OP * const kid = cLISTOPo->op_first->op_sibling;
7905 PERL_ARGS_ASSERT_CK_JOIN;
7907 if (kid && kid->op_type == OP_MATCH) {
7908 if (ckWARN(WARN_SYNTAX)) {
7909 const REGEXP *re = PM_GETRE(kPMOP);
7910 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7911 const STRLEN len = re ? RX_PRELEN(re) : 6;
7912 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7913 "/%.*s/ should probably be written as \"%.*s\"",
7914 (int)len, pmstr, (int)len, pmstr);
7921 Perl_ck_subr(pTHX_ OP *o)
7924 OP *prev = ((cUNOPo->op_first->op_sibling)
7925 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7926 OP *o2 = prev->op_sibling;
7928 const char *proto = NULL;
7929 const char *proto_end = NULL;
7934 I32 contextclass = 0;
7935 const char *e = NULL;
7938 PERL_ARGS_ASSERT_CK_SUBR;
7940 o->op_private |= OPpENTERSUB_HASTARG;
7941 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7942 if (cvop->op_type == OP_RV2CV) {
7944 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7945 op_null(cvop); /* disable rv2cv */
7946 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7947 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7948 GV *gv = cGVOPx_gv(tmpop);
7951 tmpop->op_private |= OPpEARLY_CV;
7955 namegv = CvANON(cv) ? gv : CvGV(cv);
7956 proto = SvPV(MUTABLE_SV(cv), len);
7957 proto_end = proto + len;
7962 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7963 if (o2->op_type == OP_CONST)
7964 o2->op_private &= ~OPpCONST_STRICT;
7965 else if (o2->op_type == OP_LIST) {
7966 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7967 if (sib && sib->op_type == OP_CONST)
7968 sib->op_private &= ~OPpCONST_STRICT;
7971 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7972 if (PERLDB_SUB && PL_curstash != PL_debstash)
7973 o->op_private |= OPpENTERSUB_DB;
7974 while (o2 != cvop) {
7976 if (PL_madskills && o2->op_type == OP_STUB) {
7977 o2 = o2->op_sibling;
7980 if (PL_madskills && o2->op_type == OP_NULL)
7981 o3 = ((UNOP*)o2)->op_first;
7985 if (proto >= proto_end)
7986 return too_many_arguments(o, gv_ename(namegv));
7994 /* _ must be at the end */
7995 if (proto[1] && proto[1] != ';')
8010 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8012 arg == 1 ? "block or sub {}" : "sub {}",
8013 gv_ename(namegv), o3);
8016 /* '*' allows any scalar type, including bareword */
8019 if (o3->op_type == OP_RV2GV)
8020 goto wrapref; /* autoconvert GLOB -> GLOBref */
8021 else if (o3->op_type == OP_CONST)
8022 o3->op_private &= ~OPpCONST_STRICT;
8023 else if (o3->op_type == OP_ENTERSUB) {
8024 /* accidental subroutine, revert to bareword */
8025 OP *gvop = ((UNOP*)o3)->op_first;
8026 if (gvop && gvop->op_type == OP_NULL) {
8027 gvop = ((UNOP*)gvop)->op_first;
8029 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8032 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8033 (gvop = ((UNOP*)gvop)->op_first) &&
8034 gvop->op_type == OP_GV)
8036 GV * const gv = cGVOPx_gv(gvop);
8037 OP * const sibling = o2->op_sibling;
8038 SV * const n = newSVpvs("");
8040 OP * const oldo2 = o2;
8044 gv_fullname4(n, gv, "", FALSE);
8045 o2 = newSVOP(OP_CONST, 0, n);
8046 op_getmad(oldo2,o2,'O');
8047 prev->op_sibling = o2;
8048 o2->op_sibling = sibling;
8064 if (contextclass++ == 0) {
8065 e = strchr(proto, ']');
8066 if (!e || e == proto)
8075 const char *p = proto;
8076 const char *const end = proto;
8078 while (*--p != '[') {}
8079 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8081 gv_ename(namegv), o3);
8086 if (o3->op_type == OP_RV2GV)
8089 bad_type(arg, "symbol", gv_ename(namegv), o3);
8092 if (o3->op_type == OP_ENTERSUB)
8095 bad_type(arg, "subroutine entry", gv_ename(namegv),
8099 if (o3->op_type == OP_RV2SV ||
8100 o3->op_type == OP_PADSV ||
8101 o3->op_type == OP_HELEM ||
8102 o3->op_type == OP_AELEM)
8105 bad_type(arg, "scalar", gv_ename(namegv), o3);
8108 if (o3->op_type == OP_RV2AV ||
8109 o3->op_type == OP_PADAV)
8112 bad_type(arg, "array", gv_ename(namegv), o3);
8115 if (o3->op_type == OP_RV2HV ||
8116 o3->op_type == OP_PADHV)
8119 bad_type(arg, "hash", gv_ename(namegv), o3);
8124 OP* const sib = kid->op_sibling;
8125 kid->op_sibling = 0;
8126 o2 = newUNOP(OP_REFGEN, 0, kid);
8127 o2->op_sibling = sib;
8128 prev->op_sibling = o2;
8130 if (contextclass && e) {
8145 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8146 gv_ename(namegv), SVfARG(cv));
8151 mod(o2, OP_ENTERSUB);
8153 o2 = o2->op_sibling;
8155 if (o2 == cvop && proto && *proto == '_') {
8156 /* generate an access to $_ */
8158 o2->op_sibling = prev->op_sibling;
8159 prev->op_sibling = o2; /* instead of cvop */
8161 if (proto && !optional && proto_end > proto &&
8162 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8163 return too_few_arguments(o, gv_ename(namegv));
8166 OP * const oldo = o;
8170 o=newSVOP(OP_CONST, 0, newSViv(0));
8171 op_getmad(oldo,o,'O');
8177 Perl_ck_svconst(pTHX_ OP *o)
8179 PERL_ARGS_ASSERT_CK_SVCONST;
8180 PERL_UNUSED_CONTEXT;
8181 SvREADONLY_on(cSVOPo->op_sv);
8186 Perl_ck_chdir(pTHX_ OP *o)
8188 if (o->op_flags & OPf_KIDS) {
8189 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8191 if (kid && kid->op_type == OP_CONST &&
8192 (kid->op_private & OPpCONST_BARE))
8194 o->op_flags |= OPf_SPECIAL;
8195 kid->op_private &= ~OPpCONST_STRICT;
8202 Perl_ck_trunc(pTHX_ OP *o)
8204 PERL_ARGS_ASSERT_CK_TRUNC;
8206 if (o->op_flags & OPf_KIDS) {
8207 SVOP *kid = (SVOP*)cUNOPo->op_first;
8209 if (kid->op_type == OP_NULL)
8210 kid = (SVOP*)kid->op_sibling;
8211 if (kid && kid->op_type == OP_CONST &&
8212 (kid->op_private & OPpCONST_BARE))
8214 o->op_flags |= OPf_SPECIAL;
8215 kid->op_private &= ~OPpCONST_STRICT;
8222 Perl_ck_unpack(pTHX_ OP *o)
8224 OP *kid = cLISTOPo->op_first;
8226 PERL_ARGS_ASSERT_CK_UNPACK;
8228 if (kid->op_sibling) {
8229 kid = kid->op_sibling;
8230 if (!kid->op_sibling)
8231 kid->op_sibling = newDEFSVOP();
8237 Perl_ck_substr(pTHX_ OP *o)
8239 PERL_ARGS_ASSERT_CK_SUBSTR;
8242 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8243 OP *kid = cLISTOPo->op_first;
8245 if (kid->op_type == OP_NULL)
8246 kid = kid->op_sibling;
8248 kid->op_flags |= OPf_MOD;
8255 Perl_ck_each(pTHX_ OP *o)
8258 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8260 PERL_ARGS_ASSERT_CK_EACH;
8263 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8264 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8265 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8266 o->op_type = new_type;
8267 o->op_ppaddr = PL_ppaddr[new_type];
8269 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8270 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8272 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8279 /* caller is supposed to assign the return to the
8280 container of the rep_op var */
8282 S_opt_scalarhv(pTHX_ OP *rep_op) {
8285 PERL_ARGS_ASSERT_OPT_SCALARHV;
8287 NewOp(1101, unop, 1, UNOP);
8288 unop->op_type = (OPCODE)OP_BOOLKEYS;
8289 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8290 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8291 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8292 unop->op_first = rep_op;
8293 unop->op_next = rep_op->op_next;
8294 rep_op->op_next = (OP*)unop;
8295 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8296 unop->op_sibling = rep_op->op_sibling;
8297 rep_op->op_sibling = NULL;
8298 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8299 if (rep_op->op_type == OP_PADHV) {
8300 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8301 rep_op->op_flags |= OPf_WANT_LIST;
8306 /* A peephole optimizer. We visit the ops in the order they're to execute.
8307 * See the comments at the top of this file for more details about when
8308 * peep() is called */
8311 Perl_peep(pTHX_ register OP *o)
8314 register OP* oldop = NULL;
8316 if (!o || o->op_opt)
8320 SAVEVPTR(PL_curcop);
8321 for (; o; o = o->op_next) {
8324 /* By default, this op has now been optimised. A couple of cases below
8325 clear this again. */
8328 switch (o->op_type) {
8331 PL_curcop = ((COP*)o); /* for warnings */
8335 if (cSVOPo->op_private & OPpCONST_STRICT)
8336 no_bareword_allowed(o);
8339 case OP_METHOD_NAMED:
8340 /* Relocate sv to the pad for thread safety.
8341 * Despite being a "constant", the SV is written to,
8342 * for reference counts, sv_upgrade() etc. */
8344 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8345 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8346 /* If op_sv is already a PADTMP then it is being used by
8347 * some pad, so make a copy. */
8348 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8349 SvREADONLY_on(PAD_SVl(ix));
8350 SvREFCNT_dec(cSVOPo->op_sv);
8352 else if (o->op_type != OP_METHOD_NAMED
8353 && cSVOPo->op_sv == &PL_sv_undef) {
8354 /* PL_sv_undef is hack - it's unsafe to store it in the
8355 AV that is the pad, because av_fetch treats values of
8356 PL_sv_undef as a "free" AV entry and will merrily
8357 replace them with a new SV, causing pad_alloc to think
8358 that this pad slot is free. (When, clearly, it is not)
8360 SvOK_off(PAD_SVl(ix));
8361 SvPADTMP_on(PAD_SVl(ix));
8362 SvREADONLY_on(PAD_SVl(ix));
8365 SvREFCNT_dec(PAD_SVl(ix));
8366 SvPADTMP_on(cSVOPo->op_sv);
8367 PAD_SETSV(ix, cSVOPo->op_sv);
8368 /* XXX I don't know how this isn't readonly already. */
8369 SvREADONLY_on(PAD_SVl(ix));
8371 cSVOPo->op_sv = NULL;
8378 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8379 if (o->op_next->op_private & OPpTARGET_MY) {
8380 if (o->op_flags & OPf_STACKED) /* chained concats */
8381 break; /* ignore_optimization */
8383 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8384 o->op_targ = o->op_next->op_targ;
8385 o->op_next->op_targ = 0;
8386 o->op_private |= OPpTARGET_MY;
8389 op_null(o->op_next);
8393 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8394 break; /* Scalar stub must produce undef. List stub is noop */
8398 if (o->op_targ == OP_NEXTSTATE
8399 || o->op_targ == OP_DBSTATE)
8401 PL_curcop = ((COP*)o);
8403 /* XXX: We avoid setting op_seq here to prevent later calls
8404 to peep() from mistakenly concluding that optimisation
8405 has already occurred. This doesn't fix the real problem,
8406 though (See 20010220.007). AMS 20010719 */
8407 /* op_seq functionality is now replaced by op_opt */
8414 if (oldop && o->op_next) {
8415 oldop->op_next = o->op_next;
8423 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8424 OP* const pop = (o->op_type == OP_PADAV) ?
8425 o->op_next : o->op_next->op_next;
8427 if (pop && pop->op_type == OP_CONST &&
8428 ((PL_op = pop->op_next)) &&
8429 pop->op_next->op_type == OP_AELEM &&
8430 !(pop->op_next->op_private &
8431 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8432 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8437 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8438 no_bareword_allowed(pop);
8439 if (o->op_type == OP_GV)
8440 op_null(o->op_next);
8441 op_null(pop->op_next);
8443 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8444 o->op_next = pop->op_next->op_next;
8445 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8446 o->op_private = (U8)i;
8447 if (o->op_type == OP_GV) {
8452 o->op_flags |= OPf_SPECIAL;
8453 o->op_type = OP_AELEMFAST;
8458 if (o->op_next->op_type == OP_RV2SV) {
8459 if (!(o->op_next->op_private & OPpDEREF)) {
8460 op_null(o->op_next);
8461 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8463 o->op_next = o->op_next->op_next;
8464 o->op_type = OP_GVSV;
8465 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8468 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8469 GV * const gv = cGVOPo_gv;
8470 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8471 /* XXX could check prototype here instead of just carping */
8472 SV * const sv = sv_newmortal();
8473 gv_efullname3(sv, gv, NULL);
8474 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8475 "%"SVf"() called too early to check prototype",
8479 else if (o->op_next->op_type == OP_READLINE
8480 && o->op_next->op_next->op_type == OP_CONCAT
8481 && (o->op_next->op_next->op_flags & OPf_STACKED))
8483 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8484 o->op_type = OP_RCATLINE;
8485 o->op_flags |= OPf_STACKED;
8486 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8487 op_null(o->op_next->op_next);
8488 op_null(o->op_next);
8498 fop = cUNOP->op_first;
8506 fop = cLOGOP->op_first;
8507 sop = fop->op_sibling;
8508 while (cLOGOP->op_other->op_type == OP_NULL)
8509 cLOGOP->op_other = cLOGOP->op_other->op_next;
8510 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8514 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8516 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8521 if (!(nop->op_flags && OPf_WANT_VOID)) {
8522 while (nop && nop->op_next) {
8523 switch (nop->op_next->op_type) {
8528 lop = nop = nop->op_next;
8539 if (lop->op_flags && OPf_WANT_VOID) {
8540 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8541 cLOGOP->op_first = opt_scalarhv(fop);
8542 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8543 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8559 while (cLOGOP->op_other->op_type == OP_NULL)
8560 cLOGOP->op_other = cLOGOP->op_other->op_next;
8561 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8566 while (cLOOP->op_redoop->op_type == OP_NULL)
8567 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8568 peep(cLOOP->op_redoop);
8569 while (cLOOP->op_nextop->op_type == OP_NULL)
8570 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8571 peep(cLOOP->op_nextop);
8572 while (cLOOP->op_lastop->op_type == OP_NULL)
8573 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8574 peep(cLOOP->op_lastop);
8578 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8579 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8580 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8581 cPMOP->op_pmstashstartu.op_pmreplstart
8582 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8583 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8587 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8588 && ckWARN(WARN_SYNTAX))
8590 if (o->op_next->op_sibling) {
8591 const OPCODE type = o->op_next->op_sibling->op_type;
8592 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8593 const line_t oldline = CopLINE(PL_curcop);
8594 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8595 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8596 "Statement unlikely to be reached");
8597 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8598 "\t(Maybe you meant system() when you said exec()?)\n");
8599 CopLINE_set(PL_curcop, oldline);
8610 const char *key = NULL;
8613 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8616 /* Make the CONST have a shared SV */
8617 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8618 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8619 key = SvPV_const(sv, keylen);
8620 lexname = newSVpvn_share(key,
8621 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8627 if ((o->op_private & (OPpLVAL_INTRO)))
8630 rop = (UNOP*)((BINOP*)o)->op_first;
8631 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8633 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8634 if (!SvPAD_TYPED(lexname))
8636 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8637 if (!fields || !GvHV(*fields))
8639 key = SvPV_const(*svp, keylen);
8640 if (!hv_fetch(GvHV(*fields), key,
8641 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8643 Perl_croak(aTHX_ "No such class field \"%s\" "
8644 "in variable %s of type %s",
8645 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8658 SVOP *first_key_op, *key_op;
8660 if ((o->op_private & (OPpLVAL_INTRO))
8661 /* I bet there's always a pushmark... */
8662 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8663 /* hmmm, no optimization if list contains only one key. */
8665 rop = (UNOP*)((LISTOP*)o)->op_last;
8666 if (rop->op_type != OP_RV2HV)
8668 if (rop->op_first->op_type == OP_PADSV)
8669 /* @$hash{qw(keys here)} */
8670 rop = (UNOP*)rop->op_first;
8672 /* @{$hash}{qw(keys here)} */
8673 if (rop->op_first->op_type == OP_SCOPE
8674 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8676 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8682 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8683 if (!SvPAD_TYPED(lexname))
8685 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8686 if (!fields || !GvHV(*fields))
8688 /* Again guessing that the pushmark can be jumped over.... */
8689 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8690 ->op_first->op_sibling;
8691 for (key_op = first_key_op; key_op;
8692 key_op = (SVOP*)key_op->op_sibling) {
8693 if (key_op->op_type != OP_CONST)
8695 svp = cSVOPx_svp(key_op);
8696 key = SvPV_const(*svp, keylen);
8697 if (!hv_fetch(GvHV(*fields), key,
8698 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8700 Perl_croak(aTHX_ "No such class field \"%s\" "
8701 "in variable %s of type %s",
8702 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8709 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8713 /* check that RHS of sort is a single plain array */
8714 OP *oright = cUNOPo->op_first;
8715 if (!oright || oright->op_type != OP_PUSHMARK)
8718 /* reverse sort ... can be optimised. */
8719 if (!cUNOPo->op_sibling) {
8720 /* Nothing follows us on the list. */
8721 OP * const reverse = o->op_next;
8723 if (reverse->op_type == OP_REVERSE &&
8724 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8725 OP * const pushmark = cUNOPx(reverse)->op_first;
8726 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8727 && (cUNOPx(pushmark)->op_sibling == o)) {
8728 /* reverse -> pushmark -> sort */
8729 o->op_private |= OPpSORT_REVERSE;
8731 pushmark->op_next = oright->op_next;
8737 /* make @a = sort @a act in-place */
8739 oright = cUNOPx(oright)->op_sibling;
8742 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8743 oright = cUNOPx(oright)->op_sibling;
8747 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8748 || oright->op_next != o
8749 || (oright->op_private & OPpLVAL_INTRO)
8753 /* o2 follows the chain of op_nexts through the LHS of the
8754 * assign (if any) to the aassign op itself */
8756 if (!o2 || o2->op_type != OP_NULL)
8759 if (!o2 || o2->op_type != OP_PUSHMARK)
8762 if (o2 && o2->op_type == OP_GV)
8765 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8766 || (o2->op_private & OPpLVAL_INTRO)
8771 if (!o2 || o2->op_type != OP_NULL)
8774 if (!o2 || o2->op_type != OP_AASSIGN
8775 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8778 /* check that the sort is the first arg on RHS of assign */
8780 o2 = cUNOPx(o2)->op_first;
8781 if (!o2 || o2->op_type != OP_NULL)
8783 o2 = cUNOPx(o2)->op_first;
8784 if (!o2 || o2->op_type != OP_PUSHMARK)
8786 if (o2->op_sibling != o)
8789 /* check the array is the same on both sides */
8790 if (oleft->op_type == OP_RV2AV) {
8791 if (oright->op_type != OP_RV2AV
8792 || !cUNOPx(oright)->op_first
8793 || cUNOPx(oright)->op_first->op_type != OP_GV
8794 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8795 cGVOPx_gv(cUNOPx(oright)->op_first)
8799 else if (oright->op_type != OP_PADAV
8800 || oright->op_targ != oleft->op_targ
8804 /* transfer MODishness etc from LHS arg to RHS arg */
8805 oright->op_flags = oleft->op_flags;
8806 o->op_private |= OPpSORT_INPLACE;
8808 /* excise push->gv->rv2av->null->aassign */
8809 o2 = o->op_next->op_next;
8810 op_null(o2); /* PUSHMARK */
8812 if (o2->op_type == OP_GV) {
8813 op_null(o2); /* GV */
8816 op_null(o2); /* RV2AV or PADAV */
8817 o2 = o2->op_next->op_next;
8818 op_null(o2); /* AASSIGN */
8820 o->op_next = o2->op_next;
8826 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8828 LISTOP *enter, *exlist;
8830 enter = (LISTOP *) o->op_next;
8833 if (enter->op_type == OP_NULL) {
8834 enter = (LISTOP *) enter->op_next;
8838 /* for $a (...) will have OP_GV then OP_RV2GV here.
8839 for (...) just has an OP_GV. */
8840 if (enter->op_type == OP_GV) {
8841 gvop = (OP *) enter;
8842 enter = (LISTOP *) enter->op_next;
8845 if (enter->op_type == OP_RV2GV) {
8846 enter = (LISTOP *) enter->op_next;
8852 if (enter->op_type != OP_ENTERITER)
8855 iter = enter->op_next;
8856 if (!iter || iter->op_type != OP_ITER)
8859 expushmark = enter->op_first;
8860 if (!expushmark || expushmark->op_type != OP_NULL
8861 || expushmark->op_targ != OP_PUSHMARK)
8864 exlist = (LISTOP *) expushmark->op_sibling;
8865 if (!exlist || exlist->op_type != OP_NULL
8866 || exlist->op_targ != OP_LIST)
8869 if (exlist->op_last != o) {
8870 /* Mmm. Was expecting to point back to this op. */
8873 theirmark = exlist->op_first;
8874 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8877 if (theirmark->op_sibling != o) {
8878 /* There's something between the mark and the reverse, eg
8879 for (1, reverse (...))
8884 ourmark = ((LISTOP *)o)->op_first;
8885 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8888 ourlast = ((LISTOP *)o)->op_last;
8889 if (!ourlast || ourlast->op_next != o)
8892 rv2av = ourmark->op_sibling;
8893 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8894 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8895 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8896 /* We're just reversing a single array. */
8897 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8898 enter->op_flags |= OPf_STACKED;
8901 /* We don't have control over who points to theirmark, so sacrifice
8903 theirmark->op_next = ourmark->op_next;
8904 theirmark->op_flags = ourmark->op_flags;
8905 ourlast->op_next = gvop ? gvop : (OP *) enter;
8908 enter->op_private |= OPpITER_REVERSED;
8909 iter->op_private |= OPpITER_REVERSED;
8916 UNOP *refgen, *rv2cv;
8919 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8922 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8925 rv2gv = ((BINOP *)o)->op_last;
8926 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8929 refgen = (UNOP *)((BINOP *)o)->op_first;
8931 if (!refgen || refgen->op_type != OP_REFGEN)
8934 exlist = (LISTOP *)refgen->op_first;
8935 if (!exlist || exlist->op_type != OP_NULL
8936 || exlist->op_targ != OP_LIST)
8939 if (exlist->op_first->op_type != OP_PUSHMARK)
8942 rv2cv = (UNOP*)exlist->op_last;
8944 if (rv2cv->op_type != OP_RV2CV)
8947 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8948 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8949 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8951 o->op_private |= OPpASSIGN_CV_TO_GV;
8952 rv2gv->op_private |= OPpDONT_INIT_GV;
8953 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8961 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8962 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8972 Perl_custom_op_name(pTHX_ const OP* o)
8975 const IV index = PTR2IV(o->op_ppaddr);
8979 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8981 if (!PL_custom_op_names) /* This probably shouldn't happen */
8982 return (char *)PL_op_name[OP_CUSTOM];
8984 keysv = sv_2mortal(newSViv(index));
8986 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8988 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8990 return SvPV_nolen(HeVAL(he));
8994 Perl_custom_op_desc(pTHX_ const OP* o)
8997 const IV index = PTR2IV(o->op_ppaddr);
9001 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9003 if (!PL_custom_op_descs)
9004 return (char *)PL_op_desc[OP_CUSTOM];
9006 keysv = sv_2mortal(newSViv(index));
9008 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9010 return (char *)PL_op_desc[OP_CUSTOM];
9012 return SvPV_nolen(HeVAL(he));
9017 /* Efficient sub that returns a constant scalar value. */
9019 const_sv_xsub(pTHX_ CV* cv)
9023 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9027 /* diag_listed_as: SKIPME */
9028 Perl_croak(aTHX_ "usage: %s::%s()",
9029 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9042 * c-indentation-style: bsd
9044 * indent-tabs-mode: t
9047 * ex: set ts=8 sts=4 sw=4 noet: