3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifdef PERL_DEBUG_READONLY_OPS
108 # define PERL_SLAB_SIZE 4096
109 # include <sys/mman.h>
112 #ifndef PERL_SLAB_SIZE
113 #define PERL_SLAB_SIZE 2048
117 Perl_Slab_Alloc(pTHX_ size_t sz)
120 * To make incrementing use count easy PL_OpSlab is an I32 *
121 * To make inserting the link to slab PL_OpPtr is I32 **
122 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
123 * Add an overhead for pointer to slab and round up as a number of pointers
125 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
126 if ((PL_OpSpace -= sz) < 0) {
127 #ifdef PERL_DEBUG_READONLY_OPS
128 /* We need to allocate chunk by chunk so that we can control the VM
130 PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
131 MAP_ANON|MAP_PRIVATE, -1, 0);
133 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
134 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
136 if(PL_OpPtr == MAP_FAILED) {
137 perror("mmap failed");
142 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
147 /* We reserve the 0'th I32 sized chunk as a use count */
148 PL_OpSlab = (I32 *) PL_OpPtr;
149 /* Reduce size by the use count word, and by the size we need.
150 * Latter is to mimic the '-=' in the if() above
152 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
153 /* Allocation pointer starts at the top.
154 Theory: because we build leaves before trunk allocating at end
155 means that at run time access is cache friendly upward
157 PL_OpPtr += PERL_SLAB_SIZE;
159 #ifdef PERL_DEBUG_READONLY_OPS
160 /* We remember this slab. */
161 /* This implementation isn't efficient, but it is simple. */
162 PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
163 PL_slabs[PL_slab_count++] = PL_OpSlab;
164 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
167 assert( PL_OpSpace >= 0 );
168 /* Move the allocation pointer down */
170 assert( PL_OpPtr > (I32 **) PL_OpSlab );
171 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
172 (*PL_OpSlab)++; /* Increment use count of slab */
173 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
174 assert( *PL_OpSlab > 0 );
175 return (void *)(PL_OpPtr + 1);
178 #ifdef PERL_DEBUG_READONLY_OPS
180 Perl_pending_Slabs_to_ro(pTHX) {
181 /* Turn all the allocated op slabs read only. */
182 U32 count = PL_slab_count;
183 I32 **const slabs = PL_slabs;
185 /* Reset the array of pending OP slabs, as we're about to turn this lot
186 read only. Also, do it ahead of the loop in case the warn triggers,
187 and a warn handler has an eval */
193 /* Force a new slab for any further allocation. */
197 const void *start = slabs[count];
198 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
199 if(mprotect(start, size, PROT_READ)) {
200 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
201 start, (unsigned long) size, errno);
207 S_Slab_to_rw(pTHX_ void *op)
209 I32 * const * const ptr = (I32 **) op;
210 I32 * const slab = ptr[-1];
211 assert( ptr-1 > (I32 **) slab );
212 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
214 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
215 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
216 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
221 Perl_op_refcnt_inc(pTHX_ OP *o)
232 Perl_op_refcnt_dec(pTHX_ OP *o)
238 # define Slab_to_rw(op)
242 Perl_Slab_Free(pTHX_ void *op)
244 I32 * const * const ptr = (I32 **) op;
245 I32 * const slab = ptr[-1];
246 assert( ptr-1 > (I32 **) slab );
247 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
250 if (--(*slab) == 0) {
252 # define PerlMemShared PerlMem
255 #ifdef PERL_DEBUG_READONLY_OPS
256 U32 count = PL_slab_count;
257 /* Need to remove this slab from our list of slabs */
260 if (PL_slabs[count] == slab) {
261 /* Found it. Move the entry at the end to overwrite it. */
262 DEBUG_m(PerlIO_printf(Perl_debug_log,
263 "Deallocate %p by moving %p from %lu to %lu\n",
265 PL_slabs[PL_slab_count - 1],
266 PL_slab_count, count));
267 PL_slabs[count] = PL_slabs[--PL_slab_count];
268 /* Could realloc smaller at this point, but probably not
270 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
271 perror("munmap failed");
279 PerlMemShared_free(slab);
281 if (slab == PL_OpSlab) {
288 * In the following definition, the ", (OP*)0" is just to make the compiler
289 * think the expression is of the right type: croak actually does a Siglongjmp.
291 #define CHECKOP(type,o) \
292 ((PL_op_mask && PL_op_mask[type]) \
293 ? ( op_free((OP*)o), \
294 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
296 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
298 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
301 S_gv_ename(pTHX_ GV *gv)
303 SV* const tmpsv = sv_newmortal();
304 gv_efullname3(tmpsv, gv, NULL);
305 return SvPV_nolen_const(tmpsv);
309 S_no_fh_allowed(pTHX_ OP *o)
311 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
317 S_too_few_arguments(pTHX_ OP *o, const char *name)
319 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
324 S_too_many_arguments(pTHX_ OP *o, const char *name)
326 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
331 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
333 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
334 (int)n, name, t, OP_DESC(kid)));
338 S_no_bareword_allowed(pTHX_ const OP *o)
341 return; /* various ok barewords are hidden in extra OP_NULL */
342 qerror(Perl_mess(aTHX_
343 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
347 /* "register" allocation */
350 Perl_allocmy(pTHX_ const char *const name)
354 const bool is_our = (PL_in_my == KEY_our);
356 /* complain about "my $<special_var>" etc etc */
360 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
361 (name[1] == '_' && (*name == '$' || name[2]))))
363 /* name[2] is true if strlen(name) > 2 */
364 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
365 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
366 name[0], toCTRL(name[1]), name + 2));
368 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
372 /* check for duplicate declaration */
373 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
375 if (PL_in_my_stash && *name != '$') {
376 yyerror(Perl_form(aTHX_
377 "Can't declare class for non-scalar %s in \"%s\"",
379 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
382 /* allocate a spare slot and store the name in that slot */
384 off = pad_add_name(name,
387 /* $_ is always in main::, even with our */
388 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
392 PL_in_my == KEY_state
397 /* free the body of an op without examining its contents.
398 * Always use this rather than FreeOp directly */
401 S_op_destroy(pTHX_ OP *o)
403 if (o->op_latefree) {
414 Perl_op_free(pTHX_ OP *o)
419 if (!o || o->op_static)
421 if (o->op_latefreed) {
428 if (o->op_private & OPpREFCOUNTED) {
439 refcnt = OpREFCNT_dec(o);
442 /* Need to find and remove any pattern match ops from the list
443 we maintain for reset(). */
444 find_and_forget_pmops(o);
454 if (o->op_flags & OPf_KIDS) {
455 register OP *kid, *nextkid;
456 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
457 nextkid = kid->op_sibling; /* Get before next freeing kid */
462 type = (OPCODE)o->op_targ;
464 #ifdef PERL_DEBUG_READONLY_OPS
468 /* COP* is not cleared by op_clear() so that we may track line
469 * numbers etc even after null() */
470 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
475 if (o->op_latefree) {
481 #ifdef DEBUG_LEAKING_SCALARS
488 Perl_op_clear(pTHX_ OP *o)
493 /* if (o->op_madprop && o->op_madprop->mad_next)
495 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
496 "modification of a read only value" for a reason I can't fathom why.
497 It's the "" stringification of $_, where $_ was set to '' in a foreach
498 loop, but it defies simplification into a small test case.
499 However, commenting them out has caused ext/List/Util/t/weak.t to fail
502 mad_free(o->op_madprop);
508 switch (o->op_type) {
509 case OP_NULL: /* Was holding old type, if any. */
510 if (PL_madskills && o->op_targ != OP_NULL) {
511 o->op_type = o->op_targ;
515 case OP_ENTEREVAL: /* Was holding hints. */
519 if (!(o->op_flags & OPf_REF)
520 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
526 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
527 /* not an OP_PADAV replacement */
529 if (cPADOPo->op_padix > 0) {
530 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
531 * may still exist on the pad */
532 pad_swipe(cPADOPo->op_padix, TRUE);
533 cPADOPo->op_padix = 0;
536 SvREFCNT_dec(cSVOPo->op_sv);
537 cSVOPo->op_sv = NULL;
541 case OP_METHOD_NAMED:
543 SvREFCNT_dec(cSVOPo->op_sv);
544 cSVOPo->op_sv = NULL;
547 Even if op_clear does a pad_free for the target of the op,
548 pad_free doesn't actually remove the sv that exists in the pad;
549 instead it lives on. This results in that it could be reused as
550 a target later on when the pad was reallocated.
553 pad_swipe(o->op_targ,1);
562 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
566 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
568 if (cPADOPo->op_padix > 0) {
569 pad_swipe(cPADOPo->op_padix, TRUE);
570 cPADOPo->op_padix = 0;
573 SvREFCNT_dec(cSVOPo->op_sv);
574 cSVOPo->op_sv = NULL;
578 PerlMemShared_free(cPVOPo->op_pv);
579 cPVOPo->op_pv = NULL;
583 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
587 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
588 /* No GvIN_PAD_off here, because other references may still
589 * exist on the pad */
590 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
593 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
599 forget_pmop(cPMOPo, 1);
600 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
601 /* we use the "SAFE" version of the PM_ macros here
602 * since sv_clean_all might release some PMOPs
603 * after PL_regex_padav has been cleared
604 * and the clearing of PL_regex_padav needs to
605 * happen before sv_clean_all
607 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
608 PM_SETRE_SAFE(cPMOPo, NULL);
610 if(PL_regex_pad) { /* We could be in destruction */
611 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
612 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
613 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
614 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
621 if (o->op_targ > 0) {
622 pad_free(o->op_targ);
628 S_cop_free(pTHX_ COP* cop)
633 if (! specialWARN(cop->cop_warnings))
634 PerlMemShared_free(cop->cop_warnings);
635 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
639 S_forget_pmop(pTHX_ PMOP *const o, U32 flags)
641 HV * const pmstash = PmopSTASH(o);
642 if (pmstash && !SvIS_FREED(pmstash)) {
643 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
645 PMOP **const array = (PMOP**) mg->mg_ptr;
646 U32 count = mg->mg_len / sizeof(PMOP**);
651 /* Found it. Move the entry at the end to overwrite it. */
652 array[i] = array[--count];
653 mg->mg_len = count * sizeof(PMOP**);
654 /* Could realloc smaller at this point always, but probably
655 not worth it. Probably worth free()ing if we're the
658 Safefree(mg->mg_ptr);
671 S_find_and_forget_pmops(pTHX_ OP *o)
673 if (o->op_flags & OPf_KIDS) {
674 OP *kid = cUNOPo->op_first;
676 switch (kid->op_type) {
681 forget_pmop((PMOP*)kid, 0);
683 find_and_forget_pmops(kid);
684 kid = kid->op_sibling;
690 Perl_op_null(pTHX_ OP *o)
693 if (o->op_type == OP_NULL)
697 o->op_targ = o->op_type;
698 o->op_type = OP_NULL;
699 o->op_ppaddr = PL_ppaddr[OP_NULL];
703 Perl_op_refcnt_lock(pTHX)
711 Perl_op_refcnt_unlock(pTHX)
718 /* Contextualizers */
720 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
723 Perl_linklist(pTHX_ OP *o)
730 /* establish postfix order */
731 first = cUNOPo->op_first;
734 o->op_next = LINKLIST(first);
737 if (kid->op_sibling) {
738 kid->op_next = LINKLIST(kid->op_sibling);
739 kid = kid->op_sibling;
753 Perl_scalarkids(pTHX_ OP *o)
755 if (o && o->op_flags & OPf_KIDS) {
757 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
764 S_scalarboolean(pTHX_ OP *o)
767 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
768 if (ckWARN(WARN_SYNTAX)) {
769 const line_t oldline = CopLINE(PL_curcop);
771 if (PL_copline != NOLINE)
772 CopLINE_set(PL_curcop, PL_copline);
773 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
774 CopLINE_set(PL_curcop, oldline);
781 Perl_scalar(pTHX_ OP *o)
786 /* assumes no premature commitment */
787 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
788 || o->op_type == OP_RETURN)
793 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
795 switch (o->op_type) {
797 scalar(cBINOPo->op_first);
802 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
806 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
807 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
808 deprecate_old("implicit split to @_");
816 if (o->op_flags & OPf_KIDS) {
817 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
823 kid = cLISTOPo->op_first;
825 while ((kid = kid->op_sibling)) {
831 PL_curcop = &PL_compiling;
836 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
842 PL_curcop = &PL_compiling;
845 if (ckWARN(WARN_VOID))
846 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
852 Perl_scalarvoid(pTHX_ OP *o)
856 const char* useless = NULL;
860 /* trailing mad null ops don't count as "there" for void processing */
862 o->op_type != OP_NULL &&
864 o->op_sibling->op_type == OP_NULL)
867 for (sib = o->op_sibling;
868 sib && sib->op_type == OP_NULL;
869 sib = sib->op_sibling) ;
875 if (o->op_type == OP_NEXTSTATE
876 || o->op_type == OP_SETSTATE
877 || o->op_type == OP_DBSTATE
878 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
879 || o->op_targ == OP_SETSTATE
880 || o->op_targ == OP_DBSTATE)))
881 PL_curcop = (COP*)o; /* for warning below */
883 /* assumes no premature commitment */
884 want = o->op_flags & OPf_WANT;
885 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
886 || o->op_type == OP_RETURN)
891 if ((o->op_private & OPpTARGET_MY)
892 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
894 return scalar(o); /* As if inside SASSIGN */
897 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
899 switch (o->op_type) {
901 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
905 if (o->op_flags & OPf_STACKED)
909 if (o->op_private == 4)
981 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
982 useless = OP_DESC(o);
986 kid = cUNOPo->op_first;
987 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
988 kid->op_type != OP_TRANS) {
991 useless = "negative pattern binding (!~)";
998 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
999 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1000 useless = "a variable";
1005 if (cSVOPo->op_private & OPpCONST_STRICT)
1006 no_bareword_allowed(o);
1008 if (ckWARN(WARN_VOID)) {
1009 useless = "a constant";
1010 if (o->op_private & OPpCONST_ARYBASE)
1012 /* don't warn on optimised away booleans, eg
1013 * use constant Foo, 5; Foo || print; */
1014 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1016 /* the constants 0 and 1 are permitted as they are
1017 conventionally used as dummies in constructs like
1018 1 while some_condition_with_side_effects; */
1019 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1021 else if (SvPOK(sv)) {
1022 /* perl4's way of mixing documentation and code
1023 (before the invention of POD) was based on a
1024 trick to mix nroff and perl code. The trick was
1025 built upon these three nroff macros being used in
1026 void context. The pink camel has the details in
1027 the script wrapman near page 319. */
1028 const char * const maybe_macro = SvPVX_const(sv);
1029 if (strnEQ(maybe_macro, "di", 2) ||
1030 strnEQ(maybe_macro, "ds", 2) ||
1031 strnEQ(maybe_macro, "ig", 2))
1036 op_null(o); /* don't execute or even remember it */
1040 o->op_type = OP_PREINC; /* pre-increment is faster */
1041 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1045 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1046 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1050 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1051 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1055 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1056 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1065 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1070 if (o->op_flags & OPf_STACKED)
1077 if (!(o->op_flags & OPf_KIDS))
1088 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1095 /* all requires must return a boolean value */
1096 o->op_flags &= ~OPf_WANT;
1101 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1102 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1103 deprecate_old("implicit split to @_");
1107 if (useless && ckWARN(WARN_VOID))
1108 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1113 Perl_listkids(pTHX_ OP *o)
1115 if (o && o->op_flags & OPf_KIDS) {
1117 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1124 Perl_list(pTHX_ OP *o)
1129 /* assumes no premature commitment */
1130 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1131 || o->op_type == OP_RETURN)
1136 if ((o->op_private & OPpTARGET_MY)
1137 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1139 return o; /* As if inside SASSIGN */
1142 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1144 switch (o->op_type) {
1147 list(cBINOPo->op_first);
1152 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1160 if (!(o->op_flags & OPf_KIDS))
1162 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1163 list(cBINOPo->op_first);
1164 return gen_constant_list(o);
1171 kid = cLISTOPo->op_first;
1173 while ((kid = kid->op_sibling)) {
1174 if (kid->op_sibling)
1179 PL_curcop = &PL_compiling;
1183 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1184 if (kid->op_sibling)
1189 PL_curcop = &PL_compiling;
1192 /* all requires must return a boolean value */
1193 o->op_flags &= ~OPf_WANT;
1200 Perl_scalarseq(pTHX_ OP *o)
1204 const OPCODE type = o->op_type;
1206 if (type == OP_LINESEQ || type == OP_SCOPE ||
1207 type == OP_LEAVE || type == OP_LEAVETRY)
1210 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1211 if (kid->op_sibling) {
1215 PL_curcop = &PL_compiling;
1217 o->op_flags &= ~OPf_PARENS;
1218 if (PL_hints & HINT_BLOCK_SCOPE)
1219 o->op_flags |= OPf_PARENS;
1222 o = newOP(OP_STUB, 0);
1227 S_modkids(pTHX_ OP *o, I32 type)
1229 if (o && o->op_flags & OPf_KIDS) {
1231 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1237 /* Propagate lvalue ("modifiable") context to an op and its children.
1238 * 'type' represents the context type, roughly based on the type of op that
1239 * would do the modifying, although local() is represented by OP_NULL.
1240 * It's responsible for detecting things that can't be modified, flag
1241 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1242 * might have to vivify a reference in $x), and so on.
1244 * For example, "$a+1 = 2" would cause mod() to be called with o being
1245 * OP_ADD and type being OP_SASSIGN, and would output an error.
1249 Perl_mod(pTHX_ OP *o, I32 type)
1253 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1256 if (!o || PL_error_count)
1259 if ((o->op_private & OPpTARGET_MY)
1260 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1265 switch (o->op_type) {
1271 if (!(o->op_private & OPpCONST_ARYBASE))
1274 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1275 CopARYBASE_set(&PL_compiling,
1276 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1280 SAVECOPARYBASE(&PL_compiling);
1281 CopARYBASE_set(&PL_compiling, 0);
1283 else if (type == OP_REFGEN)
1286 Perl_croak(aTHX_ "That use of $[ is unsupported");
1289 if (o->op_flags & OPf_PARENS || PL_madskills)
1293 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1294 !(o->op_flags & OPf_STACKED)) {
1295 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1296 /* The default is to set op_private to the number of children,
1297 which for a UNOP such as RV2CV is always 1. And w're using
1298 the bit for a flag in RV2CV, so we need it clear. */
1299 o->op_private &= ~1;
1300 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1301 assert(cUNOPo->op_first->op_type == OP_NULL);
1302 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1305 else if (o->op_private & OPpENTERSUB_NOMOD)
1307 else { /* lvalue subroutine call */
1308 o->op_private |= OPpLVAL_INTRO;
1309 PL_modcount = RETURN_UNLIMITED_NUMBER;
1310 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1311 /* Backward compatibility mode: */
1312 o->op_private |= OPpENTERSUB_INARGS;
1315 else { /* Compile-time error message: */
1316 OP *kid = cUNOPo->op_first;
1320 if (kid->op_type != OP_PUSHMARK) {
1321 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1323 "panic: unexpected lvalue entersub "
1324 "args: type/targ %ld:%"UVuf,
1325 (long)kid->op_type, (UV)kid->op_targ);
1326 kid = kLISTOP->op_first;
1328 while (kid->op_sibling)
1329 kid = kid->op_sibling;
1330 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1332 if (kid->op_type == OP_METHOD_NAMED
1333 || kid->op_type == OP_METHOD)
1337 NewOp(1101, newop, 1, UNOP);
1338 newop->op_type = OP_RV2CV;
1339 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1340 newop->op_first = NULL;
1341 newop->op_next = (OP*)newop;
1342 kid->op_sibling = (OP*)newop;
1343 newop->op_private |= OPpLVAL_INTRO;
1344 newop->op_private &= ~1;
1348 if (kid->op_type != OP_RV2CV)
1350 "panic: unexpected lvalue entersub "
1351 "entry via type/targ %ld:%"UVuf,
1352 (long)kid->op_type, (UV)kid->op_targ);
1353 kid->op_private |= OPpLVAL_INTRO;
1354 break; /* Postpone until runtime */
1358 kid = kUNOP->op_first;
1359 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1360 kid = kUNOP->op_first;
1361 if (kid->op_type == OP_NULL)
1363 "Unexpected constant lvalue entersub "
1364 "entry via type/targ %ld:%"UVuf,
1365 (long)kid->op_type, (UV)kid->op_targ);
1366 if (kid->op_type != OP_GV) {
1367 /* Restore RV2CV to check lvalueness */
1369 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1370 okid->op_next = kid->op_next;
1371 kid->op_next = okid;
1374 okid->op_next = NULL;
1375 okid->op_type = OP_RV2CV;
1377 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1378 okid->op_private |= OPpLVAL_INTRO;
1379 okid->op_private &= ~1;
1383 cv = GvCV(kGVOP_gv);
1393 /* grep, foreach, subcalls, refgen */
1394 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1396 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1397 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1399 : (o->op_type == OP_ENTERSUB
1400 ? "non-lvalue subroutine call"
1402 type ? PL_op_desc[type] : "local"));
1416 case OP_RIGHT_SHIFT:
1425 if (!(o->op_flags & OPf_STACKED))
1432 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1438 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1439 PL_modcount = RETURN_UNLIMITED_NUMBER;
1440 return o; /* Treat \(@foo) like ordinary list. */
1444 if (scalar_mod_type(o, type))
1446 ref(cUNOPo->op_first, o->op_type);
1450 if (type == OP_LEAVESUBLV)
1451 o->op_private |= OPpMAYBE_LVSUB;
1457 PL_modcount = RETURN_UNLIMITED_NUMBER;
1460 ref(cUNOPo->op_first, o->op_type);
1465 PL_hints |= HINT_BLOCK_SCOPE;
1480 PL_modcount = RETURN_UNLIMITED_NUMBER;
1481 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1482 return o; /* Treat \(@foo) like ordinary list. */
1483 if (scalar_mod_type(o, type))
1485 if (type == OP_LEAVESUBLV)
1486 o->op_private |= OPpMAYBE_LVSUB;
1490 if (!type) /* local() */
1491 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1492 PAD_COMPNAME_PV(o->op_targ));
1500 if (type != OP_SASSIGN)
1504 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1509 if (type == OP_LEAVESUBLV)
1510 o->op_private |= OPpMAYBE_LVSUB;
1512 pad_free(o->op_targ);
1513 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1514 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1515 if (o->op_flags & OPf_KIDS)
1516 mod(cBINOPo->op_first->op_sibling, type);
1521 ref(cBINOPo->op_first, o->op_type);
1522 if (type == OP_ENTERSUB &&
1523 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1524 o->op_private |= OPpLVAL_DEFER;
1525 if (type == OP_LEAVESUBLV)
1526 o->op_private |= OPpMAYBE_LVSUB;
1536 if (o->op_flags & OPf_KIDS)
1537 mod(cLISTOPo->op_last, type);
1542 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1544 else if (!(o->op_flags & OPf_KIDS))
1546 if (o->op_targ != OP_LIST) {
1547 mod(cBINOPo->op_first, type);
1553 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1558 if (type != OP_LEAVESUBLV)
1560 break; /* mod()ing was handled by ck_return() */
1563 /* [20011101.069] File test operators interpret OPf_REF to mean that
1564 their argument is a filehandle; thus \stat(".") should not set
1566 if (type == OP_REFGEN &&
1567 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1570 if (type != OP_LEAVESUBLV)
1571 o->op_flags |= OPf_MOD;
1573 if (type == OP_AASSIGN || type == OP_SASSIGN)
1574 o->op_flags |= OPf_SPECIAL|OPf_REF;
1575 else if (!type) { /* local() */
1578 o->op_private |= OPpLVAL_INTRO;
1579 o->op_flags &= ~OPf_SPECIAL;
1580 PL_hints |= HINT_BLOCK_SCOPE;
1585 if (ckWARN(WARN_SYNTAX)) {
1586 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1587 "Useless localization of %s", OP_DESC(o));
1591 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1592 && type != OP_LEAVESUBLV)
1593 o->op_flags |= OPf_REF;
1598 S_scalar_mod_type(const OP *o, I32 type)
1602 if (o->op_type == OP_RV2GV)
1626 case OP_RIGHT_SHIFT:
1645 S_is_handle_constructor(const OP *o, I32 numargs)
1647 switch (o->op_type) {
1655 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1668 Perl_refkids(pTHX_ OP *o, I32 type)
1670 if (o && o->op_flags & OPf_KIDS) {
1672 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1679 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1684 if (!o || PL_error_count)
1687 switch (o->op_type) {
1689 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1690 !(o->op_flags & OPf_STACKED)) {
1691 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1692 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1693 assert(cUNOPo->op_first->op_type == OP_NULL);
1694 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1695 o->op_flags |= OPf_SPECIAL;
1696 o->op_private &= ~1;
1701 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1702 doref(kid, type, set_op_ref);
1705 if (type == OP_DEFINED)
1706 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1707 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1710 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1711 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1712 : type == OP_RV2HV ? OPpDEREF_HV
1714 o->op_flags |= OPf_MOD;
1721 o->op_flags |= OPf_REF;
1724 if (type == OP_DEFINED)
1725 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1726 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1732 o->op_flags |= OPf_REF;
1737 if (!(o->op_flags & OPf_KIDS))
1739 doref(cBINOPo->op_first, type, set_op_ref);
1743 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1744 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1745 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1746 : type == OP_RV2HV ? OPpDEREF_HV
1748 o->op_flags |= OPf_MOD;
1758 if (!(o->op_flags & OPf_KIDS))
1760 doref(cLISTOPo->op_last, type, set_op_ref);
1770 S_dup_attrlist(pTHX_ OP *o)
1775 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1776 * where the first kid is OP_PUSHMARK and the remaining ones
1777 * are OP_CONST. We need to push the OP_CONST values.
1779 if (o->op_type == OP_CONST)
1780 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1782 else if (o->op_type == OP_NULL)
1786 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1788 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1789 if (o->op_type == OP_CONST)
1790 rop = append_elem(OP_LIST, rop,
1791 newSVOP(OP_CONST, o->op_flags,
1792 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1799 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1804 /* fake up C<use attributes $pkg,$rv,@attrs> */
1805 ENTER; /* need to protect against side-effects of 'use' */
1807 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1809 #define ATTRSMODULE "attributes"
1810 #define ATTRSMODULE_PM "attributes.pm"
1813 /* Don't force the C<use> if we don't need it. */
1814 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1815 if (svp && *svp != &PL_sv_undef)
1816 NOOP; /* already in %INC */
1818 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1819 newSVpvs(ATTRSMODULE), NULL);
1822 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1823 newSVpvs(ATTRSMODULE),
1825 prepend_elem(OP_LIST,
1826 newSVOP(OP_CONST, 0, stashsv),
1827 prepend_elem(OP_LIST,
1828 newSVOP(OP_CONST, 0,
1830 dup_attrlist(attrs))));
1836 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1839 OP *pack, *imop, *arg;
1845 assert(target->op_type == OP_PADSV ||
1846 target->op_type == OP_PADHV ||
1847 target->op_type == OP_PADAV);
1849 /* Ensure that attributes.pm is loaded. */
1850 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1852 /* Need package name for method call. */
1853 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1855 /* Build up the real arg-list. */
1856 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1858 arg = newOP(OP_PADSV, 0);
1859 arg->op_targ = target->op_targ;
1860 arg = prepend_elem(OP_LIST,
1861 newSVOP(OP_CONST, 0, stashsv),
1862 prepend_elem(OP_LIST,
1863 newUNOP(OP_REFGEN, 0,
1864 mod(arg, OP_REFGEN)),
1865 dup_attrlist(attrs)));
1867 /* Fake up a method call to import */
1868 meth = newSVpvs_share("import");
1869 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1870 append_elem(OP_LIST,
1871 prepend_elem(OP_LIST, pack, list(arg)),
1872 newSVOP(OP_METHOD_NAMED, 0, meth)));
1873 imop->op_private |= OPpENTERSUB_NOMOD;
1875 /* Combine the ops. */
1876 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1880 =notfor apidoc apply_attrs_string
1882 Attempts to apply a list of attributes specified by the C<attrstr> and
1883 C<len> arguments to the subroutine identified by the C<cv> argument which
1884 is expected to be associated with the package identified by the C<stashpv>
1885 argument (see L<attributes>). It gets this wrong, though, in that it
1886 does not correctly identify the boundaries of the individual attribute
1887 specifications within C<attrstr>. This is not really intended for the
1888 public API, but has to be listed here for systems such as AIX which
1889 need an explicit export list for symbols. (It's called from XS code
1890 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1891 to respect attribute syntax properly would be welcome.
1897 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1898 const char *attrstr, STRLEN len)
1903 len = strlen(attrstr);
1907 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1909 const char * const sstr = attrstr;
1910 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1911 attrs = append_elem(OP_LIST, attrs,
1912 newSVOP(OP_CONST, 0,
1913 newSVpvn(sstr, attrstr-sstr)));
1917 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1918 newSVpvs(ATTRSMODULE),
1919 NULL, prepend_elem(OP_LIST,
1920 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1921 prepend_elem(OP_LIST,
1922 newSVOP(OP_CONST, 0,
1928 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1933 if (!o || PL_error_count)
1937 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1938 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1942 if (type == OP_LIST) {
1944 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1945 my_kid(kid, attrs, imopsp);
1946 } else if (type == OP_UNDEF
1952 } else if (type == OP_RV2SV || /* "our" declaration */
1954 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1955 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1956 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1958 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1960 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1962 PL_in_my_stash = NULL;
1963 apply_attrs(GvSTASH(gv),
1964 (type == OP_RV2SV ? GvSV(gv) :
1965 type == OP_RV2AV ? (SV*)GvAV(gv) :
1966 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1969 o->op_private |= OPpOUR_INTRO;
1972 else if (type != OP_PADSV &&
1975 type != OP_PUSHMARK)
1977 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1979 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1982 else if (attrs && type != OP_PUSHMARK) {
1986 PL_in_my_stash = NULL;
1988 /* check for C<my Dog $spot> when deciding package */
1989 stash = PAD_COMPNAME_TYPE(o->op_targ);
1991 stash = PL_curstash;
1992 apply_attrs_my(stash, o, attrs, imopsp);
1994 o->op_flags |= OPf_MOD;
1995 o->op_private |= OPpLVAL_INTRO;
1996 if (PL_in_my == KEY_state)
1997 o->op_private |= OPpPAD_STATE;
2002 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2006 int maybe_scalar = 0;
2008 /* [perl #17376]: this appears to be premature, and results in code such as
2009 C< our(%x); > executing in list mode rather than void mode */
2011 if (o->op_flags & OPf_PARENS)
2021 o = my_kid(o, attrs, &rops);
2023 if (maybe_scalar && o->op_type == OP_PADSV) {
2024 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2025 o->op_private |= OPpLVAL_INTRO;
2028 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2031 PL_in_my_stash = NULL;
2036 Perl_my(pTHX_ OP *o)
2038 return my_attrs(o, NULL);
2042 Perl_sawparens(pTHX_ OP *o)
2044 PERL_UNUSED_CONTEXT;
2046 o->op_flags |= OPf_PARENS;
2051 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2055 const OPCODE ltype = left->op_type;
2056 const OPCODE rtype = right->op_type;
2058 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2059 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2061 const char * const desc
2062 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2063 ? (int)rtype : OP_MATCH];
2064 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2065 ? "@array" : "%hash");
2066 Perl_warner(aTHX_ packWARN(WARN_MISC),
2067 "Applying %s to %s will act on scalar(%s)",
2068 desc, sample, sample);
2071 if (rtype == OP_CONST &&
2072 cSVOPx(right)->op_private & OPpCONST_BARE &&
2073 cSVOPx(right)->op_private & OPpCONST_STRICT)
2075 no_bareword_allowed(right);
2078 ismatchop = rtype == OP_MATCH ||
2079 rtype == OP_SUBST ||
2081 if (ismatchop && right->op_private & OPpTARGET_MY) {
2083 right->op_private &= ~OPpTARGET_MY;
2085 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2088 right->op_flags |= OPf_STACKED;
2089 if (rtype != OP_MATCH &&
2090 ! (rtype == OP_TRANS &&
2091 right->op_private & OPpTRANS_IDENTICAL))
2092 newleft = mod(left, rtype);
2095 if (right->op_type == OP_TRANS)
2096 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2098 o = prepend_elem(rtype, scalar(newleft), right);
2100 return newUNOP(OP_NOT, 0, scalar(o));
2104 return bind_match(type, left,
2105 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2109 Perl_invert(pTHX_ OP *o)
2113 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2117 Perl_scope(pTHX_ OP *o)
2121 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2122 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2123 o->op_type = OP_LEAVE;
2124 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2126 else if (o->op_type == OP_LINESEQ) {
2128 o->op_type = OP_SCOPE;
2129 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2130 kid = ((LISTOP*)o)->op_first;
2131 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2134 /* The following deals with things like 'do {1 for 1}' */
2135 kid = kid->op_sibling;
2137 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2142 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2148 Perl_block_start(pTHX_ int full)
2151 const int retval = PL_savestack_ix;
2152 pad_block_start(full);
2154 PL_hints &= ~HINT_BLOCK_SCOPE;
2155 SAVECOMPILEWARNINGS();
2156 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2161 Perl_block_end(pTHX_ I32 floor, OP *seq)
2164 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2165 OP* const retval = scalarseq(seq);
2167 CopHINTS_set(&PL_compiling, PL_hints);
2169 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2178 const PADOFFSET offset = pad_findmy("$_");
2179 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2180 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2183 OP * const o = newOP(OP_PADSV, 0);
2184 o->op_targ = offset;
2190 Perl_newPROG(pTHX_ OP *o)
2196 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2197 ((PL_in_eval & EVAL_KEEPERR)
2198 ? OPf_SPECIAL : 0), o);
2199 PL_eval_start = linklist(PL_eval_root);
2200 PL_eval_root->op_private |= OPpREFCOUNTED;
2201 OpREFCNT_set(PL_eval_root, 1);
2202 PL_eval_root->op_next = 0;
2203 CALL_PEEP(PL_eval_start);
2206 if (o->op_type == OP_STUB) {
2207 PL_comppad_name = 0;
2209 S_op_destroy(aTHX_ o);
2212 PL_main_root = scope(sawparens(scalarvoid(o)));
2213 PL_curcop = &PL_compiling;
2214 PL_main_start = LINKLIST(PL_main_root);
2215 PL_main_root->op_private |= OPpREFCOUNTED;
2216 OpREFCNT_set(PL_main_root, 1);
2217 PL_main_root->op_next = 0;
2218 CALL_PEEP(PL_main_start);
2221 /* Register with debugger */
2224 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2228 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2230 call_sv((SV*)cv, G_DISCARD);
2237 Perl_localize(pTHX_ OP *o, I32 lex)
2240 if (o->op_flags & OPf_PARENS)
2241 /* [perl #17376]: this appears to be premature, and results in code such as
2242 C< our(%x); > executing in list mode rather than void mode */
2249 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2250 && ckWARN(WARN_PARENTHESIS))
2252 char *s = PL_bufptr;
2255 /* some heuristics to detect a potential error */
2256 while (*s && (strchr(", \t\n", *s)))
2260 if (*s && strchr("@$%*", *s) && *++s
2261 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2264 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2266 while (*s && (strchr(", \t\n", *s)))
2272 if (sigil && (*s == ';' || *s == '=')) {
2273 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2274 "Parentheses missing around \"%s\" list",
2275 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2283 o = mod(o, OP_NULL); /* a bit kludgey */
2285 PL_in_my_stash = NULL;
2290 Perl_jmaybe(pTHX_ OP *o)
2292 if (o->op_type == OP_LIST) {
2294 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2295 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2301 Perl_fold_constants(pTHX_ register OP *o)
2306 VOL I32 type = o->op_type;
2311 SV * const oldwarnhook = PL_warnhook;
2312 SV * const olddiehook = PL_diehook;
2315 if (PL_opargs[type] & OA_RETSCALAR)
2317 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2318 o->op_targ = pad_alloc(type, SVs_PADTMP);
2320 /* integerize op, unless it happens to be C<-foo>.
2321 * XXX should pp_i_negate() do magic string negation instead? */
2322 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2323 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2324 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2326 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2329 if (!(PL_opargs[type] & OA_FOLDCONST))
2334 /* XXX might want a ck_negate() for this */
2335 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2346 /* XXX what about the numeric ops? */
2347 if (PL_hints & HINT_LOCALE)
2352 goto nope; /* Don't try to run w/ errors */
2354 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2355 const OPCODE type = curop->op_type;
2356 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2358 type != OP_SCALAR &&
2360 type != OP_PUSHMARK)
2366 curop = LINKLIST(o);
2367 old_next = o->op_next;
2371 oldscope = PL_scopestack_ix;
2372 create_eval_scope(G_FAKINGEVAL);
2374 PL_warnhook = PERL_WARNHOOK_FATAL;
2381 sv = *(PL_stack_sp--);
2382 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2383 pad_swipe(o->op_targ, FALSE);
2384 else if (SvTEMP(sv)) { /* grab mortal temp? */
2385 SvREFCNT_inc_simple_void(sv);
2390 /* Something tried to die. Abandon constant folding. */
2391 /* Pretend the error never happened. */
2392 sv_setpvn(ERRSV,"",0);
2393 o->op_next = old_next;
2397 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2398 PL_warnhook = oldwarnhook;
2399 PL_diehook = olddiehook;
2400 /* XXX note that this croak may fail as we've already blown away
2401 * the stack - eg any nested evals */
2402 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2405 PL_warnhook = oldwarnhook;
2406 PL_diehook = olddiehook;
2408 if (PL_scopestack_ix > oldscope)
2409 delete_eval_scope();
2418 if (type == OP_RV2GV)
2419 newop = newGVOP(OP_GV, 0, (GV*)sv);
2421 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2422 op_getmad(o,newop,'f');
2430 Perl_gen_constant_list(pTHX_ register OP *o)
2434 const I32 oldtmps_floor = PL_tmps_floor;
2438 return o; /* Don't attempt to run with errors */
2440 PL_op = curop = LINKLIST(o);
2446 assert (!(curop->op_flags & OPf_SPECIAL));
2447 assert(curop->op_type == OP_RANGE);
2449 PL_tmps_floor = oldtmps_floor;
2451 o->op_type = OP_RV2AV;
2452 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2453 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2454 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2455 o->op_opt = 0; /* needs to be revisited in peep() */
2456 curop = ((UNOP*)o)->op_first;
2457 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2459 op_getmad(curop,o,'O');
2468 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2471 if (!o || o->op_type != OP_LIST)
2472 o = newLISTOP(OP_LIST, 0, o, NULL);
2474 o->op_flags &= ~OPf_WANT;
2476 if (!(PL_opargs[type] & OA_MARK))
2477 op_null(cLISTOPo->op_first);
2479 o->op_type = (OPCODE)type;
2480 o->op_ppaddr = PL_ppaddr[type];
2481 o->op_flags |= flags;
2483 o = CHECKOP(type, o);
2484 if (o->op_type != (unsigned)type)
2487 return fold_constants(o);
2490 /* List constructors */
2493 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2501 if (first->op_type != (unsigned)type
2502 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2504 return newLISTOP(type, 0, first, last);
2507 if (first->op_flags & OPf_KIDS)
2508 ((LISTOP*)first)->op_last->op_sibling = last;
2510 first->op_flags |= OPf_KIDS;
2511 ((LISTOP*)first)->op_first = last;
2513 ((LISTOP*)first)->op_last = last;
2518 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2526 if (first->op_type != (unsigned)type)
2527 return prepend_elem(type, (OP*)first, (OP*)last);
2529 if (last->op_type != (unsigned)type)
2530 return append_elem(type, (OP*)first, (OP*)last);
2532 first->op_last->op_sibling = last->op_first;
2533 first->op_last = last->op_last;
2534 first->op_flags |= (last->op_flags & OPf_KIDS);
2537 if (last->op_first && first->op_madprop) {
2538 MADPROP *mp = last->op_first->op_madprop;
2540 while (mp->mad_next)
2542 mp->mad_next = first->op_madprop;
2545 last->op_first->op_madprop = first->op_madprop;
2548 first->op_madprop = last->op_madprop;
2549 last->op_madprop = 0;
2552 S_op_destroy(aTHX_ (OP*)last);
2558 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2566 if (last->op_type == (unsigned)type) {
2567 if (type == OP_LIST) { /* already a PUSHMARK there */
2568 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2569 ((LISTOP*)last)->op_first->op_sibling = first;
2570 if (!(first->op_flags & OPf_PARENS))
2571 last->op_flags &= ~OPf_PARENS;
2574 if (!(last->op_flags & OPf_KIDS)) {
2575 ((LISTOP*)last)->op_last = first;
2576 last->op_flags |= OPf_KIDS;
2578 first->op_sibling = ((LISTOP*)last)->op_first;
2579 ((LISTOP*)last)->op_first = first;
2581 last->op_flags |= OPf_KIDS;
2585 return newLISTOP(type, 0, first, last);
2593 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2596 Newxz(tk, 1, TOKEN);
2597 tk->tk_type = (OPCODE)optype;
2598 tk->tk_type = 12345;
2600 tk->tk_mad = madprop;
2605 Perl_token_free(pTHX_ TOKEN* tk)
2607 if (tk->tk_type != 12345)
2609 mad_free(tk->tk_mad);
2614 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2618 if (tk->tk_type != 12345) {
2619 Perl_warner(aTHX_ packWARN(WARN_MISC),
2620 "Invalid TOKEN object ignored");
2627 /* faked up qw list? */
2629 tm->mad_type == MAD_SV &&
2630 SvPVX((SV*)tm->mad_val)[0] == 'q')
2637 /* pretend constant fold didn't happen? */
2638 if (mp->mad_key == 'f' &&
2639 (o->op_type == OP_CONST ||
2640 o->op_type == OP_GV) )
2642 token_getmad(tk,(OP*)mp->mad_val,slot);
2656 if (mp->mad_key == 'X')
2657 mp->mad_key = slot; /* just change the first one */
2667 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2676 /* pretend constant fold didn't happen? */
2677 if (mp->mad_key == 'f' &&
2678 (o->op_type == OP_CONST ||
2679 o->op_type == OP_GV) )
2681 op_getmad(from,(OP*)mp->mad_val,slot);
2688 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2691 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2697 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2706 /* pretend constant fold didn't happen? */
2707 if (mp->mad_key == 'f' &&
2708 (o->op_type == OP_CONST ||
2709 o->op_type == OP_GV) )
2711 op_getmad(from,(OP*)mp->mad_val,slot);
2718 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2721 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2725 PerlIO_printf(PerlIO_stderr(),
2726 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2732 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2750 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2754 addmad(tm, &(o->op_madprop), slot);
2758 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2779 Perl_newMADsv(pTHX_ char key, SV* sv)
2781 return newMADPROP(key, MAD_SV, sv, 0);
2785 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2788 Newxz(mp, 1, MADPROP);
2791 mp->mad_vlen = vlen;
2792 mp->mad_type = type;
2794 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2799 Perl_mad_free(pTHX_ MADPROP* mp)
2801 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2805 mad_free(mp->mad_next);
2806 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2807 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2808 switch (mp->mad_type) {
2812 Safefree((char*)mp->mad_val);
2815 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2816 op_free((OP*)mp->mad_val);
2819 sv_free((SV*)mp->mad_val);
2822 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2831 Perl_newNULLLIST(pTHX)
2833 return newOP(OP_STUB, 0);
2837 Perl_force_list(pTHX_ OP *o)
2839 if (!o || o->op_type != OP_LIST)
2840 o = newLISTOP(OP_LIST, 0, o, NULL);
2846 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2851 NewOp(1101, listop, 1, LISTOP);
2853 listop->op_type = (OPCODE)type;
2854 listop->op_ppaddr = PL_ppaddr[type];
2857 listop->op_flags = (U8)flags;
2861 else if (!first && last)
2864 first->op_sibling = last;
2865 listop->op_first = first;
2866 listop->op_last = last;
2867 if (type == OP_LIST) {
2868 OP* const pushop = newOP(OP_PUSHMARK, 0);
2869 pushop->op_sibling = first;
2870 listop->op_first = pushop;
2871 listop->op_flags |= OPf_KIDS;
2873 listop->op_last = pushop;
2876 return CHECKOP(type, listop);
2880 Perl_newOP(pTHX_ I32 type, I32 flags)
2884 NewOp(1101, o, 1, OP);
2885 o->op_type = (OPCODE)type;
2886 o->op_ppaddr = PL_ppaddr[type];
2887 o->op_flags = (U8)flags;
2889 o->op_latefreed = 0;
2893 o->op_private = (U8)(0 | (flags >> 8));
2894 if (PL_opargs[type] & OA_RETSCALAR)
2896 if (PL_opargs[type] & OA_TARGET)
2897 o->op_targ = pad_alloc(type, SVs_PADTMP);
2898 return CHECKOP(type, o);
2902 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2908 first = newOP(OP_STUB, 0);
2909 if (PL_opargs[type] & OA_MARK)
2910 first = force_list(first);
2912 NewOp(1101, unop, 1, UNOP);
2913 unop->op_type = (OPCODE)type;
2914 unop->op_ppaddr = PL_ppaddr[type];
2915 unop->op_first = first;
2916 unop->op_flags = (U8)(flags | OPf_KIDS);
2917 unop->op_private = (U8)(1 | (flags >> 8));
2918 unop = (UNOP*) CHECKOP(type, unop);
2922 return fold_constants((OP *) unop);
2926 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2930 NewOp(1101, binop, 1, BINOP);
2933 first = newOP(OP_NULL, 0);
2935 binop->op_type = (OPCODE)type;
2936 binop->op_ppaddr = PL_ppaddr[type];
2937 binop->op_first = first;
2938 binop->op_flags = (U8)(flags | OPf_KIDS);
2941 binop->op_private = (U8)(1 | (flags >> 8));
2944 binop->op_private = (U8)(2 | (flags >> 8));
2945 first->op_sibling = last;
2948 binop = (BINOP*)CHECKOP(type, binop);
2949 if (binop->op_next || binop->op_type != (OPCODE)type)
2952 binop->op_last = binop->op_first->op_sibling;
2954 return fold_constants((OP *)binop);
2957 static int uvcompare(const void *a, const void *b)
2958 __attribute__nonnull__(1)
2959 __attribute__nonnull__(2)
2960 __attribute__pure__;
2961 static int uvcompare(const void *a, const void *b)
2963 if (*((const UV *)a) < (*(const UV *)b))
2965 if (*((const UV *)a) > (*(const UV *)b))
2967 if (*((const UV *)a+1) < (*(const UV *)b+1))
2969 if (*((const UV *)a+1) > (*(const UV *)b+1))
2975 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2978 SV * const tstr = ((SVOP*)expr)->op_sv;
2981 (repl->op_type == OP_NULL)
2982 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2984 ((SVOP*)repl)->op_sv;
2987 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2988 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2992 register short *tbl;
2994 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2995 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2996 I32 del = o->op_private & OPpTRANS_DELETE;
2998 PL_hints |= HINT_BLOCK_SCOPE;
3001 o->op_private |= OPpTRANS_FROM_UTF;
3004 o->op_private |= OPpTRANS_TO_UTF;
3006 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3007 SV* const listsv = newSVpvs("# comment\n");
3009 const U8* tend = t + tlen;
3010 const U8* rend = r + rlen;
3024 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3025 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3028 const U32 flags = UTF8_ALLOW_DEFAULT;
3032 t = tsave = bytes_to_utf8(t, &len);
3035 if (!to_utf && rlen) {
3037 r = rsave = bytes_to_utf8(r, &len);
3041 /* There are several snags with this code on EBCDIC:
3042 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3043 2. scan_const() in toke.c has encoded chars in native encoding which makes
3044 ranges at least in EBCDIC 0..255 range the bottom odd.
3048 U8 tmpbuf[UTF8_MAXBYTES+1];
3051 Newx(cp, 2*tlen, UV);
3053 transv = newSVpvs("");
3055 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3057 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3059 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3063 cp[2*i+1] = cp[2*i];
3067 qsort(cp, i, 2*sizeof(UV), uvcompare);
3068 for (j = 0; j < i; j++) {
3070 diff = val - nextmin;
3072 t = uvuni_to_utf8(tmpbuf,nextmin);
3073 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3075 U8 range_mark = UTF_TO_NATIVE(0xff);
3076 t = uvuni_to_utf8(tmpbuf, val - 1);
3077 sv_catpvn(transv, (char *)&range_mark, 1);
3078 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3085 t = uvuni_to_utf8(tmpbuf,nextmin);
3086 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3088 U8 range_mark = UTF_TO_NATIVE(0xff);
3089 sv_catpvn(transv, (char *)&range_mark, 1);
3091 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3092 UNICODE_ALLOW_SUPER);
3093 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3094 t = (const U8*)SvPVX_const(transv);
3095 tlen = SvCUR(transv);
3099 else if (!rlen && !del) {
3100 r = t; rlen = tlen; rend = tend;
3103 if ((!rlen && !del) || t == r ||
3104 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3106 o->op_private |= OPpTRANS_IDENTICAL;
3110 while (t < tend || tfirst <= tlast) {
3111 /* see if we need more "t" chars */
3112 if (tfirst > tlast) {
3113 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3115 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3117 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3124 /* now see if we need more "r" chars */
3125 if (rfirst > rlast) {
3127 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3129 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3131 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3140 rfirst = rlast = 0xffffffff;
3144 /* now see which range will peter our first, if either. */
3145 tdiff = tlast - tfirst;
3146 rdiff = rlast - rfirst;
3153 if (rfirst == 0xffffffff) {
3154 diff = tdiff; /* oops, pretend rdiff is infinite */
3156 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3157 (long)tfirst, (long)tlast);
3159 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3163 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3164 (long)tfirst, (long)(tfirst + diff),
3167 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3168 (long)tfirst, (long)rfirst);
3170 if (rfirst + diff > max)
3171 max = rfirst + diff;
3173 grows = (tfirst < rfirst &&
3174 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3186 else if (max > 0xff)
3191 PerlMemShared_free(cPVOPo->op_pv);
3192 cPVOPo->op_pv = NULL;
3194 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3196 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3197 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3198 PAD_SETSV(cPADOPo->op_padix, swash);
3201 cSVOPo->op_sv = swash;
3203 SvREFCNT_dec(listsv);
3204 SvREFCNT_dec(transv);
3206 if (!del && havefinal && rlen)
3207 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3208 newSVuv((UV)final), 0);
3211 o->op_private |= OPpTRANS_GROWS;
3217 op_getmad(expr,o,'e');
3218 op_getmad(repl,o,'r');
3226 tbl = (short*)cPVOPo->op_pv;
3228 Zero(tbl, 256, short);
3229 for (i = 0; i < (I32)tlen; i++)
3231 for (i = 0, j = 0; i < 256; i++) {
3233 if (j >= (I32)rlen) {
3242 if (i < 128 && r[j] >= 128)
3252 o->op_private |= OPpTRANS_IDENTICAL;
3254 else if (j >= (I32)rlen)
3259 PerlMemShared_realloc(tbl,
3260 (0x101+rlen-j) * sizeof(short));
3261 cPVOPo->op_pv = (char*)tbl;
3263 tbl[0x100] = (short)(rlen - j);
3264 for (i=0; i < (I32)rlen - j; i++)
3265 tbl[0x101+i] = r[j+i];
3269 if (!rlen && !del) {
3272 o->op_private |= OPpTRANS_IDENTICAL;
3274 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3275 o->op_private |= OPpTRANS_IDENTICAL;
3277 for (i = 0; i < 256; i++)
3279 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3280 if (j >= (I32)rlen) {
3282 if (tbl[t[i]] == -1)
3288 if (tbl[t[i]] == -1) {
3289 if (t[i] < 128 && r[j] >= 128)
3296 o->op_private |= OPpTRANS_GROWS;
3298 op_getmad(expr,o,'e');
3299 op_getmad(repl,o,'r');
3309 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3314 NewOp(1101, pmop, 1, PMOP);
3315 pmop->op_type = (OPCODE)type;
3316 pmop->op_ppaddr = PL_ppaddr[type];
3317 pmop->op_flags = (U8)flags;
3318 pmop->op_private = (U8)(0 | (flags >> 8));
3320 if (PL_hints & HINT_RE_TAINT)
3321 pmop->op_pmflags |= PMf_RETAINT;
3322 if (PL_hints & HINT_LOCALE)
3323 pmop->op_pmflags |= PMf_LOCALE;
3327 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3328 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3329 pmop->op_pmoffset = SvIV(repointer);
3330 SvREPADTMP_off(repointer);
3331 sv_setiv(repointer,0);
3333 SV * const repointer = newSViv(0);
3334 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3335 pmop->op_pmoffset = av_len(PL_regex_padav);
3336 PL_regex_pad = AvARRAY(PL_regex_padav);
3340 return CHECKOP(type, pmop);
3343 /* Given some sort of match op o, and an expression expr containing a
3344 * pattern, either compile expr into a regex and attach it to o (if it's
3345 * constant), or convert expr into a runtime regcomp op sequence (if it's
3348 * isreg indicates that the pattern is part of a regex construct, eg
3349 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3350 * split "pattern", which aren't. In the former case, expr will be a list
3351 * if the pattern contains more than one term (eg /a$b/) or if it contains
3352 * a replacement, ie s/// or tr///.
3356 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3361 I32 repl_has_vars = 0;
3365 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3366 /* last element in list is the replacement; pop it */
3368 repl = cLISTOPx(expr)->op_last;
3369 kid = cLISTOPx(expr)->op_first;
3370 while (kid->op_sibling != repl)
3371 kid = kid->op_sibling;
3372 kid->op_sibling = NULL;
3373 cLISTOPx(expr)->op_last = kid;
3376 if (isreg && expr->op_type == OP_LIST &&
3377 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3379 /* convert single element list to element */
3380 OP* const oe = expr;
3381 expr = cLISTOPx(oe)->op_first->op_sibling;
3382 cLISTOPx(oe)->op_first->op_sibling = NULL;
3383 cLISTOPx(oe)->op_last = NULL;
3387 if (o->op_type == OP_TRANS) {
3388 return pmtrans(o, expr, repl);
3391 reglist = isreg && expr->op_type == OP_LIST;
3395 PL_hints |= HINT_BLOCK_SCOPE;
3398 if (expr->op_type == OP_CONST) {
3400 SV * const pat = ((SVOP*)expr)->op_sv;
3401 const char *p = SvPV_const(pat, plen);
3402 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3403 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
3404 U32 was_readonly = SvREADONLY(pat);
3408 sv_force_normal_flags(pat, 0);
3409 assert(!SvREADONLY(pat));
3412 SvREADONLY_off(pat);
3416 sv_setpvn(pat, "\\s+", 3);
3418 SvFLAGS(pat) |= was_readonly;
3420 p = SvPV_const(pat, plen);
3421 pm_flags |= RXf_SKIPWHITE;
3424 pm_flags |= RXf_UTF8;
3425 /* FIXME - can we make this function take const char * args? */
3426 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm_flags));
3429 op_getmad(expr,(OP*)pm,'e');
3435 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3436 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3438 : OP_REGCMAYBE),0,expr);
3440 NewOp(1101, rcop, 1, LOGOP);
3441 rcop->op_type = OP_REGCOMP;
3442 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3443 rcop->op_first = scalar(expr);
3444 rcop->op_flags |= OPf_KIDS
3445 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3446 | (reglist ? OPf_STACKED : 0);
3447 rcop->op_private = 1;
3450 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3452 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3455 /* establish postfix order */
3456 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3458 rcop->op_next = expr;
3459 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3462 rcop->op_next = LINKLIST(expr);
3463 expr->op_next = (OP*)rcop;
3466 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3471 if (pm->op_pmflags & PMf_EVAL) {
3473 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3474 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3476 else if (repl->op_type == OP_CONST)
3480 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3481 if (curop->op_type == OP_SCOPE
3482 || curop->op_type == OP_LEAVE
3483 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3484 if (curop->op_type == OP_GV) {
3485 GV * const gv = cGVOPx_gv(curop);
3487 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3490 else if (curop->op_type == OP_RV2CV)
3492 else if (curop->op_type == OP_RV2SV ||
3493 curop->op_type == OP_RV2AV ||
3494 curop->op_type == OP_RV2HV ||
3495 curop->op_type == OP_RV2GV) {
3496 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3499 else if (curop->op_type == OP_PADSV ||
3500 curop->op_type == OP_PADAV ||
3501 curop->op_type == OP_PADHV ||
3502 curop->op_type == OP_PADANY)
3506 else if (curop->op_type == OP_PUSHRE)
3507 NOOP; /* Okay here, dangerous in newASSIGNOP */
3517 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3519 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3520 prepend_elem(o->op_type, scalar(repl), o);
3523 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3524 pm->op_pmflags |= PMf_MAYBE_CONST;
3526 NewOp(1101, rcop, 1, LOGOP);
3527 rcop->op_type = OP_SUBSTCONT;
3528 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3529 rcop->op_first = scalar(repl);
3530 rcop->op_flags |= OPf_KIDS;
3531 rcop->op_private = 1;
3534 /* establish postfix order */
3535 rcop->op_next = LINKLIST(repl);
3536 repl->op_next = (OP*)rcop;
3538 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3539 assert(!(pm->op_pmflags & PMf_ONCE));
3540 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3549 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3553 NewOp(1101, svop, 1, SVOP);
3554 svop->op_type = (OPCODE)type;
3555 svop->op_ppaddr = PL_ppaddr[type];
3557 svop->op_next = (OP*)svop;
3558 svop->op_flags = (U8)flags;
3559 if (PL_opargs[type] & OA_RETSCALAR)
3561 if (PL_opargs[type] & OA_TARGET)
3562 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3563 return CHECKOP(type, svop);
3568 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3572 NewOp(1101, padop, 1, PADOP);
3573 padop->op_type = (OPCODE)type;
3574 padop->op_ppaddr = PL_ppaddr[type];
3575 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3576 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3577 PAD_SETSV(padop->op_padix, sv);
3580 padop->op_next = (OP*)padop;
3581 padop->op_flags = (U8)flags;
3582 if (PL_opargs[type] & OA_RETSCALAR)
3584 if (PL_opargs[type] & OA_TARGET)
3585 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3586 return CHECKOP(type, padop);
3591 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3597 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3599 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3604 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3608 NewOp(1101, pvop, 1, PVOP);
3609 pvop->op_type = (OPCODE)type;
3610 pvop->op_ppaddr = PL_ppaddr[type];
3612 pvop->op_next = (OP*)pvop;
3613 pvop->op_flags = (U8)flags;
3614 if (PL_opargs[type] & OA_RETSCALAR)
3616 if (PL_opargs[type] & OA_TARGET)
3617 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3618 return CHECKOP(type, pvop);
3626 Perl_package(pTHX_ OP *o)
3629 SV *const sv = cSVOPo->op_sv;
3634 save_hptr(&PL_curstash);
3635 save_item(PL_curstname);
3637 PL_curstash = gv_stashsv(sv, GV_ADD);
3638 sv_setsv(PL_curstname, sv);
3640 PL_hints |= HINT_BLOCK_SCOPE;
3641 PL_copline = NOLINE;
3647 if (!PL_madskills) {
3652 pegop = newOP(OP_NULL,0);
3653 op_getmad(o,pegop,'P');
3663 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3670 OP *pegop = newOP(OP_NULL,0);
3673 if (idop->op_type != OP_CONST)
3674 Perl_croak(aTHX_ "Module name must be constant");
3677 op_getmad(idop,pegop,'U');
3682 SV * const vesv = ((SVOP*)version)->op_sv;
3685 op_getmad(version,pegop,'V');
3686 if (!arg && !SvNIOKp(vesv)) {
3693 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3694 Perl_croak(aTHX_ "Version number must be constant number");
3696 /* Make copy of idop so we don't free it twice */
3697 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3699 /* Fake up a method call to VERSION */
3700 meth = newSVpvs_share("VERSION");
3701 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3702 append_elem(OP_LIST,
3703 prepend_elem(OP_LIST, pack, list(version)),
3704 newSVOP(OP_METHOD_NAMED, 0, meth)));
3708 /* Fake up an import/unimport */
3709 if (arg && arg->op_type == OP_STUB) {
3711 op_getmad(arg,pegop,'S');
3712 imop = arg; /* no import on explicit () */
3714 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3715 imop = NULL; /* use 5.0; */
3717 idop->op_private |= OPpCONST_NOVER;
3723 op_getmad(arg,pegop,'A');
3725 /* Make copy of idop so we don't free it twice */
3726 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3728 /* Fake up a method call to import/unimport */
3730 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3731 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3732 append_elem(OP_LIST,
3733 prepend_elem(OP_LIST, pack, list(arg)),
3734 newSVOP(OP_METHOD_NAMED, 0, meth)));
3737 /* Fake up the BEGIN {}, which does its thing immediately. */
3739 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3742 append_elem(OP_LINESEQ,
3743 append_elem(OP_LINESEQ,
3744 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3745 newSTATEOP(0, NULL, veop)),
3746 newSTATEOP(0, NULL, imop) ));
3748 /* The "did you use incorrect case?" warning used to be here.
3749 * The problem is that on case-insensitive filesystems one
3750 * might get false positives for "use" (and "require"):
3751 * "use Strict" or "require CARP" will work. This causes
3752 * portability problems for the script: in case-strict
3753 * filesystems the script will stop working.
3755 * The "incorrect case" warning checked whether "use Foo"
3756 * imported "Foo" to your namespace, but that is wrong, too:
3757 * there is no requirement nor promise in the language that
3758 * a Foo.pm should or would contain anything in package "Foo".
3760 * There is very little Configure-wise that can be done, either:
3761 * the case-sensitivity of the build filesystem of Perl does not
3762 * help in guessing the case-sensitivity of the runtime environment.
3765 PL_hints |= HINT_BLOCK_SCOPE;
3766 PL_copline = NOLINE;
3768 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3771 if (!PL_madskills) {
3772 /* FIXME - don't allocate pegop if !PL_madskills */
3781 =head1 Embedding Functions
3783 =for apidoc load_module
3785 Loads the module whose name is pointed to by the string part of name.
3786 Note that the actual module name, not its filename, should be given.
3787 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3788 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3789 (or 0 for no flags). ver, if specified, provides version semantics
3790 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3791 arguments can be used to specify arguments to the module's import()
3792 method, similar to C<use Foo::Bar VERSION LIST>.
3797 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3800 va_start(args, ver);
3801 vload_module(flags, name, ver, &args);
3805 #ifdef PERL_IMPLICIT_CONTEXT
3807 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3811 va_start(args, ver);
3812 vload_module(flags, name, ver, &args);
3818 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3823 OP * const modname = newSVOP(OP_CONST, 0, name);
3824 modname->op_private |= OPpCONST_BARE;
3826 veop = newSVOP(OP_CONST, 0, ver);
3830 if (flags & PERL_LOADMOD_NOIMPORT) {
3831 imop = sawparens(newNULLLIST());
3833 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3834 imop = va_arg(*args, OP*);
3839 sv = va_arg(*args, SV*);
3841 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3842 sv = va_arg(*args, SV*);
3846 const line_t ocopline = PL_copline;
3847 COP * const ocurcop = PL_curcop;
3848 const int oexpect = PL_expect;
3850 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3851 veop, modname, imop);
3852 PL_expect = oexpect;
3853 PL_copline = ocopline;
3854 PL_curcop = ocurcop;
3859 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3865 if (!force_builtin) {
3866 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3867 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3868 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3869 gv = gvp ? *gvp : NULL;
3873 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3874 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3875 append_elem(OP_LIST, term,
3876 scalar(newUNOP(OP_RV2CV, 0,
3877 newGVOP(OP_GV, 0, gv))))));
3880 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3886 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3888 return newBINOP(OP_LSLICE, flags,
3889 list(force_list(subscript)),
3890 list(force_list(listval)) );
3894 S_is_list_assignment(pTHX_ register const OP *o)
3902 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3903 o = cUNOPo->op_first;
3905 flags = o->op_flags;
3907 if (type == OP_COND_EXPR) {
3908 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3909 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3914 yyerror("Assignment to both a list and a scalar");
3918 if (type == OP_LIST &&
3919 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3920 o->op_private & OPpLVAL_INTRO)
3923 if (type == OP_LIST || flags & OPf_PARENS ||
3924 type == OP_RV2AV || type == OP_RV2HV ||
3925 type == OP_ASLICE || type == OP_HSLICE)
3928 if (type == OP_PADAV || type == OP_PADHV)
3931 if (type == OP_RV2SV)
3938 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3944 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3945 return newLOGOP(optype, 0,
3946 mod(scalar(left), optype),
3947 newUNOP(OP_SASSIGN, 0, scalar(right)));
3950 return newBINOP(optype, OPf_STACKED,
3951 mod(scalar(left), optype), scalar(right));
3955 if (is_list_assignment(left)) {
3959 /* Grandfathering $[ assignment here. Bletch.*/
3960 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3961 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3962 left = mod(left, OP_AASSIGN);
3965 else if (left->op_type == OP_CONST) {
3967 /* Result of assignment is always 1 (or we'd be dead already) */
3968 return newSVOP(OP_CONST, 0, newSViv(1));
3970 curop = list(force_list(left));
3971 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3972 o->op_private = (U8)(0 | (flags >> 8));
3974 /* PL_generation sorcery:
3975 * an assignment like ($a,$b) = ($c,$d) is easier than
3976 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3977 * To detect whether there are common vars, the global var
3978 * PL_generation is incremented for each assign op we compile.
3979 * Then, while compiling the assign op, we run through all the
3980 * variables on both sides of the assignment, setting a spare slot
3981 * in each of them to PL_generation. If any of them already have
3982 * that value, we know we've got commonality. We could use a
3983 * single bit marker, but then we'd have to make 2 passes, first
3984 * to clear the flag, then to test and set it. To find somewhere
3985 * to store these values, evil chicanery is done with SvUVX().
3991 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3992 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3993 if (curop->op_type == OP_GV) {
3994 GV *gv = cGVOPx_gv(curop);
3996 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3998 GvASSIGN_GENERATION_set(gv, PL_generation);
4000 else if (curop->op_type == OP_PADSV ||
4001 curop->op_type == OP_PADAV ||
4002 curop->op_type == OP_PADHV ||
4003 curop->op_type == OP_PADANY)
4005 if (PAD_COMPNAME_GEN(curop->op_targ)
4006 == (STRLEN)PL_generation)
4008 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4011 else if (curop->op_type == OP_RV2CV)
4013 else if (curop->op_type == OP_RV2SV ||
4014 curop->op_type == OP_RV2AV ||
4015 curop->op_type == OP_RV2HV ||
4016 curop->op_type == OP_RV2GV) {
4017 if (lastop->op_type != OP_GV) /* funny deref? */
4020 else if (curop->op_type == OP_PUSHRE) {
4022 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4023 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4025 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4027 GvASSIGN_GENERATION_set(gv, PL_generation);
4031 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4034 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4036 GvASSIGN_GENERATION_set(gv, PL_generation);
4046 o->op_private |= OPpASSIGN_COMMON;
4049 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
4050 && (left->op_type == OP_LIST
4051 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4053 OP* lop = ((LISTOP*)left)->op_first;
4055 if (lop->op_type == OP_PADSV ||
4056 lop->op_type == OP_PADAV ||
4057 lop->op_type == OP_PADHV ||
4058 lop->op_type == OP_PADANY)
4060 if (lop->op_private & OPpPAD_STATE) {
4061 if (left->op_private & OPpLVAL_INTRO) {
4062 o->op_private |= OPpASSIGN_STATE;
4063 /* hijacking PADSTALE for uninitialized state variables */
4064 SvPADSTALE_on(PAD_SVl(lop->op_targ));
4066 else { /* we already checked for WARN_MISC before */
4067 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
4068 PAD_COMPNAME_PV(lop->op_targ));
4072 lop = lop->op_sibling;
4075 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4076 == (OPpLVAL_INTRO | OPpPAD_STATE))
4077 && ( left->op_type == OP_PADSV
4078 || left->op_type == OP_PADAV
4079 || left->op_type == OP_PADHV
4080 || left->op_type == OP_PADANY))
4082 o->op_private |= OPpASSIGN_STATE;
4083 /* hijacking PADSTALE for uninitialized state variables */
4084 SvPADSTALE_on(PAD_SVl(left->op_targ));
4087 if (right && right->op_type == OP_SPLIT) {
4088 OP* tmpop = ((LISTOP*)right)->op_first;
4089 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4090 PMOP * const pm = (PMOP*)tmpop;
4091 if (left->op_type == OP_RV2AV &&
4092 !(left->op_private & OPpLVAL_INTRO) &&
4093 !(o->op_private & OPpASSIGN_COMMON) )
4095 tmpop = ((UNOP*)left)->op_first;
4096 if (tmpop->op_type == OP_GV
4098 && !pm->op_pmreplrootu.op_pmtargetoff
4100 && !pm->op_pmreplrootu.op_pmtargetgv
4104 pm->op_pmreplrootu.op_pmtargetoff
4105 = cPADOPx(tmpop)->op_padix;
4106 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4108 pm->op_pmreplrootu.op_pmtargetgv
4109 = (GV*)cSVOPx(tmpop)->op_sv;
4110 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4112 pm->op_pmflags |= PMf_ONCE;
4113 tmpop = cUNOPo->op_first; /* to list (nulled) */
4114 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4115 tmpop->op_sibling = NULL; /* don't free split */
4116 right->op_next = tmpop->op_next; /* fix starting loc */
4118 op_getmad(o,right,'R'); /* blow off assign */
4120 op_free(o); /* blow off assign */
4122 right->op_flags &= ~OPf_WANT;
4123 /* "I don't know and I don't care." */
4128 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4129 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4131 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4133 sv_setiv(sv, PL_modcount+1);
4141 right = newOP(OP_UNDEF, 0);
4142 if (right->op_type == OP_READLINE) {
4143 right->op_flags |= OPf_STACKED;
4144 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4147 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4148 o = newBINOP(OP_SASSIGN, flags,
4149 scalar(right), mod(scalar(left), OP_SASSIGN) );
4155 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4156 o->op_private |= OPpCONST_ARYBASE;
4163 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4166 const U32 seq = intro_my();
4169 NewOp(1101, cop, 1, COP);
4170 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4171 cop->op_type = OP_DBSTATE;
4172 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4175 cop->op_type = OP_NEXTSTATE;
4176 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4178 cop->op_flags = (U8)flags;
4179 CopHINTS_set(cop, PL_hints);
4181 cop->op_private |= NATIVE_HINTS;
4183 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4184 cop->op_next = (OP*)cop;
4187 CopLABEL_set(cop, label);
4188 PL_hints |= HINT_BLOCK_SCOPE;
4191 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4192 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4194 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4195 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4196 if (cop->cop_hints_hash) {
4198 cop->cop_hints_hash->refcounted_he_refcnt++;
4199 HINTS_REFCNT_UNLOCK;
4202 if (PL_copline == NOLINE)
4203 CopLINE_set(cop, CopLINE(PL_curcop));
4205 CopLINE_set(cop, PL_copline);
4206 PL_copline = NOLINE;
4209 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4211 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4213 CopSTASH_set(cop, PL_curstash);
4215 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4216 AV *av = CopFILEAVx(PL_curcop);
4218 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4219 if (svp && *svp != &PL_sv_undef ) {
4220 (void)SvIOK_on(*svp);
4221 SvIV_set(*svp, PTR2IV(cop));
4226 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4231 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4234 return new_logop(type, flags, &first, &other);
4238 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4243 OP *first = *firstp;
4244 OP * const other = *otherp;
4246 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4247 return newBINOP(type, flags, scalar(first), scalar(other));
4249 scalarboolean(first);
4250 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4251 if (first->op_type == OP_NOT
4252 && (first->op_flags & OPf_SPECIAL)
4253 && (first->op_flags & OPf_KIDS)) {
4254 if (type == OP_AND || type == OP_OR) {
4260 first = *firstp = cUNOPo->op_first;
4262 first->op_next = o->op_next;
4263 cUNOPo->op_first = NULL;
4265 op_getmad(o,first,'O');
4271 if (first->op_type == OP_CONST) {
4272 if (first->op_private & OPpCONST_STRICT)
4273 no_bareword_allowed(first);
4274 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4275 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4276 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4277 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4278 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4280 if (other->op_type == OP_CONST)
4281 other->op_private |= OPpCONST_SHORTCIRCUIT;
4283 OP *newop = newUNOP(OP_NULL, 0, other);
4284 op_getmad(first, newop, '1');
4285 newop->op_targ = type; /* set "was" field */
4292 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4293 const OP *o2 = other;
4294 if ( ! (o2->op_type == OP_LIST
4295 && (( o2 = cUNOPx(o2)->op_first))
4296 && o2->op_type == OP_PUSHMARK
4297 && (( o2 = o2->op_sibling)) )
4300 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4301 || o2->op_type == OP_PADHV)
4302 && o2->op_private & OPpLVAL_INTRO
4303 && ckWARN(WARN_DEPRECATED))
4305 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4306 "Deprecated use of my() in false conditional");
4310 if (first->op_type == OP_CONST)
4311 first->op_private |= OPpCONST_SHORTCIRCUIT;
4313 first = newUNOP(OP_NULL, 0, first);
4314 op_getmad(other, first, '2');
4315 first->op_targ = type; /* set "was" field */
4322 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4323 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4325 const OP * const k1 = ((UNOP*)first)->op_first;
4326 const OP * const k2 = k1->op_sibling;
4328 switch (first->op_type)
4331 if (k2 && k2->op_type == OP_READLINE
4332 && (k2->op_flags & OPf_STACKED)
4333 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4335 warnop = k2->op_type;
4340 if (k1->op_type == OP_READDIR
4341 || k1->op_type == OP_GLOB
4342 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4343 || k1->op_type == OP_EACH)
4345 warnop = ((k1->op_type == OP_NULL)
4346 ? (OPCODE)k1->op_targ : k1->op_type);
4351 const line_t oldline = CopLINE(PL_curcop);
4352 CopLINE_set(PL_curcop, PL_copline);
4353 Perl_warner(aTHX_ packWARN(WARN_MISC),
4354 "Value of %s%s can be \"0\"; test with defined()",
4356 ((warnop == OP_READLINE || warnop == OP_GLOB)
4357 ? " construct" : "() operator"));
4358 CopLINE_set(PL_curcop, oldline);
4365 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4366 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4368 NewOp(1101, logop, 1, LOGOP);
4370 logop->op_type = (OPCODE)type;
4371 logop->op_ppaddr = PL_ppaddr[type];
4372 logop->op_first = first;
4373 logop->op_flags = (U8)(flags | OPf_KIDS);
4374 logop->op_other = LINKLIST(other);
4375 logop->op_private = (U8)(1 | (flags >> 8));
4377 /* establish postfix order */
4378 logop->op_next = LINKLIST(first);
4379 first->op_next = (OP*)logop;
4380 first->op_sibling = other;
4382 CHECKOP(type,logop);
4384 o = newUNOP(OP_NULL, 0, (OP*)logop);
4391 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4399 return newLOGOP(OP_AND, 0, first, trueop);
4401 return newLOGOP(OP_OR, 0, first, falseop);
4403 scalarboolean(first);
4404 if (first->op_type == OP_CONST) {
4405 /* Left or right arm of the conditional? */
4406 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4407 OP *live = left ? trueop : falseop;
4408 OP *const dead = left ? falseop : trueop;
4409 if (first->op_private & OPpCONST_BARE &&
4410 first->op_private & OPpCONST_STRICT) {
4411 no_bareword_allowed(first);
4414 /* This is all dead code when PERL_MAD is not defined. */
4415 live = newUNOP(OP_NULL, 0, live);
4416 op_getmad(first, live, 'C');
4417 op_getmad(dead, live, left ? 'e' : 't');
4424 NewOp(1101, logop, 1, LOGOP);
4425 logop->op_type = OP_COND_EXPR;
4426 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4427 logop->op_first = first;
4428 logop->op_flags = (U8)(flags | OPf_KIDS);
4429 logop->op_private = (U8)(1 | (flags >> 8));
4430 logop->op_other = LINKLIST(trueop);
4431 logop->op_next = LINKLIST(falseop);
4433 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4436 /* establish postfix order */
4437 start = LINKLIST(first);
4438 first->op_next = (OP*)logop;
4440 first->op_sibling = trueop;
4441 trueop->op_sibling = falseop;
4442 o = newUNOP(OP_NULL, 0, (OP*)logop);
4444 trueop->op_next = falseop->op_next = o;
4451 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4460 NewOp(1101, range, 1, LOGOP);
4462 range->op_type = OP_RANGE;
4463 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4464 range->op_first = left;
4465 range->op_flags = OPf_KIDS;
4466 leftstart = LINKLIST(left);
4467 range->op_other = LINKLIST(right);
4468 range->op_private = (U8)(1 | (flags >> 8));
4470 left->op_sibling = right;
4472 range->op_next = (OP*)range;
4473 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4474 flop = newUNOP(OP_FLOP, 0, flip);
4475 o = newUNOP(OP_NULL, 0, flop);
4477 range->op_next = leftstart;
4479 left->op_next = flip;
4480 right->op_next = flop;
4482 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4483 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4484 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4485 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4487 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4488 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4491 if (!flip->op_private || !flop->op_private)
4492 linklist(o); /* blow off optimizer unless constant */
4498 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4503 const bool once = block && block->op_flags & OPf_SPECIAL &&
4504 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4506 PERL_UNUSED_ARG(debuggable);
4509 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4510 return block; /* do {} while 0 does once */
4511 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4512 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4513 expr = newUNOP(OP_DEFINED, 0,
4514 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4515 } else if (expr->op_flags & OPf_KIDS) {
4516 const OP * const k1 = ((UNOP*)expr)->op_first;
4517 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4518 switch (expr->op_type) {
4520 if (k2 && k2->op_type == OP_READLINE
4521 && (k2->op_flags & OPf_STACKED)
4522 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4523 expr = newUNOP(OP_DEFINED, 0, expr);
4527 if (k1 && (k1->op_type == OP_READDIR
4528 || k1->op_type == OP_GLOB
4529 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4530 || k1->op_type == OP_EACH))
4531 expr = newUNOP(OP_DEFINED, 0, expr);
4537 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4538 * op, in listop. This is wrong. [perl #27024] */
4540 block = newOP(OP_NULL, 0);
4541 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4542 o = new_logop(OP_AND, 0, &expr, &listop);
4545 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4547 if (once && o != listop)
4548 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4551 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4553 o->op_flags |= flags;
4555 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4560 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4561 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4570 PERL_UNUSED_ARG(debuggable);
4573 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4574 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4575 expr = newUNOP(OP_DEFINED, 0,
4576 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4577 } else if (expr->op_flags & OPf_KIDS) {
4578 const OP * const k1 = ((UNOP*)expr)->op_first;
4579 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4580 switch (expr->op_type) {
4582 if (k2 && k2->op_type == OP_READLINE
4583 && (k2->op_flags & OPf_STACKED)
4584 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4585 expr = newUNOP(OP_DEFINED, 0, expr);
4589 if (k1 && (k1->op_type == OP_READDIR
4590 || k1->op_type == OP_GLOB
4591 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4592 || k1->op_type == OP_EACH))
4593 expr = newUNOP(OP_DEFINED, 0, expr);
4600 block = newOP(OP_NULL, 0);
4601 else if (cont || has_my) {
4602 block = scope(block);
4606 next = LINKLIST(cont);
4609 OP * const unstack = newOP(OP_UNSTACK, 0);
4612 cont = append_elem(OP_LINESEQ, cont, unstack);
4616 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4618 redo = LINKLIST(listop);
4621 PL_copline = (line_t)whileline;
4623 o = new_logop(OP_AND, 0, &expr, &listop);
4624 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4625 op_free(expr); /* oops, it's a while (0) */
4627 return NULL; /* listop already freed by new_logop */
4630 ((LISTOP*)listop)->op_last->op_next =
4631 (o == listop ? redo : LINKLIST(o));
4637 NewOp(1101,loop,1,LOOP);
4638 loop->op_type = OP_ENTERLOOP;
4639 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4640 loop->op_private = 0;
4641 loop->op_next = (OP*)loop;
4644 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4646 loop->op_redoop = redo;
4647 loop->op_lastop = o;
4648 o->op_private |= loopflags;
4651 loop->op_nextop = next;
4653 loop->op_nextop = o;
4655 o->op_flags |= flags;
4656 o->op_private |= (flags >> 8);
4661 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4666 PADOFFSET padoff = 0;
4672 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4673 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4674 sv->op_type = OP_RV2GV;
4675 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4677 /* The op_type check is needed to prevent a possible segfault
4678 * if the loop variable is undeclared and 'strict vars' is in
4679 * effect. This is illegal but is nonetheless parsed, so we
4680 * may reach this point with an OP_CONST where we're expecting
4683 if (cUNOPx(sv)->op_first->op_type == OP_GV
4684 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4685 iterpflags |= OPpITER_DEF;
4687 else if (sv->op_type == OP_PADSV) { /* private variable */
4688 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4689 padoff = sv->op_targ;
4699 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4701 SV *const namesv = PAD_COMPNAME_SV(padoff);
4703 const char *const name = SvPV_const(namesv, len);
4705 if (len == 2 && name[0] == '$' && name[1] == '_')
4706 iterpflags |= OPpITER_DEF;
4710 const PADOFFSET offset = pad_findmy("$_");
4711 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4712 sv = newGVOP(OP_GV, 0, PL_defgv);
4717 iterpflags |= OPpITER_DEF;
4719 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4720 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4721 iterflags |= OPf_STACKED;
4723 else if (expr->op_type == OP_NULL &&
4724 (expr->op_flags & OPf_KIDS) &&
4725 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4727 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4728 * set the STACKED flag to indicate that these values are to be
4729 * treated as min/max values by 'pp_iterinit'.
4731 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4732 LOGOP* const range = (LOGOP*) flip->op_first;
4733 OP* const left = range->op_first;
4734 OP* const right = left->op_sibling;
4737 range->op_flags &= ~OPf_KIDS;
4738 range->op_first = NULL;
4740 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4741 listop->op_first->op_next = range->op_next;
4742 left->op_next = range->op_other;
4743 right->op_next = (OP*)listop;
4744 listop->op_next = listop->op_first;
4747 op_getmad(expr,(OP*)listop,'O');
4751 expr = (OP*)(listop);
4753 iterflags |= OPf_STACKED;
4756 expr = mod(force_list(expr), OP_GREPSTART);
4759 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4760 append_elem(OP_LIST, expr, scalar(sv))));
4761 assert(!loop->op_next);
4762 /* for my $x () sets OPpLVAL_INTRO;
4763 * for our $x () sets OPpOUR_INTRO */
4764 loop->op_private = (U8)iterpflags;
4765 #ifdef PL_OP_SLAB_ALLOC
4768 NewOp(1234,tmp,1,LOOP);
4769 Copy(loop,tmp,1,LISTOP);
4770 S_op_destroy(aTHX_ (OP*)loop);
4774 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4776 loop->op_targ = padoff;
4777 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4779 op_getmad(madsv, (OP*)loop, 'v');
4780 PL_copline = forline;
4781 return newSTATEOP(0, label, wop);
4785 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4790 if (type != OP_GOTO || label->op_type == OP_CONST) {
4791 /* "last()" means "last" */
4792 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4793 o = newOP(type, OPf_SPECIAL);
4795 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4796 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4800 op_getmad(label,o,'L');
4806 /* Check whether it's going to be a goto &function */
4807 if (label->op_type == OP_ENTERSUB
4808 && !(label->op_flags & OPf_STACKED))
4809 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4810 o = newUNOP(type, OPf_STACKED, label);
4812 PL_hints |= HINT_BLOCK_SCOPE;
4816 /* if the condition is a literal array or hash
4817 (or @{ ... } etc), make a reference to it.
4820 S_ref_array_or_hash(pTHX_ OP *cond)
4823 && (cond->op_type == OP_RV2AV
4824 || cond->op_type == OP_PADAV
4825 || cond->op_type == OP_RV2HV
4826 || cond->op_type == OP_PADHV))
4828 return newUNOP(OP_REFGEN,
4829 0, mod(cond, OP_REFGEN));
4835 /* These construct the optree fragments representing given()
4838 entergiven and enterwhen are LOGOPs; the op_other pointer
4839 points up to the associated leave op. We need this so we
4840 can put it in the context and make break/continue work.
4841 (Also, of course, pp_enterwhen will jump straight to
4842 op_other if the match fails.)
4846 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4847 I32 enter_opcode, I32 leave_opcode,
4848 PADOFFSET entertarg)
4854 NewOp(1101, enterop, 1, LOGOP);
4855 enterop->op_type = enter_opcode;
4856 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4857 enterop->op_flags = (U8) OPf_KIDS;
4858 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4859 enterop->op_private = 0;
4861 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4864 enterop->op_first = scalar(cond);
4865 cond->op_sibling = block;
4867 o->op_next = LINKLIST(cond);
4868 cond->op_next = (OP *) enterop;
4871 /* This is a default {} block */
4872 enterop->op_first = block;
4873 enterop->op_flags |= OPf_SPECIAL;
4875 o->op_next = (OP *) enterop;
4878 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4879 entergiven and enterwhen both
4882 enterop->op_next = LINKLIST(block);
4883 block->op_next = enterop->op_other = o;
4888 /* Does this look like a boolean operation? For these purposes
4889 a boolean operation is:
4890 - a subroutine call [*]
4891 - a logical connective
4892 - a comparison operator
4893 - a filetest operator, with the exception of -s -M -A -C
4894 - defined(), exists() or eof()
4895 - /$re/ or $foo =~ /$re/
4897 [*] possibly surprising
4900 S_looks_like_bool(pTHX_ const OP *o)
4903 switch(o->op_type) {
4905 return looks_like_bool(cLOGOPo->op_first);
4909 looks_like_bool(cLOGOPo->op_first)
4910 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4914 case OP_NOT: case OP_XOR:
4915 /* Note that OP_DOR is not here */
4917 case OP_EQ: case OP_NE: case OP_LT:
4918 case OP_GT: case OP_LE: case OP_GE:
4920 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4921 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4923 case OP_SEQ: case OP_SNE: case OP_SLT:
4924 case OP_SGT: case OP_SLE: case OP_SGE:
4928 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4929 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4930 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4931 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4932 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4933 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4934 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4935 case OP_FTTEXT: case OP_FTBINARY:
4937 case OP_DEFINED: case OP_EXISTS:
4938 case OP_MATCH: case OP_EOF:
4943 /* Detect comparisons that have been optimized away */
4944 if (cSVOPo->op_sv == &PL_sv_yes
4945 || cSVOPo->op_sv == &PL_sv_no)
4956 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4960 return newGIVWHENOP(
4961 ref_array_or_hash(cond),
4963 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4967 /* If cond is null, this is a default {} block */
4969 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4971 const bool cond_llb = (!cond || looks_like_bool(cond));
4977 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4979 scalar(ref_array_or_hash(cond)));
4982 return newGIVWHENOP(
4984 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4985 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4989 =for apidoc cv_undef
4991 Clear out all the active components of a CV. This can happen either
4992 by an explicit C<undef &foo>, or by the reference count going to zero.
4993 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4994 children can still follow the full lexical scope chain.
5000 Perl_cv_undef(pTHX_ CV *cv)
5004 if (CvFILE(cv) && !CvISXSUB(cv)) {
5005 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5006 Safefree(CvFILE(cv));
5011 if (!CvISXSUB(cv) && CvROOT(cv)) {
5012 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5013 Perl_croak(aTHX_ "Can't undef active subroutine");
5016 PAD_SAVE_SETNULLPAD();
5018 op_free(CvROOT(cv));
5023 SvPOK_off((SV*)cv); /* forget prototype */
5028 /* remove CvOUTSIDE unless this is an undef rather than a free */
5029 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5030 if (!CvWEAKOUTSIDE(cv))
5031 SvREFCNT_dec(CvOUTSIDE(cv));
5032 CvOUTSIDE(cv) = NULL;
5035 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5038 if (CvISXSUB(cv) && CvXSUB(cv)) {
5041 /* delete all flags except WEAKOUTSIDE */
5042 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5046 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5049 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5050 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5051 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5052 || (p && (len != SvCUR(cv) /* Not the same length. */
5053 || memNE(p, SvPVX_const(cv), len))))
5054 && ckWARN_d(WARN_PROTOTYPE)) {
5055 SV* const msg = sv_newmortal();
5059 gv_efullname3(name = sv_newmortal(), gv, NULL);
5060 sv_setpvs(msg, "Prototype mismatch:");
5062 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5064 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5066 sv_catpvs(msg, ": none");
5067 sv_catpvs(msg, " vs ");
5069 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5071 sv_catpvs(msg, "none");
5072 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5076 static void const_sv_xsub(pTHX_ CV* cv);
5080 =head1 Optree Manipulation Functions
5082 =for apidoc cv_const_sv
5084 If C<cv> is a constant sub eligible for inlining. returns the constant
5085 value returned by the sub. Otherwise, returns NULL.
5087 Constant subs can be created with C<newCONSTSUB> or as described in
5088 L<perlsub/"Constant Functions">.
5093 Perl_cv_const_sv(pTHX_ CV *cv)
5095 PERL_UNUSED_CONTEXT;
5098 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5100 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5103 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5104 * Can be called in 3 ways:
5107 * look for a single OP_CONST with attached value: return the value
5109 * cv && CvCLONE(cv) && !CvCONST(cv)
5111 * examine the clone prototype, and if contains only a single
5112 * OP_CONST referencing a pad const, or a single PADSV referencing
5113 * an outer lexical, return a non-zero value to indicate the CV is
5114 * a candidate for "constizing" at clone time
5118 * We have just cloned an anon prototype that was marked as a const
5119 * candidiate. Try to grab the current value, and in the case of
5120 * PADSV, ignore it if it has multiple references. Return the value.
5124 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5132 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5133 o = cLISTOPo->op_first->op_sibling;
5135 for (; o; o = o->op_next) {
5136 const OPCODE type = o->op_type;
5138 if (sv && o->op_next == o)
5140 if (o->op_next != o) {
5141 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5143 if (type == OP_DBSTATE)
5146 if (type == OP_LEAVESUB || type == OP_RETURN)
5150 if (type == OP_CONST && cSVOPo->op_sv)
5152 else if (cv && type == OP_CONST) {
5153 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5157 else if (cv && type == OP_PADSV) {
5158 if (CvCONST(cv)) { /* newly cloned anon */
5159 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5160 /* the candidate should have 1 ref from this pad and 1 ref
5161 * from the parent */
5162 if (!sv || SvREFCNT(sv) != 2)
5169 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5170 sv = &PL_sv_undef; /* an arbitrary non-null value */
5185 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5188 /* This would be the return value, but the return cannot be reached. */
5189 OP* pegop = newOP(OP_NULL, 0);
5192 PERL_UNUSED_ARG(floor);
5202 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5204 NORETURN_FUNCTION_END;
5209 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5211 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5215 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5222 register CV *cv = NULL;
5224 /* If the subroutine has no body, no attributes, and no builtin attributes
5225 then it's just a sub declaration, and we may be able to get away with
5226 storing with a placeholder scalar in the symbol table, rather than a
5227 full GV and CV. If anything is present then it will take a full CV to
5229 const I32 gv_fetch_flags
5230 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5232 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5233 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5236 assert(proto->op_type == OP_CONST);
5237 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5242 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5243 SV * const sv = sv_newmortal();
5244 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5245 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5246 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5247 aname = SvPVX_const(sv);
5252 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5253 : gv_fetchpv(aname ? aname
5254 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5255 gv_fetch_flags, SVt_PVCV);
5257 if (!PL_madskills) {
5266 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5267 maximum a prototype before. */
5268 if (SvTYPE(gv) > SVt_NULL) {
5269 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5270 && ckWARN_d(WARN_PROTOTYPE))
5272 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5274 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5277 sv_setpvn((SV*)gv, ps, ps_len);
5279 sv_setiv((SV*)gv, -1);
5280 SvREFCNT_dec(PL_compcv);
5281 cv = PL_compcv = NULL;
5282 PL_sub_generation++;
5286 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5288 #ifdef GV_UNIQUE_CHECK
5289 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5290 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5294 if (!block || !ps || *ps || attrs
5295 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5297 || block->op_type == OP_NULL
5302 const_sv = op_const_sv(block, NULL);
5305 const bool exists = CvROOT(cv) || CvXSUB(cv);
5307 #ifdef GV_UNIQUE_CHECK
5308 if (exists && GvUNIQUE(gv)) {
5309 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5313 /* if the subroutine doesn't exist and wasn't pre-declared
5314 * with a prototype, assume it will be AUTOLOADed,
5315 * skipping the prototype check
5317 if (exists || SvPOK(cv))
5318 cv_ckproto_len(cv, gv, ps, ps_len);
5319 /* already defined (or promised)? */
5320 if (exists || GvASSUMECV(gv)) {
5323 || block->op_type == OP_NULL
5326 if (CvFLAGS(PL_compcv)) {
5327 /* might have had built-in attrs applied */
5328 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5330 /* just a "sub foo;" when &foo is already defined */
5331 SAVEFREESV(PL_compcv);
5336 && block->op_type != OP_NULL
5339 if (ckWARN(WARN_REDEFINE)
5341 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5343 const line_t oldline = CopLINE(PL_curcop);
5344 if (PL_copline != NOLINE)
5345 CopLINE_set(PL_curcop, PL_copline);
5346 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5347 CvCONST(cv) ? "Constant subroutine %s redefined"
5348 : "Subroutine %s redefined", name);
5349 CopLINE_set(PL_curcop, oldline);
5352 if (!PL_minus_c) /* keep old one around for madskills */
5355 /* (PL_madskills unset in used file.) */
5363 SvREFCNT_inc_simple_void_NN(const_sv);
5365 assert(!CvROOT(cv) && !CvCONST(cv));
5366 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5367 CvXSUBANY(cv).any_ptr = const_sv;
5368 CvXSUB(cv) = const_sv_xsub;
5374 cv = newCONSTSUB(NULL, name, const_sv);
5376 PL_sub_generation++;
5380 SvREFCNT_dec(PL_compcv);
5388 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5389 * before we clobber PL_compcv.
5393 || block->op_type == OP_NULL
5397 /* Might have had built-in attributes applied -- propagate them. */
5398 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5399 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5400 stash = GvSTASH(CvGV(cv));
5401 else if (CvSTASH(cv))
5402 stash = CvSTASH(cv);
5404 stash = PL_curstash;
5407 /* possibly about to re-define existing subr -- ignore old cv */
5408 rcv = (SV*)PL_compcv;
5409 if (name && GvSTASH(gv))
5410 stash = GvSTASH(gv);
5412 stash = PL_curstash;
5414 apply_attrs(stash, rcv, attrs, FALSE);
5416 if (cv) { /* must reuse cv if autoloaded */
5423 || block->op_type == OP_NULL) && !PL_madskills
5426 /* got here with just attrs -- work done, so bug out */
5427 SAVEFREESV(PL_compcv);
5430 /* transfer PL_compcv to cv */
5432 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5433 if (!CvWEAKOUTSIDE(cv))
5434 SvREFCNT_dec(CvOUTSIDE(cv));
5435 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5436 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5437 CvOUTSIDE(PL_compcv) = 0;
5438 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5439 CvPADLIST(PL_compcv) = 0;
5440 /* inner references to PL_compcv must be fixed up ... */
5441 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5442 /* ... before we throw it away */
5443 SvREFCNT_dec(PL_compcv);
5445 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5446 ++PL_sub_generation;
5453 if (strEQ(name, "import")) {
5454 PL_formfeed = (SV*)cv;
5455 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5459 PL_sub_generation++;
5463 CvFILE_set_from_cop(cv, PL_curcop);
5464 CvSTASH(cv) = PL_curstash;
5467 sv_setpvn((SV*)cv, ps, ps_len);
5469 if (PL_error_count) {
5473 const char *s = strrchr(name, ':');
5475 if (strEQ(s, "BEGIN")) {
5476 const char not_safe[] =
5477 "BEGIN not safe after errors--compilation aborted";
5478 if (PL_in_eval & EVAL_KEEPERR)
5479 Perl_croak(aTHX_ not_safe);
5481 /* force display of errors found but not reported */
5482 sv_catpv(ERRSV, not_safe);
5483 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5493 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5494 mod(scalarseq(block), OP_LEAVESUBLV));
5495 block->op_attached = 1;
5498 /* This makes sub {}; work as expected. */
5499 if (block->op_type == OP_STUB) {
5500 OP* const newblock = newSTATEOP(0, NULL, 0);
5502 op_getmad(block,newblock,'B');
5509 block->op_attached = 1;
5510 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5512 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5513 OpREFCNT_set(CvROOT(cv), 1);
5514 CvSTART(cv) = LINKLIST(CvROOT(cv));
5515 CvROOT(cv)->op_next = 0;
5516 CALL_PEEP(CvSTART(cv));
5518 /* now that optimizer has done its work, adjust pad values */
5520 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5523 assert(!CvCONST(cv));
5524 if (ps && !*ps && op_const_sv(block, cv))
5528 if (name || aname) {
5529 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5530 SV * const sv = newSV(0);
5531 SV * const tmpstr = sv_newmortal();
5532 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5533 GV_ADDMULTI, SVt_PVHV);
5536 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5538 (long)PL_subline, (long)CopLINE(PL_curcop));
5539 gv_efullname3(tmpstr, gv, NULL);
5540 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5541 hv = GvHVn(db_postponed);
5542 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5543 CV * const pcv = GvCV(db_postponed);
5549 call_sv((SV*)pcv, G_DISCARD);
5554 if (name && !PL_error_count)
5555 process_special_blocks(name, gv, cv);
5559 PL_copline = NOLINE;
5565 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5568 const char *const colon = strrchr(fullname,':');
5569 const char *const name = colon ? colon + 1 : fullname;
5572 if (strEQ(name, "BEGIN")) {
5573 const I32 oldscope = PL_scopestack_ix;
5575 SAVECOPFILE(&PL_compiling);
5576 SAVECOPLINE(&PL_compiling);
5578 DEBUG_x( dump_sub(gv) );
5579 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5580 GvCV(gv) = 0; /* cv has been hijacked */
5581 call_list(oldscope, PL_beginav);
5583 PL_curcop = &PL_compiling;
5584 CopHINTS_set(&PL_compiling, PL_hints);
5591 if strEQ(name, "END") {
5592 DEBUG_x( dump_sub(gv) );
5593 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5596 } else if (*name == 'U') {
5597 if (strEQ(name, "UNITCHECK")) {
5598 /* It's never too late to run a unitcheck block */
5599 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5603 } else if (*name == 'C') {
5604 if (strEQ(name, "CHECK")) {
5605 if (PL_main_start && ckWARN(WARN_VOID))
5606 Perl_warner(aTHX_ packWARN(WARN_VOID),
5607 "Too late to run CHECK block");
5608 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5612 } else if (*name == 'I') {
5613 if (strEQ(name, "INIT")) {
5614 if (PL_main_start && ckWARN(WARN_VOID))
5615 Perl_warner(aTHX_ packWARN(WARN_VOID),
5616 "Too late to run INIT block");
5617 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5623 DEBUG_x( dump_sub(gv) );
5624 GvCV(gv) = 0; /* cv has been hijacked */
5629 =for apidoc newCONSTSUB
5631 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5632 eligible for inlining at compile-time.
5638 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5643 const char *const temp_p = CopFILE(PL_curcop);
5644 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5646 SV *const temp_sv = CopFILESV(PL_curcop);
5648 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5650 char *const file = savepvn(temp_p, temp_p ? len : 0);
5654 SAVECOPLINE(PL_curcop);
5655 CopLINE_set(PL_curcop, PL_copline);
5658 PL_hints &= ~HINT_BLOCK_SCOPE;
5661 SAVESPTR(PL_curstash);
5662 SAVECOPSTASH(PL_curcop);
5663 PL_curstash = stash;
5664 CopSTASH_set(PL_curcop,stash);
5667 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5668 and so doesn't get free()d. (It's expected to be from the C pre-
5669 processor __FILE__ directive). But we need a dynamically allocated one,
5670 and we need it to get freed. */
5671 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5672 CvXSUBANY(cv).any_ptr = sv;
5678 CopSTASH_free(PL_curcop);
5686 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5687 const char *const filename, const char *const proto,
5690 CV *cv = newXS(name, subaddr, filename);
5692 if (flags & XS_DYNAMIC_FILENAME) {
5693 /* We need to "make arrangements" (ie cheat) to ensure that the
5694 filename lasts as long as the PVCV we just created, but also doesn't
5696 STRLEN filename_len = strlen(filename);
5697 STRLEN proto_and_file_len = filename_len;
5698 char *proto_and_file;
5702 proto_len = strlen(proto);
5703 proto_and_file_len += proto_len;
5705 Newx(proto_and_file, proto_and_file_len + 1, char);
5706 Copy(proto, proto_and_file, proto_len, char);
5707 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5710 proto_and_file = savepvn(filename, filename_len);
5713 /* This gets free()d. :-) */
5714 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5715 SV_HAS_TRAILING_NUL);
5717 /* This gives us the correct prototype, rather than one with the
5718 file name appended. */
5719 SvCUR_set(cv, proto_len);
5723 CvFILE(cv) = proto_and_file + proto_len;
5725 sv_setpv((SV *)cv, proto);
5731 =for apidoc U||newXS
5733 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5734 static storage, as it is used directly as CvFILE(), without a copy being made.
5740 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5743 GV * const gv = gv_fetchpv(name ? name :
5744 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5745 GV_ADDMULTI, SVt_PVCV);
5749 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5751 if ((cv = (name ? GvCV(gv) : NULL))) {
5753 /* just a cached method */
5757 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5758 /* already defined (or promised) */
5759 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5760 if (ckWARN(WARN_REDEFINE)) {
5761 GV * const gvcv = CvGV(cv);
5763 HV * const stash = GvSTASH(gvcv);
5765 const char *redefined_name = HvNAME_get(stash);
5766 if ( strEQ(redefined_name,"autouse") ) {
5767 const line_t oldline = CopLINE(PL_curcop);
5768 if (PL_copline != NOLINE)
5769 CopLINE_set(PL_curcop, PL_copline);
5770 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5771 CvCONST(cv) ? "Constant subroutine %s redefined"
5772 : "Subroutine %s redefined"
5774 CopLINE_set(PL_curcop, oldline);
5784 if (cv) /* must reuse cv if autoloaded */
5787 cv = (CV*)newSV_type(SVt_PVCV);
5791 PL_sub_generation++;
5795 (void)gv_fetchfile(filename);
5796 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5797 an external constant string */
5799 CvXSUB(cv) = subaddr;
5802 process_special_blocks(name, gv, cv);
5814 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5819 OP* pegop = newOP(OP_NULL, 0);
5823 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5824 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5826 #ifdef GV_UNIQUE_CHECK
5828 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5832 if ((cv = GvFORM(gv))) {
5833 if (ckWARN(WARN_REDEFINE)) {
5834 const line_t oldline = CopLINE(PL_curcop);
5835 if (PL_copline != NOLINE)
5836 CopLINE_set(PL_curcop, PL_copline);
5837 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5838 o ? "Format %"SVf" redefined"
5839 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5840 CopLINE_set(PL_curcop, oldline);
5847 CvFILE_set_from_cop(cv, PL_curcop);
5850 pad_tidy(padtidy_FORMAT);
5851 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5852 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5853 OpREFCNT_set(CvROOT(cv), 1);
5854 CvSTART(cv) = LINKLIST(CvROOT(cv));
5855 CvROOT(cv)->op_next = 0;
5856 CALL_PEEP(CvSTART(cv));
5858 op_getmad(o,pegop,'n');
5859 op_getmad_weak(block, pegop, 'b');
5863 PL_copline = NOLINE;
5871 Perl_newANONLIST(pTHX_ OP *o)
5873 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5877 Perl_newANONHASH(pTHX_ OP *o)
5879 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5883 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5885 return newANONATTRSUB(floor, proto, NULL, block);
5889 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5891 return newUNOP(OP_REFGEN, 0,
5892 newSVOP(OP_ANONCODE, 0,
5893 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5897 Perl_oopsAV(pTHX_ OP *o)
5900 switch (o->op_type) {
5902 o->op_type = OP_PADAV;
5903 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5904 return ref(o, OP_RV2AV);
5907 o->op_type = OP_RV2AV;
5908 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5913 if (ckWARN_d(WARN_INTERNAL))
5914 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5921 Perl_oopsHV(pTHX_ OP *o)
5924 switch (o->op_type) {
5927 o->op_type = OP_PADHV;
5928 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5929 return ref(o, OP_RV2HV);
5933 o->op_type = OP_RV2HV;
5934 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5939 if (ckWARN_d(WARN_INTERNAL))
5940 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5947 Perl_newAVREF(pTHX_ OP *o)
5950 if (o->op_type == OP_PADANY) {
5951 o->op_type = OP_PADAV;
5952 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5955 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5956 && ckWARN(WARN_DEPRECATED)) {
5957 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5958 "Using an array as a reference is deprecated");
5960 return newUNOP(OP_RV2AV, 0, scalar(o));
5964 Perl_newGVREF(pTHX_ I32 type, OP *o)
5966 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5967 return newUNOP(OP_NULL, 0, o);
5968 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5972 Perl_newHVREF(pTHX_ OP *o)
5975 if (o->op_type == OP_PADANY) {
5976 o->op_type = OP_PADHV;
5977 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5980 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5981 && ckWARN(WARN_DEPRECATED)) {
5982 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5983 "Using a hash as a reference is deprecated");
5985 return newUNOP(OP_RV2HV, 0, scalar(o));
5989 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5991 return newUNOP(OP_RV2CV, flags, scalar(o));
5995 Perl_newSVREF(pTHX_ OP *o)
5998 if (o->op_type == OP_PADANY) {
5999 o->op_type = OP_PADSV;
6000 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6003 return newUNOP(OP_RV2SV, 0, scalar(o));
6006 /* Check routines. See the comments at the top of this file for details
6007 * on when these are called */
6010 Perl_ck_anoncode(pTHX_ OP *o)
6012 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6014 cSVOPo->op_sv = NULL;
6019 Perl_ck_bitop(pTHX_ OP *o)
6022 #define OP_IS_NUMCOMPARE(op) \
6023 ((op) == OP_LT || (op) == OP_I_LT || \
6024 (op) == OP_GT || (op) == OP_I_GT || \
6025 (op) == OP_LE || (op) == OP_I_LE || \
6026 (op) == OP_GE || (op) == OP_I_GE || \
6027 (op) == OP_EQ || (op) == OP_I_EQ || \
6028 (op) == OP_NE || (op) == OP_I_NE || \
6029 (op) == OP_NCMP || (op) == OP_I_NCMP)
6030 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6031 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6032 && (o->op_type == OP_BIT_OR
6033 || o->op_type == OP_BIT_AND
6034 || o->op_type == OP_BIT_XOR))
6036 const OP * const left = cBINOPo->op_first;
6037 const OP * const right = left->op_sibling;
6038 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6039 (left->op_flags & OPf_PARENS) == 0) ||
6040 (OP_IS_NUMCOMPARE(right->op_type) &&
6041 (right->op_flags & OPf_PARENS) == 0))
6042 if (ckWARN(WARN_PRECEDENCE))
6043 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6044 "Possible precedence problem on bitwise %c operator",
6045 o->op_type == OP_BIT_OR ? '|'
6046 : o->op_type == OP_BIT_AND ? '&' : '^'
6053 Perl_ck_concat(pTHX_ OP *o)
6055 const OP * const kid = cUNOPo->op_first;
6056 PERL_UNUSED_CONTEXT;
6057 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6058 !(kUNOP->op_first->op_flags & OPf_MOD))
6059 o->op_flags |= OPf_STACKED;
6064 Perl_ck_spair(pTHX_ OP *o)
6067 if (o->op_flags & OPf_KIDS) {
6070 const OPCODE type = o->op_type;
6071 o = modkids(ck_fun(o), type);
6072 kid = cUNOPo->op_first;
6073 newop = kUNOP->op_first->op_sibling;
6075 const OPCODE type = newop->op_type;
6076 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6077 type == OP_PADAV || type == OP_PADHV ||
6078 type == OP_RV2AV || type == OP_RV2HV)
6082 op_getmad(kUNOP->op_first,newop,'K');
6084 op_free(kUNOP->op_first);
6086 kUNOP->op_first = newop;
6088 o->op_ppaddr = PL_ppaddr[++o->op_type];
6093 Perl_ck_delete(pTHX_ OP *o)
6097 if (o->op_flags & OPf_KIDS) {
6098 OP * const kid = cUNOPo->op_first;
6099 switch (kid->op_type) {
6101 o->op_flags |= OPf_SPECIAL;
6104 o->op_private |= OPpSLICE;
6107 o->op_flags |= OPf_SPECIAL;
6112 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6121 Perl_ck_die(pTHX_ OP *o)
6124 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6130 Perl_ck_eof(pTHX_ OP *o)
6134 if (o->op_flags & OPf_KIDS) {
6135 if (cLISTOPo->op_first->op_type == OP_STUB) {
6137 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6139 op_getmad(o,newop,'O');
6151 Perl_ck_eval(pTHX_ OP *o)
6154 PL_hints |= HINT_BLOCK_SCOPE;
6155 if (o->op_flags & OPf_KIDS) {
6156 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6159 o->op_flags &= ~OPf_KIDS;
6162 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6168 cUNOPo->op_first = 0;
6173 NewOp(1101, enter, 1, LOGOP);
6174 enter->op_type = OP_ENTERTRY;
6175 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6176 enter->op_private = 0;
6178 /* establish postfix order */
6179 enter->op_next = (OP*)enter;
6181 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6182 o->op_type = OP_LEAVETRY;
6183 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6184 enter->op_other = o;
6185 op_getmad(oldo,o,'O');
6199 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6200 op_getmad(oldo,o,'O');
6202 o->op_targ = (PADOFFSET)PL_hints;
6203 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6204 /* Store a copy of %^H that pp_entereval can pick up.
6205 OPf_SPECIAL flags the opcode as being for this purpose,
6206 so that it in turn will return a copy at every
6208 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6209 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6210 cUNOPo->op_first->op_sibling = hhop;
6211 o->op_private |= OPpEVAL_HAS_HH;
6217 Perl_ck_exit(pTHX_ OP *o)
6220 HV * const table = GvHV(PL_hintgv);
6222 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6223 if (svp && *svp && SvTRUE(*svp))
6224 o->op_private |= OPpEXIT_VMSISH;
6226 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6232 Perl_ck_exec(pTHX_ OP *o)
6234 if (o->op_flags & OPf_STACKED) {
6237 kid = cUNOPo->op_first->op_sibling;
6238 if (kid->op_type == OP_RV2GV)
6247 Perl_ck_exists(pTHX_ OP *o)
6251 if (o->op_flags & OPf_KIDS) {
6252 OP * const kid = cUNOPo->op_first;
6253 if (kid->op_type == OP_ENTERSUB) {
6254 (void) ref(kid, o->op_type);
6255 if (kid->op_type != OP_RV2CV && !PL_error_count)
6256 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6258 o->op_private |= OPpEXISTS_SUB;
6260 else if (kid->op_type == OP_AELEM)
6261 o->op_flags |= OPf_SPECIAL;
6262 else if (kid->op_type != OP_HELEM)
6263 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6271 Perl_ck_rvconst(pTHX_ register OP *o)
6274 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6276 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6277 if (o->op_type == OP_RV2CV)
6278 o->op_private &= ~1;
6280 if (kid->op_type == OP_CONST) {
6283 SV * const kidsv = kid->op_sv;
6285 /* Is it a constant from cv_const_sv()? */
6286 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6287 SV * const rsv = SvRV(kidsv);
6288 const svtype type = SvTYPE(rsv);
6289 const char *badtype = NULL;
6291 switch (o->op_type) {
6293 if (type > SVt_PVMG)
6294 badtype = "a SCALAR";
6297 if (type != SVt_PVAV)
6298 badtype = "an ARRAY";
6301 if (type != SVt_PVHV)
6305 if (type != SVt_PVCV)
6310 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6313 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6314 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6315 /* If this is an access to a stash, disable "strict refs", because
6316 * stashes aren't auto-vivified at compile-time (unless we store
6317 * symbols in them), and we don't want to produce a run-time
6318 * stricture error when auto-vivifying the stash. */
6319 const char *s = SvPV_nolen(kidsv);
6320 const STRLEN l = SvCUR(kidsv);
6321 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6322 o->op_private &= ~HINT_STRICT_REFS;
6324 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6325 const char *badthing;
6326 switch (o->op_type) {
6328 badthing = "a SCALAR";
6331 badthing = "an ARRAY";
6334 badthing = "a HASH";
6342 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6343 SVfARG(kidsv), badthing);
6346 * This is a little tricky. We only want to add the symbol if we
6347 * didn't add it in the lexer. Otherwise we get duplicate strict
6348 * warnings. But if we didn't add it in the lexer, we must at
6349 * least pretend like we wanted to add it even if it existed before,
6350 * or we get possible typo warnings. OPpCONST_ENTERED says
6351 * whether the lexer already added THIS instance of this symbol.
6353 iscv = (o->op_type == OP_RV2CV) * 2;
6355 gv = gv_fetchsv(kidsv,
6356 iscv | !(kid->op_private & OPpCONST_ENTERED),
6359 : o->op_type == OP_RV2SV
6361 : o->op_type == OP_RV2AV
6363 : o->op_type == OP_RV2HV
6366 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6368 kid->op_type = OP_GV;
6369 SvREFCNT_dec(kid->op_sv);
6371 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6372 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6373 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6375 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6377 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6379 kid->op_private = 0;
6380 kid->op_ppaddr = PL_ppaddr[OP_GV];
6387 Perl_ck_ftst(pTHX_ OP *o)
6390 const I32 type = o->op_type;
6392 if (o->op_flags & OPf_REF) {
6395 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6396 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6397 const OPCODE kidtype = kid->op_type;
6399 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6400 OP * const newop = newGVOP(type, OPf_REF,
6401 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6403 op_getmad(o,newop,'O');
6409 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6410 o->op_private |= OPpFT_ACCESS;
6411 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6412 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6413 o->op_private |= OPpFT_STACKED;
6421 if (type == OP_FTTTY)
6422 o = newGVOP(type, OPf_REF, PL_stdingv);
6424 o = newUNOP(type, 0, newDEFSVOP());
6425 op_getmad(oldo,o,'O');
6431 Perl_ck_fun(pTHX_ OP *o)
6434 const int type = o->op_type;
6435 register I32 oa = PL_opargs[type] >> OASHIFT;
6437 if (o->op_flags & OPf_STACKED) {
6438 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6441 return no_fh_allowed(o);
6444 if (o->op_flags & OPf_KIDS) {
6445 OP **tokid = &cLISTOPo->op_first;
6446 register OP *kid = cLISTOPo->op_first;
6450 if (kid->op_type == OP_PUSHMARK ||
6451 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6453 tokid = &kid->op_sibling;
6454 kid = kid->op_sibling;
6456 if (!kid && PL_opargs[type] & OA_DEFGV)
6457 *tokid = kid = newDEFSVOP();
6461 sibl = kid->op_sibling;
6463 if (!sibl && kid->op_type == OP_STUB) {
6470 /* list seen where single (scalar) arg expected? */
6471 if (numargs == 1 && !(oa >> 4)
6472 && kid->op_type == OP_LIST && type != OP_SCALAR)
6474 return too_many_arguments(o,PL_op_desc[type]);
6487 if ((type == OP_PUSH || type == OP_UNSHIFT)
6488 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6489 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6490 "Useless use of %s with no values",
6493 if (kid->op_type == OP_CONST &&
6494 (kid->op_private & OPpCONST_BARE))
6496 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6497 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6498 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6499 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6500 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6501 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6503 op_getmad(kid,newop,'K');
6508 kid->op_sibling = sibl;
6511 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6512 bad_type(numargs, "array", PL_op_desc[type], kid);
6516 if (kid->op_type == OP_CONST &&
6517 (kid->op_private & OPpCONST_BARE))
6519 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6520 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6521 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6522 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6523 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6524 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6526 op_getmad(kid,newop,'K');
6531 kid->op_sibling = sibl;
6534 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6535 bad_type(numargs, "hash", PL_op_desc[type], kid);
6540 OP * const newop = newUNOP(OP_NULL, 0, kid);
6541 kid->op_sibling = 0;
6543 newop->op_next = newop;
6545 kid->op_sibling = sibl;
6550 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6551 if (kid->op_type == OP_CONST &&
6552 (kid->op_private & OPpCONST_BARE))
6554 OP * const newop = newGVOP(OP_GV, 0,
6555 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6556 if (!(o->op_private & 1) && /* if not unop */
6557 kid == cLISTOPo->op_last)
6558 cLISTOPo->op_last = newop;
6560 op_getmad(kid,newop,'K');
6566 else if (kid->op_type == OP_READLINE) {
6567 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6568 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6571 I32 flags = OPf_SPECIAL;
6575 /* is this op a FH constructor? */
6576 if (is_handle_constructor(o,numargs)) {
6577 const char *name = NULL;
6581 /* Set a flag to tell rv2gv to vivify
6582 * need to "prove" flag does not mean something
6583 * else already - NI-S 1999/05/07
6586 if (kid->op_type == OP_PADSV) {
6588 = PAD_COMPNAME_SV(kid->op_targ);
6589 name = SvPV_const(namesv, len);
6591 else if (kid->op_type == OP_RV2SV
6592 && kUNOP->op_first->op_type == OP_GV)
6594 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6596 len = GvNAMELEN(gv);
6598 else if (kid->op_type == OP_AELEM
6599 || kid->op_type == OP_HELEM)
6602 OP *op = ((BINOP*)kid)->op_first;
6606 const char * const a =
6607 kid->op_type == OP_AELEM ?
6609 if (((op->op_type == OP_RV2AV) ||
6610 (op->op_type == OP_RV2HV)) &&
6611 (firstop = ((UNOP*)op)->op_first) &&
6612 (firstop->op_type == OP_GV)) {
6613 /* packagevar $a[] or $h{} */
6614 GV * const gv = cGVOPx_gv(firstop);
6622 else if (op->op_type == OP_PADAV
6623 || op->op_type == OP_PADHV) {
6624 /* lexicalvar $a[] or $h{} */
6625 const char * const padname =
6626 PAD_COMPNAME_PV(op->op_targ);
6635 name = SvPV_const(tmpstr, len);
6640 name = "__ANONIO__";
6647 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6648 namesv = PAD_SVl(targ);
6649 SvUPGRADE(namesv, SVt_PV);
6651 sv_setpvn(namesv, "$", 1);
6652 sv_catpvn(namesv, name, len);
6655 kid->op_sibling = 0;
6656 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6657 kid->op_targ = targ;
6658 kid->op_private |= priv;
6660 kid->op_sibling = sibl;
6666 mod(scalar(kid), type);
6670 tokid = &kid->op_sibling;
6671 kid = kid->op_sibling;
6674 if (kid && kid->op_type != OP_STUB)
6675 return too_many_arguments(o,OP_DESC(o));
6676 o->op_private |= numargs;
6678 /* FIXME - should the numargs move as for the PERL_MAD case? */
6679 o->op_private |= numargs;
6681 return too_many_arguments(o,OP_DESC(o));
6685 else if (PL_opargs[type] & OA_DEFGV) {
6687 OP *newop = newUNOP(type, 0, newDEFSVOP());
6688 op_getmad(o,newop,'O');
6691 /* Ordering of these two is important to keep f_map.t passing. */
6693 return newUNOP(type, 0, newDEFSVOP());
6698 while (oa & OA_OPTIONAL)
6700 if (oa && oa != OA_LIST)
6701 return too_few_arguments(o,OP_DESC(o));
6707 Perl_ck_glob(pTHX_ OP *o)
6713 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6714 append_elem(OP_GLOB, o, newDEFSVOP());
6716 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6717 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6719 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6722 #if !defined(PERL_EXTERNAL_GLOB)
6723 /* XXX this can be tightened up and made more failsafe. */
6724 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6727 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6728 newSVpvs("File::Glob"), NULL, NULL, NULL);
6729 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6730 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6731 GvCV(gv) = GvCV(glob_gv);
6732 SvREFCNT_inc_void((SV*)GvCV(gv));
6733 GvIMPORTED_CV_on(gv);
6736 #endif /* PERL_EXTERNAL_GLOB */
6738 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6739 append_elem(OP_GLOB, o,
6740 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6741 o->op_type = OP_LIST;
6742 o->op_ppaddr = PL_ppaddr[OP_LIST];
6743 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6744 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6745 cLISTOPo->op_first->op_targ = 0;
6746 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6747 append_elem(OP_LIST, o,
6748 scalar(newUNOP(OP_RV2CV, 0,
6749 newGVOP(OP_GV, 0, gv)))));
6750 o = newUNOP(OP_NULL, 0, ck_subr(o));
6751 o->op_targ = OP_GLOB; /* hint at what it used to be */
6754 gv = newGVgen("main");
6756 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6762 Perl_ck_grep(pTHX_ OP *o)
6767 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6770 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6771 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6773 if (o->op_flags & OPf_STACKED) {
6776 kid = cLISTOPo->op_first->op_sibling;
6777 if (!cUNOPx(kid)->op_next)
6778 Perl_croak(aTHX_ "panic: ck_grep");
6779 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6782 NewOp(1101, gwop, 1, LOGOP);
6783 kid->op_next = (OP*)gwop;
6784 o->op_flags &= ~OPf_STACKED;
6786 kid = cLISTOPo->op_first->op_sibling;
6787 if (type == OP_MAPWHILE)
6794 kid = cLISTOPo->op_first->op_sibling;
6795 if (kid->op_type != OP_NULL)
6796 Perl_croak(aTHX_ "panic: ck_grep");
6797 kid = kUNOP->op_first;
6800 NewOp(1101, gwop, 1, LOGOP);
6801 gwop->op_type = type;
6802 gwop->op_ppaddr = PL_ppaddr[type];
6803 gwop->op_first = listkids(o);
6804 gwop->op_flags |= OPf_KIDS;
6805 gwop->op_other = LINKLIST(kid);
6806 kid->op_next = (OP*)gwop;
6807 offset = pad_findmy("$_");
6808 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6809 o->op_private = gwop->op_private = 0;
6810 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6813 o->op_private = gwop->op_private = OPpGREP_LEX;
6814 gwop->op_targ = o->op_targ = offset;
6817 kid = cLISTOPo->op_first->op_sibling;
6818 if (!kid || !kid->op_sibling)
6819 return too_few_arguments(o,OP_DESC(o));
6820 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6821 mod(kid, OP_GREPSTART);
6827 Perl_ck_index(pTHX_ OP *o)
6829 if (o->op_flags & OPf_KIDS) {
6830 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6832 kid = kid->op_sibling; /* get past "big" */
6833 if (kid && kid->op_type == OP_CONST)
6834 fbm_compile(((SVOP*)kid)->op_sv, 0);
6840 Perl_ck_lengthconst(pTHX_ OP *o)
6842 /* XXX length optimization goes here */
6847 Perl_ck_lfun(pTHX_ OP *o)
6849 const OPCODE type = o->op_type;
6850 return modkids(ck_fun(o), type);
6854 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6856 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6857 switch (cUNOPo->op_first->op_type) {
6859 /* This is needed for
6860 if (defined %stash::)
6861 to work. Do not break Tk.
6863 break; /* Globals via GV can be undef */
6865 case OP_AASSIGN: /* Is this a good idea? */
6866 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6867 "defined(@array) is deprecated");
6868 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6869 "\t(Maybe you should just omit the defined()?)\n");
6872 /* This is needed for
6873 if (defined %stash::)
6874 to work. Do not break Tk.
6876 break; /* Globals via GV can be undef */
6878 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6879 "defined(%%hash) is deprecated");
6880 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6881 "\t(Maybe you should just omit the defined()?)\n");
6892 Perl_ck_readline(pTHX_ OP *o)
6894 if (!(o->op_flags & OPf_KIDS)) {
6896 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6898 op_getmad(o,newop,'O');
6908 Perl_ck_rfun(pTHX_ OP *o)
6910 const OPCODE type = o->op_type;
6911 return refkids(ck_fun(o), type);
6915 Perl_ck_listiob(pTHX_ OP *o)
6919 kid = cLISTOPo->op_first;
6922 kid = cLISTOPo->op_first;
6924 if (kid->op_type == OP_PUSHMARK)
6925 kid = kid->op_sibling;
6926 if (kid && o->op_flags & OPf_STACKED)
6927 kid = kid->op_sibling;
6928 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6929 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6930 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6931 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6932 cLISTOPo->op_first->op_sibling = kid;
6933 cLISTOPo->op_last = kid;
6934 kid = kid->op_sibling;
6939 append_elem(o->op_type, o, newDEFSVOP());
6945 Perl_ck_smartmatch(pTHX_ OP *o)
6948 if (0 == (o->op_flags & OPf_SPECIAL)) {
6949 OP *first = cBINOPo->op_first;
6950 OP *second = first->op_sibling;
6952 /* Implicitly take a reference to an array or hash */
6953 first->op_sibling = NULL;
6954 first = cBINOPo->op_first = ref_array_or_hash(first);
6955 second = first->op_sibling = ref_array_or_hash(second);
6957 /* Implicitly take a reference to a regular expression */
6958 if (first->op_type == OP_MATCH) {
6959 first->op_type = OP_QR;
6960 first->op_ppaddr = PL_ppaddr[OP_QR];
6962 if (second->op_type == OP_MATCH) {
6963 second->op_type = OP_QR;
6964 second->op_ppaddr = PL_ppaddr[OP_QR];
6973 Perl_ck_sassign(pTHX_ OP *o)
6975 OP * const kid = cLISTOPo->op_first;
6976 /* has a disposable target? */
6977 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6978 && !(kid->op_flags & OPf_STACKED)
6979 /* Cannot steal the second time! */
6980 && !(kid->op_private & OPpTARGET_MY))
6982 OP * const kkid = kid->op_sibling;
6984 /* Can just relocate the target. */
6985 if (kkid && kkid->op_type == OP_PADSV
6986 && !(kkid->op_private & OPpLVAL_INTRO))
6988 kid->op_targ = kkid->op_targ;
6990 /* Now we do not need PADSV and SASSIGN. */
6991 kid->op_sibling = o->op_sibling; /* NULL */
6992 cLISTOPo->op_first = NULL;
6994 op_getmad(o,kid,'O');
6995 op_getmad(kkid,kid,'M');
7000 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7004 if (kid->op_sibling) {
7005 OP *kkid = kid->op_sibling;
7006 if (kkid->op_type == OP_PADSV
7007 && (kkid->op_private & OPpLVAL_INTRO)
7008 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7009 o->op_private |= OPpASSIGN_STATE;
7010 /* hijacking PADSTALE for uninitialized state variables */
7011 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
7018 Perl_ck_match(pTHX_ OP *o)
7021 if (o->op_type != OP_QR && PL_compcv) {
7022 const PADOFFSET offset = pad_findmy("$_");
7023 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7024 o->op_targ = offset;
7025 o->op_private |= OPpTARGET_MY;
7028 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7029 o->op_private |= OPpRUNTIME;
7034 Perl_ck_method(pTHX_ OP *o)
7036 OP * const kid = cUNOPo->op_first;
7037 if (kid->op_type == OP_CONST) {
7038 SV* sv = kSVOP->op_sv;
7039 const char * const method = SvPVX_const(sv);
7040 if (!(strchr(method, ':') || strchr(method, '\''))) {
7042 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7043 sv = newSVpvn_share(method, SvCUR(sv), 0);
7046 kSVOP->op_sv = NULL;
7048 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7050 op_getmad(o,cmop,'O');
7061 Perl_ck_null(pTHX_ OP *o)
7063 PERL_UNUSED_CONTEXT;
7068 Perl_ck_open(pTHX_ OP *o)
7071 HV * const table = GvHV(PL_hintgv);
7073 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7075 const I32 mode = mode_from_discipline(*svp);
7076 if (mode & O_BINARY)
7077 o->op_private |= OPpOPEN_IN_RAW;
7078 else if (mode & O_TEXT)
7079 o->op_private |= OPpOPEN_IN_CRLF;
7082 svp = hv_fetchs(table, "open_OUT", FALSE);
7084 const I32 mode = mode_from_discipline(*svp);
7085 if (mode & O_BINARY)
7086 o->op_private |= OPpOPEN_OUT_RAW;
7087 else if (mode & O_TEXT)
7088 o->op_private |= OPpOPEN_OUT_CRLF;
7091 if (o->op_type == OP_BACKTICK) {
7092 if (!(o->op_flags & OPf_KIDS)) {
7093 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7095 op_getmad(o,newop,'O');
7104 /* In case of three-arg dup open remove strictness
7105 * from the last arg if it is a bareword. */
7106 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7107 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7111 if ((last->op_type == OP_CONST) && /* The bareword. */
7112 (last->op_private & OPpCONST_BARE) &&
7113 (last->op_private & OPpCONST_STRICT) &&
7114 (oa = first->op_sibling) && /* The fh. */
7115 (oa = oa->op_sibling) && /* The mode. */
7116 (oa->op_type == OP_CONST) &&
7117 SvPOK(((SVOP*)oa)->op_sv) &&
7118 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7119 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7120 (last == oa->op_sibling)) /* The bareword. */
7121 last->op_private &= ~OPpCONST_STRICT;
7127 Perl_ck_repeat(pTHX_ OP *o)
7129 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7130 o->op_private |= OPpREPEAT_DOLIST;
7131 cBINOPo->op_first = force_list(cBINOPo->op_first);
7139 Perl_ck_require(pTHX_ OP *o)
7144 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7145 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7147 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7148 SV * const sv = kid->op_sv;
7149 U32 was_readonly = SvREADONLY(sv);
7154 sv_force_normal_flags(sv, 0);
7155 assert(!SvREADONLY(sv));
7162 for (s = SvPVX(sv); *s; s++) {
7163 if (*s == ':' && s[1] == ':') {
7164 const STRLEN len = strlen(s+2)+1;
7166 Move(s+2, s+1, len, char);
7167 SvCUR_set(sv, SvCUR(sv) - 1);
7170 sv_catpvs(sv, ".pm");
7171 SvFLAGS(sv) |= was_readonly;
7175 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7176 /* handle override, if any */
7177 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7178 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7179 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7180 gv = gvp ? *gvp : NULL;
7184 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7185 OP * const kid = cUNOPo->op_first;
7188 cUNOPo->op_first = 0;
7192 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7193 append_elem(OP_LIST, kid,
7194 scalar(newUNOP(OP_RV2CV, 0,
7197 op_getmad(o,newop,'O');
7205 Perl_ck_return(pTHX_ OP *o)
7208 if (CvLVALUE(PL_compcv)) {
7210 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7211 mod(kid, OP_LEAVESUBLV);
7217 Perl_ck_select(pTHX_ OP *o)
7221 if (o->op_flags & OPf_KIDS) {
7222 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7223 if (kid && kid->op_sibling) {
7224 o->op_type = OP_SSELECT;
7225 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7227 return fold_constants(o);
7231 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7232 if (kid && kid->op_type == OP_RV2GV)
7233 kid->op_private &= ~HINT_STRICT_REFS;
7238 Perl_ck_shift(pTHX_ OP *o)
7241 const I32 type = o->op_type;
7243 if (!(o->op_flags & OPf_KIDS)) {
7245 /* FIXME - this can be refactored to reduce code in #ifdefs */
7247 OP * const oldo = o;
7251 argop = newUNOP(OP_RV2AV, 0,
7252 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7254 o = newUNOP(type, 0, scalar(argop));
7255 op_getmad(oldo,o,'O');
7258 return newUNOP(type, 0, scalar(argop));
7261 return scalar(modkids(ck_fun(o), type));
7265 Perl_ck_sort(pTHX_ OP *o)
7270 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7271 HV * const hinthv = GvHV(PL_hintgv);
7273 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7275 const I32 sorthints = (I32)SvIV(*svp);
7276 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7277 o->op_private |= OPpSORT_QSORT;
7278 if ((sorthints & HINT_SORT_STABLE) != 0)
7279 o->op_private |= OPpSORT_STABLE;
7284 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7286 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7287 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7289 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7291 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7293 if (kid->op_type == OP_SCOPE) {
7297 else if (kid->op_type == OP_LEAVE) {
7298 if (o->op_type == OP_SORT) {
7299 op_null(kid); /* wipe out leave */
7302 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7303 if (k->op_next == kid)
7305 /* don't descend into loops */
7306 else if (k->op_type == OP_ENTERLOOP
7307 || k->op_type == OP_ENTERITER)
7309 k = cLOOPx(k)->op_lastop;
7314 kid->op_next = 0; /* just disconnect the leave */
7315 k = kLISTOP->op_first;
7320 if (o->op_type == OP_SORT) {
7321 /* provide scalar context for comparison function/block */
7327 o->op_flags |= OPf_SPECIAL;
7329 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7332 firstkid = firstkid->op_sibling;
7335 /* provide list context for arguments */
7336 if (o->op_type == OP_SORT)
7343 S_simplify_sort(pTHX_ OP *o)
7346 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7351 if (!(o->op_flags & OPf_STACKED))
7353 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7354 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7355 kid = kUNOP->op_first; /* get past null */
7356 if (kid->op_type != OP_SCOPE)
7358 kid = kLISTOP->op_last; /* get past scope */
7359 switch(kid->op_type) {
7367 k = kid; /* remember this node*/
7368 if (kBINOP->op_first->op_type != OP_RV2SV)
7370 kid = kBINOP->op_first; /* get past cmp */
7371 if (kUNOP->op_first->op_type != OP_GV)
7373 kid = kUNOP->op_first; /* get past rv2sv */
7375 if (GvSTASH(gv) != PL_curstash)
7377 gvname = GvNAME(gv);
7378 if (*gvname == 'a' && gvname[1] == '\0')
7380 else if (*gvname == 'b' && gvname[1] == '\0')
7385 kid = k; /* back to cmp */
7386 if (kBINOP->op_last->op_type != OP_RV2SV)
7388 kid = kBINOP->op_last; /* down to 2nd arg */
7389 if (kUNOP->op_first->op_type != OP_GV)
7391 kid = kUNOP->op_first; /* get past rv2sv */
7393 if (GvSTASH(gv) != PL_curstash)
7395 gvname = GvNAME(gv);
7397 ? !(*gvname == 'a' && gvname[1] == '\0')
7398 : !(*gvname == 'b' && gvname[1] == '\0'))
7400 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7402 o->op_private |= OPpSORT_DESCEND;
7403 if (k->op_type == OP_NCMP)
7404 o->op_private |= OPpSORT_NUMERIC;
7405 if (k->op_type == OP_I_NCMP)
7406 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7407 kid = cLISTOPo->op_first->op_sibling;
7408 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7410 op_getmad(kid,o,'S'); /* then delete it */
7412 op_free(kid); /* then delete it */
7417 Perl_ck_split(pTHX_ OP *o)
7422 if (o->op_flags & OPf_STACKED)
7423 return no_fh_allowed(o);
7425 kid = cLISTOPo->op_first;
7426 if (kid->op_type != OP_NULL)
7427 Perl_croak(aTHX_ "panic: ck_split");
7428 kid = kid->op_sibling;
7429 op_free(cLISTOPo->op_first);
7430 cLISTOPo->op_first = kid;
7432 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7433 cLISTOPo->op_last = kid; /* There was only one element previously */
7436 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7437 OP * const sibl = kid->op_sibling;
7438 kid->op_sibling = 0;
7439 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7440 if (cLISTOPo->op_first == cLISTOPo->op_last)
7441 cLISTOPo->op_last = kid;
7442 cLISTOPo->op_first = kid;
7443 kid->op_sibling = sibl;
7446 kid->op_type = OP_PUSHRE;
7447 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7449 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7450 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7451 "Use of /g modifier is meaningless in split");
7454 if (!kid->op_sibling)
7455 append_elem(OP_SPLIT, o, newDEFSVOP());
7457 kid = kid->op_sibling;
7460 if (!kid->op_sibling)
7461 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7462 assert(kid->op_sibling);
7464 kid = kid->op_sibling;
7467 if (kid->op_sibling)
7468 return too_many_arguments(o,OP_DESC(o));
7474 Perl_ck_join(pTHX_ OP *o)
7476 const OP * const kid = cLISTOPo->op_first->op_sibling;
7477 if (kid && kid->op_type == OP_MATCH) {
7478 if (ckWARN(WARN_SYNTAX)) {
7479 const REGEXP *re = PM_GETRE(kPMOP);
7480 const char *pmstr = re ? re->precomp : "STRING";
7481 const STRLEN len = re ? re->prelen : 6;
7482 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7483 "/%.*s/ should probably be written as \"%.*s\"",
7484 (int)len, pmstr, (int)len, pmstr);
7491 Perl_ck_subr(pTHX_ OP *o)
7494 OP *prev = ((cUNOPo->op_first->op_sibling)
7495 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7496 OP *o2 = prev->op_sibling;
7498 const char *proto = NULL;
7499 const char *proto_end = NULL;
7504 I32 contextclass = 0;
7505 const char *e = NULL;
7508 o->op_private |= OPpENTERSUB_HASTARG;
7509 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7510 if (cvop->op_type == OP_RV2CV) {
7512 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7513 op_null(cvop); /* disable rv2cv */
7514 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7515 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7516 GV *gv = cGVOPx_gv(tmpop);
7519 tmpop->op_private |= OPpEARLY_CV;
7523 namegv = CvANON(cv) ? gv : CvGV(cv);
7524 proto = SvPV((SV*)cv, len);
7525 proto_end = proto + len;
7527 if (CvASSERTION(cv)) {
7528 U32 asserthints = 0;
7529 HV *const hinthv = GvHV(PL_hintgv);
7531 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7533 asserthints = SvUV(*svp);
7535 if (asserthints & HINT_ASSERTING) {
7536 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7537 o->op_private |= OPpENTERSUB_DB;
7541 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7542 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7543 "Impossible to activate assertion call");
7550 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7551 if (o2->op_type == OP_CONST)
7552 o2->op_private &= ~OPpCONST_STRICT;
7553 else if (o2->op_type == OP_LIST) {
7554 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7555 if (sib && sib->op_type == OP_CONST)
7556 sib->op_private &= ~OPpCONST_STRICT;
7559 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7560 if (PERLDB_SUB && PL_curstash != PL_debstash)
7561 o->op_private |= OPpENTERSUB_DB;
7562 while (o2 != cvop) {
7564 if (PL_madskills && o2->op_type == OP_STUB) {
7565 o2 = o2->op_sibling;
7568 if (PL_madskills && o2->op_type == OP_NULL)
7569 o3 = ((UNOP*)o2)->op_first;
7573 if (proto >= proto_end)
7574 return too_many_arguments(o, gv_ename(namegv));
7582 /* _ must be at the end */
7583 if (proto[1] && proto[1] != ';')
7598 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7600 arg == 1 ? "block or sub {}" : "sub {}",
7601 gv_ename(namegv), o3);
7604 /* '*' allows any scalar type, including bareword */
7607 if (o3->op_type == OP_RV2GV)
7608 goto wrapref; /* autoconvert GLOB -> GLOBref */
7609 else if (o3->op_type == OP_CONST)
7610 o3->op_private &= ~OPpCONST_STRICT;
7611 else if (o3->op_type == OP_ENTERSUB) {
7612 /* accidental subroutine, revert to bareword */
7613 OP *gvop = ((UNOP*)o3)->op_first;
7614 if (gvop && gvop->op_type == OP_NULL) {
7615 gvop = ((UNOP*)gvop)->op_first;
7617 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7620 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7621 (gvop = ((UNOP*)gvop)->op_first) &&
7622 gvop->op_type == OP_GV)
7624 GV * const gv = cGVOPx_gv(gvop);
7625 OP * const sibling = o2->op_sibling;
7626 SV * const n = newSVpvs("");
7628 OP * const oldo2 = o2;
7632 gv_fullname4(n, gv, "", FALSE);
7633 o2 = newSVOP(OP_CONST, 0, n);
7634 op_getmad(oldo2,o2,'O');
7635 prev->op_sibling = o2;
7636 o2->op_sibling = sibling;
7652 if (contextclass++ == 0) {
7653 e = strchr(proto, ']');
7654 if (!e || e == proto)
7663 const char *p = proto;
7664 const char *const end = proto;
7666 while (*--p != '[');
7667 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7669 gv_ename(namegv), o3);
7674 if (o3->op_type == OP_RV2GV)
7677 bad_type(arg, "symbol", gv_ename(namegv), o3);
7680 if (o3->op_type == OP_ENTERSUB)
7683 bad_type(arg, "subroutine entry", gv_ename(namegv),
7687 if (o3->op_type == OP_RV2SV ||
7688 o3->op_type == OP_PADSV ||
7689 o3->op_type == OP_HELEM ||
7690 o3->op_type == OP_AELEM)
7693 bad_type(arg, "scalar", gv_ename(namegv), o3);
7696 if (o3->op_type == OP_RV2AV ||
7697 o3->op_type == OP_PADAV)
7700 bad_type(arg, "array", gv_ename(namegv), o3);
7703 if (o3->op_type == OP_RV2HV ||
7704 o3->op_type == OP_PADHV)
7707 bad_type(arg, "hash", gv_ename(namegv), o3);
7712 OP* const sib = kid->op_sibling;
7713 kid->op_sibling = 0;
7714 o2 = newUNOP(OP_REFGEN, 0, kid);
7715 o2->op_sibling = sib;
7716 prev->op_sibling = o2;
7718 if (contextclass && e) {
7733 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7734 gv_ename(namegv), SVfARG(cv));
7739 mod(o2, OP_ENTERSUB);
7741 o2 = o2->op_sibling;
7743 if (o2 == cvop && proto && *proto == '_') {
7744 /* generate an access to $_ */
7746 o2->op_sibling = prev->op_sibling;
7747 prev->op_sibling = o2; /* instead of cvop */
7749 if (proto && !optional && proto_end > proto &&
7750 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7751 return too_few_arguments(o, gv_ename(namegv));
7754 OP * const oldo = o;
7758 o=newSVOP(OP_CONST, 0, newSViv(0));
7759 op_getmad(oldo,o,'O');
7765 Perl_ck_svconst(pTHX_ OP *o)
7767 PERL_UNUSED_CONTEXT;
7768 SvREADONLY_on(cSVOPo->op_sv);
7773 Perl_ck_chdir(pTHX_ OP *o)
7775 if (o->op_flags & OPf_KIDS) {
7776 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7778 if (kid && kid->op_type == OP_CONST &&
7779 (kid->op_private & OPpCONST_BARE))
7781 o->op_flags |= OPf_SPECIAL;
7782 kid->op_private &= ~OPpCONST_STRICT;
7789 Perl_ck_trunc(pTHX_ OP *o)
7791 if (o->op_flags & OPf_KIDS) {
7792 SVOP *kid = (SVOP*)cUNOPo->op_first;
7794 if (kid->op_type == OP_NULL)
7795 kid = (SVOP*)kid->op_sibling;
7796 if (kid && kid->op_type == OP_CONST &&
7797 (kid->op_private & OPpCONST_BARE))
7799 o->op_flags |= OPf_SPECIAL;
7800 kid->op_private &= ~OPpCONST_STRICT;
7807 Perl_ck_unpack(pTHX_ OP *o)
7809 OP *kid = cLISTOPo->op_first;
7810 if (kid->op_sibling) {
7811 kid = kid->op_sibling;
7812 if (!kid->op_sibling)
7813 kid->op_sibling = newDEFSVOP();
7819 Perl_ck_substr(pTHX_ OP *o)
7822 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7823 OP *kid = cLISTOPo->op_first;
7825 if (kid->op_type == OP_NULL)
7826 kid = kid->op_sibling;
7828 kid->op_flags |= OPf_MOD;
7834 /* A peephole optimizer. We visit the ops in the order they're to execute.
7835 * See the comments at the top of this file for more details about when
7836 * peep() is called */
7839 Perl_peep(pTHX_ register OP *o)
7842 register OP* oldop = NULL;
7844 if (!o || o->op_opt)
7848 SAVEVPTR(PL_curcop);
7849 for (; o; o = o->op_next) {
7852 /* By default, this op has now been optimised. A couple of cases below
7853 clear this again. */
7856 switch (o->op_type) {
7860 PL_curcop = ((COP*)o); /* for warnings */
7864 if (cSVOPo->op_private & OPpCONST_STRICT)
7865 no_bareword_allowed(o);
7867 case OP_METHOD_NAMED:
7868 /* Relocate sv to the pad for thread safety.
7869 * Despite being a "constant", the SV is written to,
7870 * for reference counts, sv_upgrade() etc. */
7872 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7873 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7874 /* If op_sv is already a PADTMP then it is being used by
7875 * some pad, so make a copy. */
7876 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7877 SvREADONLY_on(PAD_SVl(ix));
7878 SvREFCNT_dec(cSVOPo->op_sv);
7880 else if (o->op_type == OP_CONST
7881 && cSVOPo->op_sv == &PL_sv_undef) {
7882 /* PL_sv_undef is hack - it's unsafe to store it in the
7883 AV that is the pad, because av_fetch treats values of
7884 PL_sv_undef as a "free" AV entry and will merrily
7885 replace them with a new SV, causing pad_alloc to think
7886 that this pad slot is free. (When, clearly, it is not)
7888 SvOK_off(PAD_SVl(ix));
7889 SvPADTMP_on(PAD_SVl(ix));
7890 SvREADONLY_on(PAD_SVl(ix));
7893 SvREFCNT_dec(PAD_SVl(ix));
7894 SvPADTMP_on(cSVOPo->op_sv);
7895 PAD_SETSV(ix, cSVOPo->op_sv);
7896 /* XXX I don't know how this isn't readonly already. */
7897 SvREADONLY_on(PAD_SVl(ix));
7899 cSVOPo->op_sv = NULL;
7906 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7907 if (o->op_next->op_private & OPpTARGET_MY) {
7908 if (o->op_flags & OPf_STACKED) /* chained concats */
7909 break; /* ignore_optimization */
7911 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7912 o->op_targ = o->op_next->op_targ;
7913 o->op_next->op_targ = 0;
7914 o->op_private |= OPpTARGET_MY;
7917 op_null(o->op_next);
7921 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7922 break; /* Scalar stub must produce undef. List stub is noop */
7926 if (o->op_targ == OP_NEXTSTATE
7927 || o->op_targ == OP_DBSTATE
7928 || o->op_targ == OP_SETSTATE)
7930 PL_curcop = ((COP*)o);
7932 /* XXX: We avoid setting op_seq here to prevent later calls
7933 to peep() from mistakenly concluding that optimisation
7934 has already occurred. This doesn't fix the real problem,
7935 though (See 20010220.007). AMS 20010719 */
7936 /* op_seq functionality is now replaced by op_opt */
7943 if (oldop && o->op_next) {
7944 oldop->op_next = o->op_next;
7952 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7953 OP* const pop = (o->op_type == OP_PADAV) ?
7954 o->op_next : o->op_next->op_next;
7956 if (pop && pop->op_type == OP_CONST &&
7957 ((PL_op = pop->op_next)) &&
7958 pop->op_next->op_type == OP_AELEM &&
7959 !(pop->op_next->op_private &
7960 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7961 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7966 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7967 no_bareword_allowed(pop);
7968 if (o->op_type == OP_GV)
7969 op_null(o->op_next);
7970 op_null(pop->op_next);
7972 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7973 o->op_next = pop->op_next->op_next;
7974 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7975 o->op_private = (U8)i;
7976 if (o->op_type == OP_GV) {
7981 o->op_flags |= OPf_SPECIAL;
7982 o->op_type = OP_AELEMFAST;
7987 if (o->op_next->op_type == OP_RV2SV) {
7988 if (!(o->op_next->op_private & OPpDEREF)) {
7989 op_null(o->op_next);
7990 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7992 o->op_next = o->op_next->op_next;
7993 o->op_type = OP_GVSV;
7994 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7997 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7998 GV * const gv = cGVOPo_gv;
7999 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8000 /* XXX could check prototype here instead of just carping */
8001 SV * const sv = sv_newmortal();
8002 gv_efullname3(sv, gv, NULL);
8003 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8004 "%"SVf"() called too early to check prototype",
8008 else if (o->op_next->op_type == OP_READLINE
8009 && o->op_next->op_next->op_type == OP_CONCAT
8010 && (o->op_next->op_next->op_flags & OPf_STACKED))
8012 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8013 o->op_type = OP_RCATLINE;
8014 o->op_flags |= OPf_STACKED;
8015 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8016 op_null(o->op_next->op_next);
8017 op_null(o->op_next);
8032 while (cLOGOP->op_other->op_type == OP_NULL)
8033 cLOGOP->op_other = cLOGOP->op_other->op_next;
8034 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8039 while (cLOOP->op_redoop->op_type == OP_NULL)
8040 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8041 peep(cLOOP->op_redoop);
8042 while (cLOOP->op_nextop->op_type == OP_NULL)
8043 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8044 peep(cLOOP->op_nextop);
8045 while (cLOOP->op_lastop->op_type == OP_NULL)
8046 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8047 peep(cLOOP->op_lastop);
8051 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8052 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8053 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8054 cPMOP->op_pmstashstartu.op_pmreplstart
8055 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8056 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8060 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8061 && ckWARN(WARN_SYNTAX))
8063 if (o->op_next->op_sibling) {
8064 const OPCODE type = o->op_next->op_sibling->op_type;
8065 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8066 const line_t oldline = CopLINE(PL_curcop);
8067 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8068 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8069 "Statement unlikely to be reached");
8070 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8071 "\t(Maybe you meant system() when you said exec()?)\n");
8072 CopLINE_set(PL_curcop, oldline);
8083 const char *key = NULL;
8086 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8089 /* Make the CONST have a shared SV */
8090 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8091 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8092 key = SvPV_const(sv, keylen);
8093 lexname = newSVpvn_share(key,
8094 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8100 if ((o->op_private & (OPpLVAL_INTRO)))
8103 rop = (UNOP*)((BINOP*)o)->op_first;
8104 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8106 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8107 if (!SvPAD_TYPED(lexname))
8109 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8110 if (!fields || !GvHV(*fields))
8112 key = SvPV_const(*svp, keylen);
8113 if (!hv_fetch(GvHV(*fields), key,
8114 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8116 Perl_croak(aTHX_ "No such class field \"%s\" "
8117 "in variable %s of type %s",
8118 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8131 SVOP *first_key_op, *key_op;
8133 if ((o->op_private & (OPpLVAL_INTRO))
8134 /* I bet there's always a pushmark... */
8135 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8136 /* hmmm, no optimization if list contains only one key. */
8138 rop = (UNOP*)((LISTOP*)o)->op_last;
8139 if (rop->op_type != OP_RV2HV)
8141 if (rop->op_first->op_type == OP_PADSV)
8142 /* @$hash{qw(keys here)} */
8143 rop = (UNOP*)rop->op_first;
8145 /* @{$hash}{qw(keys here)} */
8146 if (rop->op_first->op_type == OP_SCOPE
8147 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8149 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8155 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8156 if (!SvPAD_TYPED(lexname))
8158 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8159 if (!fields || !GvHV(*fields))
8161 /* Again guessing that the pushmark can be jumped over.... */
8162 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8163 ->op_first->op_sibling;
8164 for (key_op = first_key_op; key_op;
8165 key_op = (SVOP*)key_op->op_sibling) {
8166 if (key_op->op_type != OP_CONST)
8168 svp = cSVOPx_svp(key_op);
8169 key = SvPV_const(*svp, keylen);
8170 if (!hv_fetch(GvHV(*fields), key,
8171 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8173 Perl_croak(aTHX_ "No such class field \"%s\" "
8174 "in variable %s of type %s",
8175 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8182 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8186 /* check that RHS of sort is a single plain array */
8187 OP *oright = cUNOPo->op_first;
8188 if (!oright || oright->op_type != OP_PUSHMARK)
8191 /* reverse sort ... can be optimised. */
8192 if (!cUNOPo->op_sibling) {
8193 /* Nothing follows us on the list. */
8194 OP * const reverse = o->op_next;
8196 if (reverse->op_type == OP_REVERSE &&
8197 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8198 OP * const pushmark = cUNOPx(reverse)->op_first;
8199 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8200 && (cUNOPx(pushmark)->op_sibling == o)) {
8201 /* reverse -> pushmark -> sort */
8202 o->op_private |= OPpSORT_REVERSE;
8204 pushmark->op_next = oright->op_next;
8210 /* make @a = sort @a act in-place */
8212 oright = cUNOPx(oright)->op_sibling;
8215 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8216 oright = cUNOPx(oright)->op_sibling;
8220 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8221 || oright->op_next != o
8222 || (oright->op_private & OPpLVAL_INTRO)
8226 /* o2 follows the chain of op_nexts through the LHS of the
8227 * assign (if any) to the aassign op itself */
8229 if (!o2 || o2->op_type != OP_NULL)
8232 if (!o2 || o2->op_type != OP_PUSHMARK)
8235 if (o2 && o2->op_type == OP_GV)
8238 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8239 || (o2->op_private & OPpLVAL_INTRO)
8244 if (!o2 || o2->op_type != OP_NULL)
8247 if (!o2 || o2->op_type != OP_AASSIGN
8248 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8251 /* check that the sort is the first arg on RHS of assign */
8253 o2 = cUNOPx(o2)->op_first;
8254 if (!o2 || o2->op_type != OP_NULL)
8256 o2 = cUNOPx(o2)->op_first;
8257 if (!o2 || o2->op_type != OP_PUSHMARK)
8259 if (o2->op_sibling != o)
8262 /* check the array is the same on both sides */
8263 if (oleft->op_type == OP_RV2AV) {
8264 if (oright->op_type != OP_RV2AV
8265 || !cUNOPx(oright)->op_first
8266 || cUNOPx(oright)->op_first->op_type != OP_GV
8267 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8268 cGVOPx_gv(cUNOPx(oright)->op_first)
8272 else if (oright->op_type != OP_PADAV
8273 || oright->op_targ != oleft->op_targ
8277 /* transfer MODishness etc from LHS arg to RHS arg */
8278 oright->op_flags = oleft->op_flags;
8279 o->op_private |= OPpSORT_INPLACE;
8281 /* excise push->gv->rv2av->null->aassign */
8282 o2 = o->op_next->op_next;
8283 op_null(o2); /* PUSHMARK */
8285 if (o2->op_type == OP_GV) {
8286 op_null(o2); /* GV */
8289 op_null(o2); /* RV2AV or PADAV */
8290 o2 = o2->op_next->op_next;
8291 op_null(o2); /* AASSIGN */
8293 o->op_next = o2->op_next;
8299 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8301 LISTOP *enter, *exlist;
8303 enter = (LISTOP *) o->op_next;
8306 if (enter->op_type == OP_NULL) {
8307 enter = (LISTOP *) enter->op_next;
8311 /* for $a (...) will have OP_GV then OP_RV2GV here.
8312 for (...) just has an OP_GV. */
8313 if (enter->op_type == OP_GV) {
8314 gvop = (OP *) enter;
8315 enter = (LISTOP *) enter->op_next;
8318 if (enter->op_type == OP_RV2GV) {
8319 enter = (LISTOP *) enter->op_next;
8325 if (enter->op_type != OP_ENTERITER)
8328 iter = enter->op_next;
8329 if (!iter || iter->op_type != OP_ITER)
8332 expushmark = enter->op_first;
8333 if (!expushmark || expushmark->op_type != OP_NULL
8334 || expushmark->op_targ != OP_PUSHMARK)
8337 exlist = (LISTOP *) expushmark->op_sibling;
8338 if (!exlist || exlist->op_type != OP_NULL
8339 || exlist->op_targ != OP_LIST)
8342 if (exlist->op_last != o) {
8343 /* Mmm. Was expecting to point back to this op. */
8346 theirmark = exlist->op_first;
8347 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8350 if (theirmark->op_sibling != o) {
8351 /* There's something between the mark and the reverse, eg
8352 for (1, reverse (...))
8357 ourmark = ((LISTOP *)o)->op_first;
8358 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8361 ourlast = ((LISTOP *)o)->op_last;
8362 if (!ourlast || ourlast->op_next != o)
8365 rv2av = ourmark->op_sibling;
8366 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8367 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8368 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8369 /* We're just reversing a single array. */
8370 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8371 enter->op_flags |= OPf_STACKED;
8374 /* We don't have control over who points to theirmark, so sacrifice
8376 theirmark->op_next = ourmark->op_next;
8377 theirmark->op_flags = ourmark->op_flags;
8378 ourlast->op_next = gvop ? gvop : (OP *) enter;
8381 enter->op_private |= OPpITER_REVERSED;
8382 iter->op_private |= OPpITER_REVERSED;
8389 UNOP *refgen, *rv2cv;
8392 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8395 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8398 rv2gv = ((BINOP *)o)->op_last;
8399 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8402 refgen = (UNOP *)((BINOP *)o)->op_first;
8404 if (!refgen || refgen->op_type != OP_REFGEN)
8407 exlist = (LISTOP *)refgen->op_first;
8408 if (!exlist || exlist->op_type != OP_NULL
8409 || exlist->op_targ != OP_LIST)
8412 if (exlist->op_first->op_type != OP_PUSHMARK)
8415 rv2cv = (UNOP*)exlist->op_last;
8417 if (rv2cv->op_type != OP_RV2CV)
8420 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8421 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8422 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8424 o->op_private |= OPpASSIGN_CV_TO_GV;
8425 rv2gv->op_private |= OPpDONT_INIT_GV;
8426 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8434 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8435 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8445 Perl_custom_op_name(pTHX_ const OP* o)
8448 const IV index = PTR2IV(o->op_ppaddr);
8452 if (!PL_custom_op_names) /* This probably shouldn't happen */
8453 return (char *)PL_op_name[OP_CUSTOM];
8455 keysv = sv_2mortal(newSViv(index));
8457 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8459 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8461 return SvPV_nolen(HeVAL(he));
8465 Perl_custom_op_desc(pTHX_ const OP* o)
8468 const IV index = PTR2IV(o->op_ppaddr);
8472 if (!PL_custom_op_descs)
8473 return (char *)PL_op_desc[OP_CUSTOM];
8475 keysv = sv_2mortal(newSViv(index));
8477 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8479 return (char *)PL_op_desc[OP_CUSTOM];
8481 return SvPV_nolen(HeVAL(he));
8486 /* Efficient sub that returns a constant scalar value. */
8488 const_sv_xsub(pTHX_ CV* cv)
8495 Perl_croak(aTHX_ "usage: %s::%s()",
8496 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8500 ST(0) = (SV*)XSANY.any_ptr;
8506 * c-indentation-style: bsd
8508 * indent-tabs-mode: t
8511 * ex: set ts=8 sts=4 sw=4 noet: