3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifdef PERL_DEBUG_READONLY_OPS
108 # define PERL_SLAB_SIZE 4096
109 # include <sys/mman.h>
112 #ifndef PERL_SLAB_SIZE
113 #define PERL_SLAB_SIZE 2048
117 Perl_Slab_Alloc(pTHX_ size_t sz)
120 * To make incrementing use count easy PL_OpSlab is an I32 *
121 * To make inserting the link to slab PL_OpPtr is I32 **
122 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
123 * Add an overhead for pointer to slab and round up as a number of pointers
125 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
126 if ((PL_OpSpace -= sz) < 0) {
127 #ifdef PERL_DEBUG_READONLY_OPS
128 /* We need to allocate chunk by chunk so that we can control the VM
130 PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
131 MAP_ANON|MAP_PRIVATE, -1, 0);
133 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
134 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
136 if(PL_OpPtr == MAP_FAILED) {
137 perror("mmap failed");
142 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
147 /* We reserve the 0'th I32 sized chunk as a use count */
148 PL_OpSlab = (I32 *) PL_OpPtr;
149 /* Reduce size by the use count word, and by the size we need.
150 * Latter is to mimic the '-=' in the if() above
152 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
153 /* Allocation pointer starts at the top.
154 Theory: because we build leaves before trunk allocating at end
155 means that at run time access is cache friendly upward
157 PL_OpPtr += PERL_SLAB_SIZE;
159 #ifdef PERL_DEBUG_READONLY_OPS
160 /* We remember this slab. */
161 /* This implementation isn't efficient, but it is simple. */
162 PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
163 PL_slabs[PL_slab_count++] = PL_OpSlab;
164 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
167 assert( PL_OpSpace >= 0 );
168 /* Move the allocation pointer down */
170 assert( PL_OpPtr > (I32 **) PL_OpSlab );
171 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
172 (*PL_OpSlab)++; /* Increment use count of slab */
173 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
174 assert( *PL_OpSlab > 0 );
175 return (void *)(PL_OpPtr + 1);
178 #ifdef PERL_DEBUG_READONLY_OPS
180 Perl_pending_Slabs_to_ro(pTHX) {
181 /* Turn all the allocated op slabs read only. */
182 U32 count = PL_slab_count;
183 I32 **const slabs = PL_slabs;
185 /* Reset the array of pending OP slabs, as we're about to turn this lot
186 read only. Also, do it ahead of the loop in case the warn triggers,
187 and a warn handler has an eval */
192 /* Force a new slab for any further allocation. */
196 void *const start = slabs[count];
197 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
198 if(mprotect(start, size, PROT_READ)) {
199 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
200 start, (unsigned long) size, errno);
208 S_Slab_to_rw(pTHX_ void *op)
210 I32 * const * const ptr = (I32 **) op;
211 I32 * const slab = ptr[-1];
212 assert( ptr-1 > (I32 **) slab );
213 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
215 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
216 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
217 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
222 Perl_op_refcnt_inc(pTHX_ OP *o)
233 Perl_op_refcnt_dec(pTHX_ OP *o)
239 # define Slab_to_rw(op)
243 Perl_Slab_Free(pTHX_ void *op)
245 I32 * const * const ptr = (I32 **) op;
246 I32 * const slab = ptr[-1];
247 assert( ptr-1 > (I32 **) slab );
248 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
251 if (--(*slab) == 0) {
253 # define PerlMemShared PerlMem
256 #ifdef PERL_DEBUG_READONLY_OPS
257 U32 count = PL_slab_count;
258 /* Need to remove this slab from our list of slabs */
261 if (PL_slabs[count] == slab) {
262 /* Found it. Move the entry at the end to overwrite it. */
263 DEBUG_m(PerlIO_printf(Perl_debug_log,
264 "Deallocate %p by moving %p from %lu to %lu\n",
266 PL_slabs[PL_slab_count - 1],
267 PL_slab_count, count));
268 PL_slabs[count] = PL_slabs[--PL_slab_count];
269 /* Could realloc smaller at this point, but probably not
271 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
272 perror("munmap failed");
280 PerlMemShared_free(slab);
282 if (slab == PL_OpSlab) {
289 * In the following definition, the ", (OP*)0" is just to make the compiler
290 * think the expression is of the right type: croak actually does a Siglongjmp.
292 #define CHECKOP(type,o) \
293 ((PL_op_mask && PL_op_mask[type]) \
294 ? ( op_free((OP*)o), \
295 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
297 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
299 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
302 S_gv_ename(pTHX_ GV *gv)
304 SV* const tmpsv = sv_newmortal();
305 gv_efullname3(tmpsv, gv, NULL);
306 return SvPV_nolen_const(tmpsv);
310 S_no_fh_allowed(pTHX_ OP *o)
312 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
318 S_too_few_arguments(pTHX_ OP *o, const char *name)
320 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
325 S_too_many_arguments(pTHX_ OP *o, const char *name)
327 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
332 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
334 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
335 (int)n, name, t, OP_DESC(kid)));
339 S_no_bareword_allowed(pTHX_ const OP *o)
342 return; /* various ok barewords are hidden in extra OP_NULL */
343 qerror(Perl_mess(aTHX_
344 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
348 /* "register" allocation */
351 Perl_allocmy(pTHX_ const char *const name)
355 const bool is_our = (PL_in_my == KEY_our);
357 /* complain about "my $<special_var>" etc etc */
361 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
362 (name[1] == '_' && (*name == '$' || name[2]))))
364 /* name[2] is true if strlen(name) > 2 */
365 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
366 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
367 name[0], toCTRL(name[1]), name + 2));
369 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
373 /* check for duplicate declaration */
374 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
376 if (PL_in_my_stash && *name != '$') {
377 yyerror(Perl_form(aTHX_
378 "Can't declare class for non-scalar %s in \"%s\"",
380 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
383 /* allocate a spare slot and store the name in that slot */
385 off = pad_add_name(name,
388 /* $_ is always in main::, even with our */
389 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
393 PL_in_my == KEY_state
398 /* free the body of an op without examining its contents.
399 * Always use this rather than FreeOp directly */
402 S_op_destroy(pTHX_ OP *o)
404 if (o->op_latefree) {
412 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
414 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
420 Perl_op_free(pTHX_ OP *o)
425 if (!o || o->op_static)
427 if (o->op_latefreed) {
434 if (o->op_private & OPpREFCOUNTED) {
445 refcnt = OpREFCNT_dec(o);
448 /* Need to find and remove any pattern match ops from the list
449 we maintain for reset(). */
450 find_and_forget_pmops(o);
460 if (o->op_flags & OPf_KIDS) {
461 register OP *kid, *nextkid;
462 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
463 nextkid = kid->op_sibling; /* Get before next freeing kid */
468 type = (OPCODE)o->op_targ;
470 #ifdef PERL_DEBUG_READONLY_OPS
474 /* COP* is not cleared by op_clear() so that we may track line
475 * numbers etc even after null() */
476 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
481 if (o->op_latefree) {
487 #ifdef DEBUG_LEAKING_SCALARS
494 Perl_op_clear(pTHX_ OP *o)
499 /* if (o->op_madprop && o->op_madprop->mad_next)
501 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
502 "modification of a read only value" for a reason I can't fathom why.
503 It's the "" stringification of $_, where $_ was set to '' in a foreach
504 loop, but it defies simplification into a small test case.
505 However, commenting them out has caused ext/List/Util/t/weak.t to fail
508 mad_free(o->op_madprop);
514 switch (o->op_type) {
515 case OP_NULL: /* Was holding old type, if any. */
516 if (PL_madskills && o->op_targ != OP_NULL) {
517 o->op_type = o->op_targ;
521 case OP_ENTEREVAL: /* Was holding hints. */
525 if (!(o->op_flags & OPf_REF)
526 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
532 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
533 /* not an OP_PADAV replacement */
535 if (cPADOPo->op_padix > 0) {
536 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
537 * may still exist on the pad */
538 pad_swipe(cPADOPo->op_padix, TRUE);
539 cPADOPo->op_padix = 0;
542 SvREFCNT_dec(cSVOPo->op_sv);
543 cSVOPo->op_sv = NULL;
547 case OP_METHOD_NAMED:
549 SvREFCNT_dec(cSVOPo->op_sv);
550 cSVOPo->op_sv = NULL;
553 Even if op_clear does a pad_free for the target of the op,
554 pad_free doesn't actually remove the sv that exists in the pad;
555 instead it lives on. This results in that it could be reused as
556 a target later on when the pad was reallocated.
559 pad_swipe(o->op_targ,1);
568 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
572 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
574 if (cPADOPo->op_padix > 0) {
575 pad_swipe(cPADOPo->op_padix, TRUE);
576 cPADOPo->op_padix = 0;
579 SvREFCNT_dec(cSVOPo->op_sv);
580 cSVOPo->op_sv = NULL;
584 PerlMemShared_free(cPVOPo->op_pv);
585 cPVOPo->op_pv = NULL;
589 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
593 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
594 /* No GvIN_PAD_off here, because other references may still
595 * exist on the pad */
596 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
599 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
605 forget_pmop(cPMOPo, 1);
606 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
607 /* we use the "SAFE" version of the PM_ macros here
608 * since sv_clean_all might release some PMOPs
609 * after PL_regex_padav has been cleared
610 * and the clearing of PL_regex_padav needs to
611 * happen before sv_clean_all
613 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
614 PM_SETRE_SAFE(cPMOPo, NULL);
616 if(PL_regex_pad) { /* We could be in destruction */
617 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
618 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
619 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
620 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
627 if (o->op_targ > 0) {
628 pad_free(o->op_targ);
634 S_cop_free(pTHX_ COP* cop)
639 if (! specialWARN(cop->cop_warnings))
640 PerlMemShared_free(cop->cop_warnings);
641 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
645 S_forget_pmop(pTHX_ PMOP *const o
651 HV * const pmstash = PmopSTASH(o);
652 if (pmstash && !SvIS_FREED(pmstash)) {
653 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
655 PMOP **const array = (PMOP**) mg->mg_ptr;
656 U32 count = mg->mg_len / sizeof(PMOP**);
661 /* Found it. Move the entry at the end to overwrite it. */
662 array[i] = array[--count];
663 mg->mg_len = count * sizeof(PMOP**);
664 /* Could realloc smaller at this point always, but probably
665 not worth it. Probably worth free()ing if we're the
668 Safefree(mg->mg_ptr);
685 S_find_and_forget_pmops(pTHX_ OP *o)
687 if (o->op_flags & OPf_KIDS) {
688 OP *kid = cUNOPo->op_first;
690 switch (kid->op_type) {
695 forget_pmop((PMOP*)kid, 0);
697 find_and_forget_pmops(kid);
698 kid = kid->op_sibling;
704 Perl_op_null(pTHX_ OP *o)
707 if (o->op_type == OP_NULL)
711 o->op_targ = o->op_type;
712 o->op_type = OP_NULL;
713 o->op_ppaddr = PL_ppaddr[OP_NULL];
717 Perl_op_refcnt_lock(pTHX)
725 Perl_op_refcnt_unlock(pTHX)
732 /* Contextualizers */
734 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
737 Perl_linklist(pTHX_ OP *o)
744 /* establish postfix order */
745 first = cUNOPo->op_first;
748 o->op_next = LINKLIST(first);
751 if (kid->op_sibling) {
752 kid->op_next = LINKLIST(kid->op_sibling);
753 kid = kid->op_sibling;
767 Perl_scalarkids(pTHX_ OP *o)
769 if (o && o->op_flags & OPf_KIDS) {
771 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
778 S_scalarboolean(pTHX_ OP *o)
781 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
782 if (ckWARN(WARN_SYNTAX)) {
783 const line_t oldline = CopLINE(PL_curcop);
785 if (PL_copline != NOLINE)
786 CopLINE_set(PL_curcop, PL_copline);
787 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
788 CopLINE_set(PL_curcop, oldline);
795 Perl_scalar(pTHX_ OP *o)
800 /* assumes no premature commitment */
801 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
802 || o->op_type == OP_RETURN)
807 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
809 switch (o->op_type) {
811 scalar(cBINOPo->op_first);
816 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
820 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
821 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
822 deprecate_old("implicit split to @_");
830 if (o->op_flags & OPf_KIDS) {
831 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
837 kid = cLISTOPo->op_first;
839 while ((kid = kid->op_sibling)) {
845 PL_curcop = &PL_compiling;
850 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
856 PL_curcop = &PL_compiling;
859 if (ckWARN(WARN_VOID))
860 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
866 Perl_scalarvoid(pTHX_ OP *o)
870 const char* useless = NULL;
874 /* trailing mad null ops don't count as "there" for void processing */
876 o->op_type != OP_NULL &&
878 o->op_sibling->op_type == OP_NULL)
881 for (sib = o->op_sibling;
882 sib && sib->op_type == OP_NULL;
883 sib = sib->op_sibling) ;
889 if (o->op_type == OP_NEXTSTATE
890 || o->op_type == OP_SETSTATE
891 || o->op_type == OP_DBSTATE
892 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
893 || o->op_targ == OP_SETSTATE
894 || o->op_targ == OP_DBSTATE)))
895 PL_curcop = (COP*)o; /* for warning below */
897 /* assumes no premature commitment */
898 want = o->op_flags & OPf_WANT;
899 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
900 || o->op_type == OP_RETURN)
905 if ((o->op_private & OPpTARGET_MY)
906 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
908 return scalar(o); /* As if inside SASSIGN */
911 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
913 switch (o->op_type) {
915 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
919 if (o->op_flags & OPf_STACKED)
923 if (o->op_private == 4)
995 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
996 useless = OP_DESC(o);
1000 kid = cUNOPo->op_first;
1001 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1002 kid->op_type != OP_TRANS) {
1005 useless = "negative pattern binding (!~)";
1012 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1013 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1014 useless = "a variable";
1019 if (cSVOPo->op_private & OPpCONST_STRICT)
1020 no_bareword_allowed(o);
1022 if (ckWARN(WARN_VOID)) {
1023 useless = "a constant";
1024 if (o->op_private & OPpCONST_ARYBASE)
1026 /* don't warn on optimised away booleans, eg
1027 * use constant Foo, 5; Foo || print; */
1028 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1030 /* the constants 0 and 1 are permitted as they are
1031 conventionally used as dummies in constructs like
1032 1 while some_condition_with_side_effects; */
1033 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1035 else if (SvPOK(sv)) {
1036 /* perl4's way of mixing documentation and code
1037 (before the invention of POD) was based on a
1038 trick to mix nroff and perl code. The trick was
1039 built upon these three nroff macros being used in
1040 void context. The pink camel has the details in
1041 the script wrapman near page 319. */
1042 const char * const maybe_macro = SvPVX_const(sv);
1043 if (strnEQ(maybe_macro, "di", 2) ||
1044 strnEQ(maybe_macro, "ds", 2) ||
1045 strnEQ(maybe_macro, "ig", 2))
1050 op_null(o); /* don't execute or even remember it */
1054 o->op_type = OP_PREINC; /* pre-increment is faster */
1055 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1059 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1060 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1064 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1065 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1069 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1070 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1079 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1084 if (o->op_flags & OPf_STACKED)
1091 if (!(o->op_flags & OPf_KIDS))
1102 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1109 /* all requires must return a boolean value */
1110 o->op_flags &= ~OPf_WANT;
1115 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1116 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1117 deprecate_old("implicit split to @_");
1121 if (useless && ckWARN(WARN_VOID))
1122 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1127 Perl_listkids(pTHX_ OP *o)
1129 if (o && o->op_flags & OPf_KIDS) {
1131 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1138 Perl_list(pTHX_ OP *o)
1143 /* assumes no premature commitment */
1144 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1145 || o->op_type == OP_RETURN)
1150 if ((o->op_private & OPpTARGET_MY)
1151 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1153 return o; /* As if inside SASSIGN */
1156 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1158 switch (o->op_type) {
1161 list(cBINOPo->op_first);
1166 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1174 if (!(o->op_flags & OPf_KIDS))
1176 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1177 list(cBINOPo->op_first);
1178 return gen_constant_list(o);
1185 kid = cLISTOPo->op_first;
1187 while ((kid = kid->op_sibling)) {
1188 if (kid->op_sibling)
1193 PL_curcop = &PL_compiling;
1197 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1198 if (kid->op_sibling)
1203 PL_curcop = &PL_compiling;
1206 /* all requires must return a boolean value */
1207 o->op_flags &= ~OPf_WANT;
1214 Perl_scalarseq(pTHX_ OP *o)
1218 const OPCODE type = o->op_type;
1220 if (type == OP_LINESEQ || type == OP_SCOPE ||
1221 type == OP_LEAVE || type == OP_LEAVETRY)
1224 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1225 if (kid->op_sibling) {
1229 PL_curcop = &PL_compiling;
1231 o->op_flags &= ~OPf_PARENS;
1232 if (PL_hints & HINT_BLOCK_SCOPE)
1233 o->op_flags |= OPf_PARENS;
1236 o = newOP(OP_STUB, 0);
1241 S_modkids(pTHX_ OP *o, I32 type)
1243 if (o && o->op_flags & OPf_KIDS) {
1245 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1251 /* Propagate lvalue ("modifiable") context to an op and its children.
1252 * 'type' represents the context type, roughly based on the type of op that
1253 * would do the modifying, although local() is represented by OP_NULL.
1254 * It's responsible for detecting things that can't be modified, flag
1255 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1256 * might have to vivify a reference in $x), and so on.
1258 * For example, "$a+1 = 2" would cause mod() to be called with o being
1259 * OP_ADD and type being OP_SASSIGN, and would output an error.
1263 Perl_mod(pTHX_ OP *o, I32 type)
1267 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1270 if (!o || PL_error_count)
1273 if ((o->op_private & OPpTARGET_MY)
1274 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1279 switch (o->op_type) {
1285 if (!(o->op_private & OPpCONST_ARYBASE))
1288 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1289 CopARYBASE_set(&PL_compiling,
1290 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1294 SAVECOPARYBASE(&PL_compiling);
1295 CopARYBASE_set(&PL_compiling, 0);
1297 else if (type == OP_REFGEN)
1300 Perl_croak(aTHX_ "That use of $[ is unsupported");
1303 if (o->op_flags & OPf_PARENS || PL_madskills)
1307 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1308 !(o->op_flags & OPf_STACKED)) {
1309 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1310 /* The default is to set op_private to the number of children,
1311 which for a UNOP such as RV2CV is always 1. And w're using
1312 the bit for a flag in RV2CV, so we need it clear. */
1313 o->op_private &= ~1;
1314 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1315 assert(cUNOPo->op_first->op_type == OP_NULL);
1316 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1319 else if (o->op_private & OPpENTERSUB_NOMOD)
1321 else { /* lvalue subroutine call */
1322 o->op_private |= OPpLVAL_INTRO;
1323 PL_modcount = RETURN_UNLIMITED_NUMBER;
1324 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1325 /* Backward compatibility mode: */
1326 o->op_private |= OPpENTERSUB_INARGS;
1329 else { /* Compile-time error message: */
1330 OP *kid = cUNOPo->op_first;
1334 if (kid->op_type != OP_PUSHMARK) {
1335 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1337 "panic: unexpected lvalue entersub "
1338 "args: type/targ %ld:%"UVuf,
1339 (long)kid->op_type, (UV)kid->op_targ);
1340 kid = kLISTOP->op_first;
1342 while (kid->op_sibling)
1343 kid = kid->op_sibling;
1344 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1346 if (kid->op_type == OP_METHOD_NAMED
1347 || kid->op_type == OP_METHOD)
1351 NewOp(1101, newop, 1, UNOP);
1352 newop->op_type = OP_RV2CV;
1353 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1354 newop->op_first = NULL;
1355 newop->op_next = (OP*)newop;
1356 kid->op_sibling = (OP*)newop;
1357 newop->op_private |= OPpLVAL_INTRO;
1358 newop->op_private &= ~1;
1362 if (kid->op_type != OP_RV2CV)
1364 "panic: unexpected lvalue entersub "
1365 "entry via type/targ %ld:%"UVuf,
1366 (long)kid->op_type, (UV)kid->op_targ);
1367 kid->op_private |= OPpLVAL_INTRO;
1368 break; /* Postpone until runtime */
1372 kid = kUNOP->op_first;
1373 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1374 kid = kUNOP->op_first;
1375 if (kid->op_type == OP_NULL)
1377 "Unexpected constant lvalue entersub "
1378 "entry via type/targ %ld:%"UVuf,
1379 (long)kid->op_type, (UV)kid->op_targ);
1380 if (kid->op_type != OP_GV) {
1381 /* Restore RV2CV to check lvalueness */
1383 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1384 okid->op_next = kid->op_next;
1385 kid->op_next = okid;
1388 okid->op_next = NULL;
1389 okid->op_type = OP_RV2CV;
1391 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1392 okid->op_private |= OPpLVAL_INTRO;
1393 okid->op_private &= ~1;
1397 cv = GvCV(kGVOP_gv);
1407 /* grep, foreach, subcalls, refgen */
1408 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1410 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1411 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1413 : (o->op_type == OP_ENTERSUB
1414 ? "non-lvalue subroutine call"
1416 type ? PL_op_desc[type] : "local"));
1430 case OP_RIGHT_SHIFT:
1439 if (!(o->op_flags & OPf_STACKED))
1446 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1452 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1453 PL_modcount = RETURN_UNLIMITED_NUMBER;
1454 return o; /* Treat \(@foo) like ordinary list. */
1458 if (scalar_mod_type(o, type))
1460 ref(cUNOPo->op_first, o->op_type);
1464 if (type == OP_LEAVESUBLV)
1465 o->op_private |= OPpMAYBE_LVSUB;
1471 PL_modcount = RETURN_UNLIMITED_NUMBER;
1474 ref(cUNOPo->op_first, o->op_type);
1479 PL_hints |= HINT_BLOCK_SCOPE;
1494 PL_modcount = RETURN_UNLIMITED_NUMBER;
1495 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1496 return o; /* Treat \(@foo) like ordinary list. */
1497 if (scalar_mod_type(o, type))
1499 if (type == OP_LEAVESUBLV)
1500 o->op_private |= OPpMAYBE_LVSUB;
1504 if (!type) /* local() */
1505 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1506 PAD_COMPNAME_PV(o->op_targ));
1514 if (type != OP_SASSIGN)
1518 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1523 if (type == OP_LEAVESUBLV)
1524 o->op_private |= OPpMAYBE_LVSUB;
1526 pad_free(o->op_targ);
1527 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1528 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1529 if (o->op_flags & OPf_KIDS)
1530 mod(cBINOPo->op_first->op_sibling, type);
1535 ref(cBINOPo->op_first, o->op_type);
1536 if (type == OP_ENTERSUB &&
1537 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1538 o->op_private |= OPpLVAL_DEFER;
1539 if (type == OP_LEAVESUBLV)
1540 o->op_private |= OPpMAYBE_LVSUB;
1550 if (o->op_flags & OPf_KIDS)
1551 mod(cLISTOPo->op_last, type);
1556 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1558 else if (!(o->op_flags & OPf_KIDS))
1560 if (o->op_targ != OP_LIST) {
1561 mod(cBINOPo->op_first, type);
1567 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1572 if (type != OP_LEAVESUBLV)
1574 break; /* mod()ing was handled by ck_return() */
1577 /* [20011101.069] File test operators interpret OPf_REF to mean that
1578 their argument is a filehandle; thus \stat(".") should not set
1580 if (type == OP_REFGEN &&
1581 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1584 if (type != OP_LEAVESUBLV)
1585 o->op_flags |= OPf_MOD;
1587 if (type == OP_AASSIGN || type == OP_SASSIGN)
1588 o->op_flags |= OPf_SPECIAL|OPf_REF;
1589 else if (!type) { /* local() */
1592 o->op_private |= OPpLVAL_INTRO;
1593 o->op_flags &= ~OPf_SPECIAL;
1594 PL_hints |= HINT_BLOCK_SCOPE;
1599 if (ckWARN(WARN_SYNTAX)) {
1600 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1601 "Useless localization of %s", OP_DESC(o));
1605 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1606 && type != OP_LEAVESUBLV)
1607 o->op_flags |= OPf_REF;
1612 S_scalar_mod_type(const OP *o, I32 type)
1616 if (o->op_type == OP_RV2GV)
1640 case OP_RIGHT_SHIFT:
1659 S_is_handle_constructor(const OP *o, I32 numargs)
1661 switch (o->op_type) {
1669 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1682 Perl_refkids(pTHX_ OP *o, I32 type)
1684 if (o && o->op_flags & OPf_KIDS) {
1686 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1693 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1698 if (!o || PL_error_count)
1701 switch (o->op_type) {
1703 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1704 !(o->op_flags & OPf_STACKED)) {
1705 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1706 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1707 assert(cUNOPo->op_first->op_type == OP_NULL);
1708 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1709 o->op_flags |= OPf_SPECIAL;
1710 o->op_private &= ~1;
1715 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1716 doref(kid, type, set_op_ref);
1719 if (type == OP_DEFINED)
1720 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1721 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1724 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1725 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1726 : type == OP_RV2HV ? OPpDEREF_HV
1728 o->op_flags |= OPf_MOD;
1735 o->op_flags |= OPf_REF;
1738 if (type == OP_DEFINED)
1739 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1740 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1746 o->op_flags |= OPf_REF;
1751 if (!(o->op_flags & OPf_KIDS))
1753 doref(cBINOPo->op_first, type, set_op_ref);
1757 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1758 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1759 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1760 : type == OP_RV2HV ? OPpDEREF_HV
1762 o->op_flags |= OPf_MOD;
1772 if (!(o->op_flags & OPf_KIDS))
1774 doref(cLISTOPo->op_last, type, set_op_ref);
1784 S_dup_attrlist(pTHX_ OP *o)
1789 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1790 * where the first kid is OP_PUSHMARK and the remaining ones
1791 * are OP_CONST. We need to push the OP_CONST values.
1793 if (o->op_type == OP_CONST)
1794 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1796 else if (o->op_type == OP_NULL)
1800 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1802 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1803 if (o->op_type == OP_CONST)
1804 rop = append_elem(OP_LIST, rop,
1805 newSVOP(OP_CONST, o->op_flags,
1806 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1813 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1818 /* fake up C<use attributes $pkg,$rv,@attrs> */
1819 ENTER; /* need to protect against side-effects of 'use' */
1821 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1823 #define ATTRSMODULE "attributes"
1824 #define ATTRSMODULE_PM "attributes.pm"
1827 /* Don't force the C<use> if we don't need it. */
1828 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1829 if (svp && *svp != &PL_sv_undef)
1830 NOOP; /* already in %INC */
1832 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1833 newSVpvs(ATTRSMODULE), NULL);
1836 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1837 newSVpvs(ATTRSMODULE),
1839 prepend_elem(OP_LIST,
1840 newSVOP(OP_CONST, 0, stashsv),
1841 prepend_elem(OP_LIST,
1842 newSVOP(OP_CONST, 0,
1844 dup_attrlist(attrs))));
1850 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1853 OP *pack, *imop, *arg;
1859 assert(target->op_type == OP_PADSV ||
1860 target->op_type == OP_PADHV ||
1861 target->op_type == OP_PADAV);
1863 /* Ensure that attributes.pm is loaded. */
1864 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1866 /* Need package name for method call. */
1867 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1869 /* Build up the real arg-list. */
1870 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1872 arg = newOP(OP_PADSV, 0);
1873 arg->op_targ = target->op_targ;
1874 arg = prepend_elem(OP_LIST,
1875 newSVOP(OP_CONST, 0, stashsv),
1876 prepend_elem(OP_LIST,
1877 newUNOP(OP_REFGEN, 0,
1878 mod(arg, OP_REFGEN)),
1879 dup_attrlist(attrs)));
1881 /* Fake up a method call to import */
1882 meth = newSVpvs_share("import");
1883 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1884 append_elem(OP_LIST,
1885 prepend_elem(OP_LIST, pack, list(arg)),
1886 newSVOP(OP_METHOD_NAMED, 0, meth)));
1887 imop->op_private |= OPpENTERSUB_NOMOD;
1889 /* Combine the ops. */
1890 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1894 =notfor apidoc apply_attrs_string
1896 Attempts to apply a list of attributes specified by the C<attrstr> and
1897 C<len> arguments to the subroutine identified by the C<cv> argument which
1898 is expected to be associated with the package identified by the C<stashpv>
1899 argument (see L<attributes>). It gets this wrong, though, in that it
1900 does not correctly identify the boundaries of the individual attribute
1901 specifications within C<attrstr>. This is not really intended for the
1902 public API, but has to be listed here for systems such as AIX which
1903 need an explicit export list for symbols. (It's called from XS code
1904 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1905 to respect attribute syntax properly would be welcome.
1911 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1912 const char *attrstr, STRLEN len)
1917 len = strlen(attrstr);
1921 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1923 const char * const sstr = attrstr;
1924 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1925 attrs = append_elem(OP_LIST, attrs,
1926 newSVOP(OP_CONST, 0,
1927 newSVpvn(sstr, attrstr-sstr)));
1931 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1932 newSVpvs(ATTRSMODULE),
1933 NULL, prepend_elem(OP_LIST,
1934 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1935 prepend_elem(OP_LIST,
1936 newSVOP(OP_CONST, 0,
1942 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1947 if (!o || PL_error_count)
1951 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1952 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1956 if (type == OP_LIST) {
1958 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1959 my_kid(kid, attrs, imopsp);
1960 } else if (type == OP_UNDEF
1966 } else if (type == OP_RV2SV || /* "our" declaration */
1968 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1969 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1970 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1972 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1974 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1976 PL_in_my_stash = NULL;
1977 apply_attrs(GvSTASH(gv),
1978 (type == OP_RV2SV ? GvSV(gv) :
1979 type == OP_RV2AV ? (SV*)GvAV(gv) :
1980 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1983 o->op_private |= OPpOUR_INTRO;
1986 else if (type != OP_PADSV &&
1989 type != OP_PUSHMARK)
1991 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1993 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1996 else if (attrs && type != OP_PUSHMARK) {
2000 PL_in_my_stash = NULL;
2002 /* check for C<my Dog $spot> when deciding package */
2003 stash = PAD_COMPNAME_TYPE(o->op_targ);
2005 stash = PL_curstash;
2006 apply_attrs_my(stash, o, attrs, imopsp);
2008 o->op_flags |= OPf_MOD;
2009 o->op_private |= OPpLVAL_INTRO;
2010 if (PL_in_my == KEY_state)
2011 o->op_private |= OPpPAD_STATE;
2016 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2020 int maybe_scalar = 0;
2022 /* [perl #17376]: this appears to be premature, and results in code such as
2023 C< our(%x); > executing in list mode rather than void mode */
2025 if (o->op_flags & OPf_PARENS)
2035 o = my_kid(o, attrs, &rops);
2037 if (maybe_scalar && o->op_type == OP_PADSV) {
2038 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2039 o->op_private |= OPpLVAL_INTRO;
2042 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2045 PL_in_my_stash = NULL;
2050 Perl_my(pTHX_ OP *o)
2052 return my_attrs(o, NULL);
2056 Perl_sawparens(pTHX_ OP *o)
2058 PERL_UNUSED_CONTEXT;
2060 o->op_flags |= OPf_PARENS;
2065 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2069 const OPCODE ltype = left->op_type;
2070 const OPCODE rtype = right->op_type;
2072 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2073 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2075 const char * const desc
2076 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2077 ? (int)rtype : OP_MATCH];
2078 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2079 ? "@array" : "%hash");
2080 Perl_warner(aTHX_ packWARN(WARN_MISC),
2081 "Applying %s to %s will act on scalar(%s)",
2082 desc, sample, sample);
2085 if (rtype == OP_CONST &&
2086 cSVOPx(right)->op_private & OPpCONST_BARE &&
2087 cSVOPx(right)->op_private & OPpCONST_STRICT)
2089 no_bareword_allowed(right);
2092 ismatchop = rtype == OP_MATCH ||
2093 rtype == OP_SUBST ||
2095 if (ismatchop && right->op_private & OPpTARGET_MY) {
2097 right->op_private &= ~OPpTARGET_MY;
2099 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2102 right->op_flags |= OPf_STACKED;
2103 if (rtype != OP_MATCH &&
2104 ! (rtype == OP_TRANS &&
2105 right->op_private & OPpTRANS_IDENTICAL))
2106 newleft = mod(left, rtype);
2109 if (right->op_type == OP_TRANS)
2110 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2112 o = prepend_elem(rtype, scalar(newleft), right);
2114 return newUNOP(OP_NOT, 0, scalar(o));
2118 return bind_match(type, left,
2119 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2123 Perl_invert(pTHX_ OP *o)
2127 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2131 Perl_scope(pTHX_ OP *o)
2135 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2136 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2137 o->op_type = OP_LEAVE;
2138 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2140 else if (o->op_type == OP_LINESEQ) {
2142 o->op_type = OP_SCOPE;
2143 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2144 kid = ((LISTOP*)o)->op_first;
2145 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2148 /* The following deals with things like 'do {1 for 1}' */
2149 kid = kid->op_sibling;
2151 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2156 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2162 Perl_block_start(pTHX_ int full)
2165 const int retval = PL_savestack_ix;
2166 pad_block_start(full);
2168 PL_hints &= ~HINT_BLOCK_SCOPE;
2169 SAVECOMPILEWARNINGS();
2170 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2175 Perl_block_end(pTHX_ I32 floor, OP *seq)
2178 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2179 OP* const retval = scalarseq(seq);
2181 CopHINTS_set(&PL_compiling, PL_hints);
2183 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2192 const PADOFFSET offset = pad_findmy("$_");
2193 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2194 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2197 OP * const o = newOP(OP_PADSV, 0);
2198 o->op_targ = offset;
2204 Perl_newPROG(pTHX_ OP *o)
2210 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2211 ((PL_in_eval & EVAL_KEEPERR)
2212 ? OPf_SPECIAL : 0), o);
2213 PL_eval_start = linklist(PL_eval_root);
2214 PL_eval_root->op_private |= OPpREFCOUNTED;
2215 OpREFCNT_set(PL_eval_root, 1);
2216 PL_eval_root->op_next = 0;
2217 CALL_PEEP(PL_eval_start);
2220 if (o->op_type == OP_STUB) {
2221 PL_comppad_name = 0;
2223 S_op_destroy(aTHX_ o);
2226 PL_main_root = scope(sawparens(scalarvoid(o)));
2227 PL_curcop = &PL_compiling;
2228 PL_main_start = LINKLIST(PL_main_root);
2229 PL_main_root->op_private |= OPpREFCOUNTED;
2230 OpREFCNT_set(PL_main_root, 1);
2231 PL_main_root->op_next = 0;
2232 CALL_PEEP(PL_main_start);
2235 /* Register with debugger */
2238 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2242 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2244 call_sv((SV*)cv, G_DISCARD);
2251 Perl_localize(pTHX_ OP *o, I32 lex)
2254 if (o->op_flags & OPf_PARENS)
2255 /* [perl #17376]: this appears to be premature, and results in code such as
2256 C< our(%x); > executing in list mode rather than void mode */
2263 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2264 && ckWARN(WARN_PARENTHESIS))
2266 char *s = PL_bufptr;
2269 /* some heuristics to detect a potential error */
2270 while (*s && (strchr(", \t\n", *s)))
2274 if (*s && strchr("@$%*", *s) && *++s
2275 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2278 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2280 while (*s && (strchr(", \t\n", *s)))
2286 if (sigil && (*s == ';' || *s == '=')) {
2287 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2288 "Parentheses missing around \"%s\" list",
2289 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2297 o = mod(o, OP_NULL); /* a bit kludgey */
2299 PL_in_my_stash = NULL;
2304 Perl_jmaybe(pTHX_ OP *o)
2306 if (o->op_type == OP_LIST) {
2308 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2309 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2315 Perl_fold_constants(pTHX_ register OP *o)
2320 VOL I32 type = o->op_type;
2325 SV * const oldwarnhook = PL_warnhook;
2326 SV * const olddiehook = PL_diehook;
2329 if (PL_opargs[type] & OA_RETSCALAR)
2331 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2332 o->op_targ = pad_alloc(type, SVs_PADTMP);
2334 /* integerize op, unless it happens to be C<-foo>.
2335 * XXX should pp_i_negate() do magic string negation instead? */
2336 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2337 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2338 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2340 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2343 if (!(PL_opargs[type] & OA_FOLDCONST))
2348 /* XXX might want a ck_negate() for this */
2349 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2360 /* XXX what about the numeric ops? */
2361 if (PL_hints & HINT_LOCALE)
2366 goto nope; /* Don't try to run w/ errors */
2368 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2369 const OPCODE type = curop->op_type;
2370 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2372 type != OP_SCALAR &&
2374 type != OP_PUSHMARK)
2380 curop = LINKLIST(o);
2381 old_next = o->op_next;
2385 oldscope = PL_scopestack_ix;
2386 create_eval_scope(G_FAKINGEVAL);
2388 PL_warnhook = PERL_WARNHOOK_FATAL;
2395 sv = *(PL_stack_sp--);
2396 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2397 pad_swipe(o->op_targ, FALSE);
2398 else if (SvTEMP(sv)) { /* grab mortal temp? */
2399 SvREFCNT_inc_simple_void(sv);
2404 /* Something tried to die. Abandon constant folding. */
2405 /* Pretend the error never happened. */
2406 sv_setpvn(ERRSV,"",0);
2407 o->op_next = old_next;
2411 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2412 PL_warnhook = oldwarnhook;
2413 PL_diehook = olddiehook;
2414 /* XXX note that this croak may fail as we've already blown away
2415 * the stack - eg any nested evals */
2416 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2419 PL_warnhook = oldwarnhook;
2420 PL_diehook = olddiehook;
2422 if (PL_scopestack_ix > oldscope)
2423 delete_eval_scope();
2432 if (type == OP_RV2GV)
2433 newop = newGVOP(OP_GV, 0, (GV*)sv);
2435 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2436 op_getmad(o,newop,'f');
2444 Perl_gen_constant_list(pTHX_ register OP *o)
2448 const I32 oldtmps_floor = PL_tmps_floor;
2452 return o; /* Don't attempt to run with errors */
2454 PL_op = curop = LINKLIST(o);
2460 assert (!(curop->op_flags & OPf_SPECIAL));
2461 assert(curop->op_type == OP_RANGE);
2463 PL_tmps_floor = oldtmps_floor;
2465 o->op_type = OP_RV2AV;
2466 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2467 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2468 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2469 o->op_opt = 0; /* needs to be revisited in peep() */
2470 curop = ((UNOP*)o)->op_first;
2471 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2473 op_getmad(curop,o,'O');
2482 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2485 if (!o || o->op_type != OP_LIST)
2486 o = newLISTOP(OP_LIST, 0, o, NULL);
2488 o->op_flags &= ~OPf_WANT;
2490 if (!(PL_opargs[type] & OA_MARK))
2491 op_null(cLISTOPo->op_first);
2493 o->op_type = (OPCODE)type;
2494 o->op_ppaddr = PL_ppaddr[type];
2495 o->op_flags |= flags;
2497 o = CHECKOP(type, o);
2498 if (o->op_type != (unsigned)type)
2501 return fold_constants(o);
2504 /* List constructors */
2507 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2515 if (first->op_type != (unsigned)type
2516 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2518 return newLISTOP(type, 0, first, last);
2521 if (first->op_flags & OPf_KIDS)
2522 ((LISTOP*)first)->op_last->op_sibling = last;
2524 first->op_flags |= OPf_KIDS;
2525 ((LISTOP*)first)->op_first = last;
2527 ((LISTOP*)first)->op_last = last;
2532 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2540 if (first->op_type != (unsigned)type)
2541 return prepend_elem(type, (OP*)first, (OP*)last);
2543 if (last->op_type != (unsigned)type)
2544 return append_elem(type, (OP*)first, (OP*)last);
2546 first->op_last->op_sibling = last->op_first;
2547 first->op_last = last->op_last;
2548 first->op_flags |= (last->op_flags & OPf_KIDS);
2551 if (last->op_first && first->op_madprop) {
2552 MADPROP *mp = last->op_first->op_madprop;
2554 while (mp->mad_next)
2556 mp->mad_next = first->op_madprop;
2559 last->op_first->op_madprop = first->op_madprop;
2562 first->op_madprop = last->op_madprop;
2563 last->op_madprop = 0;
2566 S_op_destroy(aTHX_ (OP*)last);
2572 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2580 if (last->op_type == (unsigned)type) {
2581 if (type == OP_LIST) { /* already a PUSHMARK there */
2582 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2583 ((LISTOP*)last)->op_first->op_sibling = first;
2584 if (!(first->op_flags & OPf_PARENS))
2585 last->op_flags &= ~OPf_PARENS;
2588 if (!(last->op_flags & OPf_KIDS)) {
2589 ((LISTOP*)last)->op_last = first;
2590 last->op_flags |= OPf_KIDS;
2592 first->op_sibling = ((LISTOP*)last)->op_first;
2593 ((LISTOP*)last)->op_first = first;
2595 last->op_flags |= OPf_KIDS;
2599 return newLISTOP(type, 0, first, last);
2607 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2610 Newxz(tk, 1, TOKEN);
2611 tk->tk_type = (OPCODE)optype;
2612 tk->tk_type = 12345;
2614 tk->tk_mad = madprop;
2619 Perl_token_free(pTHX_ TOKEN* tk)
2621 if (tk->tk_type != 12345)
2623 mad_free(tk->tk_mad);
2628 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2632 if (tk->tk_type != 12345) {
2633 Perl_warner(aTHX_ packWARN(WARN_MISC),
2634 "Invalid TOKEN object ignored");
2641 /* faked up qw list? */
2643 tm->mad_type == MAD_SV &&
2644 SvPVX((SV*)tm->mad_val)[0] == 'q')
2651 /* pretend constant fold didn't happen? */
2652 if (mp->mad_key == 'f' &&
2653 (o->op_type == OP_CONST ||
2654 o->op_type == OP_GV) )
2656 token_getmad(tk,(OP*)mp->mad_val,slot);
2670 if (mp->mad_key == 'X')
2671 mp->mad_key = slot; /* just change the first one */
2681 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2690 /* pretend constant fold didn't happen? */
2691 if (mp->mad_key == 'f' &&
2692 (o->op_type == OP_CONST ||
2693 o->op_type == OP_GV) )
2695 op_getmad(from,(OP*)mp->mad_val,slot);
2702 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2705 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2711 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2720 /* pretend constant fold didn't happen? */
2721 if (mp->mad_key == 'f' &&
2722 (o->op_type == OP_CONST ||
2723 o->op_type == OP_GV) )
2725 op_getmad(from,(OP*)mp->mad_val,slot);
2732 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2735 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2739 PerlIO_printf(PerlIO_stderr(),
2740 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2746 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2764 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2768 addmad(tm, &(o->op_madprop), slot);
2772 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2793 Perl_newMADsv(pTHX_ char key, SV* sv)
2795 return newMADPROP(key, MAD_SV, sv, 0);
2799 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2802 Newxz(mp, 1, MADPROP);
2805 mp->mad_vlen = vlen;
2806 mp->mad_type = type;
2808 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2813 Perl_mad_free(pTHX_ MADPROP* mp)
2815 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2819 mad_free(mp->mad_next);
2820 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2821 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2822 switch (mp->mad_type) {
2826 Safefree((char*)mp->mad_val);
2829 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2830 op_free((OP*)mp->mad_val);
2833 sv_free((SV*)mp->mad_val);
2836 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2845 Perl_newNULLLIST(pTHX)
2847 return newOP(OP_STUB, 0);
2851 Perl_force_list(pTHX_ OP *o)
2853 if (!o || o->op_type != OP_LIST)
2854 o = newLISTOP(OP_LIST, 0, o, NULL);
2860 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2865 NewOp(1101, listop, 1, LISTOP);
2867 listop->op_type = (OPCODE)type;
2868 listop->op_ppaddr = PL_ppaddr[type];
2871 listop->op_flags = (U8)flags;
2875 else if (!first && last)
2878 first->op_sibling = last;
2879 listop->op_first = first;
2880 listop->op_last = last;
2881 if (type == OP_LIST) {
2882 OP* const pushop = newOP(OP_PUSHMARK, 0);
2883 pushop->op_sibling = first;
2884 listop->op_first = pushop;
2885 listop->op_flags |= OPf_KIDS;
2887 listop->op_last = pushop;
2890 return CHECKOP(type, listop);
2894 Perl_newOP(pTHX_ I32 type, I32 flags)
2898 NewOp(1101, o, 1, OP);
2899 o->op_type = (OPCODE)type;
2900 o->op_ppaddr = PL_ppaddr[type];
2901 o->op_flags = (U8)flags;
2903 o->op_latefreed = 0;
2907 o->op_private = (U8)(0 | (flags >> 8));
2908 if (PL_opargs[type] & OA_RETSCALAR)
2910 if (PL_opargs[type] & OA_TARGET)
2911 o->op_targ = pad_alloc(type, SVs_PADTMP);
2912 return CHECKOP(type, o);
2916 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2922 first = newOP(OP_STUB, 0);
2923 if (PL_opargs[type] & OA_MARK)
2924 first = force_list(first);
2926 NewOp(1101, unop, 1, UNOP);
2927 unop->op_type = (OPCODE)type;
2928 unop->op_ppaddr = PL_ppaddr[type];
2929 unop->op_first = first;
2930 unop->op_flags = (U8)(flags | OPf_KIDS);
2931 unop->op_private = (U8)(1 | (flags >> 8));
2932 unop = (UNOP*) CHECKOP(type, unop);
2936 return fold_constants((OP *) unop);
2940 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2944 NewOp(1101, binop, 1, BINOP);
2947 first = newOP(OP_NULL, 0);
2949 binop->op_type = (OPCODE)type;
2950 binop->op_ppaddr = PL_ppaddr[type];
2951 binop->op_first = first;
2952 binop->op_flags = (U8)(flags | OPf_KIDS);
2955 binop->op_private = (U8)(1 | (flags >> 8));
2958 binop->op_private = (U8)(2 | (flags >> 8));
2959 first->op_sibling = last;
2962 binop = (BINOP*)CHECKOP(type, binop);
2963 if (binop->op_next || binop->op_type != (OPCODE)type)
2966 binop->op_last = binop->op_first->op_sibling;
2968 return fold_constants((OP *)binop);
2971 static int uvcompare(const void *a, const void *b)
2972 __attribute__nonnull__(1)
2973 __attribute__nonnull__(2)
2974 __attribute__pure__;
2975 static int uvcompare(const void *a, const void *b)
2977 if (*((const UV *)a) < (*(const UV *)b))
2979 if (*((const UV *)a) > (*(const UV *)b))
2981 if (*((const UV *)a+1) < (*(const UV *)b+1))
2983 if (*((const UV *)a+1) > (*(const UV *)b+1))
2989 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2992 SV * const tstr = ((SVOP*)expr)->op_sv;
2995 (repl->op_type == OP_NULL)
2996 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2998 ((SVOP*)repl)->op_sv;
3001 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3002 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3006 register short *tbl;
3008 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3009 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3010 I32 del = o->op_private & OPpTRANS_DELETE;
3012 PL_hints |= HINT_BLOCK_SCOPE;
3015 o->op_private |= OPpTRANS_FROM_UTF;
3018 o->op_private |= OPpTRANS_TO_UTF;
3020 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3021 SV* const listsv = newSVpvs("# comment\n");
3023 const U8* tend = t + tlen;
3024 const U8* rend = r + rlen;
3038 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3039 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3042 const U32 flags = UTF8_ALLOW_DEFAULT;
3046 t = tsave = bytes_to_utf8(t, &len);
3049 if (!to_utf && rlen) {
3051 r = rsave = bytes_to_utf8(r, &len);
3055 /* There are several snags with this code on EBCDIC:
3056 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3057 2. scan_const() in toke.c has encoded chars in native encoding which makes
3058 ranges at least in EBCDIC 0..255 range the bottom odd.
3062 U8 tmpbuf[UTF8_MAXBYTES+1];
3065 Newx(cp, 2*tlen, UV);
3067 transv = newSVpvs("");
3069 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3071 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3073 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3077 cp[2*i+1] = cp[2*i];
3081 qsort(cp, i, 2*sizeof(UV), uvcompare);
3082 for (j = 0; j < i; j++) {
3084 diff = val - nextmin;
3086 t = uvuni_to_utf8(tmpbuf,nextmin);
3087 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3089 U8 range_mark = UTF_TO_NATIVE(0xff);
3090 t = uvuni_to_utf8(tmpbuf, val - 1);
3091 sv_catpvn(transv, (char *)&range_mark, 1);
3092 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3099 t = uvuni_to_utf8(tmpbuf,nextmin);
3100 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3102 U8 range_mark = UTF_TO_NATIVE(0xff);
3103 sv_catpvn(transv, (char *)&range_mark, 1);
3105 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3106 UNICODE_ALLOW_SUPER);
3107 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3108 t = (const U8*)SvPVX_const(transv);
3109 tlen = SvCUR(transv);
3113 else if (!rlen && !del) {
3114 r = t; rlen = tlen; rend = tend;
3117 if ((!rlen && !del) || t == r ||
3118 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3120 o->op_private |= OPpTRANS_IDENTICAL;
3124 while (t < tend || tfirst <= tlast) {
3125 /* see if we need more "t" chars */
3126 if (tfirst > tlast) {
3127 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3129 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3131 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3138 /* now see if we need more "r" chars */
3139 if (rfirst > rlast) {
3141 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3143 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3145 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3154 rfirst = rlast = 0xffffffff;
3158 /* now see which range will peter our first, if either. */
3159 tdiff = tlast - tfirst;
3160 rdiff = rlast - rfirst;
3167 if (rfirst == 0xffffffff) {
3168 diff = tdiff; /* oops, pretend rdiff is infinite */
3170 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3171 (long)tfirst, (long)tlast);
3173 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3177 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3178 (long)tfirst, (long)(tfirst + diff),
3181 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3182 (long)tfirst, (long)rfirst);
3184 if (rfirst + diff > max)
3185 max = rfirst + diff;
3187 grows = (tfirst < rfirst &&
3188 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3200 else if (max > 0xff)
3205 PerlMemShared_free(cPVOPo->op_pv);
3206 cPVOPo->op_pv = NULL;
3208 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3210 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3211 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3212 PAD_SETSV(cPADOPo->op_padix, swash);
3215 cSVOPo->op_sv = swash;
3217 SvREFCNT_dec(listsv);
3218 SvREFCNT_dec(transv);
3220 if (!del && havefinal && rlen)
3221 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3222 newSVuv((UV)final), 0);
3225 o->op_private |= OPpTRANS_GROWS;
3231 op_getmad(expr,o,'e');
3232 op_getmad(repl,o,'r');
3240 tbl = (short*)cPVOPo->op_pv;
3242 Zero(tbl, 256, short);
3243 for (i = 0; i < (I32)tlen; i++)
3245 for (i = 0, j = 0; i < 256; i++) {
3247 if (j >= (I32)rlen) {
3256 if (i < 128 && r[j] >= 128)
3266 o->op_private |= OPpTRANS_IDENTICAL;
3268 else if (j >= (I32)rlen)
3273 PerlMemShared_realloc(tbl,
3274 (0x101+rlen-j) * sizeof(short));
3275 cPVOPo->op_pv = (char*)tbl;
3277 tbl[0x100] = (short)(rlen - j);
3278 for (i=0; i < (I32)rlen - j; i++)
3279 tbl[0x101+i] = r[j+i];
3283 if (!rlen && !del) {
3286 o->op_private |= OPpTRANS_IDENTICAL;
3288 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3289 o->op_private |= OPpTRANS_IDENTICAL;
3291 for (i = 0; i < 256; i++)
3293 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3294 if (j >= (I32)rlen) {
3296 if (tbl[t[i]] == -1)
3302 if (tbl[t[i]] == -1) {
3303 if (t[i] < 128 && r[j] >= 128)
3310 o->op_private |= OPpTRANS_GROWS;
3312 op_getmad(expr,o,'e');
3313 op_getmad(repl,o,'r');
3323 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3328 NewOp(1101, pmop, 1, PMOP);
3329 pmop->op_type = (OPCODE)type;
3330 pmop->op_ppaddr = PL_ppaddr[type];
3331 pmop->op_flags = (U8)flags;
3332 pmop->op_private = (U8)(0 | (flags >> 8));
3334 if (PL_hints & HINT_RE_TAINT)
3335 pmop->op_pmflags |= PMf_RETAINT;
3336 if (PL_hints & HINT_LOCALE)
3337 pmop->op_pmflags |= PMf_LOCALE;
3341 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3342 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3343 pmop->op_pmoffset = SvIV(repointer);
3344 SvREPADTMP_off(repointer);
3345 sv_setiv(repointer,0);
3347 SV * const repointer = newSViv(0);
3348 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3349 pmop->op_pmoffset = av_len(PL_regex_padav);
3350 PL_regex_pad = AvARRAY(PL_regex_padav);
3354 return CHECKOP(type, pmop);
3357 /* Given some sort of match op o, and an expression expr containing a
3358 * pattern, either compile expr into a regex and attach it to o (if it's
3359 * constant), or convert expr into a runtime regcomp op sequence (if it's
3362 * isreg indicates that the pattern is part of a regex construct, eg
3363 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3364 * split "pattern", which aren't. In the former case, expr will be a list
3365 * if the pattern contains more than one term (eg /a$b/) or if it contains
3366 * a replacement, ie s/// or tr///.
3370 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3375 I32 repl_has_vars = 0;
3379 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3380 /* last element in list is the replacement; pop it */
3382 repl = cLISTOPx(expr)->op_last;
3383 kid = cLISTOPx(expr)->op_first;
3384 while (kid->op_sibling != repl)
3385 kid = kid->op_sibling;
3386 kid->op_sibling = NULL;
3387 cLISTOPx(expr)->op_last = kid;
3390 if (isreg && expr->op_type == OP_LIST &&
3391 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3393 /* convert single element list to element */
3394 OP* const oe = expr;
3395 expr = cLISTOPx(oe)->op_first->op_sibling;
3396 cLISTOPx(oe)->op_first->op_sibling = NULL;
3397 cLISTOPx(oe)->op_last = NULL;
3401 if (o->op_type == OP_TRANS) {
3402 return pmtrans(o, expr, repl);
3405 reglist = isreg && expr->op_type == OP_LIST;
3409 PL_hints |= HINT_BLOCK_SCOPE;
3412 if (expr->op_type == OP_CONST) {
3414 SV * const pat = ((SVOP*)expr)->op_sv;
3415 const char *p = SvPV_const(pat, plen);
3416 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3417 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
3418 U32 was_readonly = SvREADONLY(pat);
3422 sv_force_normal_flags(pat, 0);
3423 assert(!SvREADONLY(pat));
3426 SvREADONLY_off(pat);
3430 sv_setpvn(pat, "\\s+", 3);
3432 SvFLAGS(pat) |= was_readonly;
3434 p = SvPV_const(pat, plen);
3435 pm_flags |= RXf_SKIPWHITE;
3438 pm_flags |= RXf_UTF8;
3439 /* FIXME - can we make this function take const char * args? */
3440 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm_flags));
3443 op_getmad(expr,(OP*)pm,'e');
3449 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3450 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3452 : OP_REGCMAYBE),0,expr);
3454 NewOp(1101, rcop, 1, LOGOP);
3455 rcop->op_type = OP_REGCOMP;
3456 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3457 rcop->op_first = scalar(expr);
3458 rcop->op_flags |= OPf_KIDS
3459 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3460 | (reglist ? OPf_STACKED : 0);
3461 rcop->op_private = 1;
3464 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3466 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3469 /* establish postfix order */
3470 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3472 rcop->op_next = expr;
3473 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3476 rcop->op_next = LINKLIST(expr);
3477 expr->op_next = (OP*)rcop;
3480 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3485 if (pm->op_pmflags & PMf_EVAL) {
3487 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3488 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3490 else if (repl->op_type == OP_CONST)
3494 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3495 if (curop->op_type == OP_SCOPE
3496 || curop->op_type == OP_LEAVE
3497 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3498 if (curop->op_type == OP_GV) {
3499 GV * const gv = cGVOPx_gv(curop);
3501 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3504 else if (curop->op_type == OP_RV2CV)
3506 else if (curop->op_type == OP_RV2SV ||
3507 curop->op_type == OP_RV2AV ||
3508 curop->op_type == OP_RV2HV ||
3509 curop->op_type == OP_RV2GV) {
3510 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3513 else if (curop->op_type == OP_PADSV ||
3514 curop->op_type == OP_PADAV ||
3515 curop->op_type == OP_PADHV ||
3516 curop->op_type == OP_PADANY)
3520 else if (curop->op_type == OP_PUSHRE)
3521 NOOP; /* Okay here, dangerous in newASSIGNOP */
3531 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3533 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3534 prepend_elem(o->op_type, scalar(repl), o);
3537 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3538 pm->op_pmflags |= PMf_MAYBE_CONST;
3540 NewOp(1101, rcop, 1, LOGOP);
3541 rcop->op_type = OP_SUBSTCONT;
3542 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3543 rcop->op_first = scalar(repl);
3544 rcop->op_flags |= OPf_KIDS;
3545 rcop->op_private = 1;
3548 /* establish postfix order */
3549 rcop->op_next = LINKLIST(repl);
3550 repl->op_next = (OP*)rcop;
3552 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3553 assert(!(pm->op_pmflags & PMf_ONCE));
3554 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3563 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3567 NewOp(1101, svop, 1, SVOP);
3568 svop->op_type = (OPCODE)type;
3569 svop->op_ppaddr = PL_ppaddr[type];
3571 svop->op_next = (OP*)svop;
3572 svop->op_flags = (U8)flags;
3573 if (PL_opargs[type] & OA_RETSCALAR)
3575 if (PL_opargs[type] & OA_TARGET)
3576 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3577 return CHECKOP(type, svop);
3582 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3586 NewOp(1101, padop, 1, PADOP);
3587 padop->op_type = (OPCODE)type;
3588 padop->op_ppaddr = PL_ppaddr[type];
3589 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3590 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3591 PAD_SETSV(padop->op_padix, sv);
3594 padop->op_next = (OP*)padop;
3595 padop->op_flags = (U8)flags;
3596 if (PL_opargs[type] & OA_RETSCALAR)
3598 if (PL_opargs[type] & OA_TARGET)
3599 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3600 return CHECKOP(type, padop);
3605 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3611 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3613 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3618 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3622 NewOp(1101, pvop, 1, PVOP);
3623 pvop->op_type = (OPCODE)type;
3624 pvop->op_ppaddr = PL_ppaddr[type];
3626 pvop->op_next = (OP*)pvop;
3627 pvop->op_flags = (U8)flags;
3628 if (PL_opargs[type] & OA_RETSCALAR)
3630 if (PL_opargs[type] & OA_TARGET)
3631 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3632 return CHECKOP(type, pvop);
3640 Perl_package(pTHX_ OP *o)
3643 SV *const sv = cSVOPo->op_sv;
3648 save_hptr(&PL_curstash);
3649 save_item(PL_curstname);
3651 PL_curstash = gv_stashsv(sv, GV_ADD);
3653 /* In case mg.c:Perl_magic_setisa faked
3654 this package earlier, we clear the fake flag */
3655 HvMROMETA(PL_curstash)->fake = 0;
3657 sv_setsv(PL_curstname, sv);
3659 PL_hints |= HINT_BLOCK_SCOPE;
3660 PL_copline = NOLINE;
3666 if (!PL_madskills) {
3671 pegop = newOP(OP_NULL,0);
3672 op_getmad(o,pegop,'P');
3682 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3689 OP *pegop = newOP(OP_NULL,0);
3692 if (idop->op_type != OP_CONST)
3693 Perl_croak(aTHX_ "Module name must be constant");
3696 op_getmad(idop,pegop,'U');
3701 SV * const vesv = ((SVOP*)version)->op_sv;
3704 op_getmad(version,pegop,'V');
3705 if (!arg && !SvNIOKp(vesv)) {
3712 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3713 Perl_croak(aTHX_ "Version number must be constant number");
3715 /* Make copy of idop so we don't free it twice */
3716 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3718 /* Fake up a method call to VERSION */
3719 meth = newSVpvs_share("VERSION");
3720 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3721 append_elem(OP_LIST,
3722 prepend_elem(OP_LIST, pack, list(version)),
3723 newSVOP(OP_METHOD_NAMED, 0, meth)));
3727 /* Fake up an import/unimport */
3728 if (arg && arg->op_type == OP_STUB) {
3730 op_getmad(arg,pegop,'S');
3731 imop = arg; /* no import on explicit () */
3733 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3734 imop = NULL; /* use 5.0; */
3736 idop->op_private |= OPpCONST_NOVER;
3742 op_getmad(arg,pegop,'A');
3744 /* Make copy of idop so we don't free it twice */
3745 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3747 /* Fake up a method call to import/unimport */
3749 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3750 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3751 append_elem(OP_LIST,
3752 prepend_elem(OP_LIST, pack, list(arg)),
3753 newSVOP(OP_METHOD_NAMED, 0, meth)));
3756 /* Fake up the BEGIN {}, which does its thing immediately. */
3758 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3761 append_elem(OP_LINESEQ,
3762 append_elem(OP_LINESEQ,
3763 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3764 newSTATEOP(0, NULL, veop)),
3765 newSTATEOP(0, NULL, imop) ));
3767 /* The "did you use incorrect case?" warning used to be here.
3768 * The problem is that on case-insensitive filesystems one
3769 * might get false positives for "use" (and "require"):
3770 * "use Strict" or "require CARP" will work. This causes
3771 * portability problems for the script: in case-strict
3772 * filesystems the script will stop working.
3774 * The "incorrect case" warning checked whether "use Foo"
3775 * imported "Foo" to your namespace, but that is wrong, too:
3776 * there is no requirement nor promise in the language that
3777 * a Foo.pm should or would contain anything in package "Foo".
3779 * There is very little Configure-wise that can be done, either:
3780 * the case-sensitivity of the build filesystem of Perl does not
3781 * help in guessing the case-sensitivity of the runtime environment.
3784 PL_hints |= HINT_BLOCK_SCOPE;
3785 PL_copline = NOLINE;
3787 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3790 if (!PL_madskills) {
3791 /* FIXME - don't allocate pegop if !PL_madskills */
3800 =head1 Embedding Functions
3802 =for apidoc load_module
3804 Loads the module whose name is pointed to by the string part of name.
3805 Note that the actual module name, not its filename, should be given.
3806 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3807 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3808 (or 0 for no flags). ver, if specified, provides version semantics
3809 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3810 arguments can be used to specify arguments to the module's import()
3811 method, similar to C<use Foo::Bar VERSION LIST>.
3816 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3819 va_start(args, ver);
3820 vload_module(flags, name, ver, &args);
3824 #ifdef PERL_IMPLICIT_CONTEXT
3826 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3830 va_start(args, ver);
3831 vload_module(flags, name, ver, &args);
3837 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3842 OP * const modname = newSVOP(OP_CONST, 0, name);
3843 modname->op_private |= OPpCONST_BARE;
3845 veop = newSVOP(OP_CONST, 0, ver);
3849 if (flags & PERL_LOADMOD_NOIMPORT) {
3850 imop = sawparens(newNULLLIST());
3852 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3853 imop = va_arg(*args, OP*);
3858 sv = va_arg(*args, SV*);
3860 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3861 sv = va_arg(*args, SV*);
3865 const line_t ocopline = PL_copline;
3866 COP * const ocurcop = PL_curcop;
3867 const int oexpect = PL_expect;
3869 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3870 veop, modname, imop);
3871 PL_expect = oexpect;
3872 PL_copline = ocopline;
3873 PL_curcop = ocurcop;
3878 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3884 if (!force_builtin) {
3885 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3886 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3887 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3888 gv = gvp ? *gvp : NULL;
3892 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3893 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3894 append_elem(OP_LIST, term,
3895 scalar(newUNOP(OP_RV2CV, 0,
3896 newGVOP(OP_GV, 0, gv))))));
3899 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3905 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3907 return newBINOP(OP_LSLICE, flags,
3908 list(force_list(subscript)),
3909 list(force_list(listval)) );
3913 S_is_list_assignment(pTHX_ register const OP *o)
3921 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3922 o = cUNOPo->op_first;
3924 flags = o->op_flags;
3926 if (type == OP_COND_EXPR) {
3927 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3928 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3933 yyerror("Assignment to both a list and a scalar");
3937 if (type == OP_LIST &&
3938 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3939 o->op_private & OPpLVAL_INTRO)
3942 if (type == OP_LIST || flags & OPf_PARENS ||
3943 type == OP_RV2AV || type == OP_RV2HV ||
3944 type == OP_ASLICE || type == OP_HSLICE)
3947 if (type == OP_PADAV || type == OP_PADHV)
3950 if (type == OP_RV2SV)
3957 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3963 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3964 return newLOGOP(optype, 0,
3965 mod(scalar(left), optype),
3966 newUNOP(OP_SASSIGN, 0, scalar(right)));
3969 return newBINOP(optype, OPf_STACKED,
3970 mod(scalar(left), optype), scalar(right));
3974 if (is_list_assignment(left)) {
3978 /* Grandfathering $[ assignment here. Bletch.*/
3979 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3980 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3981 left = mod(left, OP_AASSIGN);
3984 else if (left->op_type == OP_CONST) {
3986 /* Result of assignment is always 1 (or we'd be dead already) */
3987 return newSVOP(OP_CONST, 0, newSViv(1));
3989 curop = list(force_list(left));
3990 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3991 o->op_private = (U8)(0 | (flags >> 8));
3993 /* PL_generation sorcery:
3994 * an assignment like ($a,$b) = ($c,$d) is easier than
3995 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3996 * To detect whether there are common vars, the global var
3997 * PL_generation is incremented for each assign op we compile.
3998 * Then, while compiling the assign op, we run through all the
3999 * variables on both sides of the assignment, setting a spare slot
4000 * in each of them to PL_generation. If any of them already have
4001 * that value, we know we've got commonality. We could use a
4002 * single bit marker, but then we'd have to make 2 passes, first
4003 * to clear the flag, then to test and set it. To find somewhere
4004 * to store these values, evil chicanery is done with SvUVX().
4010 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4011 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4012 if (curop->op_type == OP_GV) {
4013 GV *gv = cGVOPx_gv(curop);
4015 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4017 GvASSIGN_GENERATION_set(gv, PL_generation);
4019 else if (curop->op_type == OP_PADSV ||
4020 curop->op_type == OP_PADAV ||
4021 curop->op_type == OP_PADHV ||
4022 curop->op_type == OP_PADANY)
4024 if (PAD_COMPNAME_GEN(curop->op_targ)
4025 == (STRLEN)PL_generation)
4027 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4030 else if (curop->op_type == OP_RV2CV)
4032 else if (curop->op_type == OP_RV2SV ||
4033 curop->op_type == OP_RV2AV ||
4034 curop->op_type == OP_RV2HV ||
4035 curop->op_type == OP_RV2GV) {
4036 if (lastop->op_type != OP_GV) /* funny deref? */
4039 else if (curop->op_type == OP_PUSHRE) {
4041 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4042 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4044 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4046 GvASSIGN_GENERATION_set(gv, PL_generation);
4050 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4053 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4055 GvASSIGN_GENERATION_set(gv, PL_generation);
4065 o->op_private |= OPpASSIGN_COMMON;
4068 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
4069 && (left->op_type == OP_LIST
4070 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4072 OP* lop = ((LISTOP*)left)->op_first;
4074 if (lop->op_type == OP_PADSV ||
4075 lop->op_type == OP_PADAV ||
4076 lop->op_type == OP_PADHV ||
4077 lop->op_type == OP_PADANY)
4079 if (lop->op_private & OPpPAD_STATE) {
4080 if (left->op_private & OPpLVAL_INTRO) {
4081 o->op_private |= OPpASSIGN_STATE;
4082 /* hijacking PADSTALE for uninitialized state variables */
4083 SvPADSTALE_on(PAD_SVl(lop->op_targ));
4085 else { /* we already checked for WARN_MISC before */
4086 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
4087 PAD_COMPNAME_PV(lop->op_targ));
4091 lop = lop->op_sibling;
4094 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4095 == (OPpLVAL_INTRO | OPpPAD_STATE))
4096 && ( left->op_type == OP_PADSV
4097 || left->op_type == OP_PADAV
4098 || left->op_type == OP_PADHV
4099 || left->op_type == OP_PADANY))
4101 o->op_private |= OPpASSIGN_STATE;
4102 /* hijacking PADSTALE for uninitialized state variables */
4103 SvPADSTALE_on(PAD_SVl(left->op_targ));
4106 if (right && right->op_type == OP_SPLIT) {
4107 OP* tmpop = ((LISTOP*)right)->op_first;
4108 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4109 PMOP * const pm = (PMOP*)tmpop;
4110 if (left->op_type == OP_RV2AV &&
4111 !(left->op_private & OPpLVAL_INTRO) &&
4112 !(o->op_private & OPpASSIGN_COMMON) )
4114 tmpop = ((UNOP*)left)->op_first;
4115 if (tmpop->op_type == OP_GV
4117 && !pm->op_pmreplrootu.op_pmtargetoff
4119 && !pm->op_pmreplrootu.op_pmtargetgv
4123 pm->op_pmreplrootu.op_pmtargetoff
4124 = cPADOPx(tmpop)->op_padix;
4125 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4127 pm->op_pmreplrootu.op_pmtargetgv
4128 = (GV*)cSVOPx(tmpop)->op_sv;
4129 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4131 pm->op_pmflags |= PMf_ONCE;
4132 tmpop = cUNOPo->op_first; /* to list (nulled) */
4133 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4134 tmpop->op_sibling = NULL; /* don't free split */
4135 right->op_next = tmpop->op_next; /* fix starting loc */
4137 op_getmad(o,right,'R'); /* blow off assign */
4139 op_free(o); /* blow off assign */
4141 right->op_flags &= ~OPf_WANT;
4142 /* "I don't know and I don't care." */
4147 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4148 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4150 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4152 sv_setiv(sv, PL_modcount+1);
4160 right = newOP(OP_UNDEF, 0);
4161 if (right->op_type == OP_READLINE) {
4162 right->op_flags |= OPf_STACKED;
4163 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4166 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4167 o = newBINOP(OP_SASSIGN, flags,
4168 scalar(right), mod(scalar(left), OP_SASSIGN) );
4174 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4175 o->op_private |= OPpCONST_ARYBASE;
4182 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4185 const U32 seq = intro_my();
4188 NewOp(1101, cop, 1, COP);
4189 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4190 cop->op_type = OP_DBSTATE;
4191 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4194 cop->op_type = OP_NEXTSTATE;
4195 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4197 cop->op_flags = (U8)flags;
4198 CopHINTS_set(cop, PL_hints);
4200 cop->op_private |= NATIVE_HINTS;
4202 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4203 cop->op_next = (OP*)cop;
4206 CopLABEL_set(cop, label);
4207 PL_hints |= HINT_BLOCK_SCOPE;
4210 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4211 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4213 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4214 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4215 if (cop->cop_hints_hash) {
4217 cop->cop_hints_hash->refcounted_he_refcnt++;
4218 HINTS_REFCNT_UNLOCK;
4221 if (PL_copline == NOLINE)
4222 CopLINE_set(cop, CopLINE(PL_curcop));
4224 CopLINE_set(cop, PL_copline);
4225 PL_copline = NOLINE;
4228 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4230 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4232 CopSTASH_set(cop, PL_curstash);
4234 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4235 AV *av = CopFILEAVx(PL_curcop);
4237 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4238 if (svp && *svp != &PL_sv_undef ) {
4239 (void)SvIOK_on(*svp);
4240 SvIV_set(*svp, PTR2IV(cop));
4245 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4250 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4253 return new_logop(type, flags, &first, &other);
4257 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4262 OP *first = *firstp;
4263 OP * const other = *otherp;
4265 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4266 return newBINOP(type, flags, scalar(first), scalar(other));
4268 scalarboolean(first);
4269 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4270 if (first->op_type == OP_NOT
4271 && (first->op_flags & OPf_SPECIAL)
4272 && (first->op_flags & OPf_KIDS)) {
4273 if (type == OP_AND || type == OP_OR) {
4279 first = *firstp = cUNOPo->op_first;
4281 first->op_next = o->op_next;
4282 cUNOPo->op_first = NULL;
4284 op_getmad(o,first,'O');
4290 if (first->op_type == OP_CONST) {
4291 if (first->op_private & OPpCONST_STRICT)
4292 no_bareword_allowed(first);
4293 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4294 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4295 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4296 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4297 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4299 if (other->op_type == OP_CONST)
4300 other->op_private |= OPpCONST_SHORTCIRCUIT;
4302 OP *newop = newUNOP(OP_NULL, 0, other);
4303 op_getmad(first, newop, '1');
4304 newop->op_targ = type; /* set "was" field */
4311 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4312 const OP *o2 = other;
4313 if ( ! (o2->op_type == OP_LIST
4314 && (( o2 = cUNOPx(o2)->op_first))
4315 && o2->op_type == OP_PUSHMARK
4316 && (( o2 = o2->op_sibling)) )
4319 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4320 || o2->op_type == OP_PADHV)
4321 && o2->op_private & OPpLVAL_INTRO
4322 && ckWARN(WARN_DEPRECATED))
4324 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4325 "Deprecated use of my() in false conditional");
4329 if (first->op_type == OP_CONST)
4330 first->op_private |= OPpCONST_SHORTCIRCUIT;
4332 first = newUNOP(OP_NULL, 0, first);
4333 op_getmad(other, first, '2');
4334 first->op_targ = type; /* set "was" field */
4341 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4342 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4344 const OP * const k1 = ((UNOP*)first)->op_first;
4345 const OP * const k2 = k1->op_sibling;
4347 switch (first->op_type)
4350 if (k2 && k2->op_type == OP_READLINE
4351 && (k2->op_flags & OPf_STACKED)
4352 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4354 warnop = k2->op_type;
4359 if (k1->op_type == OP_READDIR
4360 || k1->op_type == OP_GLOB
4361 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4362 || k1->op_type == OP_EACH)
4364 warnop = ((k1->op_type == OP_NULL)
4365 ? (OPCODE)k1->op_targ : k1->op_type);
4370 const line_t oldline = CopLINE(PL_curcop);
4371 CopLINE_set(PL_curcop, PL_copline);
4372 Perl_warner(aTHX_ packWARN(WARN_MISC),
4373 "Value of %s%s can be \"0\"; test with defined()",
4375 ((warnop == OP_READLINE || warnop == OP_GLOB)
4376 ? " construct" : "() operator"));
4377 CopLINE_set(PL_curcop, oldline);
4384 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4385 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4387 NewOp(1101, logop, 1, LOGOP);
4389 logop->op_type = (OPCODE)type;
4390 logop->op_ppaddr = PL_ppaddr[type];
4391 logop->op_first = first;
4392 logop->op_flags = (U8)(flags | OPf_KIDS);
4393 logop->op_other = LINKLIST(other);
4394 logop->op_private = (U8)(1 | (flags >> 8));
4396 /* establish postfix order */
4397 logop->op_next = LINKLIST(first);
4398 first->op_next = (OP*)logop;
4399 first->op_sibling = other;
4401 CHECKOP(type,logop);
4403 o = newUNOP(OP_NULL, 0, (OP*)logop);
4410 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4418 return newLOGOP(OP_AND, 0, first, trueop);
4420 return newLOGOP(OP_OR, 0, first, falseop);
4422 scalarboolean(first);
4423 if (first->op_type == OP_CONST) {
4424 /* Left or right arm of the conditional? */
4425 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4426 OP *live = left ? trueop : falseop;
4427 OP *const dead = left ? falseop : trueop;
4428 if (first->op_private & OPpCONST_BARE &&
4429 first->op_private & OPpCONST_STRICT) {
4430 no_bareword_allowed(first);
4433 /* This is all dead code when PERL_MAD is not defined. */
4434 live = newUNOP(OP_NULL, 0, live);
4435 op_getmad(first, live, 'C');
4436 op_getmad(dead, live, left ? 'e' : 't');
4443 NewOp(1101, logop, 1, LOGOP);
4444 logop->op_type = OP_COND_EXPR;
4445 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4446 logop->op_first = first;
4447 logop->op_flags = (U8)(flags | OPf_KIDS);
4448 logop->op_private = (U8)(1 | (flags >> 8));
4449 logop->op_other = LINKLIST(trueop);
4450 logop->op_next = LINKLIST(falseop);
4452 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4455 /* establish postfix order */
4456 start = LINKLIST(first);
4457 first->op_next = (OP*)logop;
4459 first->op_sibling = trueop;
4460 trueop->op_sibling = falseop;
4461 o = newUNOP(OP_NULL, 0, (OP*)logop);
4463 trueop->op_next = falseop->op_next = o;
4470 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4479 NewOp(1101, range, 1, LOGOP);
4481 range->op_type = OP_RANGE;
4482 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4483 range->op_first = left;
4484 range->op_flags = OPf_KIDS;
4485 leftstart = LINKLIST(left);
4486 range->op_other = LINKLIST(right);
4487 range->op_private = (U8)(1 | (flags >> 8));
4489 left->op_sibling = right;
4491 range->op_next = (OP*)range;
4492 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4493 flop = newUNOP(OP_FLOP, 0, flip);
4494 o = newUNOP(OP_NULL, 0, flop);
4496 range->op_next = leftstart;
4498 left->op_next = flip;
4499 right->op_next = flop;
4501 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4502 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4503 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4504 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4506 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4507 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4510 if (!flip->op_private || !flop->op_private)
4511 linklist(o); /* blow off optimizer unless constant */
4517 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4522 const bool once = block && block->op_flags & OPf_SPECIAL &&
4523 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4525 PERL_UNUSED_ARG(debuggable);
4528 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4529 return block; /* do {} while 0 does once */
4530 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4531 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4532 expr = newUNOP(OP_DEFINED, 0,
4533 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4534 } else if (expr->op_flags & OPf_KIDS) {
4535 const OP * const k1 = ((UNOP*)expr)->op_first;
4536 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4537 switch (expr->op_type) {
4539 if (k2 && k2->op_type == OP_READLINE
4540 && (k2->op_flags & OPf_STACKED)
4541 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4542 expr = newUNOP(OP_DEFINED, 0, expr);
4546 if (k1 && (k1->op_type == OP_READDIR
4547 || k1->op_type == OP_GLOB
4548 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4549 || k1->op_type == OP_EACH))
4550 expr = newUNOP(OP_DEFINED, 0, expr);
4556 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4557 * op, in listop. This is wrong. [perl #27024] */
4559 block = newOP(OP_NULL, 0);
4560 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4561 o = new_logop(OP_AND, 0, &expr, &listop);
4564 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4566 if (once && o != listop)
4567 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4570 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4572 o->op_flags |= flags;
4574 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4579 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4580 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4589 PERL_UNUSED_ARG(debuggable);
4592 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4593 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4594 expr = newUNOP(OP_DEFINED, 0,
4595 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4596 } else if (expr->op_flags & OPf_KIDS) {
4597 const OP * const k1 = ((UNOP*)expr)->op_first;
4598 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4599 switch (expr->op_type) {
4601 if (k2 && k2->op_type == OP_READLINE
4602 && (k2->op_flags & OPf_STACKED)
4603 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4604 expr = newUNOP(OP_DEFINED, 0, expr);
4608 if (k1 && (k1->op_type == OP_READDIR
4609 || k1->op_type == OP_GLOB
4610 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4611 || k1->op_type == OP_EACH))
4612 expr = newUNOP(OP_DEFINED, 0, expr);
4619 block = newOP(OP_NULL, 0);
4620 else if (cont || has_my) {
4621 block = scope(block);
4625 next = LINKLIST(cont);
4628 OP * const unstack = newOP(OP_UNSTACK, 0);
4631 cont = append_elem(OP_LINESEQ, cont, unstack);
4635 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4637 redo = LINKLIST(listop);
4640 PL_copline = (line_t)whileline;
4642 o = new_logop(OP_AND, 0, &expr, &listop);
4643 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4644 op_free(expr); /* oops, it's a while (0) */
4646 return NULL; /* listop already freed by new_logop */
4649 ((LISTOP*)listop)->op_last->op_next =
4650 (o == listop ? redo : LINKLIST(o));
4656 NewOp(1101,loop,1,LOOP);
4657 loop->op_type = OP_ENTERLOOP;
4658 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4659 loop->op_private = 0;
4660 loop->op_next = (OP*)loop;
4663 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4665 loop->op_redoop = redo;
4666 loop->op_lastop = o;
4667 o->op_private |= loopflags;
4670 loop->op_nextop = next;
4672 loop->op_nextop = o;
4674 o->op_flags |= flags;
4675 o->op_private |= (flags >> 8);
4680 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4685 PADOFFSET padoff = 0;
4691 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4692 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4693 sv->op_type = OP_RV2GV;
4694 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4696 /* The op_type check is needed to prevent a possible segfault
4697 * if the loop variable is undeclared and 'strict vars' is in
4698 * effect. This is illegal but is nonetheless parsed, so we
4699 * may reach this point with an OP_CONST where we're expecting
4702 if (cUNOPx(sv)->op_first->op_type == OP_GV
4703 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4704 iterpflags |= OPpITER_DEF;
4706 else if (sv->op_type == OP_PADSV) { /* private variable */
4707 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4708 padoff = sv->op_targ;
4718 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4720 SV *const namesv = PAD_COMPNAME_SV(padoff);
4722 const char *const name = SvPV_const(namesv, len);
4724 if (len == 2 && name[0] == '$' && name[1] == '_')
4725 iterpflags |= OPpITER_DEF;
4729 const PADOFFSET offset = pad_findmy("$_");
4730 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4731 sv = newGVOP(OP_GV, 0, PL_defgv);
4736 iterpflags |= OPpITER_DEF;
4738 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4739 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4740 iterflags |= OPf_STACKED;
4742 else if (expr->op_type == OP_NULL &&
4743 (expr->op_flags & OPf_KIDS) &&
4744 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4746 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4747 * set the STACKED flag to indicate that these values are to be
4748 * treated as min/max values by 'pp_iterinit'.
4750 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4751 LOGOP* const range = (LOGOP*) flip->op_first;
4752 OP* const left = range->op_first;
4753 OP* const right = left->op_sibling;
4756 range->op_flags &= ~OPf_KIDS;
4757 range->op_first = NULL;
4759 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4760 listop->op_first->op_next = range->op_next;
4761 left->op_next = range->op_other;
4762 right->op_next = (OP*)listop;
4763 listop->op_next = listop->op_first;
4766 op_getmad(expr,(OP*)listop,'O');
4770 expr = (OP*)(listop);
4772 iterflags |= OPf_STACKED;
4775 expr = mod(force_list(expr), OP_GREPSTART);
4778 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4779 append_elem(OP_LIST, expr, scalar(sv))));
4780 assert(!loop->op_next);
4781 /* for my $x () sets OPpLVAL_INTRO;
4782 * for our $x () sets OPpOUR_INTRO */
4783 loop->op_private = (U8)iterpflags;
4784 #ifdef PL_OP_SLAB_ALLOC
4787 NewOp(1234,tmp,1,LOOP);
4788 Copy(loop,tmp,1,LISTOP);
4789 S_op_destroy(aTHX_ (OP*)loop);
4793 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4795 loop->op_targ = padoff;
4796 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4798 op_getmad(madsv, (OP*)loop, 'v');
4799 PL_copline = forline;
4800 return newSTATEOP(0, label, wop);
4804 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4809 if (type != OP_GOTO || label->op_type == OP_CONST) {
4810 /* "last()" means "last" */
4811 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4812 o = newOP(type, OPf_SPECIAL);
4814 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4815 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4819 op_getmad(label,o,'L');
4825 /* Check whether it's going to be a goto &function */
4826 if (label->op_type == OP_ENTERSUB
4827 && !(label->op_flags & OPf_STACKED))
4828 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4829 o = newUNOP(type, OPf_STACKED, label);
4831 PL_hints |= HINT_BLOCK_SCOPE;
4835 /* if the condition is a literal array or hash
4836 (or @{ ... } etc), make a reference to it.
4839 S_ref_array_or_hash(pTHX_ OP *cond)
4842 && (cond->op_type == OP_RV2AV
4843 || cond->op_type == OP_PADAV
4844 || cond->op_type == OP_RV2HV
4845 || cond->op_type == OP_PADHV))
4847 return newUNOP(OP_REFGEN,
4848 0, mod(cond, OP_REFGEN));
4854 /* These construct the optree fragments representing given()
4857 entergiven and enterwhen are LOGOPs; the op_other pointer
4858 points up to the associated leave op. We need this so we
4859 can put it in the context and make break/continue work.
4860 (Also, of course, pp_enterwhen will jump straight to
4861 op_other if the match fails.)
4865 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4866 I32 enter_opcode, I32 leave_opcode,
4867 PADOFFSET entertarg)
4873 NewOp(1101, enterop, 1, LOGOP);
4874 enterop->op_type = enter_opcode;
4875 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4876 enterop->op_flags = (U8) OPf_KIDS;
4877 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4878 enterop->op_private = 0;
4880 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4883 enterop->op_first = scalar(cond);
4884 cond->op_sibling = block;
4886 o->op_next = LINKLIST(cond);
4887 cond->op_next = (OP *) enterop;
4890 /* This is a default {} block */
4891 enterop->op_first = block;
4892 enterop->op_flags |= OPf_SPECIAL;
4894 o->op_next = (OP *) enterop;
4897 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4898 entergiven and enterwhen both
4901 enterop->op_next = LINKLIST(block);
4902 block->op_next = enterop->op_other = o;
4907 /* Does this look like a boolean operation? For these purposes
4908 a boolean operation is:
4909 - a subroutine call [*]
4910 - a logical connective
4911 - a comparison operator
4912 - a filetest operator, with the exception of -s -M -A -C
4913 - defined(), exists() or eof()
4914 - /$re/ or $foo =~ /$re/
4916 [*] possibly surprising
4919 S_looks_like_bool(pTHX_ const OP *o)
4922 switch(o->op_type) {
4924 return looks_like_bool(cLOGOPo->op_first);
4928 looks_like_bool(cLOGOPo->op_first)
4929 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4933 case OP_NOT: case OP_XOR:
4934 /* Note that OP_DOR is not here */
4936 case OP_EQ: case OP_NE: case OP_LT:
4937 case OP_GT: case OP_LE: case OP_GE:
4939 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4940 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4942 case OP_SEQ: case OP_SNE: case OP_SLT:
4943 case OP_SGT: case OP_SLE: case OP_SGE:
4947 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4948 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4949 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4950 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4951 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4952 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4953 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4954 case OP_FTTEXT: case OP_FTBINARY:
4956 case OP_DEFINED: case OP_EXISTS:
4957 case OP_MATCH: case OP_EOF:
4962 /* Detect comparisons that have been optimized away */
4963 if (cSVOPo->op_sv == &PL_sv_yes
4964 || cSVOPo->op_sv == &PL_sv_no)
4975 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4979 return newGIVWHENOP(
4980 ref_array_or_hash(cond),
4982 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4986 /* If cond is null, this is a default {} block */
4988 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4990 const bool cond_llb = (!cond || looks_like_bool(cond));
4996 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4998 scalar(ref_array_or_hash(cond)));
5001 return newGIVWHENOP(
5003 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5004 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5008 =for apidoc cv_undef
5010 Clear out all the active components of a CV. This can happen either
5011 by an explicit C<undef &foo>, or by the reference count going to zero.
5012 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5013 children can still follow the full lexical scope chain.
5019 Perl_cv_undef(pTHX_ CV *cv)
5023 if (CvFILE(cv) && !CvISXSUB(cv)) {
5024 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5025 Safefree(CvFILE(cv));
5030 if (!CvISXSUB(cv) && CvROOT(cv)) {
5031 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5032 Perl_croak(aTHX_ "Can't undef active subroutine");
5035 PAD_SAVE_SETNULLPAD();
5037 op_free(CvROOT(cv));
5042 SvPOK_off((SV*)cv); /* forget prototype */
5047 /* remove CvOUTSIDE unless this is an undef rather than a free */
5048 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5049 if (!CvWEAKOUTSIDE(cv))
5050 SvREFCNT_dec(CvOUTSIDE(cv));
5051 CvOUTSIDE(cv) = NULL;
5054 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5057 if (CvISXSUB(cv) && CvXSUB(cv)) {
5060 /* delete all flags except WEAKOUTSIDE */
5061 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5065 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5068 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5069 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5070 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5071 || (p && (len != SvCUR(cv) /* Not the same length. */
5072 || memNE(p, SvPVX_const(cv), len))))
5073 && ckWARN_d(WARN_PROTOTYPE)) {
5074 SV* const msg = sv_newmortal();
5078 gv_efullname3(name = sv_newmortal(), gv, NULL);
5079 sv_setpvs(msg, "Prototype mismatch:");
5081 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5083 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5085 sv_catpvs(msg, ": none");
5086 sv_catpvs(msg, " vs ");
5088 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5090 sv_catpvs(msg, "none");
5091 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5095 static void const_sv_xsub(pTHX_ CV* cv);
5099 =head1 Optree Manipulation Functions
5101 =for apidoc cv_const_sv
5103 If C<cv> is a constant sub eligible for inlining. returns the constant
5104 value returned by the sub. Otherwise, returns NULL.
5106 Constant subs can be created with C<newCONSTSUB> or as described in
5107 L<perlsub/"Constant Functions">.
5112 Perl_cv_const_sv(pTHX_ CV *cv)
5114 PERL_UNUSED_CONTEXT;
5117 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5119 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5122 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5123 * Can be called in 3 ways:
5126 * look for a single OP_CONST with attached value: return the value
5128 * cv && CvCLONE(cv) && !CvCONST(cv)
5130 * examine the clone prototype, and if contains only a single
5131 * OP_CONST referencing a pad const, or a single PADSV referencing
5132 * an outer lexical, return a non-zero value to indicate the CV is
5133 * a candidate for "constizing" at clone time
5137 * We have just cloned an anon prototype that was marked as a const
5138 * candidiate. Try to grab the current value, and in the case of
5139 * PADSV, ignore it if it has multiple references. Return the value.
5143 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5151 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5152 o = cLISTOPo->op_first->op_sibling;
5154 for (; o; o = o->op_next) {
5155 const OPCODE type = o->op_type;
5157 if (sv && o->op_next == o)
5159 if (o->op_next != o) {
5160 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5162 if (type == OP_DBSTATE)
5165 if (type == OP_LEAVESUB || type == OP_RETURN)
5169 if (type == OP_CONST && cSVOPo->op_sv)
5171 else if (cv && type == OP_CONST) {
5172 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5176 else if (cv && type == OP_PADSV) {
5177 if (CvCONST(cv)) { /* newly cloned anon */
5178 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5179 /* the candidate should have 1 ref from this pad and 1 ref
5180 * from the parent */
5181 if (!sv || SvREFCNT(sv) != 2)
5188 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5189 sv = &PL_sv_undef; /* an arbitrary non-null value */
5204 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5207 /* This would be the return value, but the return cannot be reached. */
5208 OP* pegop = newOP(OP_NULL, 0);
5211 PERL_UNUSED_ARG(floor);
5221 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5223 NORETURN_FUNCTION_END;
5228 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5230 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5234 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5241 register CV *cv = NULL;
5243 /* If the subroutine has no body, no attributes, and no builtin attributes
5244 then it's just a sub declaration, and we may be able to get away with
5245 storing with a placeholder scalar in the symbol table, rather than a
5246 full GV and CV. If anything is present then it will take a full CV to
5248 const I32 gv_fetch_flags
5249 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5251 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5252 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5255 assert(proto->op_type == OP_CONST);
5256 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5261 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5262 SV * const sv = sv_newmortal();
5263 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5264 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5265 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5266 aname = SvPVX_const(sv);
5271 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5272 : gv_fetchpv(aname ? aname
5273 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5274 gv_fetch_flags, SVt_PVCV);
5276 if (!PL_madskills) {
5285 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5286 maximum a prototype before. */
5287 if (SvTYPE(gv) > SVt_NULL) {
5288 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5289 && ckWARN_d(WARN_PROTOTYPE))
5291 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5293 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5296 sv_setpvn((SV*)gv, ps, ps_len);
5298 sv_setiv((SV*)gv, -1);
5300 SvREFCNT_dec(PL_compcv);
5301 cv = PL_compcv = NULL;
5305 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5307 #ifdef GV_UNIQUE_CHECK
5308 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5309 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5313 if (!block || !ps || *ps || attrs
5314 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5316 || block->op_type == OP_NULL
5321 const_sv = op_const_sv(block, NULL);
5324 const bool exists = CvROOT(cv) || CvXSUB(cv);
5326 #ifdef GV_UNIQUE_CHECK
5327 if (exists && GvUNIQUE(gv)) {
5328 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5332 /* if the subroutine doesn't exist and wasn't pre-declared
5333 * with a prototype, assume it will be AUTOLOADed,
5334 * skipping the prototype check
5336 if (exists || SvPOK(cv))
5337 cv_ckproto_len(cv, gv, ps, ps_len);
5338 /* already defined (or promised)? */
5339 if (exists || GvASSUMECV(gv)) {
5342 || block->op_type == OP_NULL
5345 if (CvFLAGS(PL_compcv)) {
5346 /* might have had built-in attrs applied */
5347 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5349 /* just a "sub foo;" when &foo is already defined */
5350 SAVEFREESV(PL_compcv);
5355 && block->op_type != OP_NULL
5358 if (ckWARN(WARN_REDEFINE)
5360 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5362 const line_t oldline = CopLINE(PL_curcop);
5363 if (PL_copline != NOLINE)
5364 CopLINE_set(PL_curcop, PL_copline);
5365 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5366 CvCONST(cv) ? "Constant subroutine %s redefined"
5367 : "Subroutine %s redefined", name);
5368 CopLINE_set(PL_curcop, oldline);
5371 if (!PL_minus_c) /* keep old one around for madskills */
5374 /* (PL_madskills unset in used file.) */
5382 SvREFCNT_inc_simple_void_NN(const_sv);
5384 assert(!CvROOT(cv) && !CvCONST(cv));
5385 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5386 CvXSUBANY(cv).any_ptr = const_sv;
5387 CvXSUB(cv) = const_sv_xsub;
5393 cv = newCONSTSUB(NULL, name, const_sv);
5395 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5396 (CvGV(cv) && GvSTASH(CvGV(cv)))
5405 SvREFCNT_dec(PL_compcv);
5413 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5414 * before we clobber PL_compcv.
5418 || block->op_type == OP_NULL
5422 /* Might have had built-in attributes applied -- propagate them. */
5423 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5424 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5425 stash = GvSTASH(CvGV(cv));
5426 else if (CvSTASH(cv))
5427 stash = CvSTASH(cv);
5429 stash = PL_curstash;
5432 /* possibly about to re-define existing subr -- ignore old cv */
5433 rcv = (SV*)PL_compcv;
5434 if (name && GvSTASH(gv))
5435 stash = GvSTASH(gv);
5437 stash = PL_curstash;
5439 apply_attrs(stash, rcv, attrs, FALSE);
5441 if (cv) { /* must reuse cv if autoloaded */
5448 || block->op_type == OP_NULL) && !PL_madskills
5451 /* got here with just attrs -- work done, so bug out */
5452 SAVEFREESV(PL_compcv);
5455 /* transfer PL_compcv to cv */
5457 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5458 if (!CvWEAKOUTSIDE(cv))
5459 SvREFCNT_dec(CvOUTSIDE(cv));
5460 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5461 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5462 CvOUTSIDE(PL_compcv) = 0;
5463 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5464 CvPADLIST(PL_compcv) = 0;
5465 /* inner references to PL_compcv must be fixed up ... */
5466 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5467 /* ... before we throw it away */
5468 SvREFCNT_dec(PL_compcv);
5470 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5471 ++PL_sub_generation;
5478 if (strEQ(name, "import")) {
5479 PL_formfeed = (SV*)cv;
5480 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5484 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5488 CvFILE_set_from_cop(cv, PL_curcop);
5489 CvSTASH(cv) = PL_curstash;
5492 sv_setpvn((SV*)cv, ps, ps_len);
5494 if (PL_error_count) {
5498 const char *s = strrchr(name, ':');
5500 if (strEQ(s, "BEGIN")) {
5501 const char not_safe[] =
5502 "BEGIN not safe after errors--compilation aborted";
5503 if (PL_in_eval & EVAL_KEEPERR)
5504 Perl_croak(aTHX_ not_safe);
5506 /* force display of errors found but not reported */
5507 sv_catpv(ERRSV, not_safe);
5508 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5518 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5519 mod(scalarseq(block), OP_LEAVESUBLV));
5520 block->op_attached = 1;
5523 /* This makes sub {}; work as expected. */
5524 if (block->op_type == OP_STUB) {
5525 OP* const newblock = newSTATEOP(0, NULL, 0);
5527 op_getmad(block,newblock,'B');
5534 block->op_attached = 1;
5535 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5537 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5538 OpREFCNT_set(CvROOT(cv), 1);
5539 CvSTART(cv) = LINKLIST(CvROOT(cv));
5540 CvROOT(cv)->op_next = 0;
5541 CALL_PEEP(CvSTART(cv));
5543 /* now that optimizer has done its work, adjust pad values */
5545 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5548 assert(!CvCONST(cv));
5549 if (ps && !*ps && op_const_sv(block, cv))
5553 if (name || aname) {
5554 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5555 SV * const sv = newSV(0);
5556 SV * const tmpstr = sv_newmortal();
5557 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5558 GV_ADDMULTI, SVt_PVHV);
5561 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5563 (long)PL_subline, (long)CopLINE(PL_curcop));
5564 gv_efullname3(tmpstr, gv, NULL);
5565 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5566 hv = GvHVn(db_postponed);
5567 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5568 CV * const pcv = GvCV(db_postponed);
5574 call_sv((SV*)pcv, G_DISCARD);
5579 if (name && !PL_error_count)
5580 process_special_blocks(name, gv, cv);
5584 PL_copline = NOLINE;
5590 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5593 const char *const colon = strrchr(fullname,':');
5594 const char *const name = colon ? colon + 1 : fullname;
5597 if (strEQ(name, "BEGIN")) {
5598 const I32 oldscope = PL_scopestack_ix;
5600 SAVECOPFILE(&PL_compiling);
5601 SAVECOPLINE(&PL_compiling);
5603 DEBUG_x( dump_sub(gv) );
5604 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5605 GvCV(gv) = 0; /* cv has been hijacked */
5606 call_list(oldscope, PL_beginav);
5608 PL_curcop = &PL_compiling;
5609 CopHINTS_set(&PL_compiling, PL_hints);
5616 if strEQ(name, "END") {
5617 DEBUG_x( dump_sub(gv) );
5618 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5621 } else if (*name == 'U') {
5622 if (strEQ(name, "UNITCHECK")) {
5623 /* It's never too late to run a unitcheck block */
5624 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5628 } else if (*name == 'C') {
5629 if (strEQ(name, "CHECK")) {
5630 if (PL_main_start && ckWARN(WARN_VOID))
5631 Perl_warner(aTHX_ packWARN(WARN_VOID),
5632 "Too late to run CHECK block");
5633 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5637 } else if (*name == 'I') {
5638 if (strEQ(name, "INIT")) {
5639 if (PL_main_start && ckWARN(WARN_VOID))
5640 Perl_warner(aTHX_ packWARN(WARN_VOID),
5641 "Too late to run INIT block");
5642 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5648 DEBUG_x( dump_sub(gv) );
5649 GvCV(gv) = 0; /* cv has been hijacked */
5654 =for apidoc newCONSTSUB
5656 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5657 eligible for inlining at compile-time.
5663 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5668 const char *const temp_p = CopFILE(PL_curcop);
5669 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5671 SV *const temp_sv = CopFILESV(PL_curcop);
5673 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5675 char *const file = savepvn(temp_p, temp_p ? len : 0);
5679 SAVECOPLINE(PL_curcop);
5680 CopLINE_set(PL_curcop, PL_copline);
5683 PL_hints &= ~HINT_BLOCK_SCOPE;
5686 SAVESPTR(PL_curstash);
5687 SAVECOPSTASH(PL_curcop);
5688 PL_curstash = stash;
5689 CopSTASH_set(PL_curcop,stash);
5692 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5693 and so doesn't get free()d. (It's expected to be from the C pre-
5694 processor __FILE__ directive). But we need a dynamically allocated one,
5695 and we need it to get freed. */
5696 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5697 CvXSUBANY(cv).any_ptr = sv;
5703 CopSTASH_free(PL_curcop);
5711 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5712 const char *const filename, const char *const proto,
5715 CV *cv = newXS(name, subaddr, filename);
5717 if (flags & XS_DYNAMIC_FILENAME) {
5718 /* We need to "make arrangements" (ie cheat) to ensure that the
5719 filename lasts as long as the PVCV we just created, but also doesn't
5721 STRLEN filename_len = strlen(filename);
5722 STRLEN proto_and_file_len = filename_len;
5723 char *proto_and_file;
5727 proto_len = strlen(proto);
5728 proto_and_file_len += proto_len;
5730 Newx(proto_and_file, proto_and_file_len + 1, char);
5731 Copy(proto, proto_and_file, proto_len, char);
5732 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5735 proto_and_file = savepvn(filename, filename_len);
5738 /* This gets free()d. :-) */
5739 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5740 SV_HAS_TRAILING_NUL);
5742 /* This gives us the correct prototype, rather than one with the
5743 file name appended. */
5744 SvCUR_set(cv, proto_len);
5748 CvFILE(cv) = proto_and_file + proto_len;
5750 sv_setpv((SV *)cv, proto);
5756 =for apidoc U||newXS
5758 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5759 static storage, as it is used directly as CvFILE(), without a copy being made.
5765 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5768 GV * const gv = gv_fetchpv(name ? name :
5769 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5770 GV_ADDMULTI, SVt_PVCV);
5774 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5776 if ((cv = (name ? GvCV(gv) : NULL))) {
5778 /* just a cached method */
5782 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5783 /* already defined (or promised) */
5784 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5785 if (ckWARN(WARN_REDEFINE)) {
5786 GV * const gvcv = CvGV(cv);
5788 HV * const stash = GvSTASH(gvcv);
5790 const char *redefined_name = HvNAME_get(stash);
5791 if ( strEQ(redefined_name,"autouse") ) {
5792 const line_t oldline = CopLINE(PL_curcop);
5793 if (PL_copline != NOLINE)
5794 CopLINE_set(PL_curcop, PL_copline);
5795 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5796 CvCONST(cv) ? "Constant subroutine %s redefined"
5797 : "Subroutine %s redefined"
5799 CopLINE_set(PL_curcop, oldline);
5809 if (cv) /* must reuse cv if autoloaded */
5812 cv = (CV*)newSV_type(SVt_PVCV);
5816 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5820 (void)gv_fetchfile(filename);
5821 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5822 an external constant string */
5824 CvXSUB(cv) = subaddr;
5827 process_special_blocks(name, gv, cv);
5839 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5844 OP* pegop = newOP(OP_NULL, 0);
5848 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5849 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5851 #ifdef GV_UNIQUE_CHECK
5853 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5857 if ((cv = GvFORM(gv))) {
5858 if (ckWARN(WARN_REDEFINE)) {
5859 const line_t oldline = CopLINE(PL_curcop);
5860 if (PL_copline != NOLINE)
5861 CopLINE_set(PL_curcop, PL_copline);
5862 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5863 o ? "Format %"SVf" redefined"
5864 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5865 CopLINE_set(PL_curcop, oldline);
5872 CvFILE_set_from_cop(cv, PL_curcop);
5875 pad_tidy(padtidy_FORMAT);
5876 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5877 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5878 OpREFCNT_set(CvROOT(cv), 1);
5879 CvSTART(cv) = LINKLIST(CvROOT(cv));
5880 CvROOT(cv)->op_next = 0;
5881 CALL_PEEP(CvSTART(cv));
5883 op_getmad(o,pegop,'n');
5884 op_getmad_weak(block, pegop, 'b');
5888 PL_copline = NOLINE;
5896 Perl_newANONLIST(pTHX_ OP *o)
5898 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5902 Perl_newANONHASH(pTHX_ OP *o)
5904 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5908 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5910 return newANONATTRSUB(floor, proto, NULL, block);
5914 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5916 return newUNOP(OP_REFGEN, 0,
5917 newSVOP(OP_ANONCODE, 0,
5918 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5922 Perl_oopsAV(pTHX_ OP *o)
5925 switch (o->op_type) {
5927 o->op_type = OP_PADAV;
5928 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5929 return ref(o, OP_RV2AV);
5932 o->op_type = OP_RV2AV;
5933 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5938 if (ckWARN_d(WARN_INTERNAL))
5939 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5946 Perl_oopsHV(pTHX_ OP *o)
5949 switch (o->op_type) {
5952 o->op_type = OP_PADHV;
5953 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5954 return ref(o, OP_RV2HV);
5958 o->op_type = OP_RV2HV;
5959 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5964 if (ckWARN_d(WARN_INTERNAL))
5965 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5972 Perl_newAVREF(pTHX_ OP *o)
5975 if (o->op_type == OP_PADANY) {
5976 o->op_type = OP_PADAV;
5977 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5980 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5981 && ckWARN(WARN_DEPRECATED)) {
5982 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5983 "Using an array as a reference is deprecated");
5985 return newUNOP(OP_RV2AV, 0, scalar(o));
5989 Perl_newGVREF(pTHX_ I32 type, OP *o)
5991 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5992 return newUNOP(OP_NULL, 0, o);
5993 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5997 Perl_newHVREF(pTHX_ OP *o)
6000 if (o->op_type == OP_PADANY) {
6001 o->op_type = OP_PADHV;
6002 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6005 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6006 && ckWARN(WARN_DEPRECATED)) {
6007 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6008 "Using a hash as a reference is deprecated");
6010 return newUNOP(OP_RV2HV, 0, scalar(o));
6014 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6016 return newUNOP(OP_RV2CV, flags, scalar(o));
6020 Perl_newSVREF(pTHX_ OP *o)
6023 if (o->op_type == OP_PADANY) {
6024 o->op_type = OP_PADSV;
6025 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6028 return newUNOP(OP_RV2SV, 0, scalar(o));
6031 /* Check routines. See the comments at the top of this file for details
6032 * on when these are called */
6035 Perl_ck_anoncode(pTHX_ OP *o)
6037 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6039 cSVOPo->op_sv = NULL;
6044 Perl_ck_bitop(pTHX_ OP *o)
6047 #define OP_IS_NUMCOMPARE(op) \
6048 ((op) == OP_LT || (op) == OP_I_LT || \
6049 (op) == OP_GT || (op) == OP_I_GT || \
6050 (op) == OP_LE || (op) == OP_I_LE || \
6051 (op) == OP_GE || (op) == OP_I_GE || \
6052 (op) == OP_EQ || (op) == OP_I_EQ || \
6053 (op) == OP_NE || (op) == OP_I_NE || \
6054 (op) == OP_NCMP || (op) == OP_I_NCMP)
6055 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6056 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6057 && (o->op_type == OP_BIT_OR
6058 || o->op_type == OP_BIT_AND
6059 || o->op_type == OP_BIT_XOR))
6061 const OP * const left = cBINOPo->op_first;
6062 const OP * const right = left->op_sibling;
6063 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6064 (left->op_flags & OPf_PARENS) == 0) ||
6065 (OP_IS_NUMCOMPARE(right->op_type) &&
6066 (right->op_flags & OPf_PARENS) == 0))
6067 if (ckWARN(WARN_PRECEDENCE))
6068 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6069 "Possible precedence problem on bitwise %c operator",
6070 o->op_type == OP_BIT_OR ? '|'
6071 : o->op_type == OP_BIT_AND ? '&' : '^'
6078 Perl_ck_concat(pTHX_ OP *o)
6080 const OP * const kid = cUNOPo->op_first;
6081 PERL_UNUSED_CONTEXT;
6082 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6083 !(kUNOP->op_first->op_flags & OPf_MOD))
6084 o->op_flags |= OPf_STACKED;
6089 Perl_ck_spair(pTHX_ OP *o)
6092 if (o->op_flags & OPf_KIDS) {
6095 const OPCODE type = o->op_type;
6096 o = modkids(ck_fun(o), type);
6097 kid = cUNOPo->op_first;
6098 newop = kUNOP->op_first->op_sibling;
6100 const OPCODE type = newop->op_type;
6101 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6102 type == OP_PADAV || type == OP_PADHV ||
6103 type == OP_RV2AV || type == OP_RV2HV)
6107 op_getmad(kUNOP->op_first,newop,'K');
6109 op_free(kUNOP->op_first);
6111 kUNOP->op_first = newop;
6113 o->op_ppaddr = PL_ppaddr[++o->op_type];
6118 Perl_ck_delete(pTHX_ OP *o)
6122 if (o->op_flags & OPf_KIDS) {
6123 OP * const kid = cUNOPo->op_first;
6124 switch (kid->op_type) {
6126 o->op_flags |= OPf_SPECIAL;
6129 o->op_private |= OPpSLICE;
6132 o->op_flags |= OPf_SPECIAL;
6137 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6146 Perl_ck_die(pTHX_ OP *o)
6149 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6155 Perl_ck_eof(pTHX_ OP *o)
6159 if (o->op_flags & OPf_KIDS) {
6160 if (cLISTOPo->op_first->op_type == OP_STUB) {
6162 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6164 op_getmad(o,newop,'O');
6176 Perl_ck_eval(pTHX_ OP *o)
6179 PL_hints |= HINT_BLOCK_SCOPE;
6180 if (o->op_flags & OPf_KIDS) {
6181 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6184 o->op_flags &= ~OPf_KIDS;
6187 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6193 cUNOPo->op_first = 0;
6198 NewOp(1101, enter, 1, LOGOP);
6199 enter->op_type = OP_ENTERTRY;
6200 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6201 enter->op_private = 0;
6203 /* establish postfix order */
6204 enter->op_next = (OP*)enter;
6206 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6207 o->op_type = OP_LEAVETRY;
6208 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6209 enter->op_other = o;
6210 op_getmad(oldo,o,'O');
6224 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6225 op_getmad(oldo,o,'O');
6227 o->op_targ = (PADOFFSET)PL_hints;
6228 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6229 /* Store a copy of %^H that pp_entereval can pick up.
6230 OPf_SPECIAL flags the opcode as being for this purpose,
6231 so that it in turn will return a copy at every
6233 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6234 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6235 cUNOPo->op_first->op_sibling = hhop;
6236 o->op_private |= OPpEVAL_HAS_HH;
6242 Perl_ck_exit(pTHX_ OP *o)
6245 HV * const table = GvHV(PL_hintgv);
6247 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6248 if (svp && *svp && SvTRUE(*svp))
6249 o->op_private |= OPpEXIT_VMSISH;
6251 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6257 Perl_ck_exec(pTHX_ OP *o)
6259 if (o->op_flags & OPf_STACKED) {
6262 kid = cUNOPo->op_first->op_sibling;
6263 if (kid->op_type == OP_RV2GV)
6272 Perl_ck_exists(pTHX_ OP *o)
6276 if (o->op_flags & OPf_KIDS) {
6277 OP * const kid = cUNOPo->op_first;
6278 if (kid->op_type == OP_ENTERSUB) {
6279 (void) ref(kid, o->op_type);
6280 if (kid->op_type != OP_RV2CV && !PL_error_count)
6281 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6283 o->op_private |= OPpEXISTS_SUB;
6285 else if (kid->op_type == OP_AELEM)
6286 o->op_flags |= OPf_SPECIAL;
6287 else if (kid->op_type != OP_HELEM)
6288 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6296 Perl_ck_rvconst(pTHX_ register OP *o)
6299 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6301 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6302 if (o->op_type == OP_RV2CV)
6303 o->op_private &= ~1;
6305 if (kid->op_type == OP_CONST) {
6308 SV * const kidsv = kid->op_sv;
6310 /* Is it a constant from cv_const_sv()? */
6311 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6312 SV * const rsv = SvRV(kidsv);
6313 const svtype type = SvTYPE(rsv);
6314 const char *badtype = NULL;
6316 switch (o->op_type) {
6318 if (type > SVt_PVMG)
6319 badtype = "a SCALAR";
6322 if (type != SVt_PVAV)
6323 badtype = "an ARRAY";
6326 if (type != SVt_PVHV)
6330 if (type != SVt_PVCV)
6335 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6338 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6339 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6340 /* If this is an access to a stash, disable "strict refs", because
6341 * stashes aren't auto-vivified at compile-time (unless we store
6342 * symbols in them), and we don't want to produce a run-time
6343 * stricture error when auto-vivifying the stash. */
6344 const char *s = SvPV_nolen(kidsv);
6345 const STRLEN l = SvCUR(kidsv);
6346 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6347 o->op_private &= ~HINT_STRICT_REFS;
6349 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6350 const char *badthing;
6351 switch (o->op_type) {
6353 badthing = "a SCALAR";
6356 badthing = "an ARRAY";
6359 badthing = "a HASH";
6367 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6368 SVfARG(kidsv), badthing);
6371 * This is a little tricky. We only want to add the symbol if we
6372 * didn't add it in the lexer. Otherwise we get duplicate strict
6373 * warnings. But if we didn't add it in the lexer, we must at
6374 * least pretend like we wanted to add it even if it existed before,
6375 * or we get possible typo warnings. OPpCONST_ENTERED says
6376 * whether the lexer already added THIS instance of this symbol.
6378 iscv = (o->op_type == OP_RV2CV) * 2;
6380 gv = gv_fetchsv(kidsv,
6381 iscv | !(kid->op_private & OPpCONST_ENTERED),
6384 : o->op_type == OP_RV2SV
6386 : o->op_type == OP_RV2AV
6388 : o->op_type == OP_RV2HV
6391 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6393 kid->op_type = OP_GV;
6394 SvREFCNT_dec(kid->op_sv);
6396 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6397 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6398 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6400 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6402 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6404 kid->op_private = 0;
6405 kid->op_ppaddr = PL_ppaddr[OP_GV];
6412 Perl_ck_ftst(pTHX_ OP *o)
6415 const I32 type = o->op_type;
6417 if (o->op_flags & OPf_REF) {
6420 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6421 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6422 const OPCODE kidtype = kid->op_type;
6424 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6425 OP * const newop = newGVOP(type, OPf_REF,
6426 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6428 op_getmad(o,newop,'O');
6434 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6435 o->op_private |= OPpFT_ACCESS;
6436 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6437 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6438 o->op_private |= OPpFT_STACKED;
6446 if (type == OP_FTTTY)
6447 o = newGVOP(type, OPf_REF, PL_stdingv);
6449 o = newUNOP(type, 0, newDEFSVOP());
6450 op_getmad(oldo,o,'O');
6456 Perl_ck_fun(pTHX_ OP *o)
6459 const int type = o->op_type;
6460 register I32 oa = PL_opargs[type] >> OASHIFT;
6462 if (o->op_flags & OPf_STACKED) {
6463 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6466 return no_fh_allowed(o);
6469 if (o->op_flags & OPf_KIDS) {
6470 OP **tokid = &cLISTOPo->op_first;
6471 register OP *kid = cLISTOPo->op_first;
6475 if (kid->op_type == OP_PUSHMARK ||
6476 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6478 tokid = &kid->op_sibling;
6479 kid = kid->op_sibling;
6481 if (!kid && PL_opargs[type] & OA_DEFGV)
6482 *tokid = kid = newDEFSVOP();
6486 sibl = kid->op_sibling;
6488 if (!sibl && kid->op_type == OP_STUB) {
6495 /* list seen where single (scalar) arg expected? */
6496 if (numargs == 1 && !(oa >> 4)
6497 && kid->op_type == OP_LIST && type != OP_SCALAR)
6499 return too_many_arguments(o,PL_op_desc[type]);
6512 if ((type == OP_PUSH || type == OP_UNSHIFT)
6513 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6514 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6515 "Useless use of %s with no values",
6518 if (kid->op_type == OP_CONST &&
6519 (kid->op_private & OPpCONST_BARE))
6521 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6522 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6523 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6524 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6525 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6526 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6528 op_getmad(kid,newop,'K');
6533 kid->op_sibling = sibl;
6536 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6537 bad_type(numargs, "array", PL_op_desc[type], kid);
6541 if (kid->op_type == OP_CONST &&
6542 (kid->op_private & OPpCONST_BARE))
6544 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6545 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6546 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6547 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6548 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6549 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6551 op_getmad(kid,newop,'K');
6556 kid->op_sibling = sibl;
6559 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6560 bad_type(numargs, "hash", PL_op_desc[type], kid);
6565 OP * const newop = newUNOP(OP_NULL, 0, kid);
6566 kid->op_sibling = 0;
6568 newop->op_next = newop;
6570 kid->op_sibling = sibl;
6575 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6576 if (kid->op_type == OP_CONST &&
6577 (kid->op_private & OPpCONST_BARE))
6579 OP * const newop = newGVOP(OP_GV, 0,
6580 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6581 if (!(o->op_private & 1) && /* if not unop */
6582 kid == cLISTOPo->op_last)
6583 cLISTOPo->op_last = newop;
6585 op_getmad(kid,newop,'K');
6591 else if (kid->op_type == OP_READLINE) {
6592 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6593 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6596 I32 flags = OPf_SPECIAL;
6600 /* is this op a FH constructor? */
6601 if (is_handle_constructor(o,numargs)) {
6602 const char *name = NULL;
6606 /* Set a flag to tell rv2gv to vivify
6607 * need to "prove" flag does not mean something
6608 * else already - NI-S 1999/05/07
6611 if (kid->op_type == OP_PADSV) {
6613 = PAD_COMPNAME_SV(kid->op_targ);
6614 name = SvPV_const(namesv, len);
6616 else if (kid->op_type == OP_RV2SV
6617 && kUNOP->op_first->op_type == OP_GV)
6619 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6621 len = GvNAMELEN(gv);
6623 else if (kid->op_type == OP_AELEM
6624 || kid->op_type == OP_HELEM)
6627 OP *op = ((BINOP*)kid)->op_first;
6631 const char * const a =
6632 kid->op_type == OP_AELEM ?
6634 if (((op->op_type == OP_RV2AV) ||
6635 (op->op_type == OP_RV2HV)) &&
6636 (firstop = ((UNOP*)op)->op_first) &&
6637 (firstop->op_type == OP_GV)) {
6638 /* packagevar $a[] or $h{} */
6639 GV * const gv = cGVOPx_gv(firstop);
6647 else if (op->op_type == OP_PADAV
6648 || op->op_type == OP_PADHV) {
6649 /* lexicalvar $a[] or $h{} */
6650 const char * const padname =
6651 PAD_COMPNAME_PV(op->op_targ);
6660 name = SvPV_const(tmpstr, len);
6665 name = "__ANONIO__";
6672 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6673 namesv = PAD_SVl(targ);
6674 SvUPGRADE(namesv, SVt_PV);
6676 sv_setpvn(namesv, "$", 1);
6677 sv_catpvn(namesv, name, len);
6680 kid->op_sibling = 0;
6681 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6682 kid->op_targ = targ;
6683 kid->op_private |= priv;
6685 kid->op_sibling = sibl;
6691 mod(scalar(kid), type);
6695 tokid = &kid->op_sibling;
6696 kid = kid->op_sibling;
6699 if (kid && kid->op_type != OP_STUB)
6700 return too_many_arguments(o,OP_DESC(o));
6701 o->op_private |= numargs;
6703 /* FIXME - should the numargs move as for the PERL_MAD case? */
6704 o->op_private |= numargs;
6706 return too_many_arguments(o,OP_DESC(o));
6710 else if (PL_opargs[type] & OA_DEFGV) {
6712 OP *newop = newUNOP(type, 0, newDEFSVOP());
6713 op_getmad(o,newop,'O');
6716 /* Ordering of these two is important to keep f_map.t passing. */
6718 return newUNOP(type, 0, newDEFSVOP());
6723 while (oa & OA_OPTIONAL)
6725 if (oa && oa != OA_LIST)
6726 return too_few_arguments(o,OP_DESC(o));
6732 Perl_ck_glob(pTHX_ OP *o)
6738 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6739 append_elem(OP_GLOB, o, newDEFSVOP());
6741 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6742 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6744 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6747 #if !defined(PERL_EXTERNAL_GLOB)
6748 /* XXX this can be tightened up and made more failsafe. */
6749 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6752 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6753 newSVpvs("File::Glob"), NULL, NULL, NULL);
6754 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6755 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6756 GvCV(gv) = GvCV(glob_gv);
6757 SvREFCNT_inc_void((SV*)GvCV(gv));
6758 GvIMPORTED_CV_on(gv);
6761 #endif /* PERL_EXTERNAL_GLOB */
6763 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6764 append_elem(OP_GLOB, o,
6765 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6766 o->op_type = OP_LIST;
6767 o->op_ppaddr = PL_ppaddr[OP_LIST];
6768 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6769 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6770 cLISTOPo->op_first->op_targ = 0;
6771 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6772 append_elem(OP_LIST, o,
6773 scalar(newUNOP(OP_RV2CV, 0,
6774 newGVOP(OP_GV, 0, gv)))));
6775 o = newUNOP(OP_NULL, 0, ck_subr(o));
6776 o->op_targ = OP_GLOB; /* hint at what it used to be */
6779 gv = newGVgen("main");
6781 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6787 Perl_ck_grep(pTHX_ OP *o)
6792 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6795 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6796 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6798 if (o->op_flags & OPf_STACKED) {
6801 kid = cLISTOPo->op_first->op_sibling;
6802 if (!cUNOPx(kid)->op_next)
6803 Perl_croak(aTHX_ "panic: ck_grep");
6804 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6807 NewOp(1101, gwop, 1, LOGOP);
6808 kid->op_next = (OP*)gwop;
6809 o->op_flags &= ~OPf_STACKED;
6811 kid = cLISTOPo->op_first->op_sibling;
6812 if (type == OP_MAPWHILE)
6819 kid = cLISTOPo->op_first->op_sibling;
6820 if (kid->op_type != OP_NULL)
6821 Perl_croak(aTHX_ "panic: ck_grep");
6822 kid = kUNOP->op_first;
6825 NewOp(1101, gwop, 1, LOGOP);
6826 gwop->op_type = type;
6827 gwop->op_ppaddr = PL_ppaddr[type];
6828 gwop->op_first = listkids(o);
6829 gwop->op_flags |= OPf_KIDS;
6830 gwop->op_other = LINKLIST(kid);
6831 kid->op_next = (OP*)gwop;
6832 offset = pad_findmy("$_");
6833 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6834 o->op_private = gwop->op_private = 0;
6835 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6838 o->op_private = gwop->op_private = OPpGREP_LEX;
6839 gwop->op_targ = o->op_targ = offset;
6842 kid = cLISTOPo->op_first->op_sibling;
6843 if (!kid || !kid->op_sibling)
6844 return too_few_arguments(o,OP_DESC(o));
6845 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6846 mod(kid, OP_GREPSTART);
6852 Perl_ck_index(pTHX_ OP *o)
6854 if (o->op_flags & OPf_KIDS) {
6855 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6857 kid = kid->op_sibling; /* get past "big" */
6858 if (kid && kid->op_type == OP_CONST)
6859 fbm_compile(((SVOP*)kid)->op_sv, 0);
6865 Perl_ck_lengthconst(pTHX_ OP *o)
6867 /* XXX length optimization goes here */
6872 Perl_ck_lfun(pTHX_ OP *o)
6874 const OPCODE type = o->op_type;
6875 return modkids(ck_fun(o), type);
6879 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6881 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6882 switch (cUNOPo->op_first->op_type) {
6884 /* This is needed for
6885 if (defined %stash::)
6886 to work. Do not break Tk.
6888 break; /* Globals via GV can be undef */
6890 case OP_AASSIGN: /* Is this a good idea? */
6891 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6892 "defined(@array) is deprecated");
6893 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6894 "\t(Maybe you should just omit the defined()?)\n");
6897 /* This is needed for
6898 if (defined %stash::)
6899 to work. Do not break Tk.
6901 break; /* Globals via GV can be undef */
6903 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6904 "defined(%%hash) is deprecated");
6905 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6906 "\t(Maybe you should just omit the defined()?)\n");
6917 Perl_ck_readline(pTHX_ OP *o)
6919 if (!(o->op_flags & OPf_KIDS)) {
6921 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6923 op_getmad(o,newop,'O');
6933 Perl_ck_rfun(pTHX_ OP *o)
6935 const OPCODE type = o->op_type;
6936 return refkids(ck_fun(o), type);
6940 Perl_ck_listiob(pTHX_ OP *o)
6944 kid = cLISTOPo->op_first;
6947 kid = cLISTOPo->op_first;
6949 if (kid->op_type == OP_PUSHMARK)
6950 kid = kid->op_sibling;
6951 if (kid && o->op_flags & OPf_STACKED)
6952 kid = kid->op_sibling;
6953 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6954 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6955 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6956 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6957 cLISTOPo->op_first->op_sibling = kid;
6958 cLISTOPo->op_last = kid;
6959 kid = kid->op_sibling;
6964 append_elem(o->op_type, o, newDEFSVOP());
6970 Perl_ck_smartmatch(pTHX_ OP *o)
6973 if (0 == (o->op_flags & OPf_SPECIAL)) {
6974 OP *first = cBINOPo->op_first;
6975 OP *second = first->op_sibling;
6977 /* Implicitly take a reference to an array or hash */
6978 first->op_sibling = NULL;
6979 first = cBINOPo->op_first = ref_array_or_hash(first);
6980 second = first->op_sibling = ref_array_or_hash(second);
6982 /* Implicitly take a reference to a regular expression */
6983 if (first->op_type == OP_MATCH) {
6984 first->op_type = OP_QR;
6985 first->op_ppaddr = PL_ppaddr[OP_QR];
6987 if (second->op_type == OP_MATCH) {
6988 second->op_type = OP_QR;
6989 second->op_ppaddr = PL_ppaddr[OP_QR];
6998 Perl_ck_sassign(pTHX_ OP *o)
7000 OP * const kid = cLISTOPo->op_first;
7001 /* has a disposable target? */
7002 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7003 && !(kid->op_flags & OPf_STACKED)
7004 /* Cannot steal the second time! */
7005 && !(kid->op_private & OPpTARGET_MY))
7007 OP * const kkid = kid->op_sibling;
7009 /* Can just relocate the target. */
7010 if (kkid && kkid->op_type == OP_PADSV
7011 && !(kkid->op_private & OPpLVAL_INTRO))
7013 kid->op_targ = kkid->op_targ;
7015 /* Now we do not need PADSV and SASSIGN. */
7016 kid->op_sibling = o->op_sibling; /* NULL */
7017 cLISTOPo->op_first = NULL;
7019 op_getmad(o,kid,'O');
7020 op_getmad(kkid,kid,'M');
7025 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7029 if (kid->op_sibling) {
7030 OP *kkid = kid->op_sibling;
7031 if (kkid->op_type == OP_PADSV
7032 && (kkid->op_private & OPpLVAL_INTRO)
7033 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7034 o->op_private |= OPpASSIGN_STATE;
7035 /* hijacking PADSTALE for uninitialized state variables */
7036 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
7043 Perl_ck_match(pTHX_ OP *o)
7046 if (o->op_type != OP_QR && PL_compcv) {
7047 const PADOFFSET offset = pad_findmy("$_");
7048 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7049 o->op_targ = offset;
7050 o->op_private |= OPpTARGET_MY;
7053 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7054 o->op_private |= OPpRUNTIME;
7059 Perl_ck_method(pTHX_ OP *o)
7061 OP * const kid = cUNOPo->op_first;
7062 if (kid->op_type == OP_CONST) {
7063 SV* sv = kSVOP->op_sv;
7064 const char * const method = SvPVX_const(sv);
7065 if (!(strchr(method, ':') || strchr(method, '\''))) {
7067 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7068 sv = newSVpvn_share(method, SvCUR(sv), 0);
7071 kSVOP->op_sv = NULL;
7073 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7075 op_getmad(o,cmop,'O');
7086 Perl_ck_null(pTHX_ OP *o)
7088 PERL_UNUSED_CONTEXT;
7093 Perl_ck_open(pTHX_ OP *o)
7096 HV * const table = GvHV(PL_hintgv);
7098 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7100 const I32 mode = mode_from_discipline(*svp);
7101 if (mode & O_BINARY)
7102 o->op_private |= OPpOPEN_IN_RAW;
7103 else if (mode & O_TEXT)
7104 o->op_private |= OPpOPEN_IN_CRLF;
7107 svp = hv_fetchs(table, "open_OUT", FALSE);
7109 const I32 mode = mode_from_discipline(*svp);
7110 if (mode & O_BINARY)
7111 o->op_private |= OPpOPEN_OUT_RAW;
7112 else if (mode & O_TEXT)
7113 o->op_private |= OPpOPEN_OUT_CRLF;
7116 if (o->op_type == OP_BACKTICK) {
7117 if (!(o->op_flags & OPf_KIDS)) {
7118 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7120 op_getmad(o,newop,'O');
7129 /* In case of three-arg dup open remove strictness
7130 * from the last arg if it is a bareword. */
7131 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7132 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7136 if ((last->op_type == OP_CONST) && /* The bareword. */
7137 (last->op_private & OPpCONST_BARE) &&
7138 (last->op_private & OPpCONST_STRICT) &&
7139 (oa = first->op_sibling) && /* The fh. */
7140 (oa = oa->op_sibling) && /* The mode. */
7141 (oa->op_type == OP_CONST) &&
7142 SvPOK(((SVOP*)oa)->op_sv) &&
7143 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7144 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7145 (last == oa->op_sibling)) /* The bareword. */
7146 last->op_private &= ~OPpCONST_STRICT;
7152 Perl_ck_repeat(pTHX_ OP *o)
7154 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7155 o->op_private |= OPpREPEAT_DOLIST;
7156 cBINOPo->op_first = force_list(cBINOPo->op_first);
7164 Perl_ck_require(pTHX_ OP *o)
7169 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7170 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7172 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7173 SV * const sv = kid->op_sv;
7174 U32 was_readonly = SvREADONLY(sv);
7179 sv_force_normal_flags(sv, 0);
7180 assert(!SvREADONLY(sv));
7187 for (s = SvPVX(sv); *s; s++) {
7188 if (*s == ':' && s[1] == ':') {
7189 const STRLEN len = strlen(s+2)+1;
7191 Move(s+2, s+1, len, char);
7192 SvCUR_set(sv, SvCUR(sv) - 1);
7195 sv_catpvs(sv, ".pm");
7196 SvFLAGS(sv) |= was_readonly;
7200 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7201 /* handle override, if any */
7202 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7203 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7204 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7205 gv = gvp ? *gvp : NULL;
7209 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7210 OP * const kid = cUNOPo->op_first;
7213 cUNOPo->op_first = 0;
7217 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7218 append_elem(OP_LIST, kid,
7219 scalar(newUNOP(OP_RV2CV, 0,
7222 op_getmad(o,newop,'O');
7230 Perl_ck_return(pTHX_ OP *o)
7233 if (CvLVALUE(PL_compcv)) {
7235 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7236 mod(kid, OP_LEAVESUBLV);
7242 Perl_ck_select(pTHX_ OP *o)
7246 if (o->op_flags & OPf_KIDS) {
7247 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7248 if (kid && kid->op_sibling) {
7249 o->op_type = OP_SSELECT;
7250 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7252 return fold_constants(o);
7256 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7257 if (kid && kid->op_type == OP_RV2GV)
7258 kid->op_private &= ~HINT_STRICT_REFS;
7263 Perl_ck_shift(pTHX_ OP *o)
7266 const I32 type = o->op_type;
7268 if (!(o->op_flags & OPf_KIDS)) {
7270 /* FIXME - this can be refactored to reduce code in #ifdefs */
7272 OP * const oldo = o;
7276 argop = newUNOP(OP_RV2AV, 0,
7277 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7279 o = newUNOP(type, 0, scalar(argop));
7280 op_getmad(oldo,o,'O');
7283 return newUNOP(type, 0, scalar(argop));
7286 return scalar(modkids(ck_fun(o), type));
7290 Perl_ck_sort(pTHX_ OP *o)
7295 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7296 HV * const hinthv = GvHV(PL_hintgv);
7298 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7300 const I32 sorthints = (I32)SvIV(*svp);
7301 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7302 o->op_private |= OPpSORT_QSORT;
7303 if ((sorthints & HINT_SORT_STABLE) != 0)
7304 o->op_private |= OPpSORT_STABLE;
7309 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7311 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7312 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7314 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7316 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7318 if (kid->op_type == OP_SCOPE) {
7322 else if (kid->op_type == OP_LEAVE) {
7323 if (o->op_type == OP_SORT) {
7324 op_null(kid); /* wipe out leave */
7327 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7328 if (k->op_next == kid)
7330 /* don't descend into loops */
7331 else if (k->op_type == OP_ENTERLOOP
7332 || k->op_type == OP_ENTERITER)
7334 k = cLOOPx(k)->op_lastop;
7339 kid->op_next = 0; /* just disconnect the leave */
7340 k = kLISTOP->op_first;
7345 if (o->op_type == OP_SORT) {
7346 /* provide scalar context for comparison function/block */
7352 o->op_flags |= OPf_SPECIAL;
7354 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7357 firstkid = firstkid->op_sibling;
7360 /* provide list context for arguments */
7361 if (o->op_type == OP_SORT)
7368 S_simplify_sort(pTHX_ OP *o)
7371 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7376 if (!(o->op_flags & OPf_STACKED))
7378 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7379 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7380 kid = kUNOP->op_first; /* get past null */
7381 if (kid->op_type != OP_SCOPE)
7383 kid = kLISTOP->op_last; /* get past scope */
7384 switch(kid->op_type) {
7392 k = kid; /* remember this node*/
7393 if (kBINOP->op_first->op_type != OP_RV2SV)
7395 kid = kBINOP->op_first; /* get past cmp */
7396 if (kUNOP->op_first->op_type != OP_GV)
7398 kid = kUNOP->op_first; /* get past rv2sv */
7400 if (GvSTASH(gv) != PL_curstash)
7402 gvname = GvNAME(gv);
7403 if (*gvname == 'a' && gvname[1] == '\0')
7405 else if (*gvname == 'b' && gvname[1] == '\0')
7410 kid = k; /* back to cmp */
7411 if (kBINOP->op_last->op_type != OP_RV2SV)
7413 kid = kBINOP->op_last; /* down to 2nd arg */
7414 if (kUNOP->op_first->op_type != OP_GV)
7416 kid = kUNOP->op_first; /* get past rv2sv */
7418 if (GvSTASH(gv) != PL_curstash)
7420 gvname = GvNAME(gv);
7422 ? !(*gvname == 'a' && gvname[1] == '\0')
7423 : !(*gvname == 'b' && gvname[1] == '\0'))
7425 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7427 o->op_private |= OPpSORT_DESCEND;
7428 if (k->op_type == OP_NCMP)
7429 o->op_private |= OPpSORT_NUMERIC;
7430 if (k->op_type == OP_I_NCMP)
7431 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7432 kid = cLISTOPo->op_first->op_sibling;
7433 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7435 op_getmad(kid,o,'S'); /* then delete it */
7437 op_free(kid); /* then delete it */
7442 Perl_ck_split(pTHX_ OP *o)
7447 if (o->op_flags & OPf_STACKED)
7448 return no_fh_allowed(o);
7450 kid = cLISTOPo->op_first;
7451 if (kid->op_type != OP_NULL)
7452 Perl_croak(aTHX_ "panic: ck_split");
7453 kid = kid->op_sibling;
7454 op_free(cLISTOPo->op_first);
7455 cLISTOPo->op_first = kid;
7457 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7458 cLISTOPo->op_last = kid; /* There was only one element previously */
7461 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7462 OP * const sibl = kid->op_sibling;
7463 kid->op_sibling = 0;
7464 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7465 if (cLISTOPo->op_first == cLISTOPo->op_last)
7466 cLISTOPo->op_last = kid;
7467 cLISTOPo->op_first = kid;
7468 kid->op_sibling = sibl;
7471 kid->op_type = OP_PUSHRE;
7472 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7474 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7475 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7476 "Use of /g modifier is meaningless in split");
7479 if (!kid->op_sibling)
7480 append_elem(OP_SPLIT, o, newDEFSVOP());
7482 kid = kid->op_sibling;
7485 if (!kid->op_sibling)
7486 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7487 assert(kid->op_sibling);
7489 kid = kid->op_sibling;
7492 if (kid->op_sibling)
7493 return too_many_arguments(o,OP_DESC(o));
7499 Perl_ck_join(pTHX_ OP *o)
7501 const OP * const kid = cLISTOPo->op_first->op_sibling;
7502 if (kid && kid->op_type == OP_MATCH) {
7503 if (ckWARN(WARN_SYNTAX)) {
7504 const REGEXP *re = PM_GETRE(kPMOP);
7505 const char *pmstr = re ? re->precomp : "STRING";
7506 const STRLEN len = re ? re->prelen : 6;
7507 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7508 "/%.*s/ should probably be written as \"%.*s\"",
7509 (int)len, pmstr, (int)len, pmstr);
7516 Perl_ck_subr(pTHX_ OP *o)
7519 OP *prev = ((cUNOPo->op_first->op_sibling)
7520 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7521 OP *o2 = prev->op_sibling;
7523 const char *proto = NULL;
7524 const char *proto_end = NULL;
7529 I32 contextclass = 0;
7530 const char *e = NULL;
7533 o->op_private |= OPpENTERSUB_HASTARG;
7534 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7535 if (cvop->op_type == OP_RV2CV) {
7537 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7538 op_null(cvop); /* disable rv2cv */
7539 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7540 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7541 GV *gv = cGVOPx_gv(tmpop);
7544 tmpop->op_private |= OPpEARLY_CV;
7548 namegv = CvANON(cv) ? gv : CvGV(cv);
7549 proto = SvPV((SV*)cv, len);
7550 proto_end = proto + len;
7552 if (CvASSERTION(cv)) {
7553 U32 asserthints = 0;
7554 HV *const hinthv = GvHV(PL_hintgv);
7556 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7558 asserthints = SvUV(*svp);
7560 if (asserthints & HINT_ASSERTING) {
7561 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7562 o->op_private |= OPpENTERSUB_DB;
7566 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7567 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7568 "Impossible to activate assertion call");
7575 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7576 if (o2->op_type == OP_CONST)
7577 o2->op_private &= ~OPpCONST_STRICT;
7578 else if (o2->op_type == OP_LIST) {
7579 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7580 if (sib && sib->op_type == OP_CONST)
7581 sib->op_private &= ~OPpCONST_STRICT;
7584 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7585 if (PERLDB_SUB && PL_curstash != PL_debstash)
7586 o->op_private |= OPpENTERSUB_DB;
7587 while (o2 != cvop) {
7589 if (PL_madskills && o2->op_type == OP_STUB) {
7590 o2 = o2->op_sibling;
7593 if (PL_madskills && o2->op_type == OP_NULL)
7594 o3 = ((UNOP*)o2)->op_first;
7598 if (proto >= proto_end)
7599 return too_many_arguments(o, gv_ename(namegv));
7607 /* _ must be at the end */
7608 if (proto[1] && proto[1] != ';')
7623 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7625 arg == 1 ? "block or sub {}" : "sub {}",
7626 gv_ename(namegv), o3);
7629 /* '*' allows any scalar type, including bareword */
7632 if (o3->op_type == OP_RV2GV)
7633 goto wrapref; /* autoconvert GLOB -> GLOBref */
7634 else if (o3->op_type == OP_CONST)
7635 o3->op_private &= ~OPpCONST_STRICT;
7636 else if (o3->op_type == OP_ENTERSUB) {
7637 /* accidental subroutine, revert to bareword */
7638 OP *gvop = ((UNOP*)o3)->op_first;
7639 if (gvop && gvop->op_type == OP_NULL) {
7640 gvop = ((UNOP*)gvop)->op_first;
7642 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7645 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7646 (gvop = ((UNOP*)gvop)->op_first) &&
7647 gvop->op_type == OP_GV)
7649 GV * const gv = cGVOPx_gv(gvop);
7650 OP * const sibling = o2->op_sibling;
7651 SV * const n = newSVpvs("");
7653 OP * const oldo2 = o2;
7657 gv_fullname4(n, gv, "", FALSE);
7658 o2 = newSVOP(OP_CONST, 0, n);
7659 op_getmad(oldo2,o2,'O');
7660 prev->op_sibling = o2;
7661 o2->op_sibling = sibling;
7677 if (contextclass++ == 0) {
7678 e = strchr(proto, ']');
7679 if (!e || e == proto)
7688 const char *p = proto;
7689 const char *const end = proto;
7691 while (*--p != '[');
7692 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7694 gv_ename(namegv), o3);
7699 if (o3->op_type == OP_RV2GV)
7702 bad_type(arg, "symbol", gv_ename(namegv), o3);
7705 if (o3->op_type == OP_ENTERSUB)
7708 bad_type(arg, "subroutine entry", gv_ename(namegv),
7712 if (o3->op_type == OP_RV2SV ||
7713 o3->op_type == OP_PADSV ||
7714 o3->op_type == OP_HELEM ||
7715 o3->op_type == OP_AELEM)
7718 bad_type(arg, "scalar", gv_ename(namegv), o3);
7721 if (o3->op_type == OP_RV2AV ||
7722 o3->op_type == OP_PADAV)
7725 bad_type(arg, "array", gv_ename(namegv), o3);
7728 if (o3->op_type == OP_RV2HV ||
7729 o3->op_type == OP_PADHV)
7732 bad_type(arg, "hash", gv_ename(namegv), o3);
7737 OP* const sib = kid->op_sibling;
7738 kid->op_sibling = 0;
7739 o2 = newUNOP(OP_REFGEN, 0, kid);
7740 o2->op_sibling = sib;
7741 prev->op_sibling = o2;
7743 if (contextclass && e) {
7758 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7759 gv_ename(namegv), SVfARG(cv));
7764 mod(o2, OP_ENTERSUB);
7766 o2 = o2->op_sibling;
7768 if (o2 == cvop && proto && *proto == '_') {
7769 /* generate an access to $_ */
7771 o2->op_sibling = prev->op_sibling;
7772 prev->op_sibling = o2; /* instead of cvop */
7774 if (proto && !optional && proto_end > proto &&
7775 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7776 return too_few_arguments(o, gv_ename(namegv));
7779 OP * const oldo = o;
7783 o=newSVOP(OP_CONST, 0, newSViv(0));
7784 op_getmad(oldo,o,'O');
7790 Perl_ck_svconst(pTHX_ OP *o)
7792 PERL_UNUSED_CONTEXT;
7793 SvREADONLY_on(cSVOPo->op_sv);
7798 Perl_ck_chdir(pTHX_ OP *o)
7800 if (o->op_flags & OPf_KIDS) {
7801 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7803 if (kid && kid->op_type == OP_CONST &&
7804 (kid->op_private & OPpCONST_BARE))
7806 o->op_flags |= OPf_SPECIAL;
7807 kid->op_private &= ~OPpCONST_STRICT;
7814 Perl_ck_trunc(pTHX_ OP *o)
7816 if (o->op_flags & OPf_KIDS) {
7817 SVOP *kid = (SVOP*)cUNOPo->op_first;
7819 if (kid->op_type == OP_NULL)
7820 kid = (SVOP*)kid->op_sibling;
7821 if (kid && kid->op_type == OP_CONST &&
7822 (kid->op_private & OPpCONST_BARE))
7824 o->op_flags |= OPf_SPECIAL;
7825 kid->op_private &= ~OPpCONST_STRICT;
7832 Perl_ck_unpack(pTHX_ OP *o)
7834 OP *kid = cLISTOPo->op_first;
7835 if (kid->op_sibling) {
7836 kid = kid->op_sibling;
7837 if (!kid->op_sibling)
7838 kid->op_sibling = newDEFSVOP();
7844 Perl_ck_substr(pTHX_ OP *o)
7847 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7848 OP *kid = cLISTOPo->op_first;
7850 if (kid->op_type == OP_NULL)
7851 kid = kid->op_sibling;
7853 kid->op_flags |= OPf_MOD;
7859 /* A peephole optimizer. We visit the ops in the order they're to execute.
7860 * See the comments at the top of this file for more details about when
7861 * peep() is called */
7864 Perl_peep(pTHX_ register OP *o)
7867 register OP* oldop = NULL;
7869 if (!o || o->op_opt)
7873 SAVEVPTR(PL_curcop);
7874 for (; o; o = o->op_next) {
7877 /* By default, this op has now been optimised. A couple of cases below
7878 clear this again. */
7881 switch (o->op_type) {
7885 PL_curcop = ((COP*)o); /* for warnings */
7889 if (cSVOPo->op_private & OPpCONST_STRICT)
7890 no_bareword_allowed(o);
7892 case OP_METHOD_NAMED:
7893 /* Relocate sv to the pad for thread safety.
7894 * Despite being a "constant", the SV is written to,
7895 * for reference counts, sv_upgrade() etc. */
7897 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7898 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7899 /* If op_sv is already a PADTMP then it is being used by
7900 * some pad, so make a copy. */
7901 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7902 SvREADONLY_on(PAD_SVl(ix));
7903 SvREFCNT_dec(cSVOPo->op_sv);
7905 else if (o->op_type == OP_CONST
7906 && cSVOPo->op_sv == &PL_sv_undef) {
7907 /* PL_sv_undef is hack - it's unsafe to store it in the
7908 AV that is the pad, because av_fetch treats values of
7909 PL_sv_undef as a "free" AV entry and will merrily
7910 replace them with a new SV, causing pad_alloc to think
7911 that this pad slot is free. (When, clearly, it is not)
7913 SvOK_off(PAD_SVl(ix));
7914 SvPADTMP_on(PAD_SVl(ix));
7915 SvREADONLY_on(PAD_SVl(ix));
7918 SvREFCNT_dec(PAD_SVl(ix));
7919 SvPADTMP_on(cSVOPo->op_sv);
7920 PAD_SETSV(ix, cSVOPo->op_sv);
7921 /* XXX I don't know how this isn't readonly already. */
7922 SvREADONLY_on(PAD_SVl(ix));
7924 cSVOPo->op_sv = NULL;
7931 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7932 if (o->op_next->op_private & OPpTARGET_MY) {
7933 if (o->op_flags & OPf_STACKED) /* chained concats */
7934 break; /* ignore_optimization */
7936 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7937 o->op_targ = o->op_next->op_targ;
7938 o->op_next->op_targ = 0;
7939 o->op_private |= OPpTARGET_MY;
7942 op_null(o->op_next);
7946 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7947 break; /* Scalar stub must produce undef. List stub is noop */
7951 if (o->op_targ == OP_NEXTSTATE
7952 || o->op_targ == OP_DBSTATE
7953 || o->op_targ == OP_SETSTATE)
7955 PL_curcop = ((COP*)o);
7957 /* XXX: We avoid setting op_seq here to prevent later calls
7958 to peep() from mistakenly concluding that optimisation
7959 has already occurred. This doesn't fix the real problem,
7960 though (See 20010220.007). AMS 20010719 */
7961 /* op_seq functionality is now replaced by op_opt */
7968 if (oldop && o->op_next) {
7969 oldop->op_next = o->op_next;
7977 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7978 OP* const pop = (o->op_type == OP_PADAV) ?
7979 o->op_next : o->op_next->op_next;
7981 if (pop && pop->op_type == OP_CONST &&
7982 ((PL_op = pop->op_next)) &&
7983 pop->op_next->op_type == OP_AELEM &&
7984 !(pop->op_next->op_private &
7985 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7986 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7991 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7992 no_bareword_allowed(pop);
7993 if (o->op_type == OP_GV)
7994 op_null(o->op_next);
7995 op_null(pop->op_next);
7997 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7998 o->op_next = pop->op_next->op_next;
7999 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8000 o->op_private = (U8)i;
8001 if (o->op_type == OP_GV) {
8006 o->op_flags |= OPf_SPECIAL;
8007 o->op_type = OP_AELEMFAST;
8012 if (o->op_next->op_type == OP_RV2SV) {
8013 if (!(o->op_next->op_private & OPpDEREF)) {
8014 op_null(o->op_next);
8015 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8017 o->op_next = o->op_next->op_next;
8018 o->op_type = OP_GVSV;
8019 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8022 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8023 GV * const gv = cGVOPo_gv;
8024 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8025 /* XXX could check prototype here instead of just carping */
8026 SV * const sv = sv_newmortal();
8027 gv_efullname3(sv, gv, NULL);
8028 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8029 "%"SVf"() called too early to check prototype",
8033 else if (o->op_next->op_type == OP_READLINE
8034 && o->op_next->op_next->op_type == OP_CONCAT
8035 && (o->op_next->op_next->op_flags & OPf_STACKED))
8037 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8038 o->op_type = OP_RCATLINE;
8039 o->op_flags |= OPf_STACKED;
8040 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8041 op_null(o->op_next->op_next);
8042 op_null(o->op_next);
8057 while (cLOGOP->op_other->op_type == OP_NULL)
8058 cLOGOP->op_other = cLOGOP->op_other->op_next;
8059 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8064 while (cLOOP->op_redoop->op_type == OP_NULL)
8065 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8066 peep(cLOOP->op_redoop);
8067 while (cLOOP->op_nextop->op_type == OP_NULL)
8068 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8069 peep(cLOOP->op_nextop);
8070 while (cLOOP->op_lastop->op_type == OP_NULL)
8071 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8072 peep(cLOOP->op_lastop);
8076 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8077 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8078 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8079 cPMOP->op_pmstashstartu.op_pmreplstart
8080 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8081 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8085 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8086 && ckWARN(WARN_SYNTAX))
8088 if (o->op_next->op_sibling) {
8089 const OPCODE type = o->op_next->op_sibling->op_type;
8090 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8091 const line_t oldline = CopLINE(PL_curcop);
8092 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8093 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8094 "Statement unlikely to be reached");
8095 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8096 "\t(Maybe you meant system() when you said exec()?)\n");
8097 CopLINE_set(PL_curcop, oldline);
8108 const char *key = NULL;
8111 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8114 /* Make the CONST have a shared SV */
8115 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8116 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8117 key = SvPV_const(sv, keylen);
8118 lexname = newSVpvn_share(key,
8119 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8125 if ((o->op_private & (OPpLVAL_INTRO)))
8128 rop = (UNOP*)((BINOP*)o)->op_first;
8129 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8131 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8132 if (!SvPAD_TYPED(lexname))
8134 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8135 if (!fields || !GvHV(*fields))
8137 key = SvPV_const(*svp, keylen);
8138 if (!hv_fetch(GvHV(*fields), key,
8139 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8141 Perl_croak(aTHX_ "No such class field \"%s\" "
8142 "in variable %s of type %s",
8143 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8156 SVOP *first_key_op, *key_op;
8158 if ((o->op_private & (OPpLVAL_INTRO))
8159 /* I bet there's always a pushmark... */
8160 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8161 /* hmmm, no optimization if list contains only one key. */
8163 rop = (UNOP*)((LISTOP*)o)->op_last;
8164 if (rop->op_type != OP_RV2HV)
8166 if (rop->op_first->op_type == OP_PADSV)
8167 /* @$hash{qw(keys here)} */
8168 rop = (UNOP*)rop->op_first;
8170 /* @{$hash}{qw(keys here)} */
8171 if (rop->op_first->op_type == OP_SCOPE
8172 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8174 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8180 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8181 if (!SvPAD_TYPED(lexname))
8183 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8184 if (!fields || !GvHV(*fields))
8186 /* Again guessing that the pushmark can be jumped over.... */
8187 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8188 ->op_first->op_sibling;
8189 for (key_op = first_key_op; key_op;
8190 key_op = (SVOP*)key_op->op_sibling) {
8191 if (key_op->op_type != OP_CONST)
8193 svp = cSVOPx_svp(key_op);
8194 key = SvPV_const(*svp, keylen);
8195 if (!hv_fetch(GvHV(*fields), key,
8196 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8198 Perl_croak(aTHX_ "No such class field \"%s\" "
8199 "in variable %s of type %s",
8200 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8207 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8211 /* check that RHS of sort is a single plain array */
8212 OP *oright = cUNOPo->op_first;
8213 if (!oright || oright->op_type != OP_PUSHMARK)
8216 /* reverse sort ... can be optimised. */
8217 if (!cUNOPo->op_sibling) {
8218 /* Nothing follows us on the list. */
8219 OP * const reverse = o->op_next;
8221 if (reverse->op_type == OP_REVERSE &&
8222 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8223 OP * const pushmark = cUNOPx(reverse)->op_first;
8224 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8225 && (cUNOPx(pushmark)->op_sibling == o)) {
8226 /* reverse -> pushmark -> sort */
8227 o->op_private |= OPpSORT_REVERSE;
8229 pushmark->op_next = oright->op_next;
8235 /* make @a = sort @a act in-place */
8237 oright = cUNOPx(oright)->op_sibling;
8240 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8241 oright = cUNOPx(oright)->op_sibling;
8245 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8246 || oright->op_next != o
8247 || (oright->op_private & OPpLVAL_INTRO)
8251 /* o2 follows the chain of op_nexts through the LHS of the
8252 * assign (if any) to the aassign op itself */
8254 if (!o2 || o2->op_type != OP_NULL)
8257 if (!o2 || o2->op_type != OP_PUSHMARK)
8260 if (o2 && o2->op_type == OP_GV)
8263 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8264 || (o2->op_private & OPpLVAL_INTRO)
8269 if (!o2 || o2->op_type != OP_NULL)
8272 if (!o2 || o2->op_type != OP_AASSIGN
8273 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8276 /* check that the sort is the first arg on RHS of assign */
8278 o2 = cUNOPx(o2)->op_first;
8279 if (!o2 || o2->op_type != OP_NULL)
8281 o2 = cUNOPx(o2)->op_first;
8282 if (!o2 || o2->op_type != OP_PUSHMARK)
8284 if (o2->op_sibling != o)
8287 /* check the array is the same on both sides */
8288 if (oleft->op_type == OP_RV2AV) {
8289 if (oright->op_type != OP_RV2AV
8290 || !cUNOPx(oright)->op_first
8291 || cUNOPx(oright)->op_first->op_type != OP_GV
8292 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8293 cGVOPx_gv(cUNOPx(oright)->op_first)
8297 else if (oright->op_type != OP_PADAV
8298 || oright->op_targ != oleft->op_targ
8302 /* transfer MODishness etc from LHS arg to RHS arg */
8303 oright->op_flags = oleft->op_flags;
8304 o->op_private |= OPpSORT_INPLACE;
8306 /* excise push->gv->rv2av->null->aassign */
8307 o2 = o->op_next->op_next;
8308 op_null(o2); /* PUSHMARK */
8310 if (o2->op_type == OP_GV) {
8311 op_null(o2); /* GV */
8314 op_null(o2); /* RV2AV or PADAV */
8315 o2 = o2->op_next->op_next;
8316 op_null(o2); /* AASSIGN */
8318 o->op_next = o2->op_next;
8324 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8326 LISTOP *enter, *exlist;
8328 enter = (LISTOP *) o->op_next;
8331 if (enter->op_type == OP_NULL) {
8332 enter = (LISTOP *) enter->op_next;
8336 /* for $a (...) will have OP_GV then OP_RV2GV here.
8337 for (...) just has an OP_GV. */
8338 if (enter->op_type == OP_GV) {
8339 gvop = (OP *) enter;
8340 enter = (LISTOP *) enter->op_next;
8343 if (enter->op_type == OP_RV2GV) {
8344 enter = (LISTOP *) enter->op_next;
8350 if (enter->op_type != OP_ENTERITER)
8353 iter = enter->op_next;
8354 if (!iter || iter->op_type != OP_ITER)
8357 expushmark = enter->op_first;
8358 if (!expushmark || expushmark->op_type != OP_NULL
8359 || expushmark->op_targ != OP_PUSHMARK)
8362 exlist = (LISTOP *) expushmark->op_sibling;
8363 if (!exlist || exlist->op_type != OP_NULL
8364 || exlist->op_targ != OP_LIST)
8367 if (exlist->op_last != o) {
8368 /* Mmm. Was expecting to point back to this op. */
8371 theirmark = exlist->op_first;
8372 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8375 if (theirmark->op_sibling != o) {
8376 /* There's something between the mark and the reverse, eg
8377 for (1, reverse (...))
8382 ourmark = ((LISTOP *)o)->op_first;
8383 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8386 ourlast = ((LISTOP *)o)->op_last;
8387 if (!ourlast || ourlast->op_next != o)
8390 rv2av = ourmark->op_sibling;
8391 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8392 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8393 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8394 /* We're just reversing a single array. */
8395 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8396 enter->op_flags |= OPf_STACKED;
8399 /* We don't have control over who points to theirmark, so sacrifice
8401 theirmark->op_next = ourmark->op_next;
8402 theirmark->op_flags = ourmark->op_flags;
8403 ourlast->op_next = gvop ? gvop : (OP *) enter;
8406 enter->op_private |= OPpITER_REVERSED;
8407 iter->op_private |= OPpITER_REVERSED;
8414 UNOP *refgen, *rv2cv;
8417 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8420 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8423 rv2gv = ((BINOP *)o)->op_last;
8424 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8427 refgen = (UNOP *)((BINOP *)o)->op_first;
8429 if (!refgen || refgen->op_type != OP_REFGEN)
8432 exlist = (LISTOP *)refgen->op_first;
8433 if (!exlist || exlist->op_type != OP_NULL
8434 || exlist->op_targ != OP_LIST)
8437 if (exlist->op_first->op_type != OP_PUSHMARK)
8440 rv2cv = (UNOP*)exlist->op_last;
8442 if (rv2cv->op_type != OP_RV2CV)
8445 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8446 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8447 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8449 o->op_private |= OPpASSIGN_CV_TO_GV;
8450 rv2gv->op_private |= OPpDONT_INIT_GV;
8451 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8459 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8460 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8470 Perl_custom_op_name(pTHX_ const OP* o)
8473 const IV index = PTR2IV(o->op_ppaddr);
8477 if (!PL_custom_op_names) /* This probably shouldn't happen */
8478 return (char *)PL_op_name[OP_CUSTOM];
8480 keysv = sv_2mortal(newSViv(index));
8482 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8484 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8486 return SvPV_nolen(HeVAL(he));
8490 Perl_custom_op_desc(pTHX_ const OP* o)
8493 const IV index = PTR2IV(o->op_ppaddr);
8497 if (!PL_custom_op_descs)
8498 return (char *)PL_op_desc[OP_CUSTOM];
8500 keysv = sv_2mortal(newSViv(index));
8502 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8504 return (char *)PL_op_desc[OP_CUSTOM];
8506 return SvPV_nolen(HeVAL(he));
8511 /* Efficient sub that returns a constant scalar value. */
8513 const_sv_xsub(pTHX_ CV* cv)
8520 Perl_croak(aTHX_ "usage: %s::%s()",
8521 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8525 ST(0) = (SV*)XSANY.any_ptr;
8531 * c-indentation-style: bsd
8533 * indent-tabs-mode: t
8536 * ex: set ts=8 sts=4 sw=4 noet: