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:
1660 S_is_handle_constructor(const OP *o, I32 numargs)
1662 switch (o->op_type) {
1670 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1683 Perl_refkids(pTHX_ OP *o, I32 type)
1685 if (o && o->op_flags & OPf_KIDS) {
1687 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1694 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1699 if (!o || PL_error_count)
1702 switch (o->op_type) {
1704 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1705 !(o->op_flags & OPf_STACKED)) {
1706 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1707 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1708 assert(cUNOPo->op_first->op_type == OP_NULL);
1709 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1710 o->op_flags |= OPf_SPECIAL;
1711 o->op_private &= ~1;
1716 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1717 doref(kid, type, set_op_ref);
1720 if (type == OP_DEFINED)
1721 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1722 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1725 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1726 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1727 : type == OP_RV2HV ? OPpDEREF_HV
1729 o->op_flags |= OPf_MOD;
1736 o->op_flags |= OPf_REF;
1739 if (type == OP_DEFINED)
1740 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1741 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1747 o->op_flags |= OPf_REF;
1752 if (!(o->op_flags & OPf_KIDS))
1754 doref(cBINOPo->op_first, type, set_op_ref);
1758 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1759 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1760 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1761 : type == OP_RV2HV ? OPpDEREF_HV
1763 o->op_flags |= OPf_MOD;
1773 if (!(o->op_flags & OPf_KIDS))
1775 doref(cLISTOPo->op_last, type, set_op_ref);
1785 S_dup_attrlist(pTHX_ OP *o)
1790 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1791 * where the first kid is OP_PUSHMARK and the remaining ones
1792 * are OP_CONST. We need to push the OP_CONST values.
1794 if (o->op_type == OP_CONST)
1795 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1797 else if (o->op_type == OP_NULL)
1801 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1803 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1804 if (o->op_type == OP_CONST)
1805 rop = append_elem(OP_LIST, rop,
1806 newSVOP(OP_CONST, o->op_flags,
1807 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1814 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1819 /* fake up C<use attributes $pkg,$rv,@attrs> */
1820 ENTER; /* need to protect against side-effects of 'use' */
1822 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1824 #define ATTRSMODULE "attributes"
1825 #define ATTRSMODULE_PM "attributes.pm"
1828 /* Don't force the C<use> if we don't need it. */
1829 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1830 if (svp && *svp != &PL_sv_undef)
1831 NOOP; /* already in %INC */
1833 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1834 newSVpvs(ATTRSMODULE), NULL);
1837 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1838 newSVpvs(ATTRSMODULE),
1840 prepend_elem(OP_LIST,
1841 newSVOP(OP_CONST, 0, stashsv),
1842 prepend_elem(OP_LIST,
1843 newSVOP(OP_CONST, 0,
1845 dup_attrlist(attrs))));
1851 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1854 OP *pack, *imop, *arg;
1860 assert(target->op_type == OP_PADSV ||
1861 target->op_type == OP_PADHV ||
1862 target->op_type == OP_PADAV);
1864 /* Ensure that attributes.pm is loaded. */
1865 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1867 /* Need package name for method call. */
1868 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1870 /* Build up the real arg-list. */
1871 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1873 arg = newOP(OP_PADSV, 0);
1874 arg->op_targ = target->op_targ;
1875 arg = prepend_elem(OP_LIST,
1876 newSVOP(OP_CONST, 0, stashsv),
1877 prepend_elem(OP_LIST,
1878 newUNOP(OP_REFGEN, 0,
1879 mod(arg, OP_REFGEN)),
1880 dup_attrlist(attrs)));
1882 /* Fake up a method call to import */
1883 meth = newSVpvs_share("import");
1884 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1885 append_elem(OP_LIST,
1886 prepend_elem(OP_LIST, pack, list(arg)),
1887 newSVOP(OP_METHOD_NAMED, 0, meth)));
1888 imop->op_private |= OPpENTERSUB_NOMOD;
1890 /* Combine the ops. */
1891 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1895 =notfor apidoc apply_attrs_string
1897 Attempts to apply a list of attributes specified by the C<attrstr> and
1898 C<len> arguments to the subroutine identified by the C<cv> argument which
1899 is expected to be associated with the package identified by the C<stashpv>
1900 argument (see L<attributes>). It gets this wrong, though, in that it
1901 does not correctly identify the boundaries of the individual attribute
1902 specifications within C<attrstr>. This is not really intended for the
1903 public API, but has to be listed here for systems such as AIX which
1904 need an explicit export list for symbols. (It's called from XS code
1905 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1906 to respect attribute syntax properly would be welcome.
1912 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1913 const char *attrstr, STRLEN len)
1918 len = strlen(attrstr);
1922 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1924 const char * const sstr = attrstr;
1925 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1926 attrs = append_elem(OP_LIST, attrs,
1927 newSVOP(OP_CONST, 0,
1928 newSVpvn(sstr, attrstr-sstr)));
1932 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1933 newSVpvs(ATTRSMODULE),
1934 NULL, prepend_elem(OP_LIST,
1935 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1936 prepend_elem(OP_LIST,
1937 newSVOP(OP_CONST, 0,
1943 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1948 if (!o || PL_error_count)
1952 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1953 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1957 if (type == OP_LIST) {
1959 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1960 my_kid(kid, attrs, imopsp);
1961 } else if (type == OP_UNDEF
1967 } else if (type == OP_RV2SV || /* "our" declaration */
1969 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1970 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1971 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1973 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1975 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1977 PL_in_my_stash = NULL;
1978 apply_attrs(GvSTASH(gv),
1979 (type == OP_RV2SV ? GvSV(gv) :
1980 type == OP_RV2AV ? (SV*)GvAV(gv) :
1981 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1984 o->op_private |= OPpOUR_INTRO;
1987 else if (type != OP_PADSV &&
1990 type != OP_PUSHMARK)
1992 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1994 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1997 else if (attrs && type != OP_PUSHMARK) {
2001 PL_in_my_stash = NULL;
2003 /* check for C<my Dog $spot> when deciding package */
2004 stash = PAD_COMPNAME_TYPE(o->op_targ);
2006 stash = PL_curstash;
2007 apply_attrs_my(stash, o, attrs, imopsp);
2009 o->op_flags |= OPf_MOD;
2010 o->op_private |= OPpLVAL_INTRO;
2011 if (PL_in_my == KEY_state)
2012 o->op_private |= OPpPAD_STATE;
2017 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2021 int maybe_scalar = 0;
2023 /* [perl #17376]: this appears to be premature, and results in code such as
2024 C< our(%x); > executing in list mode rather than void mode */
2026 if (o->op_flags & OPf_PARENS)
2036 o = my_kid(o, attrs, &rops);
2038 if (maybe_scalar && o->op_type == OP_PADSV) {
2039 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2040 o->op_private |= OPpLVAL_INTRO;
2043 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2046 PL_in_my_stash = NULL;
2051 Perl_my(pTHX_ OP *o)
2053 return my_attrs(o, NULL);
2057 Perl_sawparens(pTHX_ OP *o)
2059 PERL_UNUSED_CONTEXT;
2061 o->op_flags |= OPf_PARENS;
2066 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2070 const OPCODE ltype = left->op_type;
2071 const OPCODE rtype = right->op_type;
2073 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2074 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2076 const char * const desc
2077 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2078 ? (int)rtype : OP_MATCH];
2079 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2080 ? "@array" : "%hash");
2081 Perl_warner(aTHX_ packWARN(WARN_MISC),
2082 "Applying %s to %s will act on scalar(%s)",
2083 desc, sample, sample);
2086 if (rtype == OP_CONST &&
2087 cSVOPx(right)->op_private & OPpCONST_BARE &&
2088 cSVOPx(right)->op_private & OPpCONST_STRICT)
2090 no_bareword_allowed(right);
2093 ismatchop = rtype == OP_MATCH ||
2094 rtype == OP_SUBST ||
2096 if (ismatchop && right->op_private & OPpTARGET_MY) {
2098 right->op_private &= ~OPpTARGET_MY;
2100 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2103 right->op_flags |= OPf_STACKED;
2104 if (rtype != OP_MATCH &&
2105 ! (rtype == OP_TRANS &&
2106 right->op_private & OPpTRANS_IDENTICAL))
2107 newleft = mod(left, rtype);
2110 if (right->op_type == OP_TRANS)
2111 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2113 o = prepend_elem(rtype, scalar(newleft), right);
2115 return newUNOP(OP_NOT, 0, scalar(o));
2119 return bind_match(type, left,
2120 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2124 Perl_invert(pTHX_ OP *o)
2128 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2132 Perl_scope(pTHX_ OP *o)
2136 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2137 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2138 o->op_type = OP_LEAVE;
2139 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2141 else if (o->op_type == OP_LINESEQ) {
2143 o->op_type = OP_SCOPE;
2144 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2145 kid = ((LISTOP*)o)->op_first;
2146 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2149 /* The following deals with things like 'do {1 for 1}' */
2150 kid = kid->op_sibling;
2152 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2157 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2163 Perl_block_start(pTHX_ int full)
2166 const int retval = PL_savestack_ix;
2167 pad_block_start(full);
2169 PL_hints &= ~HINT_BLOCK_SCOPE;
2170 SAVECOMPILEWARNINGS();
2171 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2176 Perl_block_end(pTHX_ I32 floor, OP *seq)
2179 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2180 OP* const retval = scalarseq(seq);
2182 CopHINTS_set(&PL_compiling, PL_hints);
2184 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2193 const PADOFFSET offset = pad_findmy("$_");
2194 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2195 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2198 OP * const o = newOP(OP_PADSV, 0);
2199 o->op_targ = offset;
2205 Perl_newPROG(pTHX_ OP *o)
2211 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2212 ((PL_in_eval & EVAL_KEEPERR)
2213 ? OPf_SPECIAL : 0), o);
2214 PL_eval_start = linklist(PL_eval_root);
2215 PL_eval_root->op_private |= OPpREFCOUNTED;
2216 OpREFCNT_set(PL_eval_root, 1);
2217 PL_eval_root->op_next = 0;
2218 CALL_PEEP(PL_eval_start);
2221 if (o->op_type == OP_STUB) {
2222 PL_comppad_name = 0;
2224 S_op_destroy(aTHX_ o);
2227 PL_main_root = scope(sawparens(scalarvoid(o)));
2228 PL_curcop = &PL_compiling;
2229 PL_main_start = LINKLIST(PL_main_root);
2230 PL_main_root->op_private |= OPpREFCOUNTED;
2231 OpREFCNT_set(PL_main_root, 1);
2232 PL_main_root->op_next = 0;
2233 CALL_PEEP(PL_main_start);
2236 /* Register with debugger */
2239 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2243 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2245 call_sv((SV*)cv, G_DISCARD);
2252 Perl_localize(pTHX_ OP *o, I32 lex)
2255 if (o->op_flags & OPf_PARENS)
2256 /* [perl #17376]: this appears to be premature, and results in code such as
2257 C< our(%x); > executing in list mode rather than void mode */
2264 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2265 && ckWARN(WARN_PARENTHESIS))
2267 char *s = PL_bufptr;
2270 /* some heuristics to detect a potential error */
2271 while (*s && (strchr(", \t\n", *s)))
2275 if (*s && strchr("@$%*", *s) && *++s
2276 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2279 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2281 while (*s && (strchr(", \t\n", *s)))
2287 if (sigil && (*s == ';' || *s == '=')) {
2288 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2289 "Parentheses missing around \"%s\" list",
2290 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2298 o = mod(o, OP_NULL); /* a bit kludgey */
2300 PL_in_my_stash = NULL;
2305 Perl_jmaybe(pTHX_ OP *o)
2307 if (o->op_type == OP_LIST) {
2309 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2310 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2316 Perl_fold_constants(pTHX_ register OP *o)
2321 VOL I32 type = o->op_type;
2326 SV * const oldwarnhook = PL_warnhook;
2327 SV * const olddiehook = PL_diehook;
2330 if (PL_opargs[type] & OA_RETSCALAR)
2332 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2333 o->op_targ = pad_alloc(type, SVs_PADTMP);
2335 /* integerize op, unless it happens to be C<-foo>.
2336 * XXX should pp_i_negate() do magic string negation instead? */
2337 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2338 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2339 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2341 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2344 if (!(PL_opargs[type] & OA_FOLDCONST))
2349 /* XXX might want a ck_negate() for this */
2350 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2361 /* XXX what about the numeric ops? */
2362 if (PL_hints & HINT_LOCALE)
2367 goto nope; /* Don't try to run w/ errors */
2369 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2370 const OPCODE type = curop->op_type;
2371 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2373 type != OP_SCALAR &&
2375 type != OP_PUSHMARK)
2381 curop = LINKLIST(o);
2382 old_next = o->op_next;
2386 oldscope = PL_scopestack_ix;
2387 create_eval_scope(G_FAKINGEVAL);
2389 PL_warnhook = PERL_WARNHOOK_FATAL;
2396 sv = *(PL_stack_sp--);
2397 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2398 pad_swipe(o->op_targ, FALSE);
2399 else if (SvTEMP(sv)) { /* grab mortal temp? */
2400 SvREFCNT_inc_simple_void(sv);
2405 /* Something tried to die. Abandon constant folding. */
2406 /* Pretend the error never happened. */
2407 sv_setpvn(ERRSV,"",0);
2408 o->op_next = old_next;
2412 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2413 PL_warnhook = oldwarnhook;
2414 PL_diehook = olddiehook;
2415 /* XXX note that this croak may fail as we've already blown away
2416 * the stack - eg any nested evals */
2417 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2420 PL_warnhook = oldwarnhook;
2421 PL_diehook = olddiehook;
2423 if (PL_scopestack_ix > oldscope)
2424 delete_eval_scope();
2433 if (type == OP_RV2GV)
2434 newop = newGVOP(OP_GV, 0, (GV*)sv);
2436 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2437 op_getmad(o,newop,'f');
2445 Perl_gen_constant_list(pTHX_ register OP *o)
2449 const I32 oldtmps_floor = PL_tmps_floor;
2453 return o; /* Don't attempt to run with errors */
2455 PL_op = curop = LINKLIST(o);
2461 assert (!(curop->op_flags & OPf_SPECIAL));
2462 assert(curop->op_type == OP_RANGE);
2464 PL_tmps_floor = oldtmps_floor;
2466 o->op_type = OP_RV2AV;
2467 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2468 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2469 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2470 o->op_opt = 0; /* needs to be revisited in peep() */
2471 curop = ((UNOP*)o)->op_first;
2472 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2474 op_getmad(curop,o,'O');
2483 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2486 if (!o || o->op_type != OP_LIST)
2487 o = newLISTOP(OP_LIST, 0, o, NULL);
2489 o->op_flags &= ~OPf_WANT;
2491 if (!(PL_opargs[type] & OA_MARK))
2492 op_null(cLISTOPo->op_first);
2494 o->op_type = (OPCODE)type;
2495 o->op_ppaddr = PL_ppaddr[type];
2496 o->op_flags |= flags;
2498 o = CHECKOP(type, o);
2499 if (o->op_type != (unsigned)type)
2502 return fold_constants(o);
2505 /* List constructors */
2508 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2516 if (first->op_type != (unsigned)type
2517 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2519 return newLISTOP(type, 0, first, last);
2522 if (first->op_flags & OPf_KIDS)
2523 ((LISTOP*)first)->op_last->op_sibling = last;
2525 first->op_flags |= OPf_KIDS;
2526 ((LISTOP*)first)->op_first = last;
2528 ((LISTOP*)first)->op_last = last;
2533 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2541 if (first->op_type != (unsigned)type)
2542 return prepend_elem(type, (OP*)first, (OP*)last);
2544 if (last->op_type != (unsigned)type)
2545 return append_elem(type, (OP*)first, (OP*)last);
2547 first->op_last->op_sibling = last->op_first;
2548 first->op_last = last->op_last;
2549 first->op_flags |= (last->op_flags & OPf_KIDS);
2552 if (last->op_first && first->op_madprop) {
2553 MADPROP *mp = last->op_first->op_madprop;
2555 while (mp->mad_next)
2557 mp->mad_next = first->op_madprop;
2560 last->op_first->op_madprop = first->op_madprop;
2563 first->op_madprop = last->op_madprop;
2564 last->op_madprop = 0;
2567 S_op_destroy(aTHX_ (OP*)last);
2573 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2581 if (last->op_type == (unsigned)type) {
2582 if (type == OP_LIST) { /* already a PUSHMARK there */
2583 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2584 ((LISTOP*)last)->op_first->op_sibling = first;
2585 if (!(first->op_flags & OPf_PARENS))
2586 last->op_flags &= ~OPf_PARENS;
2589 if (!(last->op_flags & OPf_KIDS)) {
2590 ((LISTOP*)last)->op_last = first;
2591 last->op_flags |= OPf_KIDS;
2593 first->op_sibling = ((LISTOP*)last)->op_first;
2594 ((LISTOP*)last)->op_first = first;
2596 last->op_flags |= OPf_KIDS;
2600 return newLISTOP(type, 0, first, last);
2608 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2611 Newxz(tk, 1, TOKEN);
2612 tk->tk_type = (OPCODE)optype;
2613 tk->tk_type = 12345;
2615 tk->tk_mad = madprop;
2620 Perl_token_free(pTHX_ TOKEN* tk)
2622 if (tk->tk_type != 12345)
2624 mad_free(tk->tk_mad);
2629 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2633 if (tk->tk_type != 12345) {
2634 Perl_warner(aTHX_ packWARN(WARN_MISC),
2635 "Invalid TOKEN object ignored");
2642 /* faked up qw list? */
2644 tm->mad_type == MAD_SV &&
2645 SvPVX((SV*)tm->mad_val)[0] == 'q')
2652 /* pretend constant fold didn't happen? */
2653 if (mp->mad_key == 'f' &&
2654 (o->op_type == OP_CONST ||
2655 o->op_type == OP_GV) )
2657 token_getmad(tk,(OP*)mp->mad_val,slot);
2671 if (mp->mad_key == 'X')
2672 mp->mad_key = slot; /* just change the first one */
2682 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2691 /* pretend constant fold didn't happen? */
2692 if (mp->mad_key == 'f' &&
2693 (o->op_type == OP_CONST ||
2694 o->op_type == OP_GV) )
2696 op_getmad(from,(OP*)mp->mad_val,slot);
2703 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2706 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2712 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2721 /* pretend constant fold didn't happen? */
2722 if (mp->mad_key == 'f' &&
2723 (o->op_type == OP_CONST ||
2724 o->op_type == OP_GV) )
2726 op_getmad(from,(OP*)mp->mad_val,slot);
2733 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2736 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2740 PerlIO_printf(PerlIO_stderr(),
2741 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2747 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2765 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2769 addmad(tm, &(o->op_madprop), slot);
2773 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2794 Perl_newMADsv(pTHX_ char key, SV* sv)
2796 return newMADPROP(key, MAD_SV, sv, 0);
2800 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2803 Newxz(mp, 1, MADPROP);
2806 mp->mad_vlen = vlen;
2807 mp->mad_type = type;
2809 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2814 Perl_mad_free(pTHX_ MADPROP* mp)
2816 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2820 mad_free(mp->mad_next);
2821 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2822 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2823 switch (mp->mad_type) {
2827 Safefree((char*)mp->mad_val);
2830 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2831 op_free((OP*)mp->mad_val);
2834 sv_free((SV*)mp->mad_val);
2837 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2846 Perl_newNULLLIST(pTHX)
2848 return newOP(OP_STUB, 0);
2852 Perl_force_list(pTHX_ OP *o)
2854 if (!o || o->op_type != OP_LIST)
2855 o = newLISTOP(OP_LIST, 0, o, NULL);
2861 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2866 NewOp(1101, listop, 1, LISTOP);
2868 listop->op_type = (OPCODE)type;
2869 listop->op_ppaddr = PL_ppaddr[type];
2872 listop->op_flags = (U8)flags;
2876 else if (!first && last)
2879 first->op_sibling = last;
2880 listop->op_first = first;
2881 listop->op_last = last;
2882 if (type == OP_LIST) {
2883 OP* const pushop = newOP(OP_PUSHMARK, 0);
2884 pushop->op_sibling = first;
2885 listop->op_first = pushop;
2886 listop->op_flags |= OPf_KIDS;
2888 listop->op_last = pushop;
2891 return CHECKOP(type, listop);
2895 Perl_newOP(pTHX_ I32 type, I32 flags)
2899 NewOp(1101, o, 1, OP);
2900 o->op_type = (OPCODE)type;
2901 o->op_ppaddr = PL_ppaddr[type];
2902 o->op_flags = (U8)flags;
2904 o->op_latefreed = 0;
2908 o->op_private = (U8)(0 | (flags >> 8));
2909 if (PL_opargs[type] & OA_RETSCALAR)
2911 if (PL_opargs[type] & OA_TARGET)
2912 o->op_targ = pad_alloc(type, SVs_PADTMP);
2913 return CHECKOP(type, o);
2917 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2923 first = newOP(OP_STUB, 0);
2924 if (PL_opargs[type] & OA_MARK)
2925 first = force_list(first);
2927 NewOp(1101, unop, 1, UNOP);
2928 unop->op_type = (OPCODE)type;
2929 unop->op_ppaddr = PL_ppaddr[type];
2930 unop->op_first = first;
2931 unop->op_flags = (U8)(flags | OPf_KIDS);
2932 unop->op_private = (U8)(1 | (flags >> 8));
2933 unop = (UNOP*) CHECKOP(type, unop);
2937 return fold_constants((OP *) unop);
2941 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2945 NewOp(1101, binop, 1, BINOP);
2948 first = newOP(OP_NULL, 0);
2950 binop->op_type = (OPCODE)type;
2951 binop->op_ppaddr = PL_ppaddr[type];
2952 binop->op_first = first;
2953 binop->op_flags = (U8)(flags | OPf_KIDS);
2956 binop->op_private = (U8)(1 | (flags >> 8));
2959 binop->op_private = (U8)(2 | (flags >> 8));
2960 first->op_sibling = last;
2963 binop = (BINOP*)CHECKOP(type, binop);
2964 if (binop->op_next || binop->op_type != (OPCODE)type)
2967 binop->op_last = binop->op_first->op_sibling;
2969 return fold_constants((OP *)binop);
2972 static int uvcompare(const void *a, const void *b)
2973 __attribute__nonnull__(1)
2974 __attribute__nonnull__(2)
2975 __attribute__pure__;
2976 static int uvcompare(const void *a, const void *b)
2978 if (*((const UV *)a) < (*(const UV *)b))
2980 if (*((const UV *)a) > (*(const UV *)b))
2982 if (*((const UV *)a+1) < (*(const UV *)b+1))
2984 if (*((const UV *)a+1) > (*(const UV *)b+1))
2990 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2993 SV * const tstr = ((SVOP*)expr)->op_sv;
2996 (repl->op_type == OP_NULL)
2997 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2999 ((SVOP*)repl)->op_sv;
3002 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3003 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3007 register short *tbl;
3009 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3010 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3011 I32 del = o->op_private & OPpTRANS_DELETE;
3013 PL_hints |= HINT_BLOCK_SCOPE;
3016 o->op_private |= OPpTRANS_FROM_UTF;
3019 o->op_private |= OPpTRANS_TO_UTF;
3021 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3022 SV* const listsv = newSVpvs("# comment\n");
3024 const U8* tend = t + tlen;
3025 const U8* rend = r + rlen;
3039 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3040 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3043 const U32 flags = UTF8_ALLOW_DEFAULT;
3047 t = tsave = bytes_to_utf8(t, &len);
3050 if (!to_utf && rlen) {
3052 r = rsave = bytes_to_utf8(r, &len);
3056 /* There are several snags with this code on EBCDIC:
3057 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3058 2. scan_const() in toke.c has encoded chars in native encoding which makes
3059 ranges at least in EBCDIC 0..255 range the bottom odd.
3063 U8 tmpbuf[UTF8_MAXBYTES+1];
3066 Newx(cp, 2*tlen, UV);
3068 transv = newSVpvs("");
3070 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3072 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3074 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3078 cp[2*i+1] = cp[2*i];
3082 qsort(cp, i, 2*sizeof(UV), uvcompare);
3083 for (j = 0; j < i; j++) {
3085 diff = val - nextmin;
3087 t = uvuni_to_utf8(tmpbuf,nextmin);
3088 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3090 U8 range_mark = UTF_TO_NATIVE(0xff);
3091 t = uvuni_to_utf8(tmpbuf, val - 1);
3092 sv_catpvn(transv, (char *)&range_mark, 1);
3093 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3100 t = uvuni_to_utf8(tmpbuf,nextmin);
3101 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3103 U8 range_mark = UTF_TO_NATIVE(0xff);
3104 sv_catpvn(transv, (char *)&range_mark, 1);
3106 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3107 UNICODE_ALLOW_SUPER);
3108 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3109 t = (const U8*)SvPVX_const(transv);
3110 tlen = SvCUR(transv);
3114 else if (!rlen && !del) {
3115 r = t; rlen = tlen; rend = tend;
3118 if ((!rlen && !del) || t == r ||
3119 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3121 o->op_private |= OPpTRANS_IDENTICAL;
3125 while (t < tend || tfirst <= tlast) {
3126 /* see if we need more "t" chars */
3127 if (tfirst > tlast) {
3128 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3130 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3132 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3139 /* now see if we need more "r" chars */
3140 if (rfirst > rlast) {
3142 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3144 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3146 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3155 rfirst = rlast = 0xffffffff;
3159 /* now see which range will peter our first, if either. */
3160 tdiff = tlast - tfirst;
3161 rdiff = rlast - rfirst;
3168 if (rfirst == 0xffffffff) {
3169 diff = tdiff; /* oops, pretend rdiff is infinite */
3171 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3172 (long)tfirst, (long)tlast);
3174 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3178 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3179 (long)tfirst, (long)(tfirst + diff),
3182 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3183 (long)tfirst, (long)rfirst);
3185 if (rfirst + diff > max)
3186 max = rfirst + diff;
3188 grows = (tfirst < rfirst &&
3189 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3201 else if (max > 0xff)
3206 PerlMemShared_free(cPVOPo->op_pv);
3207 cPVOPo->op_pv = NULL;
3209 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3211 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3212 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3213 PAD_SETSV(cPADOPo->op_padix, swash);
3216 cSVOPo->op_sv = swash;
3218 SvREFCNT_dec(listsv);
3219 SvREFCNT_dec(transv);
3221 if (!del && havefinal && rlen)
3222 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3223 newSVuv((UV)final), 0);
3226 o->op_private |= OPpTRANS_GROWS;
3232 op_getmad(expr,o,'e');
3233 op_getmad(repl,o,'r');
3241 tbl = (short*)cPVOPo->op_pv;
3243 Zero(tbl, 256, short);
3244 for (i = 0; i < (I32)tlen; i++)
3246 for (i = 0, j = 0; i < 256; i++) {
3248 if (j >= (I32)rlen) {
3257 if (i < 128 && r[j] >= 128)
3267 o->op_private |= OPpTRANS_IDENTICAL;
3269 else if (j >= (I32)rlen)
3274 PerlMemShared_realloc(tbl,
3275 (0x101+rlen-j) * sizeof(short));
3276 cPVOPo->op_pv = (char*)tbl;
3278 tbl[0x100] = (short)(rlen - j);
3279 for (i=0; i < (I32)rlen - j; i++)
3280 tbl[0x101+i] = r[j+i];
3284 if (!rlen && !del) {
3287 o->op_private |= OPpTRANS_IDENTICAL;
3289 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3290 o->op_private |= OPpTRANS_IDENTICAL;
3292 for (i = 0; i < 256; i++)
3294 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3295 if (j >= (I32)rlen) {
3297 if (tbl[t[i]] == -1)
3303 if (tbl[t[i]] == -1) {
3304 if (t[i] < 128 && r[j] >= 128)
3311 o->op_private |= OPpTRANS_GROWS;
3313 op_getmad(expr,o,'e');
3314 op_getmad(repl,o,'r');
3324 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3329 NewOp(1101, pmop, 1, PMOP);
3330 pmop->op_type = (OPCODE)type;
3331 pmop->op_ppaddr = PL_ppaddr[type];
3332 pmop->op_flags = (U8)flags;
3333 pmop->op_private = (U8)(0 | (flags >> 8));
3335 if (PL_hints & HINT_RE_TAINT)
3336 pmop->op_pmflags |= PMf_RETAINT;
3337 if (PL_hints & HINT_LOCALE)
3338 pmop->op_pmflags |= PMf_LOCALE;
3342 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3343 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3344 pmop->op_pmoffset = SvIV(repointer);
3345 SvREPADTMP_off(repointer);
3346 sv_setiv(repointer,0);
3348 SV * const repointer = newSViv(0);
3349 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3350 pmop->op_pmoffset = av_len(PL_regex_padav);
3351 PL_regex_pad = AvARRAY(PL_regex_padav);
3355 return CHECKOP(type, pmop);
3358 /* Given some sort of match op o, and an expression expr containing a
3359 * pattern, either compile expr into a regex and attach it to o (if it's
3360 * constant), or convert expr into a runtime regcomp op sequence (if it's
3363 * isreg indicates that the pattern is part of a regex construct, eg
3364 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3365 * split "pattern", which aren't. In the former case, expr will be a list
3366 * if the pattern contains more than one term (eg /a$b/) or if it contains
3367 * a replacement, ie s/// or tr///.
3371 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3376 I32 repl_has_vars = 0;
3380 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3381 /* last element in list is the replacement; pop it */
3383 repl = cLISTOPx(expr)->op_last;
3384 kid = cLISTOPx(expr)->op_first;
3385 while (kid->op_sibling != repl)
3386 kid = kid->op_sibling;
3387 kid->op_sibling = NULL;
3388 cLISTOPx(expr)->op_last = kid;
3391 if (isreg && expr->op_type == OP_LIST &&
3392 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3394 /* convert single element list to element */
3395 OP* const oe = expr;
3396 expr = cLISTOPx(oe)->op_first->op_sibling;
3397 cLISTOPx(oe)->op_first->op_sibling = NULL;
3398 cLISTOPx(oe)->op_last = NULL;
3402 if (o->op_type == OP_TRANS) {
3403 return pmtrans(o, expr, repl);
3406 reglist = isreg && expr->op_type == OP_LIST;
3410 PL_hints |= HINT_BLOCK_SCOPE;
3413 if (expr->op_type == OP_CONST) {
3415 SV * const pat = ((SVOP*)expr)->op_sv;
3416 const char *p = SvPV_const(pat, plen);
3417 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3418 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
3419 U32 was_readonly = SvREADONLY(pat);
3423 sv_force_normal_flags(pat, 0);
3424 assert(!SvREADONLY(pat));
3427 SvREADONLY_off(pat);
3431 sv_setpvn(pat, "\\s+", 3);
3433 SvFLAGS(pat) |= was_readonly;
3435 p = SvPV_const(pat, plen);
3436 pm_flags |= RXf_SKIPWHITE;
3439 pm_flags |= RXf_UTF8;
3440 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3443 op_getmad(expr,(OP*)pm,'e');
3449 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3450 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3452 : OP_REGCMAYBE),0,expr);
3454 NewOp(1101, rcop, 1, LOGOP);
3455 rcop->op_type = OP_REGCOMP;
3456 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3457 rcop->op_first = scalar(expr);
3458 rcop->op_flags |= OPf_KIDS
3459 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3460 | (reglist ? OPf_STACKED : 0);
3461 rcop->op_private = 1;
3464 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3466 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3469 /* establish postfix order */
3470 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3472 rcop->op_next = expr;
3473 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3476 rcop->op_next = LINKLIST(expr);
3477 expr->op_next = (OP*)rcop;
3480 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3485 if (pm->op_pmflags & PMf_EVAL) {
3487 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3488 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3490 else if (repl->op_type == OP_CONST)
3494 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3495 if (curop->op_type == OP_SCOPE
3496 || curop->op_type == OP_LEAVE
3497 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3498 if (curop->op_type == OP_GV) {
3499 GV * const gv = cGVOPx_gv(curop);
3501 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3504 else if (curop->op_type == OP_RV2CV)
3506 else if (curop->op_type == OP_RV2SV ||
3507 curop->op_type == OP_RV2AV ||
3508 curop->op_type == OP_RV2HV ||
3509 curop->op_type == OP_RV2GV) {
3510 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3513 else if (curop->op_type == OP_PADSV ||
3514 curop->op_type == OP_PADAV ||
3515 curop->op_type == OP_PADHV ||
3516 curop->op_type == OP_PADANY)
3520 else if (curop->op_type == OP_PUSHRE)
3521 NOOP; /* Okay here, dangerous in newASSIGNOP */
3531 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3533 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3534 prepend_elem(o->op_type, scalar(repl), o);
3537 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3538 pm->op_pmflags |= PMf_MAYBE_CONST;
3540 NewOp(1101, rcop, 1, LOGOP);
3541 rcop->op_type = OP_SUBSTCONT;
3542 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3543 rcop->op_first = scalar(repl);
3544 rcop->op_flags |= OPf_KIDS;
3545 rcop->op_private = 1;
3548 /* establish postfix order */
3549 rcop->op_next = LINKLIST(repl);
3550 repl->op_next = (OP*)rcop;
3552 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3553 assert(!(pm->op_pmflags & PMf_ONCE));
3554 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3563 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3567 NewOp(1101, svop, 1, SVOP);
3568 svop->op_type = (OPCODE)type;
3569 svop->op_ppaddr = PL_ppaddr[type];
3571 svop->op_next = (OP*)svop;
3572 svop->op_flags = (U8)flags;
3573 if (PL_opargs[type] & OA_RETSCALAR)
3575 if (PL_opargs[type] & OA_TARGET)
3576 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3577 return CHECKOP(type, svop);
3582 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3586 NewOp(1101, padop, 1, PADOP);
3587 padop->op_type = (OPCODE)type;
3588 padop->op_ppaddr = PL_ppaddr[type];
3589 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3590 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3591 PAD_SETSV(padop->op_padix, sv);
3594 padop->op_next = (OP*)padop;
3595 padop->op_flags = (U8)flags;
3596 if (PL_opargs[type] & OA_RETSCALAR)
3598 if (PL_opargs[type] & OA_TARGET)
3599 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3600 return CHECKOP(type, padop);
3605 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3611 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3613 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3618 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3622 NewOp(1101, pvop, 1, PVOP);
3623 pvop->op_type = (OPCODE)type;
3624 pvop->op_ppaddr = PL_ppaddr[type];
3626 pvop->op_next = (OP*)pvop;
3627 pvop->op_flags = (U8)flags;
3628 if (PL_opargs[type] & OA_RETSCALAR)
3630 if (PL_opargs[type] & OA_TARGET)
3631 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3632 return CHECKOP(type, pvop);
3640 Perl_package(pTHX_ OP *o)
3643 SV *const sv = cSVOPo->op_sv;
3648 save_hptr(&PL_curstash);
3649 save_item(PL_curstname);
3651 PL_curstash = gv_stashsv(sv, GV_ADD);
3653 /* In case mg.c:Perl_magic_setisa faked
3654 this package earlier, we clear the fake flag */
3655 HvMROMETA(PL_curstash)->fake = 0;
3657 sv_setsv(PL_curstname, sv);
3659 PL_hints |= HINT_BLOCK_SCOPE;
3660 PL_copline = NOLINE;
3666 if (!PL_madskills) {
3671 pegop = newOP(OP_NULL,0);
3672 op_getmad(o,pegop,'P');
3682 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3689 OP *pegop = newOP(OP_NULL,0);
3692 if (idop->op_type != OP_CONST)
3693 Perl_croak(aTHX_ "Module name must be constant");
3696 op_getmad(idop,pegop,'U');
3701 SV * const vesv = ((SVOP*)version)->op_sv;
3704 op_getmad(version,pegop,'V');
3705 if (!arg && !SvNIOKp(vesv)) {
3712 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3713 Perl_croak(aTHX_ "Version number must be constant number");
3715 /* Make copy of idop so we don't free it twice */
3716 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3718 /* Fake up a method call to VERSION */
3719 meth = newSVpvs_share("VERSION");
3720 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3721 append_elem(OP_LIST,
3722 prepend_elem(OP_LIST, pack, list(version)),
3723 newSVOP(OP_METHOD_NAMED, 0, meth)));
3727 /* Fake up an import/unimport */
3728 if (arg && arg->op_type == OP_STUB) {
3730 op_getmad(arg,pegop,'S');
3731 imop = arg; /* no import on explicit () */
3733 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3734 imop = NULL; /* use 5.0; */
3736 idop->op_private |= OPpCONST_NOVER;
3742 op_getmad(arg,pegop,'A');
3744 /* Make copy of idop so we don't free it twice */
3745 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3747 /* Fake up a method call to import/unimport */
3749 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3750 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3751 append_elem(OP_LIST,
3752 prepend_elem(OP_LIST, pack, list(arg)),
3753 newSVOP(OP_METHOD_NAMED, 0, meth)));
3756 /* Fake up the BEGIN {}, which does its thing immediately. */
3758 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3761 append_elem(OP_LINESEQ,
3762 append_elem(OP_LINESEQ,
3763 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3764 newSTATEOP(0, NULL, veop)),
3765 newSTATEOP(0, NULL, imop) ));
3767 /* The "did you use incorrect case?" warning used to be here.
3768 * The problem is that on case-insensitive filesystems one
3769 * might get false positives for "use" (and "require"):
3770 * "use Strict" or "require CARP" will work. This causes
3771 * portability problems for the script: in case-strict
3772 * filesystems the script will stop working.
3774 * The "incorrect case" warning checked whether "use Foo"
3775 * imported "Foo" to your namespace, but that is wrong, too:
3776 * there is no requirement nor promise in the language that
3777 * a Foo.pm should or would contain anything in package "Foo".
3779 * There is very little Configure-wise that can be done, either:
3780 * the case-sensitivity of the build filesystem of Perl does not
3781 * help in guessing the case-sensitivity of the runtime environment.
3784 PL_hints |= HINT_BLOCK_SCOPE;
3785 PL_copline = NOLINE;
3787 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3790 if (!PL_madskills) {
3791 /* FIXME - don't allocate pegop if !PL_madskills */
3800 =head1 Embedding Functions
3802 =for apidoc load_module
3804 Loads the module whose name is pointed to by the string part of name.
3805 Note that the actual module name, not its filename, should be given.
3806 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3807 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3808 (or 0 for no flags). ver, if specified, provides version semantics
3809 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3810 arguments can be used to specify arguments to the module's import()
3811 method, similar to C<use Foo::Bar VERSION LIST>.
3816 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3819 va_start(args, ver);
3820 vload_module(flags, name, ver, &args);
3824 #ifdef PERL_IMPLICIT_CONTEXT
3826 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3830 va_start(args, ver);
3831 vload_module(flags, name, ver, &args);
3837 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3842 OP * const modname = newSVOP(OP_CONST, 0, name);
3843 modname->op_private |= OPpCONST_BARE;
3845 veop = newSVOP(OP_CONST, 0, ver);
3849 if (flags & PERL_LOADMOD_NOIMPORT) {
3850 imop = sawparens(newNULLLIST());
3852 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3853 imop = va_arg(*args, OP*);
3858 sv = va_arg(*args, SV*);
3860 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3861 sv = va_arg(*args, SV*);
3865 const line_t ocopline = PL_copline;
3866 COP * const ocurcop = PL_curcop;
3867 const U8 oexpect = PL_expect;
3869 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3870 veop, modname, imop);
3871 PL_expect = oexpect;
3872 PL_copline = ocopline;
3873 PL_curcop = ocurcop;
3878 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3884 if (!force_builtin) {
3885 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3886 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3887 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3888 gv = gvp ? *gvp : NULL;
3892 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3893 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3894 append_elem(OP_LIST, term,
3895 scalar(newUNOP(OP_RV2CV, 0,
3896 newGVOP(OP_GV, 0, gv))))));
3899 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3905 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3907 return newBINOP(OP_LSLICE, flags,
3908 list(force_list(subscript)),
3909 list(force_list(listval)) );
3913 S_is_list_assignment(pTHX_ register const OP *o)
3921 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3922 o = cUNOPo->op_first;
3924 flags = o->op_flags;
3926 if (type == OP_COND_EXPR) {
3927 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3928 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3933 yyerror("Assignment to both a list and a scalar");
3937 if (type == OP_LIST &&
3938 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3939 o->op_private & OPpLVAL_INTRO)
3942 if (type == OP_LIST || flags & OPf_PARENS ||
3943 type == OP_RV2AV || type == OP_RV2HV ||
3944 type == OP_ASLICE || type == OP_HSLICE)
3947 if (type == OP_PADAV || type == OP_PADHV)
3950 if (type == OP_RV2SV)
3957 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3963 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3964 return newLOGOP(optype, 0,
3965 mod(scalar(left), optype),
3966 newUNOP(OP_SASSIGN, 0, scalar(right)));
3969 return newBINOP(optype, OPf_STACKED,
3970 mod(scalar(left), optype), scalar(right));
3974 if (is_list_assignment(left)) {
3978 /* Grandfathering $[ assignment here. Bletch.*/
3979 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3980 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3981 left = mod(left, OP_AASSIGN);
3984 else if (left->op_type == OP_CONST) {
3986 /* Result of assignment is always 1 (or we'd be dead already) */
3987 return newSVOP(OP_CONST, 0, newSViv(1));
3989 curop = list(force_list(left));
3990 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3991 o->op_private = (U8)(0 | (flags >> 8));
3993 /* PL_generation sorcery:
3994 * an assignment like ($a,$b) = ($c,$d) is easier than
3995 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3996 * To detect whether there are common vars, the global var
3997 * PL_generation is incremented for each assign op we compile.
3998 * Then, while compiling the assign op, we run through all the
3999 * variables on both sides of the assignment, setting a spare slot
4000 * in each of them to PL_generation. If any of them already have
4001 * that value, we know we've got commonality. We could use a
4002 * single bit marker, but then we'd have to make 2 passes, first
4003 * to clear the flag, then to test and set it. To find somewhere
4004 * to store these values, evil chicanery is done with SvUVX().
4010 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4011 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4012 if (curop->op_type == OP_GV) {
4013 GV *gv = cGVOPx_gv(curop);
4015 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4017 GvASSIGN_GENERATION_set(gv, PL_generation);
4019 else if (curop->op_type == OP_PADSV ||
4020 curop->op_type == OP_PADAV ||
4021 curop->op_type == OP_PADHV ||
4022 curop->op_type == OP_PADANY)
4024 if (PAD_COMPNAME_GEN(curop->op_targ)
4025 == (STRLEN)PL_generation)
4027 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4030 else if (curop->op_type == OP_RV2CV)
4032 else if (curop->op_type == OP_RV2SV ||
4033 curop->op_type == OP_RV2AV ||
4034 curop->op_type == OP_RV2HV ||
4035 curop->op_type == OP_RV2GV) {
4036 if (lastop->op_type != OP_GV) /* funny deref? */
4039 else if (curop->op_type == OP_PUSHRE) {
4041 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4042 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4044 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4046 GvASSIGN_GENERATION_set(gv, PL_generation);
4050 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4053 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4055 GvASSIGN_GENERATION_set(gv, PL_generation);
4065 o->op_private |= OPpASSIGN_COMMON;
4068 if (right && right->op_type == OP_SPLIT) {
4069 OP* tmpop = ((LISTOP*)right)->op_first;
4070 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4071 PMOP * const pm = (PMOP*)tmpop;
4072 if (left->op_type == OP_RV2AV &&
4073 !(left->op_private & OPpLVAL_INTRO) &&
4074 !(o->op_private & OPpASSIGN_COMMON) )
4076 tmpop = ((UNOP*)left)->op_first;
4077 if (tmpop->op_type == OP_GV
4079 && !pm->op_pmreplrootu.op_pmtargetoff
4081 && !pm->op_pmreplrootu.op_pmtargetgv
4085 pm->op_pmreplrootu.op_pmtargetoff
4086 = cPADOPx(tmpop)->op_padix;
4087 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4089 pm->op_pmreplrootu.op_pmtargetgv
4090 = (GV*)cSVOPx(tmpop)->op_sv;
4091 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4093 pm->op_pmflags |= PMf_ONCE;
4094 tmpop = cUNOPo->op_first; /* to list (nulled) */
4095 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4096 tmpop->op_sibling = NULL; /* don't free split */
4097 right->op_next = tmpop->op_next; /* fix starting loc */
4099 op_getmad(o,right,'R'); /* blow off assign */
4101 op_free(o); /* blow off assign */
4103 right->op_flags &= ~OPf_WANT;
4104 /* "I don't know and I don't care." */
4109 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4110 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4112 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4114 sv_setiv(sv, PL_modcount+1);
4122 right = newOP(OP_UNDEF, 0);
4123 if (right->op_type == OP_READLINE) {
4124 right->op_flags |= OPf_STACKED;
4125 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4128 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4129 o = newBINOP(OP_SASSIGN, flags,
4130 scalar(right), mod(scalar(left), OP_SASSIGN) );
4136 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4137 o->op_private |= OPpCONST_ARYBASE;
4144 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4147 const U32 seq = intro_my();
4150 NewOp(1101, cop, 1, COP);
4151 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4152 cop->op_type = OP_DBSTATE;
4153 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4156 cop->op_type = OP_NEXTSTATE;
4157 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4159 cop->op_flags = (U8)flags;
4160 CopHINTS_set(cop, PL_hints);
4162 cop->op_private |= NATIVE_HINTS;
4164 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4165 cop->op_next = (OP*)cop;
4168 CopLABEL_set(cop, label);
4169 PL_hints |= HINT_BLOCK_SCOPE;
4172 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4173 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4175 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4176 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4177 if (cop->cop_hints_hash) {
4179 cop->cop_hints_hash->refcounted_he_refcnt++;
4180 HINTS_REFCNT_UNLOCK;
4183 if (PL_copline == NOLINE)
4184 CopLINE_set(cop, CopLINE(PL_curcop));
4186 CopLINE_set(cop, PL_copline);
4187 PL_copline = NOLINE;
4190 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4192 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4194 CopSTASH_set(cop, PL_curstash);
4196 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4197 AV *av = CopFILEAVx(PL_curcop);
4199 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4200 if (svp && *svp != &PL_sv_undef ) {
4201 (void)SvIOK_on(*svp);
4202 SvIV_set(*svp, PTR2IV(cop));
4207 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4212 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4215 return new_logop(type, flags, &first, &other);
4219 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4224 OP *first = *firstp;
4225 OP * const other = *otherp;
4227 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4228 return newBINOP(type, flags, scalar(first), scalar(other));
4230 scalarboolean(first);
4231 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4232 if (first->op_type == OP_NOT
4233 && (first->op_flags & OPf_SPECIAL)
4234 && (first->op_flags & OPf_KIDS)) {
4235 if (type == OP_AND || type == OP_OR) {
4241 first = *firstp = cUNOPo->op_first;
4243 first->op_next = o->op_next;
4244 cUNOPo->op_first = NULL;
4246 op_getmad(o,first,'O');
4252 if (first->op_type == OP_CONST) {
4253 if (first->op_private & OPpCONST_STRICT)
4254 no_bareword_allowed(first);
4255 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4256 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4257 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4258 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4259 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4261 if (other->op_type == OP_CONST)
4262 other->op_private |= OPpCONST_SHORTCIRCUIT;
4264 OP *newop = newUNOP(OP_NULL, 0, other);
4265 op_getmad(first, newop, '1');
4266 newop->op_targ = type; /* set "was" field */
4273 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4274 const OP *o2 = other;
4275 if ( ! (o2->op_type == OP_LIST
4276 && (( o2 = cUNOPx(o2)->op_first))
4277 && o2->op_type == OP_PUSHMARK
4278 && (( o2 = o2->op_sibling)) )
4281 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4282 || o2->op_type == OP_PADHV)
4283 && o2->op_private & OPpLVAL_INTRO
4284 && ckWARN(WARN_DEPRECATED))
4286 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4287 "Deprecated use of my() in false conditional");
4291 if (first->op_type == OP_CONST)
4292 first->op_private |= OPpCONST_SHORTCIRCUIT;
4294 first = newUNOP(OP_NULL, 0, first);
4295 op_getmad(other, first, '2');
4296 first->op_targ = type; /* set "was" field */
4303 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4304 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4306 const OP * const k1 = ((UNOP*)first)->op_first;
4307 const OP * const k2 = k1->op_sibling;
4309 switch (first->op_type)
4312 if (k2 && k2->op_type == OP_READLINE
4313 && (k2->op_flags & OPf_STACKED)
4314 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4316 warnop = k2->op_type;
4321 if (k1->op_type == OP_READDIR
4322 || k1->op_type == OP_GLOB
4323 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4324 || k1->op_type == OP_EACH)
4326 warnop = ((k1->op_type == OP_NULL)
4327 ? (OPCODE)k1->op_targ : k1->op_type);
4332 const line_t oldline = CopLINE(PL_curcop);
4333 CopLINE_set(PL_curcop, PL_copline);
4334 Perl_warner(aTHX_ packWARN(WARN_MISC),
4335 "Value of %s%s can be \"0\"; test with defined()",
4337 ((warnop == OP_READLINE || warnop == OP_GLOB)
4338 ? " construct" : "() operator"));
4339 CopLINE_set(PL_curcop, oldline);
4346 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4347 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4349 NewOp(1101, logop, 1, LOGOP);
4351 logop->op_type = (OPCODE)type;
4352 logop->op_ppaddr = PL_ppaddr[type];
4353 logop->op_first = first;
4354 logop->op_flags = (U8)(flags | OPf_KIDS);
4355 logop->op_other = LINKLIST(other);
4356 logop->op_private = (U8)(1 | (flags >> 8));
4358 /* establish postfix order */
4359 logop->op_next = LINKLIST(first);
4360 first->op_next = (OP*)logop;
4361 first->op_sibling = other;
4363 CHECKOP(type,logop);
4365 o = newUNOP(OP_NULL, 0, (OP*)logop);
4372 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4380 return newLOGOP(OP_AND, 0, first, trueop);
4382 return newLOGOP(OP_OR, 0, first, falseop);
4384 scalarboolean(first);
4385 if (first->op_type == OP_CONST) {
4386 /* Left or right arm of the conditional? */
4387 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4388 OP *live = left ? trueop : falseop;
4389 OP *const dead = left ? falseop : trueop;
4390 if (first->op_private & OPpCONST_BARE &&
4391 first->op_private & OPpCONST_STRICT) {
4392 no_bareword_allowed(first);
4395 /* This is all dead code when PERL_MAD is not defined. */
4396 live = newUNOP(OP_NULL, 0, live);
4397 op_getmad(first, live, 'C');
4398 op_getmad(dead, live, left ? 'e' : 't');
4405 NewOp(1101, logop, 1, LOGOP);
4406 logop->op_type = OP_COND_EXPR;
4407 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4408 logop->op_first = first;
4409 logop->op_flags = (U8)(flags | OPf_KIDS);
4410 logop->op_private = (U8)(1 | (flags >> 8));
4411 logop->op_other = LINKLIST(trueop);
4412 logop->op_next = LINKLIST(falseop);
4414 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4417 /* establish postfix order */
4418 start = LINKLIST(first);
4419 first->op_next = (OP*)logop;
4421 first->op_sibling = trueop;
4422 trueop->op_sibling = falseop;
4423 o = newUNOP(OP_NULL, 0, (OP*)logop);
4425 trueop->op_next = falseop->op_next = o;
4432 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4441 NewOp(1101, range, 1, LOGOP);
4443 range->op_type = OP_RANGE;
4444 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4445 range->op_first = left;
4446 range->op_flags = OPf_KIDS;
4447 leftstart = LINKLIST(left);
4448 range->op_other = LINKLIST(right);
4449 range->op_private = (U8)(1 | (flags >> 8));
4451 left->op_sibling = right;
4453 range->op_next = (OP*)range;
4454 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4455 flop = newUNOP(OP_FLOP, 0, flip);
4456 o = newUNOP(OP_NULL, 0, flop);
4458 range->op_next = leftstart;
4460 left->op_next = flip;
4461 right->op_next = flop;
4463 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4464 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4465 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4466 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4468 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4469 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4472 if (!flip->op_private || !flop->op_private)
4473 linklist(o); /* blow off optimizer unless constant */
4479 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4484 const bool once = block && block->op_flags & OPf_SPECIAL &&
4485 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4487 PERL_UNUSED_ARG(debuggable);
4490 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4491 return block; /* do {} while 0 does once */
4492 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4493 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4494 expr = newUNOP(OP_DEFINED, 0,
4495 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4496 } else if (expr->op_flags & OPf_KIDS) {
4497 const OP * const k1 = ((UNOP*)expr)->op_first;
4498 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4499 switch (expr->op_type) {
4501 if (k2 && k2->op_type == OP_READLINE
4502 && (k2->op_flags & OPf_STACKED)
4503 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4504 expr = newUNOP(OP_DEFINED, 0, expr);
4508 if (k1 && (k1->op_type == OP_READDIR
4509 || k1->op_type == OP_GLOB
4510 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4511 || k1->op_type == OP_EACH))
4512 expr = newUNOP(OP_DEFINED, 0, expr);
4518 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4519 * op, in listop. This is wrong. [perl #27024] */
4521 block = newOP(OP_NULL, 0);
4522 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4523 o = new_logop(OP_AND, 0, &expr, &listop);
4526 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4528 if (once && o != listop)
4529 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4532 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4534 o->op_flags |= flags;
4536 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4541 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4542 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4551 PERL_UNUSED_ARG(debuggable);
4554 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4555 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4556 expr = newUNOP(OP_DEFINED, 0,
4557 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4558 } else if (expr->op_flags & OPf_KIDS) {
4559 const OP * const k1 = ((UNOP*)expr)->op_first;
4560 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4561 switch (expr->op_type) {
4563 if (k2 && k2->op_type == OP_READLINE
4564 && (k2->op_flags & OPf_STACKED)
4565 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4566 expr = newUNOP(OP_DEFINED, 0, expr);
4570 if (k1 && (k1->op_type == OP_READDIR
4571 || k1->op_type == OP_GLOB
4572 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4573 || k1->op_type == OP_EACH))
4574 expr = newUNOP(OP_DEFINED, 0, expr);
4581 block = newOP(OP_NULL, 0);
4582 else if (cont || has_my) {
4583 block = scope(block);
4587 next = LINKLIST(cont);
4590 OP * const unstack = newOP(OP_UNSTACK, 0);
4593 cont = append_elem(OP_LINESEQ, cont, unstack);
4597 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4599 redo = LINKLIST(listop);
4602 PL_copline = (line_t)whileline;
4604 o = new_logop(OP_AND, 0, &expr, &listop);
4605 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4606 op_free(expr); /* oops, it's a while (0) */
4608 return NULL; /* listop already freed by new_logop */
4611 ((LISTOP*)listop)->op_last->op_next =
4612 (o == listop ? redo : LINKLIST(o));
4618 NewOp(1101,loop,1,LOOP);
4619 loop->op_type = OP_ENTERLOOP;
4620 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4621 loop->op_private = 0;
4622 loop->op_next = (OP*)loop;
4625 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4627 loop->op_redoop = redo;
4628 loop->op_lastop = o;
4629 o->op_private |= loopflags;
4632 loop->op_nextop = next;
4634 loop->op_nextop = o;
4636 o->op_flags |= flags;
4637 o->op_private |= (flags >> 8);
4642 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4647 PADOFFSET padoff = 0;
4653 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4654 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4655 sv->op_type = OP_RV2GV;
4656 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4658 /* The op_type check is needed to prevent a possible segfault
4659 * if the loop variable is undeclared and 'strict vars' is in
4660 * effect. This is illegal but is nonetheless parsed, so we
4661 * may reach this point with an OP_CONST where we're expecting
4664 if (cUNOPx(sv)->op_first->op_type == OP_GV
4665 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4666 iterpflags |= OPpITER_DEF;
4668 else if (sv->op_type == OP_PADSV) { /* private variable */
4669 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4670 padoff = sv->op_targ;
4680 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4682 SV *const namesv = PAD_COMPNAME_SV(padoff);
4684 const char *const name = SvPV_const(namesv, len);
4686 if (len == 2 && name[0] == '$' && name[1] == '_')
4687 iterpflags |= OPpITER_DEF;
4691 const PADOFFSET offset = pad_findmy("$_");
4692 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4693 sv = newGVOP(OP_GV, 0, PL_defgv);
4698 iterpflags |= OPpITER_DEF;
4700 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4701 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4702 iterflags |= OPf_STACKED;
4704 else if (expr->op_type == OP_NULL &&
4705 (expr->op_flags & OPf_KIDS) &&
4706 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4708 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4709 * set the STACKED flag to indicate that these values are to be
4710 * treated as min/max values by 'pp_iterinit'.
4712 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4713 LOGOP* const range = (LOGOP*) flip->op_first;
4714 OP* const left = range->op_first;
4715 OP* const right = left->op_sibling;
4718 range->op_flags &= ~OPf_KIDS;
4719 range->op_first = NULL;
4721 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4722 listop->op_first->op_next = range->op_next;
4723 left->op_next = range->op_other;
4724 right->op_next = (OP*)listop;
4725 listop->op_next = listop->op_first;
4728 op_getmad(expr,(OP*)listop,'O');
4732 expr = (OP*)(listop);
4734 iterflags |= OPf_STACKED;
4737 expr = mod(force_list(expr), OP_GREPSTART);
4740 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4741 append_elem(OP_LIST, expr, scalar(sv))));
4742 assert(!loop->op_next);
4743 /* for my $x () sets OPpLVAL_INTRO;
4744 * for our $x () sets OPpOUR_INTRO */
4745 loop->op_private = (U8)iterpflags;
4746 #ifdef PL_OP_SLAB_ALLOC
4749 NewOp(1234,tmp,1,LOOP);
4750 Copy(loop,tmp,1,LISTOP);
4751 S_op_destroy(aTHX_ (OP*)loop);
4755 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4757 loop->op_targ = padoff;
4758 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4760 op_getmad(madsv, (OP*)loop, 'v');
4761 PL_copline = forline;
4762 return newSTATEOP(0, label, wop);
4766 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4771 if (type != OP_GOTO || label->op_type == OP_CONST) {
4772 /* "last()" means "last" */
4773 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4774 o = newOP(type, OPf_SPECIAL);
4776 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4777 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4781 op_getmad(label,o,'L');
4787 /* Check whether it's going to be a goto &function */
4788 if (label->op_type == OP_ENTERSUB
4789 && !(label->op_flags & OPf_STACKED))
4790 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4791 o = newUNOP(type, OPf_STACKED, label);
4793 PL_hints |= HINT_BLOCK_SCOPE;
4797 /* if the condition is a literal array or hash
4798 (or @{ ... } etc), make a reference to it.
4801 S_ref_array_or_hash(pTHX_ OP *cond)
4804 && (cond->op_type == OP_RV2AV
4805 || cond->op_type == OP_PADAV
4806 || cond->op_type == OP_RV2HV
4807 || cond->op_type == OP_PADHV))
4809 return newUNOP(OP_REFGEN,
4810 0, mod(cond, OP_REFGEN));
4816 /* These construct the optree fragments representing given()
4819 entergiven and enterwhen are LOGOPs; the op_other pointer
4820 points up to the associated leave op. We need this so we
4821 can put it in the context and make break/continue work.
4822 (Also, of course, pp_enterwhen will jump straight to
4823 op_other if the match fails.)
4827 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4828 I32 enter_opcode, I32 leave_opcode,
4829 PADOFFSET entertarg)
4835 NewOp(1101, enterop, 1, LOGOP);
4836 enterop->op_type = enter_opcode;
4837 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4838 enterop->op_flags = (U8) OPf_KIDS;
4839 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4840 enterop->op_private = 0;
4842 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4845 enterop->op_first = scalar(cond);
4846 cond->op_sibling = block;
4848 o->op_next = LINKLIST(cond);
4849 cond->op_next = (OP *) enterop;
4852 /* This is a default {} block */
4853 enterop->op_first = block;
4854 enterop->op_flags |= OPf_SPECIAL;
4856 o->op_next = (OP *) enterop;
4859 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4860 entergiven and enterwhen both
4863 enterop->op_next = LINKLIST(block);
4864 block->op_next = enterop->op_other = o;
4869 /* Does this look like a boolean operation? For these purposes
4870 a boolean operation is:
4871 - a subroutine call [*]
4872 - a logical connective
4873 - a comparison operator
4874 - a filetest operator, with the exception of -s -M -A -C
4875 - defined(), exists() or eof()
4876 - /$re/ or $foo =~ /$re/
4878 [*] possibly surprising
4881 S_looks_like_bool(pTHX_ const OP *o)
4884 switch(o->op_type) {
4886 return looks_like_bool(cLOGOPo->op_first);
4890 looks_like_bool(cLOGOPo->op_first)
4891 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4895 case OP_NOT: case OP_XOR:
4896 /* Note that OP_DOR is not here */
4898 case OP_EQ: case OP_NE: case OP_LT:
4899 case OP_GT: case OP_LE: case OP_GE:
4901 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4902 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4904 case OP_SEQ: case OP_SNE: case OP_SLT:
4905 case OP_SGT: case OP_SLE: case OP_SGE:
4909 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4910 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4911 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4912 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4913 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4914 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4915 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4916 case OP_FTTEXT: case OP_FTBINARY:
4918 case OP_DEFINED: case OP_EXISTS:
4919 case OP_MATCH: case OP_EOF:
4924 /* Detect comparisons that have been optimized away */
4925 if (cSVOPo->op_sv == &PL_sv_yes
4926 || cSVOPo->op_sv == &PL_sv_no)
4937 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4941 return newGIVWHENOP(
4942 ref_array_or_hash(cond),
4944 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4948 /* If cond is null, this is a default {} block */
4950 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4952 const bool cond_llb = (!cond || looks_like_bool(cond));
4958 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4960 scalar(ref_array_or_hash(cond)));
4963 return newGIVWHENOP(
4965 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4966 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4970 =for apidoc cv_undef
4972 Clear out all the active components of a CV. This can happen either
4973 by an explicit C<undef &foo>, or by the reference count going to zero.
4974 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4975 children can still follow the full lexical scope chain.
4981 Perl_cv_undef(pTHX_ CV *cv)
4985 if (CvFILE(cv) && !CvISXSUB(cv)) {
4986 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4987 Safefree(CvFILE(cv));
4992 if (!CvISXSUB(cv) && CvROOT(cv)) {
4993 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4994 Perl_croak(aTHX_ "Can't undef active subroutine");
4997 PAD_SAVE_SETNULLPAD();
4999 op_free(CvROOT(cv));
5004 SvPOK_off((SV*)cv); /* forget prototype */
5009 /* remove CvOUTSIDE unless this is an undef rather than a free */
5010 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5011 if (!CvWEAKOUTSIDE(cv))
5012 SvREFCNT_dec(CvOUTSIDE(cv));
5013 CvOUTSIDE(cv) = NULL;
5016 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5019 if (CvISXSUB(cv) && CvXSUB(cv)) {
5022 /* delete all flags except WEAKOUTSIDE */
5023 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5027 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5030 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5031 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5032 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5033 || (p && (len != SvCUR(cv) /* Not the same length. */
5034 || memNE(p, SvPVX_const(cv), len))))
5035 && ckWARN_d(WARN_PROTOTYPE)) {
5036 SV* const msg = sv_newmortal();
5040 gv_efullname3(name = sv_newmortal(), gv, NULL);
5041 sv_setpvs(msg, "Prototype mismatch:");
5043 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5045 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5047 sv_catpvs(msg, ": none");
5048 sv_catpvs(msg, " vs ");
5050 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5052 sv_catpvs(msg, "none");
5053 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5057 static void const_sv_xsub(pTHX_ CV* cv);
5061 =head1 Optree Manipulation Functions
5063 =for apidoc cv_const_sv
5065 If C<cv> is a constant sub eligible for inlining. returns the constant
5066 value returned by the sub. Otherwise, returns NULL.
5068 Constant subs can be created with C<newCONSTSUB> or as described in
5069 L<perlsub/"Constant Functions">.
5074 Perl_cv_const_sv(pTHX_ CV *cv)
5076 PERL_UNUSED_CONTEXT;
5079 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5081 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5084 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5085 * Can be called in 3 ways:
5088 * look for a single OP_CONST with attached value: return the value
5090 * cv && CvCLONE(cv) && !CvCONST(cv)
5092 * examine the clone prototype, and if contains only a single
5093 * OP_CONST referencing a pad const, or a single PADSV referencing
5094 * an outer lexical, return a non-zero value to indicate the CV is
5095 * a candidate for "constizing" at clone time
5099 * We have just cloned an anon prototype that was marked as a const
5100 * candidiate. Try to grab the current value, and in the case of
5101 * PADSV, ignore it if it has multiple references. Return the value.
5105 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5113 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5114 o = cLISTOPo->op_first->op_sibling;
5116 for (; o; o = o->op_next) {
5117 const OPCODE type = o->op_type;
5119 if (sv && o->op_next == o)
5121 if (o->op_next != o) {
5122 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5124 if (type == OP_DBSTATE)
5127 if (type == OP_LEAVESUB || type == OP_RETURN)
5131 if (type == OP_CONST && cSVOPo->op_sv)
5133 else if (cv && type == OP_CONST) {
5134 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5138 else if (cv && type == OP_PADSV) {
5139 if (CvCONST(cv)) { /* newly cloned anon */
5140 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5141 /* the candidate should have 1 ref from this pad and 1 ref
5142 * from the parent */
5143 if (!sv || SvREFCNT(sv) != 2)
5150 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5151 sv = &PL_sv_undef; /* an arbitrary non-null value */
5166 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5169 /* This would be the return value, but the return cannot be reached. */
5170 OP* pegop = newOP(OP_NULL, 0);
5173 PERL_UNUSED_ARG(floor);
5183 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5185 NORETURN_FUNCTION_END;
5190 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5192 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5196 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5203 register CV *cv = NULL;
5205 /* If the subroutine has no body, no attributes, and no builtin attributes
5206 then it's just a sub declaration, and we may be able to get away with
5207 storing with a placeholder scalar in the symbol table, rather than a
5208 full GV and CV. If anything is present then it will take a full CV to
5210 const I32 gv_fetch_flags
5211 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5213 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5214 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5217 assert(proto->op_type == OP_CONST);
5218 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5223 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5224 SV * const sv = sv_newmortal();
5225 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5226 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5227 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5228 aname = SvPVX_const(sv);
5233 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5234 : gv_fetchpv(aname ? aname
5235 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5236 gv_fetch_flags, SVt_PVCV);
5238 if (!PL_madskills) {
5247 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5248 maximum a prototype before. */
5249 if (SvTYPE(gv) > SVt_NULL) {
5250 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5251 && ckWARN_d(WARN_PROTOTYPE))
5253 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5255 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5258 sv_setpvn((SV*)gv, ps, ps_len);
5260 sv_setiv((SV*)gv, -1);
5262 SvREFCNT_dec(PL_compcv);
5263 cv = PL_compcv = NULL;
5267 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5269 #ifdef GV_UNIQUE_CHECK
5270 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5271 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5275 if (!block || !ps || *ps || attrs
5276 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5278 || block->op_type == OP_NULL
5283 const_sv = op_const_sv(block, NULL);
5286 const bool exists = CvROOT(cv) || CvXSUB(cv);
5288 #ifdef GV_UNIQUE_CHECK
5289 if (exists && GvUNIQUE(gv)) {
5290 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5294 /* if the subroutine doesn't exist and wasn't pre-declared
5295 * with a prototype, assume it will be AUTOLOADed,
5296 * skipping the prototype check
5298 if (exists || SvPOK(cv))
5299 cv_ckproto_len(cv, gv, ps, ps_len);
5300 /* already defined (or promised)? */
5301 if (exists || GvASSUMECV(gv)) {
5304 || block->op_type == OP_NULL
5307 if (CvFLAGS(PL_compcv)) {
5308 /* might have had built-in attrs applied */
5309 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5311 /* just a "sub foo;" when &foo is already defined */
5312 SAVEFREESV(PL_compcv);
5317 && block->op_type != OP_NULL
5320 if (ckWARN(WARN_REDEFINE)
5322 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5324 const line_t oldline = CopLINE(PL_curcop);
5325 if (PL_copline != NOLINE)
5326 CopLINE_set(PL_curcop, PL_copline);
5327 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5328 CvCONST(cv) ? "Constant subroutine %s redefined"
5329 : "Subroutine %s redefined", name);
5330 CopLINE_set(PL_curcop, oldline);
5333 if (!PL_minus_c) /* keep old one around for madskills */
5336 /* (PL_madskills unset in used file.) */
5344 SvREFCNT_inc_simple_void_NN(const_sv);
5346 assert(!CvROOT(cv) && !CvCONST(cv));
5347 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5348 CvXSUBANY(cv).any_ptr = const_sv;
5349 CvXSUB(cv) = const_sv_xsub;
5355 cv = newCONSTSUB(NULL, name, const_sv);
5357 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5358 (CvGV(cv) && GvSTASH(CvGV(cv)))
5367 SvREFCNT_dec(PL_compcv);
5375 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5376 * before we clobber PL_compcv.
5380 || block->op_type == OP_NULL
5384 /* Might have had built-in attributes applied -- propagate them. */
5385 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5386 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5387 stash = GvSTASH(CvGV(cv));
5388 else if (CvSTASH(cv))
5389 stash = CvSTASH(cv);
5391 stash = PL_curstash;
5394 /* possibly about to re-define existing subr -- ignore old cv */
5395 rcv = (SV*)PL_compcv;
5396 if (name && GvSTASH(gv))
5397 stash = GvSTASH(gv);
5399 stash = PL_curstash;
5401 apply_attrs(stash, rcv, attrs, FALSE);
5403 if (cv) { /* must reuse cv if autoloaded */
5410 || block->op_type == OP_NULL) && !PL_madskills
5413 /* got here with just attrs -- work done, so bug out */
5414 SAVEFREESV(PL_compcv);
5417 /* transfer PL_compcv to cv */
5419 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5420 if (!CvWEAKOUTSIDE(cv))
5421 SvREFCNT_dec(CvOUTSIDE(cv));
5422 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5423 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5424 CvOUTSIDE(PL_compcv) = 0;
5425 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5426 CvPADLIST(PL_compcv) = 0;
5427 /* inner references to PL_compcv must be fixed up ... */
5428 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5429 /* ... before we throw it away */
5430 SvREFCNT_dec(PL_compcv);
5432 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5433 ++PL_sub_generation;
5440 if (strEQ(name, "import")) {
5441 PL_formfeed = (SV*)cv;
5442 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5446 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5450 CvFILE_set_from_cop(cv, PL_curcop);
5451 CvSTASH(cv) = PL_curstash;
5454 sv_setpvn((SV*)cv, ps, ps_len);
5456 if (PL_error_count) {
5460 const char *s = strrchr(name, ':');
5462 if (strEQ(s, "BEGIN")) {
5463 const char not_safe[] =
5464 "BEGIN not safe after errors--compilation aborted";
5465 if (PL_in_eval & EVAL_KEEPERR)
5466 Perl_croak(aTHX_ not_safe);
5468 /* force display of errors found but not reported */
5469 sv_catpv(ERRSV, not_safe);
5470 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5480 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5481 mod(scalarseq(block), OP_LEAVESUBLV));
5482 block->op_attached = 1;
5485 /* This makes sub {}; work as expected. */
5486 if (block->op_type == OP_STUB) {
5487 OP* const newblock = newSTATEOP(0, NULL, 0);
5489 op_getmad(block,newblock,'B');
5496 block->op_attached = 1;
5497 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5499 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5500 OpREFCNT_set(CvROOT(cv), 1);
5501 CvSTART(cv) = LINKLIST(CvROOT(cv));
5502 CvROOT(cv)->op_next = 0;
5503 CALL_PEEP(CvSTART(cv));
5505 /* now that optimizer has done its work, adjust pad values */
5507 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5510 assert(!CvCONST(cv));
5511 if (ps && !*ps && op_const_sv(block, cv))
5515 if (name || aname) {
5516 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5517 SV * const sv = newSV(0);
5518 SV * const tmpstr = sv_newmortal();
5519 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5520 GV_ADDMULTI, SVt_PVHV);
5523 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5525 (long)PL_subline, (long)CopLINE(PL_curcop));
5526 gv_efullname3(tmpstr, gv, NULL);
5527 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5528 hv = GvHVn(db_postponed);
5529 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5530 CV * const pcv = GvCV(db_postponed);
5536 call_sv((SV*)pcv, G_DISCARD);
5541 if (name && !PL_error_count)
5542 process_special_blocks(name, gv, cv);
5546 PL_copline = NOLINE;
5552 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5555 const char *const colon = strrchr(fullname,':');
5556 const char *const name = colon ? colon + 1 : fullname;
5559 if (strEQ(name, "BEGIN")) {
5560 const I32 oldscope = PL_scopestack_ix;
5562 SAVECOPFILE(&PL_compiling);
5563 SAVECOPLINE(&PL_compiling);
5565 DEBUG_x( dump_sub(gv) );
5566 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5567 GvCV(gv) = 0; /* cv has been hijacked */
5568 call_list(oldscope, PL_beginav);
5570 PL_curcop = &PL_compiling;
5571 CopHINTS_set(&PL_compiling, PL_hints);
5578 if strEQ(name, "END") {
5579 DEBUG_x( dump_sub(gv) );
5580 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5583 } else if (*name == 'U') {
5584 if (strEQ(name, "UNITCHECK")) {
5585 /* It's never too late to run a unitcheck block */
5586 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5590 } else if (*name == 'C') {
5591 if (strEQ(name, "CHECK")) {
5592 if (PL_main_start && ckWARN(WARN_VOID))
5593 Perl_warner(aTHX_ packWARN(WARN_VOID),
5594 "Too late to run CHECK block");
5595 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5599 } else if (*name == 'I') {
5600 if (strEQ(name, "INIT")) {
5601 if (PL_main_start && ckWARN(WARN_VOID))
5602 Perl_warner(aTHX_ packWARN(WARN_VOID),
5603 "Too late to run INIT block");
5604 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5610 DEBUG_x( dump_sub(gv) );
5611 GvCV(gv) = 0; /* cv has been hijacked */
5616 =for apidoc newCONSTSUB
5618 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5619 eligible for inlining at compile-time.
5625 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5630 const char *const temp_p = CopFILE(PL_curcop);
5631 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5633 SV *const temp_sv = CopFILESV(PL_curcop);
5635 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5637 char *const file = savepvn(temp_p, temp_p ? len : 0);
5641 SAVECOPLINE(PL_curcop);
5642 CopLINE_set(PL_curcop, PL_copline);
5645 PL_hints &= ~HINT_BLOCK_SCOPE;
5648 SAVESPTR(PL_curstash);
5649 SAVECOPSTASH(PL_curcop);
5650 PL_curstash = stash;
5651 CopSTASH_set(PL_curcop,stash);
5654 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5655 and so doesn't get free()d. (It's expected to be from the C pre-
5656 processor __FILE__ directive). But we need a dynamically allocated one,
5657 and we need it to get freed. */
5658 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5659 CvXSUBANY(cv).any_ptr = sv;
5665 CopSTASH_free(PL_curcop);
5673 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5674 const char *const filename, const char *const proto,
5677 CV *cv = newXS(name, subaddr, filename);
5679 if (flags & XS_DYNAMIC_FILENAME) {
5680 /* We need to "make arrangements" (ie cheat) to ensure that the
5681 filename lasts as long as the PVCV we just created, but also doesn't
5683 STRLEN filename_len = strlen(filename);
5684 STRLEN proto_and_file_len = filename_len;
5685 char *proto_and_file;
5689 proto_len = strlen(proto);
5690 proto_and_file_len += proto_len;
5692 Newx(proto_and_file, proto_and_file_len + 1, char);
5693 Copy(proto, proto_and_file, proto_len, char);
5694 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5697 proto_and_file = savepvn(filename, filename_len);
5700 /* This gets free()d. :-) */
5701 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5702 SV_HAS_TRAILING_NUL);
5704 /* This gives us the correct prototype, rather than one with the
5705 file name appended. */
5706 SvCUR_set(cv, proto_len);
5710 CvFILE(cv) = proto_and_file + proto_len;
5712 sv_setpv((SV *)cv, proto);
5718 =for apidoc U||newXS
5720 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5721 static storage, as it is used directly as CvFILE(), without a copy being made.
5727 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5730 GV * const gv = gv_fetchpv(name ? name :
5731 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5732 GV_ADDMULTI, SVt_PVCV);
5736 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5738 if ((cv = (name ? GvCV(gv) : NULL))) {
5740 /* just a cached method */
5744 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5745 /* already defined (or promised) */
5746 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5747 if (ckWARN(WARN_REDEFINE)) {
5748 GV * const gvcv = CvGV(cv);
5750 HV * const stash = GvSTASH(gvcv);
5752 const char *redefined_name = HvNAME_get(stash);
5753 if ( strEQ(redefined_name,"autouse") ) {
5754 const line_t oldline = CopLINE(PL_curcop);
5755 if (PL_copline != NOLINE)
5756 CopLINE_set(PL_curcop, PL_copline);
5757 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5758 CvCONST(cv) ? "Constant subroutine %s redefined"
5759 : "Subroutine %s redefined"
5761 CopLINE_set(PL_curcop, oldline);
5771 if (cv) /* must reuse cv if autoloaded */
5774 cv = (CV*)newSV_type(SVt_PVCV);
5778 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5782 (void)gv_fetchfile(filename);
5783 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5784 an external constant string */
5786 CvXSUB(cv) = subaddr;
5789 process_special_blocks(name, gv, cv);
5801 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5806 OP* pegop = newOP(OP_NULL, 0);
5810 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5811 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5813 #ifdef GV_UNIQUE_CHECK
5815 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5819 if ((cv = GvFORM(gv))) {
5820 if (ckWARN(WARN_REDEFINE)) {
5821 const line_t oldline = CopLINE(PL_curcop);
5822 if (PL_copline != NOLINE)
5823 CopLINE_set(PL_curcop, PL_copline);
5824 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5825 o ? "Format %"SVf" redefined"
5826 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5827 CopLINE_set(PL_curcop, oldline);
5834 CvFILE_set_from_cop(cv, PL_curcop);
5837 pad_tidy(padtidy_FORMAT);
5838 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5839 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5840 OpREFCNT_set(CvROOT(cv), 1);
5841 CvSTART(cv) = LINKLIST(CvROOT(cv));
5842 CvROOT(cv)->op_next = 0;
5843 CALL_PEEP(CvSTART(cv));
5845 op_getmad(o,pegop,'n');
5846 op_getmad_weak(block, pegop, 'b');
5850 PL_copline = NOLINE;
5858 Perl_newANONLIST(pTHX_ OP *o)
5860 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5864 Perl_newANONHASH(pTHX_ OP *o)
5866 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5870 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5872 return newANONATTRSUB(floor, proto, NULL, block);
5876 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5878 return newUNOP(OP_REFGEN, 0,
5879 newSVOP(OP_ANONCODE, 0,
5880 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5884 Perl_oopsAV(pTHX_ OP *o)
5887 switch (o->op_type) {
5889 o->op_type = OP_PADAV;
5890 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5891 return ref(o, OP_RV2AV);
5894 o->op_type = OP_RV2AV;
5895 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5900 if (ckWARN_d(WARN_INTERNAL))
5901 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5908 Perl_oopsHV(pTHX_ OP *o)
5911 switch (o->op_type) {
5914 o->op_type = OP_PADHV;
5915 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5916 return ref(o, OP_RV2HV);
5920 o->op_type = OP_RV2HV;
5921 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5926 if (ckWARN_d(WARN_INTERNAL))
5927 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5934 Perl_newAVREF(pTHX_ OP *o)
5937 if (o->op_type == OP_PADANY) {
5938 o->op_type = OP_PADAV;
5939 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5942 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5943 && ckWARN(WARN_DEPRECATED)) {
5944 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5945 "Using an array as a reference is deprecated");
5947 return newUNOP(OP_RV2AV, 0, scalar(o));
5951 Perl_newGVREF(pTHX_ I32 type, OP *o)
5953 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5954 return newUNOP(OP_NULL, 0, o);
5955 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5959 Perl_newHVREF(pTHX_ OP *o)
5962 if (o->op_type == OP_PADANY) {
5963 o->op_type = OP_PADHV;
5964 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5967 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5968 && ckWARN(WARN_DEPRECATED)) {
5969 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5970 "Using a hash as a reference is deprecated");
5972 return newUNOP(OP_RV2HV, 0, scalar(o));
5976 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5978 return newUNOP(OP_RV2CV, flags, scalar(o));
5982 Perl_newSVREF(pTHX_ OP *o)
5985 if (o->op_type == OP_PADANY) {
5986 o->op_type = OP_PADSV;
5987 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5990 return newUNOP(OP_RV2SV, 0, scalar(o));
5993 /* Check routines. See the comments at the top of this file for details
5994 * on when these are called */
5997 Perl_ck_anoncode(pTHX_ OP *o)
5999 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6001 cSVOPo->op_sv = NULL;
6006 Perl_ck_bitop(pTHX_ OP *o)
6009 #define OP_IS_NUMCOMPARE(op) \
6010 ((op) == OP_LT || (op) == OP_I_LT || \
6011 (op) == OP_GT || (op) == OP_I_GT || \
6012 (op) == OP_LE || (op) == OP_I_LE || \
6013 (op) == OP_GE || (op) == OP_I_GE || \
6014 (op) == OP_EQ || (op) == OP_I_EQ || \
6015 (op) == OP_NE || (op) == OP_I_NE || \
6016 (op) == OP_NCMP || (op) == OP_I_NCMP)
6017 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6018 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6019 && (o->op_type == OP_BIT_OR
6020 || o->op_type == OP_BIT_AND
6021 || o->op_type == OP_BIT_XOR))
6023 const OP * const left = cBINOPo->op_first;
6024 const OP * const right = left->op_sibling;
6025 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6026 (left->op_flags & OPf_PARENS) == 0) ||
6027 (OP_IS_NUMCOMPARE(right->op_type) &&
6028 (right->op_flags & OPf_PARENS) == 0))
6029 if (ckWARN(WARN_PRECEDENCE))
6030 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6031 "Possible precedence problem on bitwise %c operator",
6032 o->op_type == OP_BIT_OR ? '|'
6033 : o->op_type == OP_BIT_AND ? '&' : '^'
6040 Perl_ck_concat(pTHX_ OP *o)
6042 const OP * const kid = cUNOPo->op_first;
6043 PERL_UNUSED_CONTEXT;
6044 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6045 !(kUNOP->op_first->op_flags & OPf_MOD))
6046 o->op_flags |= OPf_STACKED;
6051 Perl_ck_spair(pTHX_ OP *o)
6054 if (o->op_flags & OPf_KIDS) {
6057 const OPCODE type = o->op_type;
6058 o = modkids(ck_fun(o), type);
6059 kid = cUNOPo->op_first;
6060 newop = kUNOP->op_first->op_sibling;
6062 const OPCODE type = newop->op_type;
6063 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6064 type == OP_PADAV || type == OP_PADHV ||
6065 type == OP_RV2AV || type == OP_RV2HV)
6069 op_getmad(kUNOP->op_first,newop,'K');
6071 op_free(kUNOP->op_first);
6073 kUNOP->op_first = newop;
6075 o->op_ppaddr = PL_ppaddr[++o->op_type];
6080 Perl_ck_delete(pTHX_ OP *o)
6084 if (o->op_flags & OPf_KIDS) {
6085 OP * const kid = cUNOPo->op_first;
6086 switch (kid->op_type) {
6088 o->op_flags |= OPf_SPECIAL;
6091 o->op_private |= OPpSLICE;
6094 o->op_flags |= OPf_SPECIAL;
6099 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6108 Perl_ck_die(pTHX_ OP *o)
6111 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6117 Perl_ck_eof(pTHX_ OP *o)
6121 if (o->op_flags & OPf_KIDS) {
6122 if (cLISTOPo->op_first->op_type == OP_STUB) {
6124 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6126 op_getmad(o,newop,'O');
6138 Perl_ck_eval(pTHX_ OP *o)
6141 PL_hints |= HINT_BLOCK_SCOPE;
6142 if (o->op_flags & OPf_KIDS) {
6143 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6146 o->op_flags &= ~OPf_KIDS;
6149 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6155 cUNOPo->op_first = 0;
6160 NewOp(1101, enter, 1, LOGOP);
6161 enter->op_type = OP_ENTERTRY;
6162 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6163 enter->op_private = 0;
6165 /* establish postfix order */
6166 enter->op_next = (OP*)enter;
6168 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6169 o->op_type = OP_LEAVETRY;
6170 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6171 enter->op_other = o;
6172 op_getmad(oldo,o,'O');
6186 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6187 op_getmad(oldo,o,'O');
6189 o->op_targ = (PADOFFSET)PL_hints;
6190 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6191 /* Store a copy of %^H that pp_entereval can pick up.
6192 OPf_SPECIAL flags the opcode as being for this purpose,
6193 so that it in turn will return a copy at every
6195 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6196 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6197 cUNOPo->op_first->op_sibling = hhop;
6198 o->op_private |= OPpEVAL_HAS_HH;
6204 Perl_ck_exit(pTHX_ OP *o)
6207 HV * const table = GvHV(PL_hintgv);
6209 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6210 if (svp && *svp && SvTRUE(*svp))
6211 o->op_private |= OPpEXIT_VMSISH;
6213 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6219 Perl_ck_exec(pTHX_ OP *o)
6221 if (o->op_flags & OPf_STACKED) {
6224 kid = cUNOPo->op_first->op_sibling;
6225 if (kid->op_type == OP_RV2GV)
6234 Perl_ck_exists(pTHX_ OP *o)
6238 if (o->op_flags & OPf_KIDS) {
6239 OP * const kid = cUNOPo->op_first;
6240 if (kid->op_type == OP_ENTERSUB) {
6241 (void) ref(kid, o->op_type);
6242 if (kid->op_type != OP_RV2CV && !PL_error_count)
6243 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6245 o->op_private |= OPpEXISTS_SUB;
6247 else if (kid->op_type == OP_AELEM)
6248 o->op_flags |= OPf_SPECIAL;
6249 else if (kid->op_type != OP_HELEM)
6250 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6258 Perl_ck_rvconst(pTHX_ register OP *o)
6261 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6263 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6264 if (o->op_type == OP_RV2CV)
6265 o->op_private &= ~1;
6267 if (kid->op_type == OP_CONST) {
6270 SV * const kidsv = kid->op_sv;
6272 /* Is it a constant from cv_const_sv()? */
6273 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6274 SV * const rsv = SvRV(kidsv);
6275 const svtype type = SvTYPE(rsv);
6276 const char *badtype = NULL;
6278 switch (o->op_type) {
6280 if (type > SVt_PVMG)
6281 badtype = "a SCALAR";
6284 if (type != SVt_PVAV)
6285 badtype = "an ARRAY";
6288 if (type != SVt_PVHV)
6292 if (type != SVt_PVCV)
6297 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6300 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6301 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6302 /* If this is an access to a stash, disable "strict refs", because
6303 * stashes aren't auto-vivified at compile-time (unless we store
6304 * symbols in them), and we don't want to produce a run-time
6305 * stricture error when auto-vivifying the stash. */
6306 const char *s = SvPV_nolen(kidsv);
6307 const STRLEN l = SvCUR(kidsv);
6308 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6309 o->op_private &= ~HINT_STRICT_REFS;
6311 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6312 const char *badthing;
6313 switch (o->op_type) {
6315 badthing = "a SCALAR";
6318 badthing = "an ARRAY";
6321 badthing = "a HASH";
6329 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6330 SVfARG(kidsv), badthing);
6333 * This is a little tricky. We only want to add the symbol if we
6334 * didn't add it in the lexer. Otherwise we get duplicate strict
6335 * warnings. But if we didn't add it in the lexer, we must at
6336 * least pretend like we wanted to add it even if it existed before,
6337 * or we get possible typo warnings. OPpCONST_ENTERED says
6338 * whether the lexer already added THIS instance of this symbol.
6340 iscv = (o->op_type == OP_RV2CV) * 2;
6342 gv = gv_fetchsv(kidsv,
6343 iscv | !(kid->op_private & OPpCONST_ENTERED),
6346 : o->op_type == OP_RV2SV
6348 : o->op_type == OP_RV2AV
6350 : o->op_type == OP_RV2HV
6353 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6355 kid->op_type = OP_GV;
6356 SvREFCNT_dec(kid->op_sv);
6358 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6359 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6360 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6362 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6364 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6366 kid->op_private = 0;
6367 kid->op_ppaddr = PL_ppaddr[OP_GV];
6374 Perl_ck_ftst(pTHX_ OP *o)
6377 const I32 type = o->op_type;
6379 if (o->op_flags & OPf_REF) {
6382 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6383 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6384 const OPCODE kidtype = kid->op_type;
6386 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6387 OP * const newop = newGVOP(type, OPf_REF,
6388 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6390 op_getmad(o,newop,'O');
6396 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6397 o->op_private |= OPpFT_ACCESS;
6398 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6399 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6400 o->op_private |= OPpFT_STACKED;
6408 if (type == OP_FTTTY)
6409 o = newGVOP(type, OPf_REF, PL_stdingv);
6411 o = newUNOP(type, 0, newDEFSVOP());
6412 op_getmad(oldo,o,'O');
6418 Perl_ck_fun(pTHX_ OP *o)
6421 const int type = o->op_type;
6422 register I32 oa = PL_opargs[type] >> OASHIFT;
6424 if (o->op_flags & OPf_STACKED) {
6425 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6428 return no_fh_allowed(o);
6431 if (o->op_flags & OPf_KIDS) {
6432 OP **tokid = &cLISTOPo->op_first;
6433 register OP *kid = cLISTOPo->op_first;
6437 if (kid->op_type == OP_PUSHMARK ||
6438 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6440 tokid = &kid->op_sibling;
6441 kid = kid->op_sibling;
6443 if (!kid && PL_opargs[type] & OA_DEFGV)
6444 *tokid = kid = newDEFSVOP();
6448 sibl = kid->op_sibling;
6450 if (!sibl && kid->op_type == OP_STUB) {
6457 /* list seen where single (scalar) arg expected? */
6458 if (numargs == 1 && !(oa >> 4)
6459 && kid->op_type == OP_LIST && type != OP_SCALAR)
6461 return too_many_arguments(o,PL_op_desc[type]);
6474 if ((type == OP_PUSH || type == OP_UNSHIFT)
6475 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6476 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6477 "Useless use of %s with no values",
6480 if (kid->op_type == OP_CONST &&
6481 (kid->op_private & OPpCONST_BARE))
6483 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6484 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6485 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6486 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6487 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6488 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6490 op_getmad(kid,newop,'K');
6495 kid->op_sibling = sibl;
6498 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6499 bad_type(numargs, "array", PL_op_desc[type], kid);
6503 if (kid->op_type == OP_CONST &&
6504 (kid->op_private & OPpCONST_BARE))
6506 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6507 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6508 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6509 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6510 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6511 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6513 op_getmad(kid,newop,'K');
6518 kid->op_sibling = sibl;
6521 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6522 bad_type(numargs, "hash", PL_op_desc[type], kid);
6527 OP * const newop = newUNOP(OP_NULL, 0, kid);
6528 kid->op_sibling = 0;
6530 newop->op_next = newop;
6532 kid->op_sibling = sibl;
6537 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6538 if (kid->op_type == OP_CONST &&
6539 (kid->op_private & OPpCONST_BARE))
6541 OP * const newop = newGVOP(OP_GV, 0,
6542 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6543 if (!(o->op_private & 1) && /* if not unop */
6544 kid == cLISTOPo->op_last)
6545 cLISTOPo->op_last = newop;
6547 op_getmad(kid,newop,'K');
6553 else if (kid->op_type == OP_READLINE) {
6554 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6555 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6558 I32 flags = OPf_SPECIAL;
6562 /* is this op a FH constructor? */
6563 if (is_handle_constructor(o,numargs)) {
6564 const char *name = NULL;
6568 /* Set a flag to tell rv2gv to vivify
6569 * need to "prove" flag does not mean something
6570 * else already - NI-S 1999/05/07
6573 if (kid->op_type == OP_PADSV) {
6575 = PAD_COMPNAME_SV(kid->op_targ);
6576 name = SvPV_const(namesv, len);
6578 else if (kid->op_type == OP_RV2SV
6579 && kUNOP->op_first->op_type == OP_GV)
6581 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6583 len = GvNAMELEN(gv);
6585 else if (kid->op_type == OP_AELEM
6586 || kid->op_type == OP_HELEM)
6589 OP *op = ((BINOP*)kid)->op_first;
6593 const char * const a =
6594 kid->op_type == OP_AELEM ?
6596 if (((op->op_type == OP_RV2AV) ||
6597 (op->op_type == OP_RV2HV)) &&
6598 (firstop = ((UNOP*)op)->op_first) &&
6599 (firstop->op_type == OP_GV)) {
6600 /* packagevar $a[] or $h{} */
6601 GV * const gv = cGVOPx_gv(firstop);
6609 else if (op->op_type == OP_PADAV
6610 || op->op_type == OP_PADHV) {
6611 /* lexicalvar $a[] or $h{} */
6612 const char * const padname =
6613 PAD_COMPNAME_PV(op->op_targ);
6622 name = SvPV_const(tmpstr, len);
6627 name = "__ANONIO__";
6634 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6635 namesv = PAD_SVl(targ);
6636 SvUPGRADE(namesv, SVt_PV);
6638 sv_setpvn(namesv, "$", 1);
6639 sv_catpvn(namesv, name, len);
6642 kid->op_sibling = 0;
6643 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6644 kid->op_targ = targ;
6645 kid->op_private |= priv;
6647 kid->op_sibling = sibl;
6653 mod(scalar(kid), type);
6657 tokid = &kid->op_sibling;
6658 kid = kid->op_sibling;
6661 if (kid && kid->op_type != OP_STUB)
6662 return too_many_arguments(o,OP_DESC(o));
6663 o->op_private |= numargs;
6665 /* FIXME - should the numargs move as for the PERL_MAD case? */
6666 o->op_private |= numargs;
6668 return too_many_arguments(o,OP_DESC(o));
6672 else if (PL_opargs[type] & OA_DEFGV) {
6674 OP *newop = newUNOP(type, 0, newDEFSVOP());
6675 op_getmad(o,newop,'O');
6678 /* Ordering of these two is important to keep f_map.t passing. */
6680 return newUNOP(type, 0, newDEFSVOP());
6685 while (oa & OA_OPTIONAL)
6687 if (oa && oa != OA_LIST)
6688 return too_few_arguments(o,OP_DESC(o));
6694 Perl_ck_glob(pTHX_ OP *o)
6700 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6701 append_elem(OP_GLOB, o, newDEFSVOP());
6703 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6704 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6706 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6709 #if !defined(PERL_EXTERNAL_GLOB)
6710 /* XXX this can be tightened up and made more failsafe. */
6711 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6714 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6715 newSVpvs("File::Glob"), NULL, NULL, NULL);
6716 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6717 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6718 GvCV(gv) = GvCV(glob_gv);
6719 SvREFCNT_inc_void((SV*)GvCV(gv));
6720 GvIMPORTED_CV_on(gv);
6723 #endif /* PERL_EXTERNAL_GLOB */
6725 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6726 append_elem(OP_GLOB, o,
6727 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6728 o->op_type = OP_LIST;
6729 o->op_ppaddr = PL_ppaddr[OP_LIST];
6730 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6731 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6732 cLISTOPo->op_first->op_targ = 0;
6733 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6734 append_elem(OP_LIST, o,
6735 scalar(newUNOP(OP_RV2CV, 0,
6736 newGVOP(OP_GV, 0, gv)))));
6737 o = newUNOP(OP_NULL, 0, ck_subr(o));
6738 o->op_targ = OP_GLOB; /* hint at what it used to be */
6741 gv = newGVgen("main");
6743 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6749 Perl_ck_grep(pTHX_ OP *o)
6754 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6757 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6758 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6760 if (o->op_flags & OPf_STACKED) {
6763 kid = cLISTOPo->op_first->op_sibling;
6764 if (!cUNOPx(kid)->op_next)
6765 Perl_croak(aTHX_ "panic: ck_grep");
6766 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6769 NewOp(1101, gwop, 1, LOGOP);
6770 kid->op_next = (OP*)gwop;
6771 o->op_flags &= ~OPf_STACKED;
6773 kid = cLISTOPo->op_first->op_sibling;
6774 if (type == OP_MAPWHILE)
6781 kid = cLISTOPo->op_first->op_sibling;
6782 if (kid->op_type != OP_NULL)
6783 Perl_croak(aTHX_ "panic: ck_grep");
6784 kid = kUNOP->op_first;
6787 NewOp(1101, gwop, 1, LOGOP);
6788 gwop->op_type = type;
6789 gwop->op_ppaddr = PL_ppaddr[type];
6790 gwop->op_first = listkids(o);
6791 gwop->op_flags |= OPf_KIDS;
6792 gwop->op_other = LINKLIST(kid);
6793 kid->op_next = (OP*)gwop;
6794 offset = pad_findmy("$_");
6795 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6796 o->op_private = gwop->op_private = 0;
6797 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6800 o->op_private = gwop->op_private = OPpGREP_LEX;
6801 gwop->op_targ = o->op_targ = offset;
6804 kid = cLISTOPo->op_first->op_sibling;
6805 if (!kid || !kid->op_sibling)
6806 return too_few_arguments(o,OP_DESC(o));
6807 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6808 mod(kid, OP_GREPSTART);
6814 Perl_ck_index(pTHX_ OP *o)
6816 if (o->op_flags & OPf_KIDS) {
6817 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6819 kid = kid->op_sibling; /* get past "big" */
6820 if (kid && kid->op_type == OP_CONST)
6821 fbm_compile(((SVOP*)kid)->op_sv, 0);
6827 Perl_ck_lengthconst(pTHX_ OP *o)
6829 /* XXX length optimization goes here */
6834 Perl_ck_lfun(pTHX_ OP *o)
6836 const OPCODE type = o->op_type;
6837 return modkids(ck_fun(o), type);
6841 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6843 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6844 switch (cUNOPo->op_first->op_type) {
6846 /* This is needed for
6847 if (defined %stash::)
6848 to work. Do not break Tk.
6850 break; /* Globals via GV can be undef */
6852 case OP_AASSIGN: /* Is this a good idea? */
6853 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6854 "defined(@array) is deprecated");
6855 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6856 "\t(Maybe you should just omit the defined()?)\n");
6859 /* This is needed for
6860 if (defined %stash::)
6861 to work. Do not break Tk.
6863 break; /* Globals via GV can be undef */
6865 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6866 "defined(%%hash) is deprecated");
6867 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6868 "\t(Maybe you should just omit the defined()?)\n");
6879 Perl_ck_readline(pTHX_ OP *o)
6881 if (!(o->op_flags & OPf_KIDS)) {
6883 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6885 op_getmad(o,newop,'O');
6895 Perl_ck_rfun(pTHX_ OP *o)
6897 const OPCODE type = o->op_type;
6898 return refkids(ck_fun(o), type);
6902 Perl_ck_listiob(pTHX_ OP *o)
6906 kid = cLISTOPo->op_first;
6909 kid = cLISTOPo->op_first;
6911 if (kid->op_type == OP_PUSHMARK)
6912 kid = kid->op_sibling;
6913 if (kid && o->op_flags & OPf_STACKED)
6914 kid = kid->op_sibling;
6915 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6916 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6917 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6918 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6919 cLISTOPo->op_first->op_sibling = kid;
6920 cLISTOPo->op_last = kid;
6921 kid = kid->op_sibling;
6926 append_elem(o->op_type, o, newDEFSVOP());
6932 Perl_ck_smartmatch(pTHX_ OP *o)
6935 if (0 == (o->op_flags & OPf_SPECIAL)) {
6936 OP *first = cBINOPo->op_first;
6937 OP *second = first->op_sibling;
6939 /* Implicitly take a reference to an array or hash */
6940 first->op_sibling = NULL;
6941 first = cBINOPo->op_first = ref_array_or_hash(first);
6942 second = first->op_sibling = ref_array_or_hash(second);
6944 /* Implicitly take a reference to a regular expression */
6945 if (first->op_type == OP_MATCH) {
6946 first->op_type = OP_QR;
6947 first->op_ppaddr = PL_ppaddr[OP_QR];
6949 if (second->op_type == OP_MATCH) {
6950 second->op_type = OP_QR;
6951 second->op_ppaddr = PL_ppaddr[OP_QR];
6960 Perl_ck_sassign(pTHX_ OP *o)
6962 OP * const kid = cLISTOPo->op_first;
6963 /* has a disposable target? */
6964 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6965 && !(kid->op_flags & OPf_STACKED)
6966 /* Cannot steal the second time! */
6967 && !(kid->op_private & OPpTARGET_MY))
6969 OP * const kkid = kid->op_sibling;
6971 /* Can just relocate the target. */
6972 if (kkid && kkid->op_type == OP_PADSV
6973 && !(kkid->op_private & OPpLVAL_INTRO))
6975 kid->op_targ = kkid->op_targ;
6977 /* Now we do not need PADSV and SASSIGN. */
6978 kid->op_sibling = o->op_sibling; /* NULL */
6979 cLISTOPo->op_first = NULL;
6981 op_getmad(o,kid,'O');
6982 op_getmad(kkid,kid,'M');
6987 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6995 Perl_ck_match(pTHX_ OP *o)
6998 if (o->op_type != OP_QR && PL_compcv) {
6999 const PADOFFSET offset = pad_findmy("$_");
7000 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7001 o->op_targ = offset;
7002 o->op_private |= OPpTARGET_MY;
7005 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7006 o->op_private |= OPpRUNTIME;
7011 Perl_ck_method(pTHX_ OP *o)
7013 OP * const kid = cUNOPo->op_first;
7014 if (kid->op_type == OP_CONST) {
7015 SV* sv = kSVOP->op_sv;
7016 const char * const method = SvPVX_const(sv);
7017 if (!(strchr(method, ':') || strchr(method, '\''))) {
7019 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7020 sv = newSVpvn_share(method, SvCUR(sv), 0);
7023 kSVOP->op_sv = NULL;
7025 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7027 op_getmad(o,cmop,'O');
7038 Perl_ck_null(pTHX_ OP *o)
7040 PERL_UNUSED_CONTEXT;
7045 Perl_ck_open(pTHX_ OP *o)
7048 HV * const table = GvHV(PL_hintgv);
7050 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7052 const I32 mode = mode_from_discipline(*svp);
7053 if (mode & O_BINARY)
7054 o->op_private |= OPpOPEN_IN_RAW;
7055 else if (mode & O_TEXT)
7056 o->op_private |= OPpOPEN_IN_CRLF;
7059 svp = hv_fetchs(table, "open_OUT", FALSE);
7061 const I32 mode = mode_from_discipline(*svp);
7062 if (mode & O_BINARY)
7063 o->op_private |= OPpOPEN_OUT_RAW;
7064 else if (mode & O_TEXT)
7065 o->op_private |= OPpOPEN_OUT_CRLF;
7068 if (o->op_type == OP_BACKTICK) {
7069 if (!(o->op_flags & OPf_KIDS)) {
7070 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7072 op_getmad(o,newop,'O');
7081 /* In case of three-arg dup open remove strictness
7082 * from the last arg if it is a bareword. */
7083 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7084 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7088 if ((last->op_type == OP_CONST) && /* The bareword. */
7089 (last->op_private & OPpCONST_BARE) &&
7090 (last->op_private & OPpCONST_STRICT) &&
7091 (oa = first->op_sibling) && /* The fh. */
7092 (oa = oa->op_sibling) && /* The mode. */
7093 (oa->op_type == OP_CONST) &&
7094 SvPOK(((SVOP*)oa)->op_sv) &&
7095 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7096 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7097 (last == oa->op_sibling)) /* The bareword. */
7098 last->op_private &= ~OPpCONST_STRICT;
7104 Perl_ck_repeat(pTHX_ OP *o)
7106 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7107 o->op_private |= OPpREPEAT_DOLIST;
7108 cBINOPo->op_first = force_list(cBINOPo->op_first);
7116 Perl_ck_require(pTHX_ OP *o)
7121 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7122 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7124 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7125 SV * const sv = kid->op_sv;
7126 U32 was_readonly = SvREADONLY(sv);
7131 sv_force_normal_flags(sv, 0);
7132 assert(!SvREADONLY(sv));
7139 for (s = SvPVX(sv); *s; s++) {
7140 if (*s == ':' && s[1] == ':') {
7141 const STRLEN len = strlen(s+2)+1;
7143 Move(s+2, s+1, len, char);
7144 SvCUR_set(sv, SvCUR(sv) - 1);
7147 sv_catpvs(sv, ".pm");
7148 SvFLAGS(sv) |= was_readonly;
7152 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7153 /* handle override, if any */
7154 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7155 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7156 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7157 gv = gvp ? *gvp : NULL;
7161 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7162 OP * const kid = cUNOPo->op_first;
7165 cUNOPo->op_first = 0;
7169 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7170 append_elem(OP_LIST, kid,
7171 scalar(newUNOP(OP_RV2CV, 0,
7174 op_getmad(o,newop,'O');
7182 Perl_ck_return(pTHX_ OP *o)
7185 if (CvLVALUE(PL_compcv)) {
7187 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7188 mod(kid, OP_LEAVESUBLV);
7194 Perl_ck_select(pTHX_ OP *o)
7198 if (o->op_flags & OPf_KIDS) {
7199 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7200 if (kid && kid->op_sibling) {
7201 o->op_type = OP_SSELECT;
7202 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7204 return fold_constants(o);
7208 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7209 if (kid && kid->op_type == OP_RV2GV)
7210 kid->op_private &= ~HINT_STRICT_REFS;
7215 Perl_ck_shift(pTHX_ OP *o)
7218 const I32 type = o->op_type;
7220 if (!(o->op_flags & OPf_KIDS)) {
7222 /* FIXME - this can be refactored to reduce code in #ifdefs */
7224 OP * const oldo = o;
7228 argop = newUNOP(OP_RV2AV, 0,
7229 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7231 o = newUNOP(type, 0, scalar(argop));
7232 op_getmad(oldo,o,'O');
7235 return newUNOP(type, 0, scalar(argop));
7238 return scalar(modkids(ck_fun(o), type));
7242 Perl_ck_sort(pTHX_ OP *o)
7247 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7248 HV * const hinthv = GvHV(PL_hintgv);
7250 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7252 const I32 sorthints = (I32)SvIV(*svp);
7253 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7254 o->op_private |= OPpSORT_QSORT;
7255 if ((sorthints & HINT_SORT_STABLE) != 0)
7256 o->op_private |= OPpSORT_STABLE;
7261 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7263 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7264 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7266 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7268 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7270 if (kid->op_type == OP_SCOPE) {
7274 else if (kid->op_type == OP_LEAVE) {
7275 if (o->op_type == OP_SORT) {
7276 op_null(kid); /* wipe out leave */
7279 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7280 if (k->op_next == kid)
7282 /* don't descend into loops */
7283 else if (k->op_type == OP_ENTERLOOP
7284 || k->op_type == OP_ENTERITER)
7286 k = cLOOPx(k)->op_lastop;
7291 kid->op_next = 0; /* just disconnect the leave */
7292 k = kLISTOP->op_first;
7297 if (o->op_type == OP_SORT) {
7298 /* provide scalar context for comparison function/block */
7304 o->op_flags |= OPf_SPECIAL;
7306 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7309 firstkid = firstkid->op_sibling;
7312 /* provide list context for arguments */
7313 if (o->op_type == OP_SORT)
7320 S_simplify_sort(pTHX_ OP *o)
7323 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7328 if (!(o->op_flags & OPf_STACKED))
7330 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7331 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7332 kid = kUNOP->op_first; /* get past null */
7333 if (kid->op_type != OP_SCOPE)
7335 kid = kLISTOP->op_last; /* get past scope */
7336 switch(kid->op_type) {
7344 k = kid; /* remember this node*/
7345 if (kBINOP->op_first->op_type != OP_RV2SV)
7347 kid = kBINOP->op_first; /* get past cmp */
7348 if (kUNOP->op_first->op_type != OP_GV)
7350 kid = kUNOP->op_first; /* get past rv2sv */
7352 if (GvSTASH(gv) != PL_curstash)
7354 gvname = GvNAME(gv);
7355 if (*gvname == 'a' && gvname[1] == '\0')
7357 else if (*gvname == 'b' && gvname[1] == '\0')
7362 kid = k; /* back to cmp */
7363 if (kBINOP->op_last->op_type != OP_RV2SV)
7365 kid = kBINOP->op_last; /* down to 2nd arg */
7366 if (kUNOP->op_first->op_type != OP_GV)
7368 kid = kUNOP->op_first; /* get past rv2sv */
7370 if (GvSTASH(gv) != PL_curstash)
7372 gvname = GvNAME(gv);
7374 ? !(*gvname == 'a' && gvname[1] == '\0')
7375 : !(*gvname == 'b' && gvname[1] == '\0'))
7377 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7379 o->op_private |= OPpSORT_DESCEND;
7380 if (k->op_type == OP_NCMP)
7381 o->op_private |= OPpSORT_NUMERIC;
7382 if (k->op_type == OP_I_NCMP)
7383 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7384 kid = cLISTOPo->op_first->op_sibling;
7385 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7387 op_getmad(kid,o,'S'); /* then delete it */
7389 op_free(kid); /* then delete it */
7394 Perl_ck_split(pTHX_ OP *o)
7399 if (o->op_flags & OPf_STACKED)
7400 return no_fh_allowed(o);
7402 kid = cLISTOPo->op_first;
7403 if (kid->op_type != OP_NULL)
7404 Perl_croak(aTHX_ "panic: ck_split");
7405 kid = kid->op_sibling;
7406 op_free(cLISTOPo->op_first);
7407 cLISTOPo->op_first = kid;
7409 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7410 cLISTOPo->op_last = kid; /* There was only one element previously */
7413 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7414 OP * const sibl = kid->op_sibling;
7415 kid->op_sibling = 0;
7416 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7417 if (cLISTOPo->op_first == cLISTOPo->op_last)
7418 cLISTOPo->op_last = kid;
7419 cLISTOPo->op_first = kid;
7420 kid->op_sibling = sibl;
7423 kid->op_type = OP_PUSHRE;
7424 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7426 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7427 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7428 "Use of /g modifier is meaningless in split");
7431 if (!kid->op_sibling)
7432 append_elem(OP_SPLIT, o, newDEFSVOP());
7434 kid = kid->op_sibling;
7437 if (!kid->op_sibling)
7438 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7439 assert(kid->op_sibling);
7441 kid = kid->op_sibling;
7444 if (kid->op_sibling)
7445 return too_many_arguments(o,OP_DESC(o));
7451 Perl_ck_join(pTHX_ OP *o)
7453 const OP * const kid = cLISTOPo->op_first->op_sibling;
7454 if (kid && kid->op_type == OP_MATCH) {
7455 if (ckWARN(WARN_SYNTAX)) {
7456 const REGEXP *re = PM_GETRE(kPMOP);
7457 const char *pmstr = re ? re->precomp : "STRING";
7458 const STRLEN len = re ? re->prelen : 6;
7459 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7460 "/%.*s/ should probably be written as \"%.*s\"",
7461 (int)len, pmstr, (int)len, pmstr);
7468 Perl_ck_subr(pTHX_ OP *o)
7471 OP *prev = ((cUNOPo->op_first->op_sibling)
7472 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7473 OP *o2 = prev->op_sibling;
7475 const char *proto = NULL;
7476 const char *proto_end = NULL;
7481 I32 contextclass = 0;
7482 const char *e = NULL;
7485 o->op_private |= OPpENTERSUB_HASTARG;
7486 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7487 if (cvop->op_type == OP_RV2CV) {
7489 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7490 op_null(cvop); /* disable rv2cv */
7491 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7492 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7493 GV *gv = cGVOPx_gv(tmpop);
7496 tmpop->op_private |= OPpEARLY_CV;
7500 namegv = CvANON(cv) ? gv : CvGV(cv);
7501 proto = SvPV((SV*)cv, len);
7502 proto_end = proto + len;
7504 if (CvASSERTION(cv)) {
7505 U32 asserthints = 0;
7506 HV *const hinthv = GvHV(PL_hintgv);
7508 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7510 asserthints = SvUV(*svp);
7512 if (asserthints & HINT_ASSERTING) {
7513 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7514 o->op_private |= OPpENTERSUB_DB;
7518 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7519 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7520 "Impossible to activate assertion call");
7527 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7528 if (o2->op_type == OP_CONST)
7529 o2->op_private &= ~OPpCONST_STRICT;
7530 else if (o2->op_type == OP_LIST) {
7531 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7532 if (sib && sib->op_type == OP_CONST)
7533 sib->op_private &= ~OPpCONST_STRICT;
7536 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7537 if (PERLDB_SUB && PL_curstash != PL_debstash)
7538 o->op_private |= OPpENTERSUB_DB;
7539 while (o2 != cvop) {
7541 if (PL_madskills && o2->op_type == OP_STUB) {
7542 o2 = o2->op_sibling;
7545 if (PL_madskills && o2->op_type == OP_NULL)
7546 o3 = ((UNOP*)o2)->op_first;
7550 if (proto >= proto_end)
7551 return too_many_arguments(o, gv_ename(namegv));
7559 /* _ must be at the end */
7560 if (proto[1] && proto[1] != ';')
7575 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7577 arg == 1 ? "block or sub {}" : "sub {}",
7578 gv_ename(namegv), o3);
7581 /* '*' allows any scalar type, including bareword */
7584 if (o3->op_type == OP_RV2GV)
7585 goto wrapref; /* autoconvert GLOB -> GLOBref */
7586 else if (o3->op_type == OP_CONST)
7587 o3->op_private &= ~OPpCONST_STRICT;
7588 else if (o3->op_type == OP_ENTERSUB) {
7589 /* accidental subroutine, revert to bareword */
7590 OP *gvop = ((UNOP*)o3)->op_first;
7591 if (gvop && gvop->op_type == OP_NULL) {
7592 gvop = ((UNOP*)gvop)->op_first;
7594 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7597 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7598 (gvop = ((UNOP*)gvop)->op_first) &&
7599 gvop->op_type == OP_GV)
7601 GV * const gv = cGVOPx_gv(gvop);
7602 OP * const sibling = o2->op_sibling;
7603 SV * const n = newSVpvs("");
7605 OP * const oldo2 = o2;
7609 gv_fullname4(n, gv, "", FALSE);
7610 o2 = newSVOP(OP_CONST, 0, n);
7611 op_getmad(oldo2,o2,'O');
7612 prev->op_sibling = o2;
7613 o2->op_sibling = sibling;
7629 if (contextclass++ == 0) {
7630 e = strchr(proto, ']');
7631 if (!e || e == proto)
7640 const char *p = proto;
7641 const char *const end = proto;
7643 while (*--p != '[');
7644 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7646 gv_ename(namegv), o3);
7651 if (o3->op_type == OP_RV2GV)
7654 bad_type(arg, "symbol", gv_ename(namegv), o3);
7657 if (o3->op_type == OP_ENTERSUB)
7660 bad_type(arg, "subroutine entry", gv_ename(namegv),
7664 if (o3->op_type == OP_RV2SV ||
7665 o3->op_type == OP_PADSV ||
7666 o3->op_type == OP_HELEM ||
7667 o3->op_type == OP_AELEM)
7670 bad_type(arg, "scalar", gv_ename(namegv), o3);
7673 if (o3->op_type == OP_RV2AV ||
7674 o3->op_type == OP_PADAV)
7677 bad_type(arg, "array", gv_ename(namegv), o3);
7680 if (o3->op_type == OP_RV2HV ||
7681 o3->op_type == OP_PADHV)
7684 bad_type(arg, "hash", gv_ename(namegv), o3);
7689 OP* const sib = kid->op_sibling;
7690 kid->op_sibling = 0;
7691 o2 = newUNOP(OP_REFGEN, 0, kid);
7692 o2->op_sibling = sib;
7693 prev->op_sibling = o2;
7695 if (contextclass && e) {
7710 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7711 gv_ename(namegv), SVfARG(cv));
7716 mod(o2, OP_ENTERSUB);
7718 o2 = o2->op_sibling;
7720 if (o2 == cvop && proto && *proto == '_') {
7721 /* generate an access to $_ */
7723 o2->op_sibling = prev->op_sibling;
7724 prev->op_sibling = o2; /* instead of cvop */
7726 if (proto && !optional && proto_end > proto &&
7727 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7728 return too_few_arguments(o, gv_ename(namegv));
7731 OP * const oldo = o;
7735 o=newSVOP(OP_CONST, 0, newSViv(0));
7736 op_getmad(oldo,o,'O');
7742 Perl_ck_svconst(pTHX_ OP *o)
7744 PERL_UNUSED_CONTEXT;
7745 SvREADONLY_on(cSVOPo->op_sv);
7750 Perl_ck_chdir(pTHX_ OP *o)
7752 if (o->op_flags & OPf_KIDS) {
7753 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7755 if (kid && kid->op_type == OP_CONST &&
7756 (kid->op_private & OPpCONST_BARE))
7758 o->op_flags |= OPf_SPECIAL;
7759 kid->op_private &= ~OPpCONST_STRICT;
7766 Perl_ck_trunc(pTHX_ OP *o)
7768 if (o->op_flags & OPf_KIDS) {
7769 SVOP *kid = (SVOP*)cUNOPo->op_first;
7771 if (kid->op_type == OP_NULL)
7772 kid = (SVOP*)kid->op_sibling;
7773 if (kid && kid->op_type == OP_CONST &&
7774 (kid->op_private & OPpCONST_BARE))
7776 o->op_flags |= OPf_SPECIAL;
7777 kid->op_private &= ~OPpCONST_STRICT;
7784 Perl_ck_unpack(pTHX_ OP *o)
7786 OP *kid = cLISTOPo->op_first;
7787 if (kid->op_sibling) {
7788 kid = kid->op_sibling;
7789 if (!kid->op_sibling)
7790 kid->op_sibling = newDEFSVOP();
7796 Perl_ck_substr(pTHX_ OP *o)
7799 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7800 OP *kid = cLISTOPo->op_first;
7802 if (kid->op_type == OP_NULL)
7803 kid = kid->op_sibling;
7805 kid->op_flags |= OPf_MOD;
7811 /* A peephole optimizer. We visit the ops in the order they're to execute.
7812 * See the comments at the top of this file for more details about when
7813 * peep() is called */
7816 Perl_peep(pTHX_ register OP *o)
7819 register OP* oldop = NULL;
7821 if (!o || o->op_opt)
7825 SAVEVPTR(PL_curcop);
7826 for (; o; o = o->op_next) {
7829 /* By default, this op has now been optimised. A couple of cases below
7830 clear this again. */
7833 switch (o->op_type) {
7837 PL_curcop = ((COP*)o); /* for warnings */
7841 if (cSVOPo->op_private & OPpCONST_STRICT)
7842 no_bareword_allowed(o);
7844 case OP_METHOD_NAMED:
7845 /* Relocate sv to the pad for thread safety.
7846 * Despite being a "constant", the SV is written to,
7847 * for reference counts, sv_upgrade() etc. */
7849 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7850 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7851 /* If op_sv is already a PADTMP then it is being used by
7852 * some pad, so make a copy. */
7853 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7854 SvREADONLY_on(PAD_SVl(ix));
7855 SvREFCNT_dec(cSVOPo->op_sv);
7857 else if (o->op_type == OP_CONST
7858 && cSVOPo->op_sv == &PL_sv_undef) {
7859 /* PL_sv_undef is hack - it's unsafe to store it in the
7860 AV that is the pad, because av_fetch treats values of
7861 PL_sv_undef as a "free" AV entry and will merrily
7862 replace them with a new SV, causing pad_alloc to think
7863 that this pad slot is free. (When, clearly, it is not)
7865 SvOK_off(PAD_SVl(ix));
7866 SvPADTMP_on(PAD_SVl(ix));
7867 SvREADONLY_on(PAD_SVl(ix));
7870 SvREFCNT_dec(PAD_SVl(ix));
7871 SvPADTMP_on(cSVOPo->op_sv);
7872 PAD_SETSV(ix, cSVOPo->op_sv);
7873 /* XXX I don't know how this isn't readonly already. */
7874 SvREADONLY_on(PAD_SVl(ix));
7876 cSVOPo->op_sv = NULL;
7883 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7884 if (o->op_next->op_private & OPpTARGET_MY) {
7885 if (o->op_flags & OPf_STACKED) /* chained concats */
7886 break; /* ignore_optimization */
7888 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7889 o->op_targ = o->op_next->op_targ;
7890 o->op_next->op_targ = 0;
7891 o->op_private |= OPpTARGET_MY;
7894 op_null(o->op_next);
7898 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7899 break; /* Scalar stub must produce undef. List stub is noop */
7903 if (o->op_targ == OP_NEXTSTATE
7904 || o->op_targ == OP_DBSTATE
7905 || o->op_targ == OP_SETSTATE)
7907 PL_curcop = ((COP*)o);
7909 /* XXX: We avoid setting op_seq here to prevent later calls
7910 to peep() from mistakenly concluding that optimisation
7911 has already occurred. This doesn't fix the real problem,
7912 though (See 20010220.007). AMS 20010719 */
7913 /* op_seq functionality is now replaced by op_opt */
7920 if (oldop && o->op_next) {
7921 oldop->op_next = o->op_next;
7929 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7930 OP* const pop = (o->op_type == OP_PADAV) ?
7931 o->op_next : o->op_next->op_next;
7933 if (pop && pop->op_type == OP_CONST &&
7934 ((PL_op = pop->op_next)) &&
7935 pop->op_next->op_type == OP_AELEM &&
7936 !(pop->op_next->op_private &
7937 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7938 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7943 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7944 no_bareword_allowed(pop);
7945 if (o->op_type == OP_GV)
7946 op_null(o->op_next);
7947 op_null(pop->op_next);
7949 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7950 o->op_next = pop->op_next->op_next;
7951 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7952 o->op_private = (U8)i;
7953 if (o->op_type == OP_GV) {
7958 o->op_flags |= OPf_SPECIAL;
7959 o->op_type = OP_AELEMFAST;
7964 if (o->op_next->op_type == OP_RV2SV) {
7965 if (!(o->op_next->op_private & OPpDEREF)) {
7966 op_null(o->op_next);
7967 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7969 o->op_next = o->op_next->op_next;
7970 o->op_type = OP_GVSV;
7971 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7974 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7975 GV * const gv = cGVOPo_gv;
7976 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7977 /* XXX could check prototype here instead of just carping */
7978 SV * const sv = sv_newmortal();
7979 gv_efullname3(sv, gv, NULL);
7980 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7981 "%"SVf"() called too early to check prototype",
7985 else if (o->op_next->op_type == OP_READLINE
7986 && o->op_next->op_next->op_type == OP_CONCAT
7987 && (o->op_next->op_next->op_flags & OPf_STACKED))
7989 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7990 o->op_type = OP_RCATLINE;
7991 o->op_flags |= OPf_STACKED;
7992 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7993 op_null(o->op_next->op_next);
7994 op_null(o->op_next);
8009 while (cLOGOP->op_other->op_type == OP_NULL)
8010 cLOGOP->op_other = cLOGOP->op_other->op_next;
8011 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8016 while (cLOOP->op_redoop->op_type == OP_NULL)
8017 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8018 peep(cLOOP->op_redoop);
8019 while (cLOOP->op_nextop->op_type == OP_NULL)
8020 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8021 peep(cLOOP->op_nextop);
8022 while (cLOOP->op_lastop->op_type == OP_NULL)
8023 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8024 peep(cLOOP->op_lastop);
8028 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8029 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8030 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8031 cPMOP->op_pmstashstartu.op_pmreplstart
8032 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8033 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8037 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8038 && ckWARN(WARN_SYNTAX))
8040 if (o->op_next->op_sibling) {
8041 const OPCODE type = o->op_next->op_sibling->op_type;
8042 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8043 const line_t oldline = CopLINE(PL_curcop);
8044 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8045 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8046 "Statement unlikely to be reached");
8047 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8048 "\t(Maybe you meant system() when you said exec()?)\n");
8049 CopLINE_set(PL_curcop, oldline);
8060 const char *key = NULL;
8063 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8066 /* Make the CONST have a shared SV */
8067 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8068 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8069 key = SvPV_const(sv, keylen);
8070 lexname = newSVpvn_share(key,
8071 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8077 if ((o->op_private & (OPpLVAL_INTRO)))
8080 rop = (UNOP*)((BINOP*)o)->op_first;
8081 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8083 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8084 if (!SvPAD_TYPED(lexname))
8086 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8087 if (!fields || !GvHV(*fields))
8089 key = SvPV_const(*svp, keylen);
8090 if (!hv_fetch(GvHV(*fields), key,
8091 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8093 Perl_croak(aTHX_ "No such class field \"%s\" "
8094 "in variable %s of type %s",
8095 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8108 SVOP *first_key_op, *key_op;
8110 if ((o->op_private & (OPpLVAL_INTRO))
8111 /* I bet there's always a pushmark... */
8112 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8113 /* hmmm, no optimization if list contains only one key. */
8115 rop = (UNOP*)((LISTOP*)o)->op_last;
8116 if (rop->op_type != OP_RV2HV)
8118 if (rop->op_first->op_type == OP_PADSV)
8119 /* @$hash{qw(keys here)} */
8120 rop = (UNOP*)rop->op_first;
8122 /* @{$hash}{qw(keys here)} */
8123 if (rop->op_first->op_type == OP_SCOPE
8124 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8126 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8132 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8133 if (!SvPAD_TYPED(lexname))
8135 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8136 if (!fields || !GvHV(*fields))
8138 /* Again guessing that the pushmark can be jumped over.... */
8139 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8140 ->op_first->op_sibling;
8141 for (key_op = first_key_op; key_op;
8142 key_op = (SVOP*)key_op->op_sibling) {
8143 if (key_op->op_type != OP_CONST)
8145 svp = cSVOPx_svp(key_op);
8146 key = SvPV_const(*svp, keylen);
8147 if (!hv_fetch(GvHV(*fields), key,
8148 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8150 Perl_croak(aTHX_ "No such class field \"%s\" "
8151 "in variable %s of type %s",
8152 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8159 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8163 /* check that RHS of sort is a single plain array */
8164 OP *oright = cUNOPo->op_first;
8165 if (!oright || oright->op_type != OP_PUSHMARK)
8168 /* reverse sort ... can be optimised. */
8169 if (!cUNOPo->op_sibling) {
8170 /* Nothing follows us on the list. */
8171 OP * const reverse = o->op_next;
8173 if (reverse->op_type == OP_REVERSE &&
8174 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8175 OP * const pushmark = cUNOPx(reverse)->op_first;
8176 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8177 && (cUNOPx(pushmark)->op_sibling == o)) {
8178 /* reverse -> pushmark -> sort */
8179 o->op_private |= OPpSORT_REVERSE;
8181 pushmark->op_next = oright->op_next;
8187 /* make @a = sort @a act in-place */
8189 oright = cUNOPx(oright)->op_sibling;
8192 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8193 oright = cUNOPx(oright)->op_sibling;
8197 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8198 || oright->op_next != o
8199 || (oright->op_private & OPpLVAL_INTRO)
8203 /* o2 follows the chain of op_nexts through the LHS of the
8204 * assign (if any) to the aassign op itself */
8206 if (!o2 || o2->op_type != OP_NULL)
8209 if (!o2 || o2->op_type != OP_PUSHMARK)
8212 if (o2 && o2->op_type == OP_GV)
8215 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8216 || (o2->op_private & OPpLVAL_INTRO)
8221 if (!o2 || o2->op_type != OP_NULL)
8224 if (!o2 || o2->op_type != OP_AASSIGN
8225 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8228 /* check that the sort is the first arg on RHS of assign */
8230 o2 = cUNOPx(o2)->op_first;
8231 if (!o2 || o2->op_type != OP_NULL)
8233 o2 = cUNOPx(o2)->op_first;
8234 if (!o2 || o2->op_type != OP_PUSHMARK)
8236 if (o2->op_sibling != o)
8239 /* check the array is the same on both sides */
8240 if (oleft->op_type == OP_RV2AV) {
8241 if (oright->op_type != OP_RV2AV
8242 || !cUNOPx(oright)->op_first
8243 || cUNOPx(oright)->op_first->op_type != OP_GV
8244 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8245 cGVOPx_gv(cUNOPx(oright)->op_first)
8249 else if (oright->op_type != OP_PADAV
8250 || oright->op_targ != oleft->op_targ
8254 /* transfer MODishness etc from LHS arg to RHS arg */
8255 oright->op_flags = oleft->op_flags;
8256 o->op_private |= OPpSORT_INPLACE;
8258 /* excise push->gv->rv2av->null->aassign */
8259 o2 = o->op_next->op_next;
8260 op_null(o2); /* PUSHMARK */
8262 if (o2->op_type == OP_GV) {
8263 op_null(o2); /* GV */
8266 op_null(o2); /* RV2AV or PADAV */
8267 o2 = o2->op_next->op_next;
8268 op_null(o2); /* AASSIGN */
8270 o->op_next = o2->op_next;
8276 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8278 LISTOP *enter, *exlist;
8280 enter = (LISTOP *) o->op_next;
8283 if (enter->op_type == OP_NULL) {
8284 enter = (LISTOP *) enter->op_next;
8288 /* for $a (...) will have OP_GV then OP_RV2GV here.
8289 for (...) just has an OP_GV. */
8290 if (enter->op_type == OP_GV) {
8291 gvop = (OP *) enter;
8292 enter = (LISTOP *) enter->op_next;
8295 if (enter->op_type == OP_RV2GV) {
8296 enter = (LISTOP *) enter->op_next;
8302 if (enter->op_type != OP_ENTERITER)
8305 iter = enter->op_next;
8306 if (!iter || iter->op_type != OP_ITER)
8309 expushmark = enter->op_first;
8310 if (!expushmark || expushmark->op_type != OP_NULL
8311 || expushmark->op_targ != OP_PUSHMARK)
8314 exlist = (LISTOP *) expushmark->op_sibling;
8315 if (!exlist || exlist->op_type != OP_NULL
8316 || exlist->op_targ != OP_LIST)
8319 if (exlist->op_last != o) {
8320 /* Mmm. Was expecting to point back to this op. */
8323 theirmark = exlist->op_first;
8324 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8327 if (theirmark->op_sibling != o) {
8328 /* There's something between the mark and the reverse, eg
8329 for (1, reverse (...))
8334 ourmark = ((LISTOP *)o)->op_first;
8335 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8338 ourlast = ((LISTOP *)o)->op_last;
8339 if (!ourlast || ourlast->op_next != o)
8342 rv2av = ourmark->op_sibling;
8343 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8344 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8345 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8346 /* We're just reversing a single array. */
8347 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8348 enter->op_flags |= OPf_STACKED;
8351 /* We don't have control over who points to theirmark, so sacrifice
8353 theirmark->op_next = ourmark->op_next;
8354 theirmark->op_flags = ourmark->op_flags;
8355 ourlast->op_next = gvop ? gvop : (OP *) enter;
8358 enter->op_private |= OPpITER_REVERSED;
8359 iter->op_private |= OPpITER_REVERSED;
8366 UNOP *refgen, *rv2cv;
8369 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8372 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8375 rv2gv = ((BINOP *)o)->op_last;
8376 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8379 refgen = (UNOP *)((BINOP *)o)->op_first;
8381 if (!refgen || refgen->op_type != OP_REFGEN)
8384 exlist = (LISTOP *)refgen->op_first;
8385 if (!exlist || exlist->op_type != OP_NULL
8386 || exlist->op_targ != OP_LIST)
8389 if (exlist->op_first->op_type != OP_PUSHMARK)
8392 rv2cv = (UNOP*)exlist->op_last;
8394 if (rv2cv->op_type != OP_RV2CV)
8397 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8398 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8399 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8401 o->op_private |= OPpASSIGN_CV_TO_GV;
8402 rv2gv->op_private |= OPpDONT_INIT_GV;
8403 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8411 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8412 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8422 Perl_custom_op_name(pTHX_ const OP* o)
8425 const IV index = PTR2IV(o->op_ppaddr);
8429 if (!PL_custom_op_names) /* This probably shouldn't happen */
8430 return (char *)PL_op_name[OP_CUSTOM];
8432 keysv = sv_2mortal(newSViv(index));
8434 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8436 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8438 return SvPV_nolen(HeVAL(he));
8442 Perl_custom_op_desc(pTHX_ const OP* o)
8445 const IV index = PTR2IV(o->op_ppaddr);
8449 if (!PL_custom_op_descs)
8450 return (char *)PL_op_desc[OP_CUSTOM];
8452 keysv = sv_2mortal(newSViv(index));
8454 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8456 return (char *)PL_op_desc[OP_CUSTOM];
8458 return SvPV_nolen(HeVAL(he));
8463 /* Efficient sub that returns a constant scalar value. */
8465 const_sv_xsub(pTHX_ CV* cv)
8472 Perl_croak(aTHX_ "usage: %s::%s()",
8473 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8477 ST(0) = (SV*)XSANY.any_ptr;
8483 * c-indentation-style: bsd
8485 * indent-tabs-mode: t
8488 * ex: set ts=8 sts=4 sw=4 noet: