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
4788 || expr->op_type == OP_READDIR
4789 || expr->op_type == OP_GLOB
4790 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4791 expr = newUNOP(OP_DEFINED, 0,
4792 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4793 } else if (expr->op_flags & OPf_KIDS) {
4794 const OP * const k1 = ((UNOP*)expr)->op_first;
4795 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4796 switch (expr->op_type) {
4798 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4799 && (k2->op_flags & OPf_STACKED)
4800 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4801 expr = newUNOP(OP_DEFINED, 0, expr);
4805 if (k1 && (k1->op_type == OP_READDIR
4806 || k1->op_type == OP_GLOB
4807 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4808 || k1->op_type == OP_EACH))
4809 expr = newUNOP(OP_DEFINED, 0, expr);
4815 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4816 * op, in listop. This is wrong. [perl #27024] */
4818 block = newOP(OP_NULL, 0);
4819 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4820 o = new_logop(OP_AND, 0, &expr, &listop);
4823 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4825 if (once && o != listop)
4826 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4829 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4831 o->op_flags |= flags;
4833 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4838 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4839 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4848 PERL_UNUSED_ARG(debuggable);
4851 if (expr->op_type == OP_READLINE
4852 || expr->op_type == OP_READDIR
4853 || expr->op_type == OP_GLOB
4854 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4855 expr = newUNOP(OP_DEFINED, 0,
4856 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4857 } else if (expr->op_flags & OPf_KIDS) {
4858 const OP * const k1 = ((UNOP*)expr)->op_first;
4859 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4860 switch (expr->op_type) {
4862 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4863 && (k2->op_flags & OPf_STACKED)
4864 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4865 expr = newUNOP(OP_DEFINED, 0, expr);
4869 if (k1 && (k1->op_type == OP_READDIR
4870 || k1->op_type == OP_GLOB
4871 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4872 || k1->op_type == OP_EACH))
4873 expr = newUNOP(OP_DEFINED, 0, expr);
4880 block = newOP(OP_NULL, 0);
4881 else if (cont || has_my) {
4882 block = scope(block);
4886 next = LINKLIST(cont);
4889 OP * const unstack = newOP(OP_UNSTACK, 0);
4892 cont = append_elem(OP_LINESEQ, cont, unstack);
4896 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4898 redo = LINKLIST(listop);
4901 PL_parser->copline = (line_t)whileline;
4903 o = new_logop(OP_AND, 0, &expr, &listop);
4904 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4905 op_free(expr); /* oops, it's a while (0) */
4907 return NULL; /* listop already freed by new_logop */
4910 ((LISTOP*)listop)->op_last->op_next =
4911 (o == listop ? redo : LINKLIST(o));
4917 NewOp(1101,loop,1,LOOP);
4918 loop->op_type = OP_ENTERLOOP;
4919 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4920 loop->op_private = 0;
4921 loop->op_next = (OP*)loop;
4924 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4926 loop->op_redoop = redo;
4927 loop->op_lastop = o;
4928 o->op_private |= loopflags;
4931 loop->op_nextop = next;
4933 loop->op_nextop = o;
4935 o->op_flags |= flags;
4936 o->op_private |= (flags >> 8);
4941 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4946 PADOFFSET padoff = 0;
4951 PERL_ARGS_ASSERT_NEWFOROP;
4954 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4955 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4956 sv->op_type = OP_RV2GV;
4957 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4959 /* The op_type check is needed to prevent a possible segfault
4960 * if the loop variable is undeclared and 'strict vars' is in
4961 * effect. This is illegal but is nonetheless parsed, so we
4962 * may reach this point with an OP_CONST where we're expecting
4965 if (cUNOPx(sv)->op_first->op_type == OP_GV
4966 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4967 iterpflags |= OPpITER_DEF;
4969 else if (sv->op_type == OP_PADSV) { /* private variable */
4970 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4971 padoff = sv->op_targ;
4981 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4983 SV *const namesv = PAD_COMPNAME_SV(padoff);
4985 const char *const name = SvPV_const(namesv, len);
4987 if (len == 2 && name[0] == '$' && name[1] == '_')
4988 iterpflags |= OPpITER_DEF;
4992 const PADOFFSET offset = pad_findmy("$_");
4993 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4994 sv = newGVOP(OP_GV, 0, PL_defgv);
4999 iterpflags |= OPpITER_DEF;
5001 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5002 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5003 iterflags |= OPf_STACKED;
5005 else if (expr->op_type == OP_NULL &&
5006 (expr->op_flags & OPf_KIDS) &&
5007 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5009 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5010 * set the STACKED flag to indicate that these values are to be
5011 * treated as min/max values by 'pp_iterinit'.
5013 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5014 LOGOP* const range = (LOGOP*) flip->op_first;
5015 OP* const left = range->op_first;
5016 OP* const right = left->op_sibling;
5019 range->op_flags &= ~OPf_KIDS;
5020 range->op_first = NULL;
5022 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5023 listop->op_first->op_next = range->op_next;
5024 left->op_next = range->op_other;
5025 right->op_next = (OP*)listop;
5026 listop->op_next = listop->op_first;
5029 op_getmad(expr,(OP*)listop,'O');
5033 expr = (OP*)(listop);
5035 iterflags |= OPf_STACKED;
5038 expr = mod(force_list(expr), OP_GREPSTART);
5041 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5042 append_elem(OP_LIST, expr, scalar(sv))));
5043 assert(!loop->op_next);
5044 /* for my $x () sets OPpLVAL_INTRO;
5045 * for our $x () sets OPpOUR_INTRO */
5046 loop->op_private = (U8)iterpflags;
5047 #ifdef PL_OP_SLAB_ALLOC
5050 NewOp(1234,tmp,1,LOOP);
5051 Copy(loop,tmp,1,LISTOP);
5052 S_op_destroy(aTHX_ (OP*)loop);
5056 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5058 loop->op_targ = padoff;
5059 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5061 op_getmad(madsv, (OP*)loop, 'v');
5062 PL_parser->copline = forline;
5063 return newSTATEOP(0, label, wop);
5067 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5072 PERL_ARGS_ASSERT_NEWLOOPEX;
5074 if (type != OP_GOTO || label->op_type == OP_CONST) {
5075 /* "last()" means "last" */
5076 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5077 o = newOP(type, OPf_SPECIAL);
5079 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5080 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5084 op_getmad(label,o,'L');
5090 /* Check whether it's going to be a goto &function */
5091 if (label->op_type == OP_ENTERSUB
5092 && !(label->op_flags & OPf_STACKED))
5093 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5094 o = newUNOP(type, OPf_STACKED, label);
5096 PL_hints |= HINT_BLOCK_SCOPE;
5100 /* if the condition is a literal array or hash
5101 (or @{ ... } etc), make a reference to it.
5104 S_ref_array_or_hash(pTHX_ OP *cond)
5107 && (cond->op_type == OP_RV2AV
5108 || cond->op_type == OP_PADAV
5109 || cond->op_type == OP_RV2HV
5110 || cond->op_type == OP_PADHV))
5112 return newUNOP(OP_REFGEN,
5113 0, mod(cond, OP_REFGEN));
5119 /* These construct the optree fragments representing given()
5122 entergiven and enterwhen are LOGOPs; the op_other pointer
5123 points up to the associated leave op. We need this so we
5124 can put it in the context and make break/continue work.
5125 (Also, of course, pp_enterwhen will jump straight to
5126 op_other if the match fails.)
5130 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5131 I32 enter_opcode, I32 leave_opcode,
5132 PADOFFSET entertarg)
5138 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5140 NewOp(1101, enterop, 1, LOGOP);
5141 enterop->op_type = (Optype)enter_opcode;
5142 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5143 enterop->op_flags = (U8) OPf_KIDS;
5144 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5145 enterop->op_private = 0;
5147 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5150 enterop->op_first = scalar(cond);
5151 cond->op_sibling = block;
5153 o->op_next = LINKLIST(cond);
5154 cond->op_next = (OP *) enterop;
5157 /* This is a default {} block */
5158 enterop->op_first = block;
5159 enterop->op_flags |= OPf_SPECIAL;
5161 o->op_next = (OP *) enterop;
5164 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5165 entergiven and enterwhen both
5168 enterop->op_next = LINKLIST(block);
5169 block->op_next = enterop->op_other = o;
5174 /* Does this look like a boolean operation? For these purposes
5175 a boolean operation is:
5176 - a subroutine call [*]
5177 - a logical connective
5178 - a comparison operator
5179 - a filetest operator, with the exception of -s -M -A -C
5180 - defined(), exists() or eof()
5181 - /$re/ or $foo =~ /$re/
5183 [*] possibly surprising
5186 S_looks_like_bool(pTHX_ const OP *o)
5190 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5192 switch(o->op_type) {
5195 return looks_like_bool(cLOGOPo->op_first);
5199 looks_like_bool(cLOGOPo->op_first)
5200 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5204 o->op_flags & OPf_KIDS
5205 && looks_like_bool(cUNOPo->op_first));
5208 return looks_like_bool(cUNOPo->op_first);
5213 case OP_NOT: case OP_XOR:
5215 case OP_EQ: case OP_NE: case OP_LT:
5216 case OP_GT: case OP_LE: case OP_GE:
5218 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5219 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5221 case OP_SEQ: case OP_SNE: case OP_SLT:
5222 case OP_SGT: case OP_SLE: case OP_SGE:
5226 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5227 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5228 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5229 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5230 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5231 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5232 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5233 case OP_FTTEXT: case OP_FTBINARY:
5235 case OP_DEFINED: case OP_EXISTS:
5236 case OP_MATCH: case OP_EOF:
5243 /* Detect comparisons that have been optimized away */
5244 if (cSVOPo->op_sv == &PL_sv_yes
5245 || cSVOPo->op_sv == &PL_sv_no)
5258 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5261 PERL_ARGS_ASSERT_NEWGIVENOP;
5262 return newGIVWHENOP(
5263 ref_array_or_hash(cond),
5265 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5269 /* If cond is null, this is a default {} block */
5271 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5273 const bool cond_llb = (!cond || looks_like_bool(cond));
5276 PERL_ARGS_ASSERT_NEWWHENOP;
5281 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5283 scalar(ref_array_or_hash(cond)));
5286 return newGIVWHENOP(
5288 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5289 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5293 =for apidoc cv_undef
5295 Clear out all the active components of a CV. This can happen either
5296 by an explicit C<undef &foo>, or by the reference count going to zero.
5297 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5298 children can still follow the full lexical scope chain.
5304 Perl_cv_undef(pTHX_ CV *cv)
5308 PERL_ARGS_ASSERT_CV_UNDEF;
5310 DEBUG_X(PerlIO_printf(Perl_debug_log,
5311 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5312 PTR2UV(cv), PTR2UV(PL_comppad))
5316 if (CvFILE(cv) && !CvISXSUB(cv)) {
5317 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5318 Safefree(CvFILE(cv));
5323 if (!CvISXSUB(cv) && CvROOT(cv)) {
5324 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5325 Perl_croak(aTHX_ "Can't undef active subroutine");
5328 PAD_SAVE_SETNULLPAD();
5330 op_free(CvROOT(cv));
5335 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5340 /* remove CvOUTSIDE unless this is an undef rather than a free */
5341 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5342 if (!CvWEAKOUTSIDE(cv))
5343 SvREFCNT_dec(CvOUTSIDE(cv));
5344 CvOUTSIDE(cv) = NULL;
5347 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5350 if (CvISXSUB(cv) && CvXSUB(cv)) {
5353 /* delete all flags except WEAKOUTSIDE */
5354 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5358 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5361 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5363 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5364 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5365 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5366 || (p && (len != SvCUR(cv) /* Not the same length. */
5367 || memNE(p, SvPVX_const(cv), len))))
5368 && ckWARN_d(WARN_PROTOTYPE)) {
5369 SV* const msg = sv_newmortal();
5373 gv_efullname3(name = sv_newmortal(), gv, NULL);
5374 sv_setpvs(msg, "Prototype mismatch:");
5376 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5378 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5380 sv_catpvs(msg, ": none");
5381 sv_catpvs(msg, " vs ");
5383 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5385 sv_catpvs(msg, "none");
5386 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5390 static void const_sv_xsub(pTHX_ CV* cv);
5394 =head1 Optree Manipulation Functions
5396 =for apidoc cv_const_sv
5398 If C<cv> is a constant sub eligible for inlining. returns the constant
5399 value returned by the sub. Otherwise, returns NULL.
5401 Constant subs can be created with C<newCONSTSUB> or as described in
5402 L<perlsub/"Constant Functions">.
5407 Perl_cv_const_sv(pTHX_ const CV *const cv)
5409 PERL_UNUSED_CONTEXT;
5412 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5414 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5417 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5418 * Can be called in 3 ways:
5421 * look for a single OP_CONST with attached value: return the value
5423 * cv && CvCLONE(cv) && !CvCONST(cv)
5425 * examine the clone prototype, and if contains only a single
5426 * OP_CONST referencing a pad const, or a single PADSV referencing
5427 * an outer lexical, return a non-zero value to indicate the CV is
5428 * a candidate for "constizing" at clone time
5432 * We have just cloned an anon prototype that was marked as a const
5433 * candidiate. Try to grab the current value, and in the case of
5434 * PADSV, ignore it if it has multiple references. Return the value.
5438 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5449 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5450 o = cLISTOPo->op_first->op_sibling;
5452 for (; o; o = o->op_next) {
5453 const OPCODE type = o->op_type;
5455 if (sv && o->op_next == o)
5457 if (o->op_next != o) {
5458 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5460 if (type == OP_DBSTATE)
5463 if (type == OP_LEAVESUB || type == OP_RETURN)
5467 if (type == OP_CONST && cSVOPo->op_sv)
5469 else if (cv && type == OP_CONST) {
5470 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5474 else if (cv && type == OP_PADSV) {
5475 if (CvCONST(cv)) { /* newly cloned anon */
5476 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5477 /* the candidate should have 1 ref from this pad and 1 ref
5478 * from the parent */
5479 if (!sv || SvREFCNT(sv) != 2)
5486 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5487 sv = &PL_sv_undef; /* an arbitrary non-null value */
5502 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5505 /* This would be the return value, but the return cannot be reached. */
5506 OP* pegop = newOP(OP_NULL, 0);
5509 PERL_UNUSED_ARG(floor);
5519 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5521 NORETURN_FUNCTION_END;
5526 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5528 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5532 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5538 register CV *cv = NULL;
5540 /* If the subroutine has no body, no attributes, and no builtin attributes
5541 then it's just a sub declaration, and we may be able to get away with
5542 storing with a placeholder scalar in the symbol table, rather than a
5543 full GV and CV. If anything is present then it will take a full CV to
5545 const I32 gv_fetch_flags
5546 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5548 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5549 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5553 assert(proto->op_type == OP_CONST);
5554 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5560 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5562 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5563 SV * const sv = sv_newmortal();
5564 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5565 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5566 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5567 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5569 } else if (PL_curstash) {
5570 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5573 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5577 if (!PL_madskills) {
5586 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5587 maximum a prototype before. */
5588 if (SvTYPE(gv) > SVt_NULL) {
5589 if (!SvPOK((const SV *)gv)
5590 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5592 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5594 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5597 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5599 sv_setiv(MUTABLE_SV(gv), -1);
5601 SvREFCNT_dec(PL_compcv);
5602 cv = PL_compcv = NULL;
5606 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5608 if (!block || !ps || *ps || attrs
5609 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5611 || block->op_type == OP_NULL
5616 const_sv = op_const_sv(block, NULL);
5619 const bool exists = CvROOT(cv) || CvXSUB(cv);
5621 /* if the subroutine doesn't exist and wasn't pre-declared
5622 * with a prototype, assume it will be AUTOLOADed,
5623 * skipping the prototype check
5625 if (exists || SvPOK(cv))
5626 cv_ckproto_len(cv, gv, ps, ps_len);
5627 /* already defined (or promised)? */
5628 if (exists || GvASSUMECV(gv)) {
5631 || block->op_type == OP_NULL
5634 if (CvFLAGS(PL_compcv)) {
5635 /* might have had built-in attrs applied */
5636 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5638 /* just a "sub foo;" when &foo is already defined */
5639 SAVEFREESV(PL_compcv);
5644 && block->op_type != OP_NULL
5647 if (ckWARN(WARN_REDEFINE)
5649 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5651 const line_t oldline = CopLINE(PL_curcop);
5652 if (PL_parser && PL_parser->copline != NOLINE)
5653 CopLINE_set(PL_curcop, PL_parser->copline);
5654 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5655 CvCONST(cv) ? "Constant subroutine %s redefined"
5656 : "Subroutine %s redefined", name);
5657 CopLINE_set(PL_curcop, oldline);
5660 if (!PL_minus_c) /* keep old one around for madskills */
5663 /* (PL_madskills unset in used file.) */
5671 SvREFCNT_inc_simple_void_NN(const_sv);
5673 assert(!CvROOT(cv) && !CvCONST(cv));
5674 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5675 CvXSUBANY(cv).any_ptr = const_sv;
5676 CvXSUB(cv) = const_sv_xsub;
5682 cv = newCONSTSUB(NULL, name, const_sv);
5684 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5685 (CvGV(cv) && GvSTASH(CvGV(cv)))
5694 SvREFCNT_dec(PL_compcv);
5698 if (cv) { /* must reuse cv if autoloaded */
5699 /* transfer PL_compcv to cv */
5702 && block->op_type != OP_NULL
5706 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5707 if (!CvWEAKOUTSIDE(cv))
5708 SvREFCNT_dec(CvOUTSIDE(cv));
5709 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5710 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5711 CvOUTSIDE(PL_compcv) = 0;
5712 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5713 CvPADLIST(PL_compcv) = 0;
5714 /* inner references to PL_compcv must be fixed up ... */
5715 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5716 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5717 ++PL_sub_generation;
5720 /* Might have had built-in attributes applied -- propagate them. */
5721 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5723 /* ... before we throw it away */
5724 SvREFCNT_dec(PL_compcv);
5732 if (strEQ(name, "import")) {
5733 PL_formfeed = MUTABLE_SV(cv);
5734 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5738 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5743 CvFILE_set_from_cop(cv, PL_curcop);
5744 CvSTASH(cv) = PL_curstash;
5747 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5748 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5749 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5753 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5755 if (PL_parser && PL_parser->error_count) {
5759 const char *s = strrchr(name, ':');
5761 if (strEQ(s, "BEGIN")) {
5762 const char not_safe[] =
5763 "BEGIN not safe after errors--compilation aborted";
5764 if (PL_in_eval & EVAL_KEEPERR)
5765 Perl_croak(aTHX_ not_safe);
5767 /* force display of errors found but not reported */
5768 sv_catpv(ERRSV, not_safe);
5769 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5778 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5779 the debugger could be able to set a breakpoint in, so signal to
5780 pp_entereval that it should not throw away any saved lines at scope
5783 PL_breakable_sub_gen++;
5785 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5786 mod(scalarseq(block), OP_LEAVESUBLV));
5787 block->op_attached = 1;
5790 /* This makes sub {}; work as expected. */
5791 if (block->op_type == OP_STUB) {
5792 OP* const newblock = newSTATEOP(0, NULL, 0);
5794 op_getmad(block,newblock,'B');
5801 block->op_attached = 1;
5802 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5804 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5805 OpREFCNT_set(CvROOT(cv), 1);
5806 CvSTART(cv) = LINKLIST(CvROOT(cv));
5807 CvROOT(cv)->op_next = 0;
5808 CALL_PEEP(CvSTART(cv));
5810 /* now that optimizer has done its work, adjust pad values */
5812 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5815 assert(!CvCONST(cv));
5816 if (ps && !*ps && op_const_sv(block, cv))
5821 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5822 SV * const sv = newSV(0);
5823 SV * const tmpstr = sv_newmortal();
5824 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5825 GV_ADDMULTI, SVt_PVHV);
5828 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5830 (long)PL_subline, (long)CopLINE(PL_curcop));
5831 gv_efullname3(tmpstr, gv, NULL);
5832 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5833 SvCUR(tmpstr), sv, 0);
5834 hv = GvHVn(db_postponed);
5835 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5836 CV * const pcv = GvCV(db_postponed);
5842 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5847 if (name && ! (PL_parser && PL_parser->error_count))
5848 process_special_blocks(name, gv, cv);
5853 PL_parser->copline = NOLINE;
5859 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5862 const char *const colon = strrchr(fullname,':');
5863 const char *const name = colon ? colon + 1 : fullname;
5865 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5868 if (strEQ(name, "BEGIN")) {
5869 const I32 oldscope = PL_scopestack_ix;
5871 SAVECOPFILE(&PL_compiling);
5872 SAVECOPLINE(&PL_compiling);
5874 DEBUG_x( dump_sub(gv) );
5875 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5876 GvCV(gv) = 0; /* cv has been hijacked */
5877 call_list(oldscope, PL_beginav);
5879 PL_curcop = &PL_compiling;
5880 CopHINTS_set(&PL_compiling, PL_hints);
5887 if strEQ(name, "END") {
5888 DEBUG_x( dump_sub(gv) );
5889 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5892 } else if (*name == 'U') {
5893 if (strEQ(name, "UNITCHECK")) {
5894 /* It's never too late to run a unitcheck block */
5895 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5899 } else if (*name == 'C') {
5900 if (strEQ(name, "CHECK")) {
5902 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5903 "Too late to run CHECK block");
5904 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5908 } else if (*name == 'I') {
5909 if (strEQ(name, "INIT")) {
5911 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5912 "Too late to run INIT block");
5913 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5919 DEBUG_x( dump_sub(gv) );
5920 GvCV(gv) = 0; /* cv has been hijacked */
5925 =for apidoc newCONSTSUB
5927 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5928 eligible for inlining at compile-time.
5930 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5931 which won't be called if used as a destructor, but will suppress the overhead
5932 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5939 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5944 const char *const file = CopFILE(PL_curcop);
5946 SV *const temp_sv = CopFILESV(PL_curcop);
5947 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5952 if (IN_PERL_RUNTIME) {
5953 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5954 * an op shared between threads. Use a non-shared COP for our
5956 SAVEVPTR(PL_curcop);
5957 PL_curcop = &PL_compiling;
5959 SAVECOPLINE(PL_curcop);
5960 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5963 PL_hints &= ~HINT_BLOCK_SCOPE;
5966 SAVESPTR(PL_curstash);
5967 SAVECOPSTASH(PL_curcop);
5968 PL_curstash = stash;
5969 CopSTASH_set(PL_curcop,stash);
5972 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5973 and so doesn't get free()d. (It's expected to be from the C pre-
5974 processor __FILE__ directive). But we need a dynamically allocated one,
5975 and we need it to get freed. */
5976 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
5977 XS_DYNAMIC_FILENAME);
5978 CvXSUBANY(cv).any_ptr = sv;
5983 CopSTASH_free(PL_curcop);
5991 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5992 const char *const filename, const char *const proto,
5995 CV *cv = newXS(name, subaddr, filename);
5997 PERL_ARGS_ASSERT_NEWXS_FLAGS;
5999 if (flags & XS_DYNAMIC_FILENAME) {
6000 /* We need to "make arrangements" (ie cheat) to ensure that the
6001 filename lasts as long as the PVCV we just created, but also doesn't
6003 STRLEN filename_len = strlen(filename);
6004 STRLEN proto_and_file_len = filename_len;
6005 char *proto_and_file;
6009 proto_len = strlen(proto);
6010 proto_and_file_len += proto_len;
6012 Newx(proto_and_file, proto_and_file_len + 1, char);
6013 Copy(proto, proto_and_file, proto_len, char);
6014 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6017 proto_and_file = savepvn(filename, filename_len);
6020 /* This gets free()d. :-) */
6021 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6022 SV_HAS_TRAILING_NUL);
6024 /* This gives us the correct prototype, rather than one with the
6025 file name appended. */
6026 SvCUR_set(cv, proto_len);
6030 CvFILE(cv) = proto_and_file + proto_len;
6032 sv_setpv(MUTABLE_SV(cv), proto);
6038 =for apidoc U||newXS
6040 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6041 static storage, as it is used directly as CvFILE(), without a copy being made.
6047 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6050 GV * const gv = gv_fetchpv(name ? name :
6051 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6052 GV_ADDMULTI, SVt_PVCV);
6055 PERL_ARGS_ASSERT_NEWXS;
6058 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6060 if ((cv = (name ? GvCV(gv) : NULL))) {
6062 /* just a cached method */
6066 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6067 /* already defined (or promised) */
6068 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6069 if (ckWARN(WARN_REDEFINE)) {
6070 GV * const gvcv = CvGV(cv);
6072 HV * const stash = GvSTASH(gvcv);
6074 const char *redefined_name = HvNAME_get(stash);
6075 if ( strEQ(redefined_name,"autouse") ) {
6076 const line_t oldline = CopLINE(PL_curcop);
6077 if (PL_parser && PL_parser->copline != NOLINE)
6078 CopLINE_set(PL_curcop, PL_parser->copline);
6079 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6080 CvCONST(cv) ? "Constant subroutine %s redefined"
6081 : "Subroutine %s redefined"
6083 CopLINE_set(PL_curcop, oldline);
6093 if (cv) /* must reuse cv if autoloaded */
6096 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6100 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6104 (void)gv_fetchfile(filename);
6105 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6106 an external constant string */
6108 CvXSUB(cv) = subaddr;
6111 process_special_blocks(name, gv, cv);
6123 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6128 OP* pegop = newOP(OP_NULL, 0);
6132 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6133 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6136 if ((cv = GvFORM(gv))) {
6137 if (ckWARN(WARN_REDEFINE)) {
6138 const line_t oldline = CopLINE(PL_curcop);
6139 if (PL_parser && PL_parser->copline != NOLINE)
6140 CopLINE_set(PL_curcop, PL_parser->copline);
6142 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6143 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6145 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6146 "Format STDOUT redefined");
6148 CopLINE_set(PL_curcop, oldline);
6155 CvFILE_set_from_cop(cv, PL_curcop);
6158 pad_tidy(padtidy_FORMAT);
6159 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6160 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6161 OpREFCNT_set(CvROOT(cv), 1);
6162 CvSTART(cv) = LINKLIST(CvROOT(cv));
6163 CvROOT(cv)->op_next = 0;
6164 CALL_PEEP(CvSTART(cv));
6166 op_getmad(o,pegop,'n');
6167 op_getmad_weak(block, pegop, 'b');
6172 PL_parser->copline = NOLINE;
6180 Perl_newANONLIST(pTHX_ OP *o)
6182 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6186 Perl_newANONHASH(pTHX_ OP *o)
6188 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6192 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6194 return newANONATTRSUB(floor, proto, NULL, block);
6198 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6200 return newUNOP(OP_REFGEN, 0,
6201 newSVOP(OP_ANONCODE, 0,
6202 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6206 Perl_oopsAV(pTHX_ OP *o)
6210 PERL_ARGS_ASSERT_OOPSAV;
6212 switch (o->op_type) {
6214 o->op_type = OP_PADAV;
6215 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6216 return ref(o, OP_RV2AV);
6219 o->op_type = OP_RV2AV;
6220 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6225 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6232 Perl_oopsHV(pTHX_ OP *o)
6236 PERL_ARGS_ASSERT_OOPSHV;
6238 switch (o->op_type) {
6241 o->op_type = OP_PADHV;
6242 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6243 return ref(o, OP_RV2HV);
6247 o->op_type = OP_RV2HV;
6248 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6253 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6260 Perl_newAVREF(pTHX_ OP *o)
6264 PERL_ARGS_ASSERT_NEWAVREF;
6266 if (o->op_type == OP_PADANY) {
6267 o->op_type = OP_PADAV;
6268 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6271 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6272 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6273 "Using an array as a reference is deprecated");
6275 return newUNOP(OP_RV2AV, 0, scalar(o));
6279 Perl_newGVREF(pTHX_ I32 type, OP *o)
6281 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6282 return newUNOP(OP_NULL, 0, o);
6283 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6287 Perl_newHVREF(pTHX_ OP *o)
6291 PERL_ARGS_ASSERT_NEWHVREF;
6293 if (o->op_type == OP_PADANY) {
6294 o->op_type = OP_PADHV;
6295 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6298 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6299 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6300 "Using a hash as a reference is deprecated");
6302 return newUNOP(OP_RV2HV, 0, scalar(o));
6306 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6308 return newUNOP(OP_RV2CV, flags, scalar(o));
6312 Perl_newSVREF(pTHX_ OP *o)
6316 PERL_ARGS_ASSERT_NEWSVREF;
6318 if (o->op_type == OP_PADANY) {
6319 o->op_type = OP_PADSV;
6320 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6323 return newUNOP(OP_RV2SV, 0, scalar(o));
6326 /* Check routines. See the comments at the top of this file for details
6327 * on when these are called */
6330 Perl_ck_anoncode(pTHX_ OP *o)
6332 PERL_ARGS_ASSERT_CK_ANONCODE;
6334 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6336 cSVOPo->op_sv = NULL;
6341 Perl_ck_bitop(pTHX_ OP *o)
6345 PERL_ARGS_ASSERT_CK_BITOP;
6347 #define OP_IS_NUMCOMPARE(op) \
6348 ((op) == OP_LT || (op) == OP_I_LT || \
6349 (op) == OP_GT || (op) == OP_I_GT || \
6350 (op) == OP_LE || (op) == OP_I_LE || \
6351 (op) == OP_GE || (op) == OP_I_GE || \
6352 (op) == OP_EQ || (op) == OP_I_EQ || \
6353 (op) == OP_NE || (op) == OP_I_NE || \
6354 (op) == OP_NCMP || (op) == OP_I_NCMP)
6355 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6356 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6357 && (o->op_type == OP_BIT_OR
6358 || o->op_type == OP_BIT_AND
6359 || o->op_type == OP_BIT_XOR))
6361 const OP * const left = cBINOPo->op_first;
6362 const OP * const right = left->op_sibling;
6363 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6364 (left->op_flags & OPf_PARENS) == 0) ||
6365 (OP_IS_NUMCOMPARE(right->op_type) &&
6366 (right->op_flags & OPf_PARENS) == 0))
6367 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6368 "Possible precedence problem on bitwise %c operator",
6369 o->op_type == OP_BIT_OR ? '|'
6370 : o->op_type == OP_BIT_AND ? '&' : '^'
6377 Perl_ck_concat(pTHX_ OP *o)
6379 const OP * const kid = cUNOPo->op_first;
6381 PERL_ARGS_ASSERT_CK_CONCAT;
6382 PERL_UNUSED_CONTEXT;
6384 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6385 !(kUNOP->op_first->op_flags & OPf_MOD))
6386 o->op_flags |= OPf_STACKED;
6391 Perl_ck_spair(pTHX_ OP *o)
6395 PERL_ARGS_ASSERT_CK_SPAIR;
6397 if (o->op_flags & OPf_KIDS) {
6400 const OPCODE type = o->op_type;
6401 o = modkids(ck_fun(o), type);
6402 kid = cUNOPo->op_first;
6403 newop = kUNOP->op_first->op_sibling;
6405 const OPCODE type = newop->op_type;
6406 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6407 type == OP_PADAV || type == OP_PADHV ||
6408 type == OP_RV2AV || type == OP_RV2HV)
6412 op_getmad(kUNOP->op_first,newop,'K');
6414 op_free(kUNOP->op_first);
6416 kUNOP->op_first = newop;
6418 o->op_ppaddr = PL_ppaddr[++o->op_type];
6423 Perl_ck_delete(pTHX_ OP *o)
6425 PERL_ARGS_ASSERT_CK_DELETE;
6429 if (o->op_flags & OPf_KIDS) {
6430 OP * const kid = cUNOPo->op_first;
6431 switch (kid->op_type) {
6433 o->op_flags |= OPf_SPECIAL;
6436 o->op_private |= OPpSLICE;
6439 o->op_flags |= OPf_SPECIAL;
6444 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6447 if (kid->op_private & OPpLVAL_INTRO)
6448 o->op_private |= OPpLVAL_INTRO;
6455 Perl_ck_die(pTHX_ OP *o)
6457 PERL_ARGS_ASSERT_CK_DIE;
6460 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6466 Perl_ck_eof(pTHX_ OP *o)
6470 PERL_ARGS_ASSERT_CK_EOF;
6472 if (o->op_flags & OPf_KIDS) {
6473 if (cLISTOPo->op_first->op_type == OP_STUB) {
6475 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6477 op_getmad(o,newop,'O');
6489 Perl_ck_eval(pTHX_ OP *o)
6493 PERL_ARGS_ASSERT_CK_EVAL;
6495 PL_hints |= HINT_BLOCK_SCOPE;
6496 if (o->op_flags & OPf_KIDS) {
6497 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6500 o->op_flags &= ~OPf_KIDS;
6503 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6509 cUNOPo->op_first = 0;
6514 NewOp(1101, enter, 1, LOGOP);
6515 enter->op_type = OP_ENTERTRY;
6516 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6517 enter->op_private = 0;
6519 /* establish postfix order */
6520 enter->op_next = (OP*)enter;
6522 CHECKOP(OP_ENTERTRY, enter);
6524 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6525 o->op_type = OP_LEAVETRY;
6526 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6527 enter->op_other = o;
6528 op_getmad(oldo,o,'O');
6542 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6543 op_getmad(oldo,o,'O');
6545 o->op_targ = (PADOFFSET)PL_hints;
6546 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6547 /* Store a copy of %^H that pp_entereval can pick up. */
6548 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6549 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6550 cUNOPo->op_first->op_sibling = hhop;
6551 o->op_private |= OPpEVAL_HAS_HH;
6557 Perl_ck_exit(pTHX_ OP *o)
6559 PERL_ARGS_ASSERT_CK_EXIT;
6562 HV * const table = GvHV(PL_hintgv);
6564 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6565 if (svp && *svp && SvTRUE(*svp))
6566 o->op_private |= OPpEXIT_VMSISH;
6568 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6574 Perl_ck_exec(pTHX_ OP *o)
6576 PERL_ARGS_ASSERT_CK_EXEC;
6578 if (o->op_flags & OPf_STACKED) {
6581 kid = cUNOPo->op_first->op_sibling;
6582 if (kid->op_type == OP_RV2GV)
6591 Perl_ck_exists(pTHX_ OP *o)
6595 PERL_ARGS_ASSERT_CK_EXISTS;
6598 if (o->op_flags & OPf_KIDS) {
6599 OP * const kid = cUNOPo->op_first;
6600 if (kid->op_type == OP_ENTERSUB) {
6601 (void) ref(kid, o->op_type);
6602 if (kid->op_type != OP_RV2CV
6603 && !(PL_parser && PL_parser->error_count))
6604 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6606 o->op_private |= OPpEXISTS_SUB;
6608 else if (kid->op_type == OP_AELEM)
6609 o->op_flags |= OPf_SPECIAL;
6610 else if (kid->op_type != OP_HELEM)
6611 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6619 Perl_ck_rvconst(pTHX_ register OP *o)
6622 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6624 PERL_ARGS_ASSERT_CK_RVCONST;
6626 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6627 if (o->op_type == OP_RV2CV)
6628 o->op_private &= ~1;
6630 if (kid->op_type == OP_CONST) {
6633 SV * const kidsv = kid->op_sv;
6635 /* Is it a constant from cv_const_sv()? */
6636 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6637 SV * const rsv = SvRV(kidsv);
6638 const svtype type = SvTYPE(rsv);
6639 const char *badtype = NULL;
6641 switch (o->op_type) {
6643 if (type > SVt_PVMG)
6644 badtype = "a SCALAR";
6647 if (type != SVt_PVAV)
6648 badtype = "an ARRAY";
6651 if (type != SVt_PVHV)
6655 if (type != SVt_PVCV)
6660 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6663 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6664 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6665 /* If this is an access to a stash, disable "strict refs", because
6666 * stashes aren't auto-vivified at compile-time (unless we store
6667 * symbols in them), and we don't want to produce a run-time
6668 * stricture error when auto-vivifying the stash. */
6669 const char *s = SvPV_nolen(kidsv);
6670 const STRLEN l = SvCUR(kidsv);
6671 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6672 o->op_private &= ~HINT_STRICT_REFS;
6674 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6675 const char *badthing;
6676 switch (o->op_type) {
6678 badthing = "a SCALAR";
6681 badthing = "an ARRAY";
6684 badthing = "a HASH";
6692 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6693 SVfARG(kidsv), badthing);
6696 * This is a little tricky. We only want to add the symbol if we
6697 * didn't add it in the lexer. Otherwise we get duplicate strict
6698 * warnings. But if we didn't add it in the lexer, we must at
6699 * least pretend like we wanted to add it even if it existed before,
6700 * or we get possible typo warnings. OPpCONST_ENTERED says
6701 * whether the lexer already added THIS instance of this symbol.
6703 iscv = (o->op_type == OP_RV2CV) * 2;
6705 gv = gv_fetchsv(kidsv,
6706 iscv | !(kid->op_private & OPpCONST_ENTERED),
6709 : o->op_type == OP_RV2SV
6711 : o->op_type == OP_RV2AV
6713 : o->op_type == OP_RV2HV
6716 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6718 kid->op_type = OP_GV;
6719 SvREFCNT_dec(kid->op_sv);
6721 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6722 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6723 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6725 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6727 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6729 kid->op_private = 0;
6730 kid->op_ppaddr = PL_ppaddr[OP_GV];
6737 Perl_ck_ftst(pTHX_ OP *o)
6740 const I32 type = o->op_type;
6742 PERL_ARGS_ASSERT_CK_FTST;
6744 if (o->op_flags & OPf_REF) {
6747 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6748 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6749 const OPCODE kidtype = kid->op_type;
6751 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6752 OP * const newop = newGVOP(type, OPf_REF,
6753 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6755 op_getmad(o,newop,'O');
6761 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6762 o->op_private |= OPpFT_ACCESS;
6763 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6764 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6765 o->op_private |= OPpFT_STACKED;
6773 if (type == OP_FTTTY)
6774 o = newGVOP(type, OPf_REF, PL_stdingv);
6776 o = newUNOP(type, 0, newDEFSVOP());
6777 op_getmad(oldo,o,'O');
6783 Perl_ck_fun(pTHX_ OP *o)
6786 const int type = o->op_type;
6787 register I32 oa = PL_opargs[type] >> OASHIFT;
6789 PERL_ARGS_ASSERT_CK_FUN;
6791 if (o->op_flags & OPf_STACKED) {
6792 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6795 return no_fh_allowed(o);
6798 if (o->op_flags & OPf_KIDS) {
6799 OP **tokid = &cLISTOPo->op_first;
6800 register OP *kid = cLISTOPo->op_first;
6804 if (kid->op_type == OP_PUSHMARK ||
6805 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6807 tokid = &kid->op_sibling;
6808 kid = kid->op_sibling;
6810 if (!kid && PL_opargs[type] & OA_DEFGV)
6811 *tokid = kid = newDEFSVOP();
6815 sibl = kid->op_sibling;
6817 if (!sibl && kid->op_type == OP_STUB) {
6824 /* list seen where single (scalar) arg expected? */
6825 if (numargs == 1 && !(oa >> 4)
6826 && kid->op_type == OP_LIST && type != OP_SCALAR)
6828 return too_many_arguments(o,PL_op_desc[type]);
6841 if ((type == OP_PUSH || type == OP_UNSHIFT)
6842 && !kid->op_sibling)
6843 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6844 "Useless use of %s with no values",
6847 if (kid->op_type == OP_CONST &&
6848 (kid->op_private & OPpCONST_BARE))
6850 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6851 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6852 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6853 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6854 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6856 op_getmad(kid,newop,'K');
6861 kid->op_sibling = sibl;
6864 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6865 bad_type(numargs, "array", PL_op_desc[type], kid);
6869 if (kid->op_type == OP_CONST &&
6870 (kid->op_private & OPpCONST_BARE))
6872 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6873 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6874 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6875 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6876 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6878 op_getmad(kid,newop,'K');
6883 kid->op_sibling = sibl;
6886 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6887 bad_type(numargs, "hash", PL_op_desc[type], kid);
6892 OP * const newop = newUNOP(OP_NULL, 0, kid);
6893 kid->op_sibling = 0;
6895 newop->op_next = newop;
6897 kid->op_sibling = sibl;
6902 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6903 if (kid->op_type == OP_CONST &&
6904 (kid->op_private & OPpCONST_BARE))
6906 OP * const newop = newGVOP(OP_GV, 0,
6907 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6908 if (!(o->op_private & 1) && /* if not unop */
6909 kid == cLISTOPo->op_last)
6910 cLISTOPo->op_last = newop;
6912 op_getmad(kid,newop,'K');
6918 else if (kid->op_type == OP_READLINE) {
6919 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6920 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6923 I32 flags = OPf_SPECIAL;
6927 /* is this op a FH constructor? */
6928 if (is_handle_constructor(o,numargs)) {
6929 const char *name = NULL;
6933 /* Set a flag to tell rv2gv to vivify
6934 * need to "prove" flag does not mean something
6935 * else already - NI-S 1999/05/07
6938 if (kid->op_type == OP_PADSV) {
6940 = PAD_COMPNAME_SV(kid->op_targ);
6941 name = SvPV_const(namesv, len);
6943 else if (kid->op_type == OP_RV2SV
6944 && kUNOP->op_first->op_type == OP_GV)
6946 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6948 len = GvNAMELEN(gv);
6950 else if (kid->op_type == OP_AELEM
6951 || kid->op_type == OP_HELEM)
6954 OP *op = ((BINOP*)kid)->op_first;
6958 const char * const a =
6959 kid->op_type == OP_AELEM ?
6961 if (((op->op_type == OP_RV2AV) ||
6962 (op->op_type == OP_RV2HV)) &&
6963 (firstop = ((UNOP*)op)->op_first) &&
6964 (firstop->op_type == OP_GV)) {
6965 /* packagevar $a[] or $h{} */
6966 GV * const gv = cGVOPx_gv(firstop);
6974 else if (op->op_type == OP_PADAV
6975 || op->op_type == OP_PADHV) {
6976 /* lexicalvar $a[] or $h{} */
6977 const char * const padname =
6978 PAD_COMPNAME_PV(op->op_targ);
6987 name = SvPV_const(tmpstr, len);
6992 name = "__ANONIO__";
6999 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7000 namesv = PAD_SVl(targ);
7001 SvUPGRADE(namesv, SVt_PV);
7003 sv_setpvs(namesv, "$");
7004 sv_catpvn(namesv, name, len);
7007 kid->op_sibling = 0;
7008 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7009 kid->op_targ = targ;
7010 kid->op_private |= priv;
7012 kid->op_sibling = sibl;
7018 mod(scalar(kid), type);
7022 tokid = &kid->op_sibling;
7023 kid = kid->op_sibling;
7026 if (kid && kid->op_type != OP_STUB)
7027 return too_many_arguments(o,OP_DESC(o));
7028 o->op_private |= numargs;
7030 /* FIXME - should the numargs move as for the PERL_MAD case? */
7031 o->op_private |= numargs;
7033 return too_many_arguments(o,OP_DESC(o));
7037 else if (PL_opargs[type] & OA_DEFGV) {
7039 OP *newop = newUNOP(type, 0, newDEFSVOP());
7040 op_getmad(o,newop,'O');
7043 /* Ordering of these two is important to keep f_map.t passing. */
7045 return newUNOP(type, 0, newDEFSVOP());
7050 while (oa & OA_OPTIONAL)
7052 if (oa && oa != OA_LIST)
7053 return too_few_arguments(o,OP_DESC(o));
7059 Perl_ck_glob(pTHX_ OP *o)
7064 PERL_ARGS_ASSERT_CK_GLOB;
7067 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7068 append_elem(OP_GLOB, o, newDEFSVOP());
7070 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7071 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7073 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7076 #if !defined(PERL_EXTERNAL_GLOB)
7077 /* XXX this can be tightened up and made more failsafe. */
7078 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7081 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7082 newSVpvs("File::Glob"), NULL, NULL, NULL);
7083 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7084 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7085 GvCV(gv) = GvCV(glob_gv);
7086 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7087 GvIMPORTED_CV_on(gv);
7090 #endif /* PERL_EXTERNAL_GLOB */
7092 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7093 append_elem(OP_GLOB, o,
7094 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7095 o->op_type = OP_LIST;
7096 o->op_ppaddr = PL_ppaddr[OP_LIST];
7097 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7098 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7099 cLISTOPo->op_first->op_targ = 0;
7100 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7101 append_elem(OP_LIST, o,
7102 scalar(newUNOP(OP_RV2CV, 0,
7103 newGVOP(OP_GV, 0, gv)))));
7104 o = newUNOP(OP_NULL, 0, ck_subr(o));
7105 o->op_targ = OP_GLOB; /* hint at what it used to be */
7108 gv = newGVgen("main");
7110 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7116 Perl_ck_grep(pTHX_ OP *o)
7121 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7124 PERL_ARGS_ASSERT_CK_GREP;
7126 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7127 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7129 if (o->op_flags & OPf_STACKED) {
7132 kid = cLISTOPo->op_first->op_sibling;
7133 if (!cUNOPx(kid)->op_next)
7134 Perl_croak(aTHX_ "panic: ck_grep");
7135 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7138 NewOp(1101, gwop, 1, LOGOP);
7139 kid->op_next = (OP*)gwop;
7140 o->op_flags &= ~OPf_STACKED;
7142 kid = cLISTOPo->op_first->op_sibling;
7143 if (type == OP_MAPWHILE)
7148 if (PL_parser && PL_parser->error_count)
7150 kid = cLISTOPo->op_first->op_sibling;
7151 if (kid->op_type != OP_NULL)
7152 Perl_croak(aTHX_ "panic: ck_grep");
7153 kid = kUNOP->op_first;
7156 NewOp(1101, gwop, 1, LOGOP);
7157 gwop->op_type = type;
7158 gwop->op_ppaddr = PL_ppaddr[type];
7159 gwop->op_first = listkids(o);
7160 gwop->op_flags |= OPf_KIDS;
7161 gwop->op_other = LINKLIST(kid);
7162 kid->op_next = (OP*)gwop;
7163 offset = pad_findmy("$_");
7164 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7165 o->op_private = gwop->op_private = 0;
7166 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7169 o->op_private = gwop->op_private = OPpGREP_LEX;
7170 gwop->op_targ = o->op_targ = offset;
7173 kid = cLISTOPo->op_first->op_sibling;
7174 if (!kid || !kid->op_sibling)
7175 return too_few_arguments(o,OP_DESC(o));
7176 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7177 mod(kid, OP_GREPSTART);
7183 Perl_ck_index(pTHX_ OP *o)
7185 PERL_ARGS_ASSERT_CK_INDEX;
7187 if (o->op_flags & OPf_KIDS) {
7188 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7190 kid = kid->op_sibling; /* get past "big" */
7191 if (kid && kid->op_type == OP_CONST)
7192 fbm_compile(((SVOP*)kid)->op_sv, 0);
7198 Perl_ck_lfun(pTHX_ OP *o)
7200 const OPCODE type = o->op_type;
7202 PERL_ARGS_ASSERT_CK_LFUN;
7204 return modkids(ck_fun(o), type);
7208 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7210 PERL_ARGS_ASSERT_CK_DEFINED;
7212 if ((o->op_flags & OPf_KIDS)) {
7213 switch (cUNOPo->op_first->op_type) {
7215 /* This is needed for
7216 if (defined %stash::)
7217 to work. Do not break Tk.
7219 break; /* Globals via GV can be undef */
7221 case OP_AASSIGN: /* Is this a good idea? */
7222 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7223 "defined(@array) is deprecated");
7224 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7225 "\t(Maybe you should just omit the defined()?)\n");
7229 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7230 "defined(%%hash) is deprecated");
7231 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7232 "\t(Maybe you should just omit the defined()?)\n");
7243 Perl_ck_readline(pTHX_ OP *o)
7245 PERL_ARGS_ASSERT_CK_READLINE;
7247 if (!(o->op_flags & OPf_KIDS)) {
7249 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7251 op_getmad(o,newop,'O');
7261 Perl_ck_rfun(pTHX_ OP *o)
7263 const OPCODE type = o->op_type;
7265 PERL_ARGS_ASSERT_CK_RFUN;
7267 return refkids(ck_fun(o), type);
7271 Perl_ck_listiob(pTHX_ OP *o)
7275 PERL_ARGS_ASSERT_CK_LISTIOB;
7277 kid = cLISTOPo->op_first;
7280 kid = cLISTOPo->op_first;
7282 if (kid->op_type == OP_PUSHMARK)
7283 kid = kid->op_sibling;
7284 if (kid && o->op_flags & OPf_STACKED)
7285 kid = kid->op_sibling;
7286 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7287 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7288 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7289 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7290 cLISTOPo->op_first->op_sibling = kid;
7291 cLISTOPo->op_last = kid;
7292 kid = kid->op_sibling;
7297 append_elem(o->op_type, o, newDEFSVOP());
7303 Perl_ck_smartmatch(pTHX_ OP *o)
7306 if (0 == (o->op_flags & OPf_SPECIAL)) {
7307 OP *first = cBINOPo->op_first;
7308 OP *second = first->op_sibling;
7310 /* Implicitly take a reference to an array or hash */
7311 first->op_sibling = NULL;
7312 first = cBINOPo->op_first = ref_array_or_hash(first);
7313 second = first->op_sibling = ref_array_or_hash(second);
7315 /* Implicitly take a reference to a regular expression */
7316 if (first->op_type == OP_MATCH) {
7317 first->op_type = OP_QR;
7318 first->op_ppaddr = PL_ppaddr[OP_QR];
7320 if (second->op_type == OP_MATCH) {
7321 second->op_type = OP_QR;
7322 second->op_ppaddr = PL_ppaddr[OP_QR];
7331 Perl_ck_sassign(pTHX_ OP *o)
7334 OP * const kid = cLISTOPo->op_first;
7336 PERL_ARGS_ASSERT_CK_SASSIGN;
7338 /* has a disposable target? */
7339 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7340 && !(kid->op_flags & OPf_STACKED)
7341 /* Cannot steal the second time! */
7342 && !(kid->op_private & OPpTARGET_MY)
7343 /* Keep the full thing for madskills */
7347 OP * const kkid = kid->op_sibling;
7349 /* Can just relocate the target. */
7350 if (kkid && kkid->op_type == OP_PADSV
7351 && !(kkid->op_private & OPpLVAL_INTRO))
7353 kid->op_targ = kkid->op_targ;
7355 /* Now we do not need PADSV and SASSIGN. */
7356 kid->op_sibling = o->op_sibling; /* NULL */
7357 cLISTOPo->op_first = NULL;
7360 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7364 if (kid->op_sibling) {
7365 OP *kkid = kid->op_sibling;
7366 if (kkid->op_type == OP_PADSV
7367 && (kkid->op_private & OPpLVAL_INTRO)
7368 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7369 const PADOFFSET target = kkid->op_targ;
7370 OP *const other = newOP(OP_PADSV,
7372 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7373 OP *const first = newOP(OP_NULL, 0);
7374 OP *const nullop = newCONDOP(0, first, o, other);
7375 OP *const condop = first->op_next;
7376 /* hijacking PADSTALE for uninitialized state variables */
7377 SvPADSTALE_on(PAD_SVl(target));
7379 condop->op_type = OP_ONCE;
7380 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7381 condop->op_targ = target;
7382 other->op_targ = target;
7384 /* Because we change the type of the op here, we will skip the
7385 assinment binop->op_last = binop->op_first->op_sibling; at the
7386 end of Perl_newBINOP(). So need to do it here. */
7387 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7396 Perl_ck_match(pTHX_ OP *o)
7400 PERL_ARGS_ASSERT_CK_MATCH;
7402 if (o->op_type != OP_QR && PL_compcv) {
7403 const PADOFFSET offset = pad_findmy("$_");
7404 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7405 o->op_targ = offset;
7406 o->op_private |= OPpTARGET_MY;
7409 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7410 o->op_private |= OPpRUNTIME;
7415 Perl_ck_method(pTHX_ OP *o)
7417 OP * const kid = cUNOPo->op_first;
7419 PERL_ARGS_ASSERT_CK_METHOD;
7421 if (kid->op_type == OP_CONST) {
7422 SV* sv = kSVOP->op_sv;
7423 const char * const method = SvPVX_const(sv);
7424 if (!(strchr(method, ':') || strchr(method, '\''))) {
7426 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7427 sv = newSVpvn_share(method, SvCUR(sv), 0);
7430 kSVOP->op_sv = NULL;
7432 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7434 op_getmad(o,cmop,'O');
7445 Perl_ck_null(pTHX_ OP *o)
7447 PERL_ARGS_ASSERT_CK_NULL;
7448 PERL_UNUSED_CONTEXT;
7453 Perl_ck_open(pTHX_ OP *o)
7456 HV * const table = GvHV(PL_hintgv);
7458 PERL_ARGS_ASSERT_CK_OPEN;
7461 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7464 const char *d = SvPV_const(*svp, len);
7465 const I32 mode = mode_from_discipline(d, len);
7466 if (mode & O_BINARY)
7467 o->op_private |= OPpOPEN_IN_RAW;
7468 else if (mode & O_TEXT)
7469 o->op_private |= OPpOPEN_IN_CRLF;
7472 svp = hv_fetchs(table, "open_OUT", FALSE);
7475 const char *d = SvPV_const(*svp, len);
7476 const I32 mode = mode_from_discipline(d, len);
7477 if (mode & O_BINARY)
7478 o->op_private |= OPpOPEN_OUT_RAW;
7479 else if (mode & O_TEXT)
7480 o->op_private |= OPpOPEN_OUT_CRLF;
7483 if (o->op_type == OP_BACKTICK) {
7484 if (!(o->op_flags & OPf_KIDS)) {
7485 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7487 op_getmad(o,newop,'O');
7496 /* In case of three-arg dup open remove strictness
7497 * from the last arg if it is a bareword. */
7498 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7499 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7503 if ((last->op_type == OP_CONST) && /* The bareword. */
7504 (last->op_private & OPpCONST_BARE) &&
7505 (last->op_private & OPpCONST_STRICT) &&
7506 (oa = first->op_sibling) && /* The fh. */
7507 (oa = oa->op_sibling) && /* The mode. */
7508 (oa->op_type == OP_CONST) &&
7509 SvPOK(((SVOP*)oa)->op_sv) &&
7510 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7511 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7512 (last == oa->op_sibling)) /* The bareword. */
7513 last->op_private &= ~OPpCONST_STRICT;
7519 Perl_ck_repeat(pTHX_ OP *o)
7521 PERL_ARGS_ASSERT_CK_REPEAT;
7523 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7524 o->op_private |= OPpREPEAT_DOLIST;
7525 cBINOPo->op_first = force_list(cBINOPo->op_first);
7533 Perl_ck_require(pTHX_ OP *o)
7538 PERL_ARGS_ASSERT_CK_REQUIRE;
7540 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7541 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7543 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7544 SV * const sv = kid->op_sv;
7545 U32 was_readonly = SvREADONLY(sv);
7552 sv_force_normal_flags(sv, 0);
7553 assert(!SvREADONLY(sv));
7563 for (; s < end; s++) {
7564 if (*s == ':' && s[1] == ':') {
7566 Move(s+2, s+1, end - s - 1, char);
7571 sv_catpvs(sv, ".pm");
7572 SvFLAGS(sv) |= was_readonly;
7576 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7577 /* handle override, if any */
7578 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7579 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7580 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7581 gv = gvp ? *gvp : NULL;
7585 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7586 OP * const kid = cUNOPo->op_first;
7589 cUNOPo->op_first = 0;
7593 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7594 append_elem(OP_LIST, kid,
7595 scalar(newUNOP(OP_RV2CV, 0,
7598 op_getmad(o,newop,'O');
7606 Perl_ck_return(pTHX_ OP *o)
7611 PERL_ARGS_ASSERT_CK_RETURN;
7613 kid = cLISTOPo->op_first->op_sibling;
7614 if (CvLVALUE(PL_compcv)) {
7615 for (; kid; kid = kid->op_sibling)
7616 mod(kid, OP_LEAVESUBLV);
7618 for (; kid; kid = kid->op_sibling)
7619 if ((kid->op_type == OP_NULL)
7620 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7621 /* This is a do block */
7622 OP *op = kUNOP->op_first;
7623 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7624 op = cUNOPx(op)->op_first;
7625 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7626 /* Force the use of the caller's context */
7627 op->op_flags |= OPf_SPECIAL;
7636 Perl_ck_select(pTHX_ OP *o)
7641 PERL_ARGS_ASSERT_CK_SELECT;
7643 if (o->op_flags & OPf_KIDS) {
7644 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7645 if (kid && kid->op_sibling) {
7646 o->op_type = OP_SSELECT;
7647 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7649 return fold_constants(o);
7653 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7654 if (kid && kid->op_type == OP_RV2GV)
7655 kid->op_private &= ~HINT_STRICT_REFS;
7660 Perl_ck_shift(pTHX_ OP *o)
7663 const I32 type = o->op_type;
7665 PERL_ARGS_ASSERT_CK_SHIFT;
7667 if (!(o->op_flags & OPf_KIDS)) {
7668 OP *argop = newUNOP(OP_RV2AV, 0,
7669 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7671 OP * const oldo = o;
7672 o = newUNOP(type, 0, scalar(argop));
7673 op_getmad(oldo,o,'O');
7677 return newUNOP(type, 0, scalar(argop));
7680 return scalar(modkids(ck_fun(o), type));
7684 Perl_ck_sort(pTHX_ OP *o)
7689 PERL_ARGS_ASSERT_CK_SORT;
7691 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7692 HV * const hinthv = GvHV(PL_hintgv);
7694 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7696 const I32 sorthints = (I32)SvIV(*svp);
7697 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7698 o->op_private |= OPpSORT_QSORT;
7699 if ((sorthints & HINT_SORT_STABLE) != 0)
7700 o->op_private |= OPpSORT_STABLE;
7705 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7707 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7708 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7710 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7712 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7714 if (kid->op_type == OP_SCOPE) {
7718 else if (kid->op_type == OP_LEAVE) {
7719 if (o->op_type == OP_SORT) {
7720 op_null(kid); /* wipe out leave */
7723 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7724 if (k->op_next == kid)
7726 /* don't descend into loops */
7727 else if (k->op_type == OP_ENTERLOOP
7728 || k->op_type == OP_ENTERITER)
7730 k = cLOOPx(k)->op_lastop;
7735 kid->op_next = 0; /* just disconnect the leave */
7736 k = kLISTOP->op_first;
7741 if (o->op_type == OP_SORT) {
7742 /* provide scalar context for comparison function/block */
7748 o->op_flags |= OPf_SPECIAL;
7750 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7753 firstkid = firstkid->op_sibling;
7756 /* provide list context for arguments */
7757 if (o->op_type == OP_SORT)
7764 S_simplify_sort(pTHX_ OP *o)
7767 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7773 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7775 if (!(o->op_flags & OPf_STACKED))
7777 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7778 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7779 kid = kUNOP->op_first; /* get past null */
7780 if (kid->op_type != OP_SCOPE)
7782 kid = kLISTOP->op_last; /* get past scope */
7783 switch(kid->op_type) {
7791 k = kid; /* remember this node*/
7792 if (kBINOP->op_first->op_type != OP_RV2SV)
7794 kid = kBINOP->op_first; /* get past cmp */
7795 if (kUNOP->op_first->op_type != OP_GV)
7797 kid = kUNOP->op_first; /* get past rv2sv */
7799 if (GvSTASH(gv) != PL_curstash)
7801 gvname = GvNAME(gv);
7802 if (*gvname == 'a' && gvname[1] == '\0')
7804 else if (*gvname == 'b' && gvname[1] == '\0')
7809 kid = k; /* back to cmp */
7810 if (kBINOP->op_last->op_type != OP_RV2SV)
7812 kid = kBINOP->op_last; /* down to 2nd arg */
7813 if (kUNOP->op_first->op_type != OP_GV)
7815 kid = kUNOP->op_first; /* get past rv2sv */
7817 if (GvSTASH(gv) != PL_curstash)
7819 gvname = GvNAME(gv);
7821 ? !(*gvname == 'a' && gvname[1] == '\0')
7822 : !(*gvname == 'b' && gvname[1] == '\0'))
7824 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7826 o->op_private |= OPpSORT_DESCEND;
7827 if (k->op_type == OP_NCMP)
7828 o->op_private |= OPpSORT_NUMERIC;
7829 if (k->op_type == OP_I_NCMP)
7830 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7831 kid = cLISTOPo->op_first->op_sibling;
7832 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7834 op_getmad(kid,o,'S'); /* then delete it */
7836 op_free(kid); /* then delete it */
7841 Perl_ck_split(pTHX_ OP *o)
7846 PERL_ARGS_ASSERT_CK_SPLIT;
7848 if (o->op_flags & OPf_STACKED)
7849 return no_fh_allowed(o);
7851 kid = cLISTOPo->op_first;
7852 if (kid->op_type != OP_NULL)
7853 Perl_croak(aTHX_ "panic: ck_split");
7854 kid = kid->op_sibling;
7855 op_free(cLISTOPo->op_first);
7856 cLISTOPo->op_first = kid;
7858 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7859 cLISTOPo->op_last = kid; /* There was only one element previously */
7862 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7863 OP * const sibl = kid->op_sibling;
7864 kid->op_sibling = 0;
7865 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7866 if (cLISTOPo->op_first == cLISTOPo->op_last)
7867 cLISTOPo->op_last = kid;
7868 cLISTOPo->op_first = kid;
7869 kid->op_sibling = sibl;
7872 kid->op_type = OP_PUSHRE;
7873 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7875 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7876 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7877 "Use of /g modifier is meaningless in split");
7880 if (!kid->op_sibling)
7881 append_elem(OP_SPLIT, o, newDEFSVOP());
7883 kid = kid->op_sibling;
7886 if (!kid->op_sibling)
7887 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7888 assert(kid->op_sibling);
7890 kid = kid->op_sibling;
7893 if (kid->op_sibling)
7894 return too_many_arguments(o,OP_DESC(o));
7900 Perl_ck_join(pTHX_ OP *o)
7902 const OP * const kid = cLISTOPo->op_first->op_sibling;
7904 PERL_ARGS_ASSERT_CK_JOIN;
7906 if (kid && kid->op_type == OP_MATCH) {
7907 if (ckWARN(WARN_SYNTAX)) {
7908 const REGEXP *re = PM_GETRE(kPMOP);
7909 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7910 const STRLEN len = re ? RX_PRELEN(re) : 6;
7911 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7912 "/%.*s/ should probably be written as \"%.*s\"",
7913 (int)len, pmstr, (int)len, pmstr);
7920 Perl_ck_subr(pTHX_ OP *o)
7923 OP *prev = ((cUNOPo->op_first->op_sibling)
7924 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7925 OP *o2 = prev->op_sibling;
7927 const char *proto = NULL;
7928 const char *proto_end = NULL;
7933 I32 contextclass = 0;
7934 const char *e = NULL;
7937 PERL_ARGS_ASSERT_CK_SUBR;
7939 o->op_private |= OPpENTERSUB_HASTARG;
7940 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7941 if (cvop->op_type == OP_RV2CV) {
7943 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7944 op_null(cvop); /* disable rv2cv */
7945 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7946 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7947 GV *gv = cGVOPx_gv(tmpop);
7950 tmpop->op_private |= OPpEARLY_CV;
7954 namegv = CvANON(cv) ? gv : CvGV(cv);
7955 proto = SvPV(MUTABLE_SV(cv), len);
7956 proto_end = proto + len;
7961 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7962 if (o2->op_type == OP_CONST)
7963 o2->op_private &= ~OPpCONST_STRICT;
7964 else if (o2->op_type == OP_LIST) {
7965 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7966 if (sib && sib->op_type == OP_CONST)
7967 sib->op_private &= ~OPpCONST_STRICT;
7970 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7971 if (PERLDB_SUB && PL_curstash != PL_debstash)
7972 o->op_private |= OPpENTERSUB_DB;
7973 while (o2 != cvop) {
7975 if (PL_madskills && o2->op_type == OP_STUB) {
7976 o2 = o2->op_sibling;
7979 if (PL_madskills && o2->op_type == OP_NULL)
7980 o3 = ((UNOP*)o2)->op_first;
7984 if (proto >= proto_end)
7985 return too_many_arguments(o, gv_ename(namegv));
7993 /* _ must be at the end */
7994 if (proto[1] && proto[1] != ';')
8009 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8011 arg == 1 ? "block or sub {}" : "sub {}",
8012 gv_ename(namegv), o3);
8015 /* '*' allows any scalar type, including bareword */
8018 if (o3->op_type == OP_RV2GV)
8019 goto wrapref; /* autoconvert GLOB -> GLOBref */
8020 else if (o3->op_type == OP_CONST)
8021 o3->op_private &= ~OPpCONST_STRICT;
8022 else if (o3->op_type == OP_ENTERSUB) {
8023 /* accidental subroutine, revert to bareword */
8024 OP *gvop = ((UNOP*)o3)->op_first;
8025 if (gvop && gvop->op_type == OP_NULL) {
8026 gvop = ((UNOP*)gvop)->op_first;
8028 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8031 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8032 (gvop = ((UNOP*)gvop)->op_first) &&
8033 gvop->op_type == OP_GV)
8035 GV * const gv = cGVOPx_gv(gvop);
8036 OP * const sibling = o2->op_sibling;
8037 SV * const n = newSVpvs("");
8039 OP * const oldo2 = o2;
8043 gv_fullname4(n, gv, "", FALSE);
8044 o2 = newSVOP(OP_CONST, 0, n);
8045 op_getmad(oldo2,o2,'O');
8046 prev->op_sibling = o2;
8047 o2->op_sibling = sibling;
8063 if (contextclass++ == 0) {
8064 e = strchr(proto, ']');
8065 if (!e || e == proto)
8074 const char *p = proto;
8075 const char *const end = proto;
8077 while (*--p != '[') {}
8078 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8080 gv_ename(namegv), o3);
8085 if (o3->op_type == OP_RV2GV)
8088 bad_type(arg, "symbol", gv_ename(namegv), o3);
8091 if (o3->op_type == OP_ENTERSUB)
8094 bad_type(arg, "subroutine entry", gv_ename(namegv),
8098 if (o3->op_type == OP_RV2SV ||
8099 o3->op_type == OP_PADSV ||
8100 o3->op_type == OP_HELEM ||
8101 o3->op_type == OP_AELEM)
8104 bad_type(arg, "scalar", gv_ename(namegv), o3);
8107 if (o3->op_type == OP_RV2AV ||
8108 o3->op_type == OP_PADAV)
8111 bad_type(arg, "array", gv_ename(namegv), o3);
8114 if (o3->op_type == OP_RV2HV ||
8115 o3->op_type == OP_PADHV)
8118 bad_type(arg, "hash", gv_ename(namegv), o3);
8123 OP* const sib = kid->op_sibling;
8124 kid->op_sibling = 0;
8125 o2 = newUNOP(OP_REFGEN, 0, kid);
8126 o2->op_sibling = sib;
8127 prev->op_sibling = o2;
8129 if (contextclass && e) {
8144 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8145 gv_ename(namegv), SVfARG(cv));
8150 mod(o2, OP_ENTERSUB);
8152 o2 = o2->op_sibling;
8154 if (o2 == cvop && proto && *proto == '_') {
8155 /* generate an access to $_ */
8157 o2->op_sibling = prev->op_sibling;
8158 prev->op_sibling = o2; /* instead of cvop */
8160 if (proto && !optional && proto_end > proto &&
8161 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8162 return too_few_arguments(o, gv_ename(namegv));
8165 OP * const oldo = o;
8169 o=newSVOP(OP_CONST, 0, newSViv(0));
8170 op_getmad(oldo,o,'O');
8176 Perl_ck_svconst(pTHX_ OP *o)
8178 PERL_ARGS_ASSERT_CK_SVCONST;
8179 PERL_UNUSED_CONTEXT;
8180 SvREADONLY_on(cSVOPo->op_sv);
8185 Perl_ck_chdir(pTHX_ OP *o)
8187 if (o->op_flags & OPf_KIDS) {
8188 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8190 if (kid && kid->op_type == OP_CONST &&
8191 (kid->op_private & OPpCONST_BARE))
8193 o->op_flags |= OPf_SPECIAL;
8194 kid->op_private &= ~OPpCONST_STRICT;
8201 Perl_ck_trunc(pTHX_ OP *o)
8203 PERL_ARGS_ASSERT_CK_TRUNC;
8205 if (o->op_flags & OPf_KIDS) {
8206 SVOP *kid = (SVOP*)cUNOPo->op_first;
8208 if (kid->op_type == OP_NULL)
8209 kid = (SVOP*)kid->op_sibling;
8210 if (kid && kid->op_type == OP_CONST &&
8211 (kid->op_private & OPpCONST_BARE))
8213 o->op_flags |= OPf_SPECIAL;
8214 kid->op_private &= ~OPpCONST_STRICT;
8221 Perl_ck_unpack(pTHX_ OP *o)
8223 OP *kid = cLISTOPo->op_first;
8225 PERL_ARGS_ASSERT_CK_UNPACK;
8227 if (kid->op_sibling) {
8228 kid = kid->op_sibling;
8229 if (!kid->op_sibling)
8230 kid->op_sibling = newDEFSVOP();
8236 Perl_ck_substr(pTHX_ OP *o)
8238 PERL_ARGS_ASSERT_CK_SUBSTR;
8241 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8242 OP *kid = cLISTOPo->op_first;
8244 if (kid->op_type == OP_NULL)
8245 kid = kid->op_sibling;
8247 kid->op_flags |= OPf_MOD;
8254 Perl_ck_each(pTHX_ OP *o)
8257 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8259 PERL_ARGS_ASSERT_CK_EACH;
8262 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8263 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8264 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8265 o->op_type = new_type;
8266 o->op_ppaddr = PL_ppaddr[new_type];
8268 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8269 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8271 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8278 /* caller is supposed to assign the return to the
8279 container of the rep_op var */
8281 S_opt_scalarhv(pTHX_ OP *rep_op) {
8284 PERL_ARGS_ASSERT_OPT_SCALARHV;
8286 NewOp(1101, unop, 1, UNOP);
8287 unop->op_type = (OPCODE)OP_BOOLKEYS;
8288 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8289 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8290 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8291 unop->op_first = rep_op;
8292 unop->op_next = rep_op->op_next;
8293 rep_op->op_next = (OP*)unop;
8294 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8295 unop->op_sibling = rep_op->op_sibling;
8296 rep_op->op_sibling = NULL;
8297 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8298 if (rep_op->op_type == OP_PADHV) {
8299 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8300 rep_op->op_flags |= OPf_WANT_LIST;
8305 /* A peephole optimizer. We visit the ops in the order they're to execute.
8306 * See the comments at the top of this file for more details about when
8307 * peep() is called */
8310 Perl_peep(pTHX_ register OP *o)
8313 register OP* oldop = NULL;
8315 if (!o || o->op_opt)
8319 SAVEVPTR(PL_curcop);
8320 for (; o; o = o->op_next) {
8323 /* By default, this op has now been optimised. A couple of cases below
8324 clear this again. */
8327 switch (o->op_type) {
8330 PL_curcop = ((COP*)o); /* for warnings */
8334 if (cSVOPo->op_private & OPpCONST_STRICT)
8335 no_bareword_allowed(o);
8338 case OP_METHOD_NAMED:
8339 /* Relocate sv to the pad for thread safety.
8340 * Despite being a "constant", the SV is written to,
8341 * for reference counts, sv_upgrade() etc. */
8343 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8344 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8345 /* If op_sv is already a PADTMP then it is being used by
8346 * some pad, so make a copy. */
8347 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8348 SvREADONLY_on(PAD_SVl(ix));
8349 SvREFCNT_dec(cSVOPo->op_sv);
8351 else if (o->op_type != OP_METHOD_NAMED
8352 && cSVOPo->op_sv == &PL_sv_undef) {
8353 /* PL_sv_undef is hack - it's unsafe to store it in the
8354 AV that is the pad, because av_fetch treats values of
8355 PL_sv_undef as a "free" AV entry and will merrily
8356 replace them with a new SV, causing pad_alloc to think
8357 that this pad slot is free. (When, clearly, it is not)
8359 SvOK_off(PAD_SVl(ix));
8360 SvPADTMP_on(PAD_SVl(ix));
8361 SvREADONLY_on(PAD_SVl(ix));
8364 SvREFCNT_dec(PAD_SVl(ix));
8365 SvPADTMP_on(cSVOPo->op_sv);
8366 PAD_SETSV(ix, cSVOPo->op_sv);
8367 /* XXX I don't know how this isn't readonly already. */
8368 SvREADONLY_on(PAD_SVl(ix));
8370 cSVOPo->op_sv = NULL;
8377 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8378 if (o->op_next->op_private & OPpTARGET_MY) {
8379 if (o->op_flags & OPf_STACKED) /* chained concats */
8380 break; /* ignore_optimization */
8382 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8383 o->op_targ = o->op_next->op_targ;
8384 o->op_next->op_targ = 0;
8385 o->op_private |= OPpTARGET_MY;
8388 op_null(o->op_next);
8392 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8393 break; /* Scalar stub must produce undef. List stub is noop */
8397 if (o->op_targ == OP_NEXTSTATE
8398 || o->op_targ == OP_DBSTATE)
8400 PL_curcop = ((COP*)o);
8402 /* XXX: We avoid setting op_seq here to prevent later calls
8403 to peep() from mistakenly concluding that optimisation
8404 has already occurred. This doesn't fix the real problem,
8405 though (See 20010220.007). AMS 20010719 */
8406 /* op_seq functionality is now replaced by op_opt */
8413 if (oldop && o->op_next) {
8414 oldop->op_next = o->op_next;
8422 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8423 OP* const pop = (o->op_type == OP_PADAV) ?
8424 o->op_next : o->op_next->op_next;
8426 if (pop && pop->op_type == OP_CONST &&
8427 ((PL_op = pop->op_next)) &&
8428 pop->op_next->op_type == OP_AELEM &&
8429 !(pop->op_next->op_private &
8430 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8431 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8436 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8437 no_bareword_allowed(pop);
8438 if (o->op_type == OP_GV)
8439 op_null(o->op_next);
8440 op_null(pop->op_next);
8442 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8443 o->op_next = pop->op_next->op_next;
8444 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8445 o->op_private = (U8)i;
8446 if (o->op_type == OP_GV) {
8451 o->op_flags |= OPf_SPECIAL;
8452 o->op_type = OP_AELEMFAST;
8457 if (o->op_next->op_type == OP_RV2SV) {
8458 if (!(o->op_next->op_private & OPpDEREF)) {
8459 op_null(o->op_next);
8460 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8462 o->op_next = o->op_next->op_next;
8463 o->op_type = OP_GVSV;
8464 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8467 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8468 GV * const gv = cGVOPo_gv;
8469 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8470 /* XXX could check prototype here instead of just carping */
8471 SV * const sv = sv_newmortal();
8472 gv_efullname3(sv, gv, NULL);
8473 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8474 "%"SVf"() called too early to check prototype",
8478 else if (o->op_next->op_type == OP_READLINE
8479 && o->op_next->op_next->op_type == OP_CONCAT
8480 && (o->op_next->op_next->op_flags & OPf_STACKED))
8482 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8483 o->op_type = OP_RCATLINE;
8484 o->op_flags |= OPf_STACKED;
8485 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8486 op_null(o->op_next->op_next);
8487 op_null(o->op_next);
8497 fop = cUNOP->op_first;
8505 fop = cLOGOP->op_first;
8506 sop = fop->op_sibling;
8507 while (cLOGOP->op_other->op_type == OP_NULL)
8508 cLOGOP->op_other = cLOGOP->op_other->op_next;
8509 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8513 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8515 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8520 if (!(nop->op_flags && OPf_WANT_VOID)) {
8521 while (nop && nop->op_next) {
8522 switch (nop->op_next->op_type) {
8527 lop = nop = nop->op_next;
8538 if (lop->op_flags && OPf_WANT_VOID) {
8539 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8540 cLOGOP->op_first = opt_scalarhv(fop);
8541 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8542 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8558 while (cLOGOP->op_other->op_type == OP_NULL)
8559 cLOGOP->op_other = cLOGOP->op_other->op_next;
8560 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8565 while (cLOOP->op_redoop->op_type == OP_NULL)
8566 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8567 peep(cLOOP->op_redoop);
8568 while (cLOOP->op_nextop->op_type == OP_NULL)
8569 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8570 peep(cLOOP->op_nextop);
8571 while (cLOOP->op_lastop->op_type == OP_NULL)
8572 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8573 peep(cLOOP->op_lastop);
8577 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8578 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8579 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8580 cPMOP->op_pmstashstartu.op_pmreplstart
8581 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8582 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8586 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8587 && ckWARN(WARN_SYNTAX))
8589 if (o->op_next->op_sibling) {
8590 const OPCODE type = o->op_next->op_sibling->op_type;
8591 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8592 const line_t oldline = CopLINE(PL_curcop);
8593 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8594 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8595 "Statement unlikely to be reached");
8596 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8597 "\t(Maybe you meant system() when you said exec()?)\n");
8598 CopLINE_set(PL_curcop, oldline);
8609 const char *key = NULL;
8612 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8615 /* Make the CONST have a shared SV */
8616 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8617 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8618 key = SvPV_const(sv, keylen);
8619 lexname = newSVpvn_share(key,
8620 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8626 if ((o->op_private & (OPpLVAL_INTRO)))
8629 rop = (UNOP*)((BINOP*)o)->op_first;
8630 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8632 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8633 if (!SvPAD_TYPED(lexname))
8635 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8636 if (!fields || !GvHV(*fields))
8638 key = SvPV_const(*svp, keylen);
8639 if (!hv_fetch(GvHV(*fields), key,
8640 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8642 Perl_croak(aTHX_ "No such class field \"%s\" "
8643 "in variable %s of type %s",
8644 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8657 SVOP *first_key_op, *key_op;
8659 if ((o->op_private & (OPpLVAL_INTRO))
8660 /* I bet there's always a pushmark... */
8661 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8662 /* hmmm, no optimization if list contains only one key. */
8664 rop = (UNOP*)((LISTOP*)o)->op_last;
8665 if (rop->op_type != OP_RV2HV)
8667 if (rop->op_first->op_type == OP_PADSV)
8668 /* @$hash{qw(keys here)} */
8669 rop = (UNOP*)rop->op_first;
8671 /* @{$hash}{qw(keys here)} */
8672 if (rop->op_first->op_type == OP_SCOPE
8673 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8675 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8681 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8682 if (!SvPAD_TYPED(lexname))
8684 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8685 if (!fields || !GvHV(*fields))
8687 /* Again guessing that the pushmark can be jumped over.... */
8688 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8689 ->op_first->op_sibling;
8690 for (key_op = first_key_op; key_op;
8691 key_op = (SVOP*)key_op->op_sibling) {
8692 if (key_op->op_type != OP_CONST)
8694 svp = cSVOPx_svp(key_op);
8695 key = SvPV_const(*svp, keylen);
8696 if (!hv_fetch(GvHV(*fields), key,
8697 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8699 Perl_croak(aTHX_ "No such class field \"%s\" "
8700 "in variable %s of type %s",
8701 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8708 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8712 /* check that RHS of sort is a single plain array */
8713 OP *oright = cUNOPo->op_first;
8714 if (!oright || oright->op_type != OP_PUSHMARK)
8717 /* reverse sort ... can be optimised. */
8718 if (!cUNOPo->op_sibling) {
8719 /* Nothing follows us on the list. */
8720 OP * const reverse = o->op_next;
8722 if (reverse->op_type == OP_REVERSE &&
8723 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8724 OP * const pushmark = cUNOPx(reverse)->op_first;
8725 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8726 && (cUNOPx(pushmark)->op_sibling == o)) {
8727 /* reverse -> pushmark -> sort */
8728 o->op_private |= OPpSORT_REVERSE;
8730 pushmark->op_next = oright->op_next;
8736 /* make @a = sort @a act in-place */
8738 oright = cUNOPx(oright)->op_sibling;
8741 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8742 oright = cUNOPx(oright)->op_sibling;
8746 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8747 || oright->op_next != o
8748 || (oright->op_private & OPpLVAL_INTRO)
8752 /* o2 follows the chain of op_nexts through the LHS of the
8753 * assign (if any) to the aassign op itself */
8755 if (!o2 || o2->op_type != OP_NULL)
8758 if (!o2 || o2->op_type != OP_PUSHMARK)
8761 if (o2 && o2->op_type == OP_GV)
8764 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8765 || (o2->op_private & OPpLVAL_INTRO)
8770 if (!o2 || o2->op_type != OP_NULL)
8773 if (!o2 || o2->op_type != OP_AASSIGN
8774 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8777 /* check that the sort is the first arg on RHS of assign */
8779 o2 = cUNOPx(o2)->op_first;
8780 if (!o2 || o2->op_type != OP_NULL)
8782 o2 = cUNOPx(o2)->op_first;
8783 if (!o2 || o2->op_type != OP_PUSHMARK)
8785 if (o2->op_sibling != o)
8788 /* check the array is the same on both sides */
8789 if (oleft->op_type == OP_RV2AV) {
8790 if (oright->op_type != OP_RV2AV
8791 || !cUNOPx(oright)->op_first
8792 || cUNOPx(oright)->op_first->op_type != OP_GV
8793 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8794 cGVOPx_gv(cUNOPx(oright)->op_first)
8798 else if (oright->op_type != OP_PADAV
8799 || oright->op_targ != oleft->op_targ
8803 /* transfer MODishness etc from LHS arg to RHS arg */
8804 oright->op_flags = oleft->op_flags;
8805 o->op_private |= OPpSORT_INPLACE;
8807 /* excise push->gv->rv2av->null->aassign */
8808 o2 = o->op_next->op_next;
8809 op_null(o2); /* PUSHMARK */
8811 if (o2->op_type == OP_GV) {
8812 op_null(o2); /* GV */
8815 op_null(o2); /* RV2AV or PADAV */
8816 o2 = o2->op_next->op_next;
8817 op_null(o2); /* AASSIGN */
8819 o->op_next = o2->op_next;
8825 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8827 LISTOP *enter, *exlist;
8829 enter = (LISTOP *) o->op_next;
8832 if (enter->op_type == OP_NULL) {
8833 enter = (LISTOP *) enter->op_next;
8837 /* for $a (...) will have OP_GV then OP_RV2GV here.
8838 for (...) just has an OP_GV. */
8839 if (enter->op_type == OP_GV) {
8840 gvop = (OP *) enter;
8841 enter = (LISTOP *) enter->op_next;
8844 if (enter->op_type == OP_RV2GV) {
8845 enter = (LISTOP *) enter->op_next;
8851 if (enter->op_type != OP_ENTERITER)
8854 iter = enter->op_next;
8855 if (!iter || iter->op_type != OP_ITER)
8858 expushmark = enter->op_first;
8859 if (!expushmark || expushmark->op_type != OP_NULL
8860 || expushmark->op_targ != OP_PUSHMARK)
8863 exlist = (LISTOP *) expushmark->op_sibling;
8864 if (!exlist || exlist->op_type != OP_NULL
8865 || exlist->op_targ != OP_LIST)
8868 if (exlist->op_last != o) {
8869 /* Mmm. Was expecting to point back to this op. */
8872 theirmark = exlist->op_first;
8873 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8876 if (theirmark->op_sibling != o) {
8877 /* There's something between the mark and the reverse, eg
8878 for (1, reverse (...))
8883 ourmark = ((LISTOP *)o)->op_first;
8884 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8887 ourlast = ((LISTOP *)o)->op_last;
8888 if (!ourlast || ourlast->op_next != o)
8891 rv2av = ourmark->op_sibling;
8892 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8893 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8894 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8895 /* We're just reversing a single array. */
8896 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8897 enter->op_flags |= OPf_STACKED;
8900 /* We don't have control over who points to theirmark, so sacrifice
8902 theirmark->op_next = ourmark->op_next;
8903 theirmark->op_flags = ourmark->op_flags;
8904 ourlast->op_next = gvop ? gvop : (OP *) enter;
8907 enter->op_private |= OPpITER_REVERSED;
8908 iter->op_private |= OPpITER_REVERSED;
8915 UNOP *refgen, *rv2cv;
8918 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8921 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8924 rv2gv = ((BINOP *)o)->op_last;
8925 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8928 refgen = (UNOP *)((BINOP *)o)->op_first;
8930 if (!refgen || refgen->op_type != OP_REFGEN)
8933 exlist = (LISTOP *)refgen->op_first;
8934 if (!exlist || exlist->op_type != OP_NULL
8935 || exlist->op_targ != OP_LIST)
8938 if (exlist->op_first->op_type != OP_PUSHMARK)
8941 rv2cv = (UNOP*)exlist->op_last;
8943 if (rv2cv->op_type != OP_RV2CV)
8946 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8947 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8948 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8950 o->op_private |= OPpASSIGN_CV_TO_GV;
8951 rv2gv->op_private |= OPpDONT_INIT_GV;
8952 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8960 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8961 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8971 Perl_custom_op_name(pTHX_ const OP* o)
8974 const IV index = PTR2IV(o->op_ppaddr);
8978 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8980 if (!PL_custom_op_names) /* This probably shouldn't happen */
8981 return (char *)PL_op_name[OP_CUSTOM];
8983 keysv = sv_2mortal(newSViv(index));
8985 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8987 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8989 return SvPV_nolen(HeVAL(he));
8993 Perl_custom_op_desc(pTHX_ const OP* o)
8996 const IV index = PTR2IV(o->op_ppaddr);
9000 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9002 if (!PL_custom_op_descs)
9003 return (char *)PL_op_desc[OP_CUSTOM];
9005 keysv = sv_2mortal(newSViv(index));
9007 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9009 return (char *)PL_op_desc[OP_CUSTOM];
9011 return SvPV_nolen(HeVAL(he));
9016 /* Efficient sub that returns a constant scalar value. */
9018 const_sv_xsub(pTHX_ CV* cv)
9022 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9026 /* diag_listed_as: SKIPME */
9027 Perl_croak(aTHX_ "usage: %s::%s()",
9028 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9041 * c-indentation-style: bsd
9043 * indent-tabs-mode: t
9046 * ex: set ts=8 sts=4 sw=4 noet: