3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifdef PERL_DEBUG_READONLY_OPS
108 # define PERL_SLAB_SIZE 4096
109 # include <sys/mman.h>
112 #ifndef PERL_SLAB_SIZE
113 #define PERL_SLAB_SIZE 2048
117 Perl_Slab_Alloc(pTHX_ size_t sz)
120 * To make incrementing use count easy PL_OpSlab is an I32 *
121 * To make inserting the link to slab PL_OpPtr is I32 **
122 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
123 * Add an overhead for pointer to slab and round up as a number of pointers
125 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
126 if ((PL_OpSpace -= sz) < 0) {
127 #ifdef PERL_DEBUG_READONLY_OPS
128 /* We need to allocate chunk by chunk so that we can control the VM
130 PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
131 MAP_ANON|MAP_PRIVATE, -1, 0);
133 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
134 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
136 if(PL_OpPtr == MAP_FAILED) {
137 perror("mmap failed");
142 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
147 /* We reserve the 0'th I32 sized chunk as a use count */
148 PL_OpSlab = (I32 *) PL_OpPtr;
149 /* Reduce size by the use count word, and by the size we need.
150 * Latter is to mimic the '-=' in the if() above
152 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
153 /* Allocation pointer starts at the top.
154 Theory: because we build leaves before trunk allocating at end
155 means that at run time access is cache friendly upward
157 PL_OpPtr += PERL_SLAB_SIZE;
159 #ifdef PERL_DEBUG_READONLY_OPS
160 /* We remember this slab. */
161 /* This implementation isn't efficient, but it is simple. */
162 PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
163 PL_slabs[PL_slab_count++] = PL_OpSlab;
164 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
167 assert( PL_OpSpace >= 0 );
168 /* Move the allocation pointer down */
170 assert( PL_OpPtr > (I32 **) PL_OpSlab );
171 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
172 (*PL_OpSlab)++; /* Increment use count of slab */
173 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
174 assert( *PL_OpSlab > 0 );
175 return (void *)(PL_OpPtr + 1);
178 #ifdef PERL_DEBUG_READONLY_OPS
180 Perl_pending_Slabs_to_ro(pTHX) {
181 /* Turn all the allocated op slabs read only. */
182 U32 count = PL_slab_count;
183 I32 **const slabs = PL_slabs;
185 /* Reset the array of pending OP slabs, as we're about to turn this lot
186 read only. Also, do it ahead of the loop in case the warn triggers,
187 and a warn handler has an eval */
193 /* Force a new slab for any further allocation. */
197 const void *start = slabs[count];
198 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
199 if(mprotect(start, size, PROT_READ)) {
200 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
201 start, (unsigned long) size, errno);
207 S_Slab_to_rw(pTHX_ void *op)
209 I32 * const * const ptr = (I32 **) op;
210 I32 * const slab = ptr[-1];
211 assert( ptr-1 > (I32 **) slab );
212 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
214 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
215 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
216 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
221 Perl_op_refcnt_inc(pTHX_ OP *o)
232 Perl_op_refcnt_dec(pTHX_ OP *o)
238 # define Slab_to_rw(op)
242 Perl_Slab_Free(pTHX_ void *op)
244 I32 * const * const ptr = (I32 **) op;
245 I32 * const slab = ptr[-1];
246 assert( ptr-1 > (I32 **) slab );
247 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
250 if (--(*slab) == 0) {
252 # define PerlMemShared PerlMem
255 #ifdef PERL_DEBUG_READONLY_OPS
256 U32 count = PL_slab_count;
257 /* Need to remove this slab from our list of slabs */
260 if (PL_slabs[count] == slab) {
261 /* Found it. Move the entry at the end to overwrite it. */
262 DEBUG_m(PerlIO_printf(Perl_debug_log,
263 "Deallocate %p by moving %p from %lu to %lu\n",
265 PL_slabs[PL_slab_count - 1],
266 PL_slab_count, count));
267 PL_slabs[count] = PL_slabs[--PL_slab_count];
268 /* Could realloc smaller at this point, but probably not
270 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
271 perror("munmap failed");
279 PerlMemShared_free(slab);
281 if (slab == PL_OpSlab) {
288 * In the following definition, the ", (OP*)0" is just to make the compiler
289 * think the expression is of the right type: croak actually does a Siglongjmp.
291 #define CHECKOP(type,o) \
292 ((PL_op_mask && PL_op_mask[type]) \
293 ? ( op_free((OP*)o), \
294 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
296 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
298 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
301 S_gv_ename(pTHX_ GV *gv)
303 SV* const tmpsv = sv_newmortal();
304 gv_efullname3(tmpsv, gv, NULL);
305 return SvPV_nolen_const(tmpsv);
309 S_no_fh_allowed(pTHX_ OP *o)
311 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
317 S_too_few_arguments(pTHX_ OP *o, const char *name)
319 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
324 S_too_many_arguments(pTHX_ OP *o, const char *name)
326 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
331 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
333 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
334 (int)n, name, t, OP_DESC(kid)));
338 S_no_bareword_allowed(pTHX_ const OP *o)
341 return; /* various ok barewords are hidden in extra OP_NULL */
342 qerror(Perl_mess(aTHX_
343 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
347 /* "register" allocation */
350 Perl_allocmy(pTHX_ const char *const name)
354 const bool is_our = (PL_in_my == KEY_our);
356 /* complain about "my $<special_var>" etc etc */
360 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
361 (name[1] == '_' && (*name == '$' || name[2]))))
363 /* name[2] is true if strlen(name) > 2 */
364 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
365 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
366 name[0], toCTRL(name[1]), name + 2));
368 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
372 /* check for duplicate declaration */
373 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
375 if (PL_in_my_stash && *name != '$') {
376 yyerror(Perl_form(aTHX_
377 "Can't declare class for non-scalar %s in \"%s\"",
379 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
382 /* allocate a spare slot and store the name in that slot */
384 off = pad_add_name(name,
387 /* $_ is always in main::, even with our */
388 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
392 PL_in_my == KEY_state
397 /* free the body of an op without examining its contents.
398 * Always use this rather than FreeOp directly */
401 S_op_destroy(pTHX_ OP *o)
403 if (o->op_latefree) {
411 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
413 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
419 Perl_op_free(pTHX_ OP *o)
424 if (!o || o->op_static)
426 if (o->op_latefreed) {
433 if (o->op_private & OPpREFCOUNTED) {
444 refcnt = OpREFCNT_dec(o);
447 /* Need to find and remove any pattern match ops from the list
448 we maintain for reset(). */
449 find_and_forget_pmops(o);
459 if (o->op_flags & OPf_KIDS) {
460 register OP *kid, *nextkid;
461 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
462 nextkid = kid->op_sibling; /* Get before next freeing kid */
467 type = (OPCODE)o->op_targ;
469 #ifdef PERL_DEBUG_READONLY_OPS
473 /* COP* is not cleared by op_clear() so that we may track line
474 * numbers etc even after null() */
475 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
480 if (o->op_latefree) {
486 #ifdef DEBUG_LEAKING_SCALARS
493 Perl_op_clear(pTHX_ OP *o)
498 /* if (o->op_madprop && o->op_madprop->mad_next)
500 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
501 "modification of a read only value" for a reason I can't fathom why.
502 It's the "" stringification of $_, where $_ was set to '' in a foreach
503 loop, but it defies simplification into a small test case.
504 However, commenting them out has caused ext/List/Util/t/weak.t to fail
507 mad_free(o->op_madprop);
513 switch (o->op_type) {
514 case OP_NULL: /* Was holding old type, if any. */
515 if (PL_madskills && o->op_targ != OP_NULL) {
516 o->op_type = o->op_targ;
520 case OP_ENTEREVAL: /* Was holding hints. */
524 if (!(o->op_flags & OPf_REF)
525 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
531 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
532 /* not an OP_PADAV replacement */
534 if (cPADOPo->op_padix > 0) {
535 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
536 * may still exist on the pad */
537 pad_swipe(cPADOPo->op_padix, TRUE);
538 cPADOPo->op_padix = 0;
541 SvREFCNT_dec(cSVOPo->op_sv);
542 cSVOPo->op_sv = NULL;
546 case OP_METHOD_NAMED:
548 SvREFCNT_dec(cSVOPo->op_sv);
549 cSVOPo->op_sv = NULL;
552 Even if op_clear does a pad_free for the target of the op,
553 pad_free doesn't actually remove the sv that exists in the pad;
554 instead it lives on. This results in that it could be reused as
555 a target later on when the pad was reallocated.
558 pad_swipe(o->op_targ,1);
567 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
571 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
573 if (cPADOPo->op_padix > 0) {
574 pad_swipe(cPADOPo->op_padix, TRUE);
575 cPADOPo->op_padix = 0;
578 SvREFCNT_dec(cSVOPo->op_sv);
579 cSVOPo->op_sv = NULL;
583 PerlMemShared_free(cPVOPo->op_pv);
584 cPVOPo->op_pv = NULL;
588 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
592 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
593 /* No GvIN_PAD_off here, because other references may still
594 * exist on the pad */
595 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
598 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
604 forget_pmop(cPMOPo, 1);
605 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
606 /* we use the "SAFE" version of the PM_ macros here
607 * since sv_clean_all might release some PMOPs
608 * after PL_regex_padav has been cleared
609 * and the clearing of PL_regex_padav needs to
610 * happen before sv_clean_all
612 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
613 PM_SETRE_SAFE(cPMOPo, NULL);
615 if(PL_regex_pad) { /* We could be in destruction */
616 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
617 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
618 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
619 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
626 if (o->op_targ > 0) {
627 pad_free(o->op_targ);
633 S_cop_free(pTHX_ COP* cop)
638 if (! specialWARN(cop->cop_warnings))
639 PerlMemShared_free(cop->cop_warnings);
640 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
644 S_forget_pmop(pTHX_ PMOP *const o
650 HV * const pmstash = PmopSTASH(o);
651 if (pmstash && !SvIS_FREED(pmstash)) {
652 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
654 PMOP **const array = (PMOP**) mg->mg_ptr;
655 U32 count = mg->mg_len / sizeof(PMOP**);
660 /* Found it. Move the entry at the end to overwrite it. */
661 array[i] = array[--count];
662 mg->mg_len = count * sizeof(PMOP**);
663 /* Could realloc smaller at this point always, but probably
664 not worth it. Probably worth free()ing if we're the
667 Safefree(mg->mg_ptr);
684 S_find_and_forget_pmops(pTHX_ OP *o)
686 if (o->op_flags & OPf_KIDS) {
687 OP *kid = cUNOPo->op_first;
689 switch (kid->op_type) {
694 forget_pmop((PMOP*)kid, 0);
696 find_and_forget_pmops(kid);
697 kid = kid->op_sibling;
703 Perl_op_null(pTHX_ OP *o)
706 if (o->op_type == OP_NULL)
710 o->op_targ = o->op_type;
711 o->op_type = OP_NULL;
712 o->op_ppaddr = PL_ppaddr[OP_NULL];
716 Perl_op_refcnt_lock(pTHX)
724 Perl_op_refcnt_unlock(pTHX)
731 /* Contextualizers */
733 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
736 Perl_linklist(pTHX_ OP *o)
743 /* establish postfix order */
744 first = cUNOPo->op_first;
747 o->op_next = LINKLIST(first);
750 if (kid->op_sibling) {
751 kid->op_next = LINKLIST(kid->op_sibling);
752 kid = kid->op_sibling;
766 Perl_scalarkids(pTHX_ OP *o)
768 if (o && o->op_flags & OPf_KIDS) {
770 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
777 S_scalarboolean(pTHX_ OP *o)
780 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
781 if (ckWARN(WARN_SYNTAX)) {
782 const line_t oldline = CopLINE(PL_curcop);
784 if (PL_copline != NOLINE)
785 CopLINE_set(PL_curcop, PL_copline);
786 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
787 CopLINE_set(PL_curcop, oldline);
794 Perl_scalar(pTHX_ OP *o)
799 /* assumes no premature commitment */
800 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
801 || o->op_type == OP_RETURN)
806 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
808 switch (o->op_type) {
810 scalar(cBINOPo->op_first);
815 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
819 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
820 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
821 deprecate_old("implicit split to @_");
829 if (o->op_flags & OPf_KIDS) {
830 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
836 kid = cLISTOPo->op_first;
838 while ((kid = kid->op_sibling)) {
844 PL_curcop = &PL_compiling;
849 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
855 PL_curcop = &PL_compiling;
858 if (ckWARN(WARN_VOID))
859 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
865 Perl_scalarvoid(pTHX_ OP *o)
869 const char* useless = NULL;
873 /* trailing mad null ops don't count as "there" for void processing */
875 o->op_type != OP_NULL &&
877 o->op_sibling->op_type == OP_NULL)
880 for (sib = o->op_sibling;
881 sib && sib->op_type == OP_NULL;
882 sib = sib->op_sibling) ;
888 if (o->op_type == OP_NEXTSTATE
889 || o->op_type == OP_SETSTATE
890 || o->op_type == OP_DBSTATE
891 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
892 || o->op_targ == OP_SETSTATE
893 || o->op_targ == OP_DBSTATE)))
894 PL_curcop = (COP*)o; /* for warning below */
896 /* assumes no premature commitment */
897 want = o->op_flags & OPf_WANT;
898 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
899 || o->op_type == OP_RETURN)
904 if ((o->op_private & OPpTARGET_MY)
905 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
907 return scalar(o); /* As if inside SASSIGN */
910 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
912 switch (o->op_type) {
914 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
918 if (o->op_flags & OPf_STACKED)
922 if (o->op_private == 4)
994 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
995 useless = OP_DESC(o);
999 kid = cUNOPo->op_first;
1000 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1001 kid->op_type != OP_TRANS) {
1004 useless = "negative pattern binding (!~)";
1011 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1012 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1013 useless = "a variable";
1018 if (cSVOPo->op_private & OPpCONST_STRICT)
1019 no_bareword_allowed(o);
1021 if (ckWARN(WARN_VOID)) {
1022 useless = "a constant";
1023 if (o->op_private & OPpCONST_ARYBASE)
1025 /* don't warn on optimised away booleans, eg
1026 * use constant Foo, 5; Foo || print; */
1027 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1029 /* the constants 0 and 1 are permitted as they are
1030 conventionally used as dummies in constructs like
1031 1 while some_condition_with_side_effects; */
1032 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1034 else if (SvPOK(sv)) {
1035 /* perl4's way of mixing documentation and code
1036 (before the invention of POD) was based on a
1037 trick to mix nroff and perl code. The trick was
1038 built upon these three nroff macros being used in
1039 void context. The pink camel has the details in
1040 the script wrapman near page 319. */
1041 const char * const maybe_macro = SvPVX_const(sv);
1042 if (strnEQ(maybe_macro, "di", 2) ||
1043 strnEQ(maybe_macro, "ds", 2) ||
1044 strnEQ(maybe_macro, "ig", 2))
1049 op_null(o); /* don't execute or even remember it */
1053 o->op_type = OP_PREINC; /* pre-increment is faster */
1054 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1058 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1059 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1063 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1064 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1068 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1069 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1078 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1083 if (o->op_flags & OPf_STACKED)
1090 if (!(o->op_flags & OPf_KIDS))
1101 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1108 /* all requires must return a boolean value */
1109 o->op_flags &= ~OPf_WANT;
1114 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1115 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1116 deprecate_old("implicit split to @_");
1120 if (useless && ckWARN(WARN_VOID))
1121 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1126 Perl_listkids(pTHX_ OP *o)
1128 if (o && o->op_flags & OPf_KIDS) {
1130 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1137 Perl_list(pTHX_ OP *o)
1142 /* assumes no premature commitment */
1143 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1144 || o->op_type == OP_RETURN)
1149 if ((o->op_private & OPpTARGET_MY)
1150 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1152 return o; /* As if inside SASSIGN */
1155 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1157 switch (o->op_type) {
1160 list(cBINOPo->op_first);
1165 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1173 if (!(o->op_flags & OPf_KIDS))
1175 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1176 list(cBINOPo->op_first);
1177 return gen_constant_list(o);
1184 kid = cLISTOPo->op_first;
1186 while ((kid = kid->op_sibling)) {
1187 if (kid->op_sibling)
1192 PL_curcop = &PL_compiling;
1196 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1197 if (kid->op_sibling)
1202 PL_curcop = &PL_compiling;
1205 /* all requires must return a boolean value */
1206 o->op_flags &= ~OPf_WANT;
1213 Perl_scalarseq(pTHX_ OP *o)
1217 const OPCODE type = o->op_type;
1219 if (type == OP_LINESEQ || type == OP_SCOPE ||
1220 type == OP_LEAVE || type == OP_LEAVETRY)
1223 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1224 if (kid->op_sibling) {
1228 PL_curcop = &PL_compiling;
1230 o->op_flags &= ~OPf_PARENS;
1231 if (PL_hints & HINT_BLOCK_SCOPE)
1232 o->op_flags |= OPf_PARENS;
1235 o = newOP(OP_STUB, 0);
1240 S_modkids(pTHX_ OP *o, I32 type)
1242 if (o && o->op_flags & OPf_KIDS) {
1244 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1250 /* Propagate lvalue ("modifiable") context to an op and its children.
1251 * 'type' represents the context type, roughly based on the type of op that
1252 * would do the modifying, although local() is represented by OP_NULL.
1253 * It's responsible for detecting things that can't be modified, flag
1254 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1255 * might have to vivify a reference in $x), and so on.
1257 * For example, "$a+1 = 2" would cause mod() to be called with o being
1258 * OP_ADD and type being OP_SASSIGN, and would output an error.
1262 Perl_mod(pTHX_ OP *o, I32 type)
1266 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1269 if (!o || PL_error_count)
1272 if ((o->op_private & OPpTARGET_MY)
1273 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1278 switch (o->op_type) {
1284 if (!(o->op_private & OPpCONST_ARYBASE))
1287 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1288 CopARYBASE_set(&PL_compiling,
1289 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1293 SAVECOPARYBASE(&PL_compiling);
1294 CopARYBASE_set(&PL_compiling, 0);
1296 else if (type == OP_REFGEN)
1299 Perl_croak(aTHX_ "That use of $[ is unsupported");
1302 if (o->op_flags & OPf_PARENS || PL_madskills)
1306 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1307 !(o->op_flags & OPf_STACKED)) {
1308 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1309 /* The default is to set op_private to the number of children,
1310 which for a UNOP such as RV2CV is always 1. And w're using
1311 the bit for a flag in RV2CV, so we need it clear. */
1312 o->op_private &= ~1;
1313 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1314 assert(cUNOPo->op_first->op_type == OP_NULL);
1315 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1318 else if (o->op_private & OPpENTERSUB_NOMOD)
1320 else { /* lvalue subroutine call */
1321 o->op_private |= OPpLVAL_INTRO;
1322 PL_modcount = RETURN_UNLIMITED_NUMBER;
1323 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1324 /* Backward compatibility mode: */
1325 o->op_private |= OPpENTERSUB_INARGS;
1328 else { /* Compile-time error message: */
1329 OP *kid = cUNOPo->op_first;
1333 if (kid->op_type != OP_PUSHMARK) {
1334 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1336 "panic: unexpected lvalue entersub "
1337 "args: type/targ %ld:%"UVuf,
1338 (long)kid->op_type, (UV)kid->op_targ);
1339 kid = kLISTOP->op_first;
1341 while (kid->op_sibling)
1342 kid = kid->op_sibling;
1343 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1345 if (kid->op_type == OP_METHOD_NAMED
1346 || kid->op_type == OP_METHOD)
1350 NewOp(1101, newop, 1, UNOP);
1351 newop->op_type = OP_RV2CV;
1352 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1353 newop->op_first = NULL;
1354 newop->op_next = (OP*)newop;
1355 kid->op_sibling = (OP*)newop;
1356 newop->op_private |= OPpLVAL_INTRO;
1357 newop->op_private &= ~1;
1361 if (kid->op_type != OP_RV2CV)
1363 "panic: unexpected lvalue entersub "
1364 "entry via type/targ %ld:%"UVuf,
1365 (long)kid->op_type, (UV)kid->op_targ);
1366 kid->op_private |= OPpLVAL_INTRO;
1367 break; /* Postpone until runtime */
1371 kid = kUNOP->op_first;
1372 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1373 kid = kUNOP->op_first;
1374 if (kid->op_type == OP_NULL)
1376 "Unexpected constant lvalue entersub "
1377 "entry via type/targ %ld:%"UVuf,
1378 (long)kid->op_type, (UV)kid->op_targ);
1379 if (kid->op_type != OP_GV) {
1380 /* Restore RV2CV to check lvalueness */
1382 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1383 okid->op_next = kid->op_next;
1384 kid->op_next = okid;
1387 okid->op_next = NULL;
1388 okid->op_type = OP_RV2CV;
1390 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1391 okid->op_private |= OPpLVAL_INTRO;
1392 okid->op_private &= ~1;
1396 cv = GvCV(kGVOP_gv);
1406 /* grep, foreach, subcalls, refgen */
1407 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1409 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1410 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1412 : (o->op_type == OP_ENTERSUB
1413 ? "non-lvalue subroutine call"
1415 type ? PL_op_desc[type] : "local"));
1429 case OP_RIGHT_SHIFT:
1438 if (!(o->op_flags & OPf_STACKED))
1445 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1451 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1452 PL_modcount = RETURN_UNLIMITED_NUMBER;
1453 return o; /* Treat \(@foo) like ordinary list. */
1457 if (scalar_mod_type(o, type))
1459 ref(cUNOPo->op_first, o->op_type);
1463 if (type == OP_LEAVESUBLV)
1464 o->op_private |= OPpMAYBE_LVSUB;
1470 PL_modcount = RETURN_UNLIMITED_NUMBER;
1473 ref(cUNOPo->op_first, o->op_type);
1478 PL_hints |= HINT_BLOCK_SCOPE;
1493 PL_modcount = RETURN_UNLIMITED_NUMBER;
1494 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1495 return o; /* Treat \(@foo) like ordinary list. */
1496 if (scalar_mod_type(o, type))
1498 if (type == OP_LEAVESUBLV)
1499 o->op_private |= OPpMAYBE_LVSUB;
1503 if (!type) /* local() */
1504 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1505 PAD_COMPNAME_PV(o->op_targ));
1513 if (type != OP_SASSIGN)
1517 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1522 if (type == OP_LEAVESUBLV)
1523 o->op_private |= OPpMAYBE_LVSUB;
1525 pad_free(o->op_targ);
1526 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1527 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1528 if (o->op_flags & OPf_KIDS)
1529 mod(cBINOPo->op_first->op_sibling, type);
1534 ref(cBINOPo->op_first, o->op_type);
1535 if (type == OP_ENTERSUB &&
1536 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1537 o->op_private |= OPpLVAL_DEFER;
1538 if (type == OP_LEAVESUBLV)
1539 o->op_private |= OPpMAYBE_LVSUB;
1549 if (o->op_flags & OPf_KIDS)
1550 mod(cLISTOPo->op_last, type);
1555 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1557 else if (!(o->op_flags & OPf_KIDS))
1559 if (o->op_targ != OP_LIST) {
1560 mod(cBINOPo->op_first, type);
1566 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1571 if (type != OP_LEAVESUBLV)
1573 break; /* mod()ing was handled by ck_return() */
1576 /* [20011101.069] File test operators interpret OPf_REF to mean that
1577 their argument is a filehandle; thus \stat(".") should not set
1579 if (type == OP_REFGEN &&
1580 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1583 if (type != OP_LEAVESUBLV)
1584 o->op_flags |= OPf_MOD;
1586 if (type == OP_AASSIGN || type == OP_SASSIGN)
1587 o->op_flags |= OPf_SPECIAL|OPf_REF;
1588 else if (!type) { /* local() */
1591 o->op_private |= OPpLVAL_INTRO;
1592 o->op_flags &= ~OPf_SPECIAL;
1593 PL_hints |= HINT_BLOCK_SCOPE;
1598 if (ckWARN(WARN_SYNTAX)) {
1599 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1600 "Useless localization of %s", OP_DESC(o));
1604 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1605 && type != OP_LEAVESUBLV)
1606 o->op_flags |= OPf_REF;
1611 S_scalar_mod_type(const OP *o, I32 type)
1615 if (o->op_type == OP_RV2GV)
1639 case OP_RIGHT_SHIFT:
1658 S_is_handle_constructor(const OP *o, I32 numargs)
1660 switch (o->op_type) {
1668 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1681 Perl_refkids(pTHX_ OP *o, I32 type)
1683 if (o && o->op_flags & OPf_KIDS) {
1685 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1692 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1697 if (!o || PL_error_count)
1700 switch (o->op_type) {
1702 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1703 !(o->op_flags & OPf_STACKED)) {
1704 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1705 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1706 assert(cUNOPo->op_first->op_type == OP_NULL);
1707 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1708 o->op_flags |= OPf_SPECIAL;
1709 o->op_private &= ~1;
1714 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1715 doref(kid, type, set_op_ref);
1718 if (type == OP_DEFINED)
1719 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1720 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1723 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1724 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1725 : type == OP_RV2HV ? OPpDEREF_HV
1727 o->op_flags |= OPf_MOD;
1734 o->op_flags |= OPf_REF;
1737 if (type == OP_DEFINED)
1738 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1739 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1745 o->op_flags |= OPf_REF;
1750 if (!(o->op_flags & OPf_KIDS))
1752 doref(cBINOPo->op_first, type, set_op_ref);
1756 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1757 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1758 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1759 : type == OP_RV2HV ? OPpDEREF_HV
1761 o->op_flags |= OPf_MOD;
1771 if (!(o->op_flags & OPf_KIDS))
1773 doref(cLISTOPo->op_last, type, set_op_ref);
1783 S_dup_attrlist(pTHX_ OP *o)
1788 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1789 * where the first kid is OP_PUSHMARK and the remaining ones
1790 * are OP_CONST. We need to push the OP_CONST values.
1792 if (o->op_type == OP_CONST)
1793 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1795 else if (o->op_type == OP_NULL)
1799 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1801 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1802 if (o->op_type == OP_CONST)
1803 rop = append_elem(OP_LIST, rop,
1804 newSVOP(OP_CONST, o->op_flags,
1805 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1812 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1817 /* fake up C<use attributes $pkg,$rv,@attrs> */
1818 ENTER; /* need to protect against side-effects of 'use' */
1820 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1822 #define ATTRSMODULE "attributes"
1823 #define ATTRSMODULE_PM "attributes.pm"
1826 /* Don't force the C<use> if we don't need it. */
1827 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1828 if (svp && *svp != &PL_sv_undef)
1829 NOOP; /* already in %INC */
1831 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1832 newSVpvs(ATTRSMODULE), NULL);
1835 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1836 newSVpvs(ATTRSMODULE),
1838 prepend_elem(OP_LIST,
1839 newSVOP(OP_CONST, 0, stashsv),
1840 prepend_elem(OP_LIST,
1841 newSVOP(OP_CONST, 0,
1843 dup_attrlist(attrs))));
1849 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1852 OP *pack, *imop, *arg;
1858 assert(target->op_type == OP_PADSV ||
1859 target->op_type == OP_PADHV ||
1860 target->op_type == OP_PADAV);
1862 /* Ensure that attributes.pm is loaded. */
1863 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1865 /* Need package name for method call. */
1866 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1868 /* Build up the real arg-list. */
1869 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1871 arg = newOP(OP_PADSV, 0);
1872 arg->op_targ = target->op_targ;
1873 arg = prepend_elem(OP_LIST,
1874 newSVOP(OP_CONST, 0, stashsv),
1875 prepend_elem(OP_LIST,
1876 newUNOP(OP_REFGEN, 0,
1877 mod(arg, OP_REFGEN)),
1878 dup_attrlist(attrs)));
1880 /* Fake up a method call to import */
1881 meth = newSVpvs_share("import");
1882 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1883 append_elem(OP_LIST,
1884 prepend_elem(OP_LIST, pack, list(arg)),
1885 newSVOP(OP_METHOD_NAMED, 0, meth)));
1886 imop->op_private |= OPpENTERSUB_NOMOD;
1888 /* Combine the ops. */
1889 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1893 =notfor apidoc apply_attrs_string
1895 Attempts to apply a list of attributes specified by the C<attrstr> and
1896 C<len> arguments to the subroutine identified by the C<cv> argument which
1897 is expected to be associated with the package identified by the C<stashpv>
1898 argument (see L<attributes>). It gets this wrong, though, in that it
1899 does not correctly identify the boundaries of the individual attribute
1900 specifications within C<attrstr>. This is not really intended for the
1901 public API, but has to be listed here for systems such as AIX which
1902 need an explicit export list for symbols. (It's called from XS code
1903 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1904 to respect attribute syntax properly would be welcome.
1910 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1911 const char *attrstr, STRLEN len)
1916 len = strlen(attrstr);
1920 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1922 const char * const sstr = attrstr;
1923 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1924 attrs = append_elem(OP_LIST, attrs,
1925 newSVOP(OP_CONST, 0,
1926 newSVpvn(sstr, attrstr-sstr)));
1930 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1931 newSVpvs(ATTRSMODULE),
1932 NULL, prepend_elem(OP_LIST,
1933 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1934 prepend_elem(OP_LIST,
1935 newSVOP(OP_CONST, 0,
1941 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1946 if (!o || PL_error_count)
1950 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1951 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1955 if (type == OP_LIST) {
1957 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1958 my_kid(kid, attrs, imopsp);
1959 } else if (type == OP_UNDEF
1965 } else if (type == OP_RV2SV || /* "our" declaration */
1967 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1968 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1969 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1971 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1973 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1975 PL_in_my_stash = NULL;
1976 apply_attrs(GvSTASH(gv),
1977 (type == OP_RV2SV ? GvSV(gv) :
1978 type == OP_RV2AV ? (SV*)GvAV(gv) :
1979 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1982 o->op_private |= OPpOUR_INTRO;
1985 else if (type != OP_PADSV &&
1988 type != OP_PUSHMARK)
1990 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1992 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1995 else if (attrs && type != OP_PUSHMARK) {
1999 PL_in_my_stash = NULL;
2001 /* check for C<my Dog $spot> when deciding package */
2002 stash = PAD_COMPNAME_TYPE(o->op_targ);
2004 stash = PL_curstash;
2005 apply_attrs_my(stash, o, attrs, imopsp);
2007 o->op_flags |= OPf_MOD;
2008 o->op_private |= OPpLVAL_INTRO;
2009 if (PL_in_my == KEY_state)
2010 o->op_private |= OPpPAD_STATE;
2015 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2019 int maybe_scalar = 0;
2021 /* [perl #17376]: this appears to be premature, and results in code such as
2022 C< our(%x); > executing in list mode rather than void mode */
2024 if (o->op_flags & OPf_PARENS)
2034 o = my_kid(o, attrs, &rops);
2036 if (maybe_scalar && o->op_type == OP_PADSV) {
2037 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2038 o->op_private |= OPpLVAL_INTRO;
2041 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2044 PL_in_my_stash = NULL;
2049 Perl_my(pTHX_ OP *o)
2051 return my_attrs(o, NULL);
2055 Perl_sawparens(pTHX_ OP *o)
2057 PERL_UNUSED_CONTEXT;
2059 o->op_flags |= OPf_PARENS;
2064 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2068 const OPCODE ltype = left->op_type;
2069 const OPCODE rtype = right->op_type;
2071 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2072 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2074 const char * const desc
2075 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2076 ? (int)rtype : OP_MATCH];
2077 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2078 ? "@array" : "%hash");
2079 Perl_warner(aTHX_ packWARN(WARN_MISC),
2080 "Applying %s to %s will act on scalar(%s)",
2081 desc, sample, sample);
2084 if (rtype == OP_CONST &&
2085 cSVOPx(right)->op_private & OPpCONST_BARE &&
2086 cSVOPx(right)->op_private & OPpCONST_STRICT)
2088 no_bareword_allowed(right);
2091 ismatchop = rtype == OP_MATCH ||
2092 rtype == OP_SUBST ||
2094 if (ismatchop && right->op_private & OPpTARGET_MY) {
2096 right->op_private &= ~OPpTARGET_MY;
2098 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2101 right->op_flags |= OPf_STACKED;
2102 if (rtype != OP_MATCH &&
2103 ! (rtype == OP_TRANS &&
2104 right->op_private & OPpTRANS_IDENTICAL))
2105 newleft = mod(left, rtype);
2108 if (right->op_type == OP_TRANS)
2109 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2111 o = prepend_elem(rtype, scalar(newleft), right);
2113 return newUNOP(OP_NOT, 0, scalar(o));
2117 return bind_match(type, left,
2118 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2122 Perl_invert(pTHX_ OP *o)
2126 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2130 Perl_scope(pTHX_ OP *o)
2134 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2135 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2136 o->op_type = OP_LEAVE;
2137 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2139 else if (o->op_type == OP_LINESEQ) {
2141 o->op_type = OP_SCOPE;
2142 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2143 kid = ((LISTOP*)o)->op_first;
2144 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2147 /* The following deals with things like 'do {1 for 1}' */
2148 kid = kid->op_sibling;
2150 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2155 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2161 Perl_block_start(pTHX_ int full)
2164 const int retval = PL_savestack_ix;
2165 pad_block_start(full);
2167 PL_hints &= ~HINT_BLOCK_SCOPE;
2168 SAVECOMPILEWARNINGS();
2169 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2174 Perl_block_end(pTHX_ I32 floor, OP *seq)
2177 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2178 OP* const retval = scalarseq(seq);
2180 CopHINTS_set(&PL_compiling, PL_hints);
2182 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2191 const PADOFFSET offset = pad_findmy("$_");
2192 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2193 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2196 OP * const o = newOP(OP_PADSV, 0);
2197 o->op_targ = offset;
2203 Perl_newPROG(pTHX_ OP *o)
2209 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2210 ((PL_in_eval & EVAL_KEEPERR)
2211 ? OPf_SPECIAL : 0), o);
2212 PL_eval_start = linklist(PL_eval_root);
2213 PL_eval_root->op_private |= OPpREFCOUNTED;
2214 OpREFCNT_set(PL_eval_root, 1);
2215 PL_eval_root->op_next = 0;
2216 CALL_PEEP(PL_eval_start);
2219 if (o->op_type == OP_STUB) {
2220 PL_comppad_name = 0;
2222 S_op_destroy(aTHX_ o);
2225 PL_main_root = scope(sawparens(scalarvoid(o)));
2226 PL_curcop = &PL_compiling;
2227 PL_main_start = LINKLIST(PL_main_root);
2228 PL_main_root->op_private |= OPpREFCOUNTED;
2229 OpREFCNT_set(PL_main_root, 1);
2230 PL_main_root->op_next = 0;
2231 CALL_PEEP(PL_main_start);
2234 /* Register with debugger */
2237 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2241 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2243 call_sv((SV*)cv, G_DISCARD);
2250 Perl_localize(pTHX_ OP *o, I32 lex)
2253 if (o->op_flags & OPf_PARENS)
2254 /* [perl #17376]: this appears to be premature, and results in code such as
2255 C< our(%x); > executing in list mode rather than void mode */
2262 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2263 && ckWARN(WARN_PARENTHESIS))
2265 char *s = PL_bufptr;
2268 /* some heuristics to detect a potential error */
2269 while (*s && (strchr(", \t\n", *s)))
2273 if (*s && strchr("@$%*", *s) && *++s
2274 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2277 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2279 while (*s && (strchr(", \t\n", *s)))
2285 if (sigil && (*s == ';' || *s == '=')) {
2286 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2287 "Parentheses missing around \"%s\" list",
2288 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2296 o = mod(o, OP_NULL); /* a bit kludgey */
2298 PL_in_my_stash = NULL;
2303 Perl_jmaybe(pTHX_ OP *o)
2305 if (o->op_type == OP_LIST) {
2307 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2308 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2314 Perl_fold_constants(pTHX_ register OP *o)
2319 VOL I32 type = o->op_type;
2324 SV * const oldwarnhook = PL_warnhook;
2325 SV * const olddiehook = PL_diehook;
2328 if (PL_opargs[type] & OA_RETSCALAR)
2330 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2331 o->op_targ = pad_alloc(type, SVs_PADTMP);
2333 /* integerize op, unless it happens to be C<-foo>.
2334 * XXX should pp_i_negate() do magic string negation instead? */
2335 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2336 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2337 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2339 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2342 if (!(PL_opargs[type] & OA_FOLDCONST))
2347 /* XXX might want a ck_negate() for this */
2348 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2359 /* XXX what about the numeric ops? */
2360 if (PL_hints & HINT_LOCALE)
2365 goto nope; /* Don't try to run w/ errors */
2367 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2368 const OPCODE type = curop->op_type;
2369 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2371 type != OP_SCALAR &&
2373 type != OP_PUSHMARK)
2379 curop = LINKLIST(o);
2380 old_next = o->op_next;
2384 oldscope = PL_scopestack_ix;
2385 create_eval_scope(G_FAKINGEVAL);
2387 PL_warnhook = PERL_WARNHOOK_FATAL;
2394 sv = *(PL_stack_sp--);
2395 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2396 pad_swipe(o->op_targ, FALSE);
2397 else if (SvTEMP(sv)) { /* grab mortal temp? */
2398 SvREFCNT_inc_simple_void(sv);
2403 /* Something tried to die. Abandon constant folding. */
2404 /* Pretend the error never happened. */
2405 sv_setpvn(ERRSV,"",0);
2406 o->op_next = old_next;
2410 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2411 PL_warnhook = oldwarnhook;
2412 PL_diehook = olddiehook;
2413 /* XXX note that this croak may fail as we've already blown away
2414 * the stack - eg any nested evals */
2415 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2418 PL_warnhook = oldwarnhook;
2419 PL_diehook = olddiehook;
2421 if (PL_scopestack_ix > oldscope)
2422 delete_eval_scope();
2431 if (type == OP_RV2GV)
2432 newop = newGVOP(OP_GV, 0, (GV*)sv);
2434 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2435 op_getmad(o,newop,'f');
2443 Perl_gen_constant_list(pTHX_ register OP *o)
2447 const I32 oldtmps_floor = PL_tmps_floor;
2451 return o; /* Don't attempt to run with errors */
2453 PL_op = curop = LINKLIST(o);
2459 assert (!(curop->op_flags & OPf_SPECIAL));
2460 assert(curop->op_type == OP_RANGE);
2462 PL_tmps_floor = oldtmps_floor;
2464 o->op_type = OP_RV2AV;
2465 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2466 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2467 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2468 o->op_opt = 0; /* needs to be revisited in peep() */
2469 curop = ((UNOP*)o)->op_first;
2470 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2472 op_getmad(curop,o,'O');
2481 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2484 if (!o || o->op_type != OP_LIST)
2485 o = newLISTOP(OP_LIST, 0, o, NULL);
2487 o->op_flags &= ~OPf_WANT;
2489 if (!(PL_opargs[type] & OA_MARK))
2490 op_null(cLISTOPo->op_first);
2492 o->op_type = (OPCODE)type;
2493 o->op_ppaddr = PL_ppaddr[type];
2494 o->op_flags |= flags;
2496 o = CHECKOP(type, o);
2497 if (o->op_type != (unsigned)type)
2500 return fold_constants(o);
2503 /* List constructors */
2506 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2514 if (first->op_type != (unsigned)type
2515 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2517 return newLISTOP(type, 0, first, last);
2520 if (first->op_flags & OPf_KIDS)
2521 ((LISTOP*)first)->op_last->op_sibling = last;
2523 first->op_flags |= OPf_KIDS;
2524 ((LISTOP*)first)->op_first = last;
2526 ((LISTOP*)first)->op_last = last;
2531 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2539 if (first->op_type != (unsigned)type)
2540 return prepend_elem(type, (OP*)first, (OP*)last);
2542 if (last->op_type != (unsigned)type)
2543 return append_elem(type, (OP*)first, (OP*)last);
2545 first->op_last->op_sibling = last->op_first;
2546 first->op_last = last->op_last;
2547 first->op_flags |= (last->op_flags & OPf_KIDS);
2550 if (last->op_first && first->op_madprop) {
2551 MADPROP *mp = last->op_first->op_madprop;
2553 while (mp->mad_next)
2555 mp->mad_next = first->op_madprop;
2558 last->op_first->op_madprop = first->op_madprop;
2561 first->op_madprop = last->op_madprop;
2562 last->op_madprop = 0;
2565 S_op_destroy(aTHX_ (OP*)last);
2571 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2579 if (last->op_type == (unsigned)type) {
2580 if (type == OP_LIST) { /* already a PUSHMARK there */
2581 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2582 ((LISTOP*)last)->op_first->op_sibling = first;
2583 if (!(first->op_flags & OPf_PARENS))
2584 last->op_flags &= ~OPf_PARENS;
2587 if (!(last->op_flags & OPf_KIDS)) {
2588 ((LISTOP*)last)->op_last = first;
2589 last->op_flags |= OPf_KIDS;
2591 first->op_sibling = ((LISTOP*)last)->op_first;
2592 ((LISTOP*)last)->op_first = first;
2594 last->op_flags |= OPf_KIDS;
2598 return newLISTOP(type, 0, first, last);
2606 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2609 Newxz(tk, 1, TOKEN);
2610 tk->tk_type = (OPCODE)optype;
2611 tk->tk_type = 12345;
2613 tk->tk_mad = madprop;
2618 Perl_token_free(pTHX_ TOKEN* tk)
2620 if (tk->tk_type != 12345)
2622 mad_free(tk->tk_mad);
2627 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2631 if (tk->tk_type != 12345) {
2632 Perl_warner(aTHX_ packWARN(WARN_MISC),
2633 "Invalid TOKEN object ignored");
2640 /* faked up qw list? */
2642 tm->mad_type == MAD_SV &&
2643 SvPVX((SV*)tm->mad_val)[0] == 'q')
2650 /* pretend constant fold didn't happen? */
2651 if (mp->mad_key == 'f' &&
2652 (o->op_type == OP_CONST ||
2653 o->op_type == OP_GV) )
2655 token_getmad(tk,(OP*)mp->mad_val,slot);
2669 if (mp->mad_key == 'X')
2670 mp->mad_key = slot; /* just change the first one */
2680 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2689 /* pretend constant fold didn't happen? */
2690 if (mp->mad_key == 'f' &&
2691 (o->op_type == OP_CONST ||
2692 o->op_type == OP_GV) )
2694 op_getmad(from,(OP*)mp->mad_val,slot);
2701 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2704 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2710 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2719 /* pretend constant fold didn't happen? */
2720 if (mp->mad_key == 'f' &&
2721 (o->op_type == OP_CONST ||
2722 o->op_type == OP_GV) )
2724 op_getmad(from,(OP*)mp->mad_val,slot);
2731 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2734 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2738 PerlIO_printf(PerlIO_stderr(),
2739 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2745 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2763 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2767 addmad(tm, &(o->op_madprop), slot);
2771 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2792 Perl_newMADsv(pTHX_ char key, SV* sv)
2794 return newMADPROP(key, MAD_SV, sv, 0);
2798 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2801 Newxz(mp, 1, MADPROP);
2804 mp->mad_vlen = vlen;
2805 mp->mad_type = type;
2807 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2812 Perl_mad_free(pTHX_ MADPROP* mp)
2814 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2818 mad_free(mp->mad_next);
2819 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2820 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2821 switch (mp->mad_type) {
2825 Safefree((char*)mp->mad_val);
2828 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2829 op_free((OP*)mp->mad_val);
2832 sv_free((SV*)mp->mad_val);
2835 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2844 Perl_newNULLLIST(pTHX)
2846 return newOP(OP_STUB, 0);
2850 Perl_force_list(pTHX_ OP *o)
2852 if (!o || o->op_type != OP_LIST)
2853 o = newLISTOP(OP_LIST, 0, o, NULL);
2859 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2864 NewOp(1101, listop, 1, LISTOP);
2866 listop->op_type = (OPCODE)type;
2867 listop->op_ppaddr = PL_ppaddr[type];
2870 listop->op_flags = (U8)flags;
2874 else if (!first && last)
2877 first->op_sibling = last;
2878 listop->op_first = first;
2879 listop->op_last = last;
2880 if (type == OP_LIST) {
2881 OP* const pushop = newOP(OP_PUSHMARK, 0);
2882 pushop->op_sibling = first;
2883 listop->op_first = pushop;
2884 listop->op_flags |= OPf_KIDS;
2886 listop->op_last = pushop;
2889 return CHECKOP(type, listop);
2893 Perl_newOP(pTHX_ I32 type, I32 flags)
2897 NewOp(1101, o, 1, OP);
2898 o->op_type = (OPCODE)type;
2899 o->op_ppaddr = PL_ppaddr[type];
2900 o->op_flags = (U8)flags;
2902 o->op_latefreed = 0;
2906 o->op_private = (U8)(0 | (flags >> 8));
2907 if (PL_opargs[type] & OA_RETSCALAR)
2909 if (PL_opargs[type] & OA_TARGET)
2910 o->op_targ = pad_alloc(type, SVs_PADTMP);
2911 return CHECKOP(type, o);
2915 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2921 first = newOP(OP_STUB, 0);
2922 if (PL_opargs[type] & OA_MARK)
2923 first = force_list(first);
2925 NewOp(1101, unop, 1, UNOP);
2926 unop->op_type = (OPCODE)type;
2927 unop->op_ppaddr = PL_ppaddr[type];
2928 unop->op_first = first;
2929 unop->op_flags = (U8)(flags | OPf_KIDS);
2930 unop->op_private = (U8)(1 | (flags >> 8));
2931 unop = (UNOP*) CHECKOP(type, unop);
2935 return fold_constants((OP *) unop);
2939 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2943 NewOp(1101, binop, 1, BINOP);
2946 first = newOP(OP_NULL, 0);
2948 binop->op_type = (OPCODE)type;
2949 binop->op_ppaddr = PL_ppaddr[type];
2950 binop->op_first = first;
2951 binop->op_flags = (U8)(flags | OPf_KIDS);
2954 binop->op_private = (U8)(1 | (flags >> 8));
2957 binop->op_private = (U8)(2 | (flags >> 8));
2958 first->op_sibling = last;
2961 binop = (BINOP*)CHECKOP(type, binop);
2962 if (binop->op_next || binop->op_type != (OPCODE)type)
2965 binop->op_last = binop->op_first->op_sibling;
2967 return fold_constants((OP *)binop);
2970 static int uvcompare(const void *a, const void *b)
2971 __attribute__nonnull__(1)
2972 __attribute__nonnull__(2)
2973 __attribute__pure__;
2974 static int uvcompare(const void *a, const void *b)
2976 if (*((const UV *)a) < (*(const UV *)b))
2978 if (*((const UV *)a) > (*(const UV *)b))
2980 if (*((const UV *)a+1) < (*(const UV *)b+1))
2982 if (*((const UV *)a+1) > (*(const UV *)b+1))
2988 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2991 SV * const tstr = ((SVOP*)expr)->op_sv;
2994 (repl->op_type == OP_NULL)
2995 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2997 ((SVOP*)repl)->op_sv;
3000 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3001 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3005 register short *tbl;
3007 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3008 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3009 I32 del = o->op_private & OPpTRANS_DELETE;
3011 PL_hints |= HINT_BLOCK_SCOPE;
3014 o->op_private |= OPpTRANS_FROM_UTF;
3017 o->op_private |= OPpTRANS_TO_UTF;
3019 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3020 SV* const listsv = newSVpvs("# comment\n");
3022 const U8* tend = t + tlen;
3023 const U8* rend = r + rlen;
3037 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3038 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3041 const U32 flags = UTF8_ALLOW_DEFAULT;
3045 t = tsave = bytes_to_utf8(t, &len);
3048 if (!to_utf && rlen) {
3050 r = rsave = bytes_to_utf8(r, &len);
3054 /* There are several snags with this code on EBCDIC:
3055 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3056 2. scan_const() in toke.c has encoded chars in native encoding which makes
3057 ranges at least in EBCDIC 0..255 range the bottom odd.
3061 U8 tmpbuf[UTF8_MAXBYTES+1];
3064 Newx(cp, 2*tlen, UV);
3066 transv = newSVpvs("");
3068 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3070 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3072 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3076 cp[2*i+1] = cp[2*i];
3080 qsort(cp, i, 2*sizeof(UV), uvcompare);
3081 for (j = 0; j < i; j++) {
3083 diff = val - nextmin;
3085 t = uvuni_to_utf8(tmpbuf,nextmin);
3086 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3088 U8 range_mark = UTF_TO_NATIVE(0xff);
3089 t = uvuni_to_utf8(tmpbuf, val - 1);
3090 sv_catpvn(transv, (char *)&range_mark, 1);
3091 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3098 t = uvuni_to_utf8(tmpbuf,nextmin);
3099 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3101 U8 range_mark = UTF_TO_NATIVE(0xff);
3102 sv_catpvn(transv, (char *)&range_mark, 1);
3104 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3105 UNICODE_ALLOW_SUPER);
3106 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3107 t = (const U8*)SvPVX_const(transv);
3108 tlen = SvCUR(transv);
3112 else if (!rlen && !del) {
3113 r = t; rlen = tlen; rend = tend;
3116 if ((!rlen && !del) || t == r ||
3117 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3119 o->op_private |= OPpTRANS_IDENTICAL;
3123 while (t < tend || tfirst <= tlast) {
3124 /* see if we need more "t" chars */
3125 if (tfirst > tlast) {
3126 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3128 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3130 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3137 /* now see if we need more "r" chars */
3138 if (rfirst > rlast) {
3140 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3142 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3144 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3153 rfirst = rlast = 0xffffffff;
3157 /* now see which range will peter our first, if either. */
3158 tdiff = tlast - tfirst;
3159 rdiff = rlast - rfirst;
3166 if (rfirst == 0xffffffff) {
3167 diff = tdiff; /* oops, pretend rdiff is infinite */
3169 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3170 (long)tfirst, (long)tlast);
3172 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3176 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3177 (long)tfirst, (long)(tfirst + diff),
3180 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3181 (long)tfirst, (long)rfirst);
3183 if (rfirst + diff > max)
3184 max = rfirst + diff;
3186 grows = (tfirst < rfirst &&
3187 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3199 else if (max > 0xff)
3204 PerlMemShared_free(cPVOPo->op_pv);
3205 cPVOPo->op_pv = NULL;
3207 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3209 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3210 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3211 PAD_SETSV(cPADOPo->op_padix, swash);
3214 cSVOPo->op_sv = swash;
3216 SvREFCNT_dec(listsv);
3217 SvREFCNT_dec(transv);
3219 if (!del && havefinal && rlen)
3220 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3221 newSVuv((UV)final), 0);
3224 o->op_private |= OPpTRANS_GROWS;
3230 op_getmad(expr,o,'e');
3231 op_getmad(repl,o,'r');
3239 tbl = (short*)cPVOPo->op_pv;
3241 Zero(tbl, 256, short);
3242 for (i = 0; i < (I32)tlen; i++)
3244 for (i = 0, j = 0; i < 256; i++) {
3246 if (j >= (I32)rlen) {
3255 if (i < 128 && r[j] >= 128)
3265 o->op_private |= OPpTRANS_IDENTICAL;
3267 else if (j >= (I32)rlen)
3272 PerlMemShared_realloc(tbl,
3273 (0x101+rlen-j) * sizeof(short));
3274 cPVOPo->op_pv = (char*)tbl;
3276 tbl[0x100] = (short)(rlen - j);
3277 for (i=0; i < (I32)rlen - j; i++)
3278 tbl[0x101+i] = r[j+i];
3282 if (!rlen && !del) {
3285 o->op_private |= OPpTRANS_IDENTICAL;
3287 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3288 o->op_private |= OPpTRANS_IDENTICAL;
3290 for (i = 0; i < 256; i++)
3292 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3293 if (j >= (I32)rlen) {
3295 if (tbl[t[i]] == -1)
3301 if (tbl[t[i]] == -1) {
3302 if (t[i] < 128 && r[j] >= 128)
3309 o->op_private |= OPpTRANS_GROWS;
3311 op_getmad(expr,o,'e');
3312 op_getmad(repl,o,'r');
3322 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3327 NewOp(1101, pmop, 1, PMOP);
3328 pmop->op_type = (OPCODE)type;
3329 pmop->op_ppaddr = PL_ppaddr[type];
3330 pmop->op_flags = (U8)flags;
3331 pmop->op_private = (U8)(0 | (flags >> 8));
3333 if (PL_hints & HINT_RE_TAINT)
3334 pmop->op_pmflags |= PMf_RETAINT;
3335 if (PL_hints & HINT_LOCALE)
3336 pmop->op_pmflags |= PMf_LOCALE;
3340 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3341 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3342 pmop->op_pmoffset = SvIV(repointer);
3343 SvREPADTMP_off(repointer);
3344 sv_setiv(repointer,0);
3346 SV * const repointer = newSViv(0);
3347 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3348 pmop->op_pmoffset = av_len(PL_regex_padav);
3349 PL_regex_pad = AvARRAY(PL_regex_padav);
3353 return CHECKOP(type, pmop);
3356 /* Given some sort of match op o, and an expression expr containing a
3357 * pattern, either compile expr into a regex and attach it to o (if it's
3358 * constant), or convert expr into a runtime regcomp op sequence (if it's
3361 * isreg indicates that the pattern is part of a regex construct, eg
3362 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3363 * split "pattern", which aren't. In the former case, expr will be a list
3364 * if the pattern contains more than one term (eg /a$b/) or if it contains
3365 * a replacement, ie s/// or tr///.
3369 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3374 I32 repl_has_vars = 0;
3378 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3379 /* last element in list is the replacement; pop it */
3381 repl = cLISTOPx(expr)->op_last;
3382 kid = cLISTOPx(expr)->op_first;
3383 while (kid->op_sibling != repl)
3384 kid = kid->op_sibling;
3385 kid->op_sibling = NULL;
3386 cLISTOPx(expr)->op_last = kid;
3389 if (isreg && expr->op_type == OP_LIST &&
3390 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3392 /* convert single element list to element */
3393 OP* const oe = expr;
3394 expr = cLISTOPx(oe)->op_first->op_sibling;
3395 cLISTOPx(oe)->op_first->op_sibling = NULL;
3396 cLISTOPx(oe)->op_last = NULL;
3400 if (o->op_type == OP_TRANS) {
3401 return pmtrans(o, expr, repl);
3404 reglist = isreg && expr->op_type == OP_LIST;
3408 PL_hints |= HINT_BLOCK_SCOPE;
3411 if (expr->op_type == OP_CONST) {
3413 SV * const pat = ((SVOP*)expr)->op_sv;
3414 const char *p = SvPV_const(pat, plen);
3415 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3416 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
3417 U32 was_readonly = SvREADONLY(pat);
3421 sv_force_normal_flags(pat, 0);
3422 assert(!SvREADONLY(pat));
3425 SvREADONLY_off(pat);
3429 sv_setpvn(pat, "\\s+", 3);
3431 SvFLAGS(pat) |= was_readonly;
3433 p = SvPV_const(pat, plen);
3434 pm_flags |= RXf_SKIPWHITE;
3437 pm_flags |= RXf_UTF8;
3438 /* FIXME - can we make this function take const char * args? */
3439 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm_flags));
3442 op_getmad(expr,(OP*)pm,'e');
3448 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3449 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3451 : OP_REGCMAYBE),0,expr);
3453 NewOp(1101, rcop, 1, LOGOP);
3454 rcop->op_type = OP_REGCOMP;
3455 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3456 rcop->op_first = scalar(expr);
3457 rcop->op_flags |= OPf_KIDS
3458 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3459 | (reglist ? OPf_STACKED : 0);
3460 rcop->op_private = 1;
3463 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3465 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3468 /* establish postfix order */
3469 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3471 rcop->op_next = expr;
3472 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3475 rcop->op_next = LINKLIST(expr);
3476 expr->op_next = (OP*)rcop;
3479 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3484 if (pm->op_pmflags & PMf_EVAL) {
3486 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3487 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3489 else if (repl->op_type == OP_CONST)
3493 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3494 if (curop->op_type == OP_SCOPE
3495 || curop->op_type == OP_LEAVE
3496 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3497 if (curop->op_type == OP_GV) {
3498 GV * const gv = cGVOPx_gv(curop);
3500 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3503 else if (curop->op_type == OP_RV2CV)
3505 else if (curop->op_type == OP_RV2SV ||
3506 curop->op_type == OP_RV2AV ||
3507 curop->op_type == OP_RV2HV ||
3508 curop->op_type == OP_RV2GV) {
3509 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3512 else if (curop->op_type == OP_PADSV ||
3513 curop->op_type == OP_PADAV ||
3514 curop->op_type == OP_PADHV ||
3515 curop->op_type == OP_PADANY)
3519 else if (curop->op_type == OP_PUSHRE)
3520 NOOP; /* Okay here, dangerous in newASSIGNOP */
3530 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3532 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3533 prepend_elem(o->op_type, scalar(repl), o);
3536 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3537 pm->op_pmflags |= PMf_MAYBE_CONST;
3539 NewOp(1101, rcop, 1, LOGOP);
3540 rcop->op_type = OP_SUBSTCONT;
3541 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3542 rcop->op_first = scalar(repl);
3543 rcop->op_flags |= OPf_KIDS;
3544 rcop->op_private = 1;
3547 /* establish postfix order */
3548 rcop->op_next = LINKLIST(repl);
3549 repl->op_next = (OP*)rcop;
3551 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3552 assert(!(pm->op_pmflags & PMf_ONCE));
3553 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3562 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3566 NewOp(1101, svop, 1, SVOP);
3567 svop->op_type = (OPCODE)type;
3568 svop->op_ppaddr = PL_ppaddr[type];
3570 svop->op_next = (OP*)svop;
3571 svop->op_flags = (U8)flags;
3572 if (PL_opargs[type] & OA_RETSCALAR)
3574 if (PL_opargs[type] & OA_TARGET)
3575 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3576 return CHECKOP(type, svop);
3581 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3585 NewOp(1101, padop, 1, PADOP);
3586 padop->op_type = (OPCODE)type;
3587 padop->op_ppaddr = PL_ppaddr[type];
3588 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3589 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3590 PAD_SETSV(padop->op_padix, sv);
3593 padop->op_next = (OP*)padop;
3594 padop->op_flags = (U8)flags;
3595 if (PL_opargs[type] & OA_RETSCALAR)
3597 if (PL_opargs[type] & OA_TARGET)
3598 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3599 return CHECKOP(type, padop);
3604 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3610 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3612 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3617 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3621 NewOp(1101, pvop, 1, PVOP);
3622 pvop->op_type = (OPCODE)type;
3623 pvop->op_ppaddr = PL_ppaddr[type];
3625 pvop->op_next = (OP*)pvop;
3626 pvop->op_flags = (U8)flags;
3627 if (PL_opargs[type] & OA_RETSCALAR)
3629 if (PL_opargs[type] & OA_TARGET)
3630 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3631 return CHECKOP(type, pvop);
3639 Perl_package(pTHX_ OP *o)
3642 SV *const sv = cSVOPo->op_sv;
3647 save_hptr(&PL_curstash);
3648 save_item(PL_curstname);
3650 PL_curstash = gv_stashsv(sv, GV_ADD);
3651 sv_setsv(PL_curstname, sv);
3653 PL_hints |= HINT_BLOCK_SCOPE;
3654 PL_copline = NOLINE;
3660 if (!PL_madskills) {
3665 pegop = newOP(OP_NULL,0);
3666 op_getmad(o,pegop,'P');
3676 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3683 OP *pegop = newOP(OP_NULL,0);
3686 if (idop->op_type != OP_CONST)
3687 Perl_croak(aTHX_ "Module name must be constant");
3690 op_getmad(idop,pegop,'U');
3695 SV * const vesv = ((SVOP*)version)->op_sv;
3698 op_getmad(version,pegop,'V');
3699 if (!arg && !SvNIOKp(vesv)) {
3706 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3707 Perl_croak(aTHX_ "Version number must be constant number");
3709 /* Make copy of idop so we don't free it twice */
3710 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3712 /* Fake up a method call to VERSION */
3713 meth = newSVpvs_share("VERSION");
3714 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3715 append_elem(OP_LIST,
3716 prepend_elem(OP_LIST, pack, list(version)),
3717 newSVOP(OP_METHOD_NAMED, 0, meth)));
3721 /* Fake up an import/unimport */
3722 if (arg && arg->op_type == OP_STUB) {
3724 op_getmad(arg,pegop,'S');
3725 imop = arg; /* no import on explicit () */
3727 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3728 imop = NULL; /* use 5.0; */
3730 idop->op_private |= OPpCONST_NOVER;
3736 op_getmad(arg,pegop,'A');
3738 /* Make copy of idop so we don't free it twice */
3739 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3741 /* Fake up a method call to import/unimport */
3743 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3744 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3745 append_elem(OP_LIST,
3746 prepend_elem(OP_LIST, pack, list(arg)),
3747 newSVOP(OP_METHOD_NAMED, 0, meth)));
3750 /* Fake up the BEGIN {}, which does its thing immediately. */
3752 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3755 append_elem(OP_LINESEQ,
3756 append_elem(OP_LINESEQ,
3757 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3758 newSTATEOP(0, NULL, veop)),
3759 newSTATEOP(0, NULL, imop) ));
3761 /* The "did you use incorrect case?" warning used to be here.
3762 * The problem is that on case-insensitive filesystems one
3763 * might get false positives for "use" (and "require"):
3764 * "use Strict" or "require CARP" will work. This causes
3765 * portability problems for the script: in case-strict
3766 * filesystems the script will stop working.
3768 * The "incorrect case" warning checked whether "use Foo"
3769 * imported "Foo" to your namespace, but that is wrong, too:
3770 * there is no requirement nor promise in the language that
3771 * a Foo.pm should or would contain anything in package "Foo".
3773 * There is very little Configure-wise that can be done, either:
3774 * the case-sensitivity of the build filesystem of Perl does not
3775 * help in guessing the case-sensitivity of the runtime environment.
3778 PL_hints |= HINT_BLOCK_SCOPE;
3779 PL_copline = NOLINE;
3781 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3784 if (!PL_madskills) {
3785 /* FIXME - don't allocate pegop if !PL_madskills */
3794 =head1 Embedding Functions
3796 =for apidoc load_module
3798 Loads the module whose name is pointed to by the string part of name.
3799 Note that the actual module name, not its filename, should be given.
3800 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3801 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3802 (or 0 for no flags). ver, if specified, provides version semantics
3803 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3804 arguments can be used to specify arguments to the module's import()
3805 method, similar to C<use Foo::Bar VERSION LIST>.
3810 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3813 va_start(args, ver);
3814 vload_module(flags, name, ver, &args);
3818 #ifdef PERL_IMPLICIT_CONTEXT
3820 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3824 va_start(args, ver);
3825 vload_module(flags, name, ver, &args);
3831 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3836 OP * const modname = newSVOP(OP_CONST, 0, name);
3837 modname->op_private |= OPpCONST_BARE;
3839 veop = newSVOP(OP_CONST, 0, ver);
3843 if (flags & PERL_LOADMOD_NOIMPORT) {
3844 imop = sawparens(newNULLLIST());
3846 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3847 imop = va_arg(*args, OP*);
3852 sv = va_arg(*args, SV*);
3854 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3855 sv = va_arg(*args, SV*);
3859 const line_t ocopline = PL_copline;
3860 COP * const ocurcop = PL_curcop;
3861 const int oexpect = PL_expect;
3863 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3864 veop, modname, imop);
3865 PL_expect = oexpect;
3866 PL_copline = ocopline;
3867 PL_curcop = ocurcop;
3872 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3878 if (!force_builtin) {
3879 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3880 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3881 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3882 gv = gvp ? *gvp : NULL;
3886 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3887 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3888 append_elem(OP_LIST, term,
3889 scalar(newUNOP(OP_RV2CV, 0,
3890 newGVOP(OP_GV, 0, gv))))));
3893 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3899 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3901 return newBINOP(OP_LSLICE, flags,
3902 list(force_list(subscript)),
3903 list(force_list(listval)) );
3907 S_is_list_assignment(pTHX_ register const OP *o)
3915 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3916 o = cUNOPo->op_first;
3918 flags = o->op_flags;
3920 if (type == OP_COND_EXPR) {
3921 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3922 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3927 yyerror("Assignment to both a list and a scalar");
3931 if (type == OP_LIST &&
3932 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3933 o->op_private & OPpLVAL_INTRO)
3936 if (type == OP_LIST || flags & OPf_PARENS ||
3937 type == OP_RV2AV || type == OP_RV2HV ||
3938 type == OP_ASLICE || type == OP_HSLICE)
3941 if (type == OP_PADAV || type == OP_PADHV)
3944 if (type == OP_RV2SV)
3951 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3957 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3958 return newLOGOP(optype, 0,
3959 mod(scalar(left), optype),
3960 newUNOP(OP_SASSIGN, 0, scalar(right)));
3963 return newBINOP(optype, OPf_STACKED,
3964 mod(scalar(left), optype), scalar(right));
3968 if (is_list_assignment(left)) {
3972 /* Grandfathering $[ assignment here. Bletch.*/
3973 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3974 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3975 left = mod(left, OP_AASSIGN);
3978 else if (left->op_type == OP_CONST) {
3980 /* Result of assignment is always 1 (or we'd be dead already) */
3981 return newSVOP(OP_CONST, 0, newSViv(1));
3983 curop = list(force_list(left));
3984 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3985 o->op_private = (U8)(0 | (flags >> 8));
3987 /* PL_generation sorcery:
3988 * an assignment like ($a,$b) = ($c,$d) is easier than
3989 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3990 * To detect whether there are common vars, the global var
3991 * PL_generation is incremented for each assign op we compile.
3992 * Then, while compiling the assign op, we run through all the
3993 * variables on both sides of the assignment, setting a spare slot
3994 * in each of them to PL_generation. If any of them already have
3995 * that value, we know we've got commonality. We could use a
3996 * single bit marker, but then we'd have to make 2 passes, first
3997 * to clear the flag, then to test and set it. To find somewhere
3998 * to store these values, evil chicanery is done with SvUVX().
4004 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4005 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4006 if (curop->op_type == OP_GV) {
4007 GV *gv = cGVOPx_gv(curop);
4009 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4011 GvASSIGN_GENERATION_set(gv, PL_generation);
4013 else if (curop->op_type == OP_PADSV ||
4014 curop->op_type == OP_PADAV ||
4015 curop->op_type == OP_PADHV ||
4016 curop->op_type == OP_PADANY)
4018 if (PAD_COMPNAME_GEN(curop->op_targ)
4019 == (STRLEN)PL_generation)
4021 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4024 else if (curop->op_type == OP_RV2CV)
4026 else if (curop->op_type == OP_RV2SV ||
4027 curop->op_type == OP_RV2AV ||
4028 curop->op_type == OP_RV2HV ||
4029 curop->op_type == OP_RV2GV) {
4030 if (lastop->op_type != OP_GV) /* funny deref? */
4033 else if (curop->op_type == OP_PUSHRE) {
4035 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4036 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4038 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4040 GvASSIGN_GENERATION_set(gv, PL_generation);
4044 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4047 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4049 GvASSIGN_GENERATION_set(gv, PL_generation);
4059 o->op_private |= OPpASSIGN_COMMON;
4062 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
4063 && (left->op_type == OP_LIST
4064 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4066 OP* lop = ((LISTOP*)left)->op_first;
4068 if (lop->op_type == OP_PADSV ||
4069 lop->op_type == OP_PADAV ||
4070 lop->op_type == OP_PADHV ||
4071 lop->op_type == OP_PADANY)
4073 if (lop->op_private & OPpPAD_STATE) {
4074 if (left->op_private & OPpLVAL_INTRO) {
4075 o->op_private |= OPpASSIGN_STATE;
4076 /* hijacking PADSTALE for uninitialized state variables */
4077 SvPADSTALE_on(PAD_SVl(lop->op_targ));
4079 else { /* we already checked for WARN_MISC before */
4080 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
4081 PAD_COMPNAME_PV(lop->op_targ));
4085 lop = lop->op_sibling;
4088 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4089 == (OPpLVAL_INTRO | OPpPAD_STATE))
4090 && ( left->op_type == OP_PADSV
4091 || left->op_type == OP_PADAV
4092 || left->op_type == OP_PADHV
4093 || left->op_type == OP_PADANY))
4095 o->op_private |= OPpASSIGN_STATE;
4096 /* hijacking PADSTALE for uninitialized state variables */
4097 SvPADSTALE_on(PAD_SVl(left->op_targ));
4100 if (right && right->op_type == OP_SPLIT) {
4101 OP* tmpop = ((LISTOP*)right)->op_first;
4102 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4103 PMOP * const pm = (PMOP*)tmpop;
4104 if (left->op_type == OP_RV2AV &&
4105 !(left->op_private & OPpLVAL_INTRO) &&
4106 !(o->op_private & OPpASSIGN_COMMON) )
4108 tmpop = ((UNOP*)left)->op_first;
4109 if (tmpop->op_type == OP_GV
4111 && !pm->op_pmreplrootu.op_pmtargetoff
4113 && !pm->op_pmreplrootu.op_pmtargetgv
4117 pm->op_pmreplrootu.op_pmtargetoff
4118 = cPADOPx(tmpop)->op_padix;
4119 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4121 pm->op_pmreplrootu.op_pmtargetgv
4122 = (GV*)cSVOPx(tmpop)->op_sv;
4123 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4125 pm->op_pmflags |= PMf_ONCE;
4126 tmpop = cUNOPo->op_first; /* to list (nulled) */
4127 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4128 tmpop->op_sibling = NULL; /* don't free split */
4129 right->op_next = tmpop->op_next; /* fix starting loc */
4131 op_getmad(o,right,'R'); /* blow off assign */
4133 op_free(o); /* blow off assign */
4135 right->op_flags &= ~OPf_WANT;
4136 /* "I don't know and I don't care." */
4141 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4142 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4144 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4146 sv_setiv(sv, PL_modcount+1);
4154 right = newOP(OP_UNDEF, 0);
4155 if (right->op_type == OP_READLINE) {
4156 right->op_flags |= OPf_STACKED;
4157 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4160 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4161 o = newBINOP(OP_SASSIGN, flags,
4162 scalar(right), mod(scalar(left), OP_SASSIGN) );
4168 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4169 o->op_private |= OPpCONST_ARYBASE;
4176 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4179 const U32 seq = intro_my();
4182 NewOp(1101, cop, 1, COP);
4183 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4184 cop->op_type = OP_DBSTATE;
4185 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4188 cop->op_type = OP_NEXTSTATE;
4189 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4191 cop->op_flags = (U8)flags;
4192 CopHINTS_set(cop, PL_hints);
4194 cop->op_private |= NATIVE_HINTS;
4196 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4197 cop->op_next = (OP*)cop;
4200 CopLABEL_set(cop, label);
4201 PL_hints |= HINT_BLOCK_SCOPE;
4204 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4205 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4207 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4208 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4209 if (cop->cop_hints_hash) {
4211 cop->cop_hints_hash->refcounted_he_refcnt++;
4212 HINTS_REFCNT_UNLOCK;
4215 if (PL_copline == NOLINE)
4216 CopLINE_set(cop, CopLINE(PL_curcop));
4218 CopLINE_set(cop, PL_copline);
4219 PL_copline = NOLINE;
4222 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4224 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4226 CopSTASH_set(cop, PL_curstash);
4228 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4229 AV *av = CopFILEAVx(PL_curcop);
4231 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4232 if (svp && *svp != &PL_sv_undef ) {
4233 (void)SvIOK_on(*svp);
4234 SvIV_set(*svp, PTR2IV(cop));
4239 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4244 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4247 return new_logop(type, flags, &first, &other);
4251 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4256 OP *first = *firstp;
4257 OP * const other = *otherp;
4259 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4260 return newBINOP(type, flags, scalar(first), scalar(other));
4262 scalarboolean(first);
4263 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4264 if (first->op_type == OP_NOT
4265 && (first->op_flags & OPf_SPECIAL)
4266 && (first->op_flags & OPf_KIDS)) {
4267 if (type == OP_AND || type == OP_OR) {
4273 first = *firstp = cUNOPo->op_first;
4275 first->op_next = o->op_next;
4276 cUNOPo->op_first = NULL;
4278 op_getmad(o,first,'O');
4284 if (first->op_type == OP_CONST) {
4285 if (first->op_private & OPpCONST_STRICT)
4286 no_bareword_allowed(first);
4287 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4288 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4289 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4290 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4291 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4293 if (other->op_type == OP_CONST)
4294 other->op_private |= OPpCONST_SHORTCIRCUIT;
4296 OP *newop = newUNOP(OP_NULL, 0, other);
4297 op_getmad(first, newop, '1');
4298 newop->op_targ = type; /* set "was" field */
4305 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4306 const OP *o2 = other;
4307 if ( ! (o2->op_type == OP_LIST
4308 && (( o2 = cUNOPx(o2)->op_first))
4309 && o2->op_type == OP_PUSHMARK
4310 && (( o2 = o2->op_sibling)) )
4313 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4314 || o2->op_type == OP_PADHV)
4315 && o2->op_private & OPpLVAL_INTRO
4316 && ckWARN(WARN_DEPRECATED))
4318 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4319 "Deprecated use of my() in false conditional");
4323 if (first->op_type == OP_CONST)
4324 first->op_private |= OPpCONST_SHORTCIRCUIT;
4326 first = newUNOP(OP_NULL, 0, first);
4327 op_getmad(other, first, '2');
4328 first->op_targ = type; /* set "was" field */
4335 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4336 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4338 const OP * const k1 = ((UNOP*)first)->op_first;
4339 const OP * const k2 = k1->op_sibling;
4341 switch (first->op_type)
4344 if (k2 && k2->op_type == OP_READLINE
4345 && (k2->op_flags & OPf_STACKED)
4346 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4348 warnop = k2->op_type;
4353 if (k1->op_type == OP_READDIR
4354 || k1->op_type == OP_GLOB
4355 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4356 || k1->op_type == OP_EACH)
4358 warnop = ((k1->op_type == OP_NULL)
4359 ? (OPCODE)k1->op_targ : k1->op_type);
4364 const line_t oldline = CopLINE(PL_curcop);
4365 CopLINE_set(PL_curcop, PL_copline);
4366 Perl_warner(aTHX_ packWARN(WARN_MISC),
4367 "Value of %s%s can be \"0\"; test with defined()",
4369 ((warnop == OP_READLINE || warnop == OP_GLOB)
4370 ? " construct" : "() operator"));
4371 CopLINE_set(PL_curcop, oldline);
4378 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4379 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4381 NewOp(1101, logop, 1, LOGOP);
4383 logop->op_type = (OPCODE)type;
4384 logop->op_ppaddr = PL_ppaddr[type];
4385 logop->op_first = first;
4386 logop->op_flags = (U8)(flags | OPf_KIDS);
4387 logop->op_other = LINKLIST(other);
4388 logop->op_private = (U8)(1 | (flags >> 8));
4390 /* establish postfix order */
4391 logop->op_next = LINKLIST(first);
4392 first->op_next = (OP*)logop;
4393 first->op_sibling = other;
4395 CHECKOP(type,logop);
4397 o = newUNOP(OP_NULL, 0, (OP*)logop);
4404 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4412 return newLOGOP(OP_AND, 0, first, trueop);
4414 return newLOGOP(OP_OR, 0, first, falseop);
4416 scalarboolean(first);
4417 if (first->op_type == OP_CONST) {
4418 /* Left or right arm of the conditional? */
4419 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4420 OP *live = left ? trueop : falseop;
4421 OP *const dead = left ? falseop : trueop;
4422 if (first->op_private & OPpCONST_BARE &&
4423 first->op_private & OPpCONST_STRICT) {
4424 no_bareword_allowed(first);
4427 /* This is all dead code when PERL_MAD is not defined. */
4428 live = newUNOP(OP_NULL, 0, live);
4429 op_getmad(first, live, 'C');
4430 op_getmad(dead, live, left ? 'e' : 't');
4437 NewOp(1101, logop, 1, LOGOP);
4438 logop->op_type = OP_COND_EXPR;
4439 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4440 logop->op_first = first;
4441 logop->op_flags = (U8)(flags | OPf_KIDS);
4442 logop->op_private = (U8)(1 | (flags >> 8));
4443 logop->op_other = LINKLIST(trueop);
4444 logop->op_next = LINKLIST(falseop);
4446 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4449 /* establish postfix order */
4450 start = LINKLIST(first);
4451 first->op_next = (OP*)logop;
4453 first->op_sibling = trueop;
4454 trueop->op_sibling = falseop;
4455 o = newUNOP(OP_NULL, 0, (OP*)logop);
4457 trueop->op_next = falseop->op_next = o;
4464 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4473 NewOp(1101, range, 1, LOGOP);
4475 range->op_type = OP_RANGE;
4476 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4477 range->op_first = left;
4478 range->op_flags = OPf_KIDS;
4479 leftstart = LINKLIST(left);
4480 range->op_other = LINKLIST(right);
4481 range->op_private = (U8)(1 | (flags >> 8));
4483 left->op_sibling = right;
4485 range->op_next = (OP*)range;
4486 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4487 flop = newUNOP(OP_FLOP, 0, flip);
4488 o = newUNOP(OP_NULL, 0, flop);
4490 range->op_next = leftstart;
4492 left->op_next = flip;
4493 right->op_next = flop;
4495 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4496 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4497 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4498 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4500 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4501 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4504 if (!flip->op_private || !flop->op_private)
4505 linklist(o); /* blow off optimizer unless constant */
4511 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4516 const bool once = block && block->op_flags & OPf_SPECIAL &&
4517 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4519 PERL_UNUSED_ARG(debuggable);
4522 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4523 return block; /* do {} while 0 does once */
4524 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4525 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4526 expr = newUNOP(OP_DEFINED, 0,
4527 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4528 } else if (expr->op_flags & OPf_KIDS) {
4529 const OP * const k1 = ((UNOP*)expr)->op_first;
4530 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4531 switch (expr->op_type) {
4533 if (k2 && k2->op_type == OP_READLINE
4534 && (k2->op_flags & OPf_STACKED)
4535 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4536 expr = newUNOP(OP_DEFINED, 0, expr);
4540 if (k1 && (k1->op_type == OP_READDIR
4541 || k1->op_type == OP_GLOB
4542 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4543 || k1->op_type == OP_EACH))
4544 expr = newUNOP(OP_DEFINED, 0, expr);
4550 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4551 * op, in listop. This is wrong. [perl #27024] */
4553 block = newOP(OP_NULL, 0);
4554 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4555 o = new_logop(OP_AND, 0, &expr, &listop);
4558 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4560 if (once && o != listop)
4561 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4564 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4566 o->op_flags |= flags;
4568 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4573 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4574 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4583 PERL_UNUSED_ARG(debuggable);
4586 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4587 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4588 expr = newUNOP(OP_DEFINED, 0,
4589 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4590 } else if (expr->op_flags & OPf_KIDS) {
4591 const OP * const k1 = ((UNOP*)expr)->op_first;
4592 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4593 switch (expr->op_type) {
4595 if (k2 && k2->op_type == OP_READLINE
4596 && (k2->op_flags & OPf_STACKED)
4597 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4598 expr = newUNOP(OP_DEFINED, 0, expr);
4602 if (k1 && (k1->op_type == OP_READDIR
4603 || k1->op_type == OP_GLOB
4604 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4605 || k1->op_type == OP_EACH))
4606 expr = newUNOP(OP_DEFINED, 0, expr);
4613 block = newOP(OP_NULL, 0);
4614 else if (cont || has_my) {
4615 block = scope(block);
4619 next = LINKLIST(cont);
4622 OP * const unstack = newOP(OP_UNSTACK, 0);
4625 cont = append_elem(OP_LINESEQ, cont, unstack);
4629 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4631 redo = LINKLIST(listop);
4634 PL_copline = (line_t)whileline;
4636 o = new_logop(OP_AND, 0, &expr, &listop);
4637 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4638 op_free(expr); /* oops, it's a while (0) */
4640 return NULL; /* listop already freed by new_logop */
4643 ((LISTOP*)listop)->op_last->op_next =
4644 (o == listop ? redo : LINKLIST(o));
4650 NewOp(1101,loop,1,LOOP);
4651 loop->op_type = OP_ENTERLOOP;
4652 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4653 loop->op_private = 0;
4654 loop->op_next = (OP*)loop;
4657 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4659 loop->op_redoop = redo;
4660 loop->op_lastop = o;
4661 o->op_private |= loopflags;
4664 loop->op_nextop = next;
4666 loop->op_nextop = o;
4668 o->op_flags |= flags;
4669 o->op_private |= (flags >> 8);
4674 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4679 PADOFFSET padoff = 0;
4685 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4686 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4687 sv->op_type = OP_RV2GV;
4688 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4690 /* The op_type check is needed to prevent a possible segfault
4691 * if the loop variable is undeclared and 'strict vars' is in
4692 * effect. This is illegal but is nonetheless parsed, so we
4693 * may reach this point with an OP_CONST where we're expecting
4696 if (cUNOPx(sv)->op_first->op_type == OP_GV
4697 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4698 iterpflags |= OPpITER_DEF;
4700 else if (sv->op_type == OP_PADSV) { /* private variable */
4701 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4702 padoff = sv->op_targ;
4712 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4714 SV *const namesv = PAD_COMPNAME_SV(padoff);
4716 const char *const name = SvPV_const(namesv, len);
4718 if (len == 2 && name[0] == '$' && name[1] == '_')
4719 iterpflags |= OPpITER_DEF;
4723 const PADOFFSET offset = pad_findmy("$_");
4724 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4725 sv = newGVOP(OP_GV, 0, PL_defgv);
4730 iterpflags |= OPpITER_DEF;
4732 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4733 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4734 iterflags |= OPf_STACKED;
4736 else if (expr->op_type == OP_NULL &&
4737 (expr->op_flags & OPf_KIDS) &&
4738 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4740 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4741 * set the STACKED flag to indicate that these values are to be
4742 * treated as min/max values by 'pp_iterinit'.
4744 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4745 LOGOP* const range = (LOGOP*) flip->op_first;
4746 OP* const left = range->op_first;
4747 OP* const right = left->op_sibling;
4750 range->op_flags &= ~OPf_KIDS;
4751 range->op_first = NULL;
4753 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4754 listop->op_first->op_next = range->op_next;
4755 left->op_next = range->op_other;
4756 right->op_next = (OP*)listop;
4757 listop->op_next = listop->op_first;
4760 op_getmad(expr,(OP*)listop,'O');
4764 expr = (OP*)(listop);
4766 iterflags |= OPf_STACKED;
4769 expr = mod(force_list(expr), OP_GREPSTART);
4772 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4773 append_elem(OP_LIST, expr, scalar(sv))));
4774 assert(!loop->op_next);
4775 /* for my $x () sets OPpLVAL_INTRO;
4776 * for our $x () sets OPpOUR_INTRO */
4777 loop->op_private = (U8)iterpflags;
4778 #ifdef PL_OP_SLAB_ALLOC
4781 NewOp(1234,tmp,1,LOOP);
4782 Copy(loop,tmp,1,LISTOP);
4783 S_op_destroy(aTHX_ (OP*)loop);
4787 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4789 loop->op_targ = padoff;
4790 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4792 op_getmad(madsv, (OP*)loop, 'v');
4793 PL_copline = forline;
4794 return newSTATEOP(0, label, wop);
4798 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4803 if (type != OP_GOTO || label->op_type == OP_CONST) {
4804 /* "last()" means "last" */
4805 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4806 o = newOP(type, OPf_SPECIAL);
4808 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4809 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4813 op_getmad(label,o,'L');
4819 /* Check whether it's going to be a goto &function */
4820 if (label->op_type == OP_ENTERSUB
4821 && !(label->op_flags & OPf_STACKED))
4822 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4823 o = newUNOP(type, OPf_STACKED, label);
4825 PL_hints |= HINT_BLOCK_SCOPE;
4829 /* if the condition is a literal array or hash
4830 (or @{ ... } etc), make a reference to it.
4833 S_ref_array_or_hash(pTHX_ OP *cond)
4836 && (cond->op_type == OP_RV2AV
4837 || cond->op_type == OP_PADAV
4838 || cond->op_type == OP_RV2HV
4839 || cond->op_type == OP_PADHV))
4841 return newUNOP(OP_REFGEN,
4842 0, mod(cond, OP_REFGEN));
4848 /* These construct the optree fragments representing given()
4851 entergiven and enterwhen are LOGOPs; the op_other pointer
4852 points up to the associated leave op. We need this so we
4853 can put it in the context and make break/continue work.
4854 (Also, of course, pp_enterwhen will jump straight to
4855 op_other if the match fails.)
4859 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4860 I32 enter_opcode, I32 leave_opcode,
4861 PADOFFSET entertarg)
4867 NewOp(1101, enterop, 1, LOGOP);
4868 enterop->op_type = enter_opcode;
4869 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4870 enterop->op_flags = (U8) OPf_KIDS;
4871 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4872 enterop->op_private = 0;
4874 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4877 enterop->op_first = scalar(cond);
4878 cond->op_sibling = block;
4880 o->op_next = LINKLIST(cond);
4881 cond->op_next = (OP *) enterop;
4884 /* This is a default {} block */
4885 enterop->op_first = block;
4886 enterop->op_flags |= OPf_SPECIAL;
4888 o->op_next = (OP *) enterop;
4891 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4892 entergiven and enterwhen both
4895 enterop->op_next = LINKLIST(block);
4896 block->op_next = enterop->op_other = o;
4901 /* Does this look like a boolean operation? For these purposes
4902 a boolean operation is:
4903 - a subroutine call [*]
4904 - a logical connective
4905 - a comparison operator
4906 - a filetest operator, with the exception of -s -M -A -C
4907 - defined(), exists() or eof()
4908 - /$re/ or $foo =~ /$re/
4910 [*] possibly surprising
4913 S_looks_like_bool(pTHX_ const OP *o)
4916 switch(o->op_type) {
4918 return looks_like_bool(cLOGOPo->op_first);
4922 looks_like_bool(cLOGOPo->op_first)
4923 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4927 case OP_NOT: case OP_XOR:
4928 /* Note that OP_DOR is not here */
4930 case OP_EQ: case OP_NE: case OP_LT:
4931 case OP_GT: case OP_LE: case OP_GE:
4933 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4934 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4936 case OP_SEQ: case OP_SNE: case OP_SLT:
4937 case OP_SGT: case OP_SLE: case OP_SGE:
4941 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4942 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4943 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4944 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4945 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4946 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4947 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4948 case OP_FTTEXT: case OP_FTBINARY:
4950 case OP_DEFINED: case OP_EXISTS:
4951 case OP_MATCH: case OP_EOF:
4956 /* Detect comparisons that have been optimized away */
4957 if (cSVOPo->op_sv == &PL_sv_yes
4958 || cSVOPo->op_sv == &PL_sv_no)
4969 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4973 return newGIVWHENOP(
4974 ref_array_or_hash(cond),
4976 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4980 /* If cond is null, this is a default {} block */
4982 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4984 const bool cond_llb = (!cond || looks_like_bool(cond));
4990 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4992 scalar(ref_array_or_hash(cond)));
4995 return newGIVWHENOP(
4997 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4998 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5002 =for apidoc cv_undef
5004 Clear out all the active components of a CV. This can happen either
5005 by an explicit C<undef &foo>, or by the reference count going to zero.
5006 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5007 children can still follow the full lexical scope chain.
5013 Perl_cv_undef(pTHX_ CV *cv)
5017 if (CvFILE(cv) && !CvISXSUB(cv)) {
5018 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5019 Safefree(CvFILE(cv));
5024 if (!CvISXSUB(cv) && CvROOT(cv)) {
5025 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5026 Perl_croak(aTHX_ "Can't undef active subroutine");
5029 PAD_SAVE_SETNULLPAD();
5031 op_free(CvROOT(cv));
5036 SvPOK_off((SV*)cv); /* forget prototype */
5041 /* remove CvOUTSIDE unless this is an undef rather than a free */
5042 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5043 if (!CvWEAKOUTSIDE(cv))
5044 SvREFCNT_dec(CvOUTSIDE(cv));
5045 CvOUTSIDE(cv) = NULL;
5048 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5051 if (CvISXSUB(cv) && CvXSUB(cv)) {
5054 /* delete all flags except WEAKOUTSIDE */
5055 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5059 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5062 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5063 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5064 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5065 || (p && (len != SvCUR(cv) /* Not the same length. */
5066 || memNE(p, SvPVX_const(cv), len))))
5067 && ckWARN_d(WARN_PROTOTYPE)) {
5068 SV* const msg = sv_newmortal();
5072 gv_efullname3(name = sv_newmortal(), gv, NULL);
5073 sv_setpvs(msg, "Prototype mismatch:");
5075 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5077 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5079 sv_catpvs(msg, ": none");
5080 sv_catpvs(msg, " vs ");
5082 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5084 sv_catpvs(msg, "none");
5085 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5089 static void const_sv_xsub(pTHX_ CV* cv);
5093 =head1 Optree Manipulation Functions
5095 =for apidoc cv_const_sv
5097 If C<cv> is a constant sub eligible for inlining. returns the constant
5098 value returned by the sub. Otherwise, returns NULL.
5100 Constant subs can be created with C<newCONSTSUB> or as described in
5101 L<perlsub/"Constant Functions">.
5106 Perl_cv_const_sv(pTHX_ CV *cv)
5108 PERL_UNUSED_CONTEXT;
5111 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5113 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5116 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5117 * Can be called in 3 ways:
5120 * look for a single OP_CONST with attached value: return the value
5122 * cv && CvCLONE(cv) && !CvCONST(cv)
5124 * examine the clone prototype, and if contains only a single
5125 * OP_CONST referencing a pad const, or a single PADSV referencing
5126 * an outer lexical, return a non-zero value to indicate the CV is
5127 * a candidate for "constizing" at clone time
5131 * We have just cloned an anon prototype that was marked as a const
5132 * candidiate. Try to grab the current value, and in the case of
5133 * PADSV, ignore it if it has multiple references. Return the value.
5137 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5145 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5146 o = cLISTOPo->op_first->op_sibling;
5148 for (; o; o = o->op_next) {
5149 const OPCODE type = o->op_type;
5151 if (sv && o->op_next == o)
5153 if (o->op_next != o) {
5154 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5156 if (type == OP_DBSTATE)
5159 if (type == OP_LEAVESUB || type == OP_RETURN)
5163 if (type == OP_CONST && cSVOPo->op_sv)
5165 else if (cv && type == OP_CONST) {
5166 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5170 else if (cv && type == OP_PADSV) {
5171 if (CvCONST(cv)) { /* newly cloned anon */
5172 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5173 /* the candidate should have 1 ref from this pad and 1 ref
5174 * from the parent */
5175 if (!sv || SvREFCNT(sv) != 2)
5182 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5183 sv = &PL_sv_undef; /* an arbitrary non-null value */
5198 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5201 /* This would be the return value, but the return cannot be reached. */
5202 OP* pegop = newOP(OP_NULL, 0);
5205 PERL_UNUSED_ARG(floor);
5215 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5217 NORETURN_FUNCTION_END;
5222 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5224 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5228 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5235 register CV *cv = NULL;
5237 /* If the subroutine has no body, no attributes, and no builtin attributes
5238 then it's just a sub declaration, and we may be able to get away with
5239 storing with a placeholder scalar in the symbol table, rather than a
5240 full GV and CV. If anything is present then it will take a full CV to
5242 const I32 gv_fetch_flags
5243 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5245 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5246 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5249 assert(proto->op_type == OP_CONST);
5250 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5255 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5256 SV * const sv = sv_newmortal();
5257 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5258 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5259 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5260 aname = SvPVX_const(sv);
5265 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5266 : gv_fetchpv(aname ? aname
5267 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5268 gv_fetch_flags, SVt_PVCV);
5270 if (!PL_madskills) {
5279 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5280 maximum a prototype before. */
5281 if (SvTYPE(gv) > SVt_NULL) {
5282 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5283 && ckWARN_d(WARN_PROTOTYPE))
5285 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5287 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5290 sv_setpvn((SV*)gv, ps, ps_len);
5292 sv_setiv((SV*)gv, -1);
5293 SvREFCNT_dec(PL_compcv);
5294 cv = PL_compcv = NULL;
5295 PL_sub_generation++;
5299 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5301 #ifdef GV_UNIQUE_CHECK
5302 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5303 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5307 if (!block || !ps || *ps || attrs
5308 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5310 || block->op_type == OP_NULL
5315 const_sv = op_const_sv(block, NULL);
5318 const bool exists = CvROOT(cv) || CvXSUB(cv);
5320 #ifdef GV_UNIQUE_CHECK
5321 if (exists && GvUNIQUE(gv)) {
5322 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5326 /* if the subroutine doesn't exist and wasn't pre-declared
5327 * with a prototype, assume it will be AUTOLOADed,
5328 * skipping the prototype check
5330 if (exists || SvPOK(cv))
5331 cv_ckproto_len(cv, gv, ps, ps_len);
5332 /* already defined (or promised)? */
5333 if (exists || GvASSUMECV(gv)) {
5336 || block->op_type == OP_NULL
5339 if (CvFLAGS(PL_compcv)) {
5340 /* might have had built-in attrs applied */
5341 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5343 /* just a "sub foo;" when &foo is already defined */
5344 SAVEFREESV(PL_compcv);
5349 && block->op_type != OP_NULL
5352 if (ckWARN(WARN_REDEFINE)
5354 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5356 const line_t oldline = CopLINE(PL_curcop);
5357 if (PL_copline != NOLINE)
5358 CopLINE_set(PL_curcop, PL_copline);
5359 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5360 CvCONST(cv) ? "Constant subroutine %s redefined"
5361 : "Subroutine %s redefined", name);
5362 CopLINE_set(PL_curcop, oldline);
5365 if (!PL_minus_c) /* keep old one around for madskills */
5368 /* (PL_madskills unset in used file.) */
5376 SvREFCNT_inc_simple_void_NN(const_sv);
5378 assert(!CvROOT(cv) && !CvCONST(cv));
5379 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5380 CvXSUBANY(cv).any_ptr = const_sv;
5381 CvXSUB(cv) = const_sv_xsub;
5387 cv = newCONSTSUB(NULL, name, const_sv);
5389 PL_sub_generation++;
5393 SvREFCNT_dec(PL_compcv);
5401 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5402 * before we clobber PL_compcv.
5406 || block->op_type == OP_NULL
5410 /* Might have had built-in attributes applied -- propagate them. */
5411 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5412 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5413 stash = GvSTASH(CvGV(cv));
5414 else if (CvSTASH(cv))
5415 stash = CvSTASH(cv);
5417 stash = PL_curstash;
5420 /* possibly about to re-define existing subr -- ignore old cv */
5421 rcv = (SV*)PL_compcv;
5422 if (name && GvSTASH(gv))
5423 stash = GvSTASH(gv);
5425 stash = PL_curstash;
5427 apply_attrs(stash, rcv, attrs, FALSE);
5429 if (cv) { /* must reuse cv if autoloaded */
5436 || block->op_type == OP_NULL) && !PL_madskills
5439 /* got here with just attrs -- work done, so bug out */
5440 SAVEFREESV(PL_compcv);
5443 /* transfer PL_compcv to cv */
5445 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5446 if (!CvWEAKOUTSIDE(cv))
5447 SvREFCNT_dec(CvOUTSIDE(cv));
5448 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5449 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5450 CvOUTSIDE(PL_compcv) = 0;
5451 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5452 CvPADLIST(PL_compcv) = 0;
5453 /* inner references to PL_compcv must be fixed up ... */
5454 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5455 /* ... before we throw it away */
5456 SvREFCNT_dec(PL_compcv);
5458 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5459 ++PL_sub_generation;
5466 if (strEQ(name, "import")) {
5467 PL_formfeed = (SV*)cv;
5468 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5472 PL_sub_generation++;
5476 CvFILE_set_from_cop(cv, PL_curcop);
5477 CvSTASH(cv) = PL_curstash;
5480 sv_setpvn((SV*)cv, ps, ps_len);
5482 if (PL_error_count) {
5486 const char *s = strrchr(name, ':');
5488 if (strEQ(s, "BEGIN")) {
5489 const char not_safe[] =
5490 "BEGIN not safe after errors--compilation aborted";
5491 if (PL_in_eval & EVAL_KEEPERR)
5492 Perl_croak(aTHX_ not_safe);
5494 /* force display of errors found but not reported */
5495 sv_catpv(ERRSV, not_safe);
5496 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5506 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5507 mod(scalarseq(block), OP_LEAVESUBLV));
5508 block->op_attached = 1;
5511 /* This makes sub {}; work as expected. */
5512 if (block->op_type == OP_STUB) {
5513 OP* const newblock = newSTATEOP(0, NULL, 0);
5515 op_getmad(block,newblock,'B');
5522 block->op_attached = 1;
5523 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5525 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5526 OpREFCNT_set(CvROOT(cv), 1);
5527 CvSTART(cv) = LINKLIST(CvROOT(cv));
5528 CvROOT(cv)->op_next = 0;
5529 CALL_PEEP(CvSTART(cv));
5531 /* now that optimizer has done its work, adjust pad values */
5533 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5536 assert(!CvCONST(cv));
5537 if (ps && !*ps && op_const_sv(block, cv))
5541 if (name || aname) {
5542 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5543 SV * const sv = newSV(0);
5544 SV * const tmpstr = sv_newmortal();
5545 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5546 GV_ADDMULTI, SVt_PVHV);
5549 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5551 (long)PL_subline, (long)CopLINE(PL_curcop));
5552 gv_efullname3(tmpstr, gv, NULL);
5553 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5554 hv = GvHVn(db_postponed);
5555 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5556 CV * const pcv = GvCV(db_postponed);
5562 call_sv((SV*)pcv, G_DISCARD);
5567 if (name && !PL_error_count)
5568 process_special_blocks(name, gv, cv);
5572 PL_copline = NOLINE;
5578 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5581 const char *const colon = strrchr(fullname,':');
5582 const char *const name = colon ? colon + 1 : fullname;
5585 if (strEQ(name, "BEGIN")) {
5586 const I32 oldscope = PL_scopestack_ix;
5588 SAVECOPFILE(&PL_compiling);
5589 SAVECOPLINE(&PL_compiling);
5591 DEBUG_x( dump_sub(gv) );
5592 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5593 GvCV(gv) = 0; /* cv has been hijacked */
5594 call_list(oldscope, PL_beginav);
5596 PL_curcop = &PL_compiling;
5597 CopHINTS_set(&PL_compiling, PL_hints);
5604 if strEQ(name, "END") {
5605 DEBUG_x( dump_sub(gv) );
5606 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5609 } else if (*name == 'U') {
5610 if (strEQ(name, "UNITCHECK")) {
5611 /* It's never too late to run a unitcheck block */
5612 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5616 } else if (*name == 'C') {
5617 if (strEQ(name, "CHECK")) {
5618 if (PL_main_start && ckWARN(WARN_VOID))
5619 Perl_warner(aTHX_ packWARN(WARN_VOID),
5620 "Too late to run CHECK block");
5621 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5625 } else if (*name == 'I') {
5626 if (strEQ(name, "INIT")) {
5627 if (PL_main_start && ckWARN(WARN_VOID))
5628 Perl_warner(aTHX_ packWARN(WARN_VOID),
5629 "Too late to run INIT block");
5630 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5636 DEBUG_x( dump_sub(gv) );
5637 GvCV(gv) = 0; /* cv has been hijacked */
5642 =for apidoc newCONSTSUB
5644 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5645 eligible for inlining at compile-time.
5651 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5656 const char *const temp_p = CopFILE(PL_curcop);
5657 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5659 SV *const temp_sv = CopFILESV(PL_curcop);
5661 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5663 char *const file = savepvn(temp_p, temp_p ? len : 0);
5667 SAVECOPLINE(PL_curcop);
5668 CopLINE_set(PL_curcop, PL_copline);
5671 PL_hints &= ~HINT_BLOCK_SCOPE;
5674 SAVESPTR(PL_curstash);
5675 SAVECOPSTASH(PL_curcop);
5676 PL_curstash = stash;
5677 CopSTASH_set(PL_curcop,stash);
5680 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5681 and so doesn't get free()d. (It's expected to be from the C pre-
5682 processor __FILE__ directive). But we need a dynamically allocated one,
5683 and we need it to get freed. */
5684 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5685 CvXSUBANY(cv).any_ptr = sv;
5691 CopSTASH_free(PL_curcop);
5699 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5700 const char *const filename, const char *const proto,
5703 CV *cv = newXS(name, subaddr, filename);
5705 if (flags & XS_DYNAMIC_FILENAME) {
5706 /* We need to "make arrangements" (ie cheat) to ensure that the
5707 filename lasts as long as the PVCV we just created, but also doesn't
5709 STRLEN filename_len = strlen(filename);
5710 STRLEN proto_and_file_len = filename_len;
5711 char *proto_and_file;
5715 proto_len = strlen(proto);
5716 proto_and_file_len += proto_len;
5718 Newx(proto_and_file, proto_and_file_len + 1, char);
5719 Copy(proto, proto_and_file, proto_len, char);
5720 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5723 proto_and_file = savepvn(filename, filename_len);
5726 /* This gets free()d. :-) */
5727 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5728 SV_HAS_TRAILING_NUL);
5730 /* This gives us the correct prototype, rather than one with the
5731 file name appended. */
5732 SvCUR_set(cv, proto_len);
5736 CvFILE(cv) = proto_and_file + proto_len;
5738 sv_setpv((SV *)cv, proto);
5744 =for apidoc U||newXS
5746 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5747 static storage, as it is used directly as CvFILE(), without a copy being made.
5753 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5756 GV * const gv = gv_fetchpv(name ? name :
5757 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5758 GV_ADDMULTI, SVt_PVCV);
5762 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5764 if ((cv = (name ? GvCV(gv) : NULL))) {
5766 /* just a cached method */
5770 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5771 /* already defined (or promised) */
5772 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5773 if (ckWARN(WARN_REDEFINE)) {
5774 GV * const gvcv = CvGV(cv);
5776 HV * const stash = GvSTASH(gvcv);
5778 const char *redefined_name = HvNAME_get(stash);
5779 if ( strEQ(redefined_name,"autouse") ) {
5780 const line_t oldline = CopLINE(PL_curcop);
5781 if (PL_copline != NOLINE)
5782 CopLINE_set(PL_curcop, PL_copline);
5783 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5784 CvCONST(cv) ? "Constant subroutine %s redefined"
5785 : "Subroutine %s redefined"
5787 CopLINE_set(PL_curcop, oldline);
5797 if (cv) /* must reuse cv if autoloaded */
5800 cv = (CV*)newSV_type(SVt_PVCV);
5804 PL_sub_generation++;
5808 (void)gv_fetchfile(filename);
5809 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5810 an external constant string */
5812 CvXSUB(cv) = subaddr;
5815 process_special_blocks(name, gv, cv);
5827 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5832 OP* pegop = newOP(OP_NULL, 0);
5836 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5837 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5839 #ifdef GV_UNIQUE_CHECK
5841 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5845 if ((cv = GvFORM(gv))) {
5846 if (ckWARN(WARN_REDEFINE)) {
5847 const line_t oldline = CopLINE(PL_curcop);
5848 if (PL_copline != NOLINE)
5849 CopLINE_set(PL_curcop, PL_copline);
5850 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5851 o ? "Format %"SVf" redefined"
5852 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5853 CopLINE_set(PL_curcop, oldline);
5860 CvFILE_set_from_cop(cv, PL_curcop);
5863 pad_tidy(padtidy_FORMAT);
5864 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5865 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5866 OpREFCNT_set(CvROOT(cv), 1);
5867 CvSTART(cv) = LINKLIST(CvROOT(cv));
5868 CvROOT(cv)->op_next = 0;
5869 CALL_PEEP(CvSTART(cv));
5871 op_getmad(o,pegop,'n');
5872 op_getmad_weak(block, pegop, 'b');
5876 PL_copline = NOLINE;
5884 Perl_newANONLIST(pTHX_ OP *o)
5886 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5890 Perl_newANONHASH(pTHX_ OP *o)
5892 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5896 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5898 return newANONATTRSUB(floor, proto, NULL, block);
5902 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5904 return newUNOP(OP_REFGEN, 0,
5905 newSVOP(OP_ANONCODE, 0,
5906 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5910 Perl_oopsAV(pTHX_ OP *o)
5913 switch (o->op_type) {
5915 o->op_type = OP_PADAV;
5916 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5917 return ref(o, OP_RV2AV);
5920 o->op_type = OP_RV2AV;
5921 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5926 if (ckWARN_d(WARN_INTERNAL))
5927 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5934 Perl_oopsHV(pTHX_ OP *o)
5937 switch (o->op_type) {
5940 o->op_type = OP_PADHV;
5941 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5942 return ref(o, OP_RV2HV);
5946 o->op_type = OP_RV2HV;
5947 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5952 if (ckWARN_d(WARN_INTERNAL))
5953 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5960 Perl_newAVREF(pTHX_ OP *o)
5963 if (o->op_type == OP_PADANY) {
5964 o->op_type = OP_PADAV;
5965 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5968 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5969 && ckWARN(WARN_DEPRECATED)) {
5970 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5971 "Using an array as a reference is deprecated");
5973 return newUNOP(OP_RV2AV, 0, scalar(o));
5977 Perl_newGVREF(pTHX_ I32 type, OP *o)
5979 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5980 return newUNOP(OP_NULL, 0, o);
5981 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5985 Perl_newHVREF(pTHX_ OP *o)
5988 if (o->op_type == OP_PADANY) {
5989 o->op_type = OP_PADHV;
5990 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5993 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5994 && ckWARN(WARN_DEPRECATED)) {
5995 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5996 "Using a hash as a reference is deprecated");
5998 return newUNOP(OP_RV2HV, 0, scalar(o));
6002 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6004 return newUNOP(OP_RV2CV, flags, scalar(o));
6008 Perl_newSVREF(pTHX_ OP *o)
6011 if (o->op_type == OP_PADANY) {
6012 o->op_type = OP_PADSV;
6013 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6016 return newUNOP(OP_RV2SV, 0, scalar(o));
6019 /* Check routines. See the comments at the top of this file for details
6020 * on when these are called */
6023 Perl_ck_anoncode(pTHX_ OP *o)
6025 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6027 cSVOPo->op_sv = NULL;
6032 Perl_ck_bitop(pTHX_ OP *o)
6035 #define OP_IS_NUMCOMPARE(op) \
6036 ((op) == OP_LT || (op) == OP_I_LT || \
6037 (op) == OP_GT || (op) == OP_I_GT || \
6038 (op) == OP_LE || (op) == OP_I_LE || \
6039 (op) == OP_GE || (op) == OP_I_GE || \
6040 (op) == OP_EQ || (op) == OP_I_EQ || \
6041 (op) == OP_NE || (op) == OP_I_NE || \
6042 (op) == OP_NCMP || (op) == OP_I_NCMP)
6043 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6044 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6045 && (o->op_type == OP_BIT_OR
6046 || o->op_type == OP_BIT_AND
6047 || o->op_type == OP_BIT_XOR))
6049 const OP * const left = cBINOPo->op_first;
6050 const OP * const right = left->op_sibling;
6051 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6052 (left->op_flags & OPf_PARENS) == 0) ||
6053 (OP_IS_NUMCOMPARE(right->op_type) &&
6054 (right->op_flags & OPf_PARENS) == 0))
6055 if (ckWARN(WARN_PRECEDENCE))
6056 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6057 "Possible precedence problem on bitwise %c operator",
6058 o->op_type == OP_BIT_OR ? '|'
6059 : o->op_type == OP_BIT_AND ? '&' : '^'
6066 Perl_ck_concat(pTHX_ OP *o)
6068 const OP * const kid = cUNOPo->op_first;
6069 PERL_UNUSED_CONTEXT;
6070 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6071 !(kUNOP->op_first->op_flags & OPf_MOD))
6072 o->op_flags |= OPf_STACKED;
6077 Perl_ck_spair(pTHX_ OP *o)
6080 if (o->op_flags & OPf_KIDS) {
6083 const OPCODE type = o->op_type;
6084 o = modkids(ck_fun(o), type);
6085 kid = cUNOPo->op_first;
6086 newop = kUNOP->op_first->op_sibling;
6088 const OPCODE type = newop->op_type;
6089 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6090 type == OP_PADAV || type == OP_PADHV ||
6091 type == OP_RV2AV || type == OP_RV2HV)
6095 op_getmad(kUNOP->op_first,newop,'K');
6097 op_free(kUNOP->op_first);
6099 kUNOP->op_first = newop;
6101 o->op_ppaddr = PL_ppaddr[++o->op_type];
6106 Perl_ck_delete(pTHX_ OP *o)
6110 if (o->op_flags & OPf_KIDS) {
6111 OP * const kid = cUNOPo->op_first;
6112 switch (kid->op_type) {
6114 o->op_flags |= OPf_SPECIAL;
6117 o->op_private |= OPpSLICE;
6120 o->op_flags |= OPf_SPECIAL;
6125 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6134 Perl_ck_die(pTHX_ OP *o)
6137 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6143 Perl_ck_eof(pTHX_ OP *o)
6147 if (o->op_flags & OPf_KIDS) {
6148 if (cLISTOPo->op_first->op_type == OP_STUB) {
6150 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6152 op_getmad(o,newop,'O');
6164 Perl_ck_eval(pTHX_ OP *o)
6167 PL_hints |= HINT_BLOCK_SCOPE;
6168 if (o->op_flags & OPf_KIDS) {
6169 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6172 o->op_flags &= ~OPf_KIDS;
6175 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6181 cUNOPo->op_first = 0;
6186 NewOp(1101, enter, 1, LOGOP);
6187 enter->op_type = OP_ENTERTRY;
6188 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6189 enter->op_private = 0;
6191 /* establish postfix order */
6192 enter->op_next = (OP*)enter;
6194 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6195 o->op_type = OP_LEAVETRY;
6196 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6197 enter->op_other = o;
6198 op_getmad(oldo,o,'O');
6212 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6213 op_getmad(oldo,o,'O');
6215 o->op_targ = (PADOFFSET)PL_hints;
6216 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6217 /* Store a copy of %^H that pp_entereval can pick up.
6218 OPf_SPECIAL flags the opcode as being for this purpose,
6219 so that it in turn will return a copy at every
6221 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6222 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6223 cUNOPo->op_first->op_sibling = hhop;
6224 o->op_private |= OPpEVAL_HAS_HH;
6230 Perl_ck_exit(pTHX_ OP *o)
6233 HV * const table = GvHV(PL_hintgv);
6235 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6236 if (svp && *svp && SvTRUE(*svp))
6237 o->op_private |= OPpEXIT_VMSISH;
6239 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6245 Perl_ck_exec(pTHX_ OP *o)
6247 if (o->op_flags & OPf_STACKED) {
6250 kid = cUNOPo->op_first->op_sibling;
6251 if (kid->op_type == OP_RV2GV)
6260 Perl_ck_exists(pTHX_ OP *o)
6264 if (o->op_flags & OPf_KIDS) {
6265 OP * const kid = cUNOPo->op_first;
6266 if (kid->op_type == OP_ENTERSUB) {
6267 (void) ref(kid, o->op_type);
6268 if (kid->op_type != OP_RV2CV && !PL_error_count)
6269 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6271 o->op_private |= OPpEXISTS_SUB;
6273 else if (kid->op_type == OP_AELEM)
6274 o->op_flags |= OPf_SPECIAL;
6275 else if (kid->op_type != OP_HELEM)
6276 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6284 Perl_ck_rvconst(pTHX_ register OP *o)
6287 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6289 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6290 if (o->op_type == OP_RV2CV)
6291 o->op_private &= ~1;
6293 if (kid->op_type == OP_CONST) {
6296 SV * const kidsv = kid->op_sv;
6298 /* Is it a constant from cv_const_sv()? */
6299 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6300 SV * const rsv = SvRV(kidsv);
6301 const svtype type = SvTYPE(rsv);
6302 const char *badtype = NULL;
6304 switch (o->op_type) {
6306 if (type > SVt_PVMG)
6307 badtype = "a SCALAR";
6310 if (type != SVt_PVAV)
6311 badtype = "an ARRAY";
6314 if (type != SVt_PVHV)
6318 if (type != SVt_PVCV)
6323 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6326 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6327 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6328 /* If this is an access to a stash, disable "strict refs", because
6329 * stashes aren't auto-vivified at compile-time (unless we store
6330 * symbols in them), and we don't want to produce a run-time
6331 * stricture error when auto-vivifying the stash. */
6332 const char *s = SvPV_nolen(kidsv);
6333 const STRLEN l = SvCUR(kidsv);
6334 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6335 o->op_private &= ~HINT_STRICT_REFS;
6337 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6338 const char *badthing;
6339 switch (o->op_type) {
6341 badthing = "a SCALAR";
6344 badthing = "an ARRAY";
6347 badthing = "a HASH";
6355 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6356 SVfARG(kidsv), badthing);
6359 * This is a little tricky. We only want to add the symbol if we
6360 * didn't add it in the lexer. Otherwise we get duplicate strict
6361 * warnings. But if we didn't add it in the lexer, we must at
6362 * least pretend like we wanted to add it even if it existed before,
6363 * or we get possible typo warnings. OPpCONST_ENTERED says
6364 * whether the lexer already added THIS instance of this symbol.
6366 iscv = (o->op_type == OP_RV2CV) * 2;
6368 gv = gv_fetchsv(kidsv,
6369 iscv | !(kid->op_private & OPpCONST_ENTERED),
6372 : o->op_type == OP_RV2SV
6374 : o->op_type == OP_RV2AV
6376 : o->op_type == OP_RV2HV
6379 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6381 kid->op_type = OP_GV;
6382 SvREFCNT_dec(kid->op_sv);
6384 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6385 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6386 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6388 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6390 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6392 kid->op_private = 0;
6393 kid->op_ppaddr = PL_ppaddr[OP_GV];
6400 Perl_ck_ftst(pTHX_ OP *o)
6403 const I32 type = o->op_type;
6405 if (o->op_flags & OPf_REF) {
6408 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6409 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6410 const OPCODE kidtype = kid->op_type;
6412 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6413 OP * const newop = newGVOP(type, OPf_REF,
6414 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6416 op_getmad(o,newop,'O');
6422 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6423 o->op_private |= OPpFT_ACCESS;
6424 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6425 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6426 o->op_private |= OPpFT_STACKED;
6434 if (type == OP_FTTTY)
6435 o = newGVOP(type, OPf_REF, PL_stdingv);
6437 o = newUNOP(type, 0, newDEFSVOP());
6438 op_getmad(oldo,o,'O');
6444 Perl_ck_fun(pTHX_ OP *o)
6447 const int type = o->op_type;
6448 register I32 oa = PL_opargs[type] >> OASHIFT;
6450 if (o->op_flags & OPf_STACKED) {
6451 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6454 return no_fh_allowed(o);
6457 if (o->op_flags & OPf_KIDS) {
6458 OP **tokid = &cLISTOPo->op_first;
6459 register OP *kid = cLISTOPo->op_first;
6463 if (kid->op_type == OP_PUSHMARK ||
6464 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6466 tokid = &kid->op_sibling;
6467 kid = kid->op_sibling;
6469 if (!kid && PL_opargs[type] & OA_DEFGV)
6470 *tokid = kid = newDEFSVOP();
6474 sibl = kid->op_sibling;
6476 if (!sibl && kid->op_type == OP_STUB) {
6483 /* list seen where single (scalar) arg expected? */
6484 if (numargs == 1 && !(oa >> 4)
6485 && kid->op_type == OP_LIST && type != OP_SCALAR)
6487 return too_many_arguments(o,PL_op_desc[type]);
6500 if ((type == OP_PUSH || type == OP_UNSHIFT)
6501 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6502 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6503 "Useless use of %s with no values",
6506 if (kid->op_type == OP_CONST &&
6507 (kid->op_private & OPpCONST_BARE))
6509 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6510 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6511 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6512 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6513 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6514 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6516 op_getmad(kid,newop,'K');
6521 kid->op_sibling = sibl;
6524 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6525 bad_type(numargs, "array", PL_op_desc[type], kid);
6529 if (kid->op_type == OP_CONST &&
6530 (kid->op_private & OPpCONST_BARE))
6532 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6533 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6534 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6535 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6536 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6537 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6539 op_getmad(kid,newop,'K');
6544 kid->op_sibling = sibl;
6547 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6548 bad_type(numargs, "hash", PL_op_desc[type], kid);
6553 OP * const newop = newUNOP(OP_NULL, 0, kid);
6554 kid->op_sibling = 0;
6556 newop->op_next = newop;
6558 kid->op_sibling = sibl;
6563 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6564 if (kid->op_type == OP_CONST &&
6565 (kid->op_private & OPpCONST_BARE))
6567 OP * const newop = newGVOP(OP_GV, 0,
6568 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6569 if (!(o->op_private & 1) && /* if not unop */
6570 kid == cLISTOPo->op_last)
6571 cLISTOPo->op_last = newop;
6573 op_getmad(kid,newop,'K');
6579 else if (kid->op_type == OP_READLINE) {
6580 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6581 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6584 I32 flags = OPf_SPECIAL;
6588 /* is this op a FH constructor? */
6589 if (is_handle_constructor(o,numargs)) {
6590 const char *name = NULL;
6594 /* Set a flag to tell rv2gv to vivify
6595 * need to "prove" flag does not mean something
6596 * else already - NI-S 1999/05/07
6599 if (kid->op_type == OP_PADSV) {
6601 = PAD_COMPNAME_SV(kid->op_targ);
6602 name = SvPV_const(namesv, len);
6604 else if (kid->op_type == OP_RV2SV
6605 && kUNOP->op_first->op_type == OP_GV)
6607 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6609 len = GvNAMELEN(gv);
6611 else if (kid->op_type == OP_AELEM
6612 || kid->op_type == OP_HELEM)
6615 OP *op = ((BINOP*)kid)->op_first;
6619 const char * const a =
6620 kid->op_type == OP_AELEM ?
6622 if (((op->op_type == OP_RV2AV) ||
6623 (op->op_type == OP_RV2HV)) &&
6624 (firstop = ((UNOP*)op)->op_first) &&
6625 (firstop->op_type == OP_GV)) {
6626 /* packagevar $a[] or $h{} */
6627 GV * const gv = cGVOPx_gv(firstop);
6635 else if (op->op_type == OP_PADAV
6636 || op->op_type == OP_PADHV) {
6637 /* lexicalvar $a[] or $h{} */
6638 const char * const padname =
6639 PAD_COMPNAME_PV(op->op_targ);
6648 name = SvPV_const(tmpstr, len);
6653 name = "__ANONIO__";
6660 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6661 namesv = PAD_SVl(targ);
6662 SvUPGRADE(namesv, SVt_PV);
6664 sv_setpvn(namesv, "$", 1);
6665 sv_catpvn(namesv, name, len);
6668 kid->op_sibling = 0;
6669 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6670 kid->op_targ = targ;
6671 kid->op_private |= priv;
6673 kid->op_sibling = sibl;
6679 mod(scalar(kid), type);
6683 tokid = &kid->op_sibling;
6684 kid = kid->op_sibling;
6687 if (kid && kid->op_type != OP_STUB)
6688 return too_many_arguments(o,OP_DESC(o));
6689 o->op_private |= numargs;
6691 /* FIXME - should the numargs move as for the PERL_MAD case? */
6692 o->op_private |= numargs;
6694 return too_many_arguments(o,OP_DESC(o));
6698 else if (PL_opargs[type] & OA_DEFGV) {
6700 OP *newop = newUNOP(type, 0, newDEFSVOP());
6701 op_getmad(o,newop,'O');
6704 /* Ordering of these two is important to keep f_map.t passing. */
6706 return newUNOP(type, 0, newDEFSVOP());
6711 while (oa & OA_OPTIONAL)
6713 if (oa && oa != OA_LIST)
6714 return too_few_arguments(o,OP_DESC(o));
6720 Perl_ck_glob(pTHX_ OP *o)
6726 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6727 append_elem(OP_GLOB, o, newDEFSVOP());
6729 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6730 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6732 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6735 #if !defined(PERL_EXTERNAL_GLOB)
6736 /* XXX this can be tightened up and made more failsafe. */
6737 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6740 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6741 newSVpvs("File::Glob"), NULL, NULL, NULL);
6742 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6743 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6744 GvCV(gv) = GvCV(glob_gv);
6745 SvREFCNT_inc_void((SV*)GvCV(gv));
6746 GvIMPORTED_CV_on(gv);
6749 #endif /* PERL_EXTERNAL_GLOB */
6751 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6752 append_elem(OP_GLOB, o,
6753 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6754 o->op_type = OP_LIST;
6755 o->op_ppaddr = PL_ppaddr[OP_LIST];
6756 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6757 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6758 cLISTOPo->op_first->op_targ = 0;
6759 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6760 append_elem(OP_LIST, o,
6761 scalar(newUNOP(OP_RV2CV, 0,
6762 newGVOP(OP_GV, 0, gv)))));
6763 o = newUNOP(OP_NULL, 0, ck_subr(o));
6764 o->op_targ = OP_GLOB; /* hint at what it used to be */
6767 gv = newGVgen("main");
6769 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6775 Perl_ck_grep(pTHX_ OP *o)
6780 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6783 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6784 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6786 if (o->op_flags & OPf_STACKED) {
6789 kid = cLISTOPo->op_first->op_sibling;
6790 if (!cUNOPx(kid)->op_next)
6791 Perl_croak(aTHX_ "panic: ck_grep");
6792 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6795 NewOp(1101, gwop, 1, LOGOP);
6796 kid->op_next = (OP*)gwop;
6797 o->op_flags &= ~OPf_STACKED;
6799 kid = cLISTOPo->op_first->op_sibling;
6800 if (type == OP_MAPWHILE)
6807 kid = cLISTOPo->op_first->op_sibling;
6808 if (kid->op_type != OP_NULL)
6809 Perl_croak(aTHX_ "panic: ck_grep");
6810 kid = kUNOP->op_first;
6813 NewOp(1101, gwop, 1, LOGOP);
6814 gwop->op_type = type;
6815 gwop->op_ppaddr = PL_ppaddr[type];
6816 gwop->op_first = listkids(o);
6817 gwop->op_flags |= OPf_KIDS;
6818 gwop->op_other = LINKLIST(kid);
6819 kid->op_next = (OP*)gwop;
6820 offset = pad_findmy("$_");
6821 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6822 o->op_private = gwop->op_private = 0;
6823 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6826 o->op_private = gwop->op_private = OPpGREP_LEX;
6827 gwop->op_targ = o->op_targ = offset;
6830 kid = cLISTOPo->op_first->op_sibling;
6831 if (!kid || !kid->op_sibling)
6832 return too_few_arguments(o,OP_DESC(o));
6833 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6834 mod(kid, OP_GREPSTART);
6840 Perl_ck_index(pTHX_ OP *o)
6842 if (o->op_flags & OPf_KIDS) {
6843 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6845 kid = kid->op_sibling; /* get past "big" */
6846 if (kid && kid->op_type == OP_CONST)
6847 fbm_compile(((SVOP*)kid)->op_sv, 0);
6853 Perl_ck_lengthconst(pTHX_ OP *o)
6855 /* XXX length optimization goes here */
6860 Perl_ck_lfun(pTHX_ OP *o)
6862 const OPCODE type = o->op_type;
6863 return modkids(ck_fun(o), type);
6867 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6869 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6870 switch (cUNOPo->op_first->op_type) {
6872 /* This is needed for
6873 if (defined %stash::)
6874 to work. Do not break Tk.
6876 break; /* Globals via GV can be undef */
6878 case OP_AASSIGN: /* Is this a good idea? */
6879 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6880 "defined(@array) is deprecated");
6881 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6882 "\t(Maybe you should just omit the defined()?)\n");
6885 /* This is needed for
6886 if (defined %stash::)
6887 to work. Do not break Tk.
6889 break; /* Globals via GV can be undef */
6891 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6892 "defined(%%hash) is deprecated");
6893 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6894 "\t(Maybe you should just omit the defined()?)\n");
6905 Perl_ck_readline(pTHX_ OP *o)
6907 if (!(o->op_flags & OPf_KIDS)) {
6909 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6911 op_getmad(o,newop,'O');
6921 Perl_ck_rfun(pTHX_ OP *o)
6923 const OPCODE type = o->op_type;
6924 return refkids(ck_fun(o), type);
6928 Perl_ck_listiob(pTHX_ OP *o)
6932 kid = cLISTOPo->op_first;
6935 kid = cLISTOPo->op_first;
6937 if (kid->op_type == OP_PUSHMARK)
6938 kid = kid->op_sibling;
6939 if (kid && o->op_flags & OPf_STACKED)
6940 kid = kid->op_sibling;
6941 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6942 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6943 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6944 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6945 cLISTOPo->op_first->op_sibling = kid;
6946 cLISTOPo->op_last = kid;
6947 kid = kid->op_sibling;
6952 append_elem(o->op_type, o, newDEFSVOP());
6958 Perl_ck_smartmatch(pTHX_ OP *o)
6961 if (0 == (o->op_flags & OPf_SPECIAL)) {
6962 OP *first = cBINOPo->op_first;
6963 OP *second = first->op_sibling;
6965 /* Implicitly take a reference to an array or hash */
6966 first->op_sibling = NULL;
6967 first = cBINOPo->op_first = ref_array_or_hash(first);
6968 second = first->op_sibling = ref_array_or_hash(second);
6970 /* Implicitly take a reference to a regular expression */
6971 if (first->op_type == OP_MATCH) {
6972 first->op_type = OP_QR;
6973 first->op_ppaddr = PL_ppaddr[OP_QR];
6975 if (second->op_type == OP_MATCH) {
6976 second->op_type = OP_QR;
6977 second->op_ppaddr = PL_ppaddr[OP_QR];
6986 Perl_ck_sassign(pTHX_ OP *o)
6988 OP * const kid = cLISTOPo->op_first;
6989 /* has a disposable target? */
6990 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6991 && !(kid->op_flags & OPf_STACKED)
6992 /* Cannot steal the second time! */
6993 && !(kid->op_private & OPpTARGET_MY))
6995 OP * const kkid = kid->op_sibling;
6997 /* Can just relocate the target. */
6998 if (kkid && kkid->op_type == OP_PADSV
6999 && !(kkid->op_private & OPpLVAL_INTRO))
7001 kid->op_targ = kkid->op_targ;
7003 /* Now we do not need PADSV and SASSIGN. */
7004 kid->op_sibling = o->op_sibling; /* NULL */
7005 cLISTOPo->op_first = NULL;
7007 op_getmad(o,kid,'O');
7008 op_getmad(kkid,kid,'M');
7013 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7017 if (kid->op_sibling) {
7018 OP *kkid = kid->op_sibling;
7019 if (kkid->op_type == OP_PADSV
7020 && (kkid->op_private & OPpLVAL_INTRO)
7021 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7022 o->op_private |= OPpASSIGN_STATE;
7023 /* hijacking PADSTALE for uninitialized state variables */
7024 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
7031 Perl_ck_match(pTHX_ OP *o)
7034 if (o->op_type != OP_QR && PL_compcv) {
7035 const PADOFFSET offset = pad_findmy("$_");
7036 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7037 o->op_targ = offset;
7038 o->op_private |= OPpTARGET_MY;
7041 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7042 o->op_private |= OPpRUNTIME;
7047 Perl_ck_method(pTHX_ OP *o)
7049 OP * const kid = cUNOPo->op_first;
7050 if (kid->op_type == OP_CONST) {
7051 SV* sv = kSVOP->op_sv;
7052 const char * const method = SvPVX_const(sv);
7053 if (!(strchr(method, ':') || strchr(method, '\''))) {
7055 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7056 sv = newSVpvn_share(method, SvCUR(sv), 0);
7059 kSVOP->op_sv = NULL;
7061 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7063 op_getmad(o,cmop,'O');
7074 Perl_ck_null(pTHX_ OP *o)
7076 PERL_UNUSED_CONTEXT;
7081 Perl_ck_open(pTHX_ OP *o)
7084 HV * const table = GvHV(PL_hintgv);
7086 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7088 const I32 mode = mode_from_discipline(*svp);
7089 if (mode & O_BINARY)
7090 o->op_private |= OPpOPEN_IN_RAW;
7091 else if (mode & O_TEXT)
7092 o->op_private |= OPpOPEN_IN_CRLF;
7095 svp = hv_fetchs(table, "open_OUT", FALSE);
7097 const I32 mode = mode_from_discipline(*svp);
7098 if (mode & O_BINARY)
7099 o->op_private |= OPpOPEN_OUT_RAW;
7100 else if (mode & O_TEXT)
7101 o->op_private |= OPpOPEN_OUT_CRLF;
7104 if (o->op_type == OP_BACKTICK) {
7105 if (!(o->op_flags & OPf_KIDS)) {
7106 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7108 op_getmad(o,newop,'O');
7117 /* In case of three-arg dup open remove strictness
7118 * from the last arg if it is a bareword. */
7119 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7120 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7124 if ((last->op_type == OP_CONST) && /* The bareword. */
7125 (last->op_private & OPpCONST_BARE) &&
7126 (last->op_private & OPpCONST_STRICT) &&
7127 (oa = first->op_sibling) && /* The fh. */
7128 (oa = oa->op_sibling) && /* The mode. */
7129 (oa->op_type == OP_CONST) &&
7130 SvPOK(((SVOP*)oa)->op_sv) &&
7131 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7132 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7133 (last == oa->op_sibling)) /* The bareword. */
7134 last->op_private &= ~OPpCONST_STRICT;
7140 Perl_ck_repeat(pTHX_ OP *o)
7142 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7143 o->op_private |= OPpREPEAT_DOLIST;
7144 cBINOPo->op_first = force_list(cBINOPo->op_first);
7152 Perl_ck_require(pTHX_ OP *o)
7157 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7158 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7160 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7161 SV * const sv = kid->op_sv;
7162 U32 was_readonly = SvREADONLY(sv);
7167 sv_force_normal_flags(sv, 0);
7168 assert(!SvREADONLY(sv));
7175 for (s = SvPVX(sv); *s; s++) {
7176 if (*s == ':' && s[1] == ':') {
7177 const STRLEN len = strlen(s+2)+1;
7179 Move(s+2, s+1, len, char);
7180 SvCUR_set(sv, SvCUR(sv) - 1);
7183 sv_catpvs(sv, ".pm");
7184 SvFLAGS(sv) |= was_readonly;
7188 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7189 /* handle override, if any */
7190 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7191 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7192 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7193 gv = gvp ? *gvp : NULL;
7197 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7198 OP * const kid = cUNOPo->op_first;
7201 cUNOPo->op_first = 0;
7205 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7206 append_elem(OP_LIST, kid,
7207 scalar(newUNOP(OP_RV2CV, 0,
7210 op_getmad(o,newop,'O');
7218 Perl_ck_return(pTHX_ OP *o)
7221 if (CvLVALUE(PL_compcv)) {
7223 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7224 mod(kid, OP_LEAVESUBLV);
7230 Perl_ck_select(pTHX_ OP *o)
7234 if (o->op_flags & OPf_KIDS) {
7235 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7236 if (kid && kid->op_sibling) {
7237 o->op_type = OP_SSELECT;
7238 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7240 return fold_constants(o);
7244 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7245 if (kid && kid->op_type == OP_RV2GV)
7246 kid->op_private &= ~HINT_STRICT_REFS;
7251 Perl_ck_shift(pTHX_ OP *o)
7254 const I32 type = o->op_type;
7256 if (!(o->op_flags & OPf_KIDS)) {
7258 /* FIXME - this can be refactored to reduce code in #ifdefs */
7260 OP * const oldo = o;
7264 argop = newUNOP(OP_RV2AV, 0,
7265 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7267 o = newUNOP(type, 0, scalar(argop));
7268 op_getmad(oldo,o,'O');
7271 return newUNOP(type, 0, scalar(argop));
7274 return scalar(modkids(ck_fun(o), type));
7278 Perl_ck_sort(pTHX_ OP *o)
7283 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7284 HV * const hinthv = GvHV(PL_hintgv);
7286 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7288 const I32 sorthints = (I32)SvIV(*svp);
7289 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7290 o->op_private |= OPpSORT_QSORT;
7291 if ((sorthints & HINT_SORT_STABLE) != 0)
7292 o->op_private |= OPpSORT_STABLE;
7297 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7299 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7300 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7302 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7304 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7306 if (kid->op_type == OP_SCOPE) {
7310 else if (kid->op_type == OP_LEAVE) {
7311 if (o->op_type == OP_SORT) {
7312 op_null(kid); /* wipe out leave */
7315 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7316 if (k->op_next == kid)
7318 /* don't descend into loops */
7319 else if (k->op_type == OP_ENTERLOOP
7320 || k->op_type == OP_ENTERITER)
7322 k = cLOOPx(k)->op_lastop;
7327 kid->op_next = 0; /* just disconnect the leave */
7328 k = kLISTOP->op_first;
7333 if (o->op_type == OP_SORT) {
7334 /* provide scalar context for comparison function/block */
7340 o->op_flags |= OPf_SPECIAL;
7342 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7345 firstkid = firstkid->op_sibling;
7348 /* provide list context for arguments */
7349 if (o->op_type == OP_SORT)
7356 S_simplify_sort(pTHX_ OP *o)
7359 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7364 if (!(o->op_flags & OPf_STACKED))
7366 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7367 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7368 kid = kUNOP->op_first; /* get past null */
7369 if (kid->op_type != OP_SCOPE)
7371 kid = kLISTOP->op_last; /* get past scope */
7372 switch(kid->op_type) {
7380 k = kid; /* remember this node*/
7381 if (kBINOP->op_first->op_type != OP_RV2SV)
7383 kid = kBINOP->op_first; /* get past cmp */
7384 if (kUNOP->op_first->op_type != OP_GV)
7386 kid = kUNOP->op_first; /* get past rv2sv */
7388 if (GvSTASH(gv) != PL_curstash)
7390 gvname = GvNAME(gv);
7391 if (*gvname == 'a' && gvname[1] == '\0')
7393 else if (*gvname == 'b' && gvname[1] == '\0')
7398 kid = k; /* back to cmp */
7399 if (kBINOP->op_last->op_type != OP_RV2SV)
7401 kid = kBINOP->op_last; /* down to 2nd arg */
7402 if (kUNOP->op_first->op_type != OP_GV)
7404 kid = kUNOP->op_first; /* get past rv2sv */
7406 if (GvSTASH(gv) != PL_curstash)
7408 gvname = GvNAME(gv);
7410 ? !(*gvname == 'a' && gvname[1] == '\0')
7411 : !(*gvname == 'b' && gvname[1] == '\0'))
7413 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7415 o->op_private |= OPpSORT_DESCEND;
7416 if (k->op_type == OP_NCMP)
7417 o->op_private |= OPpSORT_NUMERIC;
7418 if (k->op_type == OP_I_NCMP)
7419 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7420 kid = cLISTOPo->op_first->op_sibling;
7421 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7423 op_getmad(kid,o,'S'); /* then delete it */
7425 op_free(kid); /* then delete it */
7430 Perl_ck_split(pTHX_ OP *o)
7435 if (o->op_flags & OPf_STACKED)
7436 return no_fh_allowed(o);
7438 kid = cLISTOPo->op_first;
7439 if (kid->op_type != OP_NULL)
7440 Perl_croak(aTHX_ "panic: ck_split");
7441 kid = kid->op_sibling;
7442 op_free(cLISTOPo->op_first);
7443 cLISTOPo->op_first = kid;
7445 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7446 cLISTOPo->op_last = kid; /* There was only one element previously */
7449 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7450 OP * const sibl = kid->op_sibling;
7451 kid->op_sibling = 0;
7452 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7453 if (cLISTOPo->op_first == cLISTOPo->op_last)
7454 cLISTOPo->op_last = kid;
7455 cLISTOPo->op_first = kid;
7456 kid->op_sibling = sibl;
7459 kid->op_type = OP_PUSHRE;
7460 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7462 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7463 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7464 "Use of /g modifier is meaningless in split");
7467 if (!kid->op_sibling)
7468 append_elem(OP_SPLIT, o, newDEFSVOP());
7470 kid = kid->op_sibling;
7473 if (!kid->op_sibling)
7474 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7475 assert(kid->op_sibling);
7477 kid = kid->op_sibling;
7480 if (kid->op_sibling)
7481 return too_many_arguments(o,OP_DESC(o));
7487 Perl_ck_join(pTHX_ OP *o)
7489 const OP * const kid = cLISTOPo->op_first->op_sibling;
7490 if (kid && kid->op_type == OP_MATCH) {
7491 if (ckWARN(WARN_SYNTAX)) {
7492 const REGEXP *re = PM_GETRE(kPMOP);
7493 const char *pmstr = re ? re->precomp : "STRING";
7494 const STRLEN len = re ? re->prelen : 6;
7495 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7496 "/%.*s/ should probably be written as \"%.*s\"",
7497 (int)len, pmstr, (int)len, pmstr);
7504 Perl_ck_subr(pTHX_ OP *o)
7507 OP *prev = ((cUNOPo->op_first->op_sibling)
7508 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7509 OP *o2 = prev->op_sibling;
7511 const char *proto = NULL;
7512 const char *proto_end = NULL;
7517 I32 contextclass = 0;
7518 const char *e = NULL;
7521 o->op_private |= OPpENTERSUB_HASTARG;
7522 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7523 if (cvop->op_type == OP_RV2CV) {
7525 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7526 op_null(cvop); /* disable rv2cv */
7527 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7528 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7529 GV *gv = cGVOPx_gv(tmpop);
7532 tmpop->op_private |= OPpEARLY_CV;
7536 namegv = CvANON(cv) ? gv : CvGV(cv);
7537 proto = SvPV((SV*)cv, len);
7538 proto_end = proto + len;
7540 if (CvASSERTION(cv)) {
7541 U32 asserthints = 0;
7542 HV *const hinthv = GvHV(PL_hintgv);
7544 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7546 asserthints = SvUV(*svp);
7548 if (asserthints & HINT_ASSERTING) {
7549 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7550 o->op_private |= OPpENTERSUB_DB;
7554 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7555 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7556 "Impossible to activate assertion call");
7563 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7564 if (o2->op_type == OP_CONST)
7565 o2->op_private &= ~OPpCONST_STRICT;
7566 else if (o2->op_type == OP_LIST) {
7567 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7568 if (sib && sib->op_type == OP_CONST)
7569 sib->op_private &= ~OPpCONST_STRICT;
7572 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7573 if (PERLDB_SUB && PL_curstash != PL_debstash)
7574 o->op_private |= OPpENTERSUB_DB;
7575 while (o2 != cvop) {
7577 if (PL_madskills && o2->op_type == OP_STUB) {
7578 o2 = o2->op_sibling;
7581 if (PL_madskills && o2->op_type == OP_NULL)
7582 o3 = ((UNOP*)o2)->op_first;
7586 if (proto >= proto_end)
7587 return too_many_arguments(o, gv_ename(namegv));
7595 /* _ must be at the end */
7596 if (proto[1] && proto[1] != ';')
7611 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7613 arg == 1 ? "block or sub {}" : "sub {}",
7614 gv_ename(namegv), o3);
7617 /* '*' allows any scalar type, including bareword */
7620 if (o3->op_type == OP_RV2GV)
7621 goto wrapref; /* autoconvert GLOB -> GLOBref */
7622 else if (o3->op_type == OP_CONST)
7623 o3->op_private &= ~OPpCONST_STRICT;
7624 else if (o3->op_type == OP_ENTERSUB) {
7625 /* accidental subroutine, revert to bareword */
7626 OP *gvop = ((UNOP*)o3)->op_first;
7627 if (gvop && gvop->op_type == OP_NULL) {
7628 gvop = ((UNOP*)gvop)->op_first;
7630 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7633 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7634 (gvop = ((UNOP*)gvop)->op_first) &&
7635 gvop->op_type == OP_GV)
7637 GV * const gv = cGVOPx_gv(gvop);
7638 OP * const sibling = o2->op_sibling;
7639 SV * const n = newSVpvs("");
7641 OP * const oldo2 = o2;
7645 gv_fullname4(n, gv, "", FALSE);
7646 o2 = newSVOP(OP_CONST, 0, n);
7647 op_getmad(oldo2,o2,'O');
7648 prev->op_sibling = o2;
7649 o2->op_sibling = sibling;
7665 if (contextclass++ == 0) {
7666 e = strchr(proto, ']');
7667 if (!e || e == proto)
7676 const char *p = proto;
7677 const char *const end = proto;
7679 while (*--p != '[');
7680 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7682 gv_ename(namegv), o3);
7687 if (o3->op_type == OP_RV2GV)
7690 bad_type(arg, "symbol", gv_ename(namegv), o3);
7693 if (o3->op_type == OP_ENTERSUB)
7696 bad_type(arg, "subroutine entry", gv_ename(namegv),
7700 if (o3->op_type == OP_RV2SV ||
7701 o3->op_type == OP_PADSV ||
7702 o3->op_type == OP_HELEM ||
7703 o3->op_type == OP_AELEM)
7706 bad_type(arg, "scalar", gv_ename(namegv), o3);
7709 if (o3->op_type == OP_RV2AV ||
7710 o3->op_type == OP_PADAV)
7713 bad_type(arg, "array", gv_ename(namegv), o3);
7716 if (o3->op_type == OP_RV2HV ||
7717 o3->op_type == OP_PADHV)
7720 bad_type(arg, "hash", gv_ename(namegv), o3);
7725 OP* const sib = kid->op_sibling;
7726 kid->op_sibling = 0;
7727 o2 = newUNOP(OP_REFGEN, 0, kid);
7728 o2->op_sibling = sib;
7729 prev->op_sibling = o2;
7731 if (contextclass && e) {
7746 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7747 gv_ename(namegv), SVfARG(cv));
7752 mod(o2, OP_ENTERSUB);
7754 o2 = o2->op_sibling;
7756 if (o2 == cvop && proto && *proto == '_') {
7757 /* generate an access to $_ */
7759 o2->op_sibling = prev->op_sibling;
7760 prev->op_sibling = o2; /* instead of cvop */
7762 if (proto && !optional && proto_end > proto &&
7763 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7764 return too_few_arguments(o, gv_ename(namegv));
7767 OP * const oldo = o;
7771 o=newSVOP(OP_CONST, 0, newSViv(0));
7772 op_getmad(oldo,o,'O');
7778 Perl_ck_svconst(pTHX_ OP *o)
7780 PERL_UNUSED_CONTEXT;
7781 SvREADONLY_on(cSVOPo->op_sv);
7786 Perl_ck_chdir(pTHX_ OP *o)
7788 if (o->op_flags & OPf_KIDS) {
7789 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7791 if (kid && kid->op_type == OP_CONST &&
7792 (kid->op_private & OPpCONST_BARE))
7794 o->op_flags |= OPf_SPECIAL;
7795 kid->op_private &= ~OPpCONST_STRICT;
7802 Perl_ck_trunc(pTHX_ OP *o)
7804 if (o->op_flags & OPf_KIDS) {
7805 SVOP *kid = (SVOP*)cUNOPo->op_first;
7807 if (kid->op_type == OP_NULL)
7808 kid = (SVOP*)kid->op_sibling;
7809 if (kid && kid->op_type == OP_CONST &&
7810 (kid->op_private & OPpCONST_BARE))
7812 o->op_flags |= OPf_SPECIAL;
7813 kid->op_private &= ~OPpCONST_STRICT;
7820 Perl_ck_unpack(pTHX_ OP *o)
7822 OP *kid = cLISTOPo->op_first;
7823 if (kid->op_sibling) {
7824 kid = kid->op_sibling;
7825 if (!kid->op_sibling)
7826 kid->op_sibling = newDEFSVOP();
7832 Perl_ck_substr(pTHX_ OP *o)
7835 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7836 OP *kid = cLISTOPo->op_first;
7838 if (kid->op_type == OP_NULL)
7839 kid = kid->op_sibling;
7841 kid->op_flags |= OPf_MOD;
7847 /* A peephole optimizer. We visit the ops in the order they're to execute.
7848 * See the comments at the top of this file for more details about when
7849 * peep() is called */
7852 Perl_peep(pTHX_ register OP *o)
7855 register OP* oldop = NULL;
7857 if (!o || o->op_opt)
7861 SAVEVPTR(PL_curcop);
7862 for (; o; o = o->op_next) {
7865 /* By default, this op has now been optimised. A couple of cases below
7866 clear this again. */
7869 switch (o->op_type) {
7873 PL_curcop = ((COP*)o); /* for warnings */
7877 if (cSVOPo->op_private & OPpCONST_STRICT)
7878 no_bareword_allowed(o);
7880 case OP_METHOD_NAMED:
7881 /* Relocate sv to the pad for thread safety.
7882 * Despite being a "constant", the SV is written to,
7883 * for reference counts, sv_upgrade() etc. */
7885 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7886 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7887 /* If op_sv is already a PADTMP then it is being used by
7888 * some pad, so make a copy. */
7889 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7890 SvREADONLY_on(PAD_SVl(ix));
7891 SvREFCNT_dec(cSVOPo->op_sv);
7893 else if (o->op_type == OP_CONST
7894 && cSVOPo->op_sv == &PL_sv_undef) {
7895 /* PL_sv_undef is hack - it's unsafe to store it in the
7896 AV that is the pad, because av_fetch treats values of
7897 PL_sv_undef as a "free" AV entry and will merrily
7898 replace them with a new SV, causing pad_alloc to think
7899 that this pad slot is free. (When, clearly, it is not)
7901 SvOK_off(PAD_SVl(ix));
7902 SvPADTMP_on(PAD_SVl(ix));
7903 SvREADONLY_on(PAD_SVl(ix));
7906 SvREFCNT_dec(PAD_SVl(ix));
7907 SvPADTMP_on(cSVOPo->op_sv);
7908 PAD_SETSV(ix, cSVOPo->op_sv);
7909 /* XXX I don't know how this isn't readonly already. */
7910 SvREADONLY_on(PAD_SVl(ix));
7912 cSVOPo->op_sv = NULL;
7919 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7920 if (o->op_next->op_private & OPpTARGET_MY) {
7921 if (o->op_flags & OPf_STACKED) /* chained concats */
7922 break; /* ignore_optimization */
7924 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7925 o->op_targ = o->op_next->op_targ;
7926 o->op_next->op_targ = 0;
7927 o->op_private |= OPpTARGET_MY;
7930 op_null(o->op_next);
7934 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7935 break; /* Scalar stub must produce undef. List stub is noop */
7939 if (o->op_targ == OP_NEXTSTATE
7940 || o->op_targ == OP_DBSTATE
7941 || o->op_targ == OP_SETSTATE)
7943 PL_curcop = ((COP*)o);
7945 /* XXX: We avoid setting op_seq here to prevent later calls
7946 to peep() from mistakenly concluding that optimisation
7947 has already occurred. This doesn't fix the real problem,
7948 though (See 20010220.007). AMS 20010719 */
7949 /* op_seq functionality is now replaced by op_opt */
7956 if (oldop && o->op_next) {
7957 oldop->op_next = o->op_next;
7965 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7966 OP* const pop = (o->op_type == OP_PADAV) ?
7967 o->op_next : o->op_next->op_next;
7969 if (pop && pop->op_type == OP_CONST &&
7970 ((PL_op = pop->op_next)) &&
7971 pop->op_next->op_type == OP_AELEM &&
7972 !(pop->op_next->op_private &
7973 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7974 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7979 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7980 no_bareword_allowed(pop);
7981 if (o->op_type == OP_GV)
7982 op_null(o->op_next);
7983 op_null(pop->op_next);
7985 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7986 o->op_next = pop->op_next->op_next;
7987 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7988 o->op_private = (U8)i;
7989 if (o->op_type == OP_GV) {
7994 o->op_flags |= OPf_SPECIAL;
7995 o->op_type = OP_AELEMFAST;
8000 if (o->op_next->op_type == OP_RV2SV) {
8001 if (!(o->op_next->op_private & OPpDEREF)) {
8002 op_null(o->op_next);
8003 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8005 o->op_next = o->op_next->op_next;
8006 o->op_type = OP_GVSV;
8007 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8010 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8011 GV * const gv = cGVOPo_gv;
8012 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8013 /* XXX could check prototype here instead of just carping */
8014 SV * const sv = sv_newmortal();
8015 gv_efullname3(sv, gv, NULL);
8016 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8017 "%"SVf"() called too early to check prototype",
8021 else if (o->op_next->op_type == OP_READLINE
8022 && o->op_next->op_next->op_type == OP_CONCAT
8023 && (o->op_next->op_next->op_flags & OPf_STACKED))
8025 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8026 o->op_type = OP_RCATLINE;
8027 o->op_flags |= OPf_STACKED;
8028 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8029 op_null(o->op_next->op_next);
8030 op_null(o->op_next);
8045 while (cLOGOP->op_other->op_type == OP_NULL)
8046 cLOGOP->op_other = cLOGOP->op_other->op_next;
8047 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8052 while (cLOOP->op_redoop->op_type == OP_NULL)
8053 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8054 peep(cLOOP->op_redoop);
8055 while (cLOOP->op_nextop->op_type == OP_NULL)
8056 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8057 peep(cLOOP->op_nextop);
8058 while (cLOOP->op_lastop->op_type == OP_NULL)
8059 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8060 peep(cLOOP->op_lastop);
8064 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8065 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8066 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8067 cPMOP->op_pmstashstartu.op_pmreplstart
8068 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8069 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8073 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8074 && ckWARN(WARN_SYNTAX))
8076 if (o->op_next->op_sibling) {
8077 const OPCODE type = o->op_next->op_sibling->op_type;
8078 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8079 const line_t oldline = CopLINE(PL_curcop);
8080 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8081 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8082 "Statement unlikely to be reached");
8083 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8084 "\t(Maybe you meant system() when you said exec()?)\n");
8085 CopLINE_set(PL_curcop, oldline);
8096 const char *key = NULL;
8099 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8102 /* Make the CONST have a shared SV */
8103 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8104 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8105 key = SvPV_const(sv, keylen);
8106 lexname = newSVpvn_share(key,
8107 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8113 if ((o->op_private & (OPpLVAL_INTRO)))
8116 rop = (UNOP*)((BINOP*)o)->op_first;
8117 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8119 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8120 if (!SvPAD_TYPED(lexname))
8122 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8123 if (!fields || !GvHV(*fields))
8125 key = SvPV_const(*svp, keylen);
8126 if (!hv_fetch(GvHV(*fields), key,
8127 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8129 Perl_croak(aTHX_ "No such class field \"%s\" "
8130 "in variable %s of type %s",
8131 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8144 SVOP *first_key_op, *key_op;
8146 if ((o->op_private & (OPpLVAL_INTRO))
8147 /* I bet there's always a pushmark... */
8148 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8149 /* hmmm, no optimization if list contains only one key. */
8151 rop = (UNOP*)((LISTOP*)o)->op_last;
8152 if (rop->op_type != OP_RV2HV)
8154 if (rop->op_first->op_type == OP_PADSV)
8155 /* @$hash{qw(keys here)} */
8156 rop = (UNOP*)rop->op_first;
8158 /* @{$hash}{qw(keys here)} */
8159 if (rop->op_first->op_type == OP_SCOPE
8160 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8162 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8168 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8169 if (!SvPAD_TYPED(lexname))
8171 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8172 if (!fields || !GvHV(*fields))
8174 /* Again guessing that the pushmark can be jumped over.... */
8175 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8176 ->op_first->op_sibling;
8177 for (key_op = first_key_op; key_op;
8178 key_op = (SVOP*)key_op->op_sibling) {
8179 if (key_op->op_type != OP_CONST)
8181 svp = cSVOPx_svp(key_op);
8182 key = SvPV_const(*svp, keylen);
8183 if (!hv_fetch(GvHV(*fields), key,
8184 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8186 Perl_croak(aTHX_ "No such class field \"%s\" "
8187 "in variable %s of type %s",
8188 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8195 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8199 /* check that RHS of sort is a single plain array */
8200 OP *oright = cUNOPo->op_first;
8201 if (!oright || oright->op_type != OP_PUSHMARK)
8204 /* reverse sort ... can be optimised. */
8205 if (!cUNOPo->op_sibling) {
8206 /* Nothing follows us on the list. */
8207 OP * const reverse = o->op_next;
8209 if (reverse->op_type == OP_REVERSE &&
8210 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8211 OP * const pushmark = cUNOPx(reverse)->op_first;
8212 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8213 && (cUNOPx(pushmark)->op_sibling == o)) {
8214 /* reverse -> pushmark -> sort */
8215 o->op_private |= OPpSORT_REVERSE;
8217 pushmark->op_next = oright->op_next;
8223 /* make @a = sort @a act in-place */
8225 oright = cUNOPx(oright)->op_sibling;
8228 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8229 oright = cUNOPx(oright)->op_sibling;
8233 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8234 || oright->op_next != o
8235 || (oright->op_private & OPpLVAL_INTRO)
8239 /* o2 follows the chain of op_nexts through the LHS of the
8240 * assign (if any) to the aassign op itself */
8242 if (!o2 || o2->op_type != OP_NULL)
8245 if (!o2 || o2->op_type != OP_PUSHMARK)
8248 if (o2 && o2->op_type == OP_GV)
8251 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8252 || (o2->op_private & OPpLVAL_INTRO)
8257 if (!o2 || o2->op_type != OP_NULL)
8260 if (!o2 || o2->op_type != OP_AASSIGN
8261 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8264 /* check that the sort is the first arg on RHS of assign */
8266 o2 = cUNOPx(o2)->op_first;
8267 if (!o2 || o2->op_type != OP_NULL)
8269 o2 = cUNOPx(o2)->op_first;
8270 if (!o2 || o2->op_type != OP_PUSHMARK)
8272 if (o2->op_sibling != o)
8275 /* check the array is the same on both sides */
8276 if (oleft->op_type == OP_RV2AV) {
8277 if (oright->op_type != OP_RV2AV
8278 || !cUNOPx(oright)->op_first
8279 || cUNOPx(oright)->op_first->op_type != OP_GV
8280 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8281 cGVOPx_gv(cUNOPx(oright)->op_first)
8285 else if (oright->op_type != OP_PADAV
8286 || oright->op_targ != oleft->op_targ
8290 /* transfer MODishness etc from LHS arg to RHS arg */
8291 oright->op_flags = oleft->op_flags;
8292 o->op_private |= OPpSORT_INPLACE;
8294 /* excise push->gv->rv2av->null->aassign */
8295 o2 = o->op_next->op_next;
8296 op_null(o2); /* PUSHMARK */
8298 if (o2->op_type == OP_GV) {
8299 op_null(o2); /* GV */
8302 op_null(o2); /* RV2AV or PADAV */
8303 o2 = o2->op_next->op_next;
8304 op_null(o2); /* AASSIGN */
8306 o->op_next = o2->op_next;
8312 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8314 LISTOP *enter, *exlist;
8316 enter = (LISTOP *) o->op_next;
8319 if (enter->op_type == OP_NULL) {
8320 enter = (LISTOP *) enter->op_next;
8324 /* for $a (...) will have OP_GV then OP_RV2GV here.
8325 for (...) just has an OP_GV. */
8326 if (enter->op_type == OP_GV) {
8327 gvop = (OP *) enter;
8328 enter = (LISTOP *) enter->op_next;
8331 if (enter->op_type == OP_RV2GV) {
8332 enter = (LISTOP *) enter->op_next;
8338 if (enter->op_type != OP_ENTERITER)
8341 iter = enter->op_next;
8342 if (!iter || iter->op_type != OP_ITER)
8345 expushmark = enter->op_first;
8346 if (!expushmark || expushmark->op_type != OP_NULL
8347 || expushmark->op_targ != OP_PUSHMARK)
8350 exlist = (LISTOP *) expushmark->op_sibling;
8351 if (!exlist || exlist->op_type != OP_NULL
8352 || exlist->op_targ != OP_LIST)
8355 if (exlist->op_last != o) {
8356 /* Mmm. Was expecting to point back to this op. */
8359 theirmark = exlist->op_first;
8360 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8363 if (theirmark->op_sibling != o) {
8364 /* There's something between the mark and the reverse, eg
8365 for (1, reverse (...))
8370 ourmark = ((LISTOP *)o)->op_first;
8371 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8374 ourlast = ((LISTOP *)o)->op_last;
8375 if (!ourlast || ourlast->op_next != o)
8378 rv2av = ourmark->op_sibling;
8379 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8380 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8381 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8382 /* We're just reversing a single array. */
8383 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8384 enter->op_flags |= OPf_STACKED;
8387 /* We don't have control over who points to theirmark, so sacrifice
8389 theirmark->op_next = ourmark->op_next;
8390 theirmark->op_flags = ourmark->op_flags;
8391 ourlast->op_next = gvop ? gvop : (OP *) enter;
8394 enter->op_private |= OPpITER_REVERSED;
8395 iter->op_private |= OPpITER_REVERSED;
8402 UNOP *refgen, *rv2cv;
8405 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8408 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8411 rv2gv = ((BINOP *)o)->op_last;
8412 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8415 refgen = (UNOP *)((BINOP *)o)->op_first;
8417 if (!refgen || refgen->op_type != OP_REFGEN)
8420 exlist = (LISTOP *)refgen->op_first;
8421 if (!exlist || exlist->op_type != OP_NULL
8422 || exlist->op_targ != OP_LIST)
8425 if (exlist->op_first->op_type != OP_PUSHMARK)
8428 rv2cv = (UNOP*)exlist->op_last;
8430 if (rv2cv->op_type != OP_RV2CV)
8433 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8434 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8435 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8437 o->op_private |= OPpASSIGN_CV_TO_GV;
8438 rv2gv->op_private |= OPpDONT_INIT_GV;
8439 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8447 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8448 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8458 Perl_custom_op_name(pTHX_ const OP* o)
8461 const IV index = PTR2IV(o->op_ppaddr);
8465 if (!PL_custom_op_names) /* This probably shouldn't happen */
8466 return (char *)PL_op_name[OP_CUSTOM];
8468 keysv = sv_2mortal(newSViv(index));
8470 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8472 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8474 return SvPV_nolen(HeVAL(he));
8478 Perl_custom_op_desc(pTHX_ const OP* o)
8481 const IV index = PTR2IV(o->op_ppaddr);
8485 if (!PL_custom_op_descs)
8486 return (char *)PL_op_desc[OP_CUSTOM];
8488 keysv = sv_2mortal(newSViv(index));
8490 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8492 return (char *)PL_op_desc[OP_CUSTOM];
8494 return SvPV_nolen(HeVAL(he));
8499 /* Efficient sub that returns a constant scalar value. */
8501 const_sv_xsub(pTHX_ CV* cv)
8508 Perl_croak(aTHX_ "usage: %s::%s()",
8509 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8513 ST(0) = (SV*)XSANY.any_ptr;
8519 * c-indentation-style: bsd
8521 * indent-tabs-mode: t
8524 * ex: set ts=8 sts=4 sw=4 noet: