3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifdef PERL_DEBUG_READONLY_OPS
108 # define PERL_SLAB_SIZE 4096
109 # include <sys/mman.h>
112 #ifndef PERL_SLAB_SIZE
113 #define PERL_SLAB_SIZE 2048
117 Perl_Slab_Alloc(pTHX_ size_t sz)
120 * To make incrementing use count easy PL_OpSlab is an I32 *
121 * To make inserting the link to slab PL_OpPtr is I32 **
122 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
123 * Add an overhead for pointer to slab and round up as a number of pointers
125 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
126 if ((PL_OpSpace -= sz) < 0) {
127 #ifdef PERL_DEBUG_READONLY_OPS
128 /* We need to allocate chunk by chunk so that we can control the VM
130 PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
131 MAP_ANON|MAP_PRIVATE, -1, 0);
133 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
134 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
136 if(PL_OpPtr == MAP_FAILED) {
137 perror("mmap failed");
142 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
147 /* We reserve the 0'th I32 sized chunk as a use count */
148 PL_OpSlab = (I32 *) PL_OpPtr;
149 /* Reduce size by the use count word, and by the size we need.
150 * Latter is to mimic the '-=' in the if() above
152 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
153 /* Allocation pointer starts at the top.
154 Theory: because we build leaves before trunk allocating at end
155 means that at run time access is cache friendly upward
157 PL_OpPtr += PERL_SLAB_SIZE;
159 #ifdef PERL_DEBUG_READONLY_OPS
160 /* We remember this slab. */
161 /* This implementation isn't efficient, but it is simple. */
162 PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
163 PL_slabs[PL_slab_count++] = PL_OpSlab;
164 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
167 assert( PL_OpSpace >= 0 );
168 /* Move the allocation pointer down */
170 assert( PL_OpPtr > (I32 **) PL_OpSlab );
171 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
172 (*PL_OpSlab)++; /* Increment use count of slab */
173 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
174 assert( *PL_OpSlab > 0 );
175 return (void *)(PL_OpPtr + 1);
178 #ifdef PERL_DEBUG_READONLY_OPS
180 Perl_pending_Slabs_to_ro(pTHX) {
181 /* Turn all the allocated op slabs read only. */
182 U32 count = PL_slab_count;
183 I32 **const slabs = PL_slabs;
185 /* Reset the array of pending OP slabs, as we're about to turn this lot
186 read only. Also, do it ahead of the loop in case the warn triggers,
187 and a warn handler has an eval */
193 /* Force a new slab for any further allocation. */
197 const void *start = slabs[count];
198 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
199 if(mprotect(start, size, PROT_READ)) {
200 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
201 start, (unsigned long) size, errno);
207 S_Slab_to_rw(pTHX_ void *op)
209 I32 * const * const ptr = (I32 **) op;
210 I32 * const slab = ptr[-1];
211 assert( ptr-1 > (I32 **) slab );
212 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
214 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
215 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
216 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
220 # define Slab_to_rw(op)
224 Perl_Slab_Free(pTHX_ void *op)
226 I32 * const * const ptr = (I32 **) op;
227 I32 * const slab = ptr[-1];
228 assert( ptr-1 > (I32 **) slab );
229 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
232 if (--(*slab) == 0) {
234 # define PerlMemShared PerlMem
237 #ifdef PERL_DEBUG_READONLY_OPS
238 U32 count = PL_slab_count;
239 /* Need to remove this slab from our list of slabs */
242 if (PL_slabs[count] == slab) {
243 /* Found it. Move the entry at the end to overwrite it. */
244 DEBUG_m(PerlIO_printf(Perl_debug_log,
245 "Deallocate %p by moving %p from %lu to %lu\n",
247 PL_slabs[PL_slab_count - 1],
248 PL_slab_count, count));
249 PL_slabs[count] = PL_slabs[--PL_slab_count];
250 /* Could realloc smaller at this point, but probably not
257 "panic: Couldn't find slab at %p (%lu allocated)",
258 slab, (unsigned long) PL_slabs);
260 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
261 perror("munmap failed");
266 PerlMemShared_free(slab);
268 if (slab == PL_OpSlab) {
275 * In the following definition, the ", (OP*)0" is just to make the compiler
276 * think the expression is of the right type: croak actually does a Siglongjmp.
278 #define CHECKOP(type,o) \
279 ((PL_op_mask && PL_op_mask[type]) \
280 ? ( op_free((OP*)o), \
281 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
283 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
285 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
288 S_gv_ename(pTHX_ GV *gv)
290 SV* const tmpsv = sv_newmortal();
291 gv_efullname3(tmpsv, gv, NULL);
292 return SvPV_nolen_const(tmpsv);
296 S_no_fh_allowed(pTHX_ OP *o)
298 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
304 S_too_few_arguments(pTHX_ OP *o, const char *name)
306 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
311 S_too_many_arguments(pTHX_ OP *o, const char *name)
313 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
318 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
320 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
321 (int)n, name, t, OP_DESC(kid)));
325 S_no_bareword_allowed(pTHX_ const OP *o)
328 return; /* various ok barewords are hidden in extra OP_NULL */
329 qerror(Perl_mess(aTHX_
330 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
334 /* "register" allocation */
337 Perl_allocmy(pTHX_ const char *const name)
341 const bool is_our = (PL_in_my == KEY_our);
343 /* complain about "my $<special_var>" etc etc */
347 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
348 (name[1] == '_' && (*name == '$' || name[2]))))
350 /* name[2] is true if strlen(name) > 2 */
351 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
352 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
353 name[0], toCTRL(name[1]), name + 2));
355 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
359 /* check for duplicate declaration */
360 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
362 if (PL_in_my_stash && *name != '$') {
363 yyerror(Perl_form(aTHX_
364 "Can't declare class for non-scalar %s in \"%s\"",
366 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
369 /* allocate a spare slot and store the name in that slot */
371 off = pad_add_name(name,
374 /* $_ is always in main::, even with our */
375 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
379 PL_in_my == KEY_state
384 /* free the body of an op without examining its contents.
385 * Always use this rather than FreeOp directly */
388 S_op_destroy(pTHX_ OP *o)
390 if (o->op_latefree) {
401 Perl_op_free(pTHX_ OP *o)
406 if (!o || o->op_static)
408 if (o->op_latefreed) {
415 if (o->op_private & OPpREFCOUNTED) {
425 #ifdef PERL_DEBUG_READONLY_OPS
429 refcnt = OpREFCNT_dec(o);
440 if (o->op_flags & OPf_KIDS) {
441 register OP *kid, *nextkid;
442 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
443 nextkid = kid->op_sibling; /* Get before next freeing kid */
448 type = (OPCODE)o->op_targ;
450 /* COP* is not cleared by op_clear() so that we may track line
451 * numbers etc even after null() */
452 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
453 #ifdef PERL_DEBUG_READONLY_OPS
460 if (o->op_latefree) {
466 #ifdef DEBUG_LEAKING_SCALARS
473 Perl_op_clear(pTHX_ OP *o)
478 /* if (o->op_madprop && o->op_madprop->mad_next)
480 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
481 "modification of a read only value" for a reason I can't fathom why.
482 It's the "" stringification of $_, where $_ was set to '' in a foreach
483 loop, but it defies simplification into a small test case.
484 However, commenting them out has caused ext/List/Util/t/weak.t to fail
487 mad_free(o->op_madprop);
493 switch (o->op_type) {
494 case OP_NULL: /* Was holding old type, if any. */
495 if (PL_madskills && o->op_targ != OP_NULL) {
496 o->op_type = o->op_targ;
500 case OP_ENTEREVAL: /* Was holding hints. */
504 if (!(o->op_flags & OPf_REF)
505 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
511 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
512 /* not an OP_PADAV replacement */
514 if (cPADOPo->op_padix > 0) {
515 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
516 * may still exist on the pad */
517 pad_swipe(cPADOPo->op_padix, TRUE);
518 cPADOPo->op_padix = 0;
521 SvREFCNT_dec(cSVOPo->op_sv);
522 cSVOPo->op_sv = NULL;
526 case OP_METHOD_NAMED:
528 SvREFCNT_dec(cSVOPo->op_sv);
529 cSVOPo->op_sv = NULL;
532 Even if op_clear does a pad_free for the target of the op,
533 pad_free doesn't actually remove the sv that exists in the pad;
534 instead it lives on. This results in that it could be reused as
535 a target later on when the pad was reallocated.
538 pad_swipe(o->op_targ,1);
547 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
551 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
553 if (cPADOPo->op_padix > 0) {
554 pad_swipe(cPADOPo->op_padix, TRUE);
555 cPADOPo->op_padix = 0;
558 SvREFCNT_dec(cSVOPo->op_sv);
559 cSVOPo->op_sv = NULL;
563 PerlMemShared_free(cPVOPo->op_pv);
564 cPVOPo->op_pv = NULL;
568 op_free(cPMOPo->op_pmreplroot);
572 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
573 /* No GvIN_PAD_off here, because other references may still
574 * exist on the pad */
575 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
578 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
585 HV * const pmstash = PmopSTASH(cPMOPo);
586 if (pmstash && !SvIS_FREED(pmstash)) {
587 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
589 PMOP *pmop = (PMOP*) mg->mg_obj;
590 PMOP *lastpmop = NULL;
592 if (cPMOPo == pmop) {
594 lastpmop->op_pmnext = pmop->op_pmnext;
596 mg->mg_obj = (SV*) pmop->op_pmnext;
600 pmop = pmop->op_pmnext;
604 PmopSTASH_free(cPMOPo);
606 cPMOPo->op_pmreplroot = NULL;
607 /* we use the "SAFE" version of the PM_ macros here
608 * since sv_clean_all might release some PMOPs
609 * after PL_regex_padav has been cleared
610 * and the clearing of PL_regex_padav needs to
611 * happen before sv_clean_all
613 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
614 PM_SETRE_SAFE(cPMOPo, NULL);
616 if(PL_regex_pad) { /* We could be in destruction */
617 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
618 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
619 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
620 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
627 if (o->op_targ > 0) {
628 pad_free(o->op_targ);
634 S_cop_free(pTHX_ COP* cop)
639 if (! specialWARN(cop->cop_warnings))
640 PerlMemShared_free(cop->cop_warnings);
641 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
645 Perl_op_null(pTHX_ OP *o)
648 if (o->op_type == OP_NULL)
652 o->op_targ = o->op_type;
653 o->op_type = OP_NULL;
654 o->op_ppaddr = PL_ppaddr[OP_NULL];
658 Perl_op_refcnt_lock(pTHX)
666 Perl_op_refcnt_unlock(pTHX)
673 /* Contextualizers */
675 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
678 Perl_linklist(pTHX_ OP *o)
685 /* establish postfix order */
686 first = cUNOPo->op_first;
689 o->op_next = LINKLIST(first);
692 if (kid->op_sibling) {
693 kid->op_next = LINKLIST(kid->op_sibling);
694 kid = kid->op_sibling;
708 Perl_scalarkids(pTHX_ OP *o)
710 if (o && o->op_flags & OPf_KIDS) {
712 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
719 S_scalarboolean(pTHX_ OP *o)
722 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
723 if (ckWARN(WARN_SYNTAX)) {
724 const line_t oldline = CopLINE(PL_curcop);
726 if (PL_copline != NOLINE)
727 CopLINE_set(PL_curcop, PL_copline);
728 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
729 CopLINE_set(PL_curcop, oldline);
736 Perl_scalar(pTHX_ OP *o)
741 /* assumes no premature commitment */
742 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
743 || o->op_type == OP_RETURN)
748 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
750 switch (o->op_type) {
752 scalar(cBINOPo->op_first);
757 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
761 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
762 if (!kPMOP->op_pmreplroot)
763 deprecate_old("implicit split to @_");
771 if (o->op_flags & OPf_KIDS) {
772 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
778 kid = cLISTOPo->op_first;
780 while ((kid = kid->op_sibling)) {
786 PL_curcop = &PL_compiling;
791 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
797 PL_curcop = &PL_compiling;
800 if (ckWARN(WARN_VOID))
801 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
807 Perl_scalarvoid(pTHX_ OP *o)
811 const char* useless = NULL;
815 /* trailing mad null ops don't count as "there" for void processing */
817 o->op_type != OP_NULL &&
819 o->op_sibling->op_type == OP_NULL)
822 for (sib = o->op_sibling;
823 sib && sib->op_type == OP_NULL;
824 sib = sib->op_sibling) ;
830 if (o->op_type == OP_NEXTSTATE
831 || o->op_type == OP_SETSTATE
832 || o->op_type == OP_DBSTATE
833 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
834 || o->op_targ == OP_SETSTATE
835 || o->op_targ == OP_DBSTATE)))
836 PL_curcop = (COP*)o; /* for warning below */
838 /* assumes no premature commitment */
839 want = o->op_flags & OPf_WANT;
840 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
841 || o->op_type == OP_RETURN)
846 if ((o->op_private & OPpTARGET_MY)
847 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
849 return scalar(o); /* As if inside SASSIGN */
852 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
854 switch (o->op_type) {
856 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
860 if (o->op_flags & OPf_STACKED)
864 if (o->op_private == 4)
936 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
937 useless = OP_DESC(o);
941 kid = cUNOPo->op_first;
942 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
943 kid->op_type != OP_TRANS) {
946 useless = "negative pattern binding (!~)";
953 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
954 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
955 useless = "a variable";
960 if (cSVOPo->op_private & OPpCONST_STRICT)
961 no_bareword_allowed(o);
963 if (ckWARN(WARN_VOID)) {
964 useless = "a constant";
965 if (o->op_private & OPpCONST_ARYBASE)
967 /* don't warn on optimised away booleans, eg
968 * use constant Foo, 5; Foo || print; */
969 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
971 /* the constants 0 and 1 are permitted as they are
972 conventionally used as dummies in constructs like
973 1 while some_condition_with_side_effects; */
974 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
976 else if (SvPOK(sv)) {
977 /* perl4's way of mixing documentation and code
978 (before the invention of POD) was based on a
979 trick to mix nroff and perl code. The trick was
980 built upon these three nroff macros being used in
981 void context. The pink camel has the details in
982 the script wrapman near page 319. */
983 const char * const maybe_macro = SvPVX_const(sv);
984 if (strnEQ(maybe_macro, "di", 2) ||
985 strnEQ(maybe_macro, "ds", 2) ||
986 strnEQ(maybe_macro, "ig", 2))
991 op_null(o); /* don't execute or even remember it */
995 o->op_type = OP_PREINC; /* pre-increment is faster */
996 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1000 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1001 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1005 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1006 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1010 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1011 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1020 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1025 if (o->op_flags & OPf_STACKED)
1032 if (!(o->op_flags & OPf_KIDS))
1043 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1050 /* all requires must return a boolean value */
1051 o->op_flags &= ~OPf_WANT;
1056 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1057 if (!kPMOP->op_pmreplroot)
1058 deprecate_old("implicit split to @_");
1062 if (useless && ckWARN(WARN_VOID))
1063 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1068 Perl_listkids(pTHX_ OP *o)
1070 if (o && o->op_flags & OPf_KIDS) {
1072 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1079 Perl_list(pTHX_ OP *o)
1084 /* assumes no premature commitment */
1085 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1086 || o->op_type == OP_RETURN)
1091 if ((o->op_private & OPpTARGET_MY)
1092 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1094 return o; /* As if inside SASSIGN */
1097 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1099 switch (o->op_type) {
1102 list(cBINOPo->op_first);
1107 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1115 if (!(o->op_flags & OPf_KIDS))
1117 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1118 list(cBINOPo->op_first);
1119 return gen_constant_list(o);
1126 kid = cLISTOPo->op_first;
1128 while ((kid = kid->op_sibling)) {
1129 if (kid->op_sibling)
1134 PL_curcop = &PL_compiling;
1138 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1139 if (kid->op_sibling)
1144 PL_curcop = &PL_compiling;
1147 /* all requires must return a boolean value */
1148 o->op_flags &= ~OPf_WANT;
1155 Perl_scalarseq(pTHX_ OP *o)
1159 const OPCODE type = o->op_type;
1161 if (type == OP_LINESEQ || type == OP_SCOPE ||
1162 type == OP_LEAVE || type == OP_LEAVETRY)
1165 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1166 if (kid->op_sibling) {
1170 PL_curcop = &PL_compiling;
1172 o->op_flags &= ~OPf_PARENS;
1173 if (PL_hints & HINT_BLOCK_SCOPE)
1174 o->op_flags |= OPf_PARENS;
1177 o = newOP(OP_STUB, 0);
1182 S_modkids(pTHX_ OP *o, I32 type)
1184 if (o && o->op_flags & OPf_KIDS) {
1186 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1192 /* Propagate lvalue ("modifiable") context to an op and its children.
1193 * 'type' represents the context type, roughly based on the type of op that
1194 * would do the modifying, although local() is represented by OP_NULL.
1195 * It's responsible for detecting things that can't be modified, flag
1196 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1197 * might have to vivify a reference in $x), and so on.
1199 * For example, "$a+1 = 2" would cause mod() to be called with o being
1200 * OP_ADD and type being OP_SASSIGN, and would output an error.
1204 Perl_mod(pTHX_ OP *o, I32 type)
1208 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1211 if (!o || PL_error_count)
1214 if ((o->op_private & OPpTARGET_MY)
1215 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1220 switch (o->op_type) {
1226 if (!(o->op_private & OPpCONST_ARYBASE))
1229 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1230 CopARYBASE_set(&PL_compiling,
1231 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1235 SAVECOPARYBASE(&PL_compiling);
1236 CopARYBASE_set(&PL_compiling, 0);
1238 else if (type == OP_REFGEN)
1241 Perl_croak(aTHX_ "That use of $[ is unsupported");
1244 if (o->op_flags & OPf_PARENS || PL_madskills)
1248 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1249 !(o->op_flags & OPf_STACKED)) {
1250 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1251 /* The default is to set op_private to the number of children,
1252 which for a UNOP such as RV2CV is always 1. And w're using
1253 the bit for a flag in RV2CV, so we need it clear. */
1254 o->op_private &= ~1;
1255 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1256 assert(cUNOPo->op_first->op_type == OP_NULL);
1257 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1260 else if (o->op_private & OPpENTERSUB_NOMOD)
1262 else { /* lvalue subroutine call */
1263 o->op_private |= OPpLVAL_INTRO;
1264 PL_modcount = RETURN_UNLIMITED_NUMBER;
1265 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1266 /* Backward compatibility mode: */
1267 o->op_private |= OPpENTERSUB_INARGS;
1270 else { /* Compile-time error message: */
1271 OP *kid = cUNOPo->op_first;
1275 if (kid->op_type != OP_PUSHMARK) {
1276 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1278 "panic: unexpected lvalue entersub "
1279 "args: type/targ %ld:%"UVuf,
1280 (long)kid->op_type, (UV)kid->op_targ);
1281 kid = kLISTOP->op_first;
1283 while (kid->op_sibling)
1284 kid = kid->op_sibling;
1285 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1287 if (kid->op_type == OP_METHOD_NAMED
1288 || kid->op_type == OP_METHOD)
1292 NewOp(1101, newop, 1, UNOP);
1293 newop->op_type = OP_RV2CV;
1294 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1295 newop->op_first = NULL;
1296 newop->op_next = (OP*)newop;
1297 kid->op_sibling = (OP*)newop;
1298 newop->op_private |= OPpLVAL_INTRO;
1299 newop->op_private &= ~1;
1303 if (kid->op_type != OP_RV2CV)
1305 "panic: unexpected lvalue entersub "
1306 "entry via type/targ %ld:%"UVuf,
1307 (long)kid->op_type, (UV)kid->op_targ);
1308 kid->op_private |= OPpLVAL_INTRO;
1309 break; /* Postpone until runtime */
1313 kid = kUNOP->op_first;
1314 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1315 kid = kUNOP->op_first;
1316 if (kid->op_type == OP_NULL)
1318 "Unexpected constant lvalue entersub "
1319 "entry via type/targ %ld:%"UVuf,
1320 (long)kid->op_type, (UV)kid->op_targ);
1321 if (kid->op_type != OP_GV) {
1322 /* Restore RV2CV to check lvalueness */
1324 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1325 okid->op_next = kid->op_next;
1326 kid->op_next = okid;
1329 okid->op_next = NULL;
1330 okid->op_type = OP_RV2CV;
1332 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1333 okid->op_private |= OPpLVAL_INTRO;
1334 okid->op_private &= ~1;
1338 cv = GvCV(kGVOP_gv);
1348 /* grep, foreach, subcalls, refgen */
1349 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1351 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1352 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1354 : (o->op_type == OP_ENTERSUB
1355 ? "non-lvalue subroutine call"
1357 type ? PL_op_desc[type] : "local"));
1371 case OP_RIGHT_SHIFT:
1380 if (!(o->op_flags & OPf_STACKED))
1387 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1393 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1394 PL_modcount = RETURN_UNLIMITED_NUMBER;
1395 return o; /* Treat \(@foo) like ordinary list. */
1399 if (scalar_mod_type(o, type))
1401 ref(cUNOPo->op_first, o->op_type);
1405 if (type == OP_LEAVESUBLV)
1406 o->op_private |= OPpMAYBE_LVSUB;
1412 PL_modcount = RETURN_UNLIMITED_NUMBER;
1415 ref(cUNOPo->op_first, o->op_type);
1420 PL_hints |= HINT_BLOCK_SCOPE;
1435 PL_modcount = RETURN_UNLIMITED_NUMBER;
1436 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1437 return o; /* Treat \(@foo) like ordinary list. */
1438 if (scalar_mod_type(o, type))
1440 if (type == OP_LEAVESUBLV)
1441 o->op_private |= OPpMAYBE_LVSUB;
1445 if (!type) /* local() */
1446 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1447 PAD_COMPNAME_PV(o->op_targ));
1455 if (type != OP_SASSIGN)
1459 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1464 if (type == OP_LEAVESUBLV)
1465 o->op_private |= OPpMAYBE_LVSUB;
1467 pad_free(o->op_targ);
1468 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1469 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1470 if (o->op_flags & OPf_KIDS)
1471 mod(cBINOPo->op_first->op_sibling, type);
1476 ref(cBINOPo->op_first, o->op_type);
1477 if (type == OP_ENTERSUB &&
1478 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1479 o->op_private |= OPpLVAL_DEFER;
1480 if (type == OP_LEAVESUBLV)
1481 o->op_private |= OPpMAYBE_LVSUB;
1491 if (o->op_flags & OPf_KIDS)
1492 mod(cLISTOPo->op_last, type);
1497 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1499 else if (!(o->op_flags & OPf_KIDS))
1501 if (o->op_targ != OP_LIST) {
1502 mod(cBINOPo->op_first, type);
1508 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1513 if (type != OP_LEAVESUBLV)
1515 break; /* mod()ing was handled by ck_return() */
1518 /* [20011101.069] File test operators interpret OPf_REF to mean that
1519 their argument is a filehandle; thus \stat(".") should not set
1521 if (type == OP_REFGEN &&
1522 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1525 if (type != OP_LEAVESUBLV)
1526 o->op_flags |= OPf_MOD;
1528 if (type == OP_AASSIGN || type == OP_SASSIGN)
1529 o->op_flags |= OPf_SPECIAL|OPf_REF;
1530 else if (!type) { /* local() */
1533 o->op_private |= OPpLVAL_INTRO;
1534 o->op_flags &= ~OPf_SPECIAL;
1535 PL_hints |= HINT_BLOCK_SCOPE;
1540 if (ckWARN(WARN_SYNTAX)) {
1541 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1542 "Useless localization of %s", OP_DESC(o));
1546 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1547 && type != OP_LEAVESUBLV)
1548 o->op_flags |= OPf_REF;
1553 S_scalar_mod_type(const OP *o, I32 type)
1557 if (o->op_type == OP_RV2GV)
1581 case OP_RIGHT_SHIFT:
1600 S_is_handle_constructor(const OP *o, I32 numargs)
1602 switch (o->op_type) {
1610 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1623 Perl_refkids(pTHX_ OP *o, I32 type)
1625 if (o && o->op_flags & OPf_KIDS) {
1627 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1634 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1639 if (!o || PL_error_count)
1642 switch (o->op_type) {
1644 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1645 !(o->op_flags & OPf_STACKED)) {
1646 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1647 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1648 assert(cUNOPo->op_first->op_type == OP_NULL);
1649 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1650 o->op_flags |= OPf_SPECIAL;
1651 o->op_private &= ~1;
1656 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1657 doref(kid, type, set_op_ref);
1660 if (type == OP_DEFINED)
1661 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1662 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1665 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1666 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1667 : type == OP_RV2HV ? OPpDEREF_HV
1669 o->op_flags |= OPf_MOD;
1676 o->op_flags |= OPf_REF;
1679 if (type == OP_DEFINED)
1680 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1681 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1687 o->op_flags |= OPf_REF;
1692 if (!(o->op_flags & OPf_KIDS))
1694 doref(cBINOPo->op_first, type, set_op_ref);
1698 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1699 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1700 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1701 : type == OP_RV2HV ? OPpDEREF_HV
1703 o->op_flags |= OPf_MOD;
1713 if (!(o->op_flags & OPf_KIDS))
1715 doref(cLISTOPo->op_last, type, set_op_ref);
1725 S_dup_attrlist(pTHX_ OP *o)
1730 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1731 * where the first kid is OP_PUSHMARK and the remaining ones
1732 * are OP_CONST. We need to push the OP_CONST values.
1734 if (o->op_type == OP_CONST)
1735 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1737 else if (o->op_type == OP_NULL)
1741 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1743 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1744 if (o->op_type == OP_CONST)
1745 rop = append_elem(OP_LIST, rop,
1746 newSVOP(OP_CONST, o->op_flags,
1747 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1754 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1759 /* fake up C<use attributes $pkg,$rv,@attrs> */
1760 ENTER; /* need to protect against side-effects of 'use' */
1762 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1764 #define ATTRSMODULE "attributes"
1765 #define ATTRSMODULE_PM "attributes.pm"
1768 /* Don't force the C<use> if we don't need it. */
1769 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1770 if (svp && *svp != &PL_sv_undef)
1771 NOOP; /* already in %INC */
1773 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1774 newSVpvs(ATTRSMODULE), NULL);
1777 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1778 newSVpvs(ATTRSMODULE),
1780 prepend_elem(OP_LIST,
1781 newSVOP(OP_CONST, 0, stashsv),
1782 prepend_elem(OP_LIST,
1783 newSVOP(OP_CONST, 0,
1785 dup_attrlist(attrs))));
1791 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1794 OP *pack, *imop, *arg;
1800 assert(target->op_type == OP_PADSV ||
1801 target->op_type == OP_PADHV ||
1802 target->op_type == OP_PADAV);
1804 /* Ensure that attributes.pm is loaded. */
1805 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1807 /* Need package name for method call. */
1808 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1810 /* Build up the real arg-list. */
1811 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1813 arg = newOP(OP_PADSV, 0);
1814 arg->op_targ = target->op_targ;
1815 arg = prepend_elem(OP_LIST,
1816 newSVOP(OP_CONST, 0, stashsv),
1817 prepend_elem(OP_LIST,
1818 newUNOP(OP_REFGEN, 0,
1819 mod(arg, OP_REFGEN)),
1820 dup_attrlist(attrs)));
1822 /* Fake up a method call to import */
1823 meth = newSVpvs_share("import");
1824 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1825 append_elem(OP_LIST,
1826 prepend_elem(OP_LIST, pack, list(arg)),
1827 newSVOP(OP_METHOD_NAMED, 0, meth)));
1828 imop->op_private |= OPpENTERSUB_NOMOD;
1830 /* Combine the ops. */
1831 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1835 =notfor apidoc apply_attrs_string
1837 Attempts to apply a list of attributes specified by the C<attrstr> and
1838 C<len> arguments to the subroutine identified by the C<cv> argument which
1839 is expected to be associated with the package identified by the C<stashpv>
1840 argument (see L<attributes>). It gets this wrong, though, in that it
1841 does not correctly identify the boundaries of the individual attribute
1842 specifications within C<attrstr>. This is not really intended for the
1843 public API, but has to be listed here for systems such as AIX which
1844 need an explicit export list for symbols. (It's called from XS code
1845 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1846 to respect attribute syntax properly would be welcome.
1852 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1853 const char *attrstr, STRLEN len)
1858 len = strlen(attrstr);
1862 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1864 const char * const sstr = attrstr;
1865 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1866 attrs = append_elem(OP_LIST, attrs,
1867 newSVOP(OP_CONST, 0,
1868 newSVpvn(sstr, attrstr-sstr)));
1872 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1873 newSVpvs(ATTRSMODULE),
1874 NULL, prepend_elem(OP_LIST,
1875 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1876 prepend_elem(OP_LIST,
1877 newSVOP(OP_CONST, 0,
1883 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1888 if (!o || PL_error_count)
1892 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1893 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1897 if (type == OP_LIST) {
1899 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1900 my_kid(kid, attrs, imopsp);
1901 } else if (type == OP_UNDEF
1907 } else if (type == OP_RV2SV || /* "our" declaration */
1909 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1910 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1911 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1913 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1915 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1917 PL_in_my_stash = NULL;
1918 apply_attrs(GvSTASH(gv),
1919 (type == OP_RV2SV ? GvSV(gv) :
1920 type == OP_RV2AV ? (SV*)GvAV(gv) :
1921 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1924 o->op_private |= OPpOUR_INTRO;
1927 else if (type != OP_PADSV &&
1930 type != OP_PUSHMARK)
1932 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1934 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1937 else if (attrs && type != OP_PUSHMARK) {
1941 PL_in_my_stash = NULL;
1943 /* check for C<my Dog $spot> when deciding package */
1944 stash = PAD_COMPNAME_TYPE(o->op_targ);
1946 stash = PL_curstash;
1947 apply_attrs_my(stash, o, attrs, imopsp);
1949 o->op_flags |= OPf_MOD;
1950 o->op_private |= OPpLVAL_INTRO;
1951 if (PL_in_my == KEY_state)
1952 o->op_private |= OPpPAD_STATE;
1957 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1961 int maybe_scalar = 0;
1963 /* [perl #17376]: this appears to be premature, and results in code such as
1964 C< our(%x); > executing in list mode rather than void mode */
1966 if (o->op_flags & OPf_PARENS)
1976 o = my_kid(o, attrs, &rops);
1978 if (maybe_scalar && o->op_type == OP_PADSV) {
1979 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1980 o->op_private |= OPpLVAL_INTRO;
1983 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1986 PL_in_my_stash = NULL;
1991 Perl_my(pTHX_ OP *o)
1993 return my_attrs(o, NULL);
1997 Perl_sawparens(pTHX_ OP *o)
1999 PERL_UNUSED_CONTEXT;
2001 o->op_flags |= OPf_PARENS;
2006 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2010 const OPCODE ltype = left->op_type;
2011 const OPCODE rtype = right->op_type;
2013 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2014 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2016 const char * const desc
2017 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2018 ? (int)rtype : OP_MATCH];
2019 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2020 ? "@array" : "%hash");
2021 Perl_warner(aTHX_ packWARN(WARN_MISC),
2022 "Applying %s to %s will act on scalar(%s)",
2023 desc, sample, sample);
2026 if (rtype == OP_CONST &&
2027 cSVOPx(right)->op_private & OPpCONST_BARE &&
2028 cSVOPx(right)->op_private & OPpCONST_STRICT)
2030 no_bareword_allowed(right);
2033 ismatchop = rtype == OP_MATCH ||
2034 rtype == OP_SUBST ||
2036 if (ismatchop && right->op_private & OPpTARGET_MY) {
2038 right->op_private &= ~OPpTARGET_MY;
2040 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2043 right->op_flags |= OPf_STACKED;
2044 if (rtype != OP_MATCH &&
2045 ! (rtype == OP_TRANS &&
2046 right->op_private & OPpTRANS_IDENTICAL))
2047 newleft = mod(left, rtype);
2050 if (right->op_type == OP_TRANS)
2051 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2053 o = prepend_elem(rtype, scalar(newleft), right);
2055 return newUNOP(OP_NOT, 0, scalar(o));
2059 return bind_match(type, left,
2060 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2064 Perl_invert(pTHX_ OP *o)
2068 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2072 Perl_scope(pTHX_ OP *o)
2076 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2077 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2078 o->op_type = OP_LEAVE;
2079 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2081 else if (o->op_type == OP_LINESEQ) {
2083 o->op_type = OP_SCOPE;
2084 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2085 kid = ((LISTOP*)o)->op_first;
2086 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2089 /* The following deals with things like 'do {1 for 1}' */
2090 kid = kid->op_sibling;
2092 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2097 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2103 Perl_block_start(pTHX_ int full)
2106 const int retval = PL_savestack_ix;
2107 pad_block_start(full);
2109 PL_hints &= ~HINT_BLOCK_SCOPE;
2110 SAVECOMPILEWARNINGS();
2111 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2116 Perl_block_end(pTHX_ I32 floor, OP *seq)
2119 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2120 OP* const retval = scalarseq(seq);
2122 CopHINTS_set(&PL_compiling, PL_hints);
2124 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2133 const PADOFFSET offset = pad_findmy("$_");
2134 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2135 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2138 OP * const o = newOP(OP_PADSV, 0);
2139 o->op_targ = offset;
2145 Perl_newPROG(pTHX_ OP *o)
2151 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2152 ((PL_in_eval & EVAL_KEEPERR)
2153 ? OPf_SPECIAL : 0), o);
2154 PL_eval_start = linklist(PL_eval_root);
2155 PL_eval_root->op_private |= OPpREFCOUNTED;
2156 OpREFCNT_set(PL_eval_root, 1);
2157 PL_eval_root->op_next = 0;
2158 CALL_PEEP(PL_eval_start);
2161 if (o->op_type == OP_STUB) {
2162 PL_comppad_name = 0;
2164 S_op_destroy(aTHX_ o);
2167 PL_main_root = scope(sawparens(scalarvoid(o)));
2168 PL_curcop = &PL_compiling;
2169 PL_main_start = LINKLIST(PL_main_root);
2170 PL_main_root->op_private |= OPpREFCOUNTED;
2171 OpREFCNT_set(PL_main_root, 1);
2172 PL_main_root->op_next = 0;
2173 CALL_PEEP(PL_main_start);
2176 /* Register with debugger */
2179 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2183 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2185 call_sv((SV*)cv, G_DISCARD);
2192 Perl_localize(pTHX_ OP *o, I32 lex)
2195 if (o->op_flags & OPf_PARENS)
2196 /* [perl #17376]: this appears to be premature, and results in code such as
2197 C< our(%x); > executing in list mode rather than void mode */
2204 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2205 && ckWARN(WARN_PARENTHESIS))
2207 char *s = PL_bufptr;
2210 /* some heuristics to detect a potential error */
2211 while (*s && (strchr(", \t\n", *s)))
2215 if (*s && strchr("@$%*", *s) && *++s
2216 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2219 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2221 while (*s && (strchr(", \t\n", *s)))
2227 if (sigil && (*s == ';' || *s == '=')) {
2228 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2229 "Parentheses missing around \"%s\" list",
2230 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2238 o = mod(o, OP_NULL); /* a bit kludgey */
2240 PL_in_my_stash = NULL;
2245 Perl_jmaybe(pTHX_ OP *o)
2247 if (o->op_type == OP_LIST) {
2249 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2250 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2256 Perl_fold_constants(pTHX_ register OP *o)
2261 VOL I32 type = o->op_type;
2266 SV * const oldwarnhook = PL_warnhook;
2267 SV * const olddiehook = PL_diehook;
2270 if (PL_opargs[type] & OA_RETSCALAR)
2272 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2273 o->op_targ = pad_alloc(type, SVs_PADTMP);
2275 /* integerize op, unless it happens to be C<-foo>.
2276 * XXX should pp_i_negate() do magic string negation instead? */
2277 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2278 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2279 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2281 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2284 if (!(PL_opargs[type] & OA_FOLDCONST))
2289 /* XXX might want a ck_negate() for this */
2290 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2301 /* XXX what about the numeric ops? */
2302 if (PL_hints & HINT_LOCALE)
2307 goto nope; /* Don't try to run w/ errors */
2309 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2310 const OPCODE type = curop->op_type;
2311 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2313 type != OP_SCALAR &&
2315 type != OP_PUSHMARK)
2321 curop = LINKLIST(o);
2322 old_next = o->op_next;
2326 oldscope = PL_scopestack_ix;
2327 create_eval_scope(G_FAKINGEVAL);
2329 PL_warnhook = PERL_WARNHOOK_FATAL;
2336 sv = *(PL_stack_sp--);
2337 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2338 pad_swipe(o->op_targ, FALSE);
2339 else if (SvTEMP(sv)) { /* grab mortal temp? */
2340 SvREFCNT_inc_simple_void(sv);
2345 /* Something tried to die. Abandon constant folding. */
2346 /* Pretend the error never happened. */
2347 sv_setpvn(ERRSV,"",0);
2348 o->op_next = old_next;
2352 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2353 PL_warnhook = oldwarnhook;
2354 PL_diehook = olddiehook;
2355 /* XXX note that this croak may fail as we've already blown away
2356 * the stack - eg any nested evals */
2357 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2360 PL_warnhook = oldwarnhook;
2361 PL_diehook = olddiehook;
2363 if (PL_scopestack_ix > oldscope)
2364 delete_eval_scope();
2373 if (type == OP_RV2GV)
2374 newop = newGVOP(OP_GV, 0, (GV*)sv);
2376 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2377 op_getmad(o,newop,'f');
2385 Perl_gen_constant_list(pTHX_ register OP *o)
2389 const I32 oldtmps_floor = PL_tmps_floor;
2393 return o; /* Don't attempt to run with errors */
2395 PL_op = curop = LINKLIST(o);
2401 assert (!(curop->op_flags & OPf_SPECIAL));
2402 assert(curop->op_type == OP_RANGE);
2404 PL_tmps_floor = oldtmps_floor;
2406 o->op_type = OP_RV2AV;
2407 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2408 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2409 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2410 o->op_opt = 0; /* needs to be revisited in peep() */
2411 curop = ((UNOP*)o)->op_first;
2412 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2414 op_getmad(curop,o,'O');
2423 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2426 if (!o || o->op_type != OP_LIST)
2427 o = newLISTOP(OP_LIST, 0, o, NULL);
2429 o->op_flags &= ~OPf_WANT;
2431 if (!(PL_opargs[type] & OA_MARK))
2432 op_null(cLISTOPo->op_first);
2434 o->op_type = (OPCODE)type;
2435 o->op_ppaddr = PL_ppaddr[type];
2436 o->op_flags |= flags;
2438 o = CHECKOP(type, o);
2439 if (o->op_type != (unsigned)type)
2442 return fold_constants(o);
2445 /* List constructors */
2448 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2456 if (first->op_type != (unsigned)type
2457 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2459 return newLISTOP(type, 0, first, last);
2462 if (first->op_flags & OPf_KIDS)
2463 ((LISTOP*)first)->op_last->op_sibling = last;
2465 first->op_flags |= OPf_KIDS;
2466 ((LISTOP*)first)->op_first = last;
2468 ((LISTOP*)first)->op_last = last;
2473 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2481 if (first->op_type != (unsigned)type)
2482 return prepend_elem(type, (OP*)first, (OP*)last);
2484 if (last->op_type != (unsigned)type)
2485 return append_elem(type, (OP*)first, (OP*)last);
2487 first->op_last->op_sibling = last->op_first;
2488 first->op_last = last->op_last;
2489 first->op_flags |= (last->op_flags & OPf_KIDS);
2492 if (last->op_first && first->op_madprop) {
2493 MADPROP *mp = last->op_first->op_madprop;
2495 while (mp->mad_next)
2497 mp->mad_next = first->op_madprop;
2500 last->op_first->op_madprop = first->op_madprop;
2503 first->op_madprop = last->op_madprop;
2504 last->op_madprop = 0;
2507 S_op_destroy(aTHX_ (OP*)last);
2513 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2521 if (last->op_type == (unsigned)type) {
2522 if (type == OP_LIST) { /* already a PUSHMARK there */
2523 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2524 ((LISTOP*)last)->op_first->op_sibling = first;
2525 if (!(first->op_flags & OPf_PARENS))
2526 last->op_flags &= ~OPf_PARENS;
2529 if (!(last->op_flags & OPf_KIDS)) {
2530 ((LISTOP*)last)->op_last = first;
2531 last->op_flags |= OPf_KIDS;
2533 first->op_sibling = ((LISTOP*)last)->op_first;
2534 ((LISTOP*)last)->op_first = first;
2536 last->op_flags |= OPf_KIDS;
2540 return newLISTOP(type, 0, first, last);
2548 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2551 Newxz(tk, 1, TOKEN);
2552 tk->tk_type = (OPCODE)optype;
2553 tk->tk_type = 12345;
2555 tk->tk_mad = madprop;
2560 Perl_token_free(pTHX_ TOKEN* tk)
2562 if (tk->tk_type != 12345)
2564 mad_free(tk->tk_mad);
2569 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2573 if (tk->tk_type != 12345) {
2574 Perl_warner(aTHX_ packWARN(WARN_MISC),
2575 "Invalid TOKEN object ignored");
2582 /* faked up qw list? */
2584 tm->mad_type == MAD_SV &&
2585 SvPVX((SV*)tm->mad_val)[0] == 'q')
2592 /* pretend constant fold didn't happen? */
2593 if (mp->mad_key == 'f' &&
2594 (o->op_type == OP_CONST ||
2595 o->op_type == OP_GV) )
2597 token_getmad(tk,(OP*)mp->mad_val,slot);
2611 if (mp->mad_key == 'X')
2612 mp->mad_key = slot; /* just change the first one */
2622 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2631 /* pretend constant fold didn't happen? */
2632 if (mp->mad_key == 'f' &&
2633 (o->op_type == OP_CONST ||
2634 o->op_type == OP_GV) )
2636 op_getmad(from,(OP*)mp->mad_val,slot);
2643 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2646 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2652 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2661 /* pretend constant fold didn't happen? */
2662 if (mp->mad_key == 'f' &&
2663 (o->op_type == OP_CONST ||
2664 o->op_type == OP_GV) )
2666 op_getmad(from,(OP*)mp->mad_val,slot);
2673 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2676 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2680 PerlIO_printf(PerlIO_stderr(),
2681 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2687 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2705 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2709 addmad(tm, &(o->op_madprop), slot);
2713 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2734 Perl_newMADsv(pTHX_ char key, SV* sv)
2736 return newMADPROP(key, MAD_SV, sv, 0);
2740 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2743 Newxz(mp, 1, MADPROP);
2746 mp->mad_vlen = vlen;
2747 mp->mad_type = type;
2749 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2754 Perl_mad_free(pTHX_ MADPROP* mp)
2756 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2760 mad_free(mp->mad_next);
2761 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2762 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2763 switch (mp->mad_type) {
2767 Safefree((char*)mp->mad_val);
2770 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2771 op_free((OP*)mp->mad_val);
2774 sv_free((SV*)mp->mad_val);
2777 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2786 Perl_newNULLLIST(pTHX)
2788 return newOP(OP_STUB, 0);
2792 Perl_force_list(pTHX_ OP *o)
2794 if (!o || o->op_type != OP_LIST)
2795 o = newLISTOP(OP_LIST, 0, o, NULL);
2801 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2806 NewOp(1101, listop, 1, LISTOP);
2808 listop->op_type = (OPCODE)type;
2809 listop->op_ppaddr = PL_ppaddr[type];
2812 listop->op_flags = (U8)flags;
2816 else if (!first && last)
2819 first->op_sibling = last;
2820 listop->op_first = first;
2821 listop->op_last = last;
2822 if (type == OP_LIST) {
2823 OP* const pushop = newOP(OP_PUSHMARK, 0);
2824 pushop->op_sibling = first;
2825 listop->op_first = pushop;
2826 listop->op_flags |= OPf_KIDS;
2828 listop->op_last = pushop;
2831 return CHECKOP(type, listop);
2835 Perl_newOP(pTHX_ I32 type, I32 flags)
2839 NewOp(1101, o, 1, OP);
2840 o->op_type = (OPCODE)type;
2841 o->op_ppaddr = PL_ppaddr[type];
2842 o->op_flags = (U8)flags;
2844 o->op_latefreed = 0;
2848 o->op_private = (U8)(0 | (flags >> 8));
2849 if (PL_opargs[type] & OA_RETSCALAR)
2851 if (PL_opargs[type] & OA_TARGET)
2852 o->op_targ = pad_alloc(type, SVs_PADTMP);
2853 return CHECKOP(type, o);
2857 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2863 first = newOP(OP_STUB, 0);
2864 if (PL_opargs[type] & OA_MARK)
2865 first = force_list(first);
2867 NewOp(1101, unop, 1, UNOP);
2868 unop->op_type = (OPCODE)type;
2869 unop->op_ppaddr = PL_ppaddr[type];
2870 unop->op_first = first;
2871 unop->op_flags = (U8)(flags | OPf_KIDS);
2872 unop->op_private = (U8)(1 | (flags >> 8));
2873 unop = (UNOP*) CHECKOP(type, unop);
2877 return fold_constants((OP *) unop);
2881 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2885 NewOp(1101, binop, 1, BINOP);
2888 first = newOP(OP_NULL, 0);
2890 binop->op_type = (OPCODE)type;
2891 binop->op_ppaddr = PL_ppaddr[type];
2892 binop->op_first = first;
2893 binop->op_flags = (U8)(flags | OPf_KIDS);
2896 binop->op_private = (U8)(1 | (flags >> 8));
2899 binop->op_private = (U8)(2 | (flags >> 8));
2900 first->op_sibling = last;
2903 binop = (BINOP*)CHECKOP(type, binop);
2904 if (binop->op_next || binop->op_type != (OPCODE)type)
2907 binop->op_last = binop->op_first->op_sibling;
2909 return fold_constants((OP *)binop);
2912 static int uvcompare(const void *a, const void *b)
2913 __attribute__nonnull__(1)
2914 __attribute__nonnull__(2)
2915 __attribute__pure__;
2916 static int uvcompare(const void *a, const void *b)
2918 if (*((const UV *)a) < (*(const UV *)b))
2920 if (*((const UV *)a) > (*(const UV *)b))
2922 if (*((const UV *)a+1) < (*(const UV *)b+1))
2924 if (*((const UV *)a+1) > (*(const UV *)b+1))
2930 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2933 SV * const tstr = ((SVOP*)expr)->op_sv;
2936 (repl->op_type == OP_NULL)
2937 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2939 ((SVOP*)repl)->op_sv;
2942 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2943 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2947 register short *tbl;
2949 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2950 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2951 I32 del = o->op_private & OPpTRANS_DELETE;
2953 PL_hints |= HINT_BLOCK_SCOPE;
2956 o->op_private |= OPpTRANS_FROM_UTF;
2959 o->op_private |= OPpTRANS_TO_UTF;
2961 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2962 SV* const listsv = newSVpvs("# comment\n");
2964 const U8* tend = t + tlen;
2965 const U8* rend = r + rlen;
2979 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2980 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2983 const U32 flags = UTF8_ALLOW_DEFAULT;
2987 t = tsave = bytes_to_utf8(t, &len);
2990 if (!to_utf && rlen) {
2992 r = rsave = bytes_to_utf8(r, &len);
2996 /* There are several snags with this code on EBCDIC:
2997 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2998 2. scan_const() in toke.c has encoded chars in native encoding which makes
2999 ranges at least in EBCDIC 0..255 range the bottom odd.
3003 U8 tmpbuf[UTF8_MAXBYTES+1];
3006 Newx(cp, 2*tlen, UV);
3008 transv = newSVpvs("");
3010 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3012 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3014 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3018 cp[2*i+1] = cp[2*i];
3022 qsort(cp, i, 2*sizeof(UV), uvcompare);
3023 for (j = 0; j < i; j++) {
3025 diff = val - nextmin;
3027 t = uvuni_to_utf8(tmpbuf,nextmin);
3028 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3030 U8 range_mark = UTF_TO_NATIVE(0xff);
3031 t = uvuni_to_utf8(tmpbuf, val - 1);
3032 sv_catpvn(transv, (char *)&range_mark, 1);
3033 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3040 t = uvuni_to_utf8(tmpbuf,nextmin);
3041 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3043 U8 range_mark = UTF_TO_NATIVE(0xff);
3044 sv_catpvn(transv, (char *)&range_mark, 1);
3046 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3047 UNICODE_ALLOW_SUPER);
3048 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3049 t = (const U8*)SvPVX_const(transv);
3050 tlen = SvCUR(transv);
3054 else if (!rlen && !del) {
3055 r = t; rlen = tlen; rend = tend;
3058 if ((!rlen && !del) || t == r ||
3059 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3061 o->op_private |= OPpTRANS_IDENTICAL;
3065 while (t < tend || tfirst <= tlast) {
3066 /* see if we need more "t" chars */
3067 if (tfirst > tlast) {
3068 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3070 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3072 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3079 /* now see if we need more "r" chars */
3080 if (rfirst > rlast) {
3082 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3084 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3086 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3095 rfirst = rlast = 0xffffffff;
3099 /* now see which range will peter our first, if either. */
3100 tdiff = tlast - tfirst;
3101 rdiff = rlast - rfirst;
3108 if (rfirst == 0xffffffff) {
3109 diff = tdiff; /* oops, pretend rdiff is infinite */
3111 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3112 (long)tfirst, (long)tlast);
3114 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3118 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3119 (long)tfirst, (long)(tfirst + diff),
3122 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3123 (long)tfirst, (long)rfirst);
3125 if (rfirst + diff > max)
3126 max = rfirst + diff;
3128 grows = (tfirst < rfirst &&
3129 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3141 else if (max > 0xff)
3146 PerlMemShared_free(cPVOPo->op_pv);
3147 cPVOPo->op_pv = NULL;
3149 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3151 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3152 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3153 PAD_SETSV(cPADOPo->op_padix, swash);
3156 cSVOPo->op_sv = swash;
3158 SvREFCNT_dec(listsv);
3159 SvREFCNT_dec(transv);
3161 if (!del && havefinal && rlen)
3162 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3163 newSVuv((UV)final), 0);
3166 o->op_private |= OPpTRANS_GROWS;
3172 op_getmad(expr,o,'e');
3173 op_getmad(repl,o,'r');
3181 tbl = (short*)cPVOPo->op_pv;
3183 Zero(tbl, 256, short);
3184 for (i = 0; i < (I32)tlen; i++)
3186 for (i = 0, j = 0; i < 256; i++) {
3188 if (j >= (I32)rlen) {
3197 if (i < 128 && r[j] >= 128)
3207 o->op_private |= OPpTRANS_IDENTICAL;
3209 else if (j >= (I32)rlen)
3214 PerlMemShared_realloc(tbl,
3215 (0x101+rlen-j) * sizeof(short));
3216 cPVOPo->op_pv = (char*)tbl;
3218 tbl[0x100] = (short)(rlen - j);
3219 for (i=0; i < (I32)rlen - j; i++)
3220 tbl[0x101+i] = r[j+i];
3224 if (!rlen && !del) {
3227 o->op_private |= OPpTRANS_IDENTICAL;
3229 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3230 o->op_private |= OPpTRANS_IDENTICAL;
3232 for (i = 0; i < 256; i++)
3234 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3235 if (j >= (I32)rlen) {
3237 if (tbl[t[i]] == -1)
3243 if (tbl[t[i]] == -1) {
3244 if (t[i] < 128 && r[j] >= 128)
3251 o->op_private |= OPpTRANS_GROWS;
3253 op_getmad(expr,o,'e');
3254 op_getmad(repl,o,'r');
3264 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3269 NewOp(1101, pmop, 1, PMOP);
3270 pmop->op_type = (OPCODE)type;
3271 pmop->op_ppaddr = PL_ppaddr[type];
3272 pmop->op_flags = (U8)flags;
3273 pmop->op_private = (U8)(0 | (flags >> 8));
3275 if (PL_hints & HINT_RE_TAINT)
3276 pmop->op_pmflags |= PMf_RETAINT;
3277 if (PL_hints & HINT_LOCALE)
3278 pmop->op_pmflags |= PMf_LOCALE;
3282 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3283 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3284 pmop->op_pmoffset = SvIV(repointer);
3285 SvREPADTMP_off(repointer);
3286 sv_setiv(repointer,0);
3288 SV * const repointer = newSViv(0);
3289 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3290 pmop->op_pmoffset = av_len(PL_regex_padav);
3291 PL_regex_pad = AvARRAY(PL_regex_padav);
3295 /* link into pm list */
3296 if (type != OP_TRANS && PL_curstash) {
3297 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3300 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3302 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3303 mg->mg_obj = (SV*)pmop;
3304 PmopSTASH_set(pmop,PL_curstash);
3307 return CHECKOP(type, pmop);
3310 /* Given some sort of match op o, and an expression expr containing a
3311 * pattern, either compile expr into a regex and attach it to o (if it's
3312 * constant), or convert expr into a runtime regcomp op sequence (if it's
3315 * isreg indicates that the pattern is part of a regex construct, eg
3316 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3317 * split "pattern", which aren't. In the former case, expr will be a list
3318 * if the pattern contains more than one term (eg /a$b/) or if it contains
3319 * a replacement, ie s/// or tr///.
3323 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3328 I32 repl_has_vars = 0;
3332 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3333 /* last element in list is the replacement; pop it */
3335 repl = cLISTOPx(expr)->op_last;
3336 kid = cLISTOPx(expr)->op_first;
3337 while (kid->op_sibling != repl)
3338 kid = kid->op_sibling;
3339 kid->op_sibling = NULL;
3340 cLISTOPx(expr)->op_last = kid;
3343 if (isreg && expr->op_type == OP_LIST &&
3344 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3346 /* convert single element list to element */
3347 OP* const oe = expr;
3348 expr = cLISTOPx(oe)->op_first->op_sibling;
3349 cLISTOPx(oe)->op_first->op_sibling = NULL;
3350 cLISTOPx(oe)->op_last = NULL;
3354 if (o->op_type == OP_TRANS) {
3355 return pmtrans(o, expr, repl);
3358 reglist = isreg && expr->op_type == OP_LIST;
3362 PL_hints |= HINT_BLOCK_SCOPE;
3365 if (expr->op_type == OP_CONST) {
3367 SV * const pat = ((SVOP*)expr)->op_sv;
3368 const char *p = SvPV_const(pat, plen);
3369 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3370 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
3371 U32 was_readonly = SvREADONLY(pat);
3375 sv_force_normal_flags(pat, 0);
3376 assert(!SvREADONLY(pat));
3379 SvREADONLY_off(pat);
3383 sv_setpvn(pat, "\\s+", 3);
3385 SvFLAGS(pat) |= was_readonly;
3387 p = SvPV_const(pat, plen);
3388 pm_flags |= RXf_SKIPWHITE;
3391 pm_flags |= RXf_UTF8;
3392 /* FIXME - can we make this function take const char * args? */
3393 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm_flags));
3396 op_getmad(expr,(OP*)pm,'e');
3402 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3403 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3405 : OP_REGCMAYBE),0,expr);
3407 NewOp(1101, rcop, 1, LOGOP);
3408 rcop->op_type = OP_REGCOMP;
3409 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3410 rcop->op_first = scalar(expr);
3411 rcop->op_flags |= OPf_KIDS
3412 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3413 | (reglist ? OPf_STACKED : 0);
3414 rcop->op_private = 1;
3417 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3419 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3422 /* establish postfix order */
3423 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3425 rcop->op_next = expr;
3426 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3429 rcop->op_next = LINKLIST(expr);
3430 expr->op_next = (OP*)rcop;
3433 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3438 if (pm->op_pmflags & PMf_EVAL) {
3440 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3441 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3443 else if (repl->op_type == OP_CONST)
3447 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3448 if (curop->op_type == OP_SCOPE
3449 || curop->op_type == OP_LEAVE
3450 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3451 if (curop->op_type == OP_GV) {
3452 GV * const gv = cGVOPx_gv(curop);
3454 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3457 else if (curop->op_type == OP_RV2CV)
3459 else if (curop->op_type == OP_RV2SV ||
3460 curop->op_type == OP_RV2AV ||
3461 curop->op_type == OP_RV2HV ||
3462 curop->op_type == OP_RV2GV) {
3463 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3466 else if (curop->op_type == OP_PADSV ||
3467 curop->op_type == OP_PADAV ||
3468 curop->op_type == OP_PADHV ||
3469 curop->op_type == OP_PADANY)
3473 else if (curop->op_type == OP_PUSHRE)
3474 NOOP; /* Okay here, dangerous in newASSIGNOP */
3484 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3486 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3487 prepend_elem(o->op_type, scalar(repl), o);
3490 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3491 pm->op_pmflags |= PMf_MAYBE_CONST;
3493 NewOp(1101, rcop, 1, LOGOP);
3494 rcop->op_type = OP_SUBSTCONT;
3495 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3496 rcop->op_first = scalar(repl);
3497 rcop->op_flags |= OPf_KIDS;
3498 rcop->op_private = 1;
3501 /* establish postfix order */
3502 rcop->op_next = LINKLIST(repl);
3503 repl->op_next = (OP*)rcop;
3505 pm->op_pmreplroot = scalar((OP*)rcop);
3506 pm->op_pmreplstart = LINKLIST(rcop);
3515 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3519 NewOp(1101, svop, 1, SVOP);
3520 svop->op_type = (OPCODE)type;
3521 svop->op_ppaddr = PL_ppaddr[type];
3523 svop->op_next = (OP*)svop;
3524 svop->op_flags = (U8)flags;
3525 if (PL_opargs[type] & OA_RETSCALAR)
3527 if (PL_opargs[type] & OA_TARGET)
3528 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3529 return CHECKOP(type, svop);
3534 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3538 NewOp(1101, padop, 1, PADOP);
3539 padop->op_type = (OPCODE)type;
3540 padop->op_ppaddr = PL_ppaddr[type];
3541 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3542 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3543 PAD_SETSV(padop->op_padix, sv);
3546 padop->op_next = (OP*)padop;
3547 padop->op_flags = (U8)flags;
3548 if (PL_opargs[type] & OA_RETSCALAR)
3550 if (PL_opargs[type] & OA_TARGET)
3551 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3552 return CHECKOP(type, padop);
3557 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3563 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3565 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3570 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3574 NewOp(1101, pvop, 1, PVOP);
3575 pvop->op_type = (OPCODE)type;
3576 pvop->op_ppaddr = PL_ppaddr[type];
3578 pvop->op_next = (OP*)pvop;
3579 pvop->op_flags = (U8)flags;
3580 if (PL_opargs[type] & OA_RETSCALAR)
3582 if (PL_opargs[type] & OA_TARGET)
3583 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3584 return CHECKOP(type, pvop);
3592 Perl_package(pTHX_ OP *o)
3595 SV *const sv = cSVOPo->op_sv;
3600 save_hptr(&PL_curstash);
3601 save_item(PL_curstname);
3603 PL_curstash = gv_stashsv(sv, GV_ADD);
3604 sv_setsv(PL_curstname, sv);
3606 PL_hints |= HINT_BLOCK_SCOPE;
3607 PL_copline = NOLINE;
3613 if (!PL_madskills) {
3618 pegop = newOP(OP_NULL,0);
3619 op_getmad(o,pegop,'P');
3629 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3636 OP *pegop = newOP(OP_NULL,0);
3639 if (idop->op_type != OP_CONST)
3640 Perl_croak(aTHX_ "Module name must be constant");
3643 op_getmad(idop,pegop,'U');
3648 SV * const vesv = ((SVOP*)version)->op_sv;
3651 op_getmad(version,pegop,'V');
3652 if (!arg && !SvNIOKp(vesv)) {
3659 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3660 Perl_croak(aTHX_ "Version number must be constant number");
3662 /* Make copy of idop so we don't free it twice */
3663 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3665 /* Fake up a method call to VERSION */
3666 meth = newSVpvs_share("VERSION");
3667 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3668 append_elem(OP_LIST,
3669 prepend_elem(OP_LIST, pack, list(version)),
3670 newSVOP(OP_METHOD_NAMED, 0, meth)));
3674 /* Fake up an import/unimport */
3675 if (arg && arg->op_type == OP_STUB) {
3677 op_getmad(arg,pegop,'S');
3678 imop = arg; /* no import on explicit () */
3680 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3681 imop = NULL; /* use 5.0; */
3683 idop->op_private |= OPpCONST_NOVER;
3689 op_getmad(arg,pegop,'A');
3691 /* Make copy of idop so we don't free it twice */
3692 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3694 /* Fake up a method call to import/unimport */
3696 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3697 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3698 append_elem(OP_LIST,
3699 prepend_elem(OP_LIST, pack, list(arg)),
3700 newSVOP(OP_METHOD_NAMED, 0, meth)));
3703 /* Fake up the BEGIN {}, which does its thing immediately. */
3705 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3708 append_elem(OP_LINESEQ,
3709 append_elem(OP_LINESEQ,
3710 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3711 newSTATEOP(0, NULL, veop)),
3712 newSTATEOP(0, NULL, imop) ));
3714 /* The "did you use incorrect case?" warning used to be here.
3715 * The problem is that on case-insensitive filesystems one
3716 * might get false positives for "use" (and "require"):
3717 * "use Strict" or "require CARP" will work. This causes
3718 * portability problems for the script: in case-strict
3719 * filesystems the script will stop working.
3721 * The "incorrect case" warning checked whether "use Foo"
3722 * imported "Foo" to your namespace, but that is wrong, too:
3723 * there is no requirement nor promise in the language that
3724 * a Foo.pm should or would contain anything in package "Foo".
3726 * There is very little Configure-wise that can be done, either:
3727 * the case-sensitivity of the build filesystem of Perl does not
3728 * help in guessing the case-sensitivity of the runtime environment.
3731 PL_hints |= HINT_BLOCK_SCOPE;
3732 PL_copline = NOLINE;
3734 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3737 if (!PL_madskills) {
3738 /* FIXME - don't allocate pegop if !PL_madskills */
3747 =head1 Embedding Functions
3749 =for apidoc load_module
3751 Loads the module whose name is pointed to by the string part of name.
3752 Note that the actual module name, not its filename, should be given.
3753 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3754 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3755 (or 0 for no flags). ver, if specified, provides version semantics
3756 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3757 arguments can be used to specify arguments to the module's import()
3758 method, similar to C<use Foo::Bar VERSION LIST>.
3763 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3766 va_start(args, ver);
3767 vload_module(flags, name, ver, &args);
3771 #ifdef PERL_IMPLICIT_CONTEXT
3773 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3777 va_start(args, ver);
3778 vload_module(flags, name, ver, &args);
3784 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3789 OP * const modname = newSVOP(OP_CONST, 0, name);
3790 modname->op_private |= OPpCONST_BARE;
3792 veop = newSVOP(OP_CONST, 0, ver);
3796 if (flags & PERL_LOADMOD_NOIMPORT) {
3797 imop = sawparens(newNULLLIST());
3799 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3800 imop = va_arg(*args, OP*);
3805 sv = va_arg(*args, SV*);
3807 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3808 sv = va_arg(*args, SV*);
3812 const line_t ocopline = PL_copline;
3813 COP * const ocurcop = PL_curcop;
3814 const int oexpect = PL_expect;
3816 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3817 veop, modname, imop);
3818 PL_expect = oexpect;
3819 PL_copline = ocopline;
3820 PL_curcop = ocurcop;
3825 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3831 if (!force_builtin) {
3832 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3833 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3834 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3835 gv = gvp ? *gvp : NULL;
3839 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3840 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3841 append_elem(OP_LIST, term,
3842 scalar(newUNOP(OP_RV2CV, 0,
3843 newGVOP(OP_GV, 0, gv))))));
3846 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3852 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3854 return newBINOP(OP_LSLICE, flags,
3855 list(force_list(subscript)),
3856 list(force_list(listval)) );
3860 S_is_list_assignment(pTHX_ register const OP *o)
3868 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3869 o = cUNOPo->op_first;
3871 flags = o->op_flags;
3873 if (type == OP_COND_EXPR) {
3874 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3875 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3880 yyerror("Assignment to both a list and a scalar");
3884 if (type == OP_LIST &&
3885 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3886 o->op_private & OPpLVAL_INTRO)
3889 if (type == OP_LIST || flags & OPf_PARENS ||
3890 type == OP_RV2AV || type == OP_RV2HV ||
3891 type == OP_ASLICE || type == OP_HSLICE)
3894 if (type == OP_PADAV || type == OP_PADHV)
3897 if (type == OP_RV2SV)
3904 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3910 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3911 return newLOGOP(optype, 0,
3912 mod(scalar(left), optype),
3913 newUNOP(OP_SASSIGN, 0, scalar(right)));
3916 return newBINOP(optype, OPf_STACKED,
3917 mod(scalar(left), optype), scalar(right));
3921 if (is_list_assignment(left)) {
3925 /* Grandfathering $[ assignment here. Bletch.*/
3926 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3927 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3928 left = mod(left, OP_AASSIGN);
3931 else if (left->op_type == OP_CONST) {
3933 /* Result of assignment is always 1 (or we'd be dead already) */
3934 return newSVOP(OP_CONST, 0, newSViv(1));
3936 curop = list(force_list(left));
3937 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3938 o->op_private = (U8)(0 | (flags >> 8));
3940 /* PL_generation sorcery:
3941 * an assignment like ($a,$b) = ($c,$d) is easier than
3942 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3943 * To detect whether there are common vars, the global var
3944 * PL_generation is incremented for each assign op we compile.
3945 * Then, while compiling the assign op, we run through all the
3946 * variables on both sides of the assignment, setting a spare slot
3947 * in each of them to PL_generation. If any of them already have
3948 * that value, we know we've got commonality. We could use a
3949 * single bit marker, but then we'd have to make 2 passes, first
3950 * to clear the flag, then to test and set it. To find somewhere
3951 * to store these values, evil chicanery is done with SvUVX().
3957 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3958 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3959 if (curop->op_type == OP_GV) {
3960 GV *gv = cGVOPx_gv(curop);
3962 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3964 GvASSIGN_GENERATION_set(gv, PL_generation);
3966 else if (curop->op_type == OP_PADSV ||
3967 curop->op_type == OP_PADAV ||
3968 curop->op_type == OP_PADHV ||
3969 curop->op_type == OP_PADANY)
3971 if (PAD_COMPNAME_GEN(curop->op_targ)
3972 == (STRLEN)PL_generation)
3974 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3977 else if (curop->op_type == OP_RV2CV)
3979 else if (curop->op_type == OP_RV2SV ||
3980 curop->op_type == OP_RV2AV ||
3981 curop->op_type == OP_RV2HV ||
3982 curop->op_type == OP_RV2GV) {
3983 if (lastop->op_type != OP_GV) /* funny deref? */
3986 else if (curop->op_type == OP_PUSHRE) {
3987 if (((PMOP*)curop)->op_pmreplroot) {
3989 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3990 ((PMOP*)curop)->op_pmreplroot));
3992 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3995 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3997 GvASSIGN_GENERATION_set(gv, PL_generation);
3998 GvASSIGN_GENERATION_set(gv, PL_generation);
4007 o->op_private |= OPpASSIGN_COMMON;
4010 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
4011 && (left->op_type == OP_LIST
4012 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4014 OP* lop = ((LISTOP*)left)->op_first;
4016 if (lop->op_type == OP_PADSV ||
4017 lop->op_type == OP_PADAV ||
4018 lop->op_type == OP_PADHV ||
4019 lop->op_type == OP_PADANY)
4021 if (lop->op_private & OPpPAD_STATE) {
4022 if (left->op_private & OPpLVAL_INTRO) {
4023 o->op_private |= OPpASSIGN_STATE;
4024 /* hijacking PADSTALE for uninitialized state variables */
4025 SvPADSTALE_on(PAD_SVl(lop->op_targ));
4027 else { /* we already checked for WARN_MISC before */
4028 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
4029 PAD_COMPNAME_PV(lop->op_targ));
4033 lop = lop->op_sibling;
4036 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4037 == (OPpLVAL_INTRO | OPpPAD_STATE))
4038 && ( left->op_type == OP_PADSV
4039 || left->op_type == OP_PADAV
4040 || left->op_type == OP_PADHV
4041 || left->op_type == OP_PADANY))
4043 o->op_private |= OPpASSIGN_STATE;
4044 /* hijacking PADSTALE for uninitialized state variables */
4045 SvPADSTALE_on(PAD_SVl(left->op_targ));
4048 if (right && right->op_type == OP_SPLIT) {
4049 OP* tmpop = ((LISTOP*)right)->op_first;
4050 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4051 PMOP * const pm = (PMOP*)tmpop;
4052 if (left->op_type == OP_RV2AV &&
4053 !(left->op_private & OPpLVAL_INTRO) &&
4054 !(o->op_private & OPpASSIGN_COMMON) )
4056 tmpop = ((UNOP*)left)->op_first;
4057 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
4059 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
4060 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4062 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
4063 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4065 pm->op_pmflags |= PMf_ONCE;
4066 tmpop = cUNOPo->op_first; /* to list (nulled) */
4067 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4068 tmpop->op_sibling = NULL; /* don't free split */
4069 right->op_next = tmpop->op_next; /* fix starting loc */
4071 op_getmad(o,right,'R'); /* blow off assign */
4073 op_free(o); /* blow off assign */
4075 right->op_flags &= ~OPf_WANT;
4076 /* "I don't know and I don't care." */
4081 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4082 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4084 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4086 sv_setiv(sv, PL_modcount+1);
4094 right = newOP(OP_UNDEF, 0);
4095 if (right->op_type == OP_READLINE) {
4096 right->op_flags |= OPf_STACKED;
4097 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4100 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4101 o = newBINOP(OP_SASSIGN, flags,
4102 scalar(right), mod(scalar(left), OP_SASSIGN) );
4108 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4109 o->op_private |= OPpCONST_ARYBASE;
4116 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4119 const U32 seq = intro_my();
4122 NewOp(1101, cop, 1, COP);
4123 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4124 cop->op_type = OP_DBSTATE;
4125 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4128 cop->op_type = OP_NEXTSTATE;
4129 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4131 cop->op_flags = (U8)flags;
4132 CopHINTS_set(cop, PL_hints);
4134 cop->op_private |= NATIVE_HINTS;
4136 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4137 cop->op_next = (OP*)cop;
4140 CopLABEL_set(cop, label);
4141 PL_hints |= HINT_BLOCK_SCOPE;
4144 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4145 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4147 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4148 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4149 if (cop->cop_hints_hash) {
4151 cop->cop_hints_hash->refcounted_he_refcnt++;
4152 HINTS_REFCNT_UNLOCK;
4155 if (PL_copline == NOLINE)
4156 CopLINE_set(cop, CopLINE(PL_curcop));
4158 CopLINE_set(cop, PL_copline);
4159 PL_copline = NOLINE;
4162 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4164 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4166 CopSTASH_set(cop, PL_curstash);
4168 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4169 AV *av = CopFILEAVx(PL_curcop);
4171 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4172 if (svp && *svp != &PL_sv_undef ) {
4173 (void)SvIOK_on(*svp);
4174 SvIV_set(*svp, PTR2IV(cop));
4179 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4184 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4187 return new_logop(type, flags, &first, &other);
4191 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4196 OP *first = *firstp;
4197 OP * const other = *otherp;
4199 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4200 return newBINOP(type, flags, scalar(first), scalar(other));
4202 scalarboolean(first);
4203 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4204 if (first->op_type == OP_NOT
4205 && (first->op_flags & OPf_SPECIAL)
4206 && (first->op_flags & OPf_KIDS)) {
4207 if (type == OP_AND || type == OP_OR) {
4213 first = *firstp = cUNOPo->op_first;
4215 first->op_next = o->op_next;
4216 cUNOPo->op_first = NULL;
4218 op_getmad(o,first,'O');
4224 if (first->op_type == OP_CONST) {
4225 if (first->op_private & OPpCONST_STRICT)
4226 no_bareword_allowed(first);
4227 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4228 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4229 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4230 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4231 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4233 if (other->op_type == OP_CONST)
4234 other->op_private |= OPpCONST_SHORTCIRCUIT;
4236 OP *newop = newUNOP(OP_NULL, 0, other);
4237 op_getmad(first, newop, '1');
4238 newop->op_targ = type; /* set "was" field */
4245 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4246 const OP *o2 = other;
4247 if ( ! (o2->op_type == OP_LIST
4248 && (( o2 = cUNOPx(o2)->op_first))
4249 && o2->op_type == OP_PUSHMARK
4250 && (( o2 = o2->op_sibling)) )
4253 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4254 || o2->op_type == OP_PADHV)
4255 && o2->op_private & OPpLVAL_INTRO
4256 && ckWARN(WARN_DEPRECATED))
4258 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4259 "Deprecated use of my() in false conditional");
4263 if (first->op_type == OP_CONST)
4264 first->op_private |= OPpCONST_SHORTCIRCUIT;
4266 first = newUNOP(OP_NULL, 0, first);
4267 op_getmad(other, first, '2');
4268 first->op_targ = type; /* set "was" field */
4275 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4276 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4278 const OP * const k1 = ((UNOP*)first)->op_first;
4279 const OP * const k2 = k1->op_sibling;
4281 switch (first->op_type)
4284 if (k2 && k2->op_type == OP_READLINE
4285 && (k2->op_flags & OPf_STACKED)
4286 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4288 warnop = k2->op_type;
4293 if (k1->op_type == OP_READDIR
4294 || k1->op_type == OP_GLOB
4295 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4296 || k1->op_type == OP_EACH)
4298 warnop = ((k1->op_type == OP_NULL)
4299 ? (OPCODE)k1->op_targ : k1->op_type);
4304 const line_t oldline = CopLINE(PL_curcop);
4305 CopLINE_set(PL_curcop, PL_copline);
4306 Perl_warner(aTHX_ packWARN(WARN_MISC),
4307 "Value of %s%s can be \"0\"; test with defined()",
4309 ((warnop == OP_READLINE || warnop == OP_GLOB)
4310 ? " construct" : "() operator"));
4311 CopLINE_set(PL_curcop, oldline);
4318 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4319 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4321 NewOp(1101, logop, 1, LOGOP);
4323 logop->op_type = (OPCODE)type;
4324 logop->op_ppaddr = PL_ppaddr[type];
4325 logop->op_first = first;
4326 logop->op_flags = (U8)(flags | OPf_KIDS);
4327 logop->op_other = LINKLIST(other);
4328 logop->op_private = (U8)(1 | (flags >> 8));
4330 /* establish postfix order */
4331 logop->op_next = LINKLIST(first);
4332 first->op_next = (OP*)logop;
4333 first->op_sibling = other;
4335 CHECKOP(type,logop);
4337 o = newUNOP(OP_NULL, 0, (OP*)logop);
4344 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4352 return newLOGOP(OP_AND, 0, first, trueop);
4354 return newLOGOP(OP_OR, 0, first, falseop);
4356 scalarboolean(first);
4357 if (first->op_type == OP_CONST) {
4358 /* Left or right arm of the conditional? */
4359 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4360 OP *live = left ? trueop : falseop;
4361 OP *const dead = left ? falseop : trueop;
4362 if (first->op_private & OPpCONST_BARE &&
4363 first->op_private & OPpCONST_STRICT) {
4364 no_bareword_allowed(first);
4367 /* This is all dead code when PERL_MAD is not defined. */
4368 live = newUNOP(OP_NULL, 0, live);
4369 op_getmad(first, live, 'C');
4370 op_getmad(dead, live, left ? 'e' : 't');
4377 NewOp(1101, logop, 1, LOGOP);
4378 logop->op_type = OP_COND_EXPR;
4379 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4380 logop->op_first = first;
4381 logop->op_flags = (U8)(flags | OPf_KIDS);
4382 logop->op_private = (U8)(1 | (flags >> 8));
4383 logop->op_other = LINKLIST(trueop);
4384 logop->op_next = LINKLIST(falseop);
4386 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4389 /* establish postfix order */
4390 start = LINKLIST(first);
4391 first->op_next = (OP*)logop;
4393 first->op_sibling = trueop;
4394 trueop->op_sibling = falseop;
4395 o = newUNOP(OP_NULL, 0, (OP*)logop);
4397 trueop->op_next = falseop->op_next = o;
4404 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4413 NewOp(1101, range, 1, LOGOP);
4415 range->op_type = OP_RANGE;
4416 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4417 range->op_first = left;
4418 range->op_flags = OPf_KIDS;
4419 leftstart = LINKLIST(left);
4420 range->op_other = LINKLIST(right);
4421 range->op_private = (U8)(1 | (flags >> 8));
4423 left->op_sibling = right;
4425 range->op_next = (OP*)range;
4426 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4427 flop = newUNOP(OP_FLOP, 0, flip);
4428 o = newUNOP(OP_NULL, 0, flop);
4430 range->op_next = leftstart;
4432 left->op_next = flip;
4433 right->op_next = flop;
4435 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4436 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4437 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4438 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4440 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4441 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4444 if (!flip->op_private || !flop->op_private)
4445 linklist(o); /* blow off optimizer unless constant */
4451 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4456 const bool once = block && block->op_flags & OPf_SPECIAL &&
4457 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4459 PERL_UNUSED_ARG(debuggable);
4462 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4463 return block; /* do {} while 0 does once */
4464 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4465 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4466 expr = newUNOP(OP_DEFINED, 0,
4467 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4468 } else if (expr->op_flags & OPf_KIDS) {
4469 const OP * const k1 = ((UNOP*)expr)->op_first;
4470 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4471 switch (expr->op_type) {
4473 if (k2 && k2->op_type == OP_READLINE
4474 && (k2->op_flags & OPf_STACKED)
4475 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4476 expr = newUNOP(OP_DEFINED, 0, expr);
4480 if (k1 && (k1->op_type == OP_READDIR
4481 || k1->op_type == OP_GLOB
4482 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4483 || k1->op_type == OP_EACH))
4484 expr = newUNOP(OP_DEFINED, 0, expr);
4490 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4491 * op, in listop. This is wrong. [perl #27024] */
4493 block = newOP(OP_NULL, 0);
4494 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4495 o = new_logop(OP_AND, 0, &expr, &listop);
4498 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4500 if (once && o != listop)
4501 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4504 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4506 o->op_flags |= flags;
4508 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4513 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4514 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4523 PERL_UNUSED_ARG(debuggable);
4526 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4527 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4528 expr = newUNOP(OP_DEFINED, 0,
4529 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4530 } else if (expr->op_flags & OPf_KIDS) {
4531 const OP * const k1 = ((UNOP*)expr)->op_first;
4532 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4533 switch (expr->op_type) {
4535 if (k2 && k2->op_type == OP_READLINE
4536 && (k2->op_flags & OPf_STACKED)
4537 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4538 expr = newUNOP(OP_DEFINED, 0, expr);
4542 if (k1 && (k1->op_type == OP_READDIR
4543 || k1->op_type == OP_GLOB
4544 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4545 || k1->op_type == OP_EACH))
4546 expr = newUNOP(OP_DEFINED, 0, expr);
4553 block = newOP(OP_NULL, 0);
4554 else if (cont || has_my) {
4555 block = scope(block);
4559 next = LINKLIST(cont);
4562 OP * const unstack = newOP(OP_UNSTACK, 0);
4565 cont = append_elem(OP_LINESEQ, cont, unstack);
4569 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4571 redo = LINKLIST(listop);
4574 PL_copline = (line_t)whileline;
4576 o = new_logop(OP_AND, 0, &expr, &listop);
4577 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4578 op_free(expr); /* oops, it's a while (0) */
4580 return NULL; /* listop already freed by new_logop */
4583 ((LISTOP*)listop)->op_last->op_next =
4584 (o == listop ? redo : LINKLIST(o));
4590 NewOp(1101,loop,1,LOOP);
4591 loop->op_type = OP_ENTERLOOP;
4592 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4593 loop->op_private = 0;
4594 loop->op_next = (OP*)loop;
4597 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4599 loop->op_redoop = redo;
4600 loop->op_lastop = o;
4601 o->op_private |= loopflags;
4604 loop->op_nextop = next;
4606 loop->op_nextop = o;
4608 o->op_flags |= flags;
4609 o->op_private |= (flags >> 8);
4614 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4619 PADOFFSET padoff = 0;
4625 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4626 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4627 sv->op_type = OP_RV2GV;
4628 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4630 /* The op_type check is needed to prevent a possible segfault
4631 * if the loop variable is undeclared and 'strict vars' is in
4632 * effect. This is illegal but is nonetheless parsed, so we
4633 * may reach this point with an OP_CONST where we're expecting
4636 if (cUNOPx(sv)->op_first->op_type == OP_GV
4637 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4638 iterpflags |= OPpITER_DEF;
4640 else if (sv->op_type == OP_PADSV) { /* private variable */
4641 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4642 padoff = sv->op_targ;
4652 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4654 SV *const namesv = PAD_COMPNAME_SV(padoff);
4656 const char *const name = SvPV_const(namesv, len);
4658 if (len == 2 && name[0] == '$' && name[1] == '_')
4659 iterpflags |= OPpITER_DEF;
4663 const PADOFFSET offset = pad_findmy("$_");
4664 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4665 sv = newGVOP(OP_GV, 0, PL_defgv);
4670 iterpflags |= OPpITER_DEF;
4672 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4673 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4674 iterflags |= OPf_STACKED;
4676 else if (expr->op_type == OP_NULL &&
4677 (expr->op_flags & OPf_KIDS) &&
4678 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4680 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4681 * set the STACKED flag to indicate that these values are to be
4682 * treated as min/max values by 'pp_iterinit'.
4684 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4685 LOGOP* const range = (LOGOP*) flip->op_first;
4686 OP* const left = range->op_first;
4687 OP* const right = left->op_sibling;
4690 range->op_flags &= ~OPf_KIDS;
4691 range->op_first = NULL;
4693 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4694 listop->op_first->op_next = range->op_next;
4695 left->op_next = range->op_other;
4696 right->op_next = (OP*)listop;
4697 listop->op_next = listop->op_first;
4700 op_getmad(expr,(OP*)listop,'O');
4704 expr = (OP*)(listop);
4706 iterflags |= OPf_STACKED;
4709 expr = mod(force_list(expr), OP_GREPSTART);
4712 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4713 append_elem(OP_LIST, expr, scalar(sv))));
4714 assert(!loop->op_next);
4715 /* for my $x () sets OPpLVAL_INTRO;
4716 * for our $x () sets OPpOUR_INTRO */
4717 loop->op_private = (U8)iterpflags;
4718 #ifdef PL_OP_SLAB_ALLOC
4721 NewOp(1234,tmp,1,LOOP);
4722 Copy(loop,tmp,1,LISTOP);
4723 S_op_destroy(aTHX_ (OP*)loop);
4727 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4729 loop->op_targ = padoff;
4730 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4732 op_getmad(madsv, (OP*)loop, 'v');
4733 PL_copline = forline;
4734 return newSTATEOP(0, label, wop);
4738 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4743 if (type != OP_GOTO || label->op_type == OP_CONST) {
4744 /* "last()" means "last" */
4745 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4746 o = newOP(type, OPf_SPECIAL);
4748 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4749 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4753 op_getmad(label,o,'L');
4759 /* Check whether it's going to be a goto &function */
4760 if (label->op_type == OP_ENTERSUB
4761 && !(label->op_flags & OPf_STACKED))
4762 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4763 o = newUNOP(type, OPf_STACKED, label);
4765 PL_hints |= HINT_BLOCK_SCOPE;
4769 /* if the condition is a literal array or hash
4770 (or @{ ... } etc), make a reference to it.
4773 S_ref_array_or_hash(pTHX_ OP *cond)
4776 && (cond->op_type == OP_RV2AV
4777 || cond->op_type == OP_PADAV
4778 || cond->op_type == OP_RV2HV
4779 || cond->op_type == OP_PADHV))
4781 return newUNOP(OP_REFGEN,
4782 0, mod(cond, OP_REFGEN));
4788 /* These construct the optree fragments representing given()
4791 entergiven and enterwhen are LOGOPs; the op_other pointer
4792 points up to the associated leave op. We need this so we
4793 can put it in the context and make break/continue work.
4794 (Also, of course, pp_enterwhen will jump straight to
4795 op_other if the match fails.)
4800 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4801 I32 enter_opcode, I32 leave_opcode,
4802 PADOFFSET entertarg)
4808 NewOp(1101, enterop, 1, LOGOP);
4809 enterop->op_type = enter_opcode;
4810 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4811 enterop->op_flags = (U8) OPf_KIDS;
4812 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4813 enterop->op_private = 0;
4815 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4818 enterop->op_first = scalar(cond);
4819 cond->op_sibling = block;
4821 o->op_next = LINKLIST(cond);
4822 cond->op_next = (OP *) enterop;
4825 /* This is a default {} block */