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 PL_hints |= HINT_BLOCK_SCOPE;
1545 if (type == OP_LEAVESUBLV)
1546 o->op_private |= OPpMAYBE_LVSUB;
1550 ref(cUNOPo->op_first, o->op_type);
1554 PL_hints |= HINT_BLOCK_SCOPE;
1569 PL_modcount = RETURN_UNLIMITED_NUMBER;
1570 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1571 return o; /* Treat \(@foo) like ordinary list. */
1572 if (scalar_mod_type(o, type))
1574 if (type == OP_LEAVESUBLV)
1575 o->op_private |= OPpMAYBE_LVSUB;
1579 if (!type) /* local() */
1580 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1581 PAD_COMPNAME_PV(o->op_targ));
1589 if (type != OP_SASSIGN)
1593 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1598 if (type == OP_LEAVESUBLV)
1599 o->op_private |= OPpMAYBE_LVSUB;
1601 pad_free(o->op_targ);
1602 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1603 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1604 if (o->op_flags & OPf_KIDS)
1605 mod(cBINOPo->op_first->op_sibling, type);
1610 ref(cBINOPo->op_first, o->op_type);
1611 if (type == OP_ENTERSUB &&
1612 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1613 o->op_private |= OPpLVAL_DEFER;
1614 if (type == OP_LEAVESUBLV)
1615 o->op_private |= OPpMAYBE_LVSUB;
1625 if (o->op_flags & OPf_KIDS)
1626 mod(cLISTOPo->op_last, type);
1631 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1633 else if (!(o->op_flags & OPf_KIDS))
1635 if (o->op_targ != OP_LIST) {
1636 mod(cBINOPo->op_first, type);
1642 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1647 if (type != OP_LEAVESUBLV)
1649 break; /* mod()ing was handled by ck_return() */
1652 /* [20011101.069] File test operators interpret OPf_REF to mean that
1653 their argument is a filehandle; thus \stat(".") should not set
1655 if (type == OP_REFGEN &&
1656 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1659 if (type != OP_LEAVESUBLV)
1660 o->op_flags |= OPf_MOD;
1662 if (type == OP_AASSIGN || type == OP_SASSIGN)
1663 o->op_flags |= OPf_SPECIAL|OPf_REF;
1664 else if (!type) { /* local() */
1667 o->op_private |= OPpLVAL_INTRO;
1668 o->op_flags &= ~OPf_SPECIAL;
1669 PL_hints |= HINT_BLOCK_SCOPE;
1674 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1675 "Useless localization of %s", OP_DESC(o));
1678 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1679 && type != OP_LEAVESUBLV)
1680 o->op_flags |= OPf_REF;
1685 S_scalar_mod_type(const OP *o, I32 type)
1687 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1691 if (o->op_type == OP_RV2GV)
1715 case OP_RIGHT_SHIFT:
1735 S_is_handle_constructor(const OP *o, I32 numargs)
1737 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1739 switch (o->op_type) {
1747 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1760 S_refkids(pTHX_ OP *o, I32 type)
1762 if (o && o->op_flags & OPf_KIDS) {
1764 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1771 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1776 PERL_ARGS_ASSERT_DOREF;
1778 if (!o || (PL_parser && PL_parser->error_count))
1781 switch (o->op_type) {
1783 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1784 !(o->op_flags & OPf_STACKED)) {
1785 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1786 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1787 assert(cUNOPo->op_first->op_type == OP_NULL);
1788 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1789 o->op_flags |= OPf_SPECIAL;
1790 o->op_private &= ~1;
1795 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1796 doref(kid, type, set_op_ref);
1799 if (type == OP_DEFINED)
1800 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1801 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1804 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1805 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1806 : type == OP_RV2HV ? OPpDEREF_HV
1808 o->op_flags |= OPf_MOD;
1815 o->op_flags |= OPf_REF;
1818 if (type == OP_DEFINED)
1819 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1820 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1826 o->op_flags |= OPf_REF;
1831 if (!(o->op_flags & OPf_KIDS))
1833 doref(cBINOPo->op_first, type, set_op_ref);
1837 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1838 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1839 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1840 : type == OP_RV2HV ? OPpDEREF_HV
1842 o->op_flags |= OPf_MOD;
1852 if (!(o->op_flags & OPf_KIDS))
1854 doref(cLISTOPo->op_last, type, set_op_ref);
1864 S_dup_attrlist(pTHX_ OP *o)
1869 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1871 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1872 * where the first kid is OP_PUSHMARK and the remaining ones
1873 * are OP_CONST. We need to push the OP_CONST values.
1875 if (o->op_type == OP_CONST)
1876 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1878 else if (o->op_type == OP_NULL)
1882 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1884 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1885 if (o->op_type == OP_CONST)
1886 rop = append_elem(OP_LIST, rop,
1887 newSVOP(OP_CONST, o->op_flags,
1888 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1895 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1900 PERL_ARGS_ASSERT_APPLY_ATTRS;
1902 /* fake up C<use attributes $pkg,$rv,@attrs> */
1903 ENTER; /* need to protect against side-effects of 'use' */
1904 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1906 #define ATTRSMODULE "attributes"
1907 #define ATTRSMODULE_PM "attributes.pm"
1910 /* Don't force the C<use> if we don't need it. */
1911 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1912 if (svp && *svp != &PL_sv_undef)
1913 NOOP; /* already in %INC */
1915 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1916 newSVpvs(ATTRSMODULE), NULL);
1919 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1920 newSVpvs(ATTRSMODULE),
1922 prepend_elem(OP_LIST,
1923 newSVOP(OP_CONST, 0, stashsv),
1924 prepend_elem(OP_LIST,
1925 newSVOP(OP_CONST, 0,
1927 dup_attrlist(attrs))));
1933 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1936 OP *pack, *imop, *arg;
1939 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1944 assert(target->op_type == OP_PADSV ||
1945 target->op_type == OP_PADHV ||
1946 target->op_type == OP_PADAV);
1948 /* Ensure that attributes.pm is loaded. */
1949 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1951 /* Need package name for method call. */
1952 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1954 /* Build up the real arg-list. */
1955 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1957 arg = newOP(OP_PADSV, 0);
1958 arg->op_targ = target->op_targ;
1959 arg = prepend_elem(OP_LIST,
1960 newSVOP(OP_CONST, 0, stashsv),
1961 prepend_elem(OP_LIST,
1962 newUNOP(OP_REFGEN, 0,
1963 mod(arg, OP_REFGEN)),
1964 dup_attrlist(attrs)));
1966 /* Fake up a method call to import */
1967 meth = newSVpvs_share("import");
1968 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1969 append_elem(OP_LIST,
1970 prepend_elem(OP_LIST, pack, list(arg)),
1971 newSVOP(OP_METHOD_NAMED, 0, meth)));
1972 imop->op_private |= OPpENTERSUB_NOMOD;
1974 /* Combine the ops. */
1975 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1979 =notfor apidoc apply_attrs_string
1981 Attempts to apply a list of attributes specified by the C<attrstr> and
1982 C<len> arguments to the subroutine identified by the C<cv> argument which
1983 is expected to be associated with the package identified by the C<stashpv>
1984 argument (see L<attributes>). It gets this wrong, though, in that it
1985 does not correctly identify the boundaries of the individual attribute
1986 specifications within C<attrstr>. This is not really intended for the
1987 public API, but has to be listed here for systems such as AIX which
1988 need an explicit export list for symbols. (It's called from XS code
1989 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1990 to respect attribute syntax properly would be welcome.
1996 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1997 const char *attrstr, STRLEN len)
2001 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2004 len = strlen(attrstr);
2008 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2010 const char * const sstr = attrstr;
2011 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2012 attrs = append_elem(OP_LIST, attrs,
2013 newSVOP(OP_CONST, 0,
2014 newSVpvn(sstr, attrstr-sstr)));
2018 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2019 newSVpvs(ATTRSMODULE),
2020 NULL, prepend_elem(OP_LIST,
2021 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2022 prepend_elem(OP_LIST,
2023 newSVOP(OP_CONST, 0,
2024 newRV(MUTABLE_SV(cv))),
2029 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2034 PERL_ARGS_ASSERT_MY_KID;
2036 if (!o || (PL_parser && PL_parser->error_count))
2040 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2041 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2045 if (type == OP_LIST) {
2047 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2048 my_kid(kid, attrs, imopsp);
2049 } else if (type == OP_UNDEF
2055 } else if (type == OP_RV2SV || /* "our" declaration */
2057 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2058 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2059 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2061 PL_parser->in_my == KEY_our
2063 : PL_parser->in_my == KEY_state ? "state" : "my"));
2065 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2066 PL_parser->in_my = FALSE;
2067 PL_parser->in_my_stash = NULL;
2068 apply_attrs(GvSTASH(gv),
2069 (type == OP_RV2SV ? GvSV(gv) :
2070 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2071 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2074 o->op_private |= OPpOUR_INTRO;
2077 else if (type != OP_PADSV &&
2080 type != OP_PUSHMARK)
2082 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2084 PL_parser->in_my == KEY_our
2086 : PL_parser->in_my == KEY_state ? "state" : "my"));
2089 else if (attrs && type != OP_PUSHMARK) {
2092 PL_parser->in_my = FALSE;
2093 PL_parser->in_my_stash = NULL;
2095 /* check for C<my Dog $spot> when deciding package */
2096 stash = PAD_COMPNAME_TYPE(o->op_targ);
2098 stash = PL_curstash;
2099 apply_attrs_my(stash, o, attrs, imopsp);
2101 o->op_flags |= OPf_MOD;
2102 o->op_private |= OPpLVAL_INTRO;
2103 if (PL_parser->in_my == KEY_state)
2104 o->op_private |= OPpPAD_STATE;
2109 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2113 int maybe_scalar = 0;
2115 PERL_ARGS_ASSERT_MY_ATTRS;
2117 /* [perl #17376]: this appears to be premature, and results in code such as
2118 C< our(%x); > executing in list mode rather than void mode */
2120 if (o->op_flags & OPf_PARENS)
2130 o = my_kid(o, attrs, &rops);
2132 if (maybe_scalar && o->op_type == OP_PADSV) {
2133 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2134 o->op_private |= OPpLVAL_INTRO;
2137 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2139 PL_parser->in_my = FALSE;
2140 PL_parser->in_my_stash = NULL;
2145 Perl_sawparens(pTHX_ OP *o)
2147 PERL_UNUSED_CONTEXT;
2149 o->op_flags |= OPf_PARENS;
2154 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2158 const OPCODE ltype = left->op_type;
2159 const OPCODE rtype = right->op_type;
2161 PERL_ARGS_ASSERT_BIND_MATCH;
2163 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2164 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2166 const char * const desc
2167 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2168 ? (int)rtype : OP_MATCH];
2169 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2170 ? "@array" : "%hash");
2171 Perl_warner(aTHX_ packWARN(WARN_MISC),
2172 "Applying %s to %s will act on scalar(%s)",
2173 desc, sample, sample);
2176 if (rtype == OP_CONST &&
2177 cSVOPx(right)->op_private & OPpCONST_BARE &&
2178 cSVOPx(right)->op_private & OPpCONST_STRICT)
2180 no_bareword_allowed(right);
2183 ismatchop = rtype == OP_MATCH ||
2184 rtype == OP_SUBST ||
2186 if (ismatchop && right->op_private & OPpTARGET_MY) {
2188 right->op_private &= ~OPpTARGET_MY;
2190 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2193 right->op_flags |= OPf_STACKED;
2194 if (rtype != OP_MATCH &&
2195 ! (rtype == OP_TRANS &&
2196 right->op_private & OPpTRANS_IDENTICAL))
2197 newleft = mod(left, rtype);
2200 if (right->op_type == OP_TRANS)
2201 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2203 o = prepend_elem(rtype, scalar(newleft), right);
2205 return newUNOP(OP_NOT, 0, scalar(o));
2209 return bind_match(type, left,
2210 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2214 Perl_invert(pTHX_ OP *o)
2218 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2222 Perl_scope(pTHX_ OP *o)
2226 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2227 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2228 o->op_type = OP_LEAVE;
2229 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2231 else if (o->op_type == OP_LINESEQ) {
2233 o->op_type = OP_SCOPE;
2234 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2235 kid = ((LISTOP*)o)->op_first;
2236 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2239 /* The following deals with things like 'do {1 for 1}' */
2240 kid = kid->op_sibling;
2242 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2247 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2253 Perl_block_start(pTHX_ int full)
2256 const int retval = PL_savestack_ix;
2257 pad_block_start(full);
2259 PL_hints &= ~HINT_BLOCK_SCOPE;
2260 SAVECOMPILEWARNINGS();
2261 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2266 Perl_block_end(pTHX_ I32 floor, OP *seq)
2269 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2270 OP* const retval = scalarseq(seq);
2272 CopHINTS_set(&PL_compiling, PL_hints);
2274 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2283 const PADOFFSET offset = pad_findmy("$_");
2284 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2285 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2288 OP * const o = newOP(OP_PADSV, 0);
2289 o->op_targ = offset;
2295 Perl_newPROG(pTHX_ OP *o)
2299 PERL_ARGS_ASSERT_NEWPROG;
2304 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2305 ((PL_in_eval & EVAL_KEEPERR)
2306 ? OPf_SPECIAL : 0), o);
2307 PL_eval_start = linklist(PL_eval_root);
2308 PL_eval_root->op_private |= OPpREFCOUNTED;
2309 OpREFCNT_set(PL_eval_root, 1);
2310 PL_eval_root->op_next = 0;
2311 CALL_PEEP(PL_eval_start);
2314 if (o->op_type == OP_STUB) {
2315 PL_comppad_name = 0;
2317 S_op_destroy(aTHX_ o);
2320 PL_main_root = scope(sawparens(scalarvoid(o)));
2321 PL_curcop = &PL_compiling;
2322 PL_main_start = LINKLIST(PL_main_root);
2323 PL_main_root->op_private |= OPpREFCOUNTED;
2324 OpREFCNT_set(PL_main_root, 1);
2325 PL_main_root->op_next = 0;
2326 CALL_PEEP(PL_main_start);
2329 /* Register with debugger */
2331 CV * const cv = get_cvs("DB::postponed", 0);
2335 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2337 call_sv(MUTABLE_SV(cv), G_DISCARD);
2344 Perl_localize(pTHX_ OP *o, I32 lex)
2348 PERL_ARGS_ASSERT_LOCALIZE;
2350 if (o->op_flags & OPf_PARENS)
2351 /* [perl #17376]: this appears to be premature, and results in code such as
2352 C< our(%x); > executing in list mode rather than void mode */
2359 if ( PL_parser->bufptr > PL_parser->oldbufptr
2360 && PL_parser->bufptr[-1] == ','
2361 && ckWARN(WARN_PARENTHESIS))
2363 char *s = PL_parser->bufptr;
2366 /* some heuristics to detect a potential error */
2367 while (*s && (strchr(", \t\n", *s)))
2371 if (*s && strchr("@$%*", *s) && *++s
2372 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2375 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2377 while (*s && (strchr(", \t\n", *s)))
2383 if (sigil && (*s == ';' || *s == '=')) {
2384 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2385 "Parentheses missing around \"%s\" list",
2387 ? (PL_parser->in_my == KEY_our
2389 : PL_parser->in_my == KEY_state
2399 o = mod(o, OP_NULL); /* a bit kludgey */
2400 PL_parser->in_my = FALSE;
2401 PL_parser->in_my_stash = NULL;
2406 Perl_jmaybe(pTHX_ OP *o)
2408 PERL_ARGS_ASSERT_JMAYBE;
2410 if (o->op_type == OP_LIST) {
2412 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2413 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2419 S_fold_constants(pTHX_ register OP *o)
2422 register OP * VOL curop;
2424 VOL I32 type = o->op_type;
2429 SV * const oldwarnhook = PL_warnhook;
2430 SV * const olddiehook = PL_diehook;
2434 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2436 if (PL_opargs[type] & OA_RETSCALAR)
2438 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2439 o->op_targ = pad_alloc(type, SVs_PADTMP);
2441 /* integerize op, unless it happens to be C<-foo>.
2442 * XXX should pp_i_negate() do magic string negation instead? */
2443 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2444 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2445 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2447 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2450 if (!(PL_opargs[type] & OA_FOLDCONST))
2455 /* XXX might want a ck_negate() for this */
2456 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2467 /* XXX what about the numeric ops? */
2468 if (PL_hints & HINT_LOCALE)
2473 if (PL_parser && PL_parser->error_count)
2474 goto nope; /* Don't try to run w/ errors */
2476 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2477 const OPCODE type = curop->op_type;
2478 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2480 type != OP_SCALAR &&
2482 type != OP_PUSHMARK)
2488 curop = LINKLIST(o);
2489 old_next = o->op_next;
2493 oldscope = PL_scopestack_ix;
2494 create_eval_scope(G_FAKINGEVAL);
2496 /* Verify that we don't need to save it: */
2497 assert(PL_curcop == &PL_compiling);
2498 StructCopy(&PL_compiling, ¬_compiling, COP);
2499 PL_curcop = ¬_compiling;
2500 /* The above ensures that we run with all the correct hints of the
2501 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2502 assert(IN_PERL_RUNTIME);
2503 PL_warnhook = PERL_WARNHOOK_FATAL;
2510 sv = *(PL_stack_sp--);
2511 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2512 pad_swipe(o->op_targ, FALSE);
2513 else if (SvTEMP(sv)) { /* grab mortal temp? */
2514 SvREFCNT_inc_simple_void(sv);
2519 /* Something tried to die. Abandon constant folding. */
2520 /* Pretend the error never happened. */
2522 o->op_next = old_next;
2526 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2527 PL_warnhook = oldwarnhook;
2528 PL_diehook = olddiehook;
2529 /* XXX note that this croak may fail as we've already blown away
2530 * the stack - eg any nested evals */
2531 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2534 PL_warnhook = oldwarnhook;
2535 PL_diehook = olddiehook;
2536 PL_curcop = &PL_compiling;
2538 if (PL_scopestack_ix > oldscope)
2539 delete_eval_scope();
2548 if (type == OP_RV2GV)
2549 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2551 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2552 op_getmad(o,newop,'f');
2560 S_gen_constant_list(pTHX_ register OP *o)
2564 const I32 oldtmps_floor = PL_tmps_floor;
2567 if (PL_parser && PL_parser->error_count)
2568 return o; /* Don't attempt to run with errors */
2570 PL_op = curop = LINKLIST(o);
2576 assert (!(curop->op_flags & OPf_SPECIAL));
2577 assert(curop->op_type == OP_RANGE);
2579 PL_tmps_floor = oldtmps_floor;
2581 o->op_type = OP_RV2AV;
2582 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2583 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2584 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2585 o->op_opt = 0; /* needs to be revisited in peep() */
2586 curop = ((UNOP*)o)->op_first;
2587 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2589 op_getmad(curop,o,'O');
2598 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2601 if (!o || o->op_type != OP_LIST)
2602 o = newLISTOP(OP_LIST, 0, o, NULL);
2604 o->op_flags &= ~OPf_WANT;
2606 if (!(PL_opargs[type] & OA_MARK))
2607 op_null(cLISTOPo->op_first);
2609 o->op_type = (OPCODE)type;
2610 o->op_ppaddr = PL_ppaddr[type];
2611 o->op_flags |= flags;
2613 o = CHECKOP(type, o);
2614 if (o->op_type != (unsigned)type)
2617 return fold_constants(o);
2620 /* List constructors */
2623 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2631 if (first->op_type != (unsigned)type
2632 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2634 return newLISTOP(type, 0, first, last);
2637 if (first->op_flags & OPf_KIDS)
2638 ((LISTOP*)first)->op_last->op_sibling = last;
2640 first->op_flags |= OPf_KIDS;
2641 ((LISTOP*)first)->op_first = last;
2643 ((LISTOP*)first)->op_last = last;
2648 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2656 if (first->op_type != (unsigned)type)
2657 return prepend_elem(type, (OP*)first, (OP*)last);
2659 if (last->op_type != (unsigned)type)
2660 return append_elem(type, (OP*)first, (OP*)last);
2662 first->op_last->op_sibling = last->op_first;
2663 first->op_last = last->op_last;
2664 first->op_flags |= (last->op_flags & OPf_KIDS);
2667 if (last->op_first && first->op_madprop) {
2668 MADPROP *mp = last->op_first->op_madprop;
2670 while (mp->mad_next)
2672 mp->mad_next = first->op_madprop;
2675 last->op_first->op_madprop = first->op_madprop;
2678 first->op_madprop = last->op_madprop;
2679 last->op_madprop = 0;
2682 S_op_destroy(aTHX_ (OP*)last);
2688 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2696 if (last->op_type == (unsigned)type) {
2697 if (type == OP_LIST) { /* already a PUSHMARK there */
2698 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2699 ((LISTOP*)last)->op_first->op_sibling = first;
2700 if (!(first->op_flags & OPf_PARENS))
2701 last->op_flags &= ~OPf_PARENS;
2704 if (!(last->op_flags & OPf_KIDS)) {
2705 ((LISTOP*)last)->op_last = first;
2706 last->op_flags |= OPf_KIDS;
2708 first->op_sibling = ((LISTOP*)last)->op_first;
2709 ((LISTOP*)last)->op_first = first;
2711 last->op_flags |= OPf_KIDS;
2715 return newLISTOP(type, 0, first, last);
2723 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2726 Newxz(tk, 1, TOKEN);
2727 tk->tk_type = (OPCODE)optype;
2728 tk->tk_type = 12345;
2730 tk->tk_mad = madprop;
2735 Perl_token_free(pTHX_ TOKEN* tk)
2737 PERL_ARGS_ASSERT_TOKEN_FREE;
2739 if (tk->tk_type != 12345)
2741 mad_free(tk->tk_mad);
2746 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2751 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2753 if (tk->tk_type != 12345) {
2754 Perl_warner(aTHX_ packWARN(WARN_MISC),
2755 "Invalid TOKEN object ignored");
2762 /* faked up qw list? */
2764 tm->mad_type == MAD_SV &&
2765 SvPVX((SV *)tm->mad_val)[0] == 'q')
2772 /* pretend constant fold didn't happen? */
2773 if (mp->mad_key == 'f' &&
2774 (o->op_type == OP_CONST ||
2775 o->op_type == OP_GV) )
2777 token_getmad(tk,(OP*)mp->mad_val,slot);
2791 if (mp->mad_key == 'X')
2792 mp->mad_key = slot; /* just change the first one */
2802 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2811 /* pretend constant fold didn't happen? */
2812 if (mp->mad_key == 'f' &&
2813 (o->op_type == OP_CONST ||
2814 o->op_type == OP_GV) )
2816 op_getmad(from,(OP*)mp->mad_val,slot);
2823 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2826 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2832 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2841 /* pretend constant fold didn't happen? */
2842 if (mp->mad_key == 'f' &&
2843 (o->op_type == OP_CONST ||
2844 o->op_type == OP_GV) )
2846 op_getmad(from,(OP*)mp->mad_val,slot);
2853 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2856 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2860 PerlIO_printf(PerlIO_stderr(),
2861 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2867 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2885 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2889 addmad(tm, &(o->op_madprop), slot);
2893 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2914 Perl_newMADsv(pTHX_ char key, SV* sv)
2916 PERL_ARGS_ASSERT_NEWMADSV;
2918 return newMADPROP(key, MAD_SV, sv, 0);
2922 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2925 Newxz(mp, 1, MADPROP);
2928 mp->mad_vlen = vlen;
2929 mp->mad_type = type;
2931 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2936 Perl_mad_free(pTHX_ MADPROP* mp)
2938 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2942 mad_free(mp->mad_next);
2943 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2944 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2945 switch (mp->mad_type) {
2949 Safefree((char*)mp->mad_val);
2952 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2953 op_free((OP*)mp->mad_val);
2956 sv_free(MUTABLE_SV(mp->mad_val));
2959 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2968 Perl_newNULLLIST(pTHX)
2970 return newOP(OP_STUB, 0);
2974 S_force_list(pTHX_ OP *o)
2976 if (!o || o->op_type != OP_LIST)
2977 o = newLISTOP(OP_LIST, 0, o, NULL);
2983 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2988 NewOp(1101, listop, 1, LISTOP);
2990 listop->op_type = (OPCODE)type;
2991 listop->op_ppaddr = PL_ppaddr[type];
2994 listop->op_flags = (U8)flags;
2998 else if (!first && last)
3001 first->op_sibling = last;
3002 listop->op_first = first;
3003 listop->op_last = last;
3004 if (type == OP_LIST) {
3005 OP* const pushop = newOP(OP_PUSHMARK, 0);
3006 pushop->op_sibling = first;
3007 listop->op_first = pushop;
3008 listop->op_flags |= OPf_KIDS;
3010 listop->op_last = pushop;
3013 return CHECKOP(type, listop);
3017 Perl_newOP(pTHX_ I32 type, I32 flags)
3021 NewOp(1101, o, 1, OP);
3022 o->op_type = (OPCODE)type;
3023 o->op_ppaddr = PL_ppaddr[type];
3024 o->op_flags = (U8)flags;
3026 o->op_latefreed = 0;
3030 o->op_private = (U8)(0 | (flags >> 8));
3031 if (PL_opargs[type] & OA_RETSCALAR)
3033 if (PL_opargs[type] & OA_TARGET)
3034 o->op_targ = pad_alloc(type, SVs_PADTMP);
3035 return CHECKOP(type, o);
3039 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3045 first = newOP(OP_STUB, 0);
3046 if (PL_opargs[type] & OA_MARK)
3047 first = force_list(first);
3049 NewOp(1101, unop, 1, UNOP);
3050 unop->op_type = (OPCODE)type;
3051 unop->op_ppaddr = PL_ppaddr[type];
3052 unop->op_first = first;
3053 unop->op_flags = (U8)(flags | OPf_KIDS);
3054 unop->op_private = (U8)(1 | (flags >> 8));
3055 unop = (UNOP*) CHECKOP(type, unop);
3059 return fold_constants((OP *) unop);
3063 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3067 NewOp(1101, binop, 1, BINOP);
3070 first = newOP(OP_NULL, 0);
3072 binop->op_type = (OPCODE)type;
3073 binop->op_ppaddr = PL_ppaddr[type];
3074 binop->op_first = first;
3075 binop->op_flags = (U8)(flags | OPf_KIDS);
3078 binop->op_private = (U8)(1 | (flags >> 8));
3081 binop->op_private = (U8)(2 | (flags >> 8));
3082 first->op_sibling = last;
3085 binop = (BINOP*)CHECKOP(type, binop);
3086 if (binop->op_next || binop->op_type != (OPCODE)type)
3089 binop->op_last = binop->op_first->op_sibling;
3091 return fold_constants((OP *)binop);
3094 static int uvcompare(const void *a, const void *b)
3095 __attribute__nonnull__(1)
3096 __attribute__nonnull__(2)
3097 __attribute__pure__;
3098 static int uvcompare(const void *a, const void *b)
3100 if (*((const UV *)a) < (*(const UV *)b))
3102 if (*((const UV *)a) > (*(const UV *)b))
3104 if (*((const UV *)a+1) < (*(const UV *)b+1))
3106 if (*((const UV *)a+1) > (*(const UV *)b+1))
3112 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3115 SV * const tstr = ((SVOP*)expr)->op_sv;
3118 (repl->op_type == OP_NULL)
3119 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3121 ((SVOP*)repl)->op_sv;
3124 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3125 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3129 register short *tbl;
3131 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3132 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3133 I32 del = o->op_private & OPpTRANS_DELETE;
3136 PERL_ARGS_ASSERT_PMTRANS;
3138 PL_hints |= HINT_BLOCK_SCOPE;
3141 o->op_private |= OPpTRANS_FROM_UTF;
3144 o->op_private |= OPpTRANS_TO_UTF;
3146 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3147 SV* const listsv = newSVpvs("# comment\n");
3149 const U8* tend = t + tlen;
3150 const U8* rend = r + rlen;
3164 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3165 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3168 const U32 flags = UTF8_ALLOW_DEFAULT;
3172 t = tsave = bytes_to_utf8(t, &len);
3175 if (!to_utf && rlen) {
3177 r = rsave = bytes_to_utf8(r, &len);
3181 /* There are several snags with this code on EBCDIC:
3182 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3183 2. scan_const() in toke.c has encoded chars in native encoding which makes
3184 ranges at least in EBCDIC 0..255 range the bottom odd.
3188 U8 tmpbuf[UTF8_MAXBYTES+1];
3191 Newx(cp, 2*tlen, UV);
3193 transv = newSVpvs("");
3195 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3197 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3199 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3203 cp[2*i+1] = cp[2*i];
3207 qsort(cp, i, 2*sizeof(UV), uvcompare);
3208 for (j = 0; j < i; j++) {
3210 diff = val - nextmin;
3212 t = uvuni_to_utf8(tmpbuf,nextmin);
3213 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3215 U8 range_mark = UTF_TO_NATIVE(0xff);
3216 t = uvuni_to_utf8(tmpbuf, val - 1);
3217 sv_catpvn(transv, (char *)&range_mark, 1);
3218 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3225 t = uvuni_to_utf8(tmpbuf,nextmin);
3226 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3228 U8 range_mark = UTF_TO_NATIVE(0xff);
3229 sv_catpvn(transv, (char *)&range_mark, 1);
3231 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3232 UNICODE_ALLOW_SUPER);
3233 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3234 t = (const U8*)SvPVX_const(transv);
3235 tlen = SvCUR(transv);
3239 else if (!rlen && !del) {
3240 r = t; rlen = tlen; rend = tend;
3243 if ((!rlen && !del) || t == r ||
3244 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3246 o->op_private |= OPpTRANS_IDENTICAL;
3250 while (t < tend || tfirst <= tlast) {
3251 /* see if we need more "t" chars */
3252 if (tfirst > tlast) {
3253 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3255 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3257 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3264 /* now see if we need more "r" chars */
3265 if (rfirst > rlast) {
3267 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3269 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3271 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3280 rfirst = rlast = 0xffffffff;
3284 /* now see which range will peter our first, if either. */
3285 tdiff = tlast - tfirst;
3286 rdiff = rlast - rfirst;
3293 if (rfirst == 0xffffffff) {
3294 diff = tdiff; /* oops, pretend rdiff is infinite */
3296 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3297 (long)tfirst, (long)tlast);
3299 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3303 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3304 (long)tfirst, (long)(tfirst + diff),
3307 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3308 (long)tfirst, (long)rfirst);
3310 if (rfirst + diff > max)
3311 max = rfirst + diff;
3313 grows = (tfirst < rfirst &&
3314 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3326 else if (max > 0xff)
3331 PerlMemShared_free(cPVOPo->op_pv);
3332 cPVOPo->op_pv = NULL;
3334 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3336 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3337 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3338 PAD_SETSV(cPADOPo->op_padix, swash);
3340 SvREADONLY_on(swash);
3342 cSVOPo->op_sv = swash;
3344 SvREFCNT_dec(listsv);
3345 SvREFCNT_dec(transv);
3347 if (!del && havefinal && rlen)
3348 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3349 newSVuv((UV)final), 0);
3352 o->op_private |= OPpTRANS_GROWS;
3358 op_getmad(expr,o,'e');
3359 op_getmad(repl,o,'r');
3367 tbl = (short*)cPVOPo->op_pv;
3369 Zero(tbl, 256, short);
3370 for (i = 0; i < (I32)tlen; i++)
3372 for (i = 0, j = 0; i < 256; i++) {
3374 if (j >= (I32)rlen) {
3383 if (i < 128 && r[j] >= 128)
3393 o->op_private |= OPpTRANS_IDENTICAL;
3395 else if (j >= (I32)rlen)
3400 PerlMemShared_realloc(tbl,
3401 (0x101+rlen-j) * sizeof(short));
3402 cPVOPo->op_pv = (char*)tbl;
3404 tbl[0x100] = (short)(rlen - j);
3405 for (i=0; i < (I32)rlen - j; i++)
3406 tbl[0x101+i] = r[j+i];
3410 if (!rlen && !del) {
3413 o->op_private |= OPpTRANS_IDENTICAL;
3415 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3416 o->op_private |= OPpTRANS_IDENTICAL;
3418 for (i = 0; i < 256; i++)
3420 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3421 if (j >= (I32)rlen) {
3423 if (tbl[t[i]] == -1)
3429 if (tbl[t[i]] == -1) {
3430 if (t[i] < 128 && r[j] >= 128)
3437 if(del && rlen == tlen) {
3438 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3439 } else if(rlen > tlen) {
3440 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3444 o->op_private |= OPpTRANS_GROWS;
3446 op_getmad(expr,o,'e');
3447 op_getmad(repl,o,'r');
3457 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3462 NewOp(1101, pmop, 1, PMOP);
3463 pmop->op_type = (OPCODE)type;
3464 pmop->op_ppaddr = PL_ppaddr[type];
3465 pmop->op_flags = (U8)flags;
3466 pmop->op_private = (U8)(0 | (flags >> 8));
3468 if (PL_hints & HINT_RE_TAINT)
3469 pmop->op_pmflags |= PMf_RETAINT;
3470 if (PL_hints & HINT_LOCALE)
3471 pmop->op_pmflags |= PMf_LOCALE;
3475 assert(SvPOK(PL_regex_pad[0]));
3476 if (SvCUR(PL_regex_pad[0])) {
3477 /* Pop off the "packed" IV from the end. */
3478 SV *const repointer_list = PL_regex_pad[0];
3479 const char *p = SvEND(repointer_list) - sizeof(IV);
3480 const IV offset = *((IV*)p);
3482 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3484 SvEND_set(repointer_list, p);
3486 pmop->op_pmoffset = offset;
3487 /* This slot should be free, so assert this: */
3488 assert(PL_regex_pad[offset] == &PL_sv_undef);
3490 SV * const repointer = &PL_sv_undef;
3491 av_push(PL_regex_padav, repointer);
3492 pmop->op_pmoffset = av_len(PL_regex_padav);
3493 PL_regex_pad = AvARRAY(PL_regex_padav);
3497 return CHECKOP(type, pmop);
3500 /* Given some sort of match op o, and an expression expr containing a
3501 * pattern, either compile expr into a regex and attach it to o (if it's
3502 * constant), or convert expr into a runtime regcomp op sequence (if it's
3505 * isreg indicates that the pattern is part of a regex construct, eg
3506 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3507 * split "pattern", which aren't. In the former case, expr will be a list
3508 * if the pattern contains more than one term (eg /a$b/) or if it contains
3509 * a replacement, ie s/// or tr///.
3513 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3518 I32 repl_has_vars = 0;
3522 PERL_ARGS_ASSERT_PMRUNTIME;
3524 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3525 /* last element in list is the replacement; pop it */
3527 repl = cLISTOPx(expr)->op_last;
3528 kid = cLISTOPx(expr)->op_first;
3529 while (kid->op_sibling != repl)
3530 kid = kid->op_sibling;
3531 kid->op_sibling = NULL;
3532 cLISTOPx(expr)->op_last = kid;
3535 if (isreg && expr->op_type == OP_LIST &&
3536 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3538 /* convert single element list to element */
3539 OP* const oe = expr;
3540 expr = cLISTOPx(oe)->op_first->op_sibling;
3541 cLISTOPx(oe)->op_first->op_sibling = NULL;
3542 cLISTOPx(oe)->op_last = NULL;
3546 if (o->op_type == OP_TRANS) {
3547 return pmtrans(o, expr, repl);
3550 reglist = isreg && expr->op_type == OP_LIST;
3554 PL_hints |= HINT_BLOCK_SCOPE;
3557 if (expr->op_type == OP_CONST) {
3558 SV *pat = ((SVOP*)expr)->op_sv;
3559 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3561 if (o->op_flags & OPf_SPECIAL)
3562 pm_flags |= RXf_SPLIT;
3565 assert (SvUTF8(pat));
3566 } else if (SvUTF8(pat)) {
3567 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3568 trapped in use 'bytes'? */
3569 /* Make a copy of the octet sequence, but without the flag on, as
3570 the compiler now honours the SvUTF8 flag on pat. */
3572 const char *const p = SvPV(pat, len);
3573 pat = newSVpvn_flags(p, len, SVs_TEMP);
3576 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3579 op_getmad(expr,(OP*)pm,'e');
3585 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3586 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3588 : OP_REGCMAYBE),0,expr);
3590 NewOp(1101, rcop, 1, LOGOP);
3591 rcop->op_type = OP_REGCOMP;
3592 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3593 rcop->op_first = scalar(expr);
3594 rcop->op_flags |= OPf_KIDS
3595 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3596 | (reglist ? OPf_STACKED : 0);
3597 rcop->op_private = 1;
3600 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3602 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3605 /* establish postfix order */
3606 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3608 rcop->op_next = expr;
3609 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3612 rcop->op_next = LINKLIST(expr);
3613 expr->op_next = (OP*)rcop;
3616 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3621 if (pm->op_pmflags & PMf_EVAL) {
3623 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3624 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3626 else if (repl->op_type == OP_CONST)
3630 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3631 if (curop->op_type == OP_SCOPE
3632 || curop->op_type == OP_LEAVE
3633 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3634 if (curop->op_type == OP_GV) {
3635 GV * const gv = cGVOPx_gv(curop);
3637 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3640 else if (curop->op_type == OP_RV2CV)
3642 else if (curop->op_type == OP_RV2SV ||
3643 curop->op_type == OP_RV2AV ||
3644 curop->op_type == OP_RV2HV ||
3645 curop->op_type == OP_RV2GV) {
3646 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3649 else if (curop->op_type == OP_PADSV ||
3650 curop->op_type == OP_PADAV ||
3651 curop->op_type == OP_PADHV ||
3652 curop->op_type == OP_PADANY)
3656 else if (curop->op_type == OP_PUSHRE)
3657 NOOP; /* Okay here, dangerous in newASSIGNOP */
3667 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3669 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3670 prepend_elem(o->op_type, scalar(repl), o);
3673 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3674 pm->op_pmflags |= PMf_MAYBE_CONST;
3676 NewOp(1101, rcop, 1, LOGOP);
3677 rcop->op_type = OP_SUBSTCONT;
3678 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3679 rcop->op_first = scalar(repl);
3680 rcop->op_flags |= OPf_KIDS;
3681 rcop->op_private = 1;
3684 /* establish postfix order */
3685 rcop->op_next = LINKLIST(repl);
3686 repl->op_next = (OP*)rcop;
3688 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3689 assert(!(pm->op_pmflags & PMf_ONCE));
3690 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3699 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3704 PERL_ARGS_ASSERT_NEWSVOP;
3706 NewOp(1101, svop, 1, SVOP);
3707 svop->op_type = (OPCODE)type;
3708 svop->op_ppaddr = PL_ppaddr[type];
3710 svop->op_next = (OP*)svop;
3711 svop->op_flags = (U8)flags;
3712 if (PL_opargs[type] & OA_RETSCALAR)
3714 if (PL_opargs[type] & OA_TARGET)
3715 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3716 return CHECKOP(type, svop);
3721 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3726 PERL_ARGS_ASSERT_NEWPADOP;
3728 NewOp(1101, padop, 1, PADOP);
3729 padop->op_type = (OPCODE)type;
3730 padop->op_ppaddr = PL_ppaddr[type];
3731 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3732 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3733 PAD_SETSV(padop->op_padix, sv);
3736 padop->op_next = (OP*)padop;
3737 padop->op_flags = (U8)flags;
3738 if (PL_opargs[type] & OA_RETSCALAR)
3740 if (PL_opargs[type] & OA_TARGET)
3741 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3742 return CHECKOP(type, padop);
3747 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3751 PERL_ARGS_ASSERT_NEWGVOP;
3755 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3757 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3762 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3766 NewOp(1101, pvop, 1, PVOP);
3767 pvop->op_type = (OPCODE)type;
3768 pvop->op_ppaddr = PL_ppaddr[type];
3770 pvop->op_next = (OP*)pvop;
3771 pvop->op_flags = (U8)flags;
3772 if (PL_opargs[type] & OA_RETSCALAR)
3774 if (PL_opargs[type] & OA_TARGET)
3775 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3776 return CHECKOP(type, pvop);
3784 Perl_package(pTHX_ OP *o)
3787 SV *const sv = cSVOPo->op_sv;
3792 PERL_ARGS_ASSERT_PACKAGE;
3794 save_hptr(&PL_curstash);
3795 save_item(PL_curstname);
3797 PL_curstash = gv_stashsv(sv, GV_ADD);
3799 sv_setsv(PL_curstname, sv);
3801 PL_hints |= HINT_BLOCK_SCOPE;
3802 PL_parser->copline = NOLINE;
3803 PL_parser->expect = XSTATE;
3808 if (!PL_madskills) {
3813 pegop = newOP(OP_NULL,0);
3814 op_getmad(o,pegop,'P');
3820 Perl_package_version( pTHX_ OP *v )
3823 U32 savehints = PL_hints;
3824 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3825 PL_hints &= ~HINT_STRICT_VARS;
3826 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3827 PL_hints = savehints;
3836 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3843 OP *pegop = newOP(OP_NULL,0);
3846 PERL_ARGS_ASSERT_UTILIZE;
3848 if (idop->op_type != OP_CONST)
3849 Perl_croak(aTHX_ "Module name must be constant");
3852 op_getmad(idop,pegop,'U');
3857 SV * const vesv = ((SVOP*)version)->op_sv;
3860 op_getmad(version,pegop,'V');
3861 if (!arg && !SvNIOKp(vesv)) {
3868 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3869 Perl_croak(aTHX_ "Version number must be a constant number");
3871 /* Make copy of idop so we don't free it twice */
3872 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3874 /* Fake up a method call to VERSION */
3875 meth = newSVpvs_share("VERSION");
3876 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3877 append_elem(OP_LIST,
3878 prepend_elem(OP_LIST, pack, list(version)),
3879 newSVOP(OP_METHOD_NAMED, 0, meth)));
3883 /* Fake up an import/unimport */
3884 if (arg && arg->op_type == OP_STUB) {
3886 op_getmad(arg,pegop,'S');
3887 imop = arg; /* no import on explicit () */
3889 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3890 imop = NULL; /* use 5.0; */
3892 idop->op_private |= OPpCONST_NOVER;
3898 op_getmad(arg,pegop,'A');
3900 /* Make copy of idop so we don't free it twice */
3901 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3903 /* Fake up a method call to import/unimport */
3905 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3906 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3907 append_elem(OP_LIST,
3908 prepend_elem(OP_LIST, pack, list(arg)),
3909 newSVOP(OP_METHOD_NAMED, 0, meth)));
3912 /* Fake up the BEGIN {}, which does its thing immediately. */
3914 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3917 append_elem(OP_LINESEQ,
3918 append_elem(OP_LINESEQ,
3919 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3920 newSTATEOP(0, NULL, veop)),
3921 newSTATEOP(0, NULL, imop) ));
3923 /* The "did you use incorrect case?" warning used to be here.
3924 * The problem is that on case-insensitive filesystems one
3925 * might get false positives for "use" (and "require"):
3926 * "use Strict" or "require CARP" will work. This causes
3927 * portability problems for the script: in case-strict
3928 * filesystems the script will stop working.
3930 * The "incorrect case" warning checked whether "use Foo"
3931 * imported "Foo" to your namespace, but that is wrong, too:
3932 * there is no requirement nor promise in the language that
3933 * a Foo.pm should or would contain anything in package "Foo".
3935 * There is very little Configure-wise that can be done, either:
3936 * the case-sensitivity of the build filesystem of Perl does not
3937 * help in guessing the case-sensitivity of the runtime environment.
3940 PL_hints |= HINT_BLOCK_SCOPE;
3941 PL_parser->copline = NOLINE;
3942 PL_parser->expect = XSTATE;
3943 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3946 if (!PL_madskills) {
3947 /* FIXME - don't allocate pegop if !PL_madskills */
3956 =head1 Embedding Functions
3958 =for apidoc load_module
3960 Loads the module whose name is pointed to by the string part of name.
3961 Note that the actual module name, not its filename, should be given.
3962 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3963 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3964 (or 0 for no flags). ver, if specified, provides version semantics
3965 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3966 arguments can be used to specify arguments to the module's import()
3967 method, similar to C<use Foo::Bar VERSION LIST>. They must be
3968 terminated with a final NULL pointer. Note that this list can only
3969 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
3970 Otherwise at least a single NULL pointer to designate the default
3971 import list is required.
3976 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3980 PERL_ARGS_ASSERT_LOAD_MODULE;
3982 va_start(args, ver);
3983 vload_module(flags, name, ver, &args);
3987 #ifdef PERL_IMPLICIT_CONTEXT
3989 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3993 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3994 va_start(args, ver);
3995 vload_module(flags, name, ver, &args);
4001 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4005 OP * const modname = newSVOP(OP_CONST, 0, name);
4007 PERL_ARGS_ASSERT_VLOAD_MODULE;
4009 modname->op_private |= OPpCONST_BARE;
4011 veop = newSVOP(OP_CONST, 0, ver);
4015 if (flags & PERL_LOADMOD_NOIMPORT) {
4016 imop = sawparens(newNULLLIST());
4018 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4019 imop = va_arg(*args, OP*);
4024 sv = va_arg(*args, SV*);
4026 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4027 sv = va_arg(*args, SV*);
4031 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4032 * that it has a PL_parser to play with while doing that, and also
4033 * that it doesn't mess with any existing parser, by creating a tmp
4034 * new parser with lex_start(). This won't actually be used for much,
4035 * since pp_require() will create another parser for the real work. */
4038 SAVEVPTR(PL_curcop);
4039 lex_start(NULL, NULL, FALSE);
4040 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4041 veop, modname, imop);
4046 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4052 PERL_ARGS_ASSERT_DOFILE;
4054 if (!force_builtin) {
4055 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4056 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4057 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4058 gv = gvp ? *gvp : NULL;
4062 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4063 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4064 append_elem(OP_LIST, term,
4065 scalar(newUNOP(OP_RV2CV, 0,
4066 newGVOP(OP_GV, 0, gv))))));
4069 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4075 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4077 return newBINOP(OP_LSLICE, flags,
4078 list(force_list(subscript)),
4079 list(force_list(listval)) );
4083 S_is_list_assignment(pTHX_ register const OP *o)
4091 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4092 o = cUNOPo->op_first;
4094 flags = o->op_flags;
4096 if (type == OP_COND_EXPR) {
4097 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4098 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4103 yyerror("Assignment to both a list and a scalar");
4107 if (type == OP_LIST &&
4108 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4109 o->op_private & OPpLVAL_INTRO)
4112 if (type == OP_LIST || flags & OPf_PARENS ||
4113 type == OP_RV2AV || type == OP_RV2HV ||
4114 type == OP_ASLICE || type == OP_HSLICE)
4117 if (type == OP_PADAV || type == OP_PADHV)
4120 if (type == OP_RV2SV)
4127 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4133 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4134 return newLOGOP(optype, 0,
4135 mod(scalar(left), optype),
4136 newUNOP(OP_SASSIGN, 0, scalar(right)));
4139 return newBINOP(optype, OPf_STACKED,
4140 mod(scalar(left), optype), scalar(right));
4144 if (is_list_assignment(left)) {
4145 static const char no_list_state[] = "Initialization of state variables"
4146 " in list context currently forbidden";
4148 bool maybe_common_vars = TRUE;
4151 /* Grandfathering $[ assignment here. Bletch.*/
4152 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4153 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4154 left = mod(left, OP_AASSIGN);
4157 else if (left->op_type == OP_CONST) {
4159 /* Result of assignment is always 1 (or we'd be dead already) */
4160 return newSVOP(OP_CONST, 0, newSViv(1));
4162 curop = list(force_list(left));
4163 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4164 o->op_private = (U8)(0 | (flags >> 8));
4166 if ((left->op_type == OP_LIST
4167 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4169 OP* lop = ((LISTOP*)left)->op_first;
4170 maybe_common_vars = FALSE;
4172 if (lop->op_type == OP_PADSV ||
4173 lop->op_type == OP_PADAV ||
4174 lop->op_type == OP_PADHV ||
4175 lop->op_type == OP_PADANY) {
4176 if (!(lop->op_private & OPpLVAL_INTRO))
4177 maybe_common_vars = TRUE;
4179 if (lop->op_private & OPpPAD_STATE) {
4180 if (left->op_private & OPpLVAL_INTRO) {
4181 /* Each variable in state($a, $b, $c) = ... */
4184 /* Each state variable in
4185 (state $a, my $b, our $c, $d, undef) = ... */
4187 yyerror(no_list_state);
4189 /* Each my variable in
4190 (state $a, my $b, our $c, $d, undef) = ... */
4192 } else if (lop->op_type == OP_UNDEF ||
4193 lop->op_type == OP_PUSHMARK) {
4194 /* undef may be interesting in
4195 (state $a, undef, state $c) */
4197 /* Other ops in the list. */
4198 maybe_common_vars = TRUE;
4200 lop = lop->op_sibling;
4203 else if ((left->op_private & OPpLVAL_INTRO)
4204 && ( left->op_type == OP_PADSV
4205 || left->op_type == OP_PADAV
4206 || left->op_type == OP_PADHV
4207 || left->op_type == OP_PADANY))
4209 maybe_common_vars = FALSE;
4210 if (left->op_private & OPpPAD_STATE) {
4211 /* All single variable list context state assignments, hence
4221 yyerror(no_list_state);
4225 /* PL_generation sorcery:
4226 * an assignment like ($a,$b) = ($c,$d) is easier than
4227 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4228 * To detect whether there are common vars, the global var
4229 * PL_generation is incremented for each assign op we compile.
4230 * Then, while compiling the assign op, we run through all the
4231 * variables on both sides of the assignment, setting a spare slot
4232 * in each of them to PL_generation. If any of them already have
4233 * that value, we know we've got commonality. We could use a
4234 * single bit marker, but then we'd have to make 2 passes, first
4235 * to clear the flag, then to test and set it. To find somewhere
4236 * to store these values, evil chicanery is done with SvUVX().
4239 if (maybe_common_vars) {
4242 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4243 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4244 if (curop->op_type == OP_GV) {
4245 GV *gv = cGVOPx_gv(curop);
4247 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4249 GvASSIGN_GENERATION_set(gv, PL_generation);
4251 else if (curop->op_type == OP_PADSV ||
4252 curop->op_type == OP_PADAV ||
4253 curop->op_type == OP_PADHV ||
4254 curop->op_type == OP_PADANY)
4256 if (PAD_COMPNAME_GEN(curop->op_targ)
4257 == (STRLEN)PL_generation)
4259 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4262 else if (curop->op_type == OP_RV2CV)
4264 else if (curop->op_type == OP_RV2SV ||
4265 curop->op_type == OP_RV2AV ||
4266 curop->op_type == OP_RV2HV ||
4267 curop->op_type == OP_RV2GV) {
4268 if (lastop->op_type != OP_GV) /* funny deref? */
4271 else if (curop->op_type == OP_PUSHRE) {
4273 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4274 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4276 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4278 GvASSIGN_GENERATION_set(gv, PL_generation);
4282 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4285 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4287 GvASSIGN_GENERATION_set(gv, PL_generation);
4297 o->op_private |= OPpASSIGN_COMMON;
4300 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4301 OP* tmpop = ((LISTOP*)right)->op_first;
4302 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4303 PMOP * const pm = (PMOP*)tmpop;
4304 if (left->op_type == OP_RV2AV &&
4305 !(left->op_private & OPpLVAL_INTRO) &&
4306 !(o->op_private & OPpASSIGN_COMMON) )
4308 tmpop = ((UNOP*)left)->op_first;
4309 if (tmpop->op_type == OP_GV
4311 && !pm->op_pmreplrootu.op_pmtargetoff
4313 && !pm->op_pmreplrootu.op_pmtargetgv
4317 pm->op_pmreplrootu.op_pmtargetoff
4318 = cPADOPx(tmpop)->op_padix;
4319 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4321 pm->op_pmreplrootu.op_pmtargetgv
4322 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4323 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4325 pm->op_pmflags |= PMf_ONCE;
4326 tmpop = cUNOPo->op_first; /* to list (nulled) */
4327 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4328 tmpop->op_sibling = NULL; /* don't free split */
4329 right->op_next = tmpop->op_next; /* fix starting loc */
4330 op_free(o); /* blow off assign */
4331 right->op_flags &= ~OPf_WANT;
4332 /* "I don't know and I don't care." */
4337 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4338 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4340 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4341 if (SvIOK(sv) && SvIVX(sv) == 0)
4342 sv_setiv(sv, PL_modcount+1);
4350 right = newOP(OP_UNDEF, 0);
4351 if (right->op_type == OP_READLINE) {
4352 right->op_flags |= OPf_STACKED;
4353 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4356 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4357 o = newBINOP(OP_SASSIGN, flags,
4358 scalar(right), mod(scalar(left), OP_SASSIGN) );
4362 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4363 deprecate("assignment to $[");
4365 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4366 o->op_private |= OPpCONST_ARYBASE;
4374 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4377 const U32 seq = intro_my();
4380 NewOp(1101, cop, 1, COP);
4381 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4382 cop->op_type = OP_DBSTATE;
4383 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4386 cop->op_type = OP_NEXTSTATE;
4387 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4389 cop->op_flags = (U8)flags;
4390 CopHINTS_set(cop, PL_hints);
4392 cop->op_private |= NATIVE_HINTS;
4394 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4395 cop->op_next = (OP*)cop;
4398 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4399 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4401 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4402 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4403 if (cop->cop_hints_hash) {
4405 cop->cop_hints_hash->refcounted_he_refcnt++;
4406 HINTS_REFCNT_UNLOCK;
4410 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4412 PL_hints |= HINT_BLOCK_SCOPE;
4413 /* It seems that we need to defer freeing this pointer, as other parts
4414 of the grammar end up wanting to copy it after this op has been
4419 if (PL_parser && PL_parser->copline == NOLINE)
4420 CopLINE_set(cop, CopLINE(PL_curcop));
4422 CopLINE_set(cop, PL_parser->copline);
4424 PL_parser->copline = NOLINE;
4427 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4429 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4431 CopSTASH_set(cop, PL_curstash);
4433 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4434 /* this line can have a breakpoint - store the cop in IV */
4435 AV *av = CopFILEAVx(PL_curcop);
4437 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4438 if (svp && *svp != &PL_sv_undef ) {
4439 (void)SvIOK_on(*svp);
4440 SvIV_set(*svp, PTR2IV(cop));
4445 if (flags & OPf_SPECIAL)
4447 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4452 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4456 PERL_ARGS_ASSERT_NEWLOGOP;
4458 return new_logop(type, flags, &first, &other);
4462 S_search_const(pTHX_ OP *o)
4464 PERL_ARGS_ASSERT_SEARCH_CONST;
4466 switch (o->op_type) {
4470 if (o->op_flags & OPf_KIDS)
4471 return search_const(cUNOPo->op_first);
4478 if (!(o->op_flags & OPf_KIDS))
4480 kid = cLISTOPo->op_first;
4482 switch (kid->op_type) {
4486 kid = kid->op_sibling;
4489 if (kid != cLISTOPo->op_last)
4495 kid = cLISTOPo->op_last;
4497 return search_const(kid);
4505 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4513 int prepend_not = 0;
4515 PERL_ARGS_ASSERT_NEW_LOGOP;
4520 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4521 return newBINOP(type, flags, scalar(first), scalar(other));
4523 scalarboolean(first);
4524 /* optimize AND and OR ops that have NOTs as children */
4525 if (first->op_type == OP_NOT
4526 && (first->op_flags & OPf_KIDS)
4527 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4528 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4530 if (type == OP_AND || type == OP_OR) {
4536 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4538 prepend_not = 1; /* prepend a NOT op later */
4542 /* search for a constant op that could let us fold the test */
4543 if ((cstop = search_const(first))) {
4544 if (cstop->op_private & OPpCONST_STRICT)
4545 no_bareword_allowed(cstop);
4546 else if ((cstop->op_private & OPpCONST_BARE))
4547 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4548 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4549 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4550 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4552 if (other->op_type == OP_CONST)
4553 other->op_private |= OPpCONST_SHORTCIRCUIT;
4555 OP *newop = newUNOP(OP_NULL, 0, other);
4556 op_getmad(first, newop, '1');
4557 newop->op_targ = type; /* set "was" field */
4561 if (other->op_type == OP_LEAVE)
4562 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4566 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4567 const OP *o2 = other;
4568 if ( ! (o2->op_type == OP_LIST
4569 && (( o2 = cUNOPx(o2)->op_first))
4570 && o2->op_type == OP_PUSHMARK
4571 && (( o2 = o2->op_sibling)) )
4574 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4575 || o2->op_type == OP_PADHV)
4576 && o2->op_private & OPpLVAL_INTRO
4577 && !(o2->op_private & OPpPAD_STATE))
4579 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4580 "Deprecated use of my() in false conditional");
4584 if (first->op_type == OP_CONST)
4585 first->op_private |= OPpCONST_SHORTCIRCUIT;
4587 first = newUNOP(OP_NULL, 0, first);
4588 op_getmad(other, first, '2');
4589 first->op_targ = type; /* set "was" field */
4596 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4597 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4599 const OP * const k1 = ((UNOP*)first)->op_first;
4600 const OP * const k2 = k1->op_sibling;
4602 switch (first->op_type)
4605 if (k2 && k2->op_type == OP_READLINE
4606 && (k2->op_flags & OPf_STACKED)
4607 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4609 warnop = k2->op_type;
4614 if (k1->op_type == OP_READDIR
4615 || k1->op_type == OP_GLOB
4616 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4617 || k1->op_type == OP_EACH)
4619 warnop = ((k1->op_type == OP_NULL)
4620 ? (OPCODE)k1->op_targ : k1->op_type);
4625 const line_t oldline = CopLINE(PL_curcop);
4626 CopLINE_set(PL_curcop, PL_parser->copline);
4627 Perl_warner(aTHX_ packWARN(WARN_MISC),
4628 "Value of %s%s can be \"0\"; test with defined()",
4630 ((warnop == OP_READLINE || warnop == OP_GLOB)
4631 ? " construct" : "() operator"));
4632 CopLINE_set(PL_curcop, oldline);
4639 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4640 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4642 NewOp(1101, logop, 1, LOGOP);
4644 logop->op_type = (OPCODE)type;
4645 logop->op_ppaddr = PL_ppaddr[type];
4646 logop->op_first = first;
4647 logop->op_flags = (U8)(flags | OPf_KIDS);
4648 logop->op_other = LINKLIST(other);
4649 logop->op_private = (U8)(1 | (flags >> 8));
4651 /* establish postfix order */
4652 logop->op_next = LINKLIST(first);
4653 first->op_next = (OP*)logop;
4654 first->op_sibling = other;
4656 CHECKOP(type,logop);
4658 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4665 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4673 PERL_ARGS_ASSERT_NEWCONDOP;
4676 return newLOGOP(OP_AND, 0, first, trueop);
4678 return newLOGOP(OP_OR, 0, first, falseop);
4680 scalarboolean(first);
4681 if ((cstop = search_const(first))) {
4682 /* Left or right arm of the conditional? */
4683 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4684 OP *live = left ? trueop : falseop;
4685 OP *const dead = left ? falseop : trueop;
4686 if (cstop->op_private & OPpCONST_BARE &&
4687 cstop->op_private & OPpCONST_STRICT) {
4688 no_bareword_allowed(cstop);
4691 /* This is all dead code when PERL_MAD is not defined. */
4692 live = newUNOP(OP_NULL, 0, live);
4693 op_getmad(first, live, 'C');
4694 op_getmad(dead, live, left ? 'e' : 't');
4699 if (live->op_type == OP_LEAVE)
4700 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4703 NewOp(1101, logop, 1, LOGOP);
4704 logop->op_type = OP_COND_EXPR;
4705 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4706 logop->op_first = first;
4707 logop->op_flags = (U8)(flags | OPf_KIDS);
4708 logop->op_private = (U8)(1 | (flags >> 8));
4709 logop->op_other = LINKLIST(trueop);
4710 logop->op_next = LINKLIST(falseop);
4712 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4715 /* establish postfix order */
4716 start = LINKLIST(first);
4717 first->op_next = (OP*)logop;
4719 first->op_sibling = trueop;
4720 trueop->op_sibling = falseop;
4721 o = newUNOP(OP_NULL, 0, (OP*)logop);
4723 trueop->op_next = falseop->op_next = o;
4730 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4739 PERL_ARGS_ASSERT_NEWRANGE;
4741 NewOp(1101, range, 1, LOGOP);
4743 range->op_type = OP_RANGE;
4744 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4745 range->op_first = left;
4746 range->op_flags = OPf_KIDS;
4747 leftstart = LINKLIST(left);
4748 range->op_other = LINKLIST(right);
4749 range->op_private = (U8)(1 | (flags >> 8));
4751 left->op_sibling = right;
4753 range->op_next = (OP*)range;
4754 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4755 flop = newUNOP(OP_FLOP, 0, flip);
4756 o = newUNOP(OP_NULL, 0, flop);
4758 range->op_next = leftstart;
4760 left->op_next = flip;
4761 right->op_next = flop;
4763 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4764 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4765 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4766 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4768 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4769 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4772 if (!flip->op_private || !flop->op_private)
4773 linklist(o); /* blow off optimizer unless constant */
4779 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4784 const bool once = block && block->op_flags & OPf_SPECIAL &&
4785 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4787 PERL_UNUSED_ARG(debuggable);
4790 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4791 return block; /* do {} while 0 does once */
4792 if (expr->op_type == OP_READLINE
4793 || expr->op_type == OP_READDIR
4794 || expr->op_type == OP_GLOB
4795 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4796 expr = newUNOP(OP_DEFINED, 0,
4797 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4798 } else if (expr->op_flags & OPf_KIDS) {
4799 const OP * const k1 = ((UNOP*)expr)->op_first;
4800 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4801 switch (expr->op_type) {
4803 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4804 && (k2->op_flags & OPf_STACKED)
4805 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4806 expr = newUNOP(OP_DEFINED, 0, expr);
4810 if (k1 && (k1->op_type == OP_READDIR
4811 || k1->op_type == OP_GLOB
4812 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4813 || k1->op_type == OP_EACH))
4814 expr = newUNOP(OP_DEFINED, 0, expr);
4820 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4821 * op, in listop. This is wrong. [perl #27024] */
4823 block = newOP(OP_NULL, 0);
4824 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4825 o = new_logop(OP_AND, 0, &expr, &listop);
4828 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4830 if (once && o != listop)
4831 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4834 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4836 o->op_flags |= flags;
4838 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4843 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4844 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4853 PERL_UNUSED_ARG(debuggable);
4856 if (expr->op_type == OP_READLINE
4857 || expr->op_type == OP_READDIR
4858 || expr->op_type == OP_GLOB
4859 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4860 expr = newUNOP(OP_DEFINED, 0,
4861 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4862 } else if (expr->op_flags & OPf_KIDS) {
4863 const OP * const k1 = ((UNOP*)expr)->op_first;
4864 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4865 switch (expr->op_type) {
4867 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4868 && (k2->op_flags & OPf_STACKED)
4869 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4870 expr = newUNOP(OP_DEFINED, 0, expr);
4874 if (k1 && (k1->op_type == OP_READDIR
4875 || k1->op_type == OP_GLOB
4876 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4877 || k1->op_type == OP_EACH))
4878 expr = newUNOP(OP_DEFINED, 0, expr);
4885 block = newOP(OP_NULL, 0);
4886 else if (cont || has_my) {
4887 block = scope(block);
4891 next = LINKLIST(cont);
4894 OP * const unstack = newOP(OP_UNSTACK, 0);
4897 cont = append_elem(OP_LINESEQ, cont, unstack);
4901 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4903 redo = LINKLIST(listop);
4906 PL_parser->copline = (line_t)whileline;
4908 o = new_logop(OP_AND, 0, &expr, &listop);
4909 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4910 op_free(expr); /* oops, it's a while (0) */
4912 return NULL; /* listop already freed by new_logop */
4915 ((LISTOP*)listop)->op_last->op_next =
4916 (o == listop ? redo : LINKLIST(o));
4922 NewOp(1101,loop,1,LOOP);
4923 loop->op_type = OP_ENTERLOOP;
4924 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4925 loop->op_private = 0;
4926 loop->op_next = (OP*)loop;
4929 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4931 loop->op_redoop = redo;
4932 loop->op_lastop = o;
4933 o->op_private |= loopflags;
4936 loop->op_nextop = next;
4938 loop->op_nextop = o;
4940 o->op_flags |= flags;
4941 o->op_private |= (flags >> 8);
4946 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4951 PADOFFSET padoff = 0;
4956 PERL_ARGS_ASSERT_NEWFOROP;
4959 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4960 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4961 sv->op_type = OP_RV2GV;
4962 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4964 /* The op_type check is needed to prevent a possible segfault
4965 * if the loop variable is undeclared and 'strict vars' is in
4966 * effect. This is illegal but is nonetheless parsed, so we
4967 * may reach this point with an OP_CONST where we're expecting
4970 if (cUNOPx(sv)->op_first->op_type == OP_GV
4971 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4972 iterpflags |= OPpITER_DEF;
4974 else if (sv->op_type == OP_PADSV) { /* private variable */
4975 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4976 padoff = sv->op_targ;
4986 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4988 SV *const namesv = PAD_COMPNAME_SV(padoff);
4990 const char *const name = SvPV_const(namesv, len);
4992 if (len == 2 && name[0] == '$' && name[1] == '_')
4993 iterpflags |= OPpITER_DEF;
4997 const PADOFFSET offset = pad_findmy("$_");
4998 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4999 sv = newGVOP(OP_GV, 0, PL_defgv);
5004 iterpflags |= OPpITER_DEF;
5006 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5007 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5008 iterflags |= OPf_STACKED;
5010 else if (expr->op_type == OP_NULL &&
5011 (expr->op_flags & OPf_KIDS) &&
5012 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5014 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5015 * set the STACKED flag to indicate that these values are to be
5016 * treated as min/max values by 'pp_iterinit'.
5018 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5019 LOGOP* const range = (LOGOP*) flip->op_first;
5020 OP* const left = range->op_first;
5021 OP* const right = left->op_sibling;
5024 range->op_flags &= ~OPf_KIDS;
5025 range->op_first = NULL;
5027 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5028 listop->op_first->op_next = range->op_next;
5029 left->op_next = range->op_other;
5030 right->op_next = (OP*)listop;
5031 listop->op_next = listop->op_first;
5034 op_getmad(expr,(OP*)listop,'O');
5038 expr = (OP*)(listop);
5040 iterflags |= OPf_STACKED;
5043 expr = mod(force_list(expr), OP_GREPSTART);
5046 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5047 append_elem(OP_LIST, expr, scalar(sv))));
5048 assert(!loop->op_next);
5049 /* for my $x () sets OPpLVAL_INTRO;
5050 * for our $x () sets OPpOUR_INTRO */
5051 loop->op_private = (U8)iterpflags;
5052 #ifdef PL_OP_SLAB_ALLOC
5055 NewOp(1234,tmp,1,LOOP);
5056 Copy(loop,tmp,1,LISTOP);
5057 S_op_destroy(aTHX_ (OP*)loop);
5061 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5063 loop->op_targ = padoff;
5064 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5066 op_getmad(madsv, (OP*)loop, 'v');
5067 PL_parser->copline = forline;
5068 return newSTATEOP(0, label, wop);
5072 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5077 PERL_ARGS_ASSERT_NEWLOOPEX;
5079 if (type != OP_GOTO || label->op_type == OP_CONST) {
5080 /* "last()" means "last" */
5081 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5082 o = newOP(type, OPf_SPECIAL);
5084 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5085 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5089 op_getmad(label,o,'L');
5095 /* Check whether it's going to be a goto &function */
5096 if (label->op_type == OP_ENTERSUB
5097 && !(label->op_flags & OPf_STACKED))
5098 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5099 o = newUNOP(type, OPf_STACKED, label);
5101 PL_hints |= HINT_BLOCK_SCOPE;
5105 /* if the condition is a literal array or hash
5106 (or @{ ... } etc), make a reference to it.
5109 S_ref_array_or_hash(pTHX_ OP *cond)
5112 && (cond->op_type == OP_RV2AV
5113 || cond->op_type == OP_PADAV
5114 || cond->op_type == OP_RV2HV
5115 || cond->op_type == OP_PADHV))
5117 return newUNOP(OP_REFGEN,
5118 0, mod(cond, OP_REFGEN));
5124 /* These construct the optree fragments representing given()
5127 entergiven and enterwhen are LOGOPs; the op_other pointer
5128 points up to the associated leave op. We need this so we
5129 can put it in the context and make break/continue work.
5130 (Also, of course, pp_enterwhen will jump straight to
5131 op_other if the match fails.)
5135 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5136 I32 enter_opcode, I32 leave_opcode,
5137 PADOFFSET entertarg)
5143 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5145 NewOp(1101, enterop, 1, LOGOP);
5146 enterop->op_type = (Optype)enter_opcode;
5147 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5148 enterop->op_flags = (U8) OPf_KIDS;
5149 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5150 enterop->op_private = 0;
5152 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5155 enterop->op_first = scalar(cond);
5156 cond->op_sibling = block;
5158 o->op_next = LINKLIST(cond);
5159 cond->op_next = (OP *) enterop;
5162 /* This is a default {} block */
5163 enterop->op_first = block;
5164 enterop->op_flags |= OPf_SPECIAL;
5166 o->op_next = (OP *) enterop;
5169 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5170 entergiven and enterwhen both
5173 enterop->op_next = LINKLIST(block);
5174 block->op_next = enterop->op_other = o;
5179 /* Does this look like a boolean operation? For these purposes
5180 a boolean operation is:
5181 - a subroutine call [*]
5182 - a logical connective
5183 - a comparison operator
5184 - a filetest operator, with the exception of -s -M -A -C
5185 - defined(), exists() or eof()
5186 - /$re/ or $foo =~ /$re/
5188 [*] possibly surprising
5191 S_looks_like_bool(pTHX_ const OP *o)
5195 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5197 switch(o->op_type) {
5200 return looks_like_bool(cLOGOPo->op_first);
5204 looks_like_bool(cLOGOPo->op_first)
5205 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5209 o->op_flags & OPf_KIDS
5210 && looks_like_bool(cUNOPo->op_first));
5213 return looks_like_bool(cUNOPo->op_first);
5218 case OP_NOT: case OP_XOR:
5220 case OP_EQ: case OP_NE: case OP_LT:
5221 case OP_GT: case OP_LE: case OP_GE:
5223 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5224 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5226 case OP_SEQ: case OP_SNE: case OP_SLT:
5227 case OP_SGT: case OP_SLE: case OP_SGE:
5231 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5232 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5233 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5234 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5235 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5236 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5237 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5238 case OP_FTTEXT: case OP_FTBINARY:
5240 case OP_DEFINED: case OP_EXISTS:
5241 case OP_MATCH: case OP_EOF:
5248 /* Detect comparisons that have been optimized away */
5249 if (cSVOPo->op_sv == &PL_sv_yes
5250 || cSVOPo->op_sv == &PL_sv_no)
5263 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5266 PERL_ARGS_ASSERT_NEWGIVENOP;
5267 return newGIVWHENOP(
5268 ref_array_or_hash(cond),
5270 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5274 /* If cond is null, this is a default {} block */
5276 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5278 const bool cond_llb = (!cond || looks_like_bool(cond));
5281 PERL_ARGS_ASSERT_NEWWHENOP;
5286 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5288 scalar(ref_array_or_hash(cond)));
5291 return newGIVWHENOP(
5293 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5294 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5298 =for apidoc cv_undef
5300 Clear out all the active components of a CV. This can happen either
5301 by an explicit C<undef &foo>, or by the reference count going to zero.
5302 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5303 children can still follow the full lexical scope chain.
5309 Perl_cv_undef(pTHX_ CV *cv)
5313 PERL_ARGS_ASSERT_CV_UNDEF;
5315 DEBUG_X(PerlIO_printf(Perl_debug_log,
5316 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5317 PTR2UV(cv), PTR2UV(PL_comppad))
5321 if (CvFILE(cv) && !CvISXSUB(cv)) {
5322 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5323 Safefree(CvFILE(cv));
5328 if (!CvISXSUB(cv) && CvROOT(cv)) {
5329 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5330 Perl_croak(aTHX_ "Can't undef active subroutine");
5333 PAD_SAVE_SETNULLPAD();
5335 op_free(CvROOT(cv));
5340 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5345 /* remove CvOUTSIDE unless this is an undef rather than a free */
5346 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5347 if (!CvWEAKOUTSIDE(cv))
5348 SvREFCNT_dec(CvOUTSIDE(cv));
5349 CvOUTSIDE(cv) = NULL;
5352 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5355 if (CvISXSUB(cv) && CvXSUB(cv)) {
5358 /* delete all flags except WEAKOUTSIDE */
5359 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5363 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5366 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5368 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5369 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5370 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5371 || (p && (len != SvCUR(cv) /* Not the same length. */
5372 || memNE(p, SvPVX_const(cv), len))))
5373 && ckWARN_d(WARN_PROTOTYPE)) {
5374 SV* const msg = sv_newmortal();
5378 gv_efullname3(name = sv_newmortal(), gv, NULL);
5379 sv_setpvs(msg, "Prototype mismatch:");
5381 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5383 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5385 sv_catpvs(msg, ": none");
5386 sv_catpvs(msg, " vs ");
5388 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5390 sv_catpvs(msg, "none");
5391 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5395 static void const_sv_xsub(pTHX_ CV* cv);
5399 =head1 Optree Manipulation Functions
5401 =for apidoc cv_const_sv
5403 If C<cv> is a constant sub eligible for inlining. returns the constant
5404 value returned by the sub. Otherwise, returns NULL.
5406 Constant subs can be created with C<newCONSTSUB> or as described in
5407 L<perlsub/"Constant Functions">.
5412 Perl_cv_const_sv(pTHX_ const CV *const cv)
5414 PERL_UNUSED_CONTEXT;
5417 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5419 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5422 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5423 * Can be called in 3 ways:
5426 * look for a single OP_CONST with attached value: return the value
5428 * cv && CvCLONE(cv) && !CvCONST(cv)
5430 * examine the clone prototype, and if contains only a single
5431 * OP_CONST referencing a pad const, or a single PADSV referencing
5432 * an outer lexical, return a non-zero value to indicate the CV is
5433 * a candidate for "constizing" at clone time
5437 * We have just cloned an anon prototype that was marked as a const
5438 * candidiate. Try to grab the current value, and in the case of
5439 * PADSV, ignore it if it has multiple references. Return the value.
5443 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5454 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5455 o = cLISTOPo->op_first->op_sibling;
5457 for (; o; o = o->op_next) {
5458 const OPCODE type = o->op_type;
5460 if (sv && o->op_next == o)
5462 if (o->op_next != o) {
5463 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5465 if (type == OP_DBSTATE)
5468 if (type == OP_LEAVESUB || type == OP_RETURN)
5472 if (type == OP_CONST && cSVOPo->op_sv)
5474 else if (cv && type == OP_CONST) {
5475 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5479 else if (cv && type == OP_PADSV) {
5480 if (CvCONST(cv)) { /* newly cloned anon */
5481 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5482 /* the candidate should have 1 ref from this pad and 1 ref
5483 * from the parent */
5484 if (!sv || SvREFCNT(sv) != 2)
5491 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5492 sv = &PL_sv_undef; /* an arbitrary non-null value */
5507 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5510 /* This would be the return value, but the return cannot be reached. */
5511 OP* pegop = newOP(OP_NULL, 0);
5514 PERL_UNUSED_ARG(floor);
5524 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5526 NORETURN_FUNCTION_END;
5531 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5533 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5537 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5543 register CV *cv = NULL;
5545 /* If the subroutine has no body, no attributes, and no builtin attributes
5546 then it's just a sub declaration, and we may be able to get away with
5547 storing with a placeholder scalar in the symbol table, rather than a
5548 full GV and CV. If anything is present then it will take a full CV to
5550 const I32 gv_fetch_flags
5551 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5553 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5554 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5558 assert(proto->op_type == OP_CONST);
5559 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5565 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5567 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5568 SV * const sv = sv_newmortal();
5569 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5570 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5571 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5572 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5574 } else if (PL_curstash) {
5575 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5578 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5582 if (!PL_madskills) {
5591 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5592 maximum a prototype before. */
5593 if (SvTYPE(gv) > SVt_NULL) {
5594 if (!SvPOK((const SV *)gv)
5595 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5597 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5599 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5602 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5604 sv_setiv(MUTABLE_SV(gv), -1);
5606 SvREFCNT_dec(PL_compcv);
5607 cv = PL_compcv = NULL;
5611 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5613 if (!block || !ps || *ps || attrs
5614 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5616 || block->op_type == OP_NULL
5621 const_sv = op_const_sv(block, NULL);
5624 const bool exists = CvROOT(cv) || CvXSUB(cv);
5626 /* if the subroutine doesn't exist and wasn't pre-declared
5627 * with a prototype, assume it will be AUTOLOADed,
5628 * skipping the prototype check
5630 if (exists || SvPOK(cv))
5631 cv_ckproto_len(cv, gv, ps, ps_len);
5632 /* already defined (or promised)? */
5633 if (exists || GvASSUMECV(gv)) {
5636 || block->op_type == OP_NULL
5639 if (CvFLAGS(PL_compcv)) {
5640 /* might have had built-in attrs applied */
5641 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5643 /* just a "sub foo;" when &foo is already defined */
5644 SAVEFREESV(PL_compcv);
5649 && block->op_type != OP_NULL
5652 if (ckWARN(WARN_REDEFINE)
5654 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5656 const line_t oldline = CopLINE(PL_curcop);
5657 if (PL_parser && PL_parser->copline != NOLINE)
5658 CopLINE_set(PL_curcop, PL_parser->copline);
5659 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5660 CvCONST(cv) ? "Constant subroutine %s redefined"
5661 : "Subroutine %s redefined", name);
5662 CopLINE_set(PL_curcop, oldline);
5665 if (!PL_minus_c) /* keep old one around for madskills */
5668 /* (PL_madskills unset in used file.) */
5676 SvREFCNT_inc_simple_void_NN(const_sv);
5678 assert(!CvROOT(cv) && !CvCONST(cv));
5679 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5680 CvXSUBANY(cv).any_ptr = const_sv;
5681 CvXSUB(cv) = const_sv_xsub;
5687 cv = newCONSTSUB(NULL, name, const_sv);
5689 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5690 (CvGV(cv) && GvSTASH(CvGV(cv)))
5699 SvREFCNT_dec(PL_compcv);
5703 if (cv) { /* must reuse cv if autoloaded */
5704 /* transfer PL_compcv to cv */
5707 && block->op_type != OP_NULL
5711 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5712 if (!CvWEAKOUTSIDE(cv))
5713 SvREFCNT_dec(CvOUTSIDE(cv));
5714 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5715 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5716 CvOUTSIDE(PL_compcv) = 0;
5717 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5718 CvPADLIST(PL_compcv) = 0;
5719 /* inner references to PL_compcv must be fixed up ... */
5720 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5721 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5722 ++PL_sub_generation;
5725 /* Might have had built-in attributes applied -- propagate them. */
5726 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5728 /* ... before we throw it away */
5729 SvREFCNT_dec(PL_compcv);
5737 if (strEQ(name, "import")) {
5738 PL_formfeed = MUTABLE_SV(cv);
5739 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5743 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5748 CvFILE_set_from_cop(cv, PL_curcop);
5749 CvSTASH(cv) = PL_curstash;
5752 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5753 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5754 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5758 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5760 if (PL_parser && PL_parser->error_count) {
5764 const char *s = strrchr(name, ':');
5766 if (strEQ(s, "BEGIN")) {
5767 const char not_safe[] =
5768 "BEGIN not safe after errors--compilation aborted";
5769 if (PL_in_eval & EVAL_KEEPERR)
5770 Perl_croak(aTHX_ not_safe);
5772 /* force display of errors found but not reported */
5773 sv_catpv(ERRSV, not_safe);
5774 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5783 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5784 the debugger could be able to set a breakpoint in, so signal to
5785 pp_entereval that it should not throw away any saved lines at scope
5788 PL_breakable_sub_gen++;
5790 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5791 mod(scalarseq(block), OP_LEAVESUBLV));
5792 block->op_attached = 1;
5795 /* This makes sub {}; work as expected. */
5796 if (block->op_type == OP_STUB) {
5797 OP* const newblock = newSTATEOP(0, NULL, 0);
5799 op_getmad(block,newblock,'B');
5806 block->op_attached = 1;
5807 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5809 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5810 OpREFCNT_set(CvROOT(cv), 1);
5811 CvSTART(cv) = LINKLIST(CvROOT(cv));
5812 CvROOT(cv)->op_next = 0;
5813 CALL_PEEP(CvSTART(cv));
5815 /* now that optimizer has done its work, adjust pad values */
5817 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5820 assert(!CvCONST(cv));
5821 if (ps && !*ps && op_const_sv(block, cv))
5826 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5827 SV * const sv = newSV(0);
5828 SV * const tmpstr = sv_newmortal();
5829 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5830 GV_ADDMULTI, SVt_PVHV);
5833 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5835 (long)PL_subline, (long)CopLINE(PL_curcop));
5836 gv_efullname3(tmpstr, gv, NULL);
5837 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5838 SvCUR(tmpstr), sv, 0);
5839 hv = GvHVn(db_postponed);
5840 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5841 CV * const pcv = GvCV(db_postponed);
5847 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5852 if (name && ! (PL_parser && PL_parser->error_count))
5853 process_special_blocks(name, gv, cv);
5858 PL_parser->copline = NOLINE;
5864 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5867 const char *const colon = strrchr(fullname,':');
5868 const char *const name = colon ? colon + 1 : fullname;
5870 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5873 if (strEQ(name, "BEGIN")) {
5874 const I32 oldscope = PL_scopestack_ix;
5876 SAVECOPFILE(&PL_compiling);
5877 SAVECOPLINE(&PL_compiling);
5879 DEBUG_x( dump_sub(gv) );
5880 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5881 GvCV(gv) = 0; /* cv has been hijacked */
5882 call_list(oldscope, PL_beginav);
5884 PL_curcop = &PL_compiling;
5885 CopHINTS_set(&PL_compiling, PL_hints);
5892 if strEQ(name, "END") {
5893 DEBUG_x( dump_sub(gv) );
5894 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5897 } else if (*name == 'U') {
5898 if (strEQ(name, "UNITCHECK")) {
5899 /* It's never too late to run a unitcheck block */
5900 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5904 } else if (*name == 'C') {
5905 if (strEQ(name, "CHECK")) {
5907 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5908 "Too late to run CHECK block");
5909 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5913 } else if (*name == 'I') {
5914 if (strEQ(name, "INIT")) {
5916 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5917 "Too late to run INIT block");
5918 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5924 DEBUG_x( dump_sub(gv) );
5925 GvCV(gv) = 0; /* cv has been hijacked */
5930 =for apidoc newCONSTSUB
5932 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5933 eligible for inlining at compile-time.
5935 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5936 which won't be called if used as a destructor, but will suppress the overhead
5937 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5944 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5949 const char *const file = CopFILE(PL_curcop);
5951 SV *const temp_sv = CopFILESV(PL_curcop);
5952 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5957 if (IN_PERL_RUNTIME) {
5958 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5959 * an op shared between threads. Use a non-shared COP for our
5961 SAVEVPTR(PL_curcop);
5962 PL_curcop = &PL_compiling;
5964 SAVECOPLINE(PL_curcop);
5965 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5968 PL_hints &= ~HINT_BLOCK_SCOPE;
5971 SAVESPTR(PL_curstash);
5972 SAVECOPSTASH(PL_curcop);
5973 PL_curstash = stash;
5974 CopSTASH_set(PL_curcop,stash);
5977 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5978 and so doesn't get free()d. (It's expected to be from the C pre-
5979 processor __FILE__ directive). But we need a dynamically allocated one,
5980 and we need it to get freed. */
5981 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
5982 XS_DYNAMIC_FILENAME);
5983 CvXSUBANY(cv).any_ptr = sv;
5988 CopSTASH_free(PL_curcop);
5996 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5997 const char *const filename, const char *const proto,
6000 CV *cv = newXS(name, subaddr, filename);
6002 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6004 if (flags & XS_DYNAMIC_FILENAME) {
6005 /* We need to "make arrangements" (ie cheat) to ensure that the
6006 filename lasts as long as the PVCV we just created, but also doesn't
6008 STRLEN filename_len = strlen(filename);
6009 STRLEN proto_and_file_len = filename_len;
6010 char *proto_and_file;
6014 proto_len = strlen(proto);
6015 proto_and_file_len += proto_len;
6017 Newx(proto_and_file, proto_and_file_len + 1, char);
6018 Copy(proto, proto_and_file, proto_len, char);
6019 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6022 proto_and_file = savepvn(filename, filename_len);
6025 /* This gets free()d. :-) */
6026 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6027 SV_HAS_TRAILING_NUL);
6029 /* This gives us the correct prototype, rather than one with the
6030 file name appended. */
6031 SvCUR_set(cv, proto_len);
6035 CvFILE(cv) = proto_and_file + proto_len;
6037 sv_setpv(MUTABLE_SV(cv), proto);
6043 =for apidoc U||newXS
6045 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6046 static storage, as it is used directly as CvFILE(), without a copy being made.
6052 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6055 GV * const gv = gv_fetchpv(name ? name :
6056 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6057 GV_ADDMULTI, SVt_PVCV);
6060 PERL_ARGS_ASSERT_NEWXS;
6063 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6065 if ((cv = (name ? GvCV(gv) : NULL))) {
6067 /* just a cached method */
6071 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6072 /* already defined (or promised) */
6073 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6074 if (ckWARN(WARN_REDEFINE)) {
6075 GV * const gvcv = CvGV(cv);
6077 HV * const stash = GvSTASH(gvcv);
6079 const char *redefined_name = HvNAME_get(stash);
6080 if ( strEQ(redefined_name,"autouse") ) {
6081 const line_t oldline = CopLINE(PL_curcop);
6082 if (PL_parser && PL_parser->copline != NOLINE)
6083 CopLINE_set(PL_curcop, PL_parser->copline);
6084 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6085 CvCONST(cv) ? "Constant subroutine %s redefined"
6086 : "Subroutine %s redefined"
6088 CopLINE_set(PL_curcop, oldline);
6098 if (cv) /* must reuse cv if autoloaded */
6101 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6105 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6109 (void)gv_fetchfile(filename);
6110 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6111 an external constant string */
6113 CvXSUB(cv) = subaddr;
6116 process_special_blocks(name, gv, cv);
6128 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6133 OP* pegop = newOP(OP_NULL, 0);
6137 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6138 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6141 if ((cv = GvFORM(gv))) {
6142 if (ckWARN(WARN_REDEFINE)) {
6143 const line_t oldline = CopLINE(PL_curcop);
6144 if (PL_parser && PL_parser->copline != NOLINE)
6145 CopLINE_set(PL_curcop, PL_parser->copline);
6147 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6148 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6150 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6151 "Format STDOUT redefined");
6153 CopLINE_set(PL_curcop, oldline);
6160 CvFILE_set_from_cop(cv, PL_curcop);
6163 pad_tidy(padtidy_FORMAT);
6164 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6165 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6166 OpREFCNT_set(CvROOT(cv), 1);
6167 CvSTART(cv) = LINKLIST(CvROOT(cv));
6168 CvROOT(cv)->op_next = 0;
6169 CALL_PEEP(CvSTART(cv));
6171 op_getmad(o,pegop,'n');
6172 op_getmad_weak(block, pegop, 'b');
6177 PL_parser->copline = NOLINE;
6185 Perl_newANONLIST(pTHX_ OP *o)
6187 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6191 Perl_newANONHASH(pTHX_ OP *o)
6193 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6197 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6199 return newANONATTRSUB(floor, proto, NULL, block);
6203 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6205 return newUNOP(OP_REFGEN, 0,
6206 newSVOP(OP_ANONCODE, 0,
6207 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6211 Perl_oopsAV(pTHX_ OP *o)
6215 PERL_ARGS_ASSERT_OOPSAV;
6217 switch (o->op_type) {
6219 o->op_type = OP_PADAV;
6220 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6221 return ref(o, OP_RV2AV);
6224 o->op_type = OP_RV2AV;
6225 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6230 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6237 Perl_oopsHV(pTHX_ OP *o)
6241 PERL_ARGS_ASSERT_OOPSHV;
6243 switch (o->op_type) {
6246 o->op_type = OP_PADHV;
6247 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6248 return ref(o, OP_RV2HV);
6252 o->op_type = OP_RV2HV;
6253 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6258 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6265 Perl_newAVREF(pTHX_ OP *o)
6269 PERL_ARGS_ASSERT_NEWAVREF;
6271 if (o->op_type == OP_PADANY) {
6272 o->op_type = OP_PADAV;
6273 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6276 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6277 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6278 "Using an array as a reference is deprecated");
6280 return newUNOP(OP_RV2AV, 0, scalar(o));
6284 Perl_newGVREF(pTHX_ I32 type, OP *o)
6286 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6287 return newUNOP(OP_NULL, 0, o);
6288 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6292 Perl_newHVREF(pTHX_ OP *o)
6296 PERL_ARGS_ASSERT_NEWHVREF;
6298 if (o->op_type == OP_PADANY) {
6299 o->op_type = OP_PADHV;
6300 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6303 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6304 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6305 "Using a hash as a reference is deprecated");
6307 return newUNOP(OP_RV2HV, 0, scalar(o));
6311 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6313 return newUNOP(OP_RV2CV, flags, scalar(o));
6317 Perl_newSVREF(pTHX_ OP *o)
6321 PERL_ARGS_ASSERT_NEWSVREF;
6323 if (o->op_type == OP_PADANY) {
6324 o->op_type = OP_PADSV;
6325 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6328 return newUNOP(OP_RV2SV, 0, scalar(o));
6331 /* Check routines. See the comments at the top of this file for details
6332 * on when these are called */
6335 Perl_ck_anoncode(pTHX_ OP *o)
6337 PERL_ARGS_ASSERT_CK_ANONCODE;
6339 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6341 cSVOPo->op_sv = NULL;
6346 Perl_ck_bitop(pTHX_ OP *o)
6350 PERL_ARGS_ASSERT_CK_BITOP;
6352 #define OP_IS_NUMCOMPARE(op) \
6353 ((op) == OP_LT || (op) == OP_I_LT || \
6354 (op) == OP_GT || (op) == OP_I_GT || \
6355 (op) == OP_LE || (op) == OP_I_LE || \
6356 (op) == OP_GE || (op) == OP_I_GE || \
6357 (op) == OP_EQ || (op) == OP_I_EQ || \
6358 (op) == OP_NE || (op) == OP_I_NE || \
6359 (op) == OP_NCMP || (op) == OP_I_NCMP)
6360 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6361 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6362 && (o->op_type == OP_BIT_OR
6363 || o->op_type == OP_BIT_AND
6364 || o->op_type == OP_BIT_XOR))
6366 const OP * const left = cBINOPo->op_first;
6367 const OP * const right = left->op_sibling;
6368 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6369 (left->op_flags & OPf_PARENS) == 0) ||
6370 (OP_IS_NUMCOMPARE(right->op_type) &&
6371 (right->op_flags & OPf_PARENS) == 0))
6372 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6373 "Possible precedence problem on bitwise %c operator",
6374 o->op_type == OP_BIT_OR ? '|'
6375 : o->op_type == OP_BIT_AND ? '&' : '^'
6382 Perl_ck_concat(pTHX_ OP *o)
6384 const OP * const kid = cUNOPo->op_first;
6386 PERL_ARGS_ASSERT_CK_CONCAT;
6387 PERL_UNUSED_CONTEXT;
6389 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6390 !(kUNOP->op_first->op_flags & OPf_MOD))
6391 o->op_flags |= OPf_STACKED;
6396 Perl_ck_spair(pTHX_ OP *o)
6400 PERL_ARGS_ASSERT_CK_SPAIR;
6402 if (o->op_flags & OPf_KIDS) {
6405 const OPCODE type = o->op_type;
6406 o = modkids(ck_fun(o), type);
6407 kid = cUNOPo->op_first;
6408 newop = kUNOP->op_first->op_sibling;
6410 const OPCODE type = newop->op_type;
6411 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6412 type == OP_PADAV || type == OP_PADHV ||
6413 type == OP_RV2AV || type == OP_RV2HV)
6417 op_getmad(kUNOP->op_first,newop,'K');
6419 op_free(kUNOP->op_first);
6421 kUNOP->op_first = newop;
6423 o->op_ppaddr = PL_ppaddr[++o->op_type];
6428 Perl_ck_delete(pTHX_ OP *o)
6430 PERL_ARGS_ASSERT_CK_DELETE;
6434 if (o->op_flags & OPf_KIDS) {
6435 OP * const kid = cUNOPo->op_first;
6436 switch (kid->op_type) {
6438 o->op_flags |= OPf_SPECIAL;
6441 o->op_private |= OPpSLICE;
6444 o->op_flags |= OPf_SPECIAL;
6449 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6452 if (kid->op_private & OPpLVAL_INTRO)
6453 o->op_private |= OPpLVAL_INTRO;
6460 Perl_ck_die(pTHX_ OP *o)
6462 PERL_ARGS_ASSERT_CK_DIE;
6465 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6471 Perl_ck_eof(pTHX_ OP *o)
6475 PERL_ARGS_ASSERT_CK_EOF;
6477 if (o->op_flags & OPf_KIDS) {
6478 if (cLISTOPo->op_first->op_type == OP_STUB) {
6480 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6482 op_getmad(o,newop,'O');
6494 Perl_ck_eval(pTHX_ OP *o)
6498 PERL_ARGS_ASSERT_CK_EVAL;
6500 PL_hints |= HINT_BLOCK_SCOPE;
6501 if (o->op_flags & OPf_KIDS) {
6502 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6505 o->op_flags &= ~OPf_KIDS;
6508 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6514 cUNOPo->op_first = 0;
6519 NewOp(1101, enter, 1, LOGOP);
6520 enter->op_type = OP_ENTERTRY;
6521 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6522 enter->op_private = 0;
6524 /* establish postfix order */
6525 enter->op_next = (OP*)enter;
6527 CHECKOP(OP_ENTERTRY, enter);
6529 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6530 o->op_type = OP_LEAVETRY;
6531 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6532 enter->op_other = o;
6533 op_getmad(oldo,o,'O');
6547 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6548 op_getmad(oldo,o,'O');
6550 o->op_targ = (PADOFFSET)PL_hints;
6551 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6552 /* Store a copy of %^H that pp_entereval can pick up. */
6553 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6554 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6555 cUNOPo->op_first->op_sibling = hhop;
6556 o->op_private |= OPpEVAL_HAS_HH;
6562 Perl_ck_exit(pTHX_ OP *o)
6564 PERL_ARGS_ASSERT_CK_EXIT;
6567 HV * const table = GvHV(PL_hintgv);
6569 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6570 if (svp && *svp && SvTRUE(*svp))
6571 o->op_private |= OPpEXIT_VMSISH;
6573 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6579 Perl_ck_exec(pTHX_ OP *o)
6581 PERL_ARGS_ASSERT_CK_EXEC;
6583 if (o->op_flags & OPf_STACKED) {
6586 kid = cUNOPo->op_first->op_sibling;
6587 if (kid->op_type == OP_RV2GV)
6596 Perl_ck_exists(pTHX_ OP *o)
6600 PERL_ARGS_ASSERT_CK_EXISTS;
6603 if (o->op_flags & OPf_KIDS) {
6604 OP * const kid = cUNOPo->op_first;
6605 if (kid->op_type == OP_ENTERSUB) {
6606 (void) ref(kid, o->op_type);
6607 if (kid->op_type != OP_RV2CV
6608 && !(PL_parser && PL_parser->error_count))
6609 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6611 o->op_private |= OPpEXISTS_SUB;
6613 else if (kid->op_type == OP_AELEM)
6614 o->op_flags |= OPf_SPECIAL;
6615 else if (kid->op_type != OP_HELEM)
6616 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6624 Perl_ck_rvconst(pTHX_ register OP *o)
6627 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6629 PERL_ARGS_ASSERT_CK_RVCONST;
6631 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6632 if (o->op_type == OP_RV2CV)
6633 o->op_private &= ~1;
6635 if (kid->op_type == OP_CONST) {
6638 SV * const kidsv = kid->op_sv;
6640 /* Is it a constant from cv_const_sv()? */
6641 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6642 SV * const rsv = SvRV(kidsv);
6643 const svtype type = SvTYPE(rsv);
6644 const char *badtype = NULL;
6646 switch (o->op_type) {
6648 if (type > SVt_PVMG)
6649 badtype = "a SCALAR";
6652 if (type != SVt_PVAV)
6653 badtype = "an ARRAY";
6656 if (type != SVt_PVHV)
6660 if (type != SVt_PVCV)
6665 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6668 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6669 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6670 /* If this is an access to a stash, disable "strict refs", because
6671 * stashes aren't auto-vivified at compile-time (unless we store
6672 * symbols in them), and we don't want to produce a run-time
6673 * stricture error when auto-vivifying the stash. */
6674 const char *s = SvPV_nolen(kidsv);
6675 const STRLEN l = SvCUR(kidsv);
6676 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6677 o->op_private &= ~HINT_STRICT_REFS;
6679 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6680 const char *badthing;
6681 switch (o->op_type) {
6683 badthing = "a SCALAR";
6686 badthing = "an ARRAY";
6689 badthing = "a HASH";
6697 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6698 SVfARG(kidsv), badthing);
6701 * This is a little tricky. We only want to add the symbol if we
6702 * didn't add it in the lexer. Otherwise we get duplicate strict
6703 * warnings. But if we didn't add it in the lexer, we must at
6704 * least pretend like we wanted to add it even if it existed before,
6705 * or we get possible typo warnings. OPpCONST_ENTERED says
6706 * whether the lexer already added THIS instance of this symbol.
6708 iscv = (o->op_type == OP_RV2CV) * 2;
6710 gv = gv_fetchsv(kidsv,
6711 iscv | !(kid->op_private & OPpCONST_ENTERED),
6714 : o->op_type == OP_RV2SV
6716 : o->op_type == OP_RV2AV
6718 : o->op_type == OP_RV2HV
6721 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6723 kid->op_type = OP_GV;
6724 SvREFCNT_dec(kid->op_sv);
6726 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6727 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6728 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6730 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6732 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6734 kid->op_private = 0;
6735 kid->op_ppaddr = PL_ppaddr[OP_GV];
6742 Perl_ck_ftst(pTHX_ OP *o)
6745 const I32 type = o->op_type;
6747 PERL_ARGS_ASSERT_CK_FTST;
6749 if (o->op_flags & OPf_REF) {
6752 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6753 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6754 const OPCODE kidtype = kid->op_type;
6756 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6757 OP * const newop = newGVOP(type, OPf_REF,
6758 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6760 op_getmad(o,newop,'O');
6766 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6767 o->op_private |= OPpFT_ACCESS;
6768 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6769 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6770 o->op_private |= OPpFT_STACKED;
6778 if (type == OP_FTTTY)
6779 o = newGVOP(type, OPf_REF, PL_stdingv);
6781 o = newUNOP(type, 0, newDEFSVOP());
6782 op_getmad(oldo,o,'O');
6788 Perl_ck_fun(pTHX_ OP *o)
6791 const int type = o->op_type;
6792 register I32 oa = PL_opargs[type] >> OASHIFT;
6794 PERL_ARGS_ASSERT_CK_FUN;
6796 if (o->op_flags & OPf_STACKED) {
6797 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6800 return no_fh_allowed(o);
6803 if (o->op_flags & OPf_KIDS) {
6804 OP **tokid = &cLISTOPo->op_first;
6805 register OP *kid = cLISTOPo->op_first;
6809 if (kid->op_type == OP_PUSHMARK ||
6810 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6812 tokid = &kid->op_sibling;
6813 kid = kid->op_sibling;
6815 if (!kid && PL_opargs[type] & OA_DEFGV)
6816 *tokid = kid = newDEFSVOP();
6820 sibl = kid->op_sibling;
6822 if (!sibl && kid->op_type == OP_STUB) {
6829 /* list seen where single (scalar) arg expected? */
6830 if (numargs == 1 && !(oa >> 4)
6831 && kid->op_type == OP_LIST && type != OP_SCALAR)
6833 return too_many_arguments(o,PL_op_desc[type]);
6846 if ((type == OP_PUSH || type == OP_UNSHIFT)
6847 && !kid->op_sibling)
6848 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6849 "Useless use of %s with no values",
6852 if (kid->op_type == OP_CONST &&
6853 (kid->op_private & OPpCONST_BARE))
6855 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6856 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6857 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6858 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6859 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6861 op_getmad(kid,newop,'K');
6866 kid->op_sibling = sibl;
6869 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6870 bad_type(numargs, "array", PL_op_desc[type], kid);
6874 if (kid->op_type == OP_CONST &&
6875 (kid->op_private & OPpCONST_BARE))
6877 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6878 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6879 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6880 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6881 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6883 op_getmad(kid,newop,'K');
6888 kid->op_sibling = sibl;
6891 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6892 bad_type(numargs, "hash", PL_op_desc[type], kid);
6897 OP * const newop = newUNOP(OP_NULL, 0, kid);
6898 kid->op_sibling = 0;
6900 newop->op_next = newop;
6902 kid->op_sibling = sibl;
6907 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6908 if (kid->op_type == OP_CONST &&
6909 (kid->op_private & OPpCONST_BARE))
6911 OP * const newop = newGVOP(OP_GV, 0,
6912 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6913 if (!(o->op_private & 1) && /* if not unop */
6914 kid == cLISTOPo->op_last)
6915 cLISTOPo->op_last = newop;
6917 op_getmad(kid,newop,'K');
6923 else if (kid->op_type == OP_READLINE) {
6924 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6925 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6928 I32 flags = OPf_SPECIAL;
6932 /* is this op a FH constructor? */
6933 if (is_handle_constructor(o,numargs)) {
6934 const char *name = NULL;
6938 /* Set a flag to tell rv2gv to vivify
6939 * need to "prove" flag does not mean something
6940 * else already - NI-S 1999/05/07
6943 if (kid->op_type == OP_PADSV) {
6945 = PAD_COMPNAME_SV(kid->op_targ);
6946 name = SvPV_const(namesv, len);
6948 else if (kid->op_type == OP_RV2SV
6949 && kUNOP->op_first->op_type == OP_GV)
6951 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6953 len = GvNAMELEN(gv);
6955 else if (kid->op_type == OP_AELEM
6956 || kid->op_type == OP_HELEM)
6959 OP *op = ((BINOP*)kid)->op_first;
6963 const char * const a =
6964 kid->op_type == OP_AELEM ?
6966 if (((op->op_type == OP_RV2AV) ||
6967 (op->op_type == OP_RV2HV)) &&
6968 (firstop = ((UNOP*)op)->op_first) &&
6969 (firstop->op_type == OP_GV)) {
6970 /* packagevar $a[] or $h{} */
6971 GV * const gv = cGVOPx_gv(firstop);
6979 else if (op->op_type == OP_PADAV
6980 || op->op_type == OP_PADHV) {
6981 /* lexicalvar $a[] or $h{} */
6982 const char * const padname =
6983 PAD_COMPNAME_PV(op->op_targ);
6992 name = SvPV_const(tmpstr, len);
6997 name = "__ANONIO__";
7004 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7005 namesv = PAD_SVl(targ);
7006 SvUPGRADE(namesv, SVt_PV);
7008 sv_setpvs(namesv, "$");
7009 sv_catpvn(namesv, name, len);
7012 kid->op_sibling = 0;
7013 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7014 kid->op_targ = targ;
7015 kid->op_private |= priv;
7017 kid->op_sibling = sibl;
7023 mod(scalar(kid), type);
7027 tokid = &kid->op_sibling;
7028 kid = kid->op_sibling;
7031 if (kid && kid->op_type != OP_STUB)
7032 return too_many_arguments(o,OP_DESC(o));
7033 o->op_private |= numargs;
7035 /* FIXME - should the numargs move as for the PERL_MAD case? */
7036 o->op_private |= numargs;
7038 return too_many_arguments(o,OP_DESC(o));
7042 else if (PL_opargs[type] & OA_DEFGV) {
7044 OP *newop = newUNOP(type, 0, newDEFSVOP());
7045 op_getmad(o,newop,'O');
7048 /* Ordering of these two is important to keep f_map.t passing. */
7050 return newUNOP(type, 0, newDEFSVOP());
7055 while (oa & OA_OPTIONAL)
7057 if (oa && oa != OA_LIST)
7058 return too_few_arguments(o,OP_DESC(o));
7064 Perl_ck_glob(pTHX_ OP *o)
7069 PERL_ARGS_ASSERT_CK_GLOB;
7072 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7073 append_elem(OP_GLOB, o, newDEFSVOP());
7075 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7076 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7078 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7081 #if !defined(PERL_EXTERNAL_GLOB)
7082 /* XXX this can be tightened up and made more failsafe. */
7083 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7086 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7087 newSVpvs("File::Glob"), NULL, NULL, NULL);
7088 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7089 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7090 GvCV(gv) = GvCV(glob_gv);
7091 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7092 GvIMPORTED_CV_on(gv);
7095 #endif /* PERL_EXTERNAL_GLOB */
7097 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7098 append_elem(OP_GLOB, o,
7099 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7100 o->op_type = OP_LIST;
7101 o->op_ppaddr = PL_ppaddr[OP_LIST];
7102 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7103 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7104 cLISTOPo->op_first->op_targ = 0;
7105 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7106 append_elem(OP_LIST, o,
7107 scalar(newUNOP(OP_RV2CV, 0,
7108 newGVOP(OP_GV, 0, gv)))));
7109 o = newUNOP(OP_NULL, 0, ck_subr(o));
7110 o->op_targ = OP_GLOB; /* hint at what it used to be */
7113 gv = newGVgen("main");
7115 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7121 Perl_ck_grep(pTHX_ OP *o)
7126 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7129 PERL_ARGS_ASSERT_CK_GREP;
7131 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7132 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7134 if (o->op_flags & OPf_STACKED) {
7137 kid = cLISTOPo->op_first->op_sibling;
7138 if (!cUNOPx(kid)->op_next)
7139 Perl_croak(aTHX_ "panic: ck_grep");
7140 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7143 NewOp(1101, gwop, 1, LOGOP);
7144 kid->op_next = (OP*)gwop;
7145 o->op_flags &= ~OPf_STACKED;
7147 kid = cLISTOPo->op_first->op_sibling;
7148 if (type == OP_MAPWHILE)
7153 if (PL_parser && PL_parser->error_count)
7155 kid = cLISTOPo->op_first->op_sibling;
7156 if (kid->op_type != OP_NULL)
7157 Perl_croak(aTHX_ "panic: ck_grep");
7158 kid = kUNOP->op_first;
7161 NewOp(1101, gwop, 1, LOGOP);
7162 gwop->op_type = type;
7163 gwop->op_ppaddr = PL_ppaddr[type];
7164 gwop->op_first = listkids(o);
7165 gwop->op_flags |= OPf_KIDS;
7166 gwop->op_other = LINKLIST(kid);
7167 kid->op_next = (OP*)gwop;
7168 offset = pad_findmy("$_");
7169 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7170 o->op_private = gwop->op_private = 0;
7171 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7174 o->op_private = gwop->op_private = OPpGREP_LEX;
7175 gwop->op_targ = o->op_targ = offset;
7178 kid = cLISTOPo->op_first->op_sibling;
7179 if (!kid || !kid->op_sibling)
7180 return too_few_arguments(o,OP_DESC(o));
7181 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7182 mod(kid, OP_GREPSTART);
7188 Perl_ck_index(pTHX_ OP *o)
7190 PERL_ARGS_ASSERT_CK_INDEX;
7192 if (o->op_flags & OPf_KIDS) {
7193 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7195 kid = kid->op_sibling; /* get past "big" */
7196 if (kid && kid->op_type == OP_CONST)
7197 fbm_compile(((SVOP*)kid)->op_sv, 0);
7203 Perl_ck_lfun(pTHX_ OP *o)
7205 const OPCODE type = o->op_type;
7207 PERL_ARGS_ASSERT_CK_LFUN;
7209 return modkids(ck_fun(o), type);
7213 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7215 PERL_ARGS_ASSERT_CK_DEFINED;
7217 if ((o->op_flags & OPf_KIDS)) {
7218 switch (cUNOPo->op_first->op_type) {
7220 /* This is needed for
7221 if (defined %stash::)
7222 to work. Do not break Tk.
7224 break; /* Globals via GV can be undef */
7226 case OP_AASSIGN: /* Is this a good idea? */
7227 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7228 "defined(@array) is deprecated");
7229 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7230 "\t(Maybe you should just omit the defined()?)\n");
7234 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7235 "defined(%%hash) is deprecated");
7236 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7237 "\t(Maybe you should just omit the defined()?)\n");
7248 Perl_ck_readline(pTHX_ OP *o)
7250 PERL_ARGS_ASSERT_CK_READLINE;
7252 if (!(o->op_flags & OPf_KIDS)) {
7254 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7256 op_getmad(o,newop,'O');
7266 Perl_ck_rfun(pTHX_ OP *o)
7268 const OPCODE type = o->op_type;
7270 PERL_ARGS_ASSERT_CK_RFUN;
7272 return refkids(ck_fun(o), type);
7276 Perl_ck_listiob(pTHX_ OP *o)
7280 PERL_ARGS_ASSERT_CK_LISTIOB;
7282 kid = cLISTOPo->op_first;
7285 kid = cLISTOPo->op_first;
7287 if (kid->op_type == OP_PUSHMARK)
7288 kid = kid->op_sibling;
7289 if (kid && o->op_flags & OPf_STACKED)
7290 kid = kid->op_sibling;
7291 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7292 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7293 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7294 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7295 cLISTOPo->op_first->op_sibling = kid;
7296 cLISTOPo->op_last = kid;
7297 kid = kid->op_sibling;
7302 append_elem(o->op_type, o, newDEFSVOP());
7308 Perl_ck_smartmatch(pTHX_ OP *o)
7311 if (0 == (o->op_flags & OPf_SPECIAL)) {
7312 OP *first = cBINOPo->op_first;
7313 OP *second = first->op_sibling;
7315 /* Implicitly take a reference to an array or hash */
7316 first->op_sibling = NULL;
7317 first = cBINOPo->op_first = ref_array_or_hash(first);
7318 second = first->op_sibling = ref_array_or_hash(second);
7320 /* Implicitly take a reference to a regular expression */
7321 if (first->op_type == OP_MATCH) {
7322 first->op_type = OP_QR;
7323 first->op_ppaddr = PL_ppaddr[OP_QR];
7325 if (second->op_type == OP_MATCH) {
7326 second->op_type = OP_QR;
7327 second->op_ppaddr = PL_ppaddr[OP_QR];
7336 Perl_ck_sassign(pTHX_ OP *o)
7339 OP * const kid = cLISTOPo->op_first;
7341 PERL_ARGS_ASSERT_CK_SASSIGN;
7343 /* has a disposable target? */
7344 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7345 && !(kid->op_flags & OPf_STACKED)
7346 /* Cannot steal the second time! */
7347 && !(kid->op_private & OPpTARGET_MY)
7348 /* Keep the full thing for madskills */
7352 OP * const kkid = kid->op_sibling;
7354 /* Can just relocate the target. */
7355 if (kkid && kkid->op_type == OP_PADSV
7356 && !(kkid->op_private & OPpLVAL_INTRO))
7358 kid->op_targ = kkid->op_targ;
7360 /* Now we do not need PADSV and SASSIGN. */
7361 kid->op_sibling = o->op_sibling; /* NULL */
7362 cLISTOPo->op_first = NULL;
7365 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7369 if (kid->op_sibling) {
7370 OP *kkid = kid->op_sibling;
7371 if (kkid->op_type == OP_PADSV
7372 && (kkid->op_private & OPpLVAL_INTRO)
7373 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7374 const PADOFFSET target = kkid->op_targ;
7375 OP *const other = newOP(OP_PADSV,
7377 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7378 OP *const first = newOP(OP_NULL, 0);
7379 OP *const nullop = newCONDOP(0, first, o, other);
7380 OP *const condop = first->op_next;
7381 /* hijacking PADSTALE for uninitialized state variables */
7382 SvPADSTALE_on(PAD_SVl(target));
7384 condop->op_type = OP_ONCE;
7385 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7386 condop->op_targ = target;
7387 other->op_targ = target;
7389 /* Because we change the type of the op here, we will skip the
7390 assinment binop->op_last = binop->op_first->op_sibling; at the
7391 end of Perl_newBINOP(). So need to do it here. */
7392 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7401 Perl_ck_match(pTHX_ OP *o)
7405 PERL_ARGS_ASSERT_CK_MATCH;
7407 if (o->op_type != OP_QR && PL_compcv) {
7408 const PADOFFSET offset = pad_findmy("$_");
7409 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7410 o->op_targ = offset;
7411 o->op_private |= OPpTARGET_MY;
7414 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7415 o->op_private |= OPpRUNTIME;
7420 Perl_ck_method(pTHX_ OP *o)
7422 OP * const kid = cUNOPo->op_first;
7424 PERL_ARGS_ASSERT_CK_METHOD;
7426 if (kid->op_type == OP_CONST) {
7427 SV* sv = kSVOP->op_sv;
7428 const char * const method = SvPVX_const(sv);
7429 if (!(strchr(method, ':') || strchr(method, '\''))) {
7431 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7432 sv = newSVpvn_share(method, SvCUR(sv), 0);
7435 kSVOP->op_sv = NULL;
7437 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7439 op_getmad(o,cmop,'O');
7450 Perl_ck_null(pTHX_ OP *o)
7452 PERL_ARGS_ASSERT_CK_NULL;
7453 PERL_UNUSED_CONTEXT;
7458 Perl_ck_open(pTHX_ OP *o)
7461 HV * const table = GvHV(PL_hintgv);
7463 PERL_ARGS_ASSERT_CK_OPEN;
7466 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7469 const char *d = SvPV_const(*svp, len);
7470 const I32 mode = mode_from_discipline(d, len);
7471 if (mode & O_BINARY)
7472 o->op_private |= OPpOPEN_IN_RAW;
7473 else if (mode & O_TEXT)
7474 o->op_private |= OPpOPEN_IN_CRLF;
7477 svp = hv_fetchs(table, "open_OUT", FALSE);
7480 const char *d = SvPV_const(*svp, len);
7481 const I32 mode = mode_from_discipline(d, len);
7482 if (mode & O_BINARY)
7483 o->op_private |= OPpOPEN_OUT_RAW;
7484 else if (mode & O_TEXT)
7485 o->op_private |= OPpOPEN_OUT_CRLF;
7488 if (o->op_type == OP_BACKTICK) {
7489 if (!(o->op_flags & OPf_KIDS)) {
7490 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7492 op_getmad(o,newop,'O');
7501 /* In case of three-arg dup open remove strictness
7502 * from the last arg if it is a bareword. */
7503 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7504 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7508 if ((last->op_type == OP_CONST) && /* The bareword. */
7509 (last->op_private & OPpCONST_BARE) &&
7510 (last->op_private & OPpCONST_STRICT) &&
7511 (oa = first->op_sibling) && /* The fh. */
7512 (oa = oa->op_sibling) && /* The mode. */
7513 (oa->op_type == OP_CONST) &&
7514 SvPOK(((SVOP*)oa)->op_sv) &&
7515 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7516 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7517 (last == oa->op_sibling)) /* The bareword. */
7518 last->op_private &= ~OPpCONST_STRICT;
7524 Perl_ck_repeat(pTHX_ OP *o)
7526 PERL_ARGS_ASSERT_CK_REPEAT;
7528 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7529 o->op_private |= OPpREPEAT_DOLIST;
7530 cBINOPo->op_first = force_list(cBINOPo->op_first);
7538 Perl_ck_require(pTHX_ OP *o)
7543 PERL_ARGS_ASSERT_CK_REQUIRE;
7545 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7546 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7548 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7549 SV * const sv = kid->op_sv;
7550 U32 was_readonly = SvREADONLY(sv);
7557 sv_force_normal_flags(sv, 0);
7558 assert(!SvREADONLY(sv));
7568 for (; s < end; s++) {
7569 if (*s == ':' && s[1] == ':') {
7571 Move(s+2, s+1, end - s - 1, char);
7576 sv_catpvs(sv, ".pm");
7577 SvFLAGS(sv) |= was_readonly;
7581 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7582 /* handle override, if any */
7583 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7584 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7585 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7586 gv = gvp ? *gvp : NULL;
7590 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7591 OP * const kid = cUNOPo->op_first;
7594 cUNOPo->op_first = 0;
7598 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7599 append_elem(OP_LIST, kid,
7600 scalar(newUNOP(OP_RV2CV, 0,
7603 op_getmad(o,newop,'O');
7611 Perl_ck_return(pTHX_ OP *o)
7616 PERL_ARGS_ASSERT_CK_RETURN;
7618 kid = cLISTOPo->op_first->op_sibling;
7619 if (CvLVALUE(PL_compcv)) {
7620 for (; kid; kid = kid->op_sibling)
7621 mod(kid, OP_LEAVESUBLV);
7623 for (; kid; kid = kid->op_sibling)
7624 if ((kid->op_type == OP_NULL)
7625 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7626 /* This is a do block */
7627 OP *op = kUNOP->op_first;
7628 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7629 op = cUNOPx(op)->op_first;
7630 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7631 /* Force the use of the caller's context */
7632 op->op_flags |= OPf_SPECIAL;
7641 Perl_ck_select(pTHX_ OP *o)
7646 PERL_ARGS_ASSERT_CK_SELECT;
7648 if (o->op_flags & OPf_KIDS) {
7649 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7650 if (kid && kid->op_sibling) {
7651 o->op_type = OP_SSELECT;
7652 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7654 return fold_constants(o);
7658 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7659 if (kid && kid->op_type == OP_RV2GV)
7660 kid->op_private &= ~HINT_STRICT_REFS;
7665 Perl_ck_shift(pTHX_ OP *o)
7668 const I32 type = o->op_type;
7670 PERL_ARGS_ASSERT_CK_SHIFT;
7672 if (!(o->op_flags & OPf_KIDS)) {
7673 OP *argop = newUNOP(OP_RV2AV, 0,
7674 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7676 OP * const oldo = o;
7677 o = newUNOP(type, 0, scalar(argop));
7678 op_getmad(oldo,o,'O');
7682 return newUNOP(type, 0, scalar(argop));
7685 return scalar(modkids(ck_fun(o), type));
7689 Perl_ck_sort(pTHX_ OP *o)
7694 PERL_ARGS_ASSERT_CK_SORT;
7696 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7697 HV * const hinthv = GvHV(PL_hintgv);
7699 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7701 const I32 sorthints = (I32)SvIV(*svp);
7702 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7703 o->op_private |= OPpSORT_QSORT;
7704 if ((sorthints & HINT_SORT_STABLE) != 0)
7705 o->op_private |= OPpSORT_STABLE;
7710 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7712 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7713 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7715 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7717 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7719 if (kid->op_type == OP_SCOPE) {
7723 else if (kid->op_type == OP_LEAVE) {
7724 if (o->op_type == OP_SORT) {
7725 op_null(kid); /* wipe out leave */
7728 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7729 if (k->op_next == kid)
7731 /* don't descend into loops */
7732 else if (k->op_type == OP_ENTERLOOP
7733 || k->op_type == OP_ENTERITER)
7735 k = cLOOPx(k)->op_lastop;
7740 kid->op_next = 0; /* just disconnect the leave */
7741 k = kLISTOP->op_first;
7746 if (o->op_type == OP_SORT) {
7747 /* provide scalar context for comparison function/block */
7753 o->op_flags |= OPf_SPECIAL;
7755 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7758 firstkid = firstkid->op_sibling;
7761 /* provide list context for arguments */
7762 if (o->op_type == OP_SORT)
7769 S_simplify_sort(pTHX_ OP *o)
7772 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7778 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7780 if (!(o->op_flags & OPf_STACKED))
7782 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7783 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7784 kid = kUNOP->op_first; /* get past null */
7785 if (kid->op_type != OP_SCOPE)
7787 kid = kLISTOP->op_last; /* get past scope */
7788 switch(kid->op_type) {
7796 k = kid; /* remember this node*/
7797 if (kBINOP->op_first->op_type != OP_RV2SV)
7799 kid = kBINOP->op_first; /* get past cmp */
7800 if (kUNOP->op_first->op_type != OP_GV)
7802 kid = kUNOP->op_first; /* get past rv2sv */
7804 if (GvSTASH(gv) != PL_curstash)
7806 gvname = GvNAME(gv);
7807 if (*gvname == 'a' && gvname[1] == '\0')
7809 else if (*gvname == 'b' && gvname[1] == '\0')
7814 kid = k; /* back to cmp */
7815 if (kBINOP->op_last->op_type != OP_RV2SV)
7817 kid = kBINOP->op_last; /* down to 2nd arg */
7818 if (kUNOP->op_first->op_type != OP_GV)
7820 kid = kUNOP->op_first; /* get past rv2sv */
7822 if (GvSTASH(gv) != PL_curstash)
7824 gvname = GvNAME(gv);
7826 ? !(*gvname == 'a' && gvname[1] == '\0')
7827 : !(*gvname == 'b' && gvname[1] == '\0'))
7829 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7831 o->op_private |= OPpSORT_DESCEND;
7832 if (k->op_type == OP_NCMP)
7833 o->op_private |= OPpSORT_NUMERIC;
7834 if (k->op_type == OP_I_NCMP)
7835 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7836 kid = cLISTOPo->op_first->op_sibling;
7837 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7839 op_getmad(kid,o,'S'); /* then delete it */
7841 op_free(kid); /* then delete it */
7846 Perl_ck_split(pTHX_ OP *o)
7851 PERL_ARGS_ASSERT_CK_SPLIT;
7853 if (o->op_flags & OPf_STACKED)
7854 return no_fh_allowed(o);
7856 kid = cLISTOPo->op_first;
7857 if (kid->op_type != OP_NULL)
7858 Perl_croak(aTHX_ "panic: ck_split");
7859 kid = kid->op_sibling;
7860 op_free(cLISTOPo->op_first);
7861 cLISTOPo->op_first = kid;
7863 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7864 cLISTOPo->op_last = kid; /* There was only one element previously */
7867 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7868 OP * const sibl = kid->op_sibling;
7869 kid->op_sibling = 0;
7870 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7871 if (cLISTOPo->op_first == cLISTOPo->op_last)
7872 cLISTOPo->op_last = kid;
7873 cLISTOPo->op_first = kid;
7874 kid->op_sibling = sibl;
7877 kid->op_type = OP_PUSHRE;
7878 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7880 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7881 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7882 "Use of /g modifier is meaningless in split");
7885 if (!kid->op_sibling)
7886 append_elem(OP_SPLIT, o, newDEFSVOP());
7888 kid = kid->op_sibling;
7891 if (!kid->op_sibling)
7892 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7893 assert(kid->op_sibling);
7895 kid = kid->op_sibling;
7898 if (kid->op_sibling)
7899 return too_many_arguments(o,OP_DESC(o));
7905 Perl_ck_join(pTHX_ OP *o)
7907 const OP * const kid = cLISTOPo->op_first->op_sibling;
7909 PERL_ARGS_ASSERT_CK_JOIN;
7911 if (kid && kid->op_type == OP_MATCH) {
7912 if (ckWARN(WARN_SYNTAX)) {
7913 const REGEXP *re = PM_GETRE(kPMOP);
7914 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7915 const STRLEN len = re ? RX_PRELEN(re) : 6;
7916 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7917 "/%.*s/ should probably be written as \"%.*s\"",
7918 (int)len, pmstr, (int)len, pmstr);
7925 Perl_ck_subr(pTHX_ OP *o)
7928 OP *prev = ((cUNOPo->op_first->op_sibling)
7929 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7930 OP *o2 = prev->op_sibling;
7932 const char *proto = NULL;
7933 const char *proto_end = NULL;
7938 I32 contextclass = 0;
7939 const char *e = NULL;
7942 PERL_ARGS_ASSERT_CK_SUBR;
7944 o->op_private |= OPpENTERSUB_HASTARG;
7945 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7946 if (cvop->op_type == OP_RV2CV) {
7948 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7949 op_null(cvop); /* disable rv2cv */
7950 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7951 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7952 GV *gv = cGVOPx_gv(tmpop);
7955 tmpop->op_private |= OPpEARLY_CV;
7959 namegv = CvANON(cv) ? gv : CvGV(cv);
7960 proto = SvPV(MUTABLE_SV(cv), len);
7961 proto_end = proto + len;
7966 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7967 if (o2->op_type == OP_CONST)
7968 o2->op_private &= ~OPpCONST_STRICT;
7969 else if (o2->op_type == OP_LIST) {
7970 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7971 if (sib && sib->op_type == OP_CONST)
7972 sib->op_private &= ~OPpCONST_STRICT;
7975 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7976 if (PERLDB_SUB && PL_curstash != PL_debstash)
7977 o->op_private |= OPpENTERSUB_DB;
7978 while (o2 != cvop) {
7980 if (PL_madskills && o2->op_type == OP_STUB) {
7981 o2 = o2->op_sibling;
7984 if (PL_madskills && o2->op_type == OP_NULL)
7985 o3 = ((UNOP*)o2)->op_first;
7989 if (proto >= proto_end)
7990 return too_many_arguments(o, gv_ename(namegv));
7998 /* _ must be at the end */
7999 if (proto[1] && proto[1] != ';')
8014 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8016 arg == 1 ? "block or sub {}" : "sub {}",
8017 gv_ename(namegv), o3);
8020 /* '*' allows any scalar type, including bareword */
8023 if (o3->op_type == OP_RV2GV)
8024 goto wrapref; /* autoconvert GLOB -> GLOBref */
8025 else if (o3->op_type == OP_CONST)
8026 o3->op_private &= ~OPpCONST_STRICT;
8027 else if (o3->op_type == OP_ENTERSUB) {
8028 /* accidental subroutine, revert to bareword */
8029 OP *gvop = ((UNOP*)o3)->op_first;
8030 if (gvop && gvop->op_type == OP_NULL) {
8031 gvop = ((UNOP*)gvop)->op_first;
8033 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8036 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8037 (gvop = ((UNOP*)gvop)->op_first) &&
8038 gvop->op_type == OP_GV)
8040 GV * const gv = cGVOPx_gv(gvop);
8041 OP * const sibling = o2->op_sibling;
8042 SV * const n = newSVpvs("");
8044 OP * const oldo2 = o2;
8048 gv_fullname4(n, gv, "", FALSE);
8049 o2 = newSVOP(OP_CONST, 0, n);
8050 op_getmad(oldo2,o2,'O');
8051 prev->op_sibling = o2;
8052 o2->op_sibling = sibling;
8068 if (contextclass++ == 0) {
8069 e = strchr(proto, ']');
8070 if (!e || e == proto)
8079 const char *p = proto;
8080 const char *const end = proto;
8082 while (*--p != '[') {}
8083 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8085 gv_ename(namegv), o3);
8090 if (o3->op_type == OP_RV2GV)
8093 bad_type(arg, "symbol", gv_ename(namegv), o3);
8096 if (o3->op_type == OP_ENTERSUB)
8099 bad_type(arg, "subroutine entry", gv_ename(namegv),
8103 if (o3->op_type == OP_RV2SV ||
8104 o3->op_type == OP_PADSV ||
8105 o3->op_type == OP_HELEM ||
8106 o3->op_type == OP_AELEM)
8109 bad_type(arg, "scalar", gv_ename(namegv), o3);
8112 if (o3->op_type == OP_RV2AV ||
8113 o3->op_type == OP_PADAV)
8116 bad_type(arg, "array", gv_ename(namegv), o3);
8119 if (o3->op_type == OP_RV2HV ||
8120 o3->op_type == OP_PADHV)
8123 bad_type(arg, "hash", gv_ename(namegv), o3);
8128 OP* const sib = kid->op_sibling;
8129 kid->op_sibling = 0;
8130 o2 = newUNOP(OP_REFGEN, 0, kid);
8131 o2->op_sibling = sib;
8132 prev->op_sibling = o2;
8134 if (contextclass && e) {
8149 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8150 gv_ename(namegv), SVfARG(cv));
8155 mod(o2, OP_ENTERSUB);
8157 o2 = o2->op_sibling;
8159 if (o2 == cvop && proto && *proto == '_') {
8160 /* generate an access to $_ */
8162 o2->op_sibling = prev->op_sibling;
8163 prev->op_sibling = o2; /* instead of cvop */
8165 if (proto && !optional && proto_end > proto &&
8166 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8167 return too_few_arguments(o, gv_ename(namegv));
8170 OP * const oldo = o;
8174 o=newSVOP(OP_CONST, 0, newSViv(0));
8175 op_getmad(oldo,o,'O');
8181 Perl_ck_svconst(pTHX_ OP *o)
8183 PERL_ARGS_ASSERT_CK_SVCONST;
8184 PERL_UNUSED_CONTEXT;
8185 SvREADONLY_on(cSVOPo->op_sv);
8190 Perl_ck_chdir(pTHX_ OP *o)
8192 if (o->op_flags & OPf_KIDS) {
8193 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8195 if (kid && kid->op_type == OP_CONST &&
8196 (kid->op_private & OPpCONST_BARE))
8198 o->op_flags |= OPf_SPECIAL;
8199 kid->op_private &= ~OPpCONST_STRICT;
8206 Perl_ck_trunc(pTHX_ OP *o)
8208 PERL_ARGS_ASSERT_CK_TRUNC;
8210 if (o->op_flags & OPf_KIDS) {
8211 SVOP *kid = (SVOP*)cUNOPo->op_first;
8213 if (kid->op_type == OP_NULL)
8214 kid = (SVOP*)kid->op_sibling;
8215 if (kid && kid->op_type == OP_CONST &&
8216 (kid->op_private & OPpCONST_BARE))
8218 o->op_flags |= OPf_SPECIAL;
8219 kid->op_private &= ~OPpCONST_STRICT;
8226 Perl_ck_unpack(pTHX_ OP *o)
8228 OP *kid = cLISTOPo->op_first;
8230 PERL_ARGS_ASSERT_CK_UNPACK;
8232 if (kid->op_sibling) {
8233 kid = kid->op_sibling;
8234 if (!kid->op_sibling)
8235 kid->op_sibling = newDEFSVOP();
8241 Perl_ck_substr(pTHX_ OP *o)
8243 PERL_ARGS_ASSERT_CK_SUBSTR;
8246 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8247 OP *kid = cLISTOPo->op_first;
8249 if (kid->op_type == OP_NULL)
8250 kid = kid->op_sibling;
8252 kid->op_flags |= OPf_MOD;
8259 Perl_ck_each(pTHX_ OP *o)
8262 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8264 PERL_ARGS_ASSERT_CK_EACH;
8267 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8268 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8269 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8270 o->op_type = new_type;
8271 o->op_ppaddr = PL_ppaddr[new_type];
8273 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8274 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8276 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8283 /* caller is supposed to assign the return to the
8284 container of the rep_op var */
8286 S_opt_scalarhv(pTHX_ OP *rep_op) {
8289 PERL_ARGS_ASSERT_OPT_SCALARHV;
8291 NewOp(1101, unop, 1, UNOP);
8292 unop->op_type = (OPCODE)OP_BOOLKEYS;
8293 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8294 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8295 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8296 unop->op_first = rep_op;
8297 unop->op_next = rep_op->op_next;
8298 rep_op->op_next = (OP*)unop;
8299 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8300 unop->op_sibling = rep_op->op_sibling;
8301 rep_op->op_sibling = NULL;
8302 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8303 if (rep_op->op_type == OP_PADHV) {
8304 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8305 rep_op->op_flags |= OPf_WANT_LIST;
8310 /* A peephole optimizer. We visit the ops in the order they're to execute.
8311 * See the comments at the top of this file for more details about when
8312 * peep() is called */
8315 Perl_peep(pTHX_ register OP *o)
8318 register OP* oldop = NULL;
8320 if (!o || o->op_opt)
8324 SAVEVPTR(PL_curcop);
8325 for (; o; o = o->op_next) {
8328 /* By default, this op has now been optimised. A couple of cases below
8329 clear this again. */
8332 switch (o->op_type) {
8335 PL_curcop = ((COP*)o); /* for warnings */
8339 if (cSVOPo->op_private & OPpCONST_STRICT)
8340 no_bareword_allowed(o);
8343 case OP_METHOD_NAMED:
8344 /* Relocate sv to the pad for thread safety.
8345 * Despite being a "constant", the SV is written to,
8346 * for reference counts, sv_upgrade() etc. */
8348 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8349 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8350 /* If op_sv is already a PADTMP then it is being used by
8351 * some pad, so make a copy. */
8352 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8353 SvREADONLY_on(PAD_SVl(ix));
8354 SvREFCNT_dec(cSVOPo->op_sv);
8356 else if (o->op_type != OP_METHOD_NAMED
8357 && cSVOPo->op_sv == &PL_sv_undef) {
8358 /* PL_sv_undef is hack - it's unsafe to store it in the
8359 AV that is the pad, because av_fetch treats values of
8360 PL_sv_undef as a "free" AV entry and will merrily
8361 replace them with a new SV, causing pad_alloc to think
8362 that this pad slot is free. (When, clearly, it is not)
8364 SvOK_off(PAD_SVl(ix));
8365 SvPADTMP_on(PAD_SVl(ix));
8366 SvREADONLY_on(PAD_SVl(ix));
8369 SvREFCNT_dec(PAD_SVl(ix));
8370 SvPADTMP_on(cSVOPo->op_sv);
8371 PAD_SETSV(ix, cSVOPo->op_sv);
8372 /* XXX I don't know how this isn't readonly already. */
8373 SvREADONLY_on(PAD_SVl(ix));
8375 cSVOPo->op_sv = NULL;
8382 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8383 if (o->op_next->op_private & OPpTARGET_MY) {
8384 if (o->op_flags & OPf_STACKED) /* chained concats */
8385 break; /* ignore_optimization */
8387 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8388 o->op_targ = o->op_next->op_targ;
8389 o->op_next->op_targ = 0;
8390 o->op_private |= OPpTARGET_MY;
8393 op_null(o->op_next);
8397 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8398 break; /* Scalar stub must produce undef. List stub is noop */
8402 if (o->op_targ == OP_NEXTSTATE
8403 || o->op_targ == OP_DBSTATE)
8405 PL_curcop = ((COP*)o);
8407 /* XXX: We avoid setting op_seq here to prevent later calls
8408 to peep() from mistakenly concluding that optimisation
8409 has already occurred. This doesn't fix the real problem,
8410 though (See 20010220.007). AMS 20010719 */
8411 /* op_seq functionality is now replaced by op_opt */
8418 if (oldop && o->op_next) {
8419 oldop->op_next = o->op_next;
8427 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8428 OP* const pop = (o->op_type == OP_PADAV) ?
8429 o->op_next : o->op_next->op_next;
8431 if (pop && pop->op_type == OP_CONST &&
8432 ((PL_op = pop->op_next)) &&
8433 pop->op_next->op_type == OP_AELEM &&
8434 !(pop->op_next->op_private &
8435 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8436 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8441 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8442 no_bareword_allowed(pop);
8443 if (o->op_type == OP_GV)
8444 op_null(o->op_next);
8445 op_null(pop->op_next);
8447 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8448 o->op_next = pop->op_next->op_next;
8449 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8450 o->op_private = (U8)i;
8451 if (o->op_type == OP_GV) {
8456 o->op_flags |= OPf_SPECIAL;
8457 o->op_type = OP_AELEMFAST;
8462 if (o->op_next->op_type == OP_RV2SV) {
8463 if (!(o->op_next->op_private & OPpDEREF)) {
8464 op_null(o->op_next);
8465 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8467 o->op_next = o->op_next->op_next;
8468 o->op_type = OP_GVSV;
8469 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8472 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8473 GV * const gv = cGVOPo_gv;
8474 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8475 /* XXX could check prototype here instead of just carping */
8476 SV * const sv = sv_newmortal();
8477 gv_efullname3(sv, gv, NULL);
8478 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8479 "%"SVf"() called too early to check prototype",
8483 else if (o->op_next->op_type == OP_READLINE
8484 && o->op_next->op_next->op_type == OP_CONCAT
8485 && (o->op_next->op_next->op_flags & OPf_STACKED))
8487 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8488 o->op_type = OP_RCATLINE;
8489 o->op_flags |= OPf_STACKED;
8490 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8491 op_null(o->op_next->op_next);
8492 op_null(o->op_next);
8502 fop = cUNOP->op_first;
8510 fop = cLOGOP->op_first;
8511 sop = fop->op_sibling;
8512 while (cLOGOP->op_other->op_type == OP_NULL)
8513 cLOGOP->op_other = cLOGOP->op_other->op_next;
8514 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8518 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8520 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8525 if (!(nop->op_flags && OPf_WANT_VOID)) {
8526 while (nop && nop->op_next) {
8527 switch (nop->op_next->op_type) {
8532 lop = nop = nop->op_next;
8543 if (lop->op_flags && OPf_WANT_VOID) {
8544 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8545 cLOGOP->op_first = opt_scalarhv(fop);
8546 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8547 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8563 while (cLOGOP->op_other->op_type == OP_NULL)
8564 cLOGOP->op_other = cLOGOP->op_other->op_next;
8565 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8570 while (cLOOP->op_redoop->op_type == OP_NULL)
8571 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8572 peep(cLOOP->op_redoop);
8573 while (cLOOP->op_nextop->op_type == OP_NULL)
8574 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8575 peep(cLOOP->op_nextop);
8576 while (cLOOP->op_lastop->op_type == OP_NULL)
8577 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8578 peep(cLOOP->op_lastop);
8582 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8583 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8584 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8585 cPMOP->op_pmstashstartu.op_pmreplstart
8586 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8587 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8591 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8592 && ckWARN(WARN_SYNTAX))
8594 if (o->op_next->op_sibling) {
8595 const OPCODE type = o->op_next->op_sibling->op_type;
8596 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8597 const line_t oldline = CopLINE(PL_curcop);
8598 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8599 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8600 "Statement unlikely to be reached");
8601 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8602 "\t(Maybe you meant system() when you said exec()?)\n");
8603 CopLINE_set(PL_curcop, oldline);
8614 const char *key = NULL;
8617 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8620 /* Make the CONST have a shared SV */
8621 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8622 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8623 key = SvPV_const(sv, keylen);
8624 lexname = newSVpvn_share(key,
8625 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8631 if ((o->op_private & (OPpLVAL_INTRO)))
8634 rop = (UNOP*)((BINOP*)o)->op_first;
8635 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8637 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8638 if (!SvPAD_TYPED(lexname))
8640 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8641 if (!fields || !GvHV(*fields))
8643 key = SvPV_const(*svp, keylen);
8644 if (!hv_fetch(GvHV(*fields), key,
8645 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8647 Perl_croak(aTHX_ "No such class field \"%s\" "
8648 "in variable %s of type %s",
8649 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8662 SVOP *first_key_op, *key_op;
8664 if ((o->op_private & (OPpLVAL_INTRO))
8665 /* I bet there's always a pushmark... */
8666 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8667 /* hmmm, no optimization if list contains only one key. */
8669 rop = (UNOP*)((LISTOP*)o)->op_last;
8670 if (rop->op_type != OP_RV2HV)
8672 if (rop->op_first->op_type == OP_PADSV)
8673 /* @$hash{qw(keys here)} */
8674 rop = (UNOP*)rop->op_first;
8676 /* @{$hash}{qw(keys here)} */
8677 if (rop->op_first->op_type == OP_SCOPE
8678 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8680 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8686 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8687 if (!SvPAD_TYPED(lexname))
8689 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8690 if (!fields || !GvHV(*fields))
8692 /* Again guessing that the pushmark can be jumped over.... */
8693 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8694 ->op_first->op_sibling;
8695 for (key_op = first_key_op; key_op;
8696 key_op = (SVOP*)key_op->op_sibling) {
8697 if (key_op->op_type != OP_CONST)
8699 svp = cSVOPx_svp(key_op);
8700 key = SvPV_const(*svp, keylen);
8701 if (!hv_fetch(GvHV(*fields), key,
8702 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8704 Perl_croak(aTHX_ "No such class field \"%s\" "
8705 "in variable %s of type %s",
8706 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8713 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8717 /* check that RHS of sort is a single plain array */
8718 OP *oright = cUNOPo->op_first;
8719 if (!oright || oright->op_type != OP_PUSHMARK)
8722 /* reverse sort ... can be optimised. */
8723 if (!cUNOPo->op_sibling) {
8724 /* Nothing follows us on the list. */
8725 OP * const reverse = o->op_next;
8727 if (reverse->op_type == OP_REVERSE &&
8728 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8729 OP * const pushmark = cUNOPx(reverse)->op_first;
8730 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8731 && (cUNOPx(pushmark)->op_sibling == o)) {
8732 /* reverse -> pushmark -> sort */
8733 o->op_private |= OPpSORT_REVERSE;
8735 pushmark->op_next = oright->op_next;
8741 /* make @a = sort @a act in-place */
8743 oright = cUNOPx(oright)->op_sibling;
8746 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8747 oright = cUNOPx(oright)->op_sibling;
8751 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8752 || oright->op_next != o
8753 || (oright->op_private & OPpLVAL_INTRO)
8757 /* o2 follows the chain of op_nexts through the LHS of the
8758 * assign (if any) to the aassign op itself */
8760 if (!o2 || o2->op_type != OP_NULL)
8763 if (!o2 || o2->op_type != OP_PUSHMARK)
8766 if (o2 && o2->op_type == OP_GV)
8769 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8770 || (o2->op_private & OPpLVAL_INTRO)
8775 if (!o2 || o2->op_type != OP_NULL)
8778 if (!o2 || o2->op_type != OP_AASSIGN
8779 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8782 /* check that the sort is the first arg on RHS of assign */
8784 o2 = cUNOPx(o2)->op_first;
8785 if (!o2 || o2->op_type != OP_NULL)
8787 o2 = cUNOPx(o2)->op_first;
8788 if (!o2 || o2->op_type != OP_PUSHMARK)
8790 if (o2->op_sibling != o)
8793 /* check the array is the same on both sides */
8794 if (oleft->op_type == OP_RV2AV) {
8795 if (oright->op_type != OP_RV2AV
8796 || !cUNOPx(oright)->op_first
8797 || cUNOPx(oright)->op_first->op_type != OP_GV
8798 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8799 cGVOPx_gv(cUNOPx(oright)->op_first)
8803 else if (oright->op_type != OP_PADAV
8804 || oright->op_targ != oleft->op_targ
8808 /* transfer MODishness etc from LHS arg to RHS arg */
8809 oright->op_flags = oleft->op_flags;
8810 o->op_private |= OPpSORT_INPLACE;
8812 /* excise push->gv->rv2av->null->aassign */
8813 o2 = o->op_next->op_next;
8814 op_null(o2); /* PUSHMARK */
8816 if (o2->op_type == OP_GV) {
8817 op_null(o2); /* GV */
8820 op_null(o2); /* RV2AV or PADAV */
8821 o2 = o2->op_next->op_next;
8822 op_null(o2); /* AASSIGN */
8824 o->op_next = o2->op_next;
8830 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8832 LISTOP *enter, *exlist;
8834 enter = (LISTOP *) o->op_next;
8837 if (enter->op_type == OP_NULL) {
8838 enter = (LISTOP *) enter->op_next;
8842 /* for $a (...) will have OP_GV then OP_RV2GV here.
8843 for (...) just has an OP_GV. */
8844 if (enter->op_type == OP_GV) {
8845 gvop = (OP *) enter;
8846 enter = (LISTOP *) enter->op_next;
8849 if (enter->op_type == OP_RV2GV) {
8850 enter = (LISTOP *) enter->op_next;
8856 if (enter->op_type != OP_ENTERITER)
8859 iter = enter->op_next;
8860 if (!iter || iter->op_type != OP_ITER)
8863 expushmark = enter->op_first;
8864 if (!expushmark || expushmark->op_type != OP_NULL
8865 || expushmark->op_targ != OP_PUSHMARK)
8868 exlist = (LISTOP *) expushmark->op_sibling;
8869 if (!exlist || exlist->op_type != OP_NULL
8870 || exlist->op_targ != OP_LIST)
8873 if (exlist->op_last != o) {
8874 /* Mmm. Was expecting to point back to this op. */
8877 theirmark = exlist->op_first;
8878 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8881 if (theirmark->op_sibling != o) {
8882 /* There's something between the mark and the reverse, eg
8883 for (1, reverse (...))
8888 ourmark = ((LISTOP *)o)->op_first;
8889 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8892 ourlast = ((LISTOP *)o)->op_last;
8893 if (!ourlast || ourlast->op_next != o)
8896 rv2av = ourmark->op_sibling;
8897 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8898 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8899 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8900 /* We're just reversing a single array. */
8901 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8902 enter->op_flags |= OPf_STACKED;
8905 /* We don't have control over who points to theirmark, so sacrifice
8907 theirmark->op_next = ourmark->op_next;
8908 theirmark->op_flags = ourmark->op_flags;
8909 ourlast->op_next = gvop ? gvop : (OP *) enter;
8912 enter->op_private |= OPpITER_REVERSED;
8913 iter->op_private |= OPpITER_REVERSED;
8920 UNOP *refgen, *rv2cv;
8923 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8926 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8929 rv2gv = ((BINOP *)o)->op_last;
8930 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8933 refgen = (UNOP *)((BINOP *)o)->op_first;
8935 if (!refgen || refgen->op_type != OP_REFGEN)
8938 exlist = (LISTOP *)refgen->op_first;
8939 if (!exlist || exlist->op_type != OP_NULL
8940 || exlist->op_targ != OP_LIST)
8943 if (exlist->op_first->op_type != OP_PUSHMARK)
8946 rv2cv = (UNOP*)exlist->op_last;
8948 if (rv2cv->op_type != OP_RV2CV)
8951 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8952 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8953 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8955 o->op_private |= OPpASSIGN_CV_TO_GV;
8956 rv2gv->op_private |= OPpDONT_INIT_GV;
8957 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8965 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8966 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8976 Perl_custom_op_name(pTHX_ const OP* o)
8979 const IV index = PTR2IV(o->op_ppaddr);
8983 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8985 if (!PL_custom_op_names) /* This probably shouldn't happen */
8986 return (char *)PL_op_name[OP_CUSTOM];
8988 keysv = sv_2mortal(newSViv(index));
8990 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8992 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8994 return SvPV_nolen(HeVAL(he));
8998 Perl_custom_op_desc(pTHX_ const OP* o)
9001 const IV index = PTR2IV(o->op_ppaddr);
9005 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9007 if (!PL_custom_op_descs)
9008 return (char *)PL_op_desc[OP_CUSTOM];
9010 keysv = sv_2mortal(newSViv(index));
9012 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9014 return (char *)PL_op_desc[OP_CUSTOM];
9016 return SvPV_nolen(HeVAL(he));
9021 /* Efficient sub that returns a constant scalar value. */
9023 const_sv_xsub(pTHX_ CV* cv)
9027 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9031 /* diag_listed_as: SKIPME */
9032 Perl_croak(aTHX_ "usage: %s::%s()",
9033 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9046 * c-indentation-style: bsd
9048 * indent-tabs-mode: t
9051 * ex: set ts=8 sts=4 sw=4 noet: