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 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3442 op_getmad(expr,(OP*)pm,'e');
3448 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3449 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3451 : OP_REGCMAYBE),0,expr);
3453 NewOp(1101, rcop, 1, LOGOP);
3454 rcop->op_type = OP_REGCOMP;
3455 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3456 rcop->op_first = scalar(expr);
3457 rcop->op_flags |= OPf_KIDS
3458 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3459 | (reglist ? OPf_STACKED : 0);
3460 rcop->op_private = 1;
3463 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3465 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3468 /* establish postfix order */
3469 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3471 rcop->op_next = expr;
3472 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3475 rcop->op_next = LINKLIST(expr);
3476 expr->op_next = (OP*)rcop;
3479 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3484 if (pm->op_pmflags & PMf_EVAL) {
3486 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3487 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3489 else if (repl->op_type == OP_CONST)
3493 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3494 if (curop->op_type == OP_SCOPE
3495 || curop->op_type == OP_LEAVE
3496 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3497 if (curop->op_type == OP_GV) {
3498 GV * const gv = cGVOPx_gv(curop);
3500 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3503 else if (curop->op_type == OP_RV2CV)
3505 else if (curop->op_type == OP_RV2SV ||
3506 curop->op_type == OP_RV2AV ||
3507 curop->op_type == OP_RV2HV ||
3508 curop->op_type == OP_RV2GV) {
3509 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3512 else if (curop->op_type == OP_PADSV ||
3513 curop->op_type == OP_PADAV ||
3514 curop->op_type == OP_PADHV ||
3515 curop->op_type == OP_PADANY)
3519 else if (curop->op_type == OP_PUSHRE)
3520 NOOP; /* Okay here, dangerous in newASSIGNOP */
3530 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3532 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3533 prepend_elem(o->op_type, scalar(repl), o);
3536 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3537 pm->op_pmflags |= PMf_MAYBE_CONST;
3539 NewOp(1101, rcop, 1, LOGOP);
3540 rcop->op_type = OP_SUBSTCONT;
3541 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3542 rcop->op_first = scalar(repl);
3543 rcop->op_flags |= OPf_KIDS;
3544 rcop->op_private = 1;
3547 /* establish postfix order */
3548 rcop->op_next = LINKLIST(repl);
3549 repl->op_next = (OP*)rcop;
3551 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3552 assert(!(pm->op_pmflags & PMf_ONCE));
3553 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3562 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3566 NewOp(1101, svop, 1, SVOP);
3567 svop->op_type = (OPCODE)type;
3568 svop->op_ppaddr = PL_ppaddr[type];
3570 svop->op_next = (OP*)svop;
3571 svop->op_flags = (U8)flags;
3572 if (PL_opargs[type] & OA_RETSCALAR)
3574 if (PL_opargs[type] & OA_TARGET)
3575 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3576 return CHECKOP(type, svop);
3581 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3585 NewOp(1101, padop, 1, PADOP);
3586 padop->op_type = (OPCODE)type;
3587 padop->op_ppaddr = PL_ppaddr[type];
3588 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3589 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3590 PAD_SETSV(padop->op_padix, sv);
3593 padop->op_next = (OP*)padop;
3594 padop->op_flags = (U8)flags;
3595 if (PL_opargs[type] & OA_RETSCALAR)
3597 if (PL_opargs[type] & OA_TARGET)
3598 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3599 return CHECKOP(type, padop);
3604 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3610 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3612 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3617 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3621 NewOp(1101, pvop, 1, PVOP);
3622 pvop->op_type = (OPCODE)type;
3623 pvop->op_ppaddr = PL_ppaddr[type];
3625 pvop->op_next = (OP*)pvop;
3626 pvop->op_flags = (U8)flags;
3627 if (PL_opargs[type] & OA_RETSCALAR)
3629 if (PL_opargs[type] & OA_TARGET)
3630 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3631 return CHECKOP(type, pvop);
3639 Perl_package(pTHX_ OP *o)
3642 SV *const sv = cSVOPo->op_sv;
3647 save_hptr(&PL_curstash);
3648 save_item(PL_curstname);
3650 PL_curstash = gv_stashsv(sv, GV_ADD);
3652 /* In case mg.c:Perl_magic_setisa faked
3653 this package earlier, we clear the fake flag */
3654 HvMROMETA(PL_curstash)->fake = 0;
3656 sv_setsv(PL_curstname, sv);
3658 PL_hints |= HINT_BLOCK_SCOPE;
3659 PL_copline = NOLINE;
3665 if (!PL_madskills) {
3670 pegop = newOP(OP_NULL,0);
3671 op_getmad(o,pegop,'P');
3681 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3688 OP *pegop = newOP(OP_NULL,0);
3691 if (idop->op_type != OP_CONST)
3692 Perl_croak(aTHX_ "Module name must be constant");
3695 op_getmad(idop,pegop,'U');
3700 SV * const vesv = ((SVOP*)version)->op_sv;
3703 op_getmad(version,pegop,'V');
3704 if (!arg && !SvNIOKp(vesv)) {
3711 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3712 Perl_croak(aTHX_ "Version number must be constant number");
3714 /* Make copy of idop so we don't free it twice */
3715 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3717 /* Fake up a method call to VERSION */
3718 meth = newSVpvs_share("VERSION");
3719 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3720 append_elem(OP_LIST,
3721 prepend_elem(OP_LIST, pack, list(version)),
3722 newSVOP(OP_METHOD_NAMED, 0, meth)));
3726 /* Fake up an import/unimport */
3727 if (arg && arg->op_type == OP_STUB) {
3729 op_getmad(arg,pegop,'S');
3730 imop = arg; /* no import on explicit () */
3732 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3733 imop = NULL; /* use 5.0; */
3735 idop->op_private |= OPpCONST_NOVER;
3741 op_getmad(arg,pegop,'A');
3743 /* Make copy of idop so we don't free it twice */
3744 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3746 /* Fake up a method call to import/unimport */
3748 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3749 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3750 append_elem(OP_LIST,
3751 prepend_elem(OP_LIST, pack, list(arg)),
3752 newSVOP(OP_METHOD_NAMED, 0, meth)));
3755 /* Fake up the BEGIN {}, which does its thing immediately. */
3757 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3760 append_elem(OP_LINESEQ,
3761 append_elem(OP_LINESEQ,
3762 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3763 newSTATEOP(0, NULL, veop)),
3764 newSTATEOP(0, NULL, imop) ));
3766 /* The "did you use incorrect case?" warning used to be here.
3767 * The problem is that on case-insensitive filesystems one
3768 * might get false positives for "use" (and "require"):
3769 * "use Strict" or "require CARP" will work. This causes
3770 * portability problems for the script: in case-strict
3771 * filesystems the script will stop working.
3773 * The "incorrect case" warning checked whether "use Foo"
3774 * imported "Foo" to your namespace, but that is wrong, too:
3775 * there is no requirement nor promise in the language that
3776 * a Foo.pm should or would contain anything in package "Foo".
3778 * There is very little Configure-wise that can be done, either:
3779 * the case-sensitivity of the build filesystem of Perl does not
3780 * help in guessing the case-sensitivity of the runtime environment.
3783 PL_hints |= HINT_BLOCK_SCOPE;
3784 PL_copline = NOLINE;
3786 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3789 if (!PL_madskills) {
3790 /* FIXME - don't allocate pegop if !PL_madskills */
3799 =head1 Embedding Functions
3801 =for apidoc load_module
3803 Loads the module whose name is pointed to by the string part of name.
3804 Note that the actual module name, not its filename, should be given.
3805 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3806 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3807 (or 0 for no flags). ver, if specified, provides version semantics
3808 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3809 arguments can be used to specify arguments to the module's import()
3810 method, similar to C<use Foo::Bar VERSION LIST>.
3815 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3818 va_start(args, ver);
3819 vload_module(flags, name, ver, &args);
3823 #ifdef PERL_IMPLICIT_CONTEXT
3825 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3829 va_start(args, ver);
3830 vload_module(flags, name, ver, &args);
3836 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3841 OP * const modname = newSVOP(OP_CONST, 0, name);
3842 modname->op_private |= OPpCONST_BARE;
3844 veop = newSVOP(OP_CONST, 0, ver);
3848 if (flags & PERL_LOADMOD_NOIMPORT) {
3849 imop = sawparens(newNULLLIST());
3851 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3852 imop = va_arg(*args, OP*);
3857 sv = va_arg(*args, SV*);
3859 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3860 sv = va_arg(*args, SV*);
3864 const line_t ocopline = PL_copline;
3865 COP * const ocurcop = PL_curcop;
3866 const U8 oexpect = PL_expect;
3868 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3869 veop, modname, imop);
3870 PL_expect = oexpect;
3871 PL_copline = ocopline;
3872 PL_curcop = ocurcop;
3877 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3883 if (!force_builtin) {
3884 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3885 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3886 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3887 gv = gvp ? *gvp : NULL;
3891 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3892 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3893 append_elem(OP_LIST, term,
3894 scalar(newUNOP(OP_RV2CV, 0,
3895 newGVOP(OP_GV, 0, gv))))));
3898 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3904 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3906 return newBINOP(OP_LSLICE, flags,
3907 list(force_list(subscript)),
3908 list(force_list(listval)) );
3912 S_is_list_assignment(pTHX_ register const OP *o)
3920 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3921 o = cUNOPo->op_first;
3923 flags = o->op_flags;
3925 if (type == OP_COND_EXPR) {
3926 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3927 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3932 yyerror("Assignment to both a list and a scalar");
3936 if (type == OP_LIST &&
3937 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3938 o->op_private & OPpLVAL_INTRO)
3941 if (type == OP_LIST || flags & OPf_PARENS ||
3942 type == OP_RV2AV || type == OP_RV2HV ||
3943 type == OP_ASLICE || type == OP_HSLICE)
3946 if (type == OP_PADAV || type == OP_PADHV)
3949 if (type == OP_RV2SV)
3956 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3962 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3963 return newLOGOP(optype, 0,
3964 mod(scalar(left), optype),
3965 newUNOP(OP_SASSIGN, 0, scalar(right)));
3968 return newBINOP(optype, OPf_STACKED,
3969 mod(scalar(left), optype), scalar(right));
3973 if (is_list_assignment(left)) {
3977 /* Grandfathering $[ assignment here. Bletch.*/
3978 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3979 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3980 left = mod(left, OP_AASSIGN);
3983 else if (left->op_type == OP_CONST) {
3985 /* Result of assignment is always 1 (or we'd be dead already) */
3986 return newSVOP(OP_CONST, 0, newSViv(1));
3988 curop = list(force_list(left));
3989 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3990 o->op_private = (U8)(0 | (flags >> 8));
3992 /* PL_generation sorcery:
3993 * an assignment like ($a,$b) = ($c,$d) is easier than
3994 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3995 * To detect whether there are common vars, the global var
3996 * PL_generation is incremented for each assign op we compile.
3997 * Then, while compiling the assign op, we run through all the
3998 * variables on both sides of the assignment, setting a spare slot
3999 * in each of them to PL_generation. If any of them already have
4000 * that value, we know we've got commonality. We could use a
4001 * single bit marker, but then we'd have to make 2 passes, first
4002 * to clear the flag, then to test and set it. To find somewhere
4003 * to store these values, evil chicanery is done with SvUVX().
4009 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4010 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4011 if (curop->op_type == OP_GV) {
4012 GV *gv = cGVOPx_gv(curop);
4014 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4016 GvASSIGN_GENERATION_set(gv, PL_generation);
4018 else if (curop->op_type == OP_PADSV ||
4019 curop->op_type == OP_PADAV ||
4020 curop->op_type == OP_PADHV ||
4021 curop->op_type == OP_PADANY)
4023 if (PAD_COMPNAME_GEN(curop->op_targ)
4024 == (STRLEN)PL_generation)
4026 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4029 else if (curop->op_type == OP_RV2CV)
4031 else if (curop->op_type == OP_RV2SV ||
4032 curop->op_type == OP_RV2AV ||
4033 curop->op_type == OP_RV2HV ||
4034 curop->op_type == OP_RV2GV) {
4035 if (lastop->op_type != OP_GV) /* funny deref? */
4038 else if (curop->op_type == OP_PUSHRE) {
4040 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4041 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4043 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4045 GvASSIGN_GENERATION_set(gv, PL_generation);
4049 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4052 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4054 GvASSIGN_GENERATION_set(gv, PL_generation);
4064 o->op_private |= OPpASSIGN_COMMON;
4067 if (right && right->op_type == OP_SPLIT) {
4068 OP* tmpop = ((LISTOP*)right)->op_first;
4069 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4070 PMOP * const pm = (PMOP*)tmpop;
4071 if (left->op_type == OP_RV2AV &&
4072 !(left->op_private & OPpLVAL_INTRO) &&
4073 !(o->op_private & OPpASSIGN_COMMON) )
4075 tmpop = ((UNOP*)left)->op_first;
4076 if (tmpop->op_type == OP_GV
4078 && !pm->op_pmreplrootu.op_pmtargetoff
4080 && !pm->op_pmreplrootu.op_pmtargetgv
4084 pm->op_pmreplrootu.op_pmtargetoff
4085 = cPADOPx(tmpop)->op_padix;
4086 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4088 pm->op_pmreplrootu.op_pmtargetgv
4089 = (GV*)cSVOPx(tmpop)->op_sv;
4090 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4092 pm->op_pmflags |= PMf_ONCE;
4093 tmpop = cUNOPo->op_first; /* to list (nulled) */
4094 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4095 tmpop->op_sibling = NULL; /* don't free split */
4096 right->op_next = tmpop->op_next; /* fix starting loc */
4098 op_getmad(o,right,'R'); /* blow off assign */
4100 op_free(o); /* blow off assign */
4102 right->op_flags &= ~OPf_WANT;
4103 /* "I don't know and I don't care." */
4108 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4109 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4111 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4113 sv_setiv(sv, PL_modcount+1);
4121 right = newOP(OP_UNDEF, 0);
4122 if (right->op_type == OP_READLINE) {
4123 right->op_flags |= OPf_STACKED;
4124 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4127 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4128 o = newBINOP(OP_SASSIGN, flags,
4129 scalar(right), mod(scalar(left), OP_SASSIGN) );
4135 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4136 o->op_private |= OPpCONST_ARYBASE;
4143 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4146 const U32 seq = intro_my();
4149 NewOp(1101, cop, 1, COP);
4150 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4151 cop->op_type = OP_DBSTATE;
4152 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4155 cop->op_type = OP_NEXTSTATE;
4156 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4158 cop->op_flags = (U8)flags;
4159 CopHINTS_set(cop, PL_hints);
4161 cop->op_private |= NATIVE_HINTS;
4163 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4164 cop->op_next = (OP*)cop;
4167 CopLABEL_set(cop, label);
4168 PL_hints |= HINT_BLOCK_SCOPE;
4171 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4172 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4174 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4175 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4176 if (cop->cop_hints_hash) {
4178 cop->cop_hints_hash->refcounted_he_refcnt++;
4179 HINTS_REFCNT_UNLOCK;
4182 if (PL_copline == NOLINE)
4183 CopLINE_set(cop, CopLINE(PL_curcop));
4185 CopLINE_set(cop, PL_copline);
4186 PL_copline = NOLINE;
4189 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4191 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4193 CopSTASH_set(cop, PL_curstash);
4195 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4196 AV *av = CopFILEAVx(PL_curcop);
4198 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4199 if (svp && *svp != &PL_sv_undef ) {
4200 (void)SvIOK_on(*svp);
4201 SvIV_set(*svp, PTR2IV(cop));
4206 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4211 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4214 return new_logop(type, flags, &first, &other);
4218 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4223 OP *first = *firstp;
4224 OP * const other = *otherp;
4226 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4227 return newBINOP(type, flags, scalar(first), scalar(other));
4229 scalarboolean(first);
4230 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4231 if (first->op_type == OP_NOT
4232 && (first->op_flags & OPf_SPECIAL)
4233 && (first->op_flags & OPf_KIDS)) {
4234 if (type == OP_AND || type == OP_OR) {
4240 first = *firstp = cUNOPo->op_first;
4242 first->op_next = o->op_next;
4243 cUNOPo->op_first = NULL;
4245 op_getmad(o,first,'O');
4251 if (first->op_type == OP_CONST) {
4252 if (first->op_private & OPpCONST_STRICT)
4253 no_bareword_allowed(first);
4254 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4255 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4256 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4257 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4258 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4260 if (other->op_type == OP_CONST)
4261 other->op_private |= OPpCONST_SHORTCIRCUIT;
4263 OP *newop = newUNOP(OP_NULL, 0, other);
4264 op_getmad(first, newop, '1');
4265 newop->op_targ = type; /* set "was" field */
4272 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4273 const OP *o2 = other;
4274 if ( ! (o2->op_type == OP_LIST
4275 && (( o2 = cUNOPx(o2)->op_first))
4276 && o2->op_type == OP_PUSHMARK
4277 && (( o2 = o2->op_sibling)) )
4280 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4281 || o2->op_type == OP_PADHV)
4282 && o2->op_private & OPpLVAL_INTRO
4283 && ckWARN(WARN_DEPRECATED))
4285 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4286 "Deprecated use of my() in false conditional");
4290 if (first->op_type == OP_CONST)
4291 first->op_private |= OPpCONST_SHORTCIRCUIT;
4293 first = newUNOP(OP_NULL, 0, first);
4294 op_getmad(other, first, '2');
4295 first->op_targ = type; /* set "was" field */
4302 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4303 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4305 const OP * const k1 = ((UNOP*)first)->op_first;
4306 const OP * const k2 = k1->op_sibling;
4308 switch (first->op_type)
4311 if (k2 && k2->op_type == OP_READLINE
4312 && (k2->op_flags & OPf_STACKED)
4313 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4315 warnop = k2->op_type;
4320 if (k1->op_type == OP_READDIR
4321 || k1->op_type == OP_GLOB
4322 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4323 || k1->op_type == OP_EACH)
4325 warnop = ((k1->op_type == OP_NULL)
4326 ? (OPCODE)k1->op_targ : k1->op_type);
4331 const line_t oldline = CopLINE(PL_curcop);
4332 CopLINE_set(PL_curcop, PL_copline);
4333 Perl_warner(aTHX_ packWARN(WARN_MISC),
4334 "Value of %s%s can be \"0\"; test with defined()",
4336 ((warnop == OP_READLINE || warnop == OP_GLOB)
4337 ? " construct" : "() operator"));
4338 CopLINE_set(PL_curcop, oldline);
4345 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4346 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4348 NewOp(1101, logop, 1, LOGOP);
4350 logop->op_type = (OPCODE)type;
4351 logop->op_ppaddr = PL_ppaddr[type];
4352 logop->op_first = first;
4353 logop->op_flags = (U8)(flags | OPf_KIDS);
4354 logop->op_other = LINKLIST(other);
4355 logop->op_private = (U8)(1 | (flags >> 8));
4357 /* establish postfix order */
4358 logop->op_next = LINKLIST(first);
4359 first->op_next = (OP*)logop;
4360 first->op_sibling = other;
4362 CHECKOP(type,logop);
4364 o = newUNOP(OP_NULL, 0, (OP*)logop);
4371 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4379 return newLOGOP(OP_AND, 0, first, trueop);
4381 return newLOGOP(OP_OR, 0, first, falseop);
4383 scalarboolean(first);
4384 if (first->op_type == OP_CONST) {
4385 /* Left or right arm of the conditional? */
4386 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4387 OP *live = left ? trueop : falseop;
4388 OP *const dead = left ? falseop : trueop;
4389 if (first->op_private & OPpCONST_BARE &&
4390 first->op_private & OPpCONST_STRICT) {
4391 no_bareword_allowed(first);
4394 /* This is all dead code when PERL_MAD is not defined. */
4395 live = newUNOP(OP_NULL, 0, live);
4396 op_getmad(first, live, 'C');
4397 op_getmad(dead, live, left ? 'e' : 't');
4404 NewOp(1101, logop, 1, LOGOP);
4405 logop->op_type = OP_COND_EXPR;
4406 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4407 logop->op_first = first;
4408 logop->op_flags = (U8)(flags | OPf_KIDS);
4409 logop->op_private = (U8)(1 | (flags >> 8));
4410 logop->op_other = LINKLIST(trueop);
4411 logop->op_next = LINKLIST(falseop);
4413 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4416 /* establish postfix order */
4417 start = LINKLIST(first);
4418 first->op_next = (OP*)logop;
4420 first->op_sibling = trueop;
4421 trueop->op_sibling = falseop;
4422 o = newUNOP(OP_NULL, 0, (OP*)logop);
4424 trueop->op_next = falseop->op_next = o;
4431 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4440 NewOp(1101, range, 1, LOGOP);
4442 range->op_type = OP_RANGE;
4443 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4444 range->op_first = left;
4445 range->op_flags = OPf_KIDS;
4446 leftstart = LINKLIST(left);
4447 range->op_other = LINKLIST(right);
4448 range->op_private = (U8)(1 | (flags >> 8));
4450 left->op_sibling = right;
4452 range->op_next = (OP*)range;
4453 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4454 flop = newUNOP(OP_FLOP, 0, flip);
4455 o = newUNOP(OP_NULL, 0, flop);
4457 range->op_next = leftstart;
4459 left->op_next = flip;
4460 right->op_next = flop;
4462 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4463 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4464 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4465 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4467 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4468 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4471 if (!flip->op_private || !flop->op_private)
4472 linklist(o); /* blow off optimizer unless constant */
4478 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4483 const bool once = block && block->op_flags & OPf_SPECIAL &&
4484 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4486 PERL_UNUSED_ARG(debuggable);
4489 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4490 return block; /* do {} while 0 does once */
4491 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4492 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4493 expr = newUNOP(OP_DEFINED, 0,
4494 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4495 } else if (expr->op_flags & OPf_KIDS) {
4496 const OP * const k1 = ((UNOP*)expr)->op_first;
4497 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4498 switch (expr->op_type) {
4500 if (k2 && k2->op_type == OP_READLINE
4501 && (k2->op_flags & OPf_STACKED)
4502 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4503 expr = newUNOP(OP_DEFINED, 0, expr);
4507 if (k1 && (k1->op_type == OP_READDIR
4508 || k1->op_type == OP_GLOB
4509 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4510 || k1->op_type == OP_EACH))
4511 expr = newUNOP(OP_DEFINED, 0, expr);
4517 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4518 * op, in listop. This is wrong. [perl #27024] */
4520 block = newOP(OP_NULL, 0);
4521 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4522 o = new_logop(OP_AND, 0, &expr, &listop);
4525 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4527 if (once && o != listop)
4528 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4531 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4533 o->op_flags |= flags;
4535 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4540 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4541 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4550 PERL_UNUSED_ARG(debuggable);
4553 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4554 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4555 expr = newUNOP(OP_DEFINED, 0,
4556 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4557 } else if (expr->op_flags & OPf_KIDS) {
4558 const OP * const k1 = ((UNOP*)expr)->op_first;
4559 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4560 switch (expr->op_type) {
4562 if (k2 && k2->op_type == OP_READLINE
4563 && (k2->op_flags & OPf_STACKED)
4564 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4565 expr = newUNOP(OP_DEFINED, 0, expr);
4569 if (k1 && (k1->op_type == OP_READDIR
4570 || k1->op_type == OP_GLOB
4571 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4572 || k1->op_type == OP_EACH))
4573 expr = newUNOP(OP_DEFINED, 0, expr);
4580 block = newOP(OP_NULL, 0);
4581 else if (cont || has_my) {
4582 block = scope(block);
4586 next = LINKLIST(cont);
4589 OP * const unstack = newOP(OP_UNSTACK, 0);
4592 cont = append_elem(OP_LINESEQ, cont, unstack);
4596 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4598 redo = LINKLIST(listop);
4601 PL_copline = (line_t)whileline;
4603 o = new_logop(OP_AND, 0, &expr, &listop);
4604 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4605 op_free(expr); /* oops, it's a while (0) */
4607 return NULL; /* listop already freed by new_logop */
4610 ((LISTOP*)listop)->op_last->op_next =
4611 (o == listop ? redo : LINKLIST(o));
4617 NewOp(1101,loop,1,LOOP);
4618 loop->op_type = OP_ENTERLOOP;
4619 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4620 loop->op_private = 0;
4621 loop->op_next = (OP*)loop;
4624 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4626 loop->op_redoop = redo;
4627 loop->op_lastop = o;
4628 o->op_private |= loopflags;
4631 loop->op_nextop = next;
4633 loop->op_nextop = o;
4635 o->op_flags |= flags;
4636 o->op_private |= (flags >> 8);
4641 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4646 PADOFFSET padoff = 0;
4652 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4653 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4654 sv->op_type = OP_RV2GV;
4655 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4657 /* The op_type check is needed to prevent a possible segfault
4658 * if the loop variable is undeclared and 'strict vars' is in
4659 * effect. This is illegal but is nonetheless parsed, so we
4660 * may reach this point with an OP_CONST where we're expecting
4663 if (cUNOPx(sv)->op_first->op_type == OP_GV
4664 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4665 iterpflags |= OPpITER_DEF;
4667 else if (sv->op_type == OP_PADSV) { /* private variable */
4668 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4669 padoff = sv->op_targ;
4679 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4681 SV *const namesv = PAD_COMPNAME_SV(padoff);
4683 const char *const name = SvPV_const(namesv, len);
4685 if (len == 2 && name[0] == '$' && name[1] == '_')
4686 iterpflags |= OPpITER_DEF;
4690 const PADOFFSET offset = pad_findmy("$_");
4691 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4692 sv = newGVOP(OP_GV, 0, PL_defgv);
4697 iterpflags |= OPpITER_DEF;
4699 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4700 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4701 iterflags |= OPf_STACKED;
4703 else if (expr->op_type == OP_NULL &&
4704 (expr->op_flags & OPf_KIDS) &&
4705 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4707 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4708 * set the STACKED flag to indicate that these values are to be
4709 * treated as min/max values by 'pp_iterinit'.
4711 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4712 LOGOP* const range = (LOGOP*) flip->op_first;
4713 OP* const left = range->op_first;
4714 OP* const right = left->op_sibling;
4717 range->op_flags &= ~OPf_KIDS;
4718 range->op_first = NULL;
4720 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4721 listop->op_first->op_next = range->op_next;
4722 left->op_next = range->op_other;
4723 right->op_next = (OP*)listop;
4724 listop->op_next = listop->op_first;
4727 op_getmad(expr,(OP*)listop,'O');
4731 expr = (OP*)(listop);
4733 iterflags |= OPf_STACKED;
4736 expr = mod(force_list(expr), OP_GREPSTART);
4739 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4740 append_elem(OP_LIST, expr, scalar(sv))));
4741 assert(!loop->op_next);
4742 /* for my $x () sets OPpLVAL_INTRO;
4743 * for our $x () sets OPpOUR_INTRO */
4744 loop->op_private = (U8)iterpflags;
4745 #ifdef PL_OP_SLAB_ALLOC
4748 NewOp(1234,tmp,1,LOOP);
4749 Copy(loop,tmp,1,LISTOP);
4750 S_op_destroy(aTHX_ (OP*)loop);
4754 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4756 loop->op_targ = padoff;
4757 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4759 op_getmad(madsv, (OP*)loop, 'v');
4760 PL_copline = forline;
4761 return newSTATEOP(0, label, wop);
4765 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4770 if (type != OP_GOTO || label->op_type == OP_CONST) {
4771 /* "last()" means "last" */
4772 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4773 o = newOP(type, OPf_SPECIAL);
4775 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4776 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4780 op_getmad(label,o,'L');
4786 /* Check whether it's going to be a goto &function */
4787 if (label->op_type == OP_ENTERSUB
4788 && !(label->op_flags & OPf_STACKED))
4789 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4790 o = newUNOP(type, OPf_STACKED, label);
4792 PL_hints |= HINT_BLOCK_SCOPE;
4796 /* if the condition is a literal array or hash
4797 (or @{ ... } etc), make a reference to it.
4800 S_ref_array_or_hash(pTHX_ OP *cond)
4803 && (cond->op_type == OP_RV2AV
4804 || cond->op_type == OP_PADAV
4805 || cond->op_type == OP_RV2HV
4806 || cond->op_type == OP_PADHV))
4808 return newUNOP(OP_REFGEN,
4809 0, mod(cond, OP_REFGEN));
4815 /* These construct the optree fragments representing given()
4818 entergiven and enterwhen are LOGOPs; the op_other pointer
4819 points up to the associated leave op. We need this so we
4820 can put it in the context and make break/continue work.
4821 (Also, of course, pp_enterwhen will jump straight to
4822 op_other if the match fails.)
4826 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4827 I32 enter_opcode, I32 leave_opcode,
4828 PADOFFSET entertarg)
4834 NewOp(1101, enterop, 1, LOGOP);
4835 enterop->op_type = enter_opcode;
4836 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4837 enterop->op_flags = (U8) OPf_KIDS;
4838 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4839 enterop->op_private = 0;
4841 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4844 enterop->op_first = scalar(cond);
4845 cond->op_sibling = block;
4847 o->op_next = LINKLIST(cond);
4848 cond->op_next = (OP *) enterop;
4851 /* This is a default {} block */
4852 enterop->op_first = block;
4853 enterop->op_flags |= OPf_SPECIAL;
4855 o->op_next = (OP *) enterop;
4858 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4859 entergiven and enterwhen both
4862 enterop->op_next = LINKLIST(block);
4863 block->op_next = enterop->op_other = o;
4868 /* Does this look like a boolean operation? For these purposes
4869 a boolean operation is:
4870 - a subroutine call [*]
4871 - a logical connective
4872 - a comparison operator
4873 - a filetest operator, with the exception of -s -M -A -C
4874 - defined(), exists() or eof()
4875 - /$re/ or $foo =~ /$re/
4877 [*] possibly surprising
4880 S_looks_like_bool(pTHX_ const OP *o)
4883 switch(o->op_type) {
4885 return looks_like_bool(cLOGOPo->op_first);
4889 looks_like_bool(cLOGOPo->op_first)
4890 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4894 case OP_NOT: case OP_XOR:
4895 /* Note that OP_DOR is not here */
4897 case OP_EQ: case OP_NE: case OP_LT:
4898 case OP_GT: case OP_LE: case OP_GE:
4900 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4901 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4903 case OP_SEQ: case OP_SNE: case OP_SLT:
4904 case OP_SGT: case OP_SLE: case OP_SGE:
4908 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4909 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4910 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4911 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4912 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4913 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4914 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4915 case OP_FTTEXT: case OP_FTBINARY:
4917 case OP_DEFINED: case OP_EXISTS:
4918 case OP_MATCH: case OP_EOF:
4923 /* Detect comparisons that have been optimized away */
4924 if (cSVOPo->op_sv == &PL_sv_yes
4925 || cSVOPo->op_sv == &PL_sv_no)
4936 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4940 return newGIVWHENOP(
4941 ref_array_or_hash(cond),
4943 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4947 /* If cond is null, this is a default {} block */
4949 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4951 const bool cond_llb = (!cond || looks_like_bool(cond));
4957 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4959 scalar(ref_array_or_hash(cond)));
4962 return newGIVWHENOP(
4964 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4965 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4969 =for apidoc cv_undef
4971 Clear out all the active components of a CV. This can happen either
4972 by an explicit C<undef &foo>, or by the reference count going to zero.
4973 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4974 children can still follow the full lexical scope chain.
4980 Perl_cv_undef(pTHX_ CV *cv)
4984 if (CvFILE(cv) && !CvISXSUB(cv)) {
4985 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4986 Safefree(CvFILE(cv));
4991 if (!CvISXSUB(cv) && CvROOT(cv)) {
4992 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4993 Perl_croak(aTHX_ "Can't undef active subroutine");
4996 PAD_SAVE_SETNULLPAD();
4998 op_free(CvROOT(cv));
5003 SvPOK_off((SV*)cv); /* forget prototype */
5008 /* remove CvOUTSIDE unless this is an undef rather than a free */
5009 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5010 if (!CvWEAKOUTSIDE(cv))
5011 SvREFCNT_dec(CvOUTSIDE(cv));
5012 CvOUTSIDE(cv) = NULL;
5015 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5018 if (CvISXSUB(cv) && CvXSUB(cv)) {
5021 /* delete all flags except WEAKOUTSIDE */
5022 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5026 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5029 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5030 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5031 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5032 || (p && (len != SvCUR(cv) /* Not the same length. */
5033 || memNE(p, SvPVX_const(cv), len))))
5034 && ckWARN_d(WARN_PROTOTYPE)) {
5035 SV* const msg = sv_newmortal();
5039 gv_efullname3(name = sv_newmortal(), gv, NULL);
5040 sv_setpvs(msg, "Prototype mismatch:");
5042 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5044 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5046 sv_catpvs(msg, ": none");
5047 sv_catpvs(msg, " vs ");
5049 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5051 sv_catpvs(msg, "none");
5052 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5056 static void const_sv_xsub(pTHX_ CV* cv);
5060 =head1 Optree Manipulation Functions
5062 =for apidoc cv_const_sv
5064 If C<cv> is a constant sub eligible for inlining. returns the constant
5065 value returned by the sub. Otherwise, returns NULL.
5067 Constant subs can be created with C<newCONSTSUB> or as described in
5068 L<perlsub/"Constant Functions">.
5073 Perl_cv_const_sv(pTHX_ CV *cv)
5075 PERL_UNUSED_CONTEXT;
5078 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5080 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5083 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5084 * Can be called in 3 ways:
5087 * look for a single OP_CONST with attached value: return the value
5089 * cv && CvCLONE(cv) && !CvCONST(cv)
5091 * examine the clone prototype, and if contains only a single
5092 * OP_CONST referencing a pad const, or a single PADSV referencing
5093 * an outer lexical, return a non-zero value to indicate the CV is
5094 * a candidate for "constizing" at clone time
5098 * We have just cloned an anon prototype that was marked as a const
5099 * candidiate. Try to grab the current value, and in the case of
5100 * PADSV, ignore it if it has multiple references. Return the value.
5104 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5112 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5113 o = cLISTOPo->op_first->op_sibling;
5115 for (; o; o = o->op_next) {
5116 const OPCODE type = o->op_type;
5118 if (sv && o->op_next == o)
5120 if (o->op_next != o) {
5121 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5123 if (type == OP_DBSTATE)
5126 if (type == OP_LEAVESUB || type == OP_RETURN)
5130 if (type == OP_CONST && cSVOPo->op_sv)
5132 else if (cv && type == OP_CONST) {
5133 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5137 else if (cv && type == OP_PADSV) {
5138 if (CvCONST(cv)) { /* newly cloned anon */
5139 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5140 /* the candidate should have 1 ref from this pad and 1 ref
5141 * from the parent */
5142 if (!sv || SvREFCNT(sv) != 2)
5149 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5150 sv = &PL_sv_undef; /* an arbitrary non-null value */
5165 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5168 /* This would be the return value, but the return cannot be reached. */
5169 OP* pegop = newOP(OP_NULL, 0);
5172 PERL_UNUSED_ARG(floor);
5182 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5184 NORETURN_FUNCTION_END;
5189 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5191 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5195 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5202 register CV *cv = NULL;
5204 /* If the subroutine has no body, no attributes, and no builtin attributes
5205 then it's just a sub declaration, and we may be able to get away with
5206 storing with a placeholder scalar in the symbol table, rather than a
5207 full GV and CV. If anything is present then it will take a full CV to
5209 const I32 gv_fetch_flags
5210 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5212 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5213 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5216 assert(proto->op_type == OP_CONST);
5217 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5222 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5223 SV * const sv = sv_newmortal();
5224 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5225 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5226 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5227 aname = SvPVX_const(sv);
5232 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5233 : gv_fetchpv(aname ? aname
5234 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5235 gv_fetch_flags, SVt_PVCV);
5237 if (!PL_madskills) {
5246 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5247 maximum a prototype before. */
5248 if (SvTYPE(gv) > SVt_NULL) {
5249 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5250 && ckWARN_d(WARN_PROTOTYPE))
5252 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5254 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5257 sv_setpvn((SV*)gv, ps, ps_len);
5259 sv_setiv((SV*)gv, -1);
5261 SvREFCNT_dec(PL_compcv);
5262 cv = PL_compcv = NULL;
5266 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5268 #ifdef GV_UNIQUE_CHECK
5269 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5270 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5274 if (!block || !ps || *ps || attrs
5275 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5277 || block->op_type == OP_NULL
5282 const_sv = op_const_sv(block, NULL);
5285 const bool exists = CvROOT(cv) || CvXSUB(cv);
5287 #ifdef GV_UNIQUE_CHECK
5288 if (exists && GvUNIQUE(gv)) {
5289 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5293 /* if the subroutine doesn't exist and wasn't pre-declared
5294 * with a prototype, assume it will be AUTOLOADed,
5295 * skipping the prototype check
5297 if (exists || SvPOK(cv))
5298 cv_ckproto_len(cv, gv, ps, ps_len);
5299 /* already defined (or promised)? */
5300 if (exists || GvASSUMECV(gv)) {
5303 || block->op_type == OP_NULL
5306 if (CvFLAGS(PL_compcv)) {
5307 /* might have had built-in attrs applied */
5308 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5310 /* just a "sub foo;" when &foo is already defined */
5311 SAVEFREESV(PL_compcv);
5316 && block->op_type != OP_NULL
5319 if (ckWARN(WARN_REDEFINE)
5321 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5323 const line_t oldline = CopLINE(PL_curcop);
5324 if (PL_copline != NOLINE)
5325 CopLINE_set(PL_curcop, PL_copline);
5326 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5327 CvCONST(cv) ? "Constant subroutine %s redefined"
5328 : "Subroutine %s redefined", name);
5329 CopLINE_set(PL_curcop, oldline);
5332 if (!PL_minus_c) /* keep old one around for madskills */
5335 /* (PL_madskills unset in used file.) */
5343 SvREFCNT_inc_simple_void_NN(const_sv);
5345 assert(!CvROOT(cv) && !CvCONST(cv));
5346 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5347 CvXSUBANY(cv).any_ptr = const_sv;
5348 CvXSUB(cv) = const_sv_xsub;
5354 cv = newCONSTSUB(NULL, name, const_sv);
5356 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5357 (CvGV(cv) && GvSTASH(CvGV(cv)))
5366 SvREFCNT_dec(PL_compcv);
5374 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5375 * before we clobber PL_compcv.
5379 || block->op_type == OP_NULL
5383 /* Might have had built-in attributes applied -- propagate them. */
5384 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5385 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5386 stash = GvSTASH(CvGV(cv));
5387 else if (CvSTASH(cv))
5388 stash = CvSTASH(cv);
5390 stash = PL_curstash;
5393 /* possibly about to re-define existing subr -- ignore old cv */
5394 rcv = (SV*)PL_compcv;
5395 if (name && GvSTASH(gv))
5396 stash = GvSTASH(gv);
5398 stash = PL_curstash;
5400 apply_attrs(stash, rcv, attrs, FALSE);
5402 if (cv) { /* must reuse cv if autoloaded */
5409 || block->op_type == OP_NULL) && !PL_madskills
5412 /* got here with just attrs -- work done, so bug out */
5413 SAVEFREESV(PL_compcv);
5416 /* transfer PL_compcv to cv */
5418 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5419 if (!CvWEAKOUTSIDE(cv))
5420 SvREFCNT_dec(CvOUTSIDE(cv));
5421 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5422 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5423 CvOUTSIDE(PL_compcv) = 0;
5424 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5425 CvPADLIST(PL_compcv) = 0;
5426 /* inner references to PL_compcv must be fixed up ... */
5427 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5428 /* ... before we throw it away */
5429 SvREFCNT_dec(PL_compcv);
5431 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5432 ++PL_sub_generation;
5439 if (strEQ(name, "import")) {
5440 PL_formfeed = (SV*)cv;
5441 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5445 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5449 CvFILE_set_from_cop(cv, PL_curcop);
5450 CvSTASH(cv) = PL_curstash;
5453 sv_setpvn((SV*)cv, ps, ps_len);
5455 if (PL_error_count) {
5459 const char *s = strrchr(name, ':');
5461 if (strEQ(s, "BEGIN")) {
5462 const char not_safe[] =
5463 "BEGIN not safe after errors--compilation aborted";
5464 if (PL_in_eval & EVAL_KEEPERR)
5465 Perl_croak(aTHX_ not_safe);
5467 /* force display of errors found but not reported */
5468 sv_catpv(ERRSV, not_safe);
5469 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5479 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5480 mod(scalarseq(block), OP_LEAVESUBLV));
5481 block->op_attached = 1;
5484 /* This makes sub {}; work as expected. */
5485 if (block->op_type == OP_STUB) {
5486 OP* const newblock = newSTATEOP(0, NULL, 0);
5488 op_getmad(block,newblock,'B');
5495 block->op_attached = 1;
5496 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5498 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5499 OpREFCNT_set(CvROOT(cv), 1);
5500 CvSTART(cv) = LINKLIST(CvROOT(cv));
5501 CvROOT(cv)->op_next = 0;
5502 CALL_PEEP(CvSTART(cv));
5504 /* now that optimizer has done its work, adjust pad values */
5506 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5509 assert(!CvCONST(cv));
5510 if (ps && !*ps && op_const_sv(block, cv))
5514 if (name || aname) {
5515 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5516 SV * const sv = newSV(0);
5517 SV * const tmpstr = sv_newmortal();
5518 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5519 GV_ADDMULTI, SVt_PVHV);
5522 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5524 (long)PL_subline, (long)CopLINE(PL_curcop));
5525 gv_efullname3(tmpstr, gv, NULL);
5526 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5527 hv = GvHVn(db_postponed);
5528 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5529 CV * const pcv = GvCV(db_postponed);
5535 call_sv((SV*)pcv, G_DISCARD);
5540 if (name && !PL_error_count)
5541 process_special_blocks(name, gv, cv);
5545 PL_copline = NOLINE;
5551 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5554 const char *const colon = strrchr(fullname,':');
5555 const char *const name = colon ? colon + 1 : fullname;
5558 if (strEQ(name, "BEGIN")) {
5559 const I32 oldscope = PL_scopestack_ix;
5561 SAVECOPFILE(&PL_compiling);
5562 SAVECOPLINE(&PL_compiling);
5564 DEBUG_x( dump_sub(gv) );
5565 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5566 GvCV(gv) = 0; /* cv has been hijacked */
5567 call_list(oldscope, PL_beginav);
5569 PL_curcop = &PL_compiling;
5570 CopHINTS_set(&PL_compiling, PL_hints);
5577 if strEQ(name, "END") {
5578 DEBUG_x( dump_sub(gv) );
5579 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5582 } else if (*name == 'U') {
5583 if (strEQ(name, "UNITCHECK")) {
5584 /* It's never too late to run a unitcheck block */
5585 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5589 } else if (*name == 'C') {
5590 if (strEQ(name, "CHECK")) {
5591 if (PL_main_start && ckWARN(WARN_VOID))
5592 Perl_warner(aTHX_ packWARN(WARN_VOID),
5593 "Too late to run CHECK block");
5594 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5598 } else if (*name == 'I') {
5599 if (strEQ(name, "INIT")) {
5600 if (PL_main_start && ckWARN(WARN_VOID))
5601 Perl_warner(aTHX_ packWARN(WARN_VOID),
5602 "Too late to run INIT block");
5603 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5609 DEBUG_x( dump_sub(gv) );
5610 GvCV(gv) = 0; /* cv has been hijacked */
5615 =for apidoc newCONSTSUB
5617 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5618 eligible for inlining at compile-time.
5624 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5629 const char *const temp_p = CopFILE(PL_curcop);
5630 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5632 SV *const temp_sv = CopFILESV(PL_curcop);
5634 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5636 char *const file = savepvn(temp_p, temp_p ? len : 0);
5640 SAVECOPLINE(PL_curcop);
5641 CopLINE_set(PL_curcop, PL_copline);
5644 PL_hints &= ~HINT_BLOCK_SCOPE;
5647 SAVESPTR(PL_curstash);
5648 SAVECOPSTASH(PL_curcop);
5649 PL_curstash = stash;
5650 CopSTASH_set(PL_curcop,stash);
5653 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5654 and so doesn't get free()d. (It's expected to be from the C pre-
5655 processor __FILE__ directive). But we need a dynamically allocated one,
5656 and we need it to get freed. */
5657 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5658 CvXSUBANY(cv).any_ptr = sv;
5664 CopSTASH_free(PL_curcop);
5672 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5673 const char *const filename, const char *const proto,
5676 CV *cv = newXS(name, subaddr, filename);
5678 if (flags & XS_DYNAMIC_FILENAME) {
5679 /* We need to "make arrangements" (ie cheat) to ensure that the
5680 filename lasts as long as the PVCV we just created, but also doesn't
5682 STRLEN filename_len = strlen(filename);
5683 STRLEN proto_and_file_len = filename_len;
5684 char *proto_and_file;
5688 proto_len = strlen(proto);
5689 proto_and_file_len += proto_len;
5691 Newx(proto_and_file, proto_and_file_len + 1, char);
5692 Copy(proto, proto_and_file, proto_len, char);
5693 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5696 proto_and_file = savepvn(filename, filename_len);
5699 /* This gets free()d. :-) */
5700 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5701 SV_HAS_TRAILING_NUL);
5703 /* This gives us the correct prototype, rather than one with the
5704 file name appended. */
5705 SvCUR_set(cv, proto_len);
5709 CvFILE(cv) = proto_and_file + proto_len;
5711 sv_setpv((SV *)cv, proto);
5717 =for apidoc U||newXS
5719 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5720 static storage, as it is used directly as CvFILE(), without a copy being made.
5726 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5729 GV * const gv = gv_fetchpv(name ? name :
5730 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5731 GV_ADDMULTI, SVt_PVCV);
5735 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5737 if ((cv = (name ? GvCV(gv) : NULL))) {
5739 /* just a cached method */
5743 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5744 /* already defined (or promised) */
5745 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5746 if (ckWARN(WARN_REDEFINE)) {
5747 GV * const gvcv = CvGV(cv);
5749 HV * const stash = GvSTASH(gvcv);
5751 const char *redefined_name = HvNAME_get(stash);
5752 if ( strEQ(redefined_name,"autouse") ) {
5753 const line_t oldline = CopLINE(PL_curcop);
5754 if (PL_copline != NOLINE)
5755 CopLINE_set(PL_curcop, PL_copline);
5756 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5757 CvCONST(cv) ? "Constant subroutine %s redefined"
5758 : "Subroutine %s redefined"
5760 CopLINE_set(PL_curcop, oldline);
5770 if (cv) /* must reuse cv if autoloaded */
5773 cv = (CV*)newSV_type(SVt_PVCV);
5777 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5781 (void)gv_fetchfile(filename);
5782 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5783 an external constant string */
5785 CvXSUB(cv) = subaddr;
5788 process_special_blocks(name, gv, cv);
5800 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5805 OP* pegop = newOP(OP_NULL, 0);
5809 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5810 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5812 #ifdef GV_UNIQUE_CHECK
5814 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5818 if ((cv = GvFORM(gv))) {
5819 if (ckWARN(WARN_REDEFINE)) {
5820 const line_t oldline = CopLINE(PL_curcop);
5821 if (PL_copline != NOLINE)
5822 CopLINE_set(PL_curcop, PL_copline);
5823 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5824 o ? "Format %"SVf" redefined"
5825 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5826 CopLINE_set(PL_curcop, oldline);
5833 CvFILE_set_from_cop(cv, PL_curcop);
5836 pad_tidy(padtidy_FORMAT);
5837 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5838 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5839 OpREFCNT_set(CvROOT(cv), 1);
5840 CvSTART(cv) = LINKLIST(CvROOT(cv));
5841 CvROOT(cv)->op_next = 0;
5842 CALL_PEEP(CvSTART(cv));
5844 op_getmad(o,pegop,'n');
5845 op_getmad_weak(block, pegop, 'b');
5849 PL_copline = NOLINE;
5857 Perl_newANONLIST(pTHX_ OP *o)
5859 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5863 Perl_newANONHASH(pTHX_ OP *o)
5865 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5869 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5871 return newANONATTRSUB(floor, proto, NULL, block);
5875 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5877 return newUNOP(OP_REFGEN, 0,
5878 newSVOP(OP_ANONCODE, 0,
5879 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5883 Perl_oopsAV(pTHX_ OP *o)
5886 switch (o->op_type) {
5888 o->op_type = OP_PADAV;
5889 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5890 return ref(o, OP_RV2AV);
5893 o->op_type = OP_RV2AV;
5894 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5899 if (ckWARN_d(WARN_INTERNAL))
5900 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5907 Perl_oopsHV(pTHX_ OP *o)
5910 switch (o->op_type) {
5913 o->op_type = OP_PADHV;
5914 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5915 return ref(o, OP_RV2HV);
5919 o->op_type = OP_RV2HV;
5920 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5925 if (ckWARN_d(WARN_INTERNAL))
5926 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5933 Perl_newAVREF(pTHX_ OP *o)
5936 if (o->op_type == OP_PADANY) {
5937 o->op_type = OP_PADAV;
5938 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5941 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5942 && ckWARN(WARN_DEPRECATED)) {
5943 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5944 "Using an array as a reference is deprecated");
5946 return newUNOP(OP_RV2AV, 0, scalar(o));
5950 Perl_newGVREF(pTHX_ I32 type, OP *o)
5952 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5953 return newUNOP(OP_NULL, 0, o);
5954 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5958 Perl_newHVREF(pTHX_ OP *o)
5961 if (o->op_type == OP_PADANY) {
5962 o->op_type = OP_PADHV;
5963 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5966 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5967 && ckWARN(WARN_DEPRECATED)) {
5968 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5969 "Using a hash as a reference is deprecated");
5971 return newUNOP(OP_RV2HV, 0, scalar(o));
5975 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5977 return newUNOP(OP_RV2CV, flags, scalar(o));
5981 Perl_newSVREF(pTHX_ OP *o)
5984 if (o->op_type == OP_PADANY) {
5985 o->op_type = OP_PADSV;
5986 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5989 return newUNOP(OP_RV2SV, 0, scalar(o));
5992 /* Check routines. See the comments at the top of this file for details
5993 * on when these are called */
5996 Perl_ck_anoncode(pTHX_ OP *o)
5998 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6000 cSVOPo->op_sv = NULL;
6005 Perl_ck_bitop(pTHX_ OP *o)
6008 #define OP_IS_NUMCOMPARE(op) \
6009 ((op) == OP_LT || (op) == OP_I_LT || \
6010 (op) == OP_GT || (op) == OP_I_GT || \
6011 (op) == OP_LE || (op) == OP_I_LE || \
6012 (op) == OP_GE || (op) == OP_I_GE || \
6013 (op) == OP_EQ || (op) == OP_I_EQ || \
6014 (op) == OP_NE || (op) == OP_I_NE || \
6015 (op) == OP_NCMP || (op) == OP_I_NCMP)
6016 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6017 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6018 && (o->op_type == OP_BIT_OR
6019 || o->op_type == OP_BIT_AND
6020 || o->op_type == OP_BIT_XOR))
6022 const OP * const left = cBINOPo->op_first;
6023 const OP * const right = left->op_sibling;
6024 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6025 (left->op_flags & OPf_PARENS) == 0) ||
6026 (OP_IS_NUMCOMPARE(right->op_type) &&
6027 (right->op_flags & OPf_PARENS) == 0))
6028 if (ckWARN(WARN_PRECEDENCE))
6029 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6030 "Possible precedence problem on bitwise %c operator",
6031 o->op_type == OP_BIT_OR ? '|'
6032 : o->op_type == OP_BIT_AND ? '&' : '^'
6039 Perl_ck_concat(pTHX_ OP *o)
6041 const OP * const kid = cUNOPo->op_first;
6042 PERL_UNUSED_CONTEXT;
6043 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6044 !(kUNOP->op_first->op_flags & OPf_MOD))
6045 o->op_flags |= OPf_STACKED;
6050 Perl_ck_spair(pTHX_ OP *o)
6053 if (o->op_flags & OPf_KIDS) {
6056 const OPCODE type = o->op_type;
6057 o = modkids(ck_fun(o), type);
6058 kid = cUNOPo->op_first;
6059 newop = kUNOP->op_first->op_sibling;
6061 const OPCODE type = newop->op_type;
6062 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6063 type == OP_PADAV || type == OP_PADHV ||
6064 type == OP_RV2AV || type == OP_RV2HV)
6068 op_getmad(kUNOP->op_first,newop,'K');
6070 op_free(kUNOP->op_first);
6072 kUNOP->op_first = newop;
6074 o->op_ppaddr = PL_ppaddr[++o->op_type];
6079 Perl_ck_delete(pTHX_ OP *o)
6083 if (o->op_flags & OPf_KIDS) {
6084 OP * const kid = cUNOPo->op_first;
6085 switch (kid->op_type) {
6087 o->op_flags |= OPf_SPECIAL;
6090 o->op_private |= OPpSLICE;
6093 o->op_flags |= OPf_SPECIAL;
6098 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6107 Perl_ck_die(pTHX_ OP *o)
6110 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6116 Perl_ck_eof(pTHX_ OP *o)
6120 if (o->op_flags & OPf_KIDS) {
6121 if (cLISTOPo->op_first->op_type == OP_STUB) {
6123 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6125 op_getmad(o,newop,'O');
6137 Perl_ck_eval(pTHX_ OP *o)
6140 PL_hints |= HINT_BLOCK_SCOPE;
6141 if (o->op_flags & OPf_KIDS) {
6142 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6145 o->op_flags &= ~OPf_KIDS;
6148 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6154 cUNOPo->op_first = 0;
6159 NewOp(1101, enter, 1, LOGOP);
6160 enter->op_type = OP_ENTERTRY;
6161 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6162 enter->op_private = 0;
6164 /* establish postfix order */
6165 enter->op_next = (OP*)enter;
6167 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6168 o->op_type = OP_LEAVETRY;
6169 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6170 enter->op_other = o;
6171 op_getmad(oldo,o,'O');
6185 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6186 op_getmad(oldo,o,'O');
6188 o->op_targ = (PADOFFSET)PL_hints;
6189 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6190 /* Store a copy of %^H that pp_entereval can pick up.
6191 OPf_SPECIAL flags the opcode as being for this purpose,
6192 so that it in turn will return a copy at every
6194 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6195 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6196 cUNOPo->op_first->op_sibling = hhop;
6197 o->op_private |= OPpEVAL_HAS_HH;
6203 Perl_ck_exit(pTHX_ OP *o)
6206 HV * const table = GvHV(PL_hintgv);
6208 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6209 if (svp && *svp && SvTRUE(*svp))
6210 o->op_private |= OPpEXIT_VMSISH;
6212 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6218 Perl_ck_exec(pTHX_ OP *o)
6220 if (o->op_flags & OPf_STACKED) {
6223 kid = cUNOPo->op_first->op_sibling;
6224 if (kid->op_type == OP_RV2GV)
6233 Perl_ck_exists(pTHX_ OP *o)
6237 if (o->op_flags & OPf_KIDS) {
6238 OP * const kid = cUNOPo->op_first;
6239 if (kid->op_type == OP_ENTERSUB) {
6240 (void) ref(kid, o->op_type);
6241 if (kid->op_type != OP_RV2CV && !PL_error_count)
6242 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6244 o->op_private |= OPpEXISTS_SUB;
6246 else if (kid->op_type == OP_AELEM)
6247 o->op_flags |= OPf_SPECIAL;
6248 else if (kid->op_type != OP_HELEM)
6249 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6257 Perl_ck_rvconst(pTHX_ register OP *o)
6260 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6262 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6263 if (o->op_type == OP_RV2CV)
6264 o->op_private &= ~1;
6266 if (kid->op_type == OP_CONST) {
6269 SV * const kidsv = kid->op_sv;
6271 /* Is it a constant from cv_const_sv()? */
6272 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6273 SV * const rsv = SvRV(kidsv);
6274 const svtype type = SvTYPE(rsv);
6275 const char *badtype = NULL;
6277 switch (o->op_type) {
6279 if (type > SVt_PVMG)
6280 badtype = "a SCALAR";
6283 if (type != SVt_PVAV)
6284 badtype = "an ARRAY";
6287 if (type != SVt_PVHV)
6291 if (type != SVt_PVCV)
6296 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6299 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6300 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6301 /* If this is an access to a stash, disable "strict refs", because
6302 * stashes aren't auto-vivified at compile-time (unless we store
6303 * symbols in them), and we don't want to produce a run-time
6304 * stricture error when auto-vivifying the stash. */
6305 const char *s = SvPV_nolen(kidsv);
6306 const STRLEN l = SvCUR(kidsv);
6307 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6308 o->op_private &= ~HINT_STRICT_REFS;
6310 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6311 const char *badthing;
6312 switch (o->op_type) {
6314 badthing = "a SCALAR";
6317 badthing = "an ARRAY";
6320 badthing = "a HASH";
6328 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6329 SVfARG(kidsv), badthing);
6332 * This is a little tricky. We only want to add the symbol if we
6333 * didn't add it in the lexer. Otherwise we get duplicate strict
6334 * warnings. But if we didn't add it in the lexer, we must at
6335 * least pretend like we wanted to add it even if it existed before,
6336 * or we get possible typo warnings. OPpCONST_ENTERED says
6337 * whether the lexer already added THIS instance of this symbol.
6339 iscv = (o->op_type == OP_RV2CV) * 2;
6341 gv = gv_fetchsv(kidsv,
6342 iscv | !(kid->op_private & OPpCONST_ENTERED),
6345 : o->op_type == OP_RV2SV
6347 : o->op_type == OP_RV2AV
6349 : o->op_type == OP_RV2HV
6352 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6354 kid->op_type = OP_GV;
6355 SvREFCNT_dec(kid->op_sv);
6357 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6358 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6359 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6361 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6363 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6365 kid->op_private = 0;
6366 kid->op_ppaddr = PL_ppaddr[OP_GV];
6373 Perl_ck_ftst(pTHX_ OP *o)
6376 const I32 type = o->op_type;
6378 if (o->op_flags & OPf_REF) {
6381 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6382 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6383 const OPCODE kidtype = kid->op_type;
6385 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6386 OP * const newop = newGVOP(type, OPf_REF,
6387 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6389 op_getmad(o,newop,'O');
6395 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6396 o->op_private |= OPpFT_ACCESS;
6397 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6398 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6399 o->op_private |= OPpFT_STACKED;
6407 if (type == OP_FTTTY)
6408 o = newGVOP(type, OPf_REF, PL_stdingv);
6410 o = newUNOP(type, 0, newDEFSVOP());
6411 op_getmad(oldo,o,'O');
6417 Perl_ck_fun(pTHX_ OP *o)
6420 const int type = o->op_type;
6421 register I32 oa = PL_opargs[type] >> OASHIFT;
6423 if (o->op_flags & OPf_STACKED) {
6424 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6427 return no_fh_allowed(o);
6430 if (o->op_flags & OPf_KIDS) {
6431 OP **tokid = &cLISTOPo->op_first;
6432 register OP *kid = cLISTOPo->op_first;
6436 if (kid->op_type == OP_PUSHMARK ||
6437 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6439 tokid = &kid->op_sibling;
6440 kid = kid->op_sibling;
6442 if (!kid && PL_opargs[type] & OA_DEFGV)
6443 *tokid = kid = newDEFSVOP();
6447 sibl = kid->op_sibling;
6449 if (!sibl && kid->op_type == OP_STUB) {
6456 /* list seen where single (scalar) arg expected? */
6457 if (numargs == 1 && !(oa >> 4)
6458 && kid->op_type == OP_LIST && type != OP_SCALAR)
6460 return too_many_arguments(o,PL_op_desc[type]);
6473 if ((type == OP_PUSH || type == OP_UNSHIFT)
6474 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6475 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6476 "Useless use of %s with no values",
6479 if (kid->op_type == OP_CONST &&
6480 (kid->op_private & OPpCONST_BARE))
6482 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6483 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6484 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6485 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6486 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6487 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6489 op_getmad(kid,newop,'K');
6494 kid->op_sibling = sibl;
6497 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6498 bad_type(numargs, "array", PL_op_desc[type], kid);
6502 if (kid->op_type == OP_CONST &&
6503 (kid->op_private & OPpCONST_BARE))
6505 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6506 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6507 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6508 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6509 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6510 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6512 op_getmad(kid,newop,'K');
6517 kid->op_sibling = sibl;
6520 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6521 bad_type(numargs, "hash", PL_op_desc[type], kid);
6526 OP * const newop = newUNOP(OP_NULL, 0, kid);
6527 kid->op_sibling = 0;
6529 newop->op_next = newop;
6531 kid->op_sibling = sibl;
6536 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6537 if (kid->op_type == OP_CONST &&
6538 (kid->op_private & OPpCONST_BARE))
6540 OP * const newop = newGVOP(OP_GV, 0,
6541 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6542 if (!(o->op_private & 1) && /* if not unop */
6543 kid == cLISTOPo->op_last)
6544 cLISTOPo->op_last = newop;
6546 op_getmad(kid,newop,'K');
6552 else if (kid->op_type == OP_READLINE) {
6553 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6554 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6557 I32 flags = OPf_SPECIAL;
6561 /* is this op a FH constructor? */
6562 if (is_handle_constructor(o,numargs)) {
6563 const char *name = NULL;
6567 /* Set a flag to tell rv2gv to vivify
6568 * need to "prove" flag does not mean something
6569 * else already - NI-S 1999/05/07
6572 if (kid->op_type == OP_PADSV) {
6574 = PAD_COMPNAME_SV(kid->op_targ);
6575 name = SvPV_const(namesv, len);
6577 else if (kid->op_type == OP_RV2SV
6578 && kUNOP->op_first->op_type == OP_GV)
6580 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6582 len = GvNAMELEN(gv);
6584 else if (kid->op_type == OP_AELEM
6585 || kid->op_type == OP_HELEM)
6588 OP *op = ((BINOP*)kid)->op_first;
6592 const char * const a =
6593 kid->op_type == OP_AELEM ?
6595 if (((op->op_type == OP_RV2AV) ||
6596 (op->op_type == OP_RV2HV)) &&
6597 (firstop = ((UNOP*)op)->op_first) &&
6598 (firstop->op_type == OP_GV)) {
6599 /* packagevar $a[] or $h{} */
6600 GV * const gv = cGVOPx_gv(firstop);
6608 else if (op->op_type == OP_PADAV
6609 || op->op_type == OP_PADHV) {
6610 /* lexicalvar $a[] or $h{} */
6611 const char * const padname =
6612 PAD_COMPNAME_PV(op->op_targ);
6621 name = SvPV_const(tmpstr, len);
6626 name = "__ANONIO__";
6633 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6634 namesv = PAD_SVl(targ);
6635 SvUPGRADE(namesv, SVt_PV);
6637 sv_setpvn(namesv, "$", 1);
6638 sv_catpvn(namesv, name, len);
6641 kid->op_sibling = 0;
6642 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6643 kid->op_targ = targ;
6644 kid->op_private |= priv;
6646 kid->op_sibling = sibl;
6652 mod(scalar(kid), type);
6656 tokid = &kid->op_sibling;
6657 kid = kid->op_sibling;
6660 if (kid && kid->op_type != OP_STUB)
6661 return too_many_arguments(o,OP_DESC(o));
6662 o->op_private |= numargs;
6664 /* FIXME - should the numargs move as for the PERL_MAD case? */
6665 o->op_private |= numargs;
6667 return too_many_arguments(o,OP_DESC(o));
6671 else if (PL_opargs[type] & OA_DEFGV) {
6673 OP *newop = newUNOP(type, 0, newDEFSVOP());
6674 op_getmad(o,newop,'O');
6677 /* Ordering of these two is important to keep f_map.t passing. */
6679 return newUNOP(type, 0, newDEFSVOP());
6684 while (oa & OA_OPTIONAL)
6686 if (oa && oa != OA_LIST)
6687 return too_few_arguments(o,OP_DESC(o));
6693 Perl_ck_glob(pTHX_ OP *o)
6699 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6700 append_elem(OP_GLOB, o, newDEFSVOP());
6702 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6703 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6705 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6708 #if !defined(PERL_EXTERNAL_GLOB)
6709 /* XXX this can be tightened up and made more failsafe. */
6710 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6713 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6714 newSVpvs("File::Glob"), NULL, NULL, NULL);
6715 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6716 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6717 GvCV(gv) = GvCV(glob_gv);
6718 SvREFCNT_inc_void((SV*)GvCV(gv));
6719 GvIMPORTED_CV_on(gv);
6722 #endif /* PERL_EXTERNAL_GLOB */
6724 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6725 append_elem(OP_GLOB, o,
6726 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6727 o->op_type = OP_LIST;
6728 o->op_ppaddr = PL_ppaddr[OP_LIST];
6729 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6730 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6731 cLISTOPo->op_first->op_targ = 0;
6732 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6733 append_elem(OP_LIST, o,
6734 scalar(newUNOP(OP_RV2CV, 0,
6735 newGVOP(OP_GV, 0, gv)))));
6736 o = newUNOP(OP_NULL, 0, ck_subr(o));
6737 o->op_targ = OP_GLOB; /* hint at what it used to be */
6740 gv = newGVgen("main");
6742 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6748 Perl_ck_grep(pTHX_ OP *o)
6753 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6756 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6757 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6759 if (o->op_flags & OPf_STACKED) {
6762 kid = cLISTOPo->op_first->op_sibling;
6763 if (!cUNOPx(kid)->op_next)
6764 Perl_croak(aTHX_ "panic: ck_grep");
6765 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6768 NewOp(1101, gwop, 1, LOGOP);
6769 kid->op_next = (OP*)gwop;
6770 o->op_flags &= ~OPf_STACKED;
6772 kid = cLISTOPo->op_first->op_sibling;
6773 if (type == OP_MAPWHILE)
6780 kid = cLISTOPo->op_first->op_sibling;
6781 if (kid->op_type != OP_NULL)
6782 Perl_croak(aTHX_ "panic: ck_grep");
6783 kid = kUNOP->op_first;
6786 NewOp(1101, gwop, 1, LOGOP);
6787 gwop->op_type = type;
6788 gwop->op_ppaddr = PL_ppaddr[type];
6789 gwop->op_first = listkids(o);
6790 gwop->op_flags |= OPf_KIDS;
6791 gwop->op_other = LINKLIST(kid);
6792 kid->op_next = (OP*)gwop;
6793 offset = pad_findmy("$_");
6794 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6795 o->op_private = gwop->op_private = 0;
6796 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6799 o->op_private = gwop->op_private = OPpGREP_LEX;
6800 gwop->op_targ = o->op_targ = offset;
6803 kid = cLISTOPo->op_first->op_sibling;
6804 if (!kid || !kid->op_sibling)
6805 return too_few_arguments(o,OP_DESC(o));
6806 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6807 mod(kid, OP_GREPSTART);
6813 Perl_ck_index(pTHX_ OP *o)
6815 if (o->op_flags & OPf_KIDS) {
6816 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6818 kid = kid->op_sibling; /* get past "big" */
6819 if (kid && kid->op_type == OP_CONST)
6820 fbm_compile(((SVOP*)kid)->op_sv, 0);
6826 Perl_ck_lengthconst(pTHX_ OP *o)
6828 /* XXX length optimization goes here */
6833 Perl_ck_lfun(pTHX_ OP *o)
6835 const OPCODE type = o->op_type;
6836 return modkids(ck_fun(o), type);
6840 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6842 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6843 switch (cUNOPo->op_first->op_type) {
6845 /* This is needed for
6846 if (defined %stash::)
6847 to work. Do not break Tk.
6849 break; /* Globals via GV can be undef */
6851 case OP_AASSIGN: /* Is this a good idea? */
6852 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6853 "defined(@array) is deprecated");
6854 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6855 "\t(Maybe you should just omit the defined()?)\n");
6858 /* This is needed for
6859 if (defined %stash::)
6860 to work. Do not break Tk.
6862 break; /* Globals via GV can be undef */
6864 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6865 "defined(%%hash) is deprecated");
6866 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6867 "\t(Maybe you should just omit the defined()?)\n");
6878 Perl_ck_readline(pTHX_ OP *o)
6880 if (!(o->op_flags & OPf_KIDS)) {
6882 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6884 op_getmad(o,newop,'O');
6894 Perl_ck_rfun(pTHX_ OP *o)
6896 const OPCODE type = o->op_type;
6897 return refkids(ck_fun(o), type);
6901 Perl_ck_listiob(pTHX_ OP *o)
6905 kid = cLISTOPo->op_first;
6908 kid = cLISTOPo->op_first;
6910 if (kid->op_type == OP_PUSHMARK)
6911 kid = kid->op_sibling;
6912 if (kid && o->op_flags & OPf_STACKED)
6913 kid = kid->op_sibling;
6914 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6915 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6916 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6917 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6918 cLISTOPo->op_first->op_sibling = kid;
6919 cLISTOPo->op_last = kid;
6920 kid = kid->op_sibling;
6925 append_elem(o->op_type, o, newDEFSVOP());
6931 Perl_ck_smartmatch(pTHX_ OP *o)
6934 if (0 == (o->op_flags & OPf_SPECIAL)) {
6935 OP *first = cBINOPo->op_first;
6936 OP *second = first->op_sibling;
6938 /* Implicitly take a reference to an array or hash */
6939 first->op_sibling = NULL;
6940 first = cBINOPo->op_first = ref_array_or_hash(first);
6941 second = first->op_sibling = ref_array_or_hash(second);
6943 /* Implicitly take a reference to a regular expression */
6944 if (first->op_type == OP_MATCH) {
6945 first->op_type = OP_QR;
6946 first->op_ppaddr = PL_ppaddr[OP_QR];
6948 if (second->op_type == OP_MATCH) {
6949 second->op_type = OP_QR;
6950 second->op_ppaddr = PL_ppaddr[OP_QR];
6959 Perl_ck_sassign(pTHX_ OP *o)
6961 OP * const kid = cLISTOPo->op_first;
6962 /* has a disposable target? */
6963 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6964 && !(kid->op_flags & OPf_STACKED)
6965 /* Cannot steal the second time! */
6966 && !(kid->op_private & OPpTARGET_MY))
6968 OP * const kkid = kid->op_sibling;
6970 /* Can just relocate the target. */
6971 if (kkid && kkid->op_type == OP_PADSV
6972 && !(kkid->op_private & OPpLVAL_INTRO))
6974 kid->op_targ = kkid->op_targ;
6976 /* Now we do not need PADSV and SASSIGN. */
6977 kid->op_sibling = o->op_sibling; /* NULL */
6978 cLISTOPo->op_first = NULL;
6980 op_getmad(o,kid,'O');
6981 op_getmad(kkid,kid,'M');
6986 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6994 Perl_ck_match(pTHX_ OP *o)
6997 if (o->op_type != OP_QR && PL_compcv) {
6998 const PADOFFSET offset = pad_findmy("$_");
6999 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7000 o->op_targ = offset;
7001 o->op_private |= OPpTARGET_MY;
7004 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7005 o->op_private |= OPpRUNTIME;
7010 Perl_ck_method(pTHX_ OP *o)
7012 OP * const kid = cUNOPo->op_first;
7013 if (kid->op_type == OP_CONST) {
7014 SV* sv = kSVOP->op_sv;
7015 const char * const method = SvPVX_const(sv);
7016 if (!(strchr(method, ':') || strchr(method, '\''))) {
7018 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7019 sv = newSVpvn_share(method, SvCUR(sv), 0);
7022 kSVOP->op_sv = NULL;
7024 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7026 op_getmad(o,cmop,'O');
7037 Perl_ck_null(pTHX_ OP *o)
7039 PERL_UNUSED_CONTEXT;
7044 Perl_ck_open(pTHX_ OP *o)
7047 HV * const table = GvHV(PL_hintgv);
7049 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7051 const I32 mode = mode_from_discipline(*svp);
7052 if (mode & O_BINARY)
7053 o->op_private |= OPpOPEN_IN_RAW;
7054 else if (mode & O_TEXT)
7055 o->op_private |= OPpOPEN_IN_CRLF;
7058 svp = hv_fetchs(table, "open_OUT", FALSE);
7060 const I32 mode = mode_from_discipline(*svp);
7061 if (mode & O_BINARY)
7062 o->op_private |= OPpOPEN_OUT_RAW;
7063 else if (mode & O_TEXT)
7064 o->op_private |= OPpOPEN_OUT_CRLF;
7067 if (o->op_type == OP_BACKTICK) {
7068 if (!(o->op_flags & OPf_KIDS)) {
7069 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7071 op_getmad(o,newop,'O');
7080 /* In case of three-arg dup open remove strictness
7081 * from the last arg if it is a bareword. */
7082 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7083 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7087 if ((last->op_type == OP_CONST) && /* The bareword. */
7088 (last->op_private & OPpCONST_BARE) &&
7089 (last->op_private & OPpCONST_STRICT) &&
7090 (oa = first->op_sibling) && /* The fh. */
7091 (oa = oa->op_sibling) && /* The mode. */
7092 (oa->op_type == OP_CONST) &&
7093 SvPOK(((SVOP*)oa)->op_sv) &&
7094 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7095 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7096 (last == oa->op_sibling)) /* The bareword. */
7097 last->op_private &= ~OPpCONST_STRICT;
7103 Perl_ck_repeat(pTHX_ OP *o)
7105 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7106 o->op_private |= OPpREPEAT_DOLIST;
7107 cBINOPo->op_first = force_list(cBINOPo->op_first);
7115 Perl_ck_require(pTHX_ OP *o)
7120 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7121 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7123 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7124 SV * const sv = kid->op_sv;
7125 U32 was_readonly = SvREADONLY(sv);
7130 sv_force_normal_flags(sv, 0);
7131 assert(!SvREADONLY(sv));
7138 for (s = SvPVX(sv); *s; s++) {
7139 if (*s == ':' && s[1] == ':') {
7140 const STRLEN len = strlen(s+2)+1;
7142 Move(s+2, s+1, len, char);
7143 SvCUR_set(sv, SvCUR(sv) - 1);
7146 sv_catpvs(sv, ".pm");
7147 SvFLAGS(sv) |= was_readonly;
7151 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7152 /* handle override, if any */
7153 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7154 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7155 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7156 gv = gvp ? *gvp : NULL;
7160 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7161 OP * const kid = cUNOPo->op_first;
7164 cUNOPo->op_first = 0;
7168 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7169 append_elem(OP_LIST, kid,
7170 scalar(newUNOP(OP_RV2CV, 0,
7173 op_getmad(o,newop,'O');
7181 Perl_ck_return(pTHX_ OP *o)
7184 if (CvLVALUE(PL_compcv)) {
7186 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7187 mod(kid, OP_LEAVESUBLV);
7193 Perl_ck_select(pTHX_ OP *o)
7197 if (o->op_flags & OPf_KIDS) {
7198 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7199 if (kid && kid->op_sibling) {
7200 o->op_type = OP_SSELECT;
7201 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7203 return fold_constants(o);
7207 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7208 if (kid && kid->op_type == OP_RV2GV)
7209 kid->op_private &= ~HINT_STRICT_REFS;
7214 Perl_ck_shift(pTHX_ OP *o)
7217 const I32 type = o->op_type;
7219 if (!(o->op_flags & OPf_KIDS)) {
7221 /* FIXME - this can be refactored to reduce code in #ifdefs */
7223 OP * const oldo = o;
7227 argop = newUNOP(OP_RV2AV, 0,
7228 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7230 o = newUNOP(type, 0, scalar(argop));
7231 op_getmad(oldo,o,'O');
7234 return newUNOP(type, 0, scalar(argop));
7237 return scalar(modkids(ck_fun(o), type));
7241 Perl_ck_sort(pTHX_ OP *o)
7246 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7247 HV * const hinthv = GvHV(PL_hintgv);
7249 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7251 const I32 sorthints = (I32)SvIV(*svp);
7252 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7253 o->op_private |= OPpSORT_QSORT;
7254 if ((sorthints & HINT_SORT_STABLE) != 0)
7255 o->op_private |= OPpSORT_STABLE;
7260 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7262 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7263 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7265 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7267 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7269 if (kid->op_type == OP_SCOPE) {
7273 else if (kid->op_type == OP_LEAVE) {
7274 if (o->op_type == OP_SORT) {
7275 op_null(kid); /* wipe out leave */
7278 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7279 if (k->op_next == kid)
7281 /* don't descend into loops */
7282 else if (k->op_type == OP_ENTERLOOP
7283 || k->op_type == OP_ENTERITER)
7285 k = cLOOPx(k)->op_lastop;
7290 kid->op_next = 0; /* just disconnect the leave */
7291 k = kLISTOP->op_first;
7296 if (o->op_type == OP_SORT) {
7297 /* provide scalar context for comparison function/block */
7303 o->op_flags |= OPf_SPECIAL;
7305 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7308 firstkid = firstkid->op_sibling;
7311 /* provide list context for arguments */
7312 if (o->op_type == OP_SORT)
7319 S_simplify_sort(pTHX_ OP *o)
7322 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7327 if (!(o->op_flags & OPf_STACKED))
7329 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7330 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7331 kid = kUNOP->op_first; /* get past null */
7332 if (kid->op_type != OP_SCOPE)
7334 kid = kLISTOP->op_last; /* get past scope */
7335 switch(kid->op_type) {
7343 k = kid; /* remember this node*/
7344 if (kBINOP->op_first->op_type != OP_RV2SV)
7346 kid = kBINOP->op_first; /* get past cmp */
7347 if (kUNOP->op_first->op_type != OP_GV)
7349 kid = kUNOP->op_first; /* get past rv2sv */
7351 if (GvSTASH(gv) != PL_curstash)
7353 gvname = GvNAME(gv);
7354 if (*gvname == 'a' && gvname[1] == '\0')
7356 else if (*gvname == 'b' && gvname[1] == '\0')
7361 kid = k; /* back to cmp */
7362 if (kBINOP->op_last->op_type != OP_RV2SV)
7364 kid = kBINOP->op_last; /* down to 2nd arg */
7365 if (kUNOP->op_first->op_type != OP_GV)
7367 kid = kUNOP->op_first; /* get past rv2sv */
7369 if (GvSTASH(gv) != PL_curstash)
7371 gvname = GvNAME(gv);
7373 ? !(*gvname == 'a' && gvname[1] == '\0')
7374 : !(*gvname == 'b' && gvname[1] == '\0'))
7376 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7378 o->op_private |= OPpSORT_DESCEND;
7379 if (k->op_type == OP_NCMP)
7380 o->op_private |= OPpSORT_NUMERIC;
7381 if (k->op_type == OP_I_NCMP)
7382 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7383 kid = cLISTOPo->op_first->op_sibling;
7384 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7386 op_getmad(kid,o,'S'); /* then delete it */
7388 op_free(kid); /* then delete it */
7393 Perl_ck_split(pTHX_ OP *o)
7398 if (o->op_flags & OPf_STACKED)
7399 return no_fh_allowed(o);
7401 kid = cLISTOPo->op_first;
7402 if (kid->op_type != OP_NULL)
7403 Perl_croak(aTHX_ "panic: ck_split");
7404 kid = kid->op_sibling;
7405 op_free(cLISTOPo->op_first);
7406 cLISTOPo->op_first = kid;
7408 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7409 cLISTOPo->op_last = kid; /* There was only one element previously */
7412 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7413 OP * const sibl = kid->op_sibling;
7414 kid->op_sibling = 0;
7415 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7416 if (cLISTOPo->op_first == cLISTOPo->op_last)
7417 cLISTOPo->op_last = kid;
7418 cLISTOPo->op_first = kid;
7419 kid->op_sibling = sibl;
7422 kid->op_type = OP_PUSHRE;
7423 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7425 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7426 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7427 "Use of /g modifier is meaningless in split");
7430 if (!kid->op_sibling)
7431 append_elem(OP_SPLIT, o, newDEFSVOP());
7433 kid = kid->op_sibling;
7436 if (!kid->op_sibling)
7437 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7438 assert(kid->op_sibling);
7440 kid = kid->op_sibling;
7443 if (kid->op_sibling)
7444 return too_many_arguments(o,OP_DESC(o));
7450 Perl_ck_join(pTHX_ OP *o)
7452 const OP * const kid = cLISTOPo->op_first->op_sibling;
7453 if (kid && kid->op_type == OP_MATCH) {
7454 if (ckWARN(WARN_SYNTAX)) {
7455 const REGEXP *re = PM_GETRE(kPMOP);
7456 const char *pmstr = re ? re->precomp : "STRING";
7457 const STRLEN len = re ? re->prelen : 6;
7458 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7459 "/%.*s/ should probably be written as \"%.*s\"",
7460 (int)len, pmstr, (int)len, pmstr);
7467 Perl_ck_subr(pTHX_ OP *o)
7470 OP *prev = ((cUNOPo->op_first->op_sibling)
7471 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7472 OP *o2 = prev->op_sibling;
7474 const char *proto = NULL;
7475 const char *proto_end = NULL;
7480 I32 contextclass = 0;
7481 const char *e = NULL;
7484 o->op_private |= OPpENTERSUB_HASTARG;
7485 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7486 if (cvop->op_type == OP_RV2CV) {
7488 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7489 op_null(cvop); /* disable rv2cv */
7490 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7491 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7492 GV *gv = cGVOPx_gv(tmpop);
7495 tmpop->op_private |= OPpEARLY_CV;
7499 namegv = CvANON(cv) ? gv : CvGV(cv);
7500 proto = SvPV((SV*)cv, len);
7501 proto_end = proto + len;
7503 if (CvASSERTION(cv)) {
7504 U32 asserthints = 0;
7505 HV *const hinthv = GvHV(PL_hintgv);
7507 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7509 asserthints = SvUV(*svp);
7511 if (asserthints & HINT_ASSERTING) {
7512 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7513 o->op_private |= OPpENTERSUB_DB;
7517 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7518 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7519 "Impossible to activate assertion call");
7526 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7527 if (o2->op_type == OP_CONST)
7528 o2->op_private &= ~OPpCONST_STRICT;
7529 else if (o2->op_type == OP_LIST) {
7530 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7531 if (sib && sib->op_type == OP_CONST)
7532 sib->op_private &= ~OPpCONST_STRICT;
7535 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7536 if (PERLDB_SUB && PL_curstash != PL_debstash)
7537 o->op_private |= OPpENTERSUB_DB;
7538 while (o2 != cvop) {
7540 if (PL_madskills && o2->op_type == OP_STUB) {
7541 o2 = o2->op_sibling;
7544 if (PL_madskills && o2->op_type == OP_NULL)
7545 o3 = ((UNOP*)o2)->op_first;
7549 if (proto >= proto_end)
7550 return too_many_arguments(o, gv_ename(namegv));
7558 /* _ must be at the end */
7559 if (proto[1] && proto[1] != ';')
7574 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7576 arg == 1 ? "block or sub {}" : "sub {}",
7577 gv_ename(namegv), o3);
7580 /* '*' allows any scalar type, including bareword */
7583 if (o3->op_type == OP_RV2GV)
7584 goto wrapref; /* autoconvert GLOB -> GLOBref */
7585 else if (o3->op_type == OP_CONST)
7586 o3->op_private &= ~OPpCONST_STRICT;
7587 else if (o3->op_type == OP_ENTERSUB) {
7588 /* accidental subroutine, revert to bareword */
7589 OP *gvop = ((UNOP*)o3)->op_first;
7590 if (gvop && gvop->op_type == OP_NULL) {
7591 gvop = ((UNOP*)gvop)->op_first;
7593 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7596 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7597 (gvop = ((UNOP*)gvop)->op_first) &&
7598 gvop->op_type == OP_GV)
7600 GV * const gv = cGVOPx_gv(gvop);
7601 OP * const sibling = o2->op_sibling;
7602 SV * const n = newSVpvs("");
7604 OP * const oldo2 = o2;
7608 gv_fullname4(n, gv, "", FALSE);
7609 o2 = newSVOP(OP_CONST, 0, n);
7610 op_getmad(oldo2,o2,'O');
7611 prev->op_sibling = o2;
7612 o2->op_sibling = sibling;
7628 if (contextclass++ == 0) {
7629 e = strchr(proto, ']');
7630 if (!e || e == proto)
7639 const char *p = proto;
7640 const char *const end = proto;
7642 while (*--p != '[');
7643 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7645 gv_ename(namegv), o3);
7650 if (o3->op_type == OP_RV2GV)
7653 bad_type(arg, "symbol", gv_ename(namegv), o3);
7656 if (o3->op_type == OP_ENTERSUB)
7659 bad_type(arg, "subroutine entry", gv_ename(namegv),
7663 if (o3->op_type == OP_RV2SV ||
7664 o3->op_type == OP_PADSV ||
7665 o3->op_type == OP_HELEM ||
7666 o3->op_type == OP_AELEM)
7669 bad_type(arg, "scalar", gv_ename(namegv), o3);
7672 if (o3->op_type == OP_RV2AV ||
7673 o3->op_type == OP_PADAV)
7676 bad_type(arg, "array", gv_ename(namegv), o3);
7679 if (o3->op_type == OP_RV2HV ||
7680 o3->op_type == OP_PADHV)
7683 bad_type(arg, "hash", gv_ename(namegv), o3);
7688 OP* const sib = kid->op_sibling;
7689 kid->op_sibling = 0;
7690 o2 = newUNOP(OP_REFGEN, 0, kid);
7691 o2->op_sibling = sib;
7692 prev->op_sibling = o2;
7694 if (contextclass && e) {
7709 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7710 gv_ename(namegv), SVfARG(cv));
7715 mod(o2, OP_ENTERSUB);
7717 o2 = o2->op_sibling;
7719 if (o2 == cvop && proto && *proto == '_') {
7720 /* generate an access to $_ */
7722 o2->op_sibling = prev->op_sibling;
7723 prev->op_sibling = o2; /* instead of cvop */
7725 if (proto && !optional && proto_end > proto &&
7726 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7727 return too_few_arguments(o, gv_ename(namegv));
7730 OP * const oldo = o;
7734 o=newSVOP(OP_CONST, 0, newSViv(0));
7735 op_getmad(oldo,o,'O');
7741 Perl_ck_svconst(pTHX_ OP *o)
7743 PERL_UNUSED_CONTEXT;
7744 SvREADONLY_on(cSVOPo->op_sv);
7749 Perl_ck_chdir(pTHX_ OP *o)
7751 if (o->op_flags & OPf_KIDS) {
7752 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7754 if (kid && kid->op_type == OP_CONST &&
7755 (kid->op_private & OPpCONST_BARE))
7757 o->op_flags |= OPf_SPECIAL;
7758 kid->op_private &= ~OPpCONST_STRICT;
7765 Perl_ck_trunc(pTHX_ OP *o)
7767 if (o->op_flags & OPf_KIDS) {
7768 SVOP *kid = (SVOP*)cUNOPo->op_first;
7770 if (kid->op_type == OP_NULL)
7771 kid = (SVOP*)kid->op_sibling;
7772 if (kid && kid->op_type == OP_CONST &&
7773 (kid->op_private & OPpCONST_BARE))
7775 o->op_flags |= OPf_SPECIAL;
7776 kid->op_private &= ~OPpCONST_STRICT;
7783 Perl_ck_unpack(pTHX_ OP *o)
7785 OP *kid = cLISTOPo->op_first;
7786 if (kid->op_sibling) {
7787 kid = kid->op_sibling;
7788 if (!kid->op_sibling)
7789 kid->op_sibling = newDEFSVOP();
7795 Perl_ck_substr(pTHX_ OP *o)
7798 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7799 OP *kid = cLISTOPo->op_first;
7801 if (kid->op_type == OP_NULL)
7802 kid = kid->op_sibling;
7804 kid->op_flags |= OPf_MOD;
7810 /* A peephole optimizer. We visit the ops in the order they're to execute.
7811 * See the comments at the top of this file for more details about when
7812 * peep() is called */
7815 Perl_peep(pTHX_ register OP *o)
7818 register OP* oldop = NULL;
7820 if (!o || o->op_opt)
7824 SAVEVPTR(PL_curcop);
7825 for (; o; o = o->op_next) {
7828 /* By default, this op has now been optimised. A couple of cases below
7829 clear this again. */
7832 switch (o->op_type) {
7836 PL_curcop = ((COP*)o); /* for warnings */
7840 if (cSVOPo->op_private & OPpCONST_STRICT)
7841 no_bareword_allowed(o);
7843 case OP_METHOD_NAMED:
7844 /* Relocate sv to the pad for thread safety.
7845 * Despite being a "constant", the SV is written to,
7846 * for reference counts, sv_upgrade() etc. */
7848 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7849 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7850 /* If op_sv is already a PADTMP then it is being used by
7851 * some pad, so make a copy. */
7852 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7853 SvREADONLY_on(PAD_SVl(ix));
7854 SvREFCNT_dec(cSVOPo->op_sv);
7856 else if (o->op_type == OP_CONST
7857 && cSVOPo->op_sv == &PL_sv_undef) {
7858 /* PL_sv_undef is hack - it's unsafe to store it in the
7859 AV that is the pad, because av_fetch treats values of
7860 PL_sv_undef as a "free" AV entry and will merrily
7861 replace them with a new SV, causing pad_alloc to think
7862 that this pad slot is free. (When, clearly, it is not)
7864 SvOK_off(PAD_SVl(ix));
7865 SvPADTMP_on(PAD_SVl(ix));
7866 SvREADONLY_on(PAD_SVl(ix));
7869 SvREFCNT_dec(PAD_SVl(ix));
7870 SvPADTMP_on(cSVOPo->op_sv);
7871 PAD_SETSV(ix, cSVOPo->op_sv);
7872 /* XXX I don't know how this isn't readonly already. */
7873 SvREADONLY_on(PAD_SVl(ix));
7875 cSVOPo->op_sv = NULL;
7882 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7883 if (o->op_next->op_private & OPpTARGET_MY) {
7884 if (o->op_flags & OPf_STACKED) /* chained concats */
7885 break; /* ignore_optimization */
7887 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7888 o->op_targ = o->op_next->op_targ;
7889 o->op_next->op_targ = 0;
7890 o->op_private |= OPpTARGET_MY;
7893 op_null(o->op_next);
7897 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7898 break; /* Scalar stub must produce undef. List stub is noop */
7902 if (o->op_targ == OP_NEXTSTATE
7903 || o->op_targ == OP_DBSTATE
7904 || o->op_targ == OP_SETSTATE)
7906 PL_curcop = ((COP*)o);
7908 /* XXX: We avoid setting op_seq here to prevent later calls
7909 to peep() from mistakenly concluding that optimisation
7910 has already occurred. This doesn't fix the real problem,
7911 though (See 20010220.007). AMS 20010719 */
7912 /* op_seq functionality is now replaced by op_opt */
7919 if (oldop && o->op_next) {
7920 oldop->op_next = o->op_next;
7928 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7929 OP* const pop = (o->op_type == OP_PADAV) ?
7930 o->op_next : o->op_next->op_next;
7932 if (pop && pop->op_type == OP_CONST &&
7933 ((PL_op = pop->op_next)) &&
7934 pop->op_next->op_type == OP_AELEM &&
7935 !(pop->op_next->op_private &
7936 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7937 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7942 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7943 no_bareword_allowed(pop);
7944 if (o->op_type == OP_GV)
7945 op_null(o->op_next);
7946 op_null(pop->op_next);
7948 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7949 o->op_next = pop->op_next->op_next;
7950 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7951 o->op_private = (U8)i;
7952 if (o->op_type == OP_GV) {
7957 o->op_flags |= OPf_SPECIAL;
7958 o->op_type = OP_AELEMFAST;
7963 if (o->op_next->op_type == OP_RV2SV) {
7964 if (!(o->op_next->op_private & OPpDEREF)) {
7965 op_null(o->op_next);
7966 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7968 o->op_next = o->op_next->op_next;
7969 o->op_type = OP_GVSV;
7970 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7973 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7974 GV * const gv = cGVOPo_gv;
7975 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7976 /* XXX could check prototype here instead of just carping */
7977 SV * const sv = sv_newmortal();
7978 gv_efullname3(sv, gv, NULL);
7979 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7980 "%"SVf"() called too early to check prototype",
7984 else if (o->op_next->op_type == OP_READLINE
7985 && o->op_next->op_next->op_type == OP_CONCAT
7986 && (o->op_next->op_next->op_flags & OPf_STACKED))
7988 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7989 o->op_type = OP_RCATLINE;
7990 o->op_flags |= OPf_STACKED;
7991 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7992 op_null(o->op_next->op_next);
7993 op_null(o->op_next);
8008 while (cLOGOP->op_other->op_type == OP_NULL)
8009 cLOGOP->op_other = cLOGOP->op_other->op_next;
8010 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8015 while (cLOOP->op_redoop->op_type == OP_NULL)
8016 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8017 peep(cLOOP->op_redoop);
8018 while (cLOOP->op_nextop->op_type == OP_NULL)
8019 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8020 peep(cLOOP->op_nextop);
8021 while (cLOOP->op_lastop->op_type == OP_NULL)
8022 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8023 peep(cLOOP->op_lastop);
8027 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8028 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8029 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8030 cPMOP->op_pmstashstartu.op_pmreplstart
8031 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8032 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8036 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8037 && ckWARN(WARN_SYNTAX))
8039 if (o->op_next->op_sibling) {
8040 const OPCODE type = o->op_next->op_sibling->op_type;
8041 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8042 const line_t oldline = CopLINE(PL_curcop);
8043 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8044 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8045 "Statement unlikely to be reached");
8046 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8047 "\t(Maybe you meant system() when you said exec()?)\n");
8048 CopLINE_set(PL_curcop, oldline);
8059 const char *key = NULL;
8062 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8065 /* Make the CONST have a shared SV */
8066 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8067 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8068 key = SvPV_const(sv, keylen);
8069 lexname = newSVpvn_share(key,
8070 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8076 if ((o->op_private & (OPpLVAL_INTRO)))
8079 rop = (UNOP*)((BINOP*)o)->op_first;
8080 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8082 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8083 if (!SvPAD_TYPED(lexname))
8085 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8086 if (!fields || !GvHV(*fields))
8088 key = SvPV_const(*svp, keylen);
8089 if (!hv_fetch(GvHV(*fields), key,
8090 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8092 Perl_croak(aTHX_ "No such class field \"%s\" "
8093 "in variable %s of type %s",
8094 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8107 SVOP *first_key_op, *key_op;
8109 if ((o->op_private & (OPpLVAL_INTRO))
8110 /* I bet there's always a pushmark... */
8111 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8112 /* hmmm, no optimization if list contains only one key. */
8114 rop = (UNOP*)((LISTOP*)o)->op_last;
8115 if (rop->op_type != OP_RV2HV)
8117 if (rop->op_first->op_type == OP_PADSV)
8118 /* @$hash{qw(keys here)} */
8119 rop = (UNOP*)rop->op_first;
8121 /* @{$hash}{qw(keys here)} */
8122 if (rop->op_first->op_type == OP_SCOPE
8123 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8125 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8131 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8132 if (!SvPAD_TYPED(lexname))
8134 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8135 if (!fields || !GvHV(*fields))
8137 /* Again guessing that the pushmark can be jumped over.... */
8138 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8139 ->op_first->op_sibling;
8140 for (key_op = first_key_op; key_op;
8141 key_op = (SVOP*)key_op->op_sibling) {
8142 if (key_op->op_type != OP_CONST)
8144 svp = cSVOPx_svp(key_op);
8145 key = SvPV_const(*svp, keylen);
8146 if (!hv_fetch(GvHV(*fields), key,
8147 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8149 Perl_croak(aTHX_ "No such class field \"%s\" "
8150 "in variable %s of type %s",
8151 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8158 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8162 /* check that RHS of sort is a single plain array */
8163 OP *oright = cUNOPo->op_first;
8164 if (!oright || oright->op_type != OP_PUSHMARK)
8167 /* reverse sort ... can be optimised. */
8168 if (!cUNOPo->op_sibling) {
8169 /* Nothing follows us on the list. */
8170 OP * const reverse = o->op_next;
8172 if (reverse->op_type == OP_REVERSE &&
8173 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8174 OP * const pushmark = cUNOPx(reverse)->op_first;
8175 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8176 && (cUNOPx(pushmark)->op_sibling == o)) {
8177 /* reverse -> pushmark -> sort */
8178 o->op_private |= OPpSORT_REVERSE;
8180 pushmark->op_next = oright->op_next;
8186 /* make @a = sort @a act in-place */
8188 oright = cUNOPx(oright)->op_sibling;
8191 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8192 oright = cUNOPx(oright)->op_sibling;
8196 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8197 || oright->op_next != o
8198 || (oright->op_private & OPpLVAL_INTRO)
8202 /* o2 follows the chain of op_nexts through the LHS of the
8203 * assign (if any) to the aassign op itself */
8205 if (!o2 || o2->op_type != OP_NULL)
8208 if (!o2 || o2->op_type != OP_PUSHMARK)
8211 if (o2 && o2->op_type == OP_GV)
8214 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8215 || (o2->op_private & OPpLVAL_INTRO)
8220 if (!o2 || o2->op_type != OP_NULL)
8223 if (!o2 || o2->op_type != OP_AASSIGN
8224 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8227 /* check that the sort is the first arg on RHS of assign */
8229 o2 = cUNOPx(o2)->op_first;
8230 if (!o2 || o2->op_type != OP_NULL)
8232 o2 = cUNOPx(o2)->op_first;
8233 if (!o2 || o2->op_type != OP_PUSHMARK)
8235 if (o2->op_sibling != o)
8238 /* check the array is the same on both sides */
8239 if (oleft->op_type == OP_RV2AV) {
8240 if (oright->op_type != OP_RV2AV
8241 || !cUNOPx(oright)->op_first
8242 || cUNOPx(oright)->op_first->op_type != OP_GV
8243 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8244 cGVOPx_gv(cUNOPx(oright)->op_first)
8248 else if (oright->op_type != OP_PADAV
8249 || oright->op_targ != oleft->op_targ
8253 /* transfer MODishness etc from LHS arg to RHS arg */
8254 oright->op_flags = oleft->op_flags;
8255 o->op_private |= OPpSORT_INPLACE;
8257 /* excise push->gv->rv2av->null->aassign */
8258 o2 = o->op_next->op_next;
8259 op_null(o2); /* PUSHMARK */
8261 if (o2->op_type == OP_GV) {
8262 op_null(o2); /* GV */
8265 op_null(o2); /* RV2AV or PADAV */
8266 o2 = o2->op_next->op_next;
8267 op_null(o2); /* AASSIGN */
8269 o->op_next = o2->op_next;
8275 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8277 LISTOP *enter, *exlist;
8279 enter = (LISTOP *) o->op_next;
8282 if (enter->op_type == OP_NULL) {
8283 enter = (LISTOP *) enter->op_next;
8287 /* for $a (...) will have OP_GV then OP_RV2GV here.
8288 for (...) just has an OP_GV. */
8289 if (enter->op_type == OP_GV) {
8290 gvop = (OP *) enter;
8291 enter = (LISTOP *) enter->op_next;
8294 if (enter->op_type == OP_RV2GV) {
8295 enter = (LISTOP *) enter->op_next;
8301 if (enter->op_type != OP_ENTERITER)
8304 iter = enter->op_next;
8305 if (!iter || iter->op_type != OP_ITER)
8308 expushmark = enter->op_first;
8309 if (!expushmark || expushmark->op_type != OP_NULL
8310 || expushmark->op_targ != OP_PUSHMARK)
8313 exlist = (LISTOP *) expushmark->op_sibling;
8314 if (!exlist || exlist->op_type != OP_NULL
8315 || exlist->op_targ != OP_LIST)
8318 if (exlist->op_last != o) {
8319 /* Mmm. Was expecting to point back to this op. */
8322 theirmark = exlist->op_first;
8323 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8326 if (theirmark->op_sibling != o) {
8327 /* There's something between the mark and the reverse, eg
8328 for (1, reverse (...))
8333 ourmark = ((LISTOP *)o)->op_first;
8334 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8337 ourlast = ((LISTOP *)o)->op_last;
8338 if (!ourlast || ourlast->op_next != o)
8341 rv2av = ourmark->op_sibling;
8342 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8343 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8344 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8345 /* We're just reversing a single array. */
8346 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8347 enter->op_flags |= OPf_STACKED;
8350 /* We don't have control over who points to theirmark, so sacrifice
8352 theirmark->op_next = ourmark->op_next;
8353 theirmark->op_flags = ourmark->op_flags;
8354 ourlast->op_next = gvop ? gvop : (OP *) enter;
8357 enter->op_private |= OPpITER_REVERSED;
8358 iter->op_private |= OPpITER_REVERSED;
8365 UNOP *refgen, *rv2cv;
8368 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8371 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8374 rv2gv = ((BINOP *)o)->op_last;
8375 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8378 refgen = (UNOP *)((BINOP *)o)->op_first;
8380 if (!refgen || refgen->op_type != OP_REFGEN)
8383 exlist = (LISTOP *)refgen->op_first;
8384 if (!exlist || exlist->op_type != OP_NULL
8385 || exlist->op_targ != OP_LIST)
8388 if (exlist->op_first->op_type != OP_PUSHMARK)
8391 rv2cv = (UNOP*)exlist->op_last;
8393 if (rv2cv->op_type != OP_RV2CV)
8396 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8397 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8398 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8400 o->op_private |= OPpASSIGN_CV_TO_GV;
8401 rv2gv->op_private |= OPpDONT_INIT_GV;
8402 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8410 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8411 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8421 Perl_custom_op_name(pTHX_ const OP* o)
8424 const IV index = PTR2IV(o->op_ppaddr);
8428 if (!PL_custom_op_names) /* This probably shouldn't happen */
8429 return (char *)PL_op_name[OP_CUSTOM];
8431 keysv = sv_2mortal(newSViv(index));
8433 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8435 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8437 return SvPV_nolen(HeVAL(he));
8441 Perl_custom_op_desc(pTHX_ const OP* o)
8444 const IV index = PTR2IV(o->op_ppaddr);
8448 if (!PL_custom_op_descs)
8449 return (char *)PL_op_desc[OP_CUSTOM];
8451 keysv = sv_2mortal(newSViv(index));
8453 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8455 return (char *)PL_op_desc[OP_CUSTOM];
8457 return SvPV_nolen(HeVAL(he));
8462 /* Efficient sub that returns a constant scalar value. */
8464 const_sv_xsub(pTHX_ CV* cv)
8471 Perl_croak(aTHX_ "usage: %s::%s()",
8472 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8476 ST(0) = (SV*)XSANY.any_ptr;
8482 * c-indentation-style: bsd
8484 * indent-tabs-mode: t
8487 * ex: set ts=8 sts=4 sw=4 noet: