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 */
192 /* Force a new slab for any further allocation. */
196 void *const start = slabs[count];
197 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
198 if(mprotect(start, size, PROT_READ)) {
199 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
200 start, (unsigned long) size, errno);
208 S_Slab_to_rw(pTHX_ void *op)
210 I32 * const * const ptr = (I32 **) op;
211 I32 * const slab = ptr[-1];
212 assert( ptr-1 > (I32 **) slab );
213 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
215 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
216 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
217 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
222 Perl_op_refcnt_inc(pTHX_ OP *o)
233 Perl_op_refcnt_dec(pTHX_ OP *o)
239 # define Slab_to_rw(op)
243 Perl_Slab_Free(pTHX_ void *op)
245 I32 * const * const ptr = (I32 **) op;
246 I32 * const slab = ptr[-1];
247 assert( ptr-1 > (I32 **) slab );
248 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
251 if (--(*slab) == 0) {
253 # define PerlMemShared PerlMem
256 #ifdef PERL_DEBUG_READONLY_OPS
257 U32 count = PL_slab_count;
258 /* Need to remove this slab from our list of slabs */
261 if (PL_slabs[count] == slab) {
262 /* Found it. Move the entry at the end to overwrite it. */
263 DEBUG_m(PerlIO_printf(Perl_debug_log,
264 "Deallocate %p by moving %p from %lu to %lu\n",
266 PL_slabs[PL_slab_count - 1],
267 PL_slab_count, count));
268 PL_slabs[count] = PL_slabs[--PL_slab_count];
269 /* Could realloc smaller at this point, but probably not
271 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
272 perror("munmap failed");
280 PerlMemShared_free(slab);
282 if (slab == PL_OpSlab) {
289 * In the following definition, the ", (OP*)0" is just to make the compiler
290 * think the expression is of the right type: croak actually does a Siglongjmp.
292 #define CHECKOP(type,o) \
293 ((PL_op_mask && PL_op_mask[type]) \
294 ? ( op_free((OP*)o), \
295 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
297 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
299 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
302 S_gv_ename(pTHX_ GV *gv)
304 SV* const tmpsv = sv_newmortal();
305 gv_efullname3(tmpsv, gv, NULL);
306 return SvPV_nolen_const(tmpsv);
310 S_no_fh_allowed(pTHX_ OP *o)
312 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
318 S_too_few_arguments(pTHX_ OP *o, const char *name)
320 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
325 S_too_many_arguments(pTHX_ OP *o, const char *name)
327 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
332 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
334 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
335 (int)n, name, t, OP_DESC(kid)));
339 S_no_bareword_allowed(pTHX_ const OP *o)
342 return; /* various ok barewords are hidden in extra OP_NULL */
343 qerror(Perl_mess(aTHX_
344 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
348 /* "register" allocation */
351 Perl_allocmy(pTHX_ const char *const name)
355 const bool is_our = (PL_parser->in_my == KEY_our);
357 /* complain about "my $<special_var>" etc etc */
361 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
362 (name[1] == '_' && (*name == '$' || name[2]))))
364 /* name[2] is true if strlen(name) > 2 */
365 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
366 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
367 name[0], toCTRL(name[1]), name + 2,
368 PL_parser->in_my == KEY_state ? "state" : "my"));
370 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
371 PL_parser->in_my == KEY_state ? "state" : "my"));
375 /* check for duplicate declaration */
376 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
378 if (PL_parser->in_my_stash && *name != '$') {
379 yyerror(Perl_form(aTHX_
380 "Can't declare class for non-scalar %s in \"%s\"",
383 : PL_parser->in_my == KEY_state ? "state" : "my"));
386 /* allocate a spare slot and store the name in that slot */
388 off = pad_add_name(name,
389 PL_parser->in_my_stash,
391 /* $_ is always in main::, even with our */
392 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
396 PL_parser->in_my == KEY_state
398 /* anon sub prototypes contains state vars should always be cloned,
399 * otherwise the state var would be shared between anon subs */
401 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
402 CvCLONE_on(PL_compcv);
407 /* free the body of an op without examining its contents.
408 * Always use this rather than FreeOp directly */
411 S_op_destroy(pTHX_ OP *o)
413 if (o->op_latefree) {
421 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
423 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
429 Perl_op_free(pTHX_ OP *o)
436 if (o->op_latefreed) {
443 if (o->op_private & OPpREFCOUNTED) {
454 refcnt = OpREFCNT_dec(o);
457 /* Need to find and remove any pattern match ops from the list
458 we maintain for reset(). */
459 find_and_forget_pmops(o);
469 if (o->op_flags & OPf_KIDS) {
470 register OP *kid, *nextkid;
471 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
472 nextkid = kid->op_sibling; /* Get before next freeing kid */
477 type = (OPCODE)o->op_targ;
479 #ifdef PERL_DEBUG_READONLY_OPS
483 /* COP* is not cleared by op_clear() so that we may track line
484 * numbers etc even after null() */
485 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
490 if (o->op_latefree) {
496 #ifdef DEBUG_LEAKING_SCALARS
503 Perl_op_clear(pTHX_ OP *o)
508 /* if (o->op_madprop && o->op_madprop->mad_next)
510 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
511 "modification of a read only value" for a reason I can't fathom why.
512 It's the "" stringification of $_, where $_ was set to '' in a foreach
513 loop, but it defies simplification into a small test case.
514 However, commenting them out has caused ext/List/Util/t/weak.t to fail
517 mad_free(o->op_madprop);
523 switch (o->op_type) {
524 case OP_NULL: /* Was holding old type, if any. */
525 if (PL_madskills && o->op_targ != OP_NULL) {
526 o->op_type = o->op_targ;
530 case OP_ENTEREVAL: /* Was holding hints. */
534 if (!(o->op_flags & OPf_REF)
535 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
541 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
542 /* not an OP_PADAV replacement */
544 if (cPADOPo->op_padix > 0) {
545 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
546 * may still exist on the pad */
547 pad_swipe(cPADOPo->op_padix, TRUE);
548 cPADOPo->op_padix = 0;
551 SvREFCNT_dec(cSVOPo->op_sv);
552 cSVOPo->op_sv = NULL;
556 case OP_METHOD_NAMED:
558 SvREFCNT_dec(cSVOPo->op_sv);
559 cSVOPo->op_sv = NULL;
562 Even if op_clear does a pad_free for the target of the op,
563 pad_free doesn't actually remove the sv that exists in the pad;
564 instead it lives on. This results in that it could be reused as
565 a target later on when the pad was reallocated.
568 pad_swipe(o->op_targ,1);
577 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
581 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
583 if (cPADOPo->op_padix > 0) {
584 pad_swipe(cPADOPo->op_padix, TRUE);
585 cPADOPo->op_padix = 0;
588 SvREFCNT_dec(cSVOPo->op_sv);
589 cSVOPo->op_sv = NULL;
593 PerlMemShared_free(cPVOPo->op_pv);
594 cPVOPo->op_pv = NULL;
598 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
602 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
603 /* No GvIN_PAD_off here, because other references may still
604 * exist on the pad */
605 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
608 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
614 forget_pmop(cPMOPo, 1);
615 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
616 /* we use the "SAFE" version of the PM_ macros here
617 * since sv_clean_all might release some PMOPs
618 * after PL_regex_padav has been cleared
619 * and the clearing of PL_regex_padav needs to
620 * happen before sv_clean_all
622 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
623 PM_SETRE_SAFE(cPMOPo, NULL);
625 if(PL_regex_pad) { /* We could be in destruction */
626 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
627 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
628 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
629 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
636 if (o->op_targ > 0) {
637 pad_free(o->op_targ);
643 S_cop_free(pTHX_ COP* cop)
648 if (! specialWARN(cop->cop_warnings))
649 PerlMemShared_free(cop->cop_warnings);
650 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
654 S_forget_pmop(pTHX_ PMOP *const o
660 HV * const pmstash = PmopSTASH(o);
661 if (pmstash && !SvIS_FREED(pmstash)) {
662 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
664 PMOP **const array = (PMOP**) mg->mg_ptr;
665 U32 count = mg->mg_len / sizeof(PMOP**);
670 /* Found it. Move the entry at the end to overwrite it. */
671 array[i] = array[--count];
672 mg->mg_len = count * sizeof(PMOP**);
673 /* Could realloc smaller at this point always, but probably
674 not worth it. Probably worth free()ing if we're the
677 Safefree(mg->mg_ptr);
694 S_find_and_forget_pmops(pTHX_ OP *o)
696 if (o->op_flags & OPf_KIDS) {
697 OP *kid = cUNOPo->op_first;
699 switch (kid->op_type) {
704 forget_pmop((PMOP*)kid, 0);
706 find_and_forget_pmops(kid);
707 kid = kid->op_sibling;
713 Perl_op_null(pTHX_ OP *o)
716 if (o->op_type == OP_NULL)
720 o->op_targ = o->op_type;
721 o->op_type = OP_NULL;
722 o->op_ppaddr = PL_ppaddr[OP_NULL];
726 Perl_op_refcnt_lock(pTHX)
734 Perl_op_refcnt_unlock(pTHX)
741 /* Contextualizers */
743 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
746 Perl_linklist(pTHX_ OP *o)
753 /* establish postfix order */
754 first = cUNOPo->op_first;
757 o->op_next = LINKLIST(first);
760 if (kid->op_sibling) {
761 kid->op_next = LINKLIST(kid->op_sibling);
762 kid = kid->op_sibling;
776 Perl_scalarkids(pTHX_ OP *o)
778 if (o && o->op_flags & OPf_KIDS) {
780 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
787 S_scalarboolean(pTHX_ OP *o)
790 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
791 if (ckWARN(WARN_SYNTAX)) {
792 const line_t oldline = CopLINE(PL_curcop);
794 if (PL_parser && PL_parser->copline != NOLINE)
795 CopLINE_set(PL_curcop, PL_parser->copline);
796 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
797 CopLINE_set(PL_curcop, oldline);
804 Perl_scalar(pTHX_ OP *o)
809 /* assumes no premature commitment */
810 if (!o || (PL_parser && PL_parser->error_count)
811 || (o->op_flags & OPf_WANT)
812 || o->op_type == OP_RETURN)
817 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
819 switch (o->op_type) {
821 scalar(cBINOPo->op_first);
826 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
830 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
831 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
832 deprecate_old("implicit split to @_");
840 if (o->op_flags & OPf_KIDS) {
841 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
847 kid = cLISTOPo->op_first;
849 while ((kid = kid->op_sibling)) {
855 PL_curcop = &PL_compiling;
860 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
866 PL_curcop = &PL_compiling;
869 if (ckWARN(WARN_VOID))
870 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
876 Perl_scalarvoid(pTHX_ OP *o)
880 const char* useless = NULL;
884 /* trailing mad null ops don't count as "there" for void processing */
886 o->op_type != OP_NULL &&
888 o->op_sibling->op_type == OP_NULL)
891 for (sib = o->op_sibling;
892 sib && sib->op_type == OP_NULL;
893 sib = sib->op_sibling) ;
899 if (o->op_type == OP_NEXTSTATE
900 || o->op_type == OP_SETSTATE
901 || o->op_type == OP_DBSTATE
902 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
903 || o->op_targ == OP_SETSTATE
904 || o->op_targ == OP_DBSTATE)))
905 PL_curcop = (COP*)o; /* for warning below */
907 /* assumes no premature commitment */
908 want = o->op_flags & OPf_WANT;
909 if ((want && want != OPf_WANT_SCALAR)
910 || (PL_parser && PL_parser->error_count)
911 || o->op_type == OP_RETURN)
916 if ((o->op_private & OPpTARGET_MY)
917 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
919 return scalar(o); /* As if inside SASSIGN */
922 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
924 switch (o->op_type) {
926 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
930 if (o->op_flags & OPf_STACKED)
934 if (o->op_private == 4)
1006 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1007 useless = OP_DESC(o);
1011 kid = cUNOPo->op_first;
1012 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1013 kid->op_type != OP_TRANS) {
1016 useless = "negative pattern binding (!~)";
1023 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1024 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1025 useless = "a variable";
1030 if (cSVOPo->op_private & OPpCONST_STRICT)
1031 no_bareword_allowed(o);
1033 if (ckWARN(WARN_VOID)) {
1034 useless = "a constant";
1035 if (o->op_private & OPpCONST_ARYBASE)
1037 /* don't warn on optimised away booleans, eg
1038 * use constant Foo, 5; Foo || print; */
1039 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1041 /* the constants 0 and 1 are permitted as they are
1042 conventionally used as dummies in constructs like
1043 1 while some_condition_with_side_effects; */
1044 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1046 else if (SvPOK(sv)) {
1047 /* perl4's way of mixing documentation and code
1048 (before the invention of POD) was based on a
1049 trick to mix nroff and perl code. The trick was
1050 built upon these three nroff macros being used in
1051 void context. The pink camel has the details in
1052 the script wrapman near page 319. */
1053 const char * const maybe_macro = SvPVX_const(sv);
1054 if (strnEQ(maybe_macro, "di", 2) ||
1055 strnEQ(maybe_macro, "ds", 2) ||
1056 strnEQ(maybe_macro, "ig", 2))
1061 op_null(o); /* don't execute or even remember it */
1065 o->op_type = OP_PREINC; /* pre-increment is faster */
1066 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1070 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1071 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1075 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1076 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1080 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1081 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1090 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1095 if (o->op_flags & OPf_STACKED)
1102 if (!(o->op_flags & OPf_KIDS))
1113 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1120 /* all requires must return a boolean value */
1121 o->op_flags &= ~OPf_WANT;
1126 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1127 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1128 deprecate_old("implicit split to @_");
1132 if (useless && ckWARN(WARN_VOID))
1133 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1138 Perl_listkids(pTHX_ OP *o)
1140 if (o && o->op_flags & OPf_KIDS) {
1142 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1149 Perl_list(pTHX_ OP *o)
1154 /* assumes no premature commitment */
1155 if (!o || (o->op_flags & OPf_WANT)
1156 || (PL_parser && PL_parser->error_count)
1157 || o->op_type == OP_RETURN)
1162 if ((o->op_private & OPpTARGET_MY)
1163 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1165 return o; /* As if inside SASSIGN */
1168 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1170 switch (o->op_type) {
1173 list(cBINOPo->op_first);
1178 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1186 if (!(o->op_flags & OPf_KIDS))
1188 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1189 list(cBINOPo->op_first);
1190 return gen_constant_list(o);
1197 kid = cLISTOPo->op_first;
1199 while ((kid = kid->op_sibling)) {
1200 if (kid->op_sibling)
1205 PL_curcop = &PL_compiling;
1209 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1210 if (kid->op_sibling)
1215 PL_curcop = &PL_compiling;
1218 /* all requires must return a boolean value */
1219 o->op_flags &= ~OPf_WANT;
1226 Perl_scalarseq(pTHX_ OP *o)
1230 const OPCODE type = o->op_type;
1232 if (type == OP_LINESEQ || type == OP_SCOPE ||
1233 type == OP_LEAVE || type == OP_LEAVETRY)
1236 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1237 if (kid->op_sibling) {
1241 PL_curcop = &PL_compiling;
1243 o->op_flags &= ~OPf_PARENS;
1244 if (PL_hints & HINT_BLOCK_SCOPE)
1245 o->op_flags |= OPf_PARENS;
1248 o = newOP(OP_STUB, 0);
1253 S_modkids(pTHX_ OP *o, I32 type)
1255 if (o && o->op_flags & OPf_KIDS) {
1257 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1263 /* Propagate lvalue ("modifiable") context to an op and its children.
1264 * 'type' represents the context type, roughly based on the type of op that
1265 * would do the modifying, although local() is represented by OP_NULL.
1266 * It's responsible for detecting things that can't be modified, flag
1267 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1268 * might have to vivify a reference in $x), and so on.
1270 * For example, "$a+1 = 2" would cause mod() to be called with o being
1271 * OP_ADD and type being OP_SASSIGN, and would output an error.
1275 Perl_mod(pTHX_ OP *o, I32 type)
1279 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1282 if (!o || (PL_parser && PL_parser->error_count))
1285 if ((o->op_private & OPpTARGET_MY)
1286 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1291 switch (o->op_type) {
1297 if (!(o->op_private & OPpCONST_ARYBASE))
1300 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1301 CopARYBASE_set(&PL_compiling,
1302 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1306 SAVECOPARYBASE(&PL_compiling);
1307 CopARYBASE_set(&PL_compiling, 0);
1309 else if (type == OP_REFGEN)
1312 Perl_croak(aTHX_ "That use of $[ is unsupported");
1315 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1319 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1320 !(o->op_flags & OPf_STACKED)) {
1321 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1322 /* The default is to set op_private to the number of children,
1323 which for a UNOP such as RV2CV is always 1. And w're using
1324 the bit for a flag in RV2CV, so we need it clear. */
1325 o->op_private &= ~1;
1326 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1327 assert(cUNOPo->op_first->op_type == OP_NULL);
1328 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1331 else if (o->op_private & OPpENTERSUB_NOMOD)
1333 else { /* lvalue subroutine call */
1334 o->op_private |= OPpLVAL_INTRO;
1335 PL_modcount = RETURN_UNLIMITED_NUMBER;
1336 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1337 /* Backward compatibility mode: */
1338 o->op_private |= OPpENTERSUB_INARGS;
1341 else { /* Compile-time error message: */
1342 OP *kid = cUNOPo->op_first;
1346 if (kid->op_type != OP_PUSHMARK) {
1347 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1349 "panic: unexpected lvalue entersub "
1350 "args: type/targ %ld:%"UVuf,
1351 (long)kid->op_type, (UV)kid->op_targ);
1352 kid = kLISTOP->op_first;
1354 while (kid->op_sibling)
1355 kid = kid->op_sibling;
1356 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1358 if (kid->op_type == OP_METHOD_NAMED
1359 || kid->op_type == OP_METHOD)
1363 NewOp(1101, newop, 1, UNOP);
1364 newop->op_type = OP_RV2CV;
1365 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1366 newop->op_first = NULL;
1367 newop->op_next = (OP*)newop;
1368 kid->op_sibling = (OP*)newop;
1369 newop->op_private |= OPpLVAL_INTRO;
1370 newop->op_private &= ~1;
1374 if (kid->op_type != OP_RV2CV)
1376 "panic: unexpected lvalue entersub "
1377 "entry via type/targ %ld:%"UVuf,
1378 (long)kid->op_type, (UV)kid->op_targ);
1379 kid->op_private |= OPpLVAL_INTRO;
1380 break; /* Postpone until runtime */
1384 kid = kUNOP->op_first;
1385 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1386 kid = kUNOP->op_first;
1387 if (kid->op_type == OP_NULL)
1389 "Unexpected constant lvalue entersub "
1390 "entry via type/targ %ld:%"UVuf,
1391 (long)kid->op_type, (UV)kid->op_targ);
1392 if (kid->op_type != OP_GV) {
1393 /* Restore RV2CV to check lvalueness */
1395 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1396 okid->op_next = kid->op_next;
1397 kid->op_next = okid;
1400 okid->op_next = NULL;
1401 okid->op_type = OP_RV2CV;
1403 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1404 okid->op_private |= OPpLVAL_INTRO;
1405 okid->op_private &= ~1;
1409 cv = GvCV(kGVOP_gv);
1419 /* grep, foreach, subcalls, refgen */
1420 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1422 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1423 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1425 : (o->op_type == OP_ENTERSUB
1426 ? "non-lvalue subroutine call"
1428 type ? PL_op_desc[type] : "local"));
1442 case OP_RIGHT_SHIFT:
1451 if (!(o->op_flags & OPf_STACKED))
1458 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1464 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1465 PL_modcount = RETURN_UNLIMITED_NUMBER;
1466 return o; /* Treat \(@foo) like ordinary list. */
1470 if (scalar_mod_type(o, type))
1472 ref(cUNOPo->op_first, o->op_type);
1476 if (type == OP_LEAVESUBLV)
1477 o->op_private |= OPpMAYBE_LVSUB;
1483 PL_modcount = RETURN_UNLIMITED_NUMBER;
1486 ref(cUNOPo->op_first, o->op_type);
1491 PL_hints |= HINT_BLOCK_SCOPE;
1506 PL_modcount = RETURN_UNLIMITED_NUMBER;
1507 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1508 return o; /* Treat \(@foo) like ordinary list. */
1509 if (scalar_mod_type(o, type))
1511 if (type == OP_LEAVESUBLV)
1512 o->op_private |= OPpMAYBE_LVSUB;
1516 if (!type) /* local() */
1517 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1518 PAD_COMPNAME_PV(o->op_targ));
1526 if (type != OP_SASSIGN)
1530 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1535 if (type == OP_LEAVESUBLV)
1536 o->op_private |= OPpMAYBE_LVSUB;
1538 pad_free(o->op_targ);
1539 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1540 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1541 if (o->op_flags & OPf_KIDS)
1542 mod(cBINOPo->op_first->op_sibling, type);
1547 ref(cBINOPo->op_first, o->op_type);
1548 if (type == OP_ENTERSUB &&
1549 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1550 o->op_private |= OPpLVAL_DEFER;
1551 if (type == OP_LEAVESUBLV)
1552 o->op_private |= OPpMAYBE_LVSUB;
1562 if (o->op_flags & OPf_KIDS)
1563 mod(cLISTOPo->op_last, type);
1568 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1570 else if (!(o->op_flags & OPf_KIDS))
1572 if (o->op_targ != OP_LIST) {
1573 mod(cBINOPo->op_first, type);
1579 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1584 if (type != OP_LEAVESUBLV)
1586 break; /* mod()ing was handled by ck_return() */
1589 /* [20011101.069] File test operators interpret OPf_REF to mean that
1590 their argument is a filehandle; thus \stat(".") should not set
1592 if (type == OP_REFGEN &&
1593 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1596 if (type != OP_LEAVESUBLV)
1597 o->op_flags |= OPf_MOD;
1599 if (type == OP_AASSIGN || type == OP_SASSIGN)
1600 o->op_flags |= OPf_SPECIAL|OPf_REF;
1601 else if (!type) { /* local() */
1604 o->op_private |= OPpLVAL_INTRO;
1605 o->op_flags &= ~OPf_SPECIAL;
1606 PL_hints |= HINT_BLOCK_SCOPE;
1611 if (ckWARN(WARN_SYNTAX)) {
1612 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1613 "Useless localization of %s", OP_DESC(o));
1617 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1618 && type != OP_LEAVESUBLV)
1619 o->op_flags |= OPf_REF;
1624 S_scalar_mod_type(const OP *o, I32 type)
1628 if (o->op_type == OP_RV2GV)
1652 case OP_RIGHT_SHIFT:
1672 S_is_handle_constructor(const OP *o, I32 numargs)
1674 switch (o->op_type) {
1682 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1695 Perl_refkids(pTHX_ OP *o, I32 type)
1697 if (o && o->op_flags & OPf_KIDS) {
1699 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1706 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1711 if (!o || (PL_parser && PL_parser->error_count))
1714 switch (o->op_type) {
1716 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1717 !(o->op_flags & OPf_STACKED)) {
1718 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1719 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1720 assert(cUNOPo->op_first->op_type == OP_NULL);
1721 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1722 o->op_flags |= OPf_SPECIAL;
1723 o->op_private &= ~1;
1728 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1729 doref(kid, type, set_op_ref);
1732 if (type == OP_DEFINED)
1733 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1734 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1737 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1738 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1739 : type == OP_RV2HV ? OPpDEREF_HV
1741 o->op_flags |= OPf_MOD;
1748 o->op_flags |= OPf_REF;
1751 if (type == OP_DEFINED)
1752 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1753 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1759 o->op_flags |= OPf_REF;
1764 if (!(o->op_flags & OPf_KIDS))
1766 doref(cBINOPo->op_first, type, set_op_ref);
1770 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1771 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1772 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1773 : type == OP_RV2HV ? OPpDEREF_HV
1775 o->op_flags |= OPf_MOD;
1785 if (!(o->op_flags & OPf_KIDS))
1787 doref(cLISTOPo->op_last, type, set_op_ref);
1797 S_dup_attrlist(pTHX_ OP *o)
1802 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1803 * where the first kid is OP_PUSHMARK and the remaining ones
1804 * are OP_CONST. We need to push the OP_CONST values.
1806 if (o->op_type == OP_CONST)
1807 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1809 else if (o->op_type == OP_NULL)
1813 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1815 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1816 if (o->op_type == OP_CONST)
1817 rop = append_elem(OP_LIST, rop,
1818 newSVOP(OP_CONST, o->op_flags,
1819 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1826 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1831 /* fake up C<use attributes $pkg,$rv,@attrs> */
1832 ENTER; /* need to protect against side-effects of 'use' */
1833 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1835 #define ATTRSMODULE "attributes"
1836 #define ATTRSMODULE_PM "attributes.pm"
1839 /* Don't force the C<use> if we don't need it. */
1840 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1841 if (svp && *svp != &PL_sv_undef)
1842 NOOP; /* already in %INC */
1844 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1845 newSVpvs(ATTRSMODULE), NULL);
1848 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1849 newSVpvs(ATTRSMODULE),
1851 prepend_elem(OP_LIST,
1852 newSVOP(OP_CONST, 0, stashsv),
1853 prepend_elem(OP_LIST,
1854 newSVOP(OP_CONST, 0,
1856 dup_attrlist(attrs))));
1862 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1865 OP *pack, *imop, *arg;
1871 assert(target->op_type == OP_PADSV ||
1872 target->op_type == OP_PADHV ||
1873 target->op_type == OP_PADAV);
1875 /* Ensure that attributes.pm is loaded. */
1876 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1878 /* Need package name for method call. */
1879 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1881 /* Build up the real arg-list. */
1882 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1884 arg = newOP(OP_PADSV, 0);
1885 arg->op_targ = target->op_targ;
1886 arg = prepend_elem(OP_LIST,
1887 newSVOP(OP_CONST, 0, stashsv),
1888 prepend_elem(OP_LIST,
1889 newUNOP(OP_REFGEN, 0,
1890 mod(arg, OP_REFGEN)),
1891 dup_attrlist(attrs)));
1893 /* Fake up a method call to import */
1894 meth = newSVpvs_share("import");
1895 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1896 append_elem(OP_LIST,
1897 prepend_elem(OP_LIST, pack, list(arg)),
1898 newSVOP(OP_METHOD_NAMED, 0, meth)));
1899 imop->op_private |= OPpENTERSUB_NOMOD;
1901 /* Combine the ops. */
1902 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1906 =notfor apidoc apply_attrs_string
1908 Attempts to apply a list of attributes specified by the C<attrstr> and
1909 C<len> arguments to the subroutine identified by the C<cv> argument which
1910 is expected to be associated with the package identified by the C<stashpv>
1911 argument (see L<attributes>). It gets this wrong, though, in that it
1912 does not correctly identify the boundaries of the individual attribute
1913 specifications within C<attrstr>. This is not really intended for the
1914 public API, but has to be listed here for systems such as AIX which
1915 need an explicit export list for symbols. (It's called from XS code
1916 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1917 to respect attribute syntax properly would be welcome.
1923 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1924 const char *attrstr, STRLEN len)
1929 len = strlen(attrstr);
1933 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1935 const char * const sstr = attrstr;
1936 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1937 attrs = append_elem(OP_LIST, attrs,
1938 newSVOP(OP_CONST, 0,
1939 newSVpvn(sstr, attrstr-sstr)));
1943 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1944 newSVpvs(ATTRSMODULE),
1945 NULL, prepend_elem(OP_LIST,
1946 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1947 prepend_elem(OP_LIST,
1948 newSVOP(OP_CONST, 0,
1954 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1959 if (!o || (PL_parser && PL_parser->error_count))
1963 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1964 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1968 if (type == OP_LIST) {
1970 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1971 my_kid(kid, attrs, imopsp);
1972 } else if (type == OP_UNDEF
1978 } else if (type == OP_RV2SV || /* "our" declaration */
1980 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1981 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1982 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1984 PL_parser->in_my == KEY_our
1986 : PL_parser->in_my == KEY_state ? "state" : "my"));
1988 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1989 PL_parser->in_my = FALSE;
1990 PL_parser->in_my_stash = NULL;
1991 apply_attrs(GvSTASH(gv),
1992 (type == OP_RV2SV ? GvSV(gv) :
1993 type == OP_RV2AV ? (SV*)GvAV(gv) :
1994 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1997 o->op_private |= OPpOUR_INTRO;
2000 else if (type != OP_PADSV &&
2003 type != OP_PUSHMARK)
2005 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2007 PL_parser->in_my == KEY_our
2009 : PL_parser->in_my == KEY_state ? "state" : "my"));
2012 else if (attrs && type != OP_PUSHMARK) {
2015 PL_parser->in_my = FALSE;
2016 PL_parser->in_my_stash = NULL;
2018 /* check for C<my Dog $spot> when deciding package */
2019 stash = PAD_COMPNAME_TYPE(o->op_targ);
2021 stash = PL_curstash;
2022 apply_attrs_my(stash, o, attrs, imopsp);
2024 o->op_flags |= OPf_MOD;
2025 o->op_private |= OPpLVAL_INTRO;
2026 if (PL_parser->in_my == KEY_state)
2027 o->op_private |= OPpPAD_STATE;
2032 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2036 int maybe_scalar = 0;
2038 /* [perl #17376]: this appears to be premature, and results in code such as
2039 C< our(%x); > executing in list mode rather than void mode */
2041 if (o->op_flags & OPf_PARENS)
2051 o = my_kid(o, attrs, &rops);
2053 if (maybe_scalar && o->op_type == OP_PADSV) {
2054 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2055 o->op_private |= OPpLVAL_INTRO;
2058 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2060 PL_parser->in_my = FALSE;
2061 PL_parser->in_my_stash = NULL;
2066 Perl_my(pTHX_ OP *o)
2068 return my_attrs(o, NULL);
2072 Perl_sawparens(pTHX_ OP *o)
2074 PERL_UNUSED_CONTEXT;
2076 o->op_flags |= OPf_PARENS;
2081 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2085 const OPCODE ltype = left->op_type;
2086 const OPCODE rtype = right->op_type;
2088 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2089 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2091 const char * const desc
2092 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2093 ? (int)rtype : OP_MATCH];
2094 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2095 ? "@array" : "%hash");
2096 Perl_warner(aTHX_ packWARN(WARN_MISC),
2097 "Applying %s to %s will act on scalar(%s)",
2098 desc, sample, sample);
2101 if (rtype == OP_CONST &&
2102 cSVOPx(right)->op_private & OPpCONST_BARE &&
2103 cSVOPx(right)->op_private & OPpCONST_STRICT)
2105 no_bareword_allowed(right);
2108 ismatchop = rtype == OP_MATCH ||
2109 rtype == OP_SUBST ||
2111 if (ismatchop && right->op_private & OPpTARGET_MY) {
2113 right->op_private &= ~OPpTARGET_MY;
2115 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2118 right->op_flags |= OPf_STACKED;
2119 if (rtype != OP_MATCH &&
2120 ! (rtype == OP_TRANS &&
2121 right->op_private & OPpTRANS_IDENTICAL))
2122 newleft = mod(left, rtype);
2125 if (right->op_type == OP_TRANS)
2126 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2128 o = prepend_elem(rtype, scalar(newleft), right);
2130 return newUNOP(OP_NOT, 0, scalar(o));
2134 return bind_match(type, left,
2135 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2139 Perl_invert(pTHX_ OP *o)
2143 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2147 Perl_scope(pTHX_ OP *o)
2151 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2152 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2153 o->op_type = OP_LEAVE;
2154 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2156 else if (o->op_type == OP_LINESEQ) {
2158 o->op_type = OP_SCOPE;
2159 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2160 kid = ((LISTOP*)o)->op_first;
2161 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2164 /* The following deals with things like 'do {1 for 1}' */
2165 kid = kid->op_sibling;
2167 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2172 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2178 Perl_block_start(pTHX_ int full)
2181 const int retval = PL_savestack_ix;
2182 pad_block_start(full);
2184 PL_hints &= ~HINT_BLOCK_SCOPE;
2185 SAVECOMPILEWARNINGS();
2186 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2191 Perl_block_end(pTHX_ I32 floor, OP *seq)
2194 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2195 OP* const retval = scalarseq(seq);
2197 CopHINTS_set(&PL_compiling, PL_hints);
2199 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2208 const PADOFFSET offset = pad_findmy("$_");
2209 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2210 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2213 OP * const o = newOP(OP_PADSV, 0);
2214 o->op_targ = offset;
2220 Perl_newPROG(pTHX_ OP *o)
2226 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2227 ((PL_in_eval & EVAL_KEEPERR)
2228 ? OPf_SPECIAL : 0), o);
2229 PL_eval_start = linklist(PL_eval_root);
2230 PL_eval_root->op_private |= OPpREFCOUNTED;
2231 OpREFCNT_set(PL_eval_root, 1);
2232 PL_eval_root->op_next = 0;
2233 CALL_PEEP(PL_eval_start);
2236 if (o->op_type == OP_STUB) {
2237 PL_comppad_name = 0;
2239 S_op_destroy(aTHX_ o);
2242 PL_main_root = scope(sawparens(scalarvoid(o)));
2243 PL_curcop = &PL_compiling;
2244 PL_main_start = LINKLIST(PL_main_root);
2245 PL_main_root->op_private |= OPpREFCOUNTED;
2246 OpREFCNT_set(PL_main_root, 1);
2247 PL_main_root->op_next = 0;
2248 CALL_PEEP(PL_main_start);
2251 /* Register with debugger */
2254 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2258 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2260 call_sv((SV*)cv, G_DISCARD);
2267 Perl_localize(pTHX_ OP *o, I32 lex)
2270 if (o->op_flags & OPf_PARENS)
2271 /* [perl #17376]: this appears to be premature, and results in code such as
2272 C< our(%x); > executing in list mode rather than void mode */
2279 if ( PL_parser->bufptr > PL_parser->oldbufptr
2280 && PL_parser->bufptr[-1] == ','
2281 && ckWARN(WARN_PARENTHESIS))
2283 char *s = PL_parser->bufptr;
2286 /* some heuristics to detect a potential error */
2287 while (*s && (strchr(", \t\n", *s)))
2291 if (*s && strchr("@$%*", *s) && *++s
2292 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2295 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2297 while (*s && (strchr(", \t\n", *s)))
2303 if (sigil && (*s == ';' || *s == '=')) {
2304 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2305 "Parentheses missing around \"%s\" list",
2307 ? (PL_parser->in_my == KEY_our
2309 : PL_parser->in_my == KEY_state
2319 o = mod(o, OP_NULL); /* a bit kludgey */
2320 PL_parser->in_my = FALSE;
2321 PL_parser->in_my_stash = NULL;
2326 Perl_jmaybe(pTHX_ OP *o)
2328 if (o->op_type == OP_LIST) {
2330 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2331 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2337 Perl_fold_constants(pTHX_ register OP *o)
2342 VOL I32 type = o->op_type;
2347 SV * const oldwarnhook = PL_warnhook;
2348 SV * const olddiehook = PL_diehook;
2351 if (PL_opargs[type] & OA_RETSCALAR)
2353 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2354 o->op_targ = pad_alloc(type, SVs_PADTMP);
2356 /* integerize op, unless it happens to be C<-foo>.
2357 * XXX should pp_i_negate() do magic string negation instead? */
2358 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2359 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2360 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2362 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2365 if (!(PL_opargs[type] & OA_FOLDCONST))
2370 /* XXX might want a ck_negate() for this */
2371 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2382 /* XXX what about the numeric ops? */
2383 if (PL_hints & HINT_LOCALE)
2387 if (PL_parser && PL_parser->error_count)
2388 goto nope; /* Don't try to run w/ errors */
2390 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2391 const OPCODE type = curop->op_type;
2392 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2394 type != OP_SCALAR &&
2396 type != OP_PUSHMARK)
2402 curop = LINKLIST(o);
2403 old_next = o->op_next;
2407 oldscope = PL_scopestack_ix;
2408 create_eval_scope(G_FAKINGEVAL);
2410 PL_warnhook = PERL_WARNHOOK_FATAL;
2417 sv = *(PL_stack_sp--);
2418 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2419 pad_swipe(o->op_targ, FALSE);
2420 else if (SvTEMP(sv)) { /* grab mortal temp? */
2421 SvREFCNT_inc_simple_void(sv);
2426 /* Something tried to die. Abandon constant folding. */
2427 /* Pretend the error never happened. */
2428 sv_setpvn(ERRSV,"",0);
2429 o->op_next = old_next;
2433 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2434 PL_warnhook = oldwarnhook;
2435 PL_diehook = olddiehook;
2436 /* XXX note that this croak may fail as we've already blown away
2437 * the stack - eg any nested evals */
2438 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2441 PL_warnhook = oldwarnhook;
2442 PL_diehook = olddiehook;
2444 if (PL_scopestack_ix > oldscope)
2445 delete_eval_scope();
2454 if (type == OP_RV2GV)
2455 newop = newGVOP(OP_GV, 0, (GV*)sv);
2457 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2458 op_getmad(o,newop,'f');
2466 Perl_gen_constant_list(pTHX_ register OP *o)
2470 const I32 oldtmps_floor = PL_tmps_floor;
2473 if (PL_parser && PL_parser->error_count)
2474 return o; /* Don't attempt to run with errors */
2476 PL_op = curop = LINKLIST(o);
2482 assert (!(curop->op_flags & OPf_SPECIAL));
2483 assert(curop->op_type == OP_RANGE);
2485 PL_tmps_floor = oldtmps_floor;
2487 o->op_type = OP_RV2AV;
2488 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2489 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2490 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2491 o->op_opt = 0; /* needs to be revisited in peep() */
2492 curop = ((UNOP*)o)->op_first;
2493 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2495 op_getmad(curop,o,'O');
2504 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2507 if (!o || o->op_type != OP_LIST)
2508 o = newLISTOP(OP_LIST, 0, o, NULL);
2510 o->op_flags &= ~OPf_WANT;
2512 if (!(PL_opargs[type] & OA_MARK))
2513 op_null(cLISTOPo->op_first);
2515 o->op_type = (OPCODE)type;
2516 o->op_ppaddr = PL_ppaddr[type];
2517 o->op_flags |= flags;
2519 o = CHECKOP(type, o);
2520 if (o->op_type != (unsigned)type)
2523 return fold_constants(o);
2526 /* List constructors */
2529 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2537 if (first->op_type != (unsigned)type
2538 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2540 return newLISTOP(type, 0, first, last);
2543 if (first->op_flags & OPf_KIDS)
2544 ((LISTOP*)first)->op_last->op_sibling = last;
2546 first->op_flags |= OPf_KIDS;
2547 ((LISTOP*)first)->op_first = last;
2549 ((LISTOP*)first)->op_last = last;
2554 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2562 if (first->op_type != (unsigned)type)
2563 return prepend_elem(type, (OP*)first, (OP*)last);
2565 if (last->op_type != (unsigned)type)
2566 return append_elem(type, (OP*)first, (OP*)last);
2568 first->op_last->op_sibling = last->op_first;
2569 first->op_last = last->op_last;
2570 first->op_flags |= (last->op_flags & OPf_KIDS);
2573 if (last->op_first && first->op_madprop) {
2574 MADPROP *mp = last->op_first->op_madprop;
2576 while (mp->mad_next)
2578 mp->mad_next = first->op_madprop;
2581 last->op_first->op_madprop = first->op_madprop;
2584 first->op_madprop = last->op_madprop;
2585 last->op_madprop = 0;
2588 S_op_destroy(aTHX_ (OP*)last);
2594 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2602 if (last->op_type == (unsigned)type) {
2603 if (type == OP_LIST) { /* already a PUSHMARK there */
2604 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2605 ((LISTOP*)last)->op_first->op_sibling = first;
2606 if (!(first->op_flags & OPf_PARENS))
2607 last->op_flags &= ~OPf_PARENS;
2610 if (!(last->op_flags & OPf_KIDS)) {
2611 ((LISTOP*)last)->op_last = first;
2612 last->op_flags |= OPf_KIDS;
2614 first->op_sibling = ((LISTOP*)last)->op_first;
2615 ((LISTOP*)last)->op_first = first;
2617 last->op_flags |= OPf_KIDS;
2621 return newLISTOP(type, 0, first, last);
2629 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2632 Newxz(tk, 1, TOKEN);
2633 tk->tk_type = (OPCODE)optype;
2634 tk->tk_type = 12345;
2636 tk->tk_mad = madprop;
2641 Perl_token_free(pTHX_ TOKEN* tk)
2643 if (tk->tk_type != 12345)
2645 mad_free(tk->tk_mad);
2650 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2654 if (tk->tk_type != 12345) {
2655 Perl_warner(aTHX_ packWARN(WARN_MISC),
2656 "Invalid TOKEN object ignored");
2663 /* faked up qw list? */
2665 tm->mad_type == MAD_SV &&
2666 SvPVX((SV*)tm->mad_val)[0] == 'q')
2673 /* pretend constant fold didn't happen? */
2674 if (mp->mad_key == 'f' &&
2675 (o->op_type == OP_CONST ||
2676 o->op_type == OP_GV) )
2678 token_getmad(tk,(OP*)mp->mad_val,slot);
2692 if (mp->mad_key == 'X')
2693 mp->mad_key = slot; /* just change the first one */
2703 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2712 /* pretend constant fold didn't happen? */
2713 if (mp->mad_key == 'f' &&
2714 (o->op_type == OP_CONST ||
2715 o->op_type == OP_GV) )
2717 op_getmad(from,(OP*)mp->mad_val,slot);
2724 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2727 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2733 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2742 /* pretend constant fold didn't happen? */
2743 if (mp->mad_key == 'f' &&
2744 (o->op_type == OP_CONST ||
2745 o->op_type == OP_GV) )
2747 op_getmad(from,(OP*)mp->mad_val,slot);
2754 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2757 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2761 PerlIO_printf(PerlIO_stderr(),
2762 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2768 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2786 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2790 addmad(tm, &(o->op_madprop), slot);
2794 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2815 Perl_newMADsv(pTHX_ char key, SV* sv)
2817 return newMADPROP(key, MAD_SV, sv, 0);
2821 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2824 Newxz(mp, 1, MADPROP);
2827 mp->mad_vlen = vlen;
2828 mp->mad_type = type;
2830 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2835 Perl_mad_free(pTHX_ MADPROP* mp)
2837 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2841 mad_free(mp->mad_next);
2842 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2843 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2844 switch (mp->mad_type) {
2848 Safefree((char*)mp->mad_val);
2851 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2852 op_free((OP*)mp->mad_val);
2855 sv_free((SV*)mp->mad_val);
2858 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2867 Perl_newNULLLIST(pTHX)
2869 return newOP(OP_STUB, 0);
2873 Perl_force_list(pTHX_ OP *o)
2875 if (!o || o->op_type != OP_LIST)
2876 o = newLISTOP(OP_LIST, 0, o, NULL);
2882 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2887 NewOp(1101, listop, 1, LISTOP);
2889 listop->op_type = (OPCODE)type;
2890 listop->op_ppaddr = PL_ppaddr[type];
2893 listop->op_flags = (U8)flags;
2897 else if (!first && last)
2900 first->op_sibling = last;
2901 listop->op_first = first;
2902 listop->op_last = last;
2903 if (type == OP_LIST) {
2904 OP* const pushop = newOP(OP_PUSHMARK, 0);
2905 pushop->op_sibling = first;
2906 listop->op_first = pushop;
2907 listop->op_flags |= OPf_KIDS;
2909 listop->op_last = pushop;
2912 return CHECKOP(type, listop);
2916 Perl_newOP(pTHX_ I32 type, I32 flags)
2920 NewOp(1101, o, 1, OP);
2921 o->op_type = (OPCODE)type;
2922 o->op_ppaddr = PL_ppaddr[type];
2923 o->op_flags = (U8)flags;
2925 o->op_latefreed = 0;
2929 o->op_private = (U8)(0 | (flags >> 8));
2930 if (PL_opargs[type] & OA_RETSCALAR)
2932 if (PL_opargs[type] & OA_TARGET)
2933 o->op_targ = pad_alloc(type, SVs_PADTMP);
2934 return CHECKOP(type, o);
2938 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2944 first = newOP(OP_STUB, 0);
2945 if (PL_opargs[type] & OA_MARK)
2946 first = force_list(first);
2948 NewOp(1101, unop, 1, UNOP);
2949 unop->op_type = (OPCODE)type;
2950 unop->op_ppaddr = PL_ppaddr[type];
2951 unop->op_first = first;
2952 unop->op_flags = (U8)(flags | OPf_KIDS);
2953 unop->op_private = (U8)(1 | (flags >> 8));
2954 unop = (UNOP*) CHECKOP(type, unop);
2958 return fold_constants((OP *) unop);
2962 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2966 NewOp(1101, binop, 1, BINOP);
2969 first = newOP(OP_NULL, 0);
2971 binop->op_type = (OPCODE)type;
2972 binop->op_ppaddr = PL_ppaddr[type];
2973 binop->op_first = first;
2974 binop->op_flags = (U8)(flags | OPf_KIDS);
2977 binop->op_private = (U8)(1 | (flags >> 8));
2980 binop->op_private = (U8)(2 | (flags >> 8));
2981 first->op_sibling = last;
2984 binop = (BINOP*)CHECKOP(type, binop);
2985 if (binop->op_next || binop->op_type != (OPCODE)type)
2988 binop->op_last = binop->op_first->op_sibling;
2990 return fold_constants((OP *)binop);
2993 static int uvcompare(const void *a, const void *b)
2994 __attribute__nonnull__(1)
2995 __attribute__nonnull__(2)
2996 __attribute__pure__;
2997 static int uvcompare(const void *a, const void *b)
2999 if (*((const UV *)a) < (*(const UV *)b))
3001 if (*((const UV *)a) > (*(const UV *)b))
3003 if (*((const UV *)a+1) < (*(const UV *)b+1))
3005 if (*((const UV *)a+1) > (*(const UV *)b+1))
3011 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3014 SV * const tstr = ((SVOP*)expr)->op_sv;
3017 (repl->op_type == OP_NULL)
3018 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3020 ((SVOP*)repl)->op_sv;
3023 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3024 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3028 register short *tbl;
3030 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3031 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3032 I32 del = o->op_private & OPpTRANS_DELETE;
3034 PL_hints |= HINT_BLOCK_SCOPE;
3037 o->op_private |= OPpTRANS_FROM_UTF;
3040 o->op_private |= OPpTRANS_TO_UTF;
3042 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3043 SV* const listsv = newSVpvs("# comment\n");
3045 const U8* tend = t + tlen;
3046 const U8* rend = r + rlen;
3060 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3061 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3064 const U32 flags = UTF8_ALLOW_DEFAULT;
3068 t = tsave = bytes_to_utf8(t, &len);
3071 if (!to_utf && rlen) {
3073 r = rsave = bytes_to_utf8(r, &len);
3077 /* There are several snags with this code on EBCDIC:
3078 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3079 2. scan_const() in toke.c has encoded chars in native encoding which makes
3080 ranges at least in EBCDIC 0..255 range the bottom odd.
3084 U8 tmpbuf[UTF8_MAXBYTES+1];
3087 Newx(cp, 2*tlen, UV);
3089 transv = newSVpvs("");
3091 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3093 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3095 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3099 cp[2*i+1] = cp[2*i];
3103 qsort(cp, i, 2*sizeof(UV), uvcompare);
3104 for (j = 0; j < i; j++) {
3106 diff = val - nextmin;
3108 t = uvuni_to_utf8(tmpbuf,nextmin);
3109 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3111 U8 range_mark = UTF_TO_NATIVE(0xff);
3112 t = uvuni_to_utf8(tmpbuf, val - 1);
3113 sv_catpvn(transv, (char *)&range_mark, 1);
3114 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3121 t = uvuni_to_utf8(tmpbuf,nextmin);
3122 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3124 U8 range_mark = UTF_TO_NATIVE(0xff);
3125 sv_catpvn(transv, (char *)&range_mark, 1);
3127 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3128 UNICODE_ALLOW_SUPER);
3129 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3130 t = (const U8*)SvPVX_const(transv);
3131 tlen = SvCUR(transv);
3135 else if (!rlen && !del) {
3136 r = t; rlen = tlen; rend = tend;
3139 if ((!rlen && !del) || t == r ||
3140 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3142 o->op_private |= OPpTRANS_IDENTICAL;
3146 while (t < tend || tfirst <= tlast) {
3147 /* see if we need more "t" chars */
3148 if (tfirst > tlast) {
3149 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3151 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3153 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3160 /* now see if we need more "r" chars */
3161 if (rfirst > rlast) {
3163 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3165 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3167 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3176 rfirst = rlast = 0xffffffff;
3180 /* now see which range will peter our first, if either. */
3181 tdiff = tlast - tfirst;
3182 rdiff = rlast - rfirst;
3189 if (rfirst == 0xffffffff) {
3190 diff = tdiff; /* oops, pretend rdiff is infinite */
3192 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3193 (long)tfirst, (long)tlast);
3195 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3199 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3200 (long)tfirst, (long)(tfirst + diff),
3203 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3204 (long)tfirst, (long)rfirst);
3206 if (rfirst + diff > max)
3207 max = rfirst + diff;
3209 grows = (tfirst < rfirst &&
3210 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3222 else if (max > 0xff)
3227 PerlMemShared_free(cPVOPo->op_pv);
3228 cPVOPo->op_pv = NULL;
3230 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3232 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3233 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3234 PAD_SETSV(cPADOPo->op_padix, swash);
3237 cSVOPo->op_sv = swash;
3239 SvREFCNT_dec(listsv);
3240 SvREFCNT_dec(transv);
3242 if (!del && havefinal && rlen)
3243 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3244 newSVuv((UV)final), 0);
3247 o->op_private |= OPpTRANS_GROWS;
3253 op_getmad(expr,o,'e');
3254 op_getmad(repl,o,'r');
3262 tbl = (short*)cPVOPo->op_pv;
3264 Zero(tbl, 256, short);
3265 for (i = 0; i < (I32)tlen; i++)
3267 for (i = 0, j = 0; i < 256; i++) {
3269 if (j >= (I32)rlen) {
3278 if (i < 128 && r[j] >= 128)
3288 o->op_private |= OPpTRANS_IDENTICAL;
3290 else if (j >= (I32)rlen)
3295 PerlMemShared_realloc(tbl,
3296 (0x101+rlen-j) * sizeof(short));
3297 cPVOPo->op_pv = (char*)tbl;
3299 tbl[0x100] = (short)(rlen - j);
3300 for (i=0; i < (I32)rlen - j; i++)
3301 tbl[0x101+i] = r[j+i];
3305 if (!rlen && !del) {
3308 o->op_private |= OPpTRANS_IDENTICAL;
3310 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3311 o->op_private |= OPpTRANS_IDENTICAL;
3313 for (i = 0; i < 256; i++)
3315 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3316 if (j >= (I32)rlen) {
3318 if (tbl[t[i]] == -1)
3324 if (tbl[t[i]] == -1) {
3325 if (t[i] < 128 && r[j] >= 128)
3332 o->op_private |= OPpTRANS_GROWS;
3334 op_getmad(expr,o,'e');
3335 op_getmad(repl,o,'r');
3345 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3350 NewOp(1101, pmop, 1, PMOP);
3351 pmop->op_type = (OPCODE)type;
3352 pmop->op_ppaddr = PL_ppaddr[type];
3353 pmop->op_flags = (U8)flags;
3354 pmop->op_private = (U8)(0 | (flags >> 8));
3356 if (PL_hints & HINT_RE_TAINT)
3357 pmop->op_pmflags |= PMf_RETAINT;
3358 if (PL_hints & HINT_LOCALE)
3359 pmop->op_pmflags |= PMf_LOCALE;
3363 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3364 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3365 pmop->op_pmoffset = SvIV(repointer);
3366 SvREPADTMP_off(repointer);
3367 sv_setiv(repointer,0);
3369 SV * const repointer = newSViv(0);
3370 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3371 pmop->op_pmoffset = av_len(PL_regex_padav);
3372 PL_regex_pad = AvARRAY(PL_regex_padav);
3376 return CHECKOP(type, pmop);
3379 /* Given some sort of match op o, and an expression expr containing a
3380 * pattern, either compile expr into a regex and attach it to o (if it's
3381 * constant), or convert expr into a runtime regcomp op sequence (if it's
3384 * isreg indicates that the pattern is part of a regex construct, eg
3385 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3386 * split "pattern", which aren't. In the former case, expr will be a list
3387 * if the pattern contains more than one term (eg /a$b/) or if it contains
3388 * a replacement, ie s/// or tr///.
3392 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3397 I32 repl_has_vars = 0;
3401 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3402 /* last element in list is the replacement; pop it */
3404 repl = cLISTOPx(expr)->op_last;
3405 kid = cLISTOPx(expr)->op_first;
3406 while (kid->op_sibling != repl)
3407 kid = kid->op_sibling;
3408 kid->op_sibling = NULL;
3409 cLISTOPx(expr)->op_last = kid;
3412 if (isreg && expr->op_type == OP_LIST &&
3413 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3415 /* convert single element list to element */
3416 OP* const oe = expr;
3417 expr = cLISTOPx(oe)->op_first->op_sibling;
3418 cLISTOPx(oe)->op_first->op_sibling = NULL;
3419 cLISTOPx(oe)->op_last = NULL;
3423 if (o->op_type == OP_TRANS) {
3424 return pmtrans(o, expr, repl);
3427 reglist = isreg && expr->op_type == OP_LIST;
3431 PL_hints |= HINT_BLOCK_SCOPE;
3434 if (expr->op_type == OP_CONST) {
3435 SV *pat = ((SVOP*)expr)->op_sv;
3436 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3438 if (o->op_flags & OPf_SPECIAL)
3439 pm_flags |= RXf_SPLIT;
3442 assert (SvUTF8(pat));
3443 } else if (SvUTF8(pat)) {
3444 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3445 trapped in use 'bytes'? */
3446 /* Make a copy of the octet sequence, but without the flag on, as
3447 the compiler now honours the SvUTF8 flag on pat. */
3449 const char *const p = SvPV(pat, len);
3450 pat = newSVpvn_flags(p, len, SVs_TEMP);
3453 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3456 op_getmad(expr,(OP*)pm,'e');
3462 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3463 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3465 : OP_REGCMAYBE),0,expr);
3467 NewOp(1101, rcop, 1, LOGOP);
3468 rcop->op_type = OP_REGCOMP;
3469 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3470 rcop->op_first = scalar(expr);
3471 rcop->op_flags |= OPf_KIDS
3472 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3473 | (reglist ? OPf_STACKED : 0);
3474 rcop->op_private = 1;
3477 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3479 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3482 /* establish postfix order */
3483 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3485 rcop->op_next = expr;
3486 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3489 rcop->op_next = LINKLIST(expr);
3490 expr->op_next = (OP*)rcop;
3493 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3498 if (pm->op_pmflags & PMf_EVAL) {
3500 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3501 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3503 else if (repl->op_type == OP_CONST)
3507 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3508 if (curop->op_type == OP_SCOPE
3509 || curop->op_type == OP_LEAVE
3510 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3511 if (curop->op_type == OP_GV) {
3512 GV * const gv = cGVOPx_gv(curop);
3514 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3517 else if (curop->op_type == OP_RV2CV)
3519 else if (curop->op_type == OP_RV2SV ||
3520 curop->op_type == OP_RV2AV ||
3521 curop->op_type == OP_RV2HV ||
3522 curop->op_type == OP_RV2GV) {
3523 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3526 else if (curop->op_type == OP_PADSV ||
3527 curop->op_type == OP_PADAV ||
3528 curop->op_type == OP_PADHV ||
3529 curop->op_type == OP_PADANY)
3533 else if (curop->op_type == OP_PUSHRE)
3534 NOOP; /* Okay here, dangerous in newASSIGNOP */
3544 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3546 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3547 prepend_elem(o->op_type, scalar(repl), o);
3550 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3551 pm->op_pmflags |= PMf_MAYBE_CONST;
3553 NewOp(1101, rcop, 1, LOGOP);
3554 rcop->op_type = OP_SUBSTCONT;
3555 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3556 rcop->op_first = scalar(repl);
3557 rcop->op_flags |= OPf_KIDS;
3558 rcop->op_private = 1;
3561 /* establish postfix order */
3562 rcop->op_next = LINKLIST(repl);
3563 repl->op_next = (OP*)rcop;
3565 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3566 assert(!(pm->op_pmflags & PMf_ONCE));
3567 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3576 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3580 NewOp(1101, svop, 1, SVOP);
3581 svop->op_type = (OPCODE)type;
3582 svop->op_ppaddr = PL_ppaddr[type];
3584 svop->op_next = (OP*)svop;
3585 svop->op_flags = (U8)flags;
3586 if (PL_opargs[type] & OA_RETSCALAR)
3588 if (PL_opargs[type] & OA_TARGET)
3589 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3590 return CHECKOP(type, svop);
3595 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3599 NewOp(1101, padop, 1, PADOP);
3600 padop->op_type = (OPCODE)type;
3601 padop->op_ppaddr = PL_ppaddr[type];
3602 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3603 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3604 PAD_SETSV(padop->op_padix, sv);
3607 padop->op_next = (OP*)padop;
3608 padop->op_flags = (U8)flags;
3609 if (PL_opargs[type] & OA_RETSCALAR)
3611 if (PL_opargs[type] & OA_TARGET)
3612 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3613 return CHECKOP(type, padop);
3618 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3624 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3626 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3631 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3635 NewOp(1101, pvop, 1, PVOP);
3636 pvop->op_type = (OPCODE)type;
3637 pvop->op_ppaddr = PL_ppaddr[type];
3639 pvop->op_next = (OP*)pvop;
3640 pvop->op_flags = (U8)flags;
3641 if (PL_opargs[type] & OA_RETSCALAR)
3643 if (PL_opargs[type] & OA_TARGET)
3644 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3645 return CHECKOP(type, pvop);
3653 Perl_package(pTHX_ OP *o)
3656 SV *const sv = cSVOPo->op_sv;
3661 save_hptr(&PL_curstash);
3662 save_item(PL_curstname);
3664 PL_curstash = gv_stashsv(sv, GV_ADD);
3666 sv_setsv(PL_curstname, sv);
3668 PL_hints |= HINT_BLOCK_SCOPE;
3669 PL_parser->copline = NOLINE;
3670 PL_parser->expect = XSTATE;
3675 if (!PL_madskills) {
3680 pegop = newOP(OP_NULL,0);
3681 op_getmad(o,pegop,'P');
3691 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3698 OP *pegop = newOP(OP_NULL,0);
3701 if (idop->op_type != OP_CONST)
3702 Perl_croak(aTHX_ "Module name must be constant");
3705 op_getmad(idop,pegop,'U');
3710 SV * const vesv = ((SVOP*)version)->op_sv;
3713 op_getmad(version,pegop,'V');
3714 if (!arg && !SvNIOKp(vesv)) {
3721 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3722 Perl_croak(aTHX_ "Version number must be constant number");
3724 /* Make copy of idop so we don't free it twice */
3725 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3727 /* Fake up a method call to VERSION */
3728 meth = newSVpvs_share("VERSION");
3729 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3730 append_elem(OP_LIST,
3731 prepend_elem(OP_LIST, pack, list(version)),
3732 newSVOP(OP_METHOD_NAMED, 0, meth)));
3736 /* Fake up an import/unimport */
3737 if (arg && arg->op_type == OP_STUB) {
3739 op_getmad(arg,pegop,'S');
3740 imop = arg; /* no import on explicit () */
3742 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3743 imop = NULL; /* use 5.0; */
3745 idop->op_private |= OPpCONST_NOVER;
3751 op_getmad(arg,pegop,'A');
3753 /* Make copy of idop so we don't free it twice */
3754 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3756 /* Fake up a method call to import/unimport */
3758 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3759 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3760 append_elem(OP_LIST,
3761 prepend_elem(OP_LIST, pack, list(arg)),
3762 newSVOP(OP_METHOD_NAMED, 0, meth)));
3765 /* Fake up the BEGIN {}, which does its thing immediately. */
3767 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3770 append_elem(OP_LINESEQ,
3771 append_elem(OP_LINESEQ,
3772 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3773 newSTATEOP(0, NULL, veop)),
3774 newSTATEOP(0, NULL, imop) ));
3776 /* The "did you use incorrect case?" warning used to be here.
3777 * The problem is that on case-insensitive filesystems one
3778 * might get false positives for "use" (and "require"):
3779 * "use Strict" or "require CARP" will work. This causes
3780 * portability problems for the script: in case-strict
3781 * filesystems the script will stop working.
3783 * The "incorrect case" warning checked whether "use Foo"
3784 * imported "Foo" to your namespace, but that is wrong, too:
3785 * there is no requirement nor promise in the language that
3786 * a Foo.pm should or would contain anything in package "Foo".
3788 * There is very little Configure-wise that can be done, either:
3789 * the case-sensitivity of the build filesystem of Perl does not
3790 * help in guessing the case-sensitivity of the runtime environment.
3793 PL_hints |= HINT_BLOCK_SCOPE;
3794 PL_parser->copline = NOLINE;
3795 PL_parser->expect = XSTATE;
3796 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3799 if (!PL_madskills) {
3800 /* FIXME - don't allocate pegop if !PL_madskills */
3809 =head1 Embedding Functions
3811 =for apidoc load_module
3813 Loads the module whose name is pointed to by the string part of name.
3814 Note that the actual module name, not its filename, should be given.
3815 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3816 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3817 (or 0 for no flags). ver, if specified, provides version semantics
3818 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3819 arguments can be used to specify arguments to the module's import()
3820 method, similar to C<use Foo::Bar VERSION LIST>.
3825 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3828 va_start(args, ver);
3829 vload_module(flags, name, ver, &args);
3833 #ifdef PERL_IMPLICIT_CONTEXT
3835 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3839 va_start(args, ver);
3840 vload_module(flags, name, ver, &args);
3846 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3851 OP * const modname = newSVOP(OP_CONST, 0, name);
3852 modname->op_private |= OPpCONST_BARE;
3854 veop = newSVOP(OP_CONST, 0, ver);
3858 if (flags & PERL_LOADMOD_NOIMPORT) {
3859 imop = sawparens(newNULLLIST());
3861 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3862 imop = va_arg(*args, OP*);
3867 sv = va_arg(*args, SV*);
3869 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3870 sv = va_arg(*args, SV*);
3874 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3875 * that it has a PL_parser to play with while doing that, and also
3876 * that it doesn't mess with any existing parser, by creating a tmp
3877 * new parser with lex_start(). This won't actually be used for much,
3878 * since pp_require() will create another parser for the real work. */
3881 SAVEVPTR(PL_curcop);
3882 lex_start(NULL, NULL, FALSE);
3883 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3884 veop, modname, imop);
3889 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3895 if (!force_builtin) {
3896 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3897 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3898 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3899 gv = gvp ? *gvp : NULL;
3903 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3904 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3905 append_elem(OP_LIST, term,
3906 scalar(newUNOP(OP_RV2CV, 0,
3907 newGVOP(OP_GV, 0, gv))))));
3910 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3916 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3918 return newBINOP(OP_LSLICE, flags,
3919 list(force_list(subscript)),
3920 list(force_list(listval)) );
3924 S_is_list_assignment(pTHX_ register const OP *o)
3932 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3933 o = cUNOPo->op_first;
3935 flags = o->op_flags;
3937 if (type == OP_COND_EXPR) {
3938 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3939 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3944 yyerror("Assignment to both a list and a scalar");
3948 if (type == OP_LIST &&
3949 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3950 o->op_private & OPpLVAL_INTRO)
3953 if (type == OP_LIST || flags & OPf_PARENS ||
3954 type == OP_RV2AV || type == OP_RV2HV ||
3955 type == OP_ASLICE || type == OP_HSLICE)
3958 if (type == OP_PADAV || type == OP_PADHV)
3961 if (type == OP_RV2SV)
3968 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3974 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3975 return newLOGOP(optype, 0,
3976 mod(scalar(left), optype),
3977 newUNOP(OP_SASSIGN, 0, scalar(right)));
3980 return newBINOP(optype, OPf_STACKED,
3981 mod(scalar(left), optype), scalar(right));
3985 if (is_list_assignment(left)) {
3986 static const char no_list_state[] = "Initialization of state variables"
3987 " in list context currently forbidden";
3991 /* Grandfathering $[ assignment here. Bletch.*/
3992 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3993 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
3994 left = mod(left, OP_AASSIGN);
3997 else if (left->op_type == OP_CONST) {
3999 /* Result of assignment is always 1 (or we'd be dead already) */
4000 return newSVOP(OP_CONST, 0, newSViv(1));
4002 curop = list(force_list(left));
4003 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4004 o->op_private = (U8)(0 | (flags >> 8));
4006 /* PL_generation sorcery:
4007 * an assignment like ($a,$b) = ($c,$d) is easier than
4008 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4009 * To detect whether there are common vars, the global var
4010 * PL_generation is incremented for each assign op we compile.
4011 * Then, while compiling the assign op, we run through all the
4012 * variables on both sides of the assignment, setting a spare slot
4013 * in each of them to PL_generation. If any of them already have
4014 * that value, we know we've got commonality. We could use a
4015 * single bit marker, but then we'd have to make 2 passes, first
4016 * to clear the flag, then to test and set it. To find somewhere
4017 * to store these values, evil chicanery is done with SvUVX().
4023 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4024 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4025 if (curop->op_type == OP_GV) {
4026 GV *gv = cGVOPx_gv(curop);
4028 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4030 GvASSIGN_GENERATION_set(gv, PL_generation);
4032 else if (curop->op_type == OP_PADSV ||
4033 curop->op_type == OP_PADAV ||
4034 curop->op_type == OP_PADHV ||
4035 curop->op_type == OP_PADANY)
4037 if (PAD_COMPNAME_GEN(curop->op_targ)
4038 == (STRLEN)PL_generation)
4040 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4043 else if (curop->op_type == OP_RV2CV)
4045 else if (curop->op_type == OP_RV2SV ||
4046 curop->op_type == OP_RV2AV ||
4047 curop->op_type == OP_RV2HV ||
4048 curop->op_type == OP_RV2GV) {
4049 if (lastop->op_type != OP_GV) /* funny deref? */
4052 else if (curop->op_type == OP_PUSHRE) {
4054 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4055 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4057 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4059 GvASSIGN_GENERATION_set(gv, PL_generation);
4063 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4066 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4068 GvASSIGN_GENERATION_set(gv, PL_generation);
4078 o->op_private |= OPpASSIGN_COMMON;
4081 if ((left->op_type == OP_LIST
4082 || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) {
4083 OP* lop = ((LISTOP*)left)->op_first;
4085 if (lop->op_type == OP_PADSV ||
4086 lop->op_type == OP_PADAV ||
4087 lop->op_type == OP_PADHV ||
4088 lop->op_type == OP_PADANY) {
4089 if (lop->op_private & OPpPAD_STATE) {
4090 if (left->op_private & OPpLVAL_INTRO) {
4091 /* Each variable in state($a, $b, $c) = ... */
4094 /* Each state variable in
4095 (state $a, my $b, our $c, $d, undef) = ... */
4097 yyerror(no_list_state);
4099 /* Each my variable in
4100 (state $a, my $b, our $c, $d, undef) = ... */
4103 /* Other ops in the list. undef may be interesting in
4104 (state $a, undef, state $c) */
4106 lop = lop->op_sibling;
4109 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4110 == (OPpLVAL_INTRO | OPpPAD_STATE))
4111 && ( left->op_type == OP_PADSV
4112 || left->op_type == OP_PADAV
4113 || left->op_type == OP_PADHV
4114 || left->op_type == OP_PADANY))
4116 /* All single variable list context state assignments, hence
4126 yyerror(no_list_state);
4129 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4130 OP* tmpop = ((LISTOP*)right)->op_first;
4131 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4132 PMOP * const pm = (PMOP*)tmpop;
4133 if (left->op_type == OP_RV2AV &&
4134 !(left->op_private & OPpLVAL_INTRO) &&
4135 !(o->op_private & OPpASSIGN_COMMON) )
4137 tmpop = ((UNOP*)left)->op_first;
4138 if (tmpop->op_type == OP_GV
4140 && !pm->op_pmreplrootu.op_pmtargetoff
4142 && !pm->op_pmreplrootu.op_pmtargetgv
4146 pm->op_pmreplrootu.op_pmtargetoff
4147 = cPADOPx(tmpop)->op_padix;
4148 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4150 pm->op_pmreplrootu.op_pmtargetgv
4151 = (GV*)cSVOPx(tmpop)->op_sv;
4152 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4154 pm->op_pmflags |= PMf_ONCE;
4155 tmpop = cUNOPo->op_first; /* to list (nulled) */
4156 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4157 tmpop->op_sibling = NULL; /* don't free split */
4158 right->op_next = tmpop->op_next; /* fix starting loc */
4159 op_free(o); /* blow off assign */
4160 right->op_flags &= ~OPf_WANT;
4161 /* "I don't know and I don't care." */
4166 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4167 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4169 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4171 sv_setiv(sv, PL_modcount+1);
4179 right = newOP(OP_UNDEF, 0);
4180 if (right->op_type == OP_READLINE) {
4181 right->op_flags |= OPf_STACKED;
4182 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4185 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4186 o = newBINOP(OP_SASSIGN, flags,
4187 scalar(right), mod(scalar(left), OP_SASSIGN) );
4193 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4194 o->op_private |= OPpCONST_ARYBASE;
4201 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4204 const U32 seq = intro_my();
4207 NewOp(1101, cop, 1, COP);
4208 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4209 cop->op_type = OP_DBSTATE;
4210 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4213 cop->op_type = OP_NEXTSTATE;
4214 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4216 cop->op_flags = (U8)flags;
4217 CopHINTS_set(cop, PL_hints);
4219 cop->op_private |= NATIVE_HINTS;
4221 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4222 cop->op_next = (OP*)cop;
4225 CopLABEL_set(cop, label);
4226 PL_hints |= HINT_BLOCK_SCOPE;
4229 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4230 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4232 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4233 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4234 if (cop->cop_hints_hash) {
4236 cop->cop_hints_hash->refcounted_he_refcnt++;
4237 HINTS_REFCNT_UNLOCK;
4240 if (PL_parser && PL_parser->copline == NOLINE)
4241 CopLINE_set(cop, CopLINE(PL_curcop));
4243 CopLINE_set(cop, PL_parser->copline);
4245 PL_parser->copline = NOLINE;
4248 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4250 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4252 CopSTASH_set(cop, PL_curstash);
4254 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4255 AV *av = CopFILEAVx(PL_curcop);
4257 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4258 if (svp && *svp != &PL_sv_undef ) {
4259 (void)SvIOK_on(*svp);
4260 SvIV_set(*svp, PTR2IV(cop));
4265 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4270 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4273 return new_logop(type, flags, &first, &other);
4277 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4282 OP *first = *firstp;
4283 OP * const other = *otherp;
4285 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4286 return newBINOP(type, flags, scalar(first), scalar(other));
4288 scalarboolean(first);
4289 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4290 if (first->op_type == OP_NOT
4291 && (first->op_flags & OPf_SPECIAL)
4292 && (first->op_flags & OPf_KIDS)
4294 if (type == OP_AND || type == OP_OR) {
4300 first = *firstp = cUNOPo->op_first;
4302 first->op_next = o->op_next;
4303 cUNOPo->op_first = NULL;
4307 if (first->op_type == OP_CONST) {
4308 if (first->op_private & OPpCONST_STRICT)
4309 no_bareword_allowed(first);
4310 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4311 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4312 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4313 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4314 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4316 if (other->op_type == OP_CONST)
4317 other->op_private |= OPpCONST_SHORTCIRCUIT;
4319 OP *newop = newUNOP(OP_NULL, 0, other);
4320 op_getmad(first, newop, '1');
4321 newop->op_targ = type; /* set "was" field */
4328 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4329 const OP *o2 = other;
4330 if ( ! (o2->op_type == OP_LIST
4331 && (( o2 = cUNOPx(o2)->op_first))
4332 && o2->op_type == OP_PUSHMARK
4333 && (( o2 = o2->op_sibling)) )
4336 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4337 || o2->op_type == OP_PADHV)
4338 && o2->op_private & OPpLVAL_INTRO
4339 && !(o2->op_private & OPpPAD_STATE)
4340 && ckWARN(WARN_DEPRECATED))
4342 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4343 "Deprecated use of my() in false conditional");
4347 if (first->op_type == OP_CONST)
4348 first->op_private |= OPpCONST_SHORTCIRCUIT;
4350 first = newUNOP(OP_NULL, 0, first);
4351 op_getmad(other, first, '2');
4352 first->op_targ = type; /* set "was" field */
4359 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4360 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4362 const OP * const k1 = ((UNOP*)first)->op_first;
4363 const OP * const k2 = k1->op_sibling;
4365 switch (first->op_type)
4368 if (k2 && k2->op_type == OP_READLINE
4369 && (k2->op_flags & OPf_STACKED)
4370 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4372 warnop = k2->op_type;
4377 if (k1->op_type == OP_READDIR
4378 || k1->op_type == OP_GLOB
4379 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4380 || k1->op_type == OP_EACH)
4382 warnop = ((k1->op_type == OP_NULL)
4383 ? (OPCODE)k1->op_targ : k1->op_type);
4388 const line_t oldline = CopLINE(PL_curcop);
4389 CopLINE_set(PL_curcop, PL_parser->copline);
4390 Perl_warner(aTHX_ packWARN(WARN_MISC),
4391 "Value of %s%s can be \"0\"; test with defined()",
4393 ((warnop == OP_READLINE || warnop == OP_GLOB)
4394 ? " construct" : "() operator"));
4395 CopLINE_set(PL_curcop, oldline);
4402 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4403 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4405 NewOp(1101, logop, 1, LOGOP);
4407 logop->op_type = (OPCODE)type;
4408 logop->op_ppaddr = PL_ppaddr[type];
4409 logop->op_first = first;
4410 logop->op_flags = (U8)(flags | OPf_KIDS);
4411 logop->op_other = LINKLIST(other);
4412 logop->op_private = (U8)(1 | (flags >> 8));
4414 /* establish postfix order */
4415 logop->op_next = LINKLIST(first);
4416 first->op_next = (OP*)logop;
4417 first->op_sibling = other;
4419 CHECKOP(type,logop);
4421 o = newUNOP(OP_NULL, 0, (OP*)logop);
4428 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4436 return newLOGOP(OP_AND, 0, first, trueop);
4438 return newLOGOP(OP_OR, 0, first, falseop);
4440 scalarboolean(first);
4441 if (first->op_type == OP_CONST) {
4442 /* Left or right arm of the conditional? */
4443 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4444 OP *live = left ? trueop : falseop;
4445 OP *const dead = left ? falseop : trueop;
4446 if (first->op_private & OPpCONST_BARE &&
4447 first->op_private & OPpCONST_STRICT) {
4448 no_bareword_allowed(first);
4451 /* This is all dead code when PERL_MAD is not defined. */
4452 live = newUNOP(OP_NULL, 0, live);
4453 op_getmad(first, live, 'C');
4454 op_getmad(dead, live, left ? 'e' : 't');
4461 NewOp(1101, logop, 1, LOGOP);
4462 logop->op_type = OP_COND_EXPR;
4463 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4464 logop->op_first = first;
4465 logop->op_flags = (U8)(flags | OPf_KIDS);
4466 logop->op_private = (U8)(1 | (flags >> 8));
4467 logop->op_other = LINKLIST(trueop);
4468 logop->op_next = LINKLIST(falseop);
4470 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4473 /* establish postfix order */
4474 start = LINKLIST(first);
4475 first->op_next = (OP*)logop;
4477 first->op_sibling = trueop;
4478 trueop->op_sibling = falseop;
4479 o = newUNOP(OP_NULL, 0, (OP*)logop);
4481 trueop->op_next = falseop->op_next = o;
4488 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4497 NewOp(1101, range, 1, LOGOP);
4499 range->op_type = OP_RANGE;
4500 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4501 range->op_first = left;
4502 range->op_flags = OPf_KIDS;
4503 leftstart = LINKLIST(left);
4504 range->op_other = LINKLIST(right);
4505 range->op_private = (U8)(1 | (flags >> 8));
4507 left->op_sibling = right;
4509 range->op_next = (OP*)range;
4510 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4511 flop = newUNOP(OP_FLOP, 0, flip);
4512 o = newUNOP(OP_NULL, 0, flop);
4514 range->op_next = leftstart;
4516 left->op_next = flip;
4517 right->op_next = flop;
4519 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4520 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4521 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4522 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4524 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4525 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4528 if (!flip->op_private || !flop->op_private)
4529 linklist(o); /* blow off optimizer unless constant */
4535 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4540 const bool once = block && block->op_flags & OPf_SPECIAL &&
4541 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4543 PERL_UNUSED_ARG(debuggable);
4546 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4547 return block; /* do {} while 0 does once */
4548 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4549 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4550 expr = newUNOP(OP_DEFINED, 0,
4551 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4552 } else if (expr->op_flags & OPf_KIDS) {
4553 const OP * const k1 = ((UNOP*)expr)->op_first;
4554 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4555 switch (expr->op_type) {
4557 if (k2 && k2->op_type == OP_READLINE
4558 && (k2->op_flags & OPf_STACKED)
4559 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4560 expr = newUNOP(OP_DEFINED, 0, expr);
4564 if (k1 && (k1->op_type == OP_READDIR
4565 || k1->op_type == OP_GLOB
4566 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4567 || k1->op_type == OP_EACH))
4568 expr = newUNOP(OP_DEFINED, 0, expr);
4574 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4575 * op, in listop. This is wrong. [perl #27024] */
4577 block = newOP(OP_NULL, 0);
4578 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4579 o = new_logop(OP_AND, 0, &expr, &listop);
4582 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4584 if (once && o != listop)
4585 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4588 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4590 o->op_flags |= flags;
4592 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4597 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4598 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4607 PERL_UNUSED_ARG(debuggable);
4610 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4611 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4612 expr = newUNOP(OP_DEFINED, 0,
4613 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4614 } else if (expr->op_flags & OPf_KIDS) {
4615 const OP * const k1 = ((UNOP*)expr)->op_first;
4616 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4617 switch (expr->op_type) {
4619 if (k2 && k2->op_type == OP_READLINE
4620 && (k2->op_flags & OPf_STACKED)
4621 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4622 expr = newUNOP(OP_DEFINED, 0, expr);
4626 if (k1 && (k1->op_type == OP_READDIR
4627 || k1->op_type == OP_GLOB
4628 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4629 || k1->op_type == OP_EACH))
4630 expr = newUNOP(OP_DEFINED, 0, expr);
4637 block = newOP(OP_NULL, 0);
4638 else if (cont || has_my) {
4639 block = scope(block);
4643 next = LINKLIST(cont);
4646 OP * const unstack = newOP(OP_UNSTACK, 0);
4649 cont = append_elem(OP_LINESEQ, cont, unstack);
4653 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4655 redo = LINKLIST(listop);
4658 PL_parser->copline = (line_t)whileline;
4660 o = new_logop(OP_AND, 0, &expr, &listop);
4661 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4662 op_free(expr); /* oops, it's a while (0) */
4664 return NULL; /* listop already freed by new_logop */
4667 ((LISTOP*)listop)->op_last->op_next =
4668 (o == listop ? redo : LINKLIST(o));
4674 NewOp(1101,loop,1,LOOP);
4675 loop->op_type = OP_ENTERLOOP;
4676 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4677 loop->op_private = 0;
4678 loop->op_next = (OP*)loop;
4681 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4683 loop->op_redoop = redo;
4684 loop->op_lastop = o;
4685 o->op_private |= loopflags;
4688 loop->op_nextop = next;
4690 loop->op_nextop = o;
4692 o->op_flags |= flags;
4693 o->op_private |= (flags >> 8);
4698 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4703 PADOFFSET padoff = 0;
4709 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4710 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4711 sv->op_type = OP_RV2GV;
4712 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4714 /* The op_type check is needed to prevent a possible segfault
4715 * if the loop variable is undeclared and 'strict vars' is in
4716 * effect. This is illegal but is nonetheless parsed, so we
4717 * may reach this point with an OP_CONST where we're expecting
4720 if (cUNOPx(sv)->op_first->op_type == OP_GV
4721 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4722 iterpflags |= OPpITER_DEF;
4724 else if (sv->op_type == OP_PADSV) { /* private variable */
4725 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4726 padoff = sv->op_targ;
4736 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4738 SV *const namesv = PAD_COMPNAME_SV(padoff);
4740 const char *const name = SvPV_const(namesv, len);
4742 if (len == 2 && name[0] == '$' && name[1] == '_')
4743 iterpflags |= OPpITER_DEF;
4747 const PADOFFSET offset = pad_findmy("$_");
4748 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4749 sv = newGVOP(OP_GV, 0, PL_defgv);
4754 iterpflags |= OPpITER_DEF;
4756 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4757 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4758 iterflags |= OPf_STACKED;
4760 else if (expr->op_type == OP_NULL &&
4761 (expr->op_flags & OPf_KIDS) &&
4762 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4764 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4765 * set the STACKED flag to indicate that these values are to be
4766 * treated as min/max values by 'pp_iterinit'.
4768 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4769 LOGOP* const range = (LOGOP*) flip->op_first;
4770 OP* const left = range->op_first;
4771 OP* const right = left->op_sibling;
4774 range->op_flags &= ~OPf_KIDS;
4775 range->op_first = NULL;
4777 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4778 listop->op_first->op_next = range->op_next;
4779 left->op_next = range->op_other;
4780 right->op_next = (OP*)listop;
4781 listop->op_next = listop->op_first;
4784 op_getmad(expr,(OP*)listop,'O');
4788 expr = (OP*)(listop);
4790 iterflags |= OPf_STACKED;
4793 expr = mod(force_list(expr), OP_GREPSTART);
4796 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4797 append_elem(OP_LIST, expr, scalar(sv))));
4798 assert(!loop->op_next);
4799 /* for my $x () sets OPpLVAL_INTRO;
4800 * for our $x () sets OPpOUR_INTRO */
4801 loop->op_private = (U8)iterpflags;
4802 #ifdef PL_OP_SLAB_ALLOC
4805 NewOp(1234,tmp,1,LOOP);
4806 Copy(loop,tmp,1,LISTOP);
4807 S_op_destroy(aTHX_ (OP*)loop);