3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifdef PERL_DEBUG_READONLY_OPS
108 # define PERL_SLAB_SIZE 4096
109 # include <sys/mman.h>
112 #ifndef PERL_SLAB_SIZE
113 #define PERL_SLAB_SIZE 2048
117 Perl_Slab_Alloc(pTHX_ size_t sz)
120 * To make incrementing use count easy PL_OpSlab is an I32 *
121 * To make inserting the link to slab PL_OpPtr is I32 **
122 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
123 * Add an overhead for pointer to slab and round up as a number of pointers
125 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
126 if ((PL_OpSpace -= sz) < 0) {
127 #ifdef PERL_DEBUG_READONLY_OPS
128 /* We need to allocate chunk by chunk so that we can control the VM
130 PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
131 MAP_ANON|MAP_PRIVATE, -1, 0);
133 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
134 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
136 if(PL_OpPtr == MAP_FAILED) {
137 perror("mmap failed");
142 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
147 /* We reserve the 0'th I32 sized chunk as a use count */
148 PL_OpSlab = (I32 *) PL_OpPtr;
149 /* Reduce size by the use count word, and by the size we need.
150 * Latter is to mimic the '-=' in the if() above
152 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
153 /* Allocation pointer starts at the top.
154 Theory: because we build leaves before trunk allocating at end
155 means that at run time access is cache friendly upward
157 PL_OpPtr += PERL_SLAB_SIZE;
159 #ifdef PERL_DEBUG_READONLY_OPS
160 /* We remember this slab. */
161 /* This implementation isn't efficient, but it is simple. */
162 PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
163 PL_slabs[PL_slab_count++] = PL_OpSlab;
164 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
167 assert( PL_OpSpace >= 0 );
168 /* Move the allocation pointer down */
170 assert( PL_OpPtr > (I32 **) PL_OpSlab );
171 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
172 (*PL_OpSlab)++; /* Increment use count of slab */
173 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
174 assert( *PL_OpSlab > 0 );
175 return (void *)(PL_OpPtr + 1);
178 #ifdef PERL_DEBUG_READONLY_OPS
180 Perl_pending_Slabs_to_ro(pTHX) {
181 /* Turn all the allocated op slabs read only. */
182 U32 count = PL_slab_count;
183 I32 **const slabs = PL_slabs;
185 /* Reset the array of pending OP slabs, as we're about to turn this lot
186 read only. Also, do it ahead of the loop in case the warn triggers,
187 and a warn handler has an eval */
192 /* Force a new slab for any further allocation. */
196 void *const start = slabs[count];
197 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
198 if(mprotect(start, size, PROT_READ)) {
199 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
200 start, (unsigned long) size, errno);
208 S_Slab_to_rw(pTHX_ void *op)
210 I32 * const * const ptr = (I32 **) op;
211 I32 * const slab = ptr[-1];
212 assert( ptr-1 > (I32 **) slab );
213 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
215 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
216 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
217 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
222 Perl_op_refcnt_inc(pTHX_ OP *o)
233 Perl_op_refcnt_dec(pTHX_ OP *o)
239 # define Slab_to_rw(op)
243 Perl_Slab_Free(pTHX_ void *op)
245 I32 * const * const ptr = (I32 **) op;
246 I32 * const slab = ptr[-1];
247 assert( ptr-1 > (I32 **) slab );
248 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
251 if (--(*slab) == 0) {
253 # define PerlMemShared PerlMem
256 #ifdef PERL_DEBUG_READONLY_OPS
257 U32 count = PL_slab_count;
258 /* Need to remove this slab from our list of slabs */
261 if (PL_slabs[count] == slab) {
262 /* Found it. Move the entry at the end to overwrite it. */
263 DEBUG_m(PerlIO_printf(Perl_debug_log,
264 "Deallocate %p by moving %p from %lu to %lu\n",
266 PL_slabs[PL_slab_count - 1],
267 PL_slab_count, count));
268 PL_slabs[count] = PL_slabs[--PL_slab_count];
269 /* Could realloc smaller at this point, but probably not
271 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
272 perror("munmap failed");
280 PerlMemShared_free(slab);
282 if (slab == PL_OpSlab) {
289 * In the following definition, the ", (OP*)0" is just to make the compiler
290 * think the expression is of the right type: croak actually does a Siglongjmp.
292 #define CHECKOP(type,o) \
293 ((PL_op_mask && PL_op_mask[type]) \
294 ? ( op_free((OP*)o), \
295 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
297 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
299 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
302 S_gv_ename(pTHX_ GV *gv)
304 SV* const tmpsv = sv_newmortal();
305 gv_efullname3(tmpsv, gv, NULL);
306 return SvPV_nolen_const(tmpsv);
310 S_no_fh_allowed(pTHX_ OP *o)
312 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
318 S_too_few_arguments(pTHX_ OP *o, const char *name)
320 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
325 S_too_many_arguments(pTHX_ OP *o, const char *name)
327 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
332 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
334 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
335 (int)n, name, t, OP_DESC(kid)));
339 S_no_bareword_allowed(pTHX_ const OP *o)
342 return; /* various ok barewords are hidden in extra OP_NULL */
343 qerror(Perl_mess(aTHX_
344 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
348 /* "register" allocation */
351 Perl_allocmy(pTHX_ const char *const name)
355 const bool is_our = (PL_parser->in_my == KEY_our);
357 /* complain about "my $<special_var>" etc etc */
361 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
362 (name[1] == '_' && (*name == '$' || name[2]))))
364 /* name[2] is true if strlen(name) > 2 */
365 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
366 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
367 name[0], toCTRL(name[1]), name + 2));
369 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
373 /* check for duplicate declaration */
374 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
376 if (PL_parser->in_my_stash && *name != '$') {
377 yyerror(Perl_form(aTHX_
378 "Can't declare class for non-scalar %s in \"%s\"",
381 : PL_parser->in_my == KEY_state ? "state" : "my"));
384 /* allocate a spare slot and store the name in that slot */
386 off = pad_add_name(name,
387 PL_parser->in_my_stash,
389 /* $_ is always in main::, even with our */
390 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
394 PL_parser->in_my == KEY_state
399 /* free the body of an op without examining its contents.
400 * Always use this rather than FreeOp directly */
403 S_op_destroy(pTHX_ OP *o)
405 if (o->op_latefree) {
413 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
415 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
421 Perl_op_free(pTHX_ OP *o)
428 if (o->op_latefreed) {
435 if (o->op_private & OPpREFCOUNTED) {
446 refcnt = OpREFCNT_dec(o);
449 /* Need to find and remove any pattern match ops from the list
450 we maintain for reset(). */
451 find_and_forget_pmops(o);
461 if (o->op_flags & OPf_KIDS) {
462 register OP *kid, *nextkid;
463 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
464 nextkid = kid->op_sibling; /* Get before next freeing kid */
469 type = (OPCODE)o->op_targ;
471 #ifdef PERL_DEBUG_READONLY_OPS
475 /* COP* is not cleared by op_clear() so that we may track line
476 * numbers etc even after null() */
477 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
482 if (o->op_latefree) {
488 #ifdef DEBUG_LEAKING_SCALARS
495 Perl_op_clear(pTHX_ OP *o)
500 /* if (o->op_madprop && o->op_madprop->mad_next)
502 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
503 "modification of a read only value" for a reason I can't fathom why.
504 It's the "" stringification of $_, where $_ was set to '' in a foreach
505 loop, but it defies simplification into a small test case.
506 However, commenting them out has caused ext/List/Util/t/weak.t to fail
509 mad_free(o->op_madprop);
515 switch (o->op_type) {
516 case OP_NULL: /* Was holding old type, if any. */
517 if (PL_madskills && o->op_targ != OP_NULL) {
518 o->op_type = o->op_targ;
522 case OP_ENTEREVAL: /* Was holding hints. */
526 if (!(o->op_flags & OPf_REF)
527 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
533 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
534 /* not an OP_PADAV replacement */
536 if (cPADOPo->op_padix > 0) {
537 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
538 * may still exist on the pad */
539 pad_swipe(cPADOPo->op_padix, TRUE);
540 cPADOPo->op_padix = 0;
543 SvREFCNT_dec(cSVOPo->op_sv);
544 cSVOPo->op_sv = NULL;
548 case OP_METHOD_NAMED:
550 SvREFCNT_dec(cSVOPo->op_sv);
551 cSVOPo->op_sv = NULL;
554 Even if op_clear does a pad_free for the target of the op,
555 pad_free doesn't actually remove the sv that exists in the pad;
556 instead it lives on. This results in that it could be reused as
557 a target later on when the pad was reallocated.
560 pad_swipe(o->op_targ,1);
569 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
573 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
575 if (cPADOPo->op_padix > 0) {
576 pad_swipe(cPADOPo->op_padix, TRUE);
577 cPADOPo->op_padix = 0;
580 SvREFCNT_dec(cSVOPo->op_sv);
581 cSVOPo->op_sv = NULL;
585 PerlMemShared_free(cPVOPo->op_pv);
586 cPVOPo->op_pv = NULL;
590 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
594 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
595 /* No GvIN_PAD_off here, because other references may still
596 * exist on the pad */
597 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
600 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
606 forget_pmop(cPMOPo, 1);
607 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
608 /* we use the "SAFE" version of the PM_ macros here
609 * since sv_clean_all might release some PMOPs
610 * after PL_regex_padav has been cleared
611 * and the clearing of PL_regex_padav needs to
612 * happen before sv_clean_all
614 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
615 PM_SETRE_SAFE(cPMOPo, NULL);
617 if(PL_regex_pad) { /* We could be in destruction */
618 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
619 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
620 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
621 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
628 if (o->op_targ > 0) {
629 pad_free(o->op_targ);
635 S_cop_free(pTHX_ COP* cop)
640 if (! specialWARN(cop->cop_warnings))
641 PerlMemShared_free(cop->cop_warnings);
642 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
646 S_forget_pmop(pTHX_ PMOP *const o
652 HV * const pmstash = PmopSTASH(o);
653 if (pmstash && !SvIS_FREED(pmstash)) {
654 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
656 PMOP **const array = (PMOP**) mg->mg_ptr;
657 U32 count = mg->mg_len / sizeof(PMOP**);
662 /* Found it. Move the entry at the end to overwrite it. */
663 array[i] = array[--count];
664 mg->mg_len = count * sizeof(PMOP**);
665 /* Could realloc smaller at this point always, but probably
666 not worth it. Probably worth free()ing if we're the
669 Safefree(mg->mg_ptr);
686 S_find_and_forget_pmops(pTHX_ OP *o)
688 if (o->op_flags & OPf_KIDS) {
689 OP *kid = cUNOPo->op_first;
691 switch (kid->op_type) {
696 forget_pmop((PMOP*)kid, 0);
698 find_and_forget_pmops(kid);
699 kid = kid->op_sibling;
705 Perl_op_null(pTHX_ OP *o)
708 if (o->op_type == OP_NULL)
712 o->op_targ = o->op_type;
713 o->op_type = OP_NULL;
714 o->op_ppaddr = PL_ppaddr[OP_NULL];
718 Perl_op_refcnt_lock(pTHX)
726 Perl_op_refcnt_unlock(pTHX)
733 /* Contextualizers */
735 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
738 Perl_linklist(pTHX_ OP *o)
745 /* establish postfix order */
746 first = cUNOPo->op_first;
749 o->op_next = LINKLIST(first);
752 if (kid->op_sibling) {
753 kid->op_next = LINKLIST(kid->op_sibling);
754 kid = kid->op_sibling;
768 Perl_scalarkids(pTHX_ OP *o)
770 if (o && o->op_flags & OPf_KIDS) {
772 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
779 S_scalarboolean(pTHX_ OP *o)
782 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
783 if (ckWARN(WARN_SYNTAX)) {
784 const line_t oldline = CopLINE(PL_curcop);
786 if (PL_parser && PL_parser->copline != NOLINE)
787 CopLINE_set(PL_curcop, PL_parser->copline);
788 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
789 CopLINE_set(PL_curcop, oldline);
796 Perl_scalar(pTHX_ OP *o)
801 /* assumes no premature commitment */
802 if (!o || (PL_parser && PL_parser->error_count)
803 || (o->op_flags & OPf_WANT)
804 || o->op_type == OP_RETURN)
809 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
811 switch (o->op_type) {
813 scalar(cBINOPo->op_first);
818 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
822 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
823 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
824 deprecate_old("implicit split to @_");
832 if (o->op_flags & OPf_KIDS) {
833 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
839 kid = cLISTOPo->op_first;
841 while ((kid = kid->op_sibling)) {
847 PL_curcop = &PL_compiling;
852 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
858 PL_curcop = &PL_compiling;
861 if (ckWARN(WARN_VOID))
862 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
868 Perl_scalarvoid(pTHX_ OP *o)
872 const char* useless = NULL;
876 /* trailing mad null ops don't count as "there" for void processing */
878 o->op_type != OP_NULL &&
880 o->op_sibling->op_type == OP_NULL)
883 for (sib = o->op_sibling;
884 sib && sib->op_type == OP_NULL;
885 sib = sib->op_sibling) ;
891 if (o->op_type == OP_NEXTSTATE
892 || o->op_type == OP_SETSTATE
893 || o->op_type == OP_DBSTATE
894 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
895 || o->op_targ == OP_SETSTATE
896 || o->op_targ == OP_DBSTATE)))
897 PL_curcop = (COP*)o; /* for warning below */
899 /* assumes no premature commitment */
900 want = o->op_flags & OPf_WANT;
901 if ((want && want != OPf_WANT_SCALAR)
902 || (PL_parser && PL_parser->error_count)
903 || o->op_type == OP_RETURN)
908 if ((o->op_private & OPpTARGET_MY)
909 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
911 return scalar(o); /* As if inside SASSIGN */
914 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
916 switch (o->op_type) {
918 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
922 if (o->op_flags & OPf_STACKED)
926 if (o->op_private == 4)
998 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
999 useless = OP_DESC(o);
1003 kid = cUNOPo->op_first;
1004 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1005 kid->op_type != OP_TRANS) {
1008 useless = "negative pattern binding (!~)";
1015 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1016 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1017 useless = "a variable";
1022 if (cSVOPo->op_private & OPpCONST_STRICT)
1023 no_bareword_allowed(o);
1025 if (ckWARN(WARN_VOID)) {
1026 useless = "a constant";
1027 if (o->op_private & OPpCONST_ARYBASE)
1029 /* don't warn on optimised away booleans, eg
1030 * use constant Foo, 5; Foo || print; */
1031 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1033 /* the constants 0 and 1 are permitted as they are
1034 conventionally used as dummies in constructs like
1035 1 while some_condition_with_side_effects; */
1036 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1038 else if (SvPOK(sv)) {
1039 /* perl4's way of mixing documentation and code
1040 (before the invention of POD) was based on a
1041 trick to mix nroff and perl code. The trick was
1042 built upon these three nroff macros being used in
1043 void context. The pink camel has the details in
1044 the script wrapman near page 319. */
1045 const char * const maybe_macro = SvPVX_const(sv);
1046 if (strnEQ(maybe_macro, "di", 2) ||
1047 strnEQ(maybe_macro, "ds", 2) ||
1048 strnEQ(maybe_macro, "ig", 2))
1053 op_null(o); /* don't execute or even remember it */
1057 o->op_type = OP_PREINC; /* pre-increment is faster */
1058 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1062 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1063 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1067 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1068 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1072 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1073 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1082 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1087 if (o->op_flags & OPf_STACKED)
1094 if (!(o->op_flags & OPf_KIDS))
1105 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1112 /* all requires must return a boolean value */
1113 o->op_flags &= ~OPf_WANT;
1118 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1119 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1120 deprecate_old("implicit split to @_");
1124 if (useless && ckWARN(WARN_VOID))
1125 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1130 Perl_listkids(pTHX_ OP *o)
1132 if (o && o->op_flags & OPf_KIDS) {
1134 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1141 Perl_list(pTHX_ OP *o)
1146 /* assumes no premature commitment */
1147 if (!o || (o->op_flags & OPf_WANT)
1148 || (PL_parser && PL_parser->error_count)
1149 || o->op_type == OP_RETURN)
1154 if ((o->op_private & OPpTARGET_MY)
1155 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1157 return o; /* As if inside SASSIGN */
1160 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1162 switch (o->op_type) {
1165 list(cBINOPo->op_first);
1170 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1178 if (!(o->op_flags & OPf_KIDS))
1180 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1181 list(cBINOPo->op_first);
1182 return gen_constant_list(o);
1189 kid = cLISTOPo->op_first;
1191 while ((kid = kid->op_sibling)) {
1192 if (kid->op_sibling)
1197 PL_curcop = &PL_compiling;
1201 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1202 if (kid->op_sibling)
1207 PL_curcop = &PL_compiling;
1210 /* all requires must return a boolean value */
1211 o->op_flags &= ~OPf_WANT;
1218 Perl_scalarseq(pTHX_ OP *o)
1222 const OPCODE type = o->op_type;
1224 if (type == OP_LINESEQ || type == OP_SCOPE ||
1225 type == OP_LEAVE || type == OP_LEAVETRY)
1228 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1229 if (kid->op_sibling) {
1233 PL_curcop = &PL_compiling;
1235 o->op_flags &= ~OPf_PARENS;
1236 if (PL_hints & HINT_BLOCK_SCOPE)
1237 o->op_flags |= OPf_PARENS;
1240 o = newOP(OP_STUB, 0);
1245 S_modkids(pTHX_ OP *o, I32 type)
1247 if (o && o->op_flags & OPf_KIDS) {
1249 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1255 /* Propagate lvalue ("modifiable") context to an op and its children.
1256 * 'type' represents the context type, roughly based on the type of op that
1257 * would do the modifying, although local() is represented by OP_NULL.
1258 * It's responsible for detecting things that can't be modified, flag
1259 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1260 * might have to vivify a reference in $x), and so on.
1262 * For example, "$a+1 = 2" would cause mod() to be called with o being
1263 * OP_ADD and type being OP_SASSIGN, and would output an error.
1267 Perl_mod(pTHX_ OP *o, I32 type)
1271 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1274 if (!o || (PL_parser && PL_parser->error_count))
1277 if ((o->op_private & OPpTARGET_MY)
1278 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1283 switch (o->op_type) {
1289 if (!(o->op_private & OPpCONST_ARYBASE))
1292 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1293 CopARYBASE_set(&PL_compiling,
1294 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1298 SAVECOPARYBASE(&PL_compiling);
1299 CopARYBASE_set(&PL_compiling, 0);
1301 else if (type == OP_REFGEN)
1304 Perl_croak(aTHX_ "That use of $[ is unsupported");
1307 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1311 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1312 !(o->op_flags & OPf_STACKED)) {
1313 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1314 /* The default is to set op_private to the number of children,
1315 which for a UNOP such as RV2CV is always 1. And w're using
1316 the bit for a flag in RV2CV, so we need it clear. */
1317 o->op_private &= ~1;
1318 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1319 assert(cUNOPo->op_first->op_type == OP_NULL);
1320 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1323 else if (o->op_private & OPpENTERSUB_NOMOD)
1325 else { /* lvalue subroutine call */
1326 o->op_private |= OPpLVAL_INTRO;
1327 PL_modcount = RETURN_UNLIMITED_NUMBER;
1328 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1329 /* Backward compatibility mode: */
1330 o->op_private |= OPpENTERSUB_INARGS;
1333 else { /* Compile-time error message: */
1334 OP *kid = cUNOPo->op_first;
1338 if (kid->op_type != OP_PUSHMARK) {
1339 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1341 "panic: unexpected lvalue entersub "
1342 "args: type/targ %ld:%"UVuf,
1343 (long)kid->op_type, (UV)kid->op_targ);
1344 kid = kLISTOP->op_first;
1346 while (kid->op_sibling)
1347 kid = kid->op_sibling;
1348 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1350 if (kid->op_type == OP_METHOD_NAMED
1351 || kid->op_type == OP_METHOD)
1355 NewOp(1101, newop, 1, UNOP);
1356 newop->op_type = OP_RV2CV;
1357 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1358 newop->op_first = NULL;
1359 newop->op_next = (OP*)newop;
1360 kid->op_sibling = (OP*)newop;
1361 newop->op_private |= OPpLVAL_INTRO;
1362 newop->op_private &= ~1;
1366 if (kid->op_type != OP_RV2CV)
1368 "panic: unexpected lvalue entersub "
1369 "entry via type/targ %ld:%"UVuf,
1370 (long)kid->op_type, (UV)kid->op_targ);
1371 kid->op_private |= OPpLVAL_INTRO;
1372 break; /* Postpone until runtime */
1376 kid = kUNOP->op_first;
1377 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1378 kid = kUNOP->op_first;
1379 if (kid->op_type == OP_NULL)
1381 "Unexpected constant lvalue entersub "
1382 "entry via type/targ %ld:%"UVuf,
1383 (long)kid->op_type, (UV)kid->op_targ);
1384 if (kid->op_type != OP_GV) {
1385 /* Restore RV2CV to check lvalueness */
1387 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1388 okid->op_next = kid->op_next;
1389 kid->op_next = okid;
1392 okid->op_next = NULL;
1393 okid->op_type = OP_RV2CV;
1395 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1396 okid->op_private |= OPpLVAL_INTRO;
1397 okid->op_private &= ~1;
1401 cv = GvCV(kGVOP_gv);
1411 /* grep, foreach, subcalls, refgen */
1412 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1414 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1415 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1417 : (o->op_type == OP_ENTERSUB
1418 ? "non-lvalue subroutine call"
1420 type ? PL_op_desc[type] : "local"));
1434 case OP_RIGHT_SHIFT:
1443 if (!(o->op_flags & OPf_STACKED))
1450 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1456 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1457 PL_modcount = RETURN_UNLIMITED_NUMBER;
1458 return o; /* Treat \(@foo) like ordinary list. */
1462 if (scalar_mod_type(o, type))
1464 ref(cUNOPo->op_first, o->op_type);
1468 if (type == OP_LEAVESUBLV)
1469 o->op_private |= OPpMAYBE_LVSUB;
1475 PL_modcount = RETURN_UNLIMITED_NUMBER;
1478 ref(cUNOPo->op_first, o->op_type);
1483 PL_hints |= HINT_BLOCK_SCOPE;
1498 PL_modcount = RETURN_UNLIMITED_NUMBER;
1499 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1500 return o; /* Treat \(@foo) like ordinary list. */
1501 if (scalar_mod_type(o, type))
1503 if (type == OP_LEAVESUBLV)
1504 o->op_private |= OPpMAYBE_LVSUB;
1508 if (!type) /* local() */
1509 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1510 PAD_COMPNAME_PV(o->op_targ));
1518 if (type != OP_SASSIGN)
1522 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1527 if (type == OP_LEAVESUBLV)
1528 o->op_private |= OPpMAYBE_LVSUB;
1530 pad_free(o->op_targ);
1531 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1532 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1533 if (o->op_flags & OPf_KIDS)
1534 mod(cBINOPo->op_first->op_sibling, type);
1539 ref(cBINOPo->op_first, o->op_type);
1540 if (type == OP_ENTERSUB &&
1541 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1542 o->op_private |= OPpLVAL_DEFER;
1543 if (type == OP_LEAVESUBLV)
1544 o->op_private |= OPpMAYBE_LVSUB;
1554 if (o->op_flags & OPf_KIDS)
1555 mod(cLISTOPo->op_last, type);
1560 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1562 else if (!(o->op_flags & OPf_KIDS))
1564 if (o->op_targ != OP_LIST) {
1565 mod(cBINOPo->op_first, type);
1571 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1576 if (type != OP_LEAVESUBLV)
1578 break; /* mod()ing was handled by ck_return() */
1581 /* [20011101.069] File test operators interpret OPf_REF to mean that
1582 their argument is a filehandle; thus \stat(".") should not set
1584 if (type == OP_REFGEN &&
1585 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1588 if (type != OP_LEAVESUBLV)
1589 o->op_flags |= OPf_MOD;
1591 if (type == OP_AASSIGN || type == OP_SASSIGN)
1592 o->op_flags |= OPf_SPECIAL|OPf_REF;
1593 else if (!type) { /* local() */
1596 o->op_private |= OPpLVAL_INTRO;
1597 o->op_flags &= ~OPf_SPECIAL;
1598 PL_hints |= HINT_BLOCK_SCOPE;
1603 if (ckWARN(WARN_SYNTAX)) {
1604 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1605 "Useless localization of %s", OP_DESC(o));
1609 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1610 && type != OP_LEAVESUBLV)
1611 o->op_flags |= OPf_REF;
1616 S_scalar_mod_type(const OP *o, I32 type)
1620 if (o->op_type == OP_RV2GV)
1644 case OP_RIGHT_SHIFT:
1664 S_is_handle_constructor(const OP *o, I32 numargs)
1666 switch (o->op_type) {
1674 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1687 Perl_refkids(pTHX_ OP *o, I32 type)
1689 if (o && o->op_flags & OPf_KIDS) {
1691 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1698 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1703 if (!o || (PL_parser && PL_parser->error_count))
1706 switch (o->op_type) {
1708 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1709 !(o->op_flags & OPf_STACKED)) {
1710 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1711 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1712 assert(cUNOPo->op_first->op_type == OP_NULL);
1713 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1714 o->op_flags |= OPf_SPECIAL;
1715 o->op_private &= ~1;
1720 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1721 doref(kid, type, set_op_ref);
1724 if (type == OP_DEFINED)
1725 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1726 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1729 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1730 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1731 : type == OP_RV2HV ? OPpDEREF_HV
1733 o->op_flags |= OPf_MOD;
1740 o->op_flags |= OPf_REF;
1743 if (type == OP_DEFINED)
1744 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1745 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1751 o->op_flags |= OPf_REF;
1756 if (!(o->op_flags & OPf_KIDS))
1758 doref(cBINOPo->op_first, type, set_op_ref);
1762 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1763 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1764 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1765 : type == OP_RV2HV ? OPpDEREF_HV
1767 o->op_flags |= OPf_MOD;
1777 if (!(o->op_flags & OPf_KIDS))
1779 doref(cLISTOPo->op_last, type, set_op_ref);
1789 S_dup_attrlist(pTHX_ OP *o)
1794 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1795 * where the first kid is OP_PUSHMARK and the remaining ones
1796 * are OP_CONST. We need to push the OP_CONST values.
1798 if (o->op_type == OP_CONST)
1799 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1801 else if (o->op_type == OP_NULL)
1805 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1807 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1808 if (o->op_type == OP_CONST)
1809 rop = append_elem(OP_LIST, rop,
1810 newSVOP(OP_CONST, o->op_flags,
1811 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1818 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1823 /* fake up C<use attributes $pkg,$rv,@attrs> */
1824 ENTER; /* need to protect against side-effects of 'use' */
1825 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1827 #define ATTRSMODULE "attributes"
1828 #define ATTRSMODULE_PM "attributes.pm"
1831 /* Don't force the C<use> if we don't need it. */
1832 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1833 if (svp && *svp != &PL_sv_undef)
1834 NOOP; /* already in %INC */
1836 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1837 newSVpvs(ATTRSMODULE), NULL);
1840 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1841 newSVpvs(ATTRSMODULE),
1843 prepend_elem(OP_LIST,
1844 newSVOP(OP_CONST, 0, stashsv),
1845 prepend_elem(OP_LIST,
1846 newSVOP(OP_CONST, 0,
1848 dup_attrlist(attrs))));
1854 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1857 OP *pack, *imop, *arg;
1863 assert(target->op_type == OP_PADSV ||
1864 target->op_type == OP_PADHV ||
1865 target->op_type == OP_PADAV);
1867 /* Ensure that attributes.pm is loaded. */
1868 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1870 /* Need package name for method call. */
1871 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1873 /* Build up the real arg-list. */
1874 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1876 arg = newOP(OP_PADSV, 0);
1877 arg->op_targ = target->op_targ;
1878 arg = prepend_elem(OP_LIST,
1879 newSVOP(OP_CONST, 0, stashsv),
1880 prepend_elem(OP_LIST,
1881 newUNOP(OP_REFGEN, 0,
1882 mod(arg, OP_REFGEN)),
1883 dup_attrlist(attrs)));
1885 /* Fake up a method call to import */
1886 meth = newSVpvs_share("import");
1887 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1888 append_elem(OP_LIST,
1889 prepend_elem(OP_LIST, pack, list(arg)),
1890 newSVOP(OP_METHOD_NAMED, 0, meth)));
1891 imop->op_private |= OPpENTERSUB_NOMOD;
1893 /* Combine the ops. */
1894 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1898 =notfor apidoc apply_attrs_string
1900 Attempts to apply a list of attributes specified by the C<attrstr> and
1901 C<len> arguments to the subroutine identified by the C<cv> argument which
1902 is expected to be associated with the package identified by the C<stashpv>
1903 argument (see L<attributes>). It gets this wrong, though, in that it
1904 does not correctly identify the boundaries of the individual attribute
1905 specifications within C<attrstr>. This is not really intended for the
1906 public API, but has to be listed here for systems such as AIX which
1907 need an explicit export list for symbols. (It's called from XS code
1908 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1909 to respect attribute syntax properly would be welcome.
1915 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1916 const char *attrstr, STRLEN len)
1921 len = strlen(attrstr);
1925 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1927 const char * const sstr = attrstr;
1928 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1929 attrs = append_elem(OP_LIST, attrs,
1930 newSVOP(OP_CONST, 0,
1931 newSVpvn(sstr, attrstr-sstr)));
1935 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1936 newSVpvs(ATTRSMODULE),
1937 NULL, prepend_elem(OP_LIST,
1938 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1939 prepend_elem(OP_LIST,
1940 newSVOP(OP_CONST, 0,
1946 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1951 if (!o || (PL_parser && PL_parser->error_count))
1955 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1956 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1960 if (type == OP_LIST) {
1962 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1963 my_kid(kid, attrs, imopsp);
1964 } else if (type == OP_UNDEF
1970 } else if (type == OP_RV2SV || /* "our" declaration */
1972 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1973 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1974 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1976 PL_parser->in_my == KEY_our
1978 : PL_parser->in_my == KEY_state ? "state" : "my"));
1980 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1981 PL_parser->in_my = FALSE;
1982 PL_parser->in_my_stash = NULL;
1983 apply_attrs(GvSTASH(gv),
1984 (type == OP_RV2SV ? GvSV(gv) :
1985 type == OP_RV2AV ? (SV*)GvAV(gv) :
1986 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1989 o->op_private |= OPpOUR_INTRO;
1992 else if (type != OP_PADSV &&
1995 type != OP_PUSHMARK)
1997 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1999 PL_parser->in_my == KEY_our
2001 : PL_parser->in_my == KEY_state ? "state" : "my"));
2004 else if (attrs && type != OP_PUSHMARK) {
2007 PL_parser->in_my = FALSE;
2008 PL_parser->in_my_stash = NULL;
2010 /* check for C<my Dog $spot> when deciding package */
2011 stash = PAD_COMPNAME_TYPE(o->op_targ);
2013 stash = PL_curstash;
2014 apply_attrs_my(stash, o, attrs, imopsp);
2016 o->op_flags |= OPf_MOD;
2017 o->op_private |= OPpLVAL_INTRO;
2018 if (PL_parser->in_my == KEY_state)
2019 o->op_private |= OPpPAD_STATE;
2024 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2028 int maybe_scalar = 0;
2030 /* [perl #17376]: this appears to be premature, and results in code such as
2031 C< our(%x); > executing in list mode rather than void mode */
2033 if (o->op_flags & OPf_PARENS)
2043 o = my_kid(o, attrs, &rops);
2045 if (maybe_scalar && o->op_type == OP_PADSV) {
2046 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2047 o->op_private |= OPpLVAL_INTRO;
2050 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2052 PL_parser->in_my = FALSE;
2053 PL_parser->in_my_stash = NULL;
2058 Perl_my(pTHX_ OP *o)
2060 return my_attrs(o, NULL);
2064 Perl_sawparens(pTHX_ OP *o)
2066 PERL_UNUSED_CONTEXT;
2068 o->op_flags |= OPf_PARENS;
2073 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2077 const OPCODE ltype = left->op_type;
2078 const OPCODE rtype = right->op_type;
2080 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2081 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2083 const char * const desc
2084 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2085 ? (int)rtype : OP_MATCH];
2086 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2087 ? "@array" : "%hash");
2088 Perl_warner(aTHX_ packWARN(WARN_MISC),
2089 "Applying %s to %s will act on scalar(%s)",
2090 desc, sample, sample);
2093 if (rtype == OP_CONST &&
2094 cSVOPx(right)->op_private & OPpCONST_BARE &&
2095 cSVOPx(right)->op_private & OPpCONST_STRICT)
2097 no_bareword_allowed(right);
2100 ismatchop = rtype == OP_MATCH ||
2101 rtype == OP_SUBST ||
2103 if (ismatchop && right->op_private & OPpTARGET_MY) {
2105 right->op_private &= ~OPpTARGET_MY;
2107 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2110 right->op_flags |= OPf_STACKED;
2111 if (rtype != OP_MATCH &&
2112 ! (rtype == OP_TRANS &&
2113 right->op_private & OPpTRANS_IDENTICAL))
2114 newleft = mod(left, rtype);
2117 if (right->op_type == OP_TRANS)
2118 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2120 o = prepend_elem(rtype, scalar(newleft), right);
2122 return newUNOP(OP_NOT, 0, scalar(o));
2126 return bind_match(type, left,
2127 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2131 Perl_invert(pTHX_ OP *o)
2135 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2139 Perl_scope(pTHX_ OP *o)
2143 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2144 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2145 o->op_type = OP_LEAVE;
2146 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2148 else if (o->op_type == OP_LINESEQ) {
2150 o->op_type = OP_SCOPE;
2151 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2152 kid = ((LISTOP*)o)->op_first;
2153 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2156 /* The following deals with things like 'do {1 for 1}' */
2157 kid = kid->op_sibling;
2159 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2164 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2170 Perl_block_start(pTHX_ int full)
2173 const int retval = PL_savestack_ix;
2174 pad_block_start(full);
2176 PL_hints &= ~HINT_BLOCK_SCOPE;
2177 SAVECOMPILEWARNINGS();
2178 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2183 Perl_block_end(pTHX_ I32 floor, OP *seq)
2186 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2187 OP* const retval = scalarseq(seq);
2189 CopHINTS_set(&PL_compiling, PL_hints);
2191 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2200 const PADOFFSET offset = pad_findmy("$_");
2201 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2202 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2205 OP * const o = newOP(OP_PADSV, 0);
2206 o->op_targ = offset;
2212 Perl_newPROG(pTHX_ OP *o)
2218 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2219 ((PL_in_eval & EVAL_KEEPERR)
2220 ? OPf_SPECIAL : 0), o);
2221 PL_eval_start = linklist(PL_eval_root);
2222 PL_eval_root->op_private |= OPpREFCOUNTED;
2223 OpREFCNT_set(PL_eval_root, 1);
2224 PL_eval_root->op_next = 0;
2225 CALL_PEEP(PL_eval_start);
2228 if (o->op_type == OP_STUB) {
2229 PL_comppad_name = 0;
2231 S_op_destroy(aTHX_ o);
2234 PL_main_root = scope(sawparens(scalarvoid(o)));
2235 PL_curcop = &PL_compiling;
2236 PL_main_start = LINKLIST(PL_main_root);
2237 PL_main_root->op_private |= OPpREFCOUNTED;
2238 OpREFCNT_set(PL_main_root, 1);
2239 PL_main_root->op_next = 0;
2240 CALL_PEEP(PL_main_start);
2243 /* Register with debugger */
2246 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2250 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2252 call_sv((SV*)cv, G_DISCARD);
2259 Perl_localize(pTHX_ OP *o, I32 lex)
2262 if (o->op_flags & OPf_PARENS)
2263 /* [perl #17376]: this appears to be premature, and results in code such as
2264 C< our(%x); > executing in list mode rather than void mode */
2271 if ( PL_parser->bufptr > PL_parser->oldbufptr
2272 && PL_parser->bufptr[-1] == ','
2273 && ckWARN(WARN_PARENTHESIS))
2275 char *s = PL_parser->bufptr;
2278 /* some heuristics to detect a potential error */
2279 while (*s && (strchr(", \t\n", *s)))
2283 if (*s && strchr("@$%*", *s) && *++s
2284 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2287 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2289 while (*s && (strchr(", \t\n", *s)))
2295 if (sigil && (*s == ';' || *s == '=')) {
2296 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2297 "Parentheses missing around \"%s\" list",
2299 ? (PL_parser->in_my == KEY_our
2301 : PL_parser->in_my == KEY_state
2311 o = mod(o, OP_NULL); /* a bit kludgey */
2312 PL_parser->in_my = FALSE;
2313 PL_parser->in_my_stash = NULL;
2318 Perl_jmaybe(pTHX_ OP *o)
2320 if (o->op_type == OP_LIST) {
2322 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2323 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2329 Perl_fold_constants(pTHX_ register OP *o)
2334 VOL I32 type = o->op_type;
2339 SV * const oldwarnhook = PL_warnhook;
2340 SV * const olddiehook = PL_diehook;
2343 if (PL_opargs[type] & OA_RETSCALAR)
2345 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2346 o->op_targ = pad_alloc(type, SVs_PADTMP);
2348 /* integerize op, unless it happens to be C<-foo>.
2349 * XXX should pp_i_negate() do magic string negation instead? */
2350 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2351 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2352 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2354 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2357 if (!(PL_opargs[type] & OA_FOLDCONST))
2362 /* XXX might want a ck_negate() for this */
2363 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2374 /* XXX what about the numeric ops? */
2375 if (PL_hints & HINT_LOCALE)
2379 if (PL_parser && PL_parser->error_count)
2380 goto nope; /* Don't try to run w/ errors */
2382 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2383 const OPCODE type = curop->op_type;
2384 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2386 type != OP_SCALAR &&
2388 type != OP_PUSHMARK)
2394 curop = LINKLIST(o);
2395 old_next = o->op_next;
2399 oldscope = PL_scopestack_ix;
2400 create_eval_scope(G_FAKINGEVAL);
2402 PL_warnhook = PERL_WARNHOOK_FATAL;
2409 sv = *(PL_stack_sp--);
2410 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2411 pad_swipe(o->op_targ, FALSE);
2412 else if (SvTEMP(sv)) { /* grab mortal temp? */
2413 SvREFCNT_inc_simple_void(sv);
2418 /* Something tried to die. Abandon constant folding. */
2419 /* Pretend the error never happened. */
2420 sv_setpvn(ERRSV,"",0);
2421 o->op_next = old_next;
2425 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2426 PL_warnhook = oldwarnhook;
2427 PL_diehook = olddiehook;
2428 /* XXX note that this croak may fail as we've already blown away
2429 * the stack - eg any nested evals */
2430 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2433 PL_warnhook = oldwarnhook;
2434 PL_diehook = olddiehook;
2436 if (PL_scopestack_ix > oldscope)
2437 delete_eval_scope();
2446 if (type == OP_RV2GV)
2447 newop = newGVOP(OP_GV, 0, (GV*)sv);
2449 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2450 op_getmad(o,newop,'f');
2458 Perl_gen_constant_list(pTHX_ register OP *o)
2462 const I32 oldtmps_floor = PL_tmps_floor;
2465 if (PL_parser && PL_parser->error_count)
2466 return o; /* Don't attempt to run with errors */
2468 PL_op = curop = LINKLIST(o);
2474 assert (!(curop->op_flags & OPf_SPECIAL));
2475 assert(curop->op_type == OP_RANGE);
2477 PL_tmps_floor = oldtmps_floor;
2479 o->op_type = OP_RV2AV;
2480 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2481 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2482 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2483 o->op_opt = 0; /* needs to be revisited in peep() */
2484 curop = ((UNOP*)o)->op_first;
2485 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2487 op_getmad(curop,o,'O');
2496 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2499 if (!o || o->op_type != OP_LIST)
2500 o = newLISTOP(OP_LIST, 0, o, NULL);
2502 o->op_flags &= ~OPf_WANT;
2504 if (!(PL_opargs[type] & OA_MARK))
2505 op_null(cLISTOPo->op_first);
2507 o->op_type = (OPCODE)type;
2508 o->op_ppaddr = PL_ppaddr[type];
2509 o->op_flags |= flags;
2511 o = CHECKOP(type, o);
2512 if (o->op_type != (unsigned)type)
2515 return fold_constants(o);
2518 /* List constructors */
2521 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2529 if (first->op_type != (unsigned)type
2530 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2532 return newLISTOP(type, 0, first, last);
2535 if (first->op_flags & OPf_KIDS)
2536 ((LISTOP*)first)->op_last->op_sibling = last;
2538 first->op_flags |= OPf_KIDS;
2539 ((LISTOP*)first)->op_first = last;
2541 ((LISTOP*)first)->op_last = last;
2546 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2554 if (first->op_type != (unsigned)type)
2555 return prepend_elem(type, (OP*)first, (OP*)last);
2557 if (last->op_type != (unsigned)type)
2558 return append_elem(type, (OP*)first, (OP*)last);
2560 first->op_last->op_sibling = last->op_first;
2561 first->op_last = last->op_last;
2562 first->op_flags |= (last->op_flags & OPf_KIDS);
2565 if (last->op_first && first->op_madprop) {
2566 MADPROP *mp = last->op_first->op_madprop;
2568 while (mp->mad_next)
2570 mp->mad_next = first->op_madprop;
2573 last->op_first->op_madprop = first->op_madprop;
2576 first->op_madprop = last->op_madprop;
2577 last->op_madprop = 0;
2580 S_op_destroy(aTHX_ (OP*)last);
2586 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2594 if (last->op_type == (unsigned)type) {
2595 if (type == OP_LIST) { /* already a PUSHMARK there */
2596 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2597 ((LISTOP*)last)->op_first->op_sibling = first;
2598 if (!(first->op_flags & OPf_PARENS))
2599 last->op_flags &= ~OPf_PARENS;
2602 if (!(last->op_flags & OPf_KIDS)) {
2603 ((LISTOP*)last)->op_last = first;
2604 last->op_flags |= OPf_KIDS;
2606 first->op_sibling = ((LISTOP*)last)->op_first;
2607 ((LISTOP*)last)->op_first = first;
2609 last->op_flags |= OPf_KIDS;
2613 return newLISTOP(type, 0, first, last);
2621 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2624 Newxz(tk, 1, TOKEN);
2625 tk->tk_type = (OPCODE)optype;
2626 tk->tk_type = 12345;
2628 tk->tk_mad = madprop;
2633 Perl_token_free(pTHX_ TOKEN* tk)
2635 if (tk->tk_type != 12345)
2637 mad_free(tk->tk_mad);
2642 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2646 if (tk->tk_type != 12345) {
2647 Perl_warner(aTHX_ packWARN(WARN_MISC),
2648 "Invalid TOKEN object ignored");
2655 /* faked up qw list? */
2657 tm->mad_type == MAD_SV &&
2658 SvPVX((SV*)tm->mad_val)[0] == 'q')
2665 /* pretend constant fold didn't happen? */
2666 if (mp->mad_key == 'f' &&
2667 (o->op_type == OP_CONST ||
2668 o->op_type == OP_GV) )
2670 token_getmad(tk,(OP*)mp->mad_val,slot);
2684 if (mp->mad_key == 'X')
2685 mp->mad_key = slot; /* just change the first one */
2695 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2704 /* pretend constant fold didn't happen? */
2705 if (mp->mad_key == 'f' &&
2706 (o->op_type == OP_CONST ||
2707 o->op_type == OP_GV) )
2709 op_getmad(from,(OP*)mp->mad_val,slot);
2716 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2719 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2725 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2734 /* pretend constant fold didn't happen? */
2735 if (mp->mad_key == 'f' &&
2736 (o->op_type == OP_CONST ||
2737 o->op_type == OP_GV) )
2739 op_getmad(from,(OP*)mp->mad_val,slot);
2746 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2749 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2753 PerlIO_printf(PerlIO_stderr(),
2754 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2760 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2778 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2782 addmad(tm, &(o->op_madprop), slot);
2786 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2807 Perl_newMADsv(pTHX_ char key, SV* sv)
2809 return newMADPROP(key, MAD_SV, sv, 0);
2813 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2816 Newxz(mp, 1, MADPROP);
2819 mp->mad_vlen = vlen;
2820 mp->mad_type = type;
2822 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2827 Perl_mad_free(pTHX_ MADPROP* mp)
2829 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2833 mad_free(mp->mad_next);
2834 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2835 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2836 switch (mp->mad_type) {
2840 Safefree((char*)mp->mad_val);
2843 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2844 op_free((OP*)mp->mad_val);
2847 sv_free((SV*)mp->mad_val);
2850 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2859 Perl_newNULLLIST(pTHX)
2861 return newOP(OP_STUB, 0);
2865 Perl_force_list(pTHX_ OP *o)
2867 if (!o || o->op_type != OP_LIST)
2868 o = newLISTOP(OP_LIST, 0, o, NULL);
2874 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2879 NewOp(1101, listop, 1, LISTOP);
2881 listop->op_type = (OPCODE)type;
2882 listop->op_ppaddr = PL_ppaddr[type];
2885 listop->op_flags = (U8)flags;
2889 else if (!first && last)
2892 first->op_sibling = last;
2893 listop->op_first = first;
2894 listop->op_last = last;
2895 if (type == OP_LIST) {
2896 OP* const pushop = newOP(OP_PUSHMARK, 0);
2897 pushop->op_sibling = first;
2898 listop->op_first = pushop;
2899 listop->op_flags |= OPf_KIDS;
2901 listop->op_last = pushop;
2904 return CHECKOP(type, listop);
2908 Perl_newOP(pTHX_ I32 type, I32 flags)
2912 NewOp(1101, o, 1, OP);
2913 o->op_type = (OPCODE)type;
2914 o->op_ppaddr = PL_ppaddr[type];
2915 o->op_flags = (U8)flags;
2917 o->op_latefreed = 0;
2921 o->op_private = (U8)(0 | (flags >> 8));
2922 if (PL_opargs[type] & OA_RETSCALAR)
2924 if (PL_opargs[type] & OA_TARGET)
2925 o->op_targ = pad_alloc(type, SVs_PADTMP);
2926 return CHECKOP(type, o);
2930 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2936 first = newOP(OP_STUB, 0);
2937 if (PL_opargs[type] & OA_MARK)
2938 first = force_list(first);
2940 NewOp(1101, unop, 1, UNOP);
2941 unop->op_type = (OPCODE)type;
2942 unop->op_ppaddr = PL_ppaddr[type];
2943 unop->op_first = first;
2944 unop->op_flags = (U8)(flags | OPf_KIDS);
2945 unop->op_private = (U8)(1 | (flags >> 8));
2946 unop = (UNOP*) CHECKOP(type, unop);
2950 return fold_constants((OP *) unop);
2954 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2958 NewOp(1101, binop, 1, BINOP);
2961 first = newOP(OP_NULL, 0);
2963 binop->op_type = (OPCODE)type;
2964 binop->op_ppaddr = PL_ppaddr[type];
2965 binop->op_first = first;
2966 binop->op_flags = (U8)(flags | OPf_KIDS);
2969 binop->op_private = (U8)(1 | (flags >> 8));
2972 binop->op_private = (U8)(2 | (flags >> 8));
2973 first->op_sibling = last;
2976 binop = (BINOP*)CHECKOP(type, binop);
2977 if (binop->op_next || binop->op_type != (OPCODE)type)
2980 binop->op_last = binop->op_first->op_sibling;
2982 return fold_constants((OP *)binop);
2985 static int uvcompare(const void *a, const void *b)
2986 __attribute__nonnull__(1)
2987 __attribute__nonnull__(2)
2988 __attribute__pure__;
2989 static int uvcompare(const void *a, const void *b)
2991 if (*((const UV *)a) < (*(const UV *)b))
2993 if (*((const UV *)a) > (*(const UV *)b))
2995 if (*((const UV *)a+1) < (*(const UV *)b+1))
2997 if (*((const UV *)a+1) > (*(const UV *)b+1))
3003 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3006 SV * const tstr = ((SVOP*)expr)->op_sv;
3009 (repl->op_type == OP_NULL)
3010 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3012 ((SVOP*)repl)->op_sv;
3015 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3016 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3020 register short *tbl;
3022 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3023 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3024 I32 del = o->op_private & OPpTRANS_DELETE;
3026 PL_hints |= HINT_BLOCK_SCOPE;
3029 o->op_private |= OPpTRANS_FROM_UTF;
3032 o->op_private |= OPpTRANS_TO_UTF;
3034 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3035 SV* const listsv = newSVpvs("# comment\n");
3037 const U8* tend = t + tlen;
3038 const U8* rend = r + rlen;
3052 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3053 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3056 const U32 flags = UTF8_ALLOW_DEFAULT;
3060 t = tsave = bytes_to_utf8(t, &len);
3063 if (!to_utf && rlen) {
3065 r = rsave = bytes_to_utf8(r, &len);
3069 /* There are several snags with this code on EBCDIC:
3070 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3071 2. scan_const() in toke.c has encoded chars in native encoding which makes
3072 ranges at least in EBCDIC 0..255 range the bottom odd.
3076 U8 tmpbuf[UTF8_MAXBYTES+1];
3079 Newx(cp, 2*tlen, UV);
3081 transv = newSVpvs("");
3083 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3085 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3087 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3091 cp[2*i+1] = cp[2*i];
3095 qsort(cp, i, 2*sizeof(UV), uvcompare);
3096 for (j = 0; j < i; j++) {
3098 diff = val - nextmin;
3100 t = uvuni_to_utf8(tmpbuf,nextmin);
3101 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3103 U8 range_mark = UTF_TO_NATIVE(0xff);
3104 t = uvuni_to_utf8(tmpbuf, val - 1);
3105 sv_catpvn(transv, (char *)&range_mark, 1);
3106 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3113 t = uvuni_to_utf8(tmpbuf,nextmin);
3114 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3116 U8 range_mark = UTF_TO_NATIVE(0xff);
3117 sv_catpvn(transv, (char *)&range_mark, 1);
3119 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3120 UNICODE_ALLOW_SUPER);
3121 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3122 t = (const U8*)SvPVX_const(transv);
3123 tlen = SvCUR(transv);
3127 else if (!rlen && !del) {
3128 r = t; rlen = tlen; rend = tend;
3131 if ((!rlen && !del) || t == r ||
3132 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3134 o->op_private |= OPpTRANS_IDENTICAL;
3138 while (t < tend || tfirst <= tlast) {
3139 /* see if we need more "t" chars */
3140 if (tfirst > tlast) {
3141 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3143 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3145 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3152 /* now see if we need more "r" chars */
3153 if (rfirst > rlast) {
3155 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3157 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3159 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3168 rfirst = rlast = 0xffffffff;
3172 /* now see which range will peter our first, if either. */
3173 tdiff = tlast - tfirst;
3174 rdiff = rlast - rfirst;
3181 if (rfirst == 0xffffffff) {
3182 diff = tdiff; /* oops, pretend rdiff is infinite */
3184 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3185 (long)tfirst, (long)tlast);
3187 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3191 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3192 (long)tfirst, (long)(tfirst + diff),
3195 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3196 (long)tfirst, (long)rfirst);
3198 if (rfirst + diff > max)
3199 max = rfirst + diff;
3201 grows = (tfirst < rfirst &&
3202 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3214 else if (max > 0xff)
3219 PerlMemShared_free(cPVOPo->op_pv);
3220 cPVOPo->op_pv = NULL;
3222 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3224 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3225 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3226 PAD_SETSV(cPADOPo->op_padix, swash);
3229 cSVOPo->op_sv = swash;
3231 SvREFCNT_dec(listsv);
3232 SvREFCNT_dec(transv);
3234 if (!del && havefinal && rlen)
3235 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3236 newSVuv((UV)final), 0);
3239 o->op_private |= OPpTRANS_GROWS;
3245 op_getmad(expr,o,'e');
3246 op_getmad(repl,o,'r');
3254 tbl = (short*)cPVOPo->op_pv;
3256 Zero(tbl, 256, short);
3257 for (i = 0; i < (I32)tlen; i++)
3259 for (i = 0, j = 0; i < 256; i++) {
3261 if (j >= (I32)rlen) {
3270 if (i < 128 && r[j] >= 128)
3280 o->op_private |= OPpTRANS_IDENTICAL;
3282 else if (j >= (I32)rlen)
3287 PerlMemShared_realloc(tbl,
3288 (0x101+rlen-j) * sizeof(short));
3289 cPVOPo->op_pv = (char*)tbl;
3291 tbl[0x100] = (short)(rlen - j);
3292 for (i=0; i < (I32)rlen - j; i++)
3293 tbl[0x101+i] = r[j+i];
3297 if (!rlen && !del) {
3300 o->op_private |= OPpTRANS_IDENTICAL;
3302 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3303 o->op_private |= OPpTRANS_IDENTICAL;
3305 for (i = 0; i < 256; i++)
3307 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3308 if (j >= (I32)rlen) {
3310 if (tbl[t[i]] == -1)
3316 if (tbl[t[i]] == -1) {
3317 if (t[i] < 128 && r[j] >= 128)
3324 o->op_private |= OPpTRANS_GROWS;
3326 op_getmad(expr,o,'e');
3327 op_getmad(repl,o,'r');
3337 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3342 NewOp(1101, pmop, 1, PMOP);
3343 pmop->op_type = (OPCODE)type;
3344 pmop->op_ppaddr = PL_ppaddr[type];
3345 pmop->op_flags = (U8)flags;
3346 pmop->op_private = (U8)(0 | (flags >> 8));
3348 if (PL_hints & HINT_RE_TAINT)
3349 pmop->op_pmflags |= PMf_RETAINT;
3350 if (PL_hints & HINT_LOCALE)
3351 pmop->op_pmflags |= PMf_LOCALE;
3355 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3356 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3357 pmop->op_pmoffset = SvIV(repointer);
3358 SvREPADTMP_off(repointer);
3359 sv_setiv(repointer,0);
3361 SV * const repointer = newSViv(0);
3362 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3363 pmop->op_pmoffset = av_len(PL_regex_padav);
3364 PL_regex_pad = AvARRAY(PL_regex_padav);
3368 return CHECKOP(type, pmop);
3371 /* Given some sort of match op o, and an expression expr containing a
3372 * pattern, either compile expr into a regex and attach it to o (if it's
3373 * constant), or convert expr into a runtime regcomp op sequence (if it's
3376 * isreg indicates that the pattern is part of a regex construct, eg
3377 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3378 * split "pattern", which aren't. In the former case, expr will be a list
3379 * if the pattern contains more than one term (eg /a$b/) or if it contains
3380 * a replacement, ie s/// or tr///.
3384 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3389 I32 repl_has_vars = 0;
3393 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3394 /* last element in list is the replacement; pop it */
3396 repl = cLISTOPx(expr)->op_last;
3397 kid = cLISTOPx(expr)->op_first;
3398 while (kid->op_sibling != repl)
3399 kid = kid->op_sibling;
3400 kid->op_sibling = NULL;
3401 cLISTOPx(expr)->op_last = kid;
3404 if (isreg && expr->op_type == OP_LIST &&
3405 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3407 /* convert single element list to element */
3408 OP* const oe = expr;
3409 expr = cLISTOPx(oe)->op_first->op_sibling;
3410 cLISTOPx(oe)->op_first->op_sibling = NULL;
3411 cLISTOPx(oe)->op_last = NULL;
3415 if (o->op_type == OP_TRANS) {
3416 return pmtrans(o, expr, repl);
3419 reglist = isreg && expr->op_type == OP_LIST;
3423 PL_hints |= HINT_BLOCK_SCOPE;
3426 if (expr->op_type == OP_CONST) {
3427 SV * const pat = ((SVOP*)expr)->op_sv;
3428 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3430 if (o->op_flags & OPf_SPECIAL)
3431 pm_flags |= RXf_SPLIT;
3434 pm_flags |= RXf_UTF8;
3436 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3439 op_getmad(expr,(OP*)pm,'e');
3445 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3446 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3448 : OP_REGCMAYBE),0,expr);
3450 NewOp(1101, rcop, 1, LOGOP);
3451 rcop->op_type = OP_REGCOMP;
3452 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3453 rcop->op_first = scalar(expr);
3454 rcop->op_flags |= OPf_KIDS
3455 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3456 | (reglist ? OPf_STACKED : 0);
3457 rcop->op_private = 1;
3460 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3462 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3465 /* establish postfix order */
3466 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3468 rcop->op_next = expr;
3469 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3472 rcop->op_next = LINKLIST(expr);
3473 expr->op_next = (OP*)rcop;
3476 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3481 if (pm->op_pmflags & PMf_EVAL) {
3483 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3484 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3486 else if (repl->op_type == OP_CONST)
3490 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3491 if (curop->op_type == OP_SCOPE
3492 || curop->op_type == OP_LEAVE
3493 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3494 if (curop->op_type == OP_GV) {
3495 GV * const gv = cGVOPx_gv(curop);
3497 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3500 else if (curop->op_type == OP_RV2CV)
3502 else if (curop->op_type == OP_RV2SV ||
3503 curop->op_type == OP_RV2AV ||
3504 curop->op_type == OP_RV2HV ||
3505 curop->op_type == OP_RV2GV) {
3506 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3509 else if (curop->op_type == OP_PADSV ||
3510 curop->op_type == OP_PADAV ||
3511 curop->op_type == OP_PADHV ||
3512 curop->op_type == OP_PADANY)
3516 else if (curop->op_type == OP_PUSHRE)
3517 NOOP; /* Okay here, dangerous in newASSIGNOP */
3527 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3529 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3530 prepend_elem(o->op_type, scalar(repl), o);
3533 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3534 pm->op_pmflags |= PMf_MAYBE_CONST;
3536 NewOp(1101, rcop, 1, LOGOP);
3537 rcop->op_type = OP_SUBSTCONT;
3538 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3539 rcop->op_first = scalar(repl);
3540 rcop->op_flags |= OPf_KIDS;
3541 rcop->op_private = 1;
3544 /* establish postfix order */
3545 rcop->op_next = LINKLIST(repl);
3546 repl->op_next = (OP*)rcop;
3548 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3549 assert(!(pm->op_pmflags & PMf_ONCE));
3550 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3559 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3563 NewOp(1101, svop, 1, SVOP);
3564 svop->op_type = (OPCODE)type;
3565 svop->op_ppaddr = PL_ppaddr[type];
3567 svop->op_next = (OP*)svop;
3568 svop->op_flags = (U8)flags;
3569 if (PL_opargs[type] & OA_RETSCALAR)
3571 if (PL_opargs[type] & OA_TARGET)
3572 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3573 return CHECKOP(type, svop);
3578 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3582 NewOp(1101, padop, 1, PADOP);
3583 padop->op_type = (OPCODE)type;
3584 padop->op_ppaddr = PL_ppaddr[type];
3585 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3586 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3587 PAD_SETSV(padop->op_padix, sv);
3590 padop->op_next = (OP*)padop;
3591 padop->op_flags = (U8)flags;
3592 if (PL_opargs[type] & OA_RETSCALAR)
3594 if (PL_opargs[type] & OA_TARGET)
3595 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3596 return CHECKOP(type, padop);
3601 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3607 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3609 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3614 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3618 NewOp(1101, pvop, 1, PVOP);
3619 pvop->op_type = (OPCODE)type;
3620 pvop->op_ppaddr = PL_ppaddr[type];
3622 pvop->op_next = (OP*)pvop;
3623 pvop->op_flags = (U8)flags;
3624 if (PL_opargs[type] & OA_RETSCALAR)
3626 if (PL_opargs[type] & OA_TARGET)
3627 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3628 return CHECKOP(type, pvop);
3636 Perl_package(pTHX_ OP *o)
3639 SV *const sv = cSVOPo->op_sv;
3644 save_hptr(&PL_curstash);
3645 save_item(PL_curstname);
3647 PL_curstash = gv_stashsv(sv, GV_ADD);
3649 sv_setsv(PL_curstname, sv);
3651 PL_hints |= HINT_BLOCK_SCOPE;
3652 PL_parser->copline = NOLINE;
3653 PL_parser->expect = XSTATE;
3658 if (!PL_madskills) {
3663 pegop = newOP(OP_NULL,0);
3664 op_getmad(o,pegop,'P');
3674 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3681 OP *pegop = newOP(OP_NULL,0);
3684 if (idop->op_type != OP_CONST)
3685 Perl_croak(aTHX_ "Module name must be constant");
3688 op_getmad(idop,pegop,'U');
3693 SV * const vesv = ((SVOP*)version)->op_sv;
3696 op_getmad(version,pegop,'V');
3697 if (!arg && !SvNIOKp(vesv)) {
3704 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3705 Perl_croak(aTHX_ "Version number must be constant number");
3707 /* Make copy of idop so we don't free it twice */
3708 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3710 /* Fake up a method call to VERSION */
3711 meth = newSVpvs_share("VERSION");
3712 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3713 append_elem(OP_LIST,
3714 prepend_elem(OP_LIST, pack, list(version)),
3715 newSVOP(OP_METHOD_NAMED, 0, meth)));
3719 /* Fake up an import/unimport */
3720 if (arg && arg->op_type == OP_STUB) {
3722 op_getmad(arg,pegop,'S');
3723 imop = arg; /* no import on explicit () */
3725 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3726 imop = NULL; /* use 5.0; */
3728 idop->op_private |= OPpCONST_NOVER;
3734 op_getmad(arg,pegop,'A');
3736 /* Make copy of idop so we don't free it twice */
3737 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3739 /* Fake up a method call to import/unimport */
3741 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3742 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3743 append_elem(OP_LIST,
3744 prepend_elem(OP_LIST, pack, list(arg)),
3745 newSVOP(OP_METHOD_NAMED, 0, meth)));
3748 /* Fake up the BEGIN {}, which does its thing immediately. */
3750 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3753 append_elem(OP_LINESEQ,
3754 append_elem(OP_LINESEQ,
3755 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3756 newSTATEOP(0, NULL, veop)),
3757 newSTATEOP(0, NULL, imop) ));
3759 /* The "did you use incorrect case?" warning used to be here.
3760 * The problem is that on case-insensitive filesystems one
3761 * might get false positives for "use" (and "require"):
3762 * "use Strict" or "require CARP" will work. This causes
3763 * portability problems for the script: in case-strict
3764 * filesystems the script will stop working.
3766 * The "incorrect case" warning checked whether "use Foo"
3767 * imported "Foo" to your namespace, but that is wrong, too:
3768 * there is no requirement nor promise in the language that
3769 * a Foo.pm should or would contain anything in package "Foo".
3771 * There is very little Configure-wise that can be done, either:
3772 * the case-sensitivity of the build filesystem of Perl does not
3773 * help in guessing the case-sensitivity of the runtime environment.
3776 PL_hints |= HINT_BLOCK_SCOPE;
3777 PL_parser->copline = NOLINE;
3778 PL_parser->expect = XSTATE;
3779 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3782 if (!PL_madskills) {
3783 /* FIXME - don't allocate pegop if !PL_madskills */
3792 =head1 Embedding Functions
3794 =for apidoc load_module
3796 Loads the module whose name is pointed to by the string part of name.
3797 Note that the actual module name, not its filename, should be given.
3798 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3799 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3800 (or 0 for no flags). ver, if specified, provides version semantics
3801 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3802 arguments can be used to specify arguments to the module's import()
3803 method, similar to C<use Foo::Bar VERSION LIST>.
3808 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3811 va_start(args, ver);
3812 vload_module(flags, name, ver, &args);
3816 #ifdef PERL_IMPLICIT_CONTEXT
3818 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3822 va_start(args, ver);
3823 vload_module(flags, name, ver, &args);
3829 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3834 OP * const modname = newSVOP(OP_CONST, 0, name);
3835 modname->op_private |= OPpCONST_BARE;
3837 veop = newSVOP(OP_CONST, 0, ver);
3841 if (flags & PERL_LOADMOD_NOIMPORT) {
3842 imop = sawparens(newNULLLIST());
3844 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3845 imop = va_arg(*args, OP*);
3850 sv = va_arg(*args, SV*);
3852 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3853 sv = va_arg(*args, SV*);
3857 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3858 * that it has a PL_parser to play with while doing that, and also
3859 * that it doesn't mess with any existing parser, by creating a tmp
3860 * new parser with lex_start(). This won't actually be used for much,
3861 * since pp_require() will create another parser for the real work. */
3864 SAVEVPTR(PL_curcop);
3865 lex_start(NULL, NULL, FALSE);
3866 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3867 veop, modname, imop);
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 (right && right->op_type == OP_SPLIT && !PL_madskills) {
4063 OP* tmpop = ((LISTOP*)right)->op_first;
4064 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4065 PMOP * const pm = (PMOP*)tmpop;
4066 if (left->op_type == OP_RV2AV &&
4067 !(left->op_private & OPpLVAL_INTRO) &&
4068 !(o->op_private & OPpASSIGN_COMMON) )
4070 tmpop = ((UNOP*)left)->op_first;
4071 if (tmpop->op_type == OP_GV
4073 && !pm->op_pmreplrootu.op_pmtargetoff
4075 && !pm->op_pmreplrootu.op_pmtargetgv
4079 pm->op_pmreplrootu.op_pmtargetoff
4080 = cPADOPx(tmpop)->op_padix;
4081 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4083 pm->op_pmreplrootu.op_pmtargetgv
4084 = (GV*)cSVOPx(tmpop)->op_sv;
4085 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4087 pm->op_pmflags |= PMf_ONCE;
4088 tmpop = cUNOPo->op_first; /* to list (nulled) */
4089 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4090 tmpop->op_sibling = NULL; /* don't free split */
4091 right->op_next = tmpop->op_next; /* fix starting loc */
4092 op_free(o); /* blow off assign */
4093 right->op_flags &= ~OPf_WANT;
4094 /* "I don't know and I don't care." */
4099 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4100 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4102 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4104 sv_setiv(sv, PL_modcount+1);
4112 right = newOP(OP_UNDEF, 0);
4113 if (right->op_type == OP_READLINE) {
4114 right->op_flags |= OPf_STACKED;
4115 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4118 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4119 o = newBINOP(OP_SASSIGN, flags,
4120 scalar(right), mod(scalar(left), OP_SASSIGN) );
4126 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4127 o->op_private |= OPpCONST_ARYBASE;
4134 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4137 const U32 seq = intro_my();
4140 NewOp(1101, cop, 1, COP);
4141 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4142 cop->op_type = OP_DBSTATE;
4143 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4146 cop->op_type = OP_NEXTSTATE;
4147 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4149 cop->op_flags = (U8)flags;
4150 CopHINTS_set(cop, PL_hints);
4152 cop->op_private |= NATIVE_HINTS;
4154 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4155 cop->op_next = (OP*)cop;
4158 CopLABEL_set(cop, label);
4159 PL_hints |= HINT_BLOCK_SCOPE;
4162 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4163 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4165 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4166 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4167 if (cop->cop_hints_hash) {
4169 cop->cop_hints_hash->refcounted_he_refcnt++;
4170 HINTS_REFCNT_UNLOCK;
4173 if (PL_parser && PL_parser->copline == NOLINE)
4174 CopLINE_set(cop, CopLINE(PL_curcop));
4176 CopLINE_set(cop, PL_parser->copline);
4178 PL_parser->copline = NOLINE;
4181 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4183 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4185 CopSTASH_set(cop, PL_curstash);
4187 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4188 AV *av = CopFILEAVx(PL_curcop);
4190 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4191 if (svp && *svp != &PL_sv_undef ) {
4192 (void)SvIOK_on(*svp);
4193 SvIV_set(*svp, PTR2IV(cop));
4198 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4203 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4206 return new_logop(type, flags, &first, &other);
4210 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4215 OP *first = *firstp;
4216 OP * const other = *otherp;
4218 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4219 return newBINOP(type, flags, scalar(first), scalar(other));
4221 scalarboolean(first);
4222 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4223 if (first->op_type == OP_NOT
4224 && (first->op_flags & OPf_SPECIAL)
4225 && (first->op_flags & OPf_KIDS)
4227 if (type == OP_AND || type == OP_OR) {
4233 first = *firstp = cUNOPo->op_first;
4235 first->op_next = o->op_next;
4236 cUNOPo->op_first = NULL;
4240 if (first->op_type == OP_CONST) {
4241 if (first->op_private & OPpCONST_STRICT)
4242 no_bareword_allowed(first);
4243 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4244 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4245 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4246 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4247 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4249 if (other->op_type == OP_CONST)
4250 other->op_private |= OPpCONST_SHORTCIRCUIT;
4252 OP *newop = newUNOP(OP_NULL, 0, other);
4253 op_getmad(first, newop, '1');
4254 newop->op_targ = type; /* set "was" field */
4261 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4262 const OP *o2 = other;
4263 if ( ! (o2->op_type == OP_LIST
4264 && (( o2 = cUNOPx(o2)->op_first))
4265 && o2->op_type == OP_PUSHMARK
4266 && (( o2 = o2->op_sibling)) )
4269 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4270 || o2->op_type == OP_PADHV)
4271 && o2->op_private & OPpLVAL_INTRO
4272 && ckWARN(WARN_DEPRECATED))
4274 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4275 "Deprecated use of my() in false conditional");
4279 if (first->op_type == OP_CONST)
4280 first->op_private |= OPpCONST_SHORTCIRCUIT;
4282 first = newUNOP(OP_NULL, 0, first);
4283 op_getmad(other, first, '2');
4284 first->op_targ = type; /* set "was" field */
4291 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4292 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4294 const OP * const k1 = ((UNOP*)first)->op_first;
4295 const OP * const k2 = k1->op_sibling;
4297 switch (first->op_type)
4300 if (k2 && k2->op_type == OP_READLINE
4301 && (k2->op_flags & OPf_STACKED)
4302 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4304 warnop = k2->op_type;
4309 if (k1->op_type == OP_READDIR
4310 || k1->op_type == OP_GLOB
4311 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4312 || k1->op_type == OP_EACH)
4314 warnop = ((k1->op_type == OP_NULL)
4315 ? (OPCODE)k1->op_targ : k1->op_type);
4320 const line_t oldline = CopLINE(PL_curcop);
4321 CopLINE_set(PL_curcop, PL_parser->copline);
4322 Perl_warner(aTHX_ packWARN(WARN_MISC),
4323 "Value of %s%s can be \"0\"; test with defined()",
4325 ((warnop == OP_READLINE || warnop == OP_GLOB)
4326 ? " construct" : "() operator"));
4327 CopLINE_set(PL_curcop, oldline);
4334 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4335 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4337 NewOp(1101, logop, 1, LOGOP);
4339 logop->op_type = (OPCODE)type;
4340 logop->op_ppaddr = PL_ppaddr[type];
4341 logop->op_first = first;
4342 logop->op_flags = (U8)(flags | OPf_KIDS);
4343 logop->op_other = LINKLIST(other);
4344 logop->op_private = (U8)(1 | (flags >> 8));
4346 /* establish postfix order */
4347 logop->op_next = LINKLIST(first);
4348 first->op_next = (OP*)logop;
4349 first->op_sibling = other;
4351 CHECKOP(type,logop);
4353 o = newUNOP(OP_NULL, 0, (OP*)logop);
4360 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4368 return newLOGOP(OP_AND, 0, first, trueop);
4370 return newLOGOP(OP_OR, 0, first, falseop);
4372 scalarboolean(first);
4373 if (first->op_type == OP_CONST) {
4374 /* Left or right arm of the conditional? */
4375 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4376 OP *live = left ? trueop : falseop;
4377 OP *const dead = left ? falseop : trueop;
4378 if (first->op_private & OPpCONST_BARE &&
4379 first->op_private & OPpCONST_STRICT) {
4380 no_bareword_allowed(first);
4383 /* This is all dead code when PERL_MAD is not defined. */
4384 live = newUNOP(OP_NULL, 0, live);
4385 op_getmad(first, live, 'C');
4386 op_getmad(dead, live, left ? 'e' : 't');
4393 NewOp(1101, logop, 1, LOGOP);
4394 logop->op_type = OP_COND_EXPR;
4395 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4396 logop->op_first = first;
4397 logop->op_flags = (U8)(flags | OPf_KIDS);
4398 logop->op_private = (U8)(1 | (flags >> 8));
4399 logop->op_other = LINKLIST(trueop);
4400 logop->op_next = LINKLIST(falseop);
4402 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4405 /* establish postfix order */
4406 start = LINKLIST(first);
4407 first->op_next = (OP*)logop;
4409 first->op_sibling = trueop;
4410 trueop->op_sibling = falseop;
4411 o = newUNOP(OP_NULL, 0, (OP*)logop);
4413 trueop->op_next = falseop->op_next = o;
4420 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4429 NewOp(1101, range, 1, LOGOP);
4431 range->op_type = OP_RANGE;
4432 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4433 range->op_first = left;
4434 range->op_flags = OPf_KIDS;
4435 leftstart = LINKLIST(left);
4436 range->op_other = LINKLIST(right);
4437 range->op_private = (U8)(1 | (flags >> 8));
4439 left->op_sibling = right;
4441 range->op_next = (OP*)range;
4442 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4443 flop = newUNOP(OP_FLOP, 0, flip);
4444 o = newUNOP(OP_NULL, 0, flop);
4446 range->op_next = leftstart;
4448 left->op_next = flip;
4449 right->op_next = flop;
4451 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4452 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4453 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4454 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4456 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4457 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4460 if (!flip->op_private || !flop->op_private)
4461 linklist(o); /* blow off optimizer unless constant */
4467 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4472 const bool once = block && block->op_flags & OPf_SPECIAL &&
4473 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4475 PERL_UNUSED_ARG(debuggable);
4478 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4479 return block; /* do {} while 0 does once */
4480 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4481 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4482 expr = newUNOP(OP_DEFINED, 0,
4483 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4484 } else if (expr->op_flags & OPf_KIDS) {
4485 const OP * const k1 = ((UNOP*)expr)->op_first;
4486 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4487 switch (expr->op_type) {
4489 if (k2 && k2->op_type == OP_READLINE
4490 && (k2->op_flags & OPf_STACKED)
4491 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4492 expr = newUNOP(OP_DEFINED, 0, expr);
4496 if (k1 && (k1->op_type == OP_READDIR
4497 || k1->op_type == OP_GLOB
4498 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4499 || k1->op_type == OP_EACH))
4500 expr = newUNOP(OP_DEFINED, 0, expr);
4506 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4507 * op, in listop. This is wrong. [perl #27024] */
4509 block = newOP(OP_NULL, 0);
4510 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4511 o = new_logop(OP_AND, 0, &expr, &listop);
4514 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4516 if (once && o != listop)
4517 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4520 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4522 o->op_flags |= flags;
4524 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4529 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4530 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4539 PERL_UNUSED_ARG(debuggable);
4542 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4543 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4544 expr = newUNOP(OP_DEFINED, 0,
4545 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4546 } else if (expr->op_flags & OPf_KIDS) {
4547 const OP * const k1 = ((UNOP*)expr)->op_first;
4548 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4549 switch (expr->op_type) {
4551 if (k2 && k2->op_type == OP_READLINE
4552 && (k2->op_flags & OPf_STACKED)
4553 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4554 expr = newUNOP(OP_DEFINED, 0, expr);
4558 if (k1 && (k1->op_type == OP_READDIR
4559 || k1->op_type == OP_GLOB
4560 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4561 || k1->op_type == OP_EACH))
4562 expr = newUNOP(OP_DEFINED, 0, expr);
4569 block = newOP(OP_NULL, 0);
4570 else if (cont || has_my) {
4571 block = scope(block);
4575 next = LINKLIST(cont);
4578 OP * const unstack = newOP(OP_UNSTACK, 0);
4581 cont = append_elem(OP_LINESEQ, cont, unstack);
4585 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4587 redo = LINKLIST(listop);
4590 PL_parser->copline = (line_t)whileline;
4592 o = new_logop(OP_AND, 0, &expr, &listop);
4593 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4594 op_free(expr); /* oops, it's a while (0) */
4596 return NULL; /* listop already freed by new_logop */
4599 ((LISTOP*)listop)->op_last->op_next =
4600 (o == listop ? redo : LINKLIST(o));
4606 NewOp(1101,loop,1,LOOP);
4607 loop->op_type = OP_ENTERLOOP;
4608 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4609 loop->op_private = 0;
4610 loop->op_next = (OP*)loop;
4613 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4615 loop->op_redoop = redo;
4616 loop->op_lastop = o;
4617 o->op_private |= loopflags;
4620 loop->op_nextop = next;
4622 loop->op_nextop = o;
4624 o->op_flags |= flags;
4625 o->op_private |= (flags >> 8);
4630 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4635 PADOFFSET padoff = 0;
4641 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4642 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4643 sv->op_type = OP_RV2GV;
4644 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4646 /* The op_type check is needed to prevent a possible segfault
4647 * if the loop variable is undeclared and 'strict vars' is in
4648 * effect. This is illegal but is nonetheless parsed, so we
4649 * may reach this point with an OP_CONST where we're expecting
4652 if (cUNOPx(sv)->op_first->op_type == OP_GV
4653 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4654 iterpflags |= OPpITER_DEF;
4656 else if (sv->op_type == OP_PADSV) { /* private variable */
4657 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4658 padoff = sv->op_targ;
4668 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4670 SV *const namesv = PAD_COMPNAME_SV(padoff);
4672 const char *const name = SvPV_const(namesv, len);
4674 if (len == 2 && name[0] == '$' && name[1] == '_')
4675 iterpflags |= OPpITER_DEF;
4679 const PADOFFSET offset = pad_findmy("$_");
4680 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4681 sv = newGVOP(OP_GV, 0, PL_defgv);
4686 iterpflags |= OPpITER_DEF;
4688 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4689 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4690 iterflags |= OPf_STACKED;
4692 else if (expr->op_type == OP_NULL &&
4693 (expr->op_flags & OPf_KIDS) &&
4694 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4696 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4697 * set the STACKED flag to indicate that these values are to be
4698 * treated as min/max values by 'pp_iterinit'.
4700 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4701 LOGOP* const range = (LOGOP*) flip->op_first;
4702 OP* const left = range->op_first;
4703 OP* const right = left->op_sibling;
4706 range->op_flags &= ~OPf_KIDS;
4707 range->op_first = NULL;
4709 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4710 listop->op_first->op_next = range->op_next;
4711 left->op_next = range->op_other;
4712 right->op_next = (OP*)listop;
4713 listop->op_next = listop->op_first;
4716 op_getmad(expr,(OP*)listop,'O');
4720 expr = (OP*)(listop);
4722 iterflags |= OPf_STACKED;
4725 expr = mod(force_list(expr), OP_GREPSTART);
4728 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4729 append_elem(OP_LIST, expr, scalar(sv))));
4730 assert(!loop->op_next);
4731 /* for my $x () sets OPpLVAL_INTRO;
4732 * for our $x () sets OPpOUR_INTRO */
4733 loop->op_private = (U8)iterpflags;
4734 #ifdef PL_OP_SLAB_ALLOC
4737 NewOp(1234,tmp,1,LOOP);
4738 Copy(loop,tmp,1,LISTOP);
4739 S_op_destroy(aTHX_ (OP*)loop);
4743 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4745 loop->op_targ = padoff;
4746 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4748 op_getmad(madsv, (OP*)loop, 'v');
4749 PL_parser->copline = forline;
4750 return newSTATEOP(0, label, wop);
4754 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4759 if (type != OP_GOTO || label->op_type == OP_CONST) {
4760 /* "last()" means "last" */
4761 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4762 o = newOP(type, OPf_SPECIAL);
4764 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4765 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4769 op_getmad(label,o,'L');
4775 /* Check whether it's going to be a goto &function */
4776 if (label->op_type == OP_ENTERSUB
4777 && !(label->op_flags & OPf_STACKED))
4778 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4779 o = newUNOP(type, OPf_STACKED, label);
4781 PL_hints |= HINT_BLOCK_SCOPE;
4785 /* if the condition is a literal array or hash
4786 (or @{ ... } etc), make a reference to it.
4789 S_ref_array_or_hash(pTHX_ OP *cond)
4792 && (cond->op_type == OP_RV2AV
4793 || cond->op_type == OP_PADAV
4794 || cond->op_type == OP_RV2HV
4795 || cond->op_type == OP_PADHV))
4797 return newUNOP(OP_REFGEN,
4798 0, mod(cond, OP_REFGEN));
4804 /* These construct the optree fragments representing given()
4807 entergiven and enterwhen are LOGOPs; the op_other pointer
4808 points up to the associated leave op. We need this so we
4809 can put it in the context and make break/continue work.
4810 (Also, of course, pp_enterwhen will jump straight to
4811 op_other if the match fails.)
4815 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4816 I32 enter_opcode, I32 leave_opcode,
4817 PADOFFSET entertarg)
4823 NewOp(1101, enterop, 1, LOGOP);
4824 enterop->op_type = enter_opcode;
4825 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4826 enterop->op_flags = (U8) OPf_KIDS;
4827 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4828 enterop->op_private = 0;
4830 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4833 enterop->op_first = scalar(cond);
4834 cond->op_sibling = block;
4836 o->op_next = LINKLIST(cond);
4837 cond->op_next = (OP *) enterop;
4840 /* This is a default {} block */
4841 enterop->op_first = block;
4842 enterop->op_flags |= OPf_SPECIAL;
4844 o->op_next = (OP *) enterop;
4847 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4848 entergiven and enterwhen both
4851 enterop->op_next = LINKLIST(block);
4852 block->op_next = enterop->op_other = o;
4857 /* Does this look like a boolean operation? For these purposes
4858 a boolean operation is:
4859 - a subroutine call [*]
4860 - a logical connective
4861 - a comparison operator
4862 - a filetest operator, with the exception of -s -M -A -C
4863 - defined(), exists() or eof()
4864 - /$re/ or $foo =~ /$re/
4866 [*] possibly surprising
4869 S_looks_like_bool(pTHX_ const OP *o)
4872 switch(o->op_type) {
4874 return looks_like_bool(cLOGOPo->op_first);
4878 looks_like_bool(cLOGOPo->op_first)
4879 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4883 case OP_NOT: case OP_XOR:
4884 /* Note that OP_DOR is not here */
4886 case OP_EQ: case OP_NE: case OP_LT:
4887 case OP_GT: case OP_LE: case OP_GE:
4889 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4890 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4892 case OP_SEQ: case OP_SNE: case OP_SLT:
4893 case OP_SGT: case OP_SLE: case OP_SGE:
4897 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4898 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4899 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4900 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4901 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4902 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4903 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4904 case OP_FTTEXT: case OP_FTBINARY:
4906 case OP_DEFINED: case OP_EXISTS:
4907 case OP_MATCH: case OP_EOF:
4912 /* Detect comparisons that have been optimized away */
4913 if (cSVOPo->op_sv == &PL_sv_yes
4914 || cSVOPo->op_sv == &PL_sv_no)
4925 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4929 return newGIVWHENOP(
4930 ref_array_or_hash(cond),
4932 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4936 /* If cond is null, this is a default {} block */
4938 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4940 const bool cond_llb = (!cond || looks_like_bool(cond));
4946 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4948 scalar(ref_array_or_hash(cond)));
4951 return newGIVWHENOP(
4953 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4954 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4958 =for apidoc cv_undef
4960 Clear out all the active components of a CV. This can happen either
4961 by an explicit C<undef &foo>, or by the reference count going to zero.
4962 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4963 children can still follow the full lexical scope chain.
4969 Perl_cv_undef(pTHX_ CV *cv)
4973 if (CvFILE(cv) && !CvISXSUB(cv)) {
4974 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4975 Safefree(CvFILE(cv));
4980 if (!CvISXSUB(cv) && CvROOT(cv)) {
4981 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4982 Perl_croak(aTHX_ "Can't undef active subroutine");
4985 PAD_SAVE_SETNULLPAD();
4987 op_free(CvROOT(cv));
4992 SvPOK_off((SV*)cv); /* forget prototype */
4997 /* remove CvOUTSIDE unless this is an undef rather than a free */
4998 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4999 if (!CvWEAKOUTSIDE(cv))
5000 SvREFCNT_dec(CvOUTSIDE(cv));
5001 CvOUTSIDE(cv) = NULL;
5004 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5007 if (CvISXSUB(cv) && CvXSUB(cv)) {
5010 /* delete all flags except WEAKOUTSIDE */
5011 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5015 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5018 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5019 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5020 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5021 || (p && (len != SvCUR(cv) /* Not the same length. */
5022 || memNE(p, SvPVX_const(cv), len))))
5023 && ckWARN_d(WARN_PROTOTYPE)) {
5024 SV* const msg = sv_newmortal();
5028 gv_efullname3(name = sv_newmortal(), gv, NULL);
5029 sv_setpvs(msg, "Prototype mismatch:");
5031 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5033 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5035 sv_catpvs(msg, ": none");
5036 sv_catpvs(msg, " vs ");
5038 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5040 sv_catpvs(msg, "none");
5041 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5045 static void const_sv_xsub(pTHX_ CV* cv);
5049 =head1 Optree Manipulation Functions
5051 =for apidoc cv_const_sv
5053 If C<cv> is a constant sub eligible for inlining. returns the constant
5054 value returned by the sub. Otherwise, returns NULL.
5056 Constant subs can be created with C<newCONSTSUB> or as described in
5057 L<perlsub/"Constant Functions">.
5062 Perl_cv_const_sv(pTHX_ CV *cv)
5064 PERL_UNUSED_CONTEXT;
5067 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5069 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5072 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5073 * Can be called in 3 ways:
5076 * look for a single OP_CONST with attached value: return the value
5078 * cv && CvCLONE(cv) && !CvCONST(cv)
5080 * examine the clone prototype, and if contains only a single
5081 * OP_CONST referencing a pad const, or a single PADSV referencing
5082 * an outer lexical, return a non-zero value to indicate the CV is
5083 * a candidate for "constizing" at clone time
5087 * We have just cloned an anon prototype that was marked as a const
5088 * candidiate. Try to grab the current value, and in the case of
5089 * PADSV, ignore it if it has multiple references. Return the value.
5093 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5101 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5102 o = cLISTOPo->op_first->op_sibling;
5104 for (; o; o = o->op_next) {
5105 const OPCODE type = o->op_type;
5107 if (sv && o->op_next == o)
5109 if (o->op_next != o) {
5110 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5112 if (type == OP_DBSTATE)
5115 if (type == OP_LEAVESUB || type == OP_RETURN)
5119 if (type == OP_CONST && cSVOPo->op_sv)
5121 else if (cv && type == OP_CONST) {
5122 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5126 else if (cv && type == OP_PADSV) {
5127 if (CvCONST(cv)) { /* newly cloned anon */
5128 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5129 /* the candidate should have 1 ref from this pad and 1 ref
5130 * from the parent */
5131 if (!sv || SvREFCNT(sv) != 2)
5138 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5139 sv = &PL_sv_undef; /* an arbitrary non-null value */
5154 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5157 /* This would be the return value, but the return cannot be reached. */
5158 OP* pegop = newOP(OP_NULL, 0);
5161 PERL_UNUSED_ARG(floor);
5171 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5173 NORETURN_FUNCTION_END;
5178 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5180 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5184 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5191 register CV *cv = NULL;
5193 /* If the subroutine has no body, no attributes, and no builtin attributes
5194 then it's just a sub declaration, and we may be able to get away with
5195 storing with a placeholder scalar in the symbol table, rather than a
5196 full GV and CV. If anything is present then it will take a full CV to
5198 const I32 gv_fetch_flags
5199 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5201 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5202 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5205 assert(proto->op_type == OP_CONST);
5206 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5211 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5212 SV * const sv = sv_newmortal();
5213 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5214 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5215 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5216 aname = SvPVX_const(sv);
5221 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5222 : gv_fetchpv(aname ? aname
5223 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5224 gv_fetch_flags, SVt_PVCV);
5226 if (!PL_madskills) {
5235 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5236 maximum a prototype before. */
5237 if (SvTYPE(gv) > SVt_NULL) {
5238 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5239 && ckWARN_d(WARN_PROTOTYPE))
5241 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5243 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5246 sv_setpvn((SV*)gv, ps, ps_len);
5248 sv_setiv((SV*)gv, -1);
5250 SvREFCNT_dec(PL_compcv);
5251 cv = PL_compcv = NULL;
5255 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5257 #ifdef GV_UNIQUE_CHECK
5258 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5259 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5263 if (!block || !ps || *ps || attrs
5264 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5266 || block->op_type == OP_NULL
5271 const_sv = op_const_sv(block, NULL);
5274 const bool exists = CvROOT(cv) || CvXSUB(cv);
5276 #ifdef GV_UNIQUE_CHECK
5277 if (exists && GvUNIQUE(gv)) {
5278 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5282 /* if the subroutine doesn't exist and wasn't pre-declared
5283 * with a prototype, assume it will be AUTOLOADed,
5284 * skipping the prototype check
5286 if (exists || SvPOK(cv))
5287 cv_ckproto_len(cv, gv, ps, ps_len);
5288 /* already defined (or promised)? */
5289 if (exists || GvASSUMECV(gv)) {
5292 || block->op_type == OP_NULL
5295 if (CvFLAGS(PL_compcv)) {
5296 /* might have had built-in attrs applied */
5297 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5299 /* just a "sub foo;" when &foo is already defined */
5300 SAVEFREESV(PL_compcv);
5305 && block->op_type != OP_NULL
5308 if (ckWARN(WARN_REDEFINE)
5310 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5312 const line_t oldline = CopLINE(PL_curcop);
5313 if (PL_parser && PL_parser->copline != NOLINE)
5314 CopLINE_set(PL_curcop, PL_parser->copline);
5315 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5316 CvCONST(cv) ? "Constant subroutine %s redefined"
5317 : "Subroutine %s redefined", name);
5318 CopLINE_set(PL_curcop, oldline);
5321 if (!PL_minus_c) /* keep old one around for madskills */
5324 /* (PL_madskills unset in used file.) */
5332 SvREFCNT_inc_simple_void_NN(const_sv);
5334 assert(!CvROOT(cv) && !CvCONST(cv));
5335 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5336 CvXSUBANY(cv).any_ptr = const_sv;
5337 CvXSUB(cv) = const_sv_xsub;
5343 cv = newCONSTSUB(NULL, name, const_sv);
5345 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5346 (CvGV(cv) && GvSTASH(CvGV(cv)))
5355 SvREFCNT_dec(PL_compcv);
5363 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5364 * before we clobber PL_compcv.
5368 || block->op_type == OP_NULL
5372 /* Might have had built-in attributes applied -- propagate them. */
5373 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5374 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5375 stash = GvSTASH(CvGV(cv));
5376 else if (CvSTASH(cv))
5377 stash = CvSTASH(cv);
5379 stash = PL_curstash;
5382 /* possibly about to re-define existing subr -- ignore old cv */
5383 rcv = (SV*)PL_compcv;
5384 if (name && GvSTASH(gv))
5385 stash = GvSTASH(gv);
5387 stash = PL_curstash;
5389 apply_attrs(stash, rcv, attrs, FALSE);
5391 if (cv) { /* must reuse cv if autoloaded */
5398 || block->op_type == OP_NULL) && !PL_madskills
5401 /* got here with just attrs -- work done, so bug out */
5402 SAVEFREESV(PL_compcv);
5405 /* transfer PL_compcv to cv */
5407 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5408 if (!CvWEAKOUTSIDE(cv))
5409 SvREFCNT_dec(CvOUTSIDE(cv));
5410 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5411 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5412 CvOUTSIDE(PL_compcv) = 0;
5413 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5414 CvPADLIST(PL_compcv) = 0;
5415 /* inner references to PL_compcv must be fixed up ... */
5416 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5417 /* ... before we throw it away */
5418 SvREFCNT_dec(PL_compcv);
5420 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5421 ++PL_sub_generation;
5428 if (strEQ(name, "import")) {
5429 PL_formfeed = (SV*)cv;
5430 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5434 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5438 CvFILE_set_from_cop(cv, PL_curcop);
5439 CvSTASH(cv) = PL_curstash;
5442 sv_setpvn((SV*)cv, ps, ps_len);
5444 if (PL_parser && PL_parser->error_count) {
5448 const char *s = strrchr(name, ':');
5450 if (strEQ(s, "BEGIN")) {
5451 const char not_safe[] =
5452 "BEGIN not safe after errors--compilation aborted";
5453 if (PL_in_eval & EVAL_KEEPERR)
5454 Perl_croak(aTHX_ not_safe);
5456 /* force display of errors found but not reported */
5457 sv_catpv(ERRSV, not_safe);
5458 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5468 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5469 mod(scalarseq(block), OP_LEAVESUBLV));
5470 block->op_attached = 1;
5473 /* This makes sub {}; work as expected. */
5474 if (block->op_type == OP_STUB) {
5475 OP* const newblock = newSTATEOP(0, NULL, 0);
5477 op_getmad(block,newblock,'B');
5484 block->op_attached = 1;
5485 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5487 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5488 OpREFCNT_set(CvROOT(cv), 1);
5489 CvSTART(cv) = LINKLIST(CvROOT(cv));
5490 CvROOT(cv)->op_next = 0;
5491 CALL_PEEP(CvSTART(cv));
5493 /* now that optimizer has done its work, adjust pad values */
5495 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5498 assert(!CvCONST(cv));
5499 if (ps && !*ps && op_const_sv(block, cv))
5503 if (name || aname) {
5504 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5505 SV * const sv = newSV(0);
5506 SV * const tmpstr = sv_newmortal();
5507 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5508 GV_ADDMULTI, SVt_PVHV);
5511 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5513 (long)PL_subline, (long)CopLINE(PL_curcop));
5514 gv_efullname3(tmpstr, gv, NULL);
5515 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5516 hv = GvHVn(db_postponed);
5517 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5518 CV * const pcv = GvCV(db_postponed);
5524 call_sv((SV*)pcv, G_DISCARD);
5529 if (name && ! (PL_parser && PL_parser->error_count))
5530 process_special_blocks(name, gv, cv);
5535 PL_parser->copline = NOLINE;
5541 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5544 const char *const colon = strrchr(fullname,':');
5545 const char *const name = colon ? colon + 1 : fullname;
5548 if (strEQ(name, "BEGIN")) {
5549 const I32 oldscope = PL_scopestack_ix;
5551 SAVECOPFILE(&PL_compiling);
5552 SAVECOPLINE(&PL_compiling);
5554 DEBUG_x( dump_sub(gv) );
5555 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5556 GvCV(gv) = 0; /* cv has been hijacked */
5557 call_list(oldscope, PL_beginav);
5559 PL_curcop = &PL_compiling;
5560 CopHINTS_set(&PL_compiling, PL_hints);
5567 if strEQ(name, "END") {
5568 DEBUG_x( dump_sub(gv) );
5569 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5572 } else if (*name == 'U') {
5573 if (strEQ(name, "UNITCHECK")) {
5574 /* It's never too late to run a unitcheck block */
5575 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5579 } else if (*name == 'C') {
5580 if (strEQ(name, "CHECK")) {
5581 if (PL_main_start && ckWARN(WARN_VOID))
5582 Perl_warner(aTHX_ packWARN(WARN_VOID),
5583 "Too late to run CHECK block");
5584 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5588 } else if (*name == 'I') {
5589 if (strEQ(name, "INIT")) {
5590 if (PL_main_start && ckWARN(WARN_VOID))
5591 Perl_warner(aTHX_ packWARN(WARN_VOID),
5592 "Too late to run INIT block");
5593 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5599 DEBUG_x( dump_sub(gv) );
5600 GvCV(gv) = 0; /* cv has been hijacked */
5605 =for apidoc newCONSTSUB
5607 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5608 eligible for inlining at compile-time.
5614 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5619 const char *const temp_p = CopFILE(PL_curcop);
5620 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5622 SV *const temp_sv = CopFILESV(PL_curcop);
5624 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5626 char *const file = savepvn(temp_p, temp_p ? len : 0);
5630 SAVECOPLINE(PL_curcop);
5631 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5634 PL_hints &= ~HINT_BLOCK_SCOPE;
5637 SAVESPTR(PL_curstash);
5638 SAVECOPSTASH(PL_curcop);
5639 PL_curstash = stash;
5640 CopSTASH_set(PL_curcop,stash);
5643 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5644 and so doesn't get free()d. (It's expected to be from the C pre-
5645 processor __FILE__ directive). But we need a dynamically allocated one,
5646 and we need it to get freed. */
5647 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5648 CvXSUBANY(cv).any_ptr = sv;
5654 CopSTASH_free(PL_curcop);
5662 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5663 const char *const filename, const char *const proto,
5666 CV *cv = newXS(name, subaddr, filename);
5668 if (flags & XS_DYNAMIC_FILENAME) {
5669 /* We need to "make arrangements" (ie cheat) to ensure that the
5670 filename lasts as long as the PVCV we just created, but also doesn't
5672 STRLEN filename_len = strlen(filename);
5673 STRLEN proto_and_file_len = filename_len;
5674 char *proto_and_file;
5678 proto_len = strlen(proto);
5679 proto_and_file_len += proto_len;
5681 Newx(proto_and_file, proto_and_file_len + 1, char);
5682 Copy(proto, proto_and_file, proto_len, char);
5683 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5686 proto_and_file = savepvn(filename, filename_len);
5689 /* This gets free()d. :-) */
5690 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5691 SV_HAS_TRAILING_NUL);
5693 /* This gives us the correct prototype, rather than one with the
5694 file name appended. */
5695 SvCUR_set(cv, proto_len);
5699 CvFILE(cv) = proto_and_file + proto_len;
5701 sv_setpv((SV *)cv, proto);
5707 =for apidoc U||newXS
5709 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5710 static storage, as it is used directly as CvFILE(), without a copy being made.
5716 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5719 GV * const gv = gv_fetchpv(name ? name :
5720 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5721 GV_ADDMULTI, SVt_PVCV);
5725 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5727 if ((cv = (name ? GvCV(gv) : NULL))) {
5729 /* just a cached method */
5733 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5734 /* already defined (or promised) */
5735 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5736 if (ckWARN(WARN_REDEFINE)) {
5737 GV * const gvcv = CvGV(cv);
5739 HV * const stash = GvSTASH(gvcv);
5741 const char *redefined_name = HvNAME_get(stash);
5742 if ( strEQ(redefined_name,"autouse") ) {
5743 const line_t oldline = CopLINE(PL_curcop);
5744 if (PL_parser && PL_parser->copline != NOLINE)
5745 CopLINE_set(PL_curcop, PL_parser->copline);
5746 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5747 CvCONST(cv) ? "Constant subroutine %s redefined"
5748 : "Subroutine %s redefined"
5750 CopLINE_set(PL_curcop, oldline);
5760 if (cv) /* must reuse cv if autoloaded */
5763 cv = (CV*)newSV_type(SVt_PVCV);
5767 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5771 (void)gv_fetchfile(filename);
5772 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5773 an external constant string */
5775 CvXSUB(cv) = subaddr;
5778 process_special_blocks(name, gv, cv);
5790 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5795 OP* pegop = newOP(OP_NULL, 0);
5799 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5800 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5802 #ifdef GV_UNIQUE_CHECK
5804 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5808 if ((cv = GvFORM(gv))) {
5809 if (ckWARN(WARN_REDEFINE)) {
5810 const line_t oldline = CopLINE(PL_curcop);
5811 if (PL_parser && PL_parser->copline != NOLINE)
5812 CopLINE_set(PL_curcop, PL_parser->copline);
5813 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5814 o ? "Format %"SVf" redefined"
5815 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5816 CopLINE_set(PL_curcop, oldline);
5823 CvFILE_set_from_cop(cv, PL_curcop);
5826 pad_tidy(padtidy_FORMAT);
5827 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5828 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5829 OpREFCNT_set(CvROOT(cv), 1);
5830 CvSTART(cv) = LINKLIST(CvROOT(cv));
5831 CvROOT(cv)->op_next = 0;
5832 CALL_PEEP(CvSTART(cv));
5834 op_getmad(o,pegop,'n');
5835 op_getmad_weak(block, pegop, 'b');
5840 PL_parser->copline = NOLINE;
5848 Perl_newANONLIST(pTHX_ OP *o)
5850 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5854 Perl_newANONHASH(pTHX_ OP *o)
5856 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5860 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5862 return newANONATTRSUB(floor, proto, NULL, block);
5866 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5868 return newUNOP(OP_REFGEN, 0,
5869 newSVOP(OP_ANONCODE, 0,
5870 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5874 Perl_oopsAV(pTHX_ OP *o)
5877 switch (o->op_type) {
5879 o->op_type = OP_PADAV;
5880 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5881 return ref(o, OP_RV2AV);
5884 o->op_type = OP_RV2AV;
5885 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5890 if (ckWARN_d(WARN_INTERNAL))
5891 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5898 Perl_oopsHV(pTHX_ OP *o)
5901 switch (o->op_type) {
5904 o->op_type = OP_PADHV;
5905 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5906 return ref(o, OP_RV2HV);
5910 o->op_type = OP_RV2HV;
5911 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5916 if (ckWARN_d(WARN_INTERNAL))
5917 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5924 Perl_newAVREF(pTHX_ OP *o)
5927 if (o->op_type == OP_PADANY) {
5928 o->op_type = OP_PADAV;
5929 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5932 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5933 && ckWARN(WARN_DEPRECATED)) {
5934 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5935 "Using an array as a reference is deprecated");
5937 return newUNOP(OP_RV2AV, 0, scalar(o));
5941 Perl_newGVREF(pTHX_ I32 type, OP *o)
5943 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5944 return newUNOP(OP_NULL, 0, o);
5945 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5949 Perl_newHVREF(pTHX_ OP *o)
5952 if (o->op_type == OP_PADANY) {
5953 o->op_type = OP_PADHV;
5954 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5957 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5958 && ckWARN(WARN_DEPRECATED)) {
5959 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5960 "Using a hash as a reference is deprecated");
5962 return newUNOP(OP_RV2HV, 0, scalar(o));
5966 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5968 return newUNOP(OP_RV2CV, flags, scalar(o));
5972 Perl_newSVREF(pTHX_ OP *o)
5975 if (o->op_type == OP_PADANY) {
5976 o->op_type = OP_PADSV;
5977 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5980 return newUNOP(OP_RV2SV, 0, scalar(o));
5983 /* Check routines. See the comments at the top of this file for details
5984 * on when these are called */
5987 Perl_ck_anoncode(pTHX_ OP *o)
5989 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5991 cSVOPo->op_sv = NULL;
5996 Perl_ck_bitop(pTHX_ OP *o)
5999 #define OP_IS_NUMCOMPARE(op) \
6000 ((op) == OP_LT || (op) == OP_I_LT || \
6001 (op) == OP_GT || (op) == OP_I_GT || \
6002 (op) == OP_LE || (op) == OP_I_LE || \
6003 (op) == OP_GE || (op) == OP_I_GE || \
6004 (op) == OP_EQ || (op) == OP_I_EQ || \
6005 (op) == OP_NE || (op) == OP_I_NE || \
6006 (op) == OP_NCMP || (op) == OP_I_NCMP)
6007 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6008 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6009 && (o->op_type == OP_BIT_OR
6010 || o->op_type == OP_BIT_AND
6011 || o->op_type == OP_BIT_XOR))
6013 const OP * const left = cBINOPo->op_first;
6014 const OP * const right = left->op_sibling;
6015 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6016 (left->op_flags & OPf_PARENS) == 0) ||
6017 (OP_IS_NUMCOMPARE(right->op_type) &&
6018 (right->op_flags & OPf_PARENS) == 0))
6019 if (ckWARN(WARN_PRECEDENCE))
6020 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6021 "Possible precedence problem on bitwise %c operator",
6022 o->op_type == OP_BIT_OR ? '|'
6023 : o->op_type == OP_BIT_AND ? '&' : '^'
6030 Perl_ck_concat(pTHX_ OP *o)
6032 const OP * const kid = cUNOPo->op_first;
6033 PERL_UNUSED_CONTEXT;
6034 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6035 !(kUNOP->op_first->op_flags & OPf_MOD))
6036 o->op_flags |= OPf_STACKED;
6041 Perl_ck_spair(pTHX_ OP *o)
6044 if (o->op_flags & OPf_KIDS) {
6047 const OPCODE type = o->op_type;
6048 o = modkids(ck_fun(o), type);
6049 kid = cUNOPo->op_first;
6050 newop = kUNOP->op_first->op_sibling;
6052 const OPCODE type = newop->op_type;
6053 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6054 type == OP_PADAV || type == OP_PADHV ||
6055 type == OP_RV2AV || type == OP_RV2HV)
6059 op_getmad(kUNOP->op_first,newop,'K');
6061 op_free(kUNOP->op_first);
6063 kUNOP->op_first = newop;
6065 o->op_ppaddr = PL_ppaddr[++o->op_type];
6070 Perl_ck_delete(pTHX_ OP *o)
6074 if (o->op_flags & OPf_KIDS) {
6075 OP * const kid = cUNOPo->op_first;
6076 switch (kid->op_type) {
6078 o->op_flags |= OPf_SPECIAL;
6081 o->op_private |= OPpSLICE;
6084 o->op_flags |= OPf_SPECIAL;
6089 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6098 Perl_ck_die(pTHX_ OP *o)
6101 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6107 Perl_ck_eof(pTHX_ OP *o)
6111 if (o->op_flags & OPf_KIDS) {
6112 if (cLISTOPo->op_first->op_type == OP_STUB) {
6114 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6116 op_getmad(o,newop,'O');
6128 Perl_ck_eval(pTHX_ OP *o)
6131 PL_hints |= HINT_BLOCK_SCOPE;
6132 if (o->op_flags & OPf_KIDS) {
6133 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6136 o->op_flags &= ~OPf_KIDS;
6139 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6145 cUNOPo->op_first = 0;
6150 NewOp(1101, enter, 1, LOGOP);
6151 enter->op_type = OP_ENTERTRY;
6152 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6153 enter->op_private = 0;
6155 /* establish postfix order */
6156 enter->op_next = (OP*)enter;
6158 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6159 o->op_type = OP_LEAVETRY;
6160 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6161 enter->op_other = o;
6162 op_getmad(oldo,o,'O');
6176 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6177 op_getmad(oldo,o,'O');
6179 o->op_targ = (PADOFFSET)PL_hints;
6180 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6181 /* Store a copy of %^H that pp_entereval can pick up.
6182 OPf_SPECIAL flags the opcode as being for this purpose,
6183 so that it in turn will return a copy at every
6185 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6186 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6187 cUNOPo->op_first->op_sibling = hhop;
6188 o->op_private |= OPpEVAL_HAS_HH;
6194 Perl_ck_exit(pTHX_ OP *o)
6197 HV * const table = GvHV(PL_hintgv);
6199 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6200 if (svp && *svp && SvTRUE(*svp))
6201 o->op_private |= OPpEXIT_VMSISH;
6203 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6209 Perl_ck_exec(pTHX_ OP *o)
6211 if (o->op_flags & OPf_STACKED) {
6214 kid = cUNOPo->op_first->op_sibling;
6215 if (kid->op_type == OP_RV2GV)
6224 Perl_ck_exists(pTHX_ OP *o)
6228 if (o->op_flags & OPf_KIDS) {
6229 OP * const kid = cUNOPo->op_first;
6230 if (kid->op_type == OP_ENTERSUB) {
6231 (void) ref(kid, o->op_type);
6232 if (kid->op_type != OP_RV2CV
6233 && !(PL_parser && PL_parser->error_count))
6234 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6236 o->op_private |= OPpEXISTS_SUB;
6238 else if (kid->op_type == OP_AELEM)
6239 o->op_flags |= OPf_SPECIAL;
6240 else if (kid->op_type != OP_HELEM)
6241 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6249 Perl_ck_rvconst(pTHX_ register OP *o)
6252 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6254 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6255 if (o->op_type == OP_RV2CV)
6256 o->op_private &= ~1;
6258 if (kid->op_type == OP_CONST) {
6261 SV * const kidsv = kid->op_sv;
6263 /* Is it a constant from cv_const_sv()? */
6264 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6265 SV * const rsv = SvRV(kidsv);
6266 const svtype type = SvTYPE(rsv);
6267 const char *badtype = NULL;
6269 switch (o->op_type) {
6271 if (type > SVt_PVMG)
6272 badtype = "a SCALAR";
6275 if (type != SVt_PVAV)
6276 badtype = "an ARRAY";
6279 if (type != SVt_PVHV)
6283 if (type != SVt_PVCV)
6288 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6291 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6292 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6293 /* If this is an access to a stash, disable "strict refs", because
6294 * stashes aren't auto-vivified at compile-time (unless we store
6295 * symbols in them), and we don't want to produce a run-time
6296 * stricture error when auto-vivifying the stash. */
6297 const char *s = SvPV_nolen(kidsv);
6298 const STRLEN l = SvCUR(kidsv);
6299 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6300 o->op_private &= ~HINT_STRICT_REFS;
6302 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6303 const char *badthing;
6304 switch (o->op_type) {
6306 badthing = "a SCALAR";
6309 badthing = "an ARRAY";
6312 badthing = "a HASH";
6320 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6321 SVfARG(kidsv), badthing);
6324 * This is a little tricky. We only want to add the symbol if we
6325 * didn't add it in the lexer. Otherwise we get duplicate strict
6326 * warnings. But if we didn't add it in the lexer, we must at
6327 * least pretend like we wanted to add it even if it existed before,
6328 * or we get possible typo warnings. OPpCONST_ENTERED says
6329 * whether the lexer already added THIS instance of this symbol.
6331 iscv = (o->op_type == OP_RV2CV) * 2;
6333 gv = gv_fetchsv(kidsv,
6334 iscv | !(kid->op_private & OPpCONST_ENTERED),
6337 : o->op_type == OP_RV2SV
6339 : o->op_type == OP_RV2AV
6341 : o->op_type == OP_RV2HV
6344 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6346 kid->op_type = OP_GV;
6347 SvREFCNT_dec(kid->op_sv);
6349 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6350 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6351 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6353 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6355 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6357 kid->op_private = 0;
6358 kid->op_ppaddr = PL_ppaddr[OP_GV];
6365 Perl_ck_ftst(pTHX_ OP *o)
6368 const I32 type = o->op_type;
6370 if (o->op_flags & OPf_REF) {
6373 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6374 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6375 const OPCODE kidtype = kid->op_type;
6377 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6378 OP * const newop = newGVOP(type, OPf_REF,
6379 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6381 op_getmad(o,newop,'O');
6387 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6388 o->op_private |= OPpFT_ACCESS;
6389 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6390 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6391 o->op_private |= OPpFT_STACKED;
6399 if (type == OP_FTTTY)
6400 o = newGVOP(type, OPf_REF, PL_stdingv);
6402 o = newUNOP(type, 0, newDEFSVOP());
6403 op_getmad(oldo,o,'O');
6409 Perl_ck_fun(pTHX_ OP *o)
6412 const int type = o->op_type;
6413 register I32 oa = PL_opargs[type] >> OASHIFT;
6415 if (o->op_flags & OPf_STACKED) {
6416 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6419 return no_fh_allowed(o);
6422 if (o->op_flags & OPf_KIDS) {
6423 OP **tokid = &cLISTOPo->op_first;
6424 register OP *kid = cLISTOPo->op_first;
6428 if (kid->op_type == OP_PUSHMARK ||
6429 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6431 tokid = &kid->op_sibling;
6432 kid = kid->op_sibling;
6434 if (!kid && PL_opargs[type] & OA_DEFGV)
6435 *tokid = kid = newDEFSVOP();
6439 sibl = kid->op_sibling;
6441 if (!sibl && kid->op_type == OP_STUB) {
6448 /* list seen where single (scalar) arg expected? */
6449 if (numargs == 1 && !(oa >> 4)
6450 && kid->op_type == OP_LIST && type != OP_SCALAR)
6452 return too_many_arguments(o,PL_op_desc[type]);
6465 if ((type == OP_PUSH || type == OP_UNSHIFT)
6466 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6467 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6468 "Useless use of %s with no values",
6471 if (kid->op_type == OP_CONST &&
6472 (kid->op_private & OPpCONST_BARE))
6474 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6475 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6476 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6477 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6478 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6479 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6481 op_getmad(kid,newop,'K');
6486 kid->op_sibling = sibl;
6489 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6490 bad_type(numargs, "array", PL_op_desc[type], kid);
6494 if (kid->op_type == OP_CONST &&
6495 (kid->op_private & OPpCONST_BARE))
6497 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6498 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6499 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6500 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6501 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6502 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6504 op_getmad(kid,newop,'K');
6509 kid->op_sibling = sibl;
6512 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6513 bad_type(numargs, "hash", PL_op_desc[type], kid);
6518 OP * const newop = newUNOP(OP_NULL, 0, kid);
6519 kid->op_sibling = 0;
6521 newop->op_next = newop;
6523 kid->op_sibling = sibl;
6528 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6529 if (kid->op_type == OP_CONST &&
6530 (kid->op_private & OPpCONST_BARE))
6532 OP * const newop = newGVOP(OP_GV, 0,
6533 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6534 if (!(o->op_private & 1) && /* if not unop */
6535 kid == cLISTOPo->op_last)
6536 cLISTOPo->op_last = newop;
6538 op_getmad(kid,newop,'K');
6544 else if (kid->op_type == OP_READLINE) {
6545 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6546 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6549 I32 flags = OPf_SPECIAL;
6553 /* is this op a FH constructor? */
6554 if (is_handle_constructor(o,numargs)) {
6555 const char *name = NULL;
6559 /* Set a flag to tell rv2gv to vivify
6560 * need to "prove" flag does not mean something
6561 * else already - NI-S 1999/05/07
6564 if (kid->op_type == OP_PADSV) {
6566 = PAD_COMPNAME_SV(kid->op_targ);
6567 name = SvPV_const(namesv, len);
6569 else if (kid->op_type == OP_RV2SV
6570 && kUNOP->op_first->op_type == OP_GV)
6572 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6574 len = GvNAMELEN(gv);
6576 else if (kid->op_type == OP_AELEM
6577 || kid->op_type == OP_HELEM)
6580 OP *op = ((BINOP*)kid)->op_first;
6584 const char * const a =
6585 kid->op_type == OP_AELEM ?
6587 if (((op->op_type == OP_RV2AV) ||
6588 (op->op_type == OP_RV2HV)) &&
6589 (firstop = ((UNOP*)op)->op_first) &&
6590 (firstop->op_type == OP_GV)) {
6591 /* packagevar $a[] or $h{} */
6592 GV * const gv = cGVOPx_gv(firstop);
6600 else if (op->op_type == OP_PADAV
6601 || op->op_type == OP_PADHV) {
6602 /* lexicalvar $a[] or $h{} */
6603 const char * const padname =
6604 PAD_COMPNAME_PV(op->op_targ);
6613 name = SvPV_const(tmpstr, len);
6618 name = "__ANONIO__";
6625 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6626 namesv = PAD_SVl(targ);
6627 SvUPGRADE(namesv, SVt_PV);
6629 sv_setpvn(namesv, "$", 1);
6630 sv_catpvn(namesv, name, len);
6633 kid->op_sibling = 0;
6634 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6635 kid->op_targ = targ;
6636 kid->op_private |= priv;
6638 kid->op_sibling = sibl;
6644 mod(scalar(kid), type);
6648 tokid = &kid->op_sibling;
6649 kid = kid->op_sibling;
6652 if (kid && kid->op_type != OP_STUB)
6653 return too_many_arguments(o,OP_DESC(o));
6654 o->op_private |= numargs;
6656 /* FIXME - should the numargs move as for the PERL_MAD case? */
6657 o->op_private |= numargs;
6659 return too_many_arguments(o,OP_DESC(o));
6663 else if (PL_opargs[type] & OA_DEFGV) {
6665 OP *newop = newUNOP(type, 0, newDEFSVOP());
6666 op_getmad(o,newop,'O');
6669 /* Ordering of these two is important to keep f_map.t passing. */
6671 return newUNOP(type, 0, newDEFSVOP());
6676 while (oa & OA_OPTIONAL)
6678 if (oa && oa != OA_LIST)
6679 return too_few_arguments(o,OP_DESC(o));
6685 Perl_ck_glob(pTHX_ OP *o)
6691 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6692 append_elem(OP_GLOB, o, newDEFSVOP());
6694 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6695 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6697 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6700 #if !defined(PERL_EXTERNAL_GLOB)
6701 /* XXX this can be tightened up and made more failsafe. */
6702 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6705 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6706 newSVpvs("File::Glob"), NULL, NULL, NULL);
6707 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6708 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6709 GvCV(gv) = GvCV(glob_gv);
6710 SvREFCNT_inc_void((SV*)GvCV(gv));
6711 GvIMPORTED_CV_on(gv);
6714 #endif /* PERL_EXTERNAL_GLOB */
6716 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6717 append_elem(OP_GLOB, o,
6718 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6719 o->op_type = OP_LIST;
6720 o->op_ppaddr = PL_ppaddr[OP_LIST];
6721 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6722 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6723 cLISTOPo->op_first->op_targ = 0;
6724 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6725 append_elem(OP_LIST, o,
6726 scalar(newUNOP(OP_RV2CV, 0,
6727 newGVOP(OP_GV, 0, gv)))));
6728 o = newUNOP(OP_NULL, 0, ck_subr(o));
6729 o->op_targ = OP_GLOB; /* hint at what it used to be */
6732 gv = newGVgen("main");
6734 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6740 Perl_ck_grep(pTHX_ OP *o)
6745 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6748 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6749 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
6751 if (o->op_flags & OPf_STACKED) {
6754 kid = cLISTOPo->op_first->op_sibling;
6755 if (!cUNOPx(kid)->op_next)
6756 Perl_croak(aTHX_ "panic: ck_grep");
6757 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6760 NewOp(1101, gwop, 1, LOGOP);
6761 kid->op_next = (OP*)gwop;
6762 o->op_flags &= ~OPf_STACKED;
6764 kid = cLISTOPo->op_first->op_sibling;
6765 if (type == OP_MAPWHILE)
6770 if (PL_parser && PL_parser->error_count)
6772 kid = cLISTOPo->op_first->op_sibling;
6773 if (kid->op_type != OP_NULL)
6774 Perl_croak(aTHX_ "panic: ck_grep");
6775 kid = kUNOP->op_first;
6778 NewOp(1101, gwop, 1, LOGOP);
6779 gwop->op_type = type;
6780 gwop->op_ppaddr = PL_ppaddr[type];
6781 gwop->op_first = listkids(o);
6782 gwop->op_flags |= OPf_KIDS;
6783 gwop->op_other = LINKLIST(kid);
6784 kid->op_next = (OP*)gwop;
6785 offset = pad_findmy("$_");
6786 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6787 o->op_private = gwop->op_private = 0;
6788 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6791 o->op_private = gwop->op_private = OPpGREP_LEX;
6792 gwop->op_targ = o->op_targ = offset;
6795 kid = cLISTOPo->op_first->op_sibling;
6796 if (!kid || !kid->op_sibling)
6797 return too_few_arguments(o,OP_DESC(o));
6798 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6799 mod(kid, OP_GREPSTART);
6805 Perl_ck_index(pTHX_ OP *o)
6807 if (o->op_flags & OPf_KIDS) {
6808 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6810 kid = kid->op_sibling; /* get past "big" */
6811 if (kid && kid->op_type == OP_CONST)
6812 fbm_compile(((SVOP*)kid)->op_sv, 0);
6818 Perl_ck_lengthconst(pTHX_ OP *o)
6820 /* XXX length optimization goes here */
6825 Perl_ck_lfun(pTHX_ OP *o)
6827 const OPCODE type = o->op_type;
6828 return modkids(ck_fun(o), type);
6832 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6834 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6835 switch (cUNOPo->op_first->op_type) {
6837 /* This is needed for
6838 if (defined %stash::)
6839 to work. Do not break Tk.
6841 break; /* Globals via GV can be undef */
6843 case OP_AASSIGN: /* Is this a good idea? */
6844 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6845 "defined(@array) is deprecated");
6846 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6847 "\t(Maybe you should just omit the defined()?)\n");
6850 /* This is needed for
6851 if (defined %stash::)
6852 to work. Do not break Tk.
6854 break; /* Globals via GV can be undef */
6856 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6857 "defined(%%hash) is deprecated");
6858 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6859 "\t(Maybe you should just omit the defined()?)\n");
6870 Perl_ck_readline(pTHX_ OP *o)
6872 if (!(o->op_flags & OPf_KIDS)) {
6874 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6876 op_getmad(o,newop,'O');
6886 Perl_ck_rfun(pTHX_ OP *o)
6888 const OPCODE type = o->op_type;
6889 return refkids(ck_fun(o), type);
6893 Perl_ck_listiob(pTHX_ OP *o)
6897 kid = cLISTOPo->op_first;
6900 kid = cLISTOPo->op_first;
6902 if (kid->op_type == OP_PUSHMARK)
6903 kid = kid->op_sibling;
6904 if (kid && o->op_flags & OPf_STACKED)
6905 kid = kid->op_sibling;
6906 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6907 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6908 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6909 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6910 cLISTOPo->op_first->op_sibling = kid;
6911 cLISTOPo->op_last = kid;
6912 kid = kid->op_sibling;
6917 append_elem(o->op_type, o, newDEFSVOP());
6923 Perl_ck_smartmatch(pTHX_ OP *o)
6926 if (0 == (o->op_flags & OPf_SPECIAL)) {
6927 OP *first = cBINOPo->op_first;
6928 OP *second = first->op_sibling;
6930 /* Implicitly take a reference to an array or hash */
6931 first->op_sibling = NULL;
6932 first = cBINOPo->op_first = ref_array_or_hash(first);
6933 second = first->op_sibling = ref_array_or_hash(second);
6935 /* Implicitly take a reference to a regular expression */
6936 if (first->op_type == OP_MATCH) {
6937 first->op_type = OP_QR;
6938 first->op_ppaddr = PL_ppaddr[OP_QR];
6940 if (second->op_type == OP_MATCH) {
6941 second->op_type = OP_QR;
6942 second->op_ppaddr = PL_ppaddr[OP_QR];
6951 Perl_ck_sassign(pTHX_ OP *o)
6953 OP * const kid = cLISTOPo->op_first;
6954 /* has a disposable target? */
6955 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6956 && !(kid->op_flags & OPf_STACKED)
6957 /* Cannot steal the second time! */
6958 && !(kid->op_private & OPpTARGET_MY)
6959 /* Keep the full thing for madskills */
6963 OP * const kkid = kid->op_sibling;
6965 /* Can just relocate the target. */
6966 if (kkid && kkid->op_type == OP_PADSV
6967 && !(kkid->op_private & OPpLVAL_INTRO))
6969 kid->op_targ = kkid->op_targ;
6971 /* Now we do not need PADSV and SASSIGN. */
6972 kid->op_sibling = o->op_sibling; /* NULL */
6973 cLISTOPo->op_first = NULL;
6976 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6984 Perl_ck_match(pTHX_ OP *o)
6987 if (o->op_type != OP_QR && PL_compcv) {
6988 const PADOFFSET offset = pad_findmy("$_");
6989 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6990 o->op_targ = offset;
6991 o->op_private |= OPpTARGET_MY;
6994 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6995 o->op_private |= OPpRUNTIME;
7000 Perl_ck_method(pTHX_ OP *o)
7002 OP * const kid = cUNOPo->op_first;
7003 if (kid->op_type == OP_CONST) {
7004 SV* sv = kSVOP->op_sv;
7005 const char * const method = SvPVX_const(sv);
7006 if (!(strchr(method, ':') || strchr(method, '\''))) {
7008 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7009 sv = newSVpvn_share(method, SvCUR(sv), 0);
7012 kSVOP->op_sv = NULL;
7014 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7016 op_getmad(o,cmop,'O');
7027 Perl_ck_null(pTHX_ OP *o)
7029 PERL_UNUSED_CONTEXT;
7034 Perl_ck_open(pTHX_ OP *o)
7037 HV * const table = GvHV(PL_hintgv);
7039 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7041 const I32 mode = mode_from_discipline(*svp);
7042 if (mode & O_BINARY)
7043 o->op_private |= OPpOPEN_IN_RAW;
7044 else if (mode & O_TEXT)
7045 o->op_private |= OPpOPEN_IN_CRLF;
7048 svp = hv_fetchs(table, "open_OUT", FALSE);
7050 const I32 mode = mode_from_discipline(*svp);
7051 if (mode & O_BINARY)
7052 o->op_private |= OPpOPEN_OUT_RAW;
7053 else if (mode & O_TEXT)
7054 o->op_private |= OPpOPEN_OUT_CRLF;
7057 if (o->op_type == OP_BACKTICK) {
7058 if (!(o->op_flags & OPf_KIDS)) {
7059 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7061 op_getmad(o,newop,'O');
7070 /* In case of three-arg dup open remove strictness
7071 * from the last arg if it is a bareword. */
7072 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7073 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7077 if ((last->op_type == OP_CONST) && /* The bareword. */
7078 (last->op_private & OPpCONST_BARE) &&
7079 (last->op_private & OPpCONST_STRICT) &&
7080 (oa = first->op_sibling) && /* The fh. */
7081 (oa = oa->op_sibling) && /* The mode. */
7082 (oa->op_type == OP_CONST) &&
7083 SvPOK(((SVOP*)oa)->op_sv) &&
7084 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7085 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7086 (last == oa->op_sibling)) /* The bareword. */
7087 last->op_private &= ~OPpCONST_STRICT;
7093 Perl_ck_repeat(pTHX_ OP *o)
7095 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7096 o->op_private |= OPpREPEAT_DOLIST;
7097 cBINOPo->op_first = force_list(cBINOPo->op_first);
7105 Perl_ck_require(pTHX_ OP *o)
7110 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7111 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7113 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7114 SV * const sv = kid->op_sv;
7115 U32 was_readonly = SvREADONLY(sv);
7120 sv_force_normal_flags(sv, 0);
7121 assert(!SvREADONLY(sv));
7128 for (s = SvPVX(sv); *s; s++) {
7129 if (*s == ':' && s[1] == ':') {
7130 const STRLEN len = strlen(s+2)+1;
7132 Move(s+2, s+1, len, char);
7133 SvCUR_set(sv, SvCUR(sv) - 1);
7136 sv_catpvs(sv, ".pm");
7137 SvFLAGS(sv) |= was_readonly;
7141 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7142 /* handle override, if any */
7143 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7144 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7145 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7146 gv = gvp ? *gvp : NULL;
7150 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7151 OP * const kid = cUNOPo->op_first;
7154 cUNOPo->op_first = 0;
7158 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7159 append_elem(OP_LIST, kid,
7160 scalar(newUNOP(OP_RV2CV, 0,
7163 op_getmad(o,newop,'O');
7171 Perl_ck_return(pTHX_ OP *o)
7174 if (CvLVALUE(PL_compcv)) {
7176 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7177 mod(kid, OP_LEAVESUBLV);
7183 Perl_ck_select(pTHX_ OP *o)
7187 if (o->op_flags & OPf_KIDS) {
7188 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7189 if (kid && kid->op_sibling) {
7190 o->op_type = OP_SSELECT;
7191 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7193 return fold_constants(o);
7197 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7198 if (kid && kid->op_type == OP_RV2GV)
7199 kid->op_private &= ~HINT_STRICT_REFS;
7204 Perl_ck_shift(pTHX_ OP *o)
7207 const I32 type = o->op_type;
7209 if (!(o->op_flags & OPf_KIDS)) {
7211 /* FIXME - this can be refactored to reduce code in #ifdefs */
7213 OP * const oldo = o;
7217 argop = newUNOP(OP_RV2AV, 0,
7218 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7220 o = newUNOP(type, 0, scalar(argop));
7221 op_getmad(oldo,o,'O');
7224 return newUNOP(type, 0, scalar(argop));
7227 return scalar(modkids(ck_fun(o), type));
7231 Perl_ck_sort(pTHX_ OP *o)
7236 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7237 HV * const hinthv = GvHV(PL_hintgv);
7239 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7241 const I32 sorthints = (I32)SvIV(*svp);
7242 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7243 o->op_private |= OPpSORT_QSORT;
7244 if ((sorthints & HINT_SORT_STABLE) != 0)
7245 o->op_private |= OPpSORT_STABLE;
7250 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7252 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7253 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7255 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7257 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7259 if (kid->op_type == OP_SCOPE) {
7263 else if (kid->op_type == OP_LEAVE) {
7264 if (o->op_type == OP_SORT) {
7265 op_null(kid); /* wipe out leave */
7268 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7269 if (k->op_next == kid)
7271 /* don't descend into loops */
7272 else if (k->op_type == OP_ENTERLOOP
7273 || k->op_type == OP_ENTERITER)
7275 k = cLOOPx(k)->op_lastop;
7280 kid->op_next = 0; /* just disconnect the leave */
7281 k = kLISTOP->op_first;
7286 if (o->op_type == OP_SORT) {
7287 /* provide scalar context for comparison function/block */
7293 o->op_flags |= OPf_SPECIAL;
7295 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7298 firstkid = firstkid->op_sibling;
7301 /* provide list context for arguments */
7302 if (o->op_type == OP_SORT)
7309 S_simplify_sort(pTHX_ OP *o)
7312 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7317 if (!(o->op_flags & OPf_STACKED))
7319 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7320 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7321 kid = kUNOP->op_first; /* get past null */
7322 if (kid->op_type != OP_SCOPE)
7324 kid = kLISTOP->op_last; /* get past scope */
7325 switch(kid->op_type) {
7333 k = kid; /* remember this node*/
7334 if (kBINOP->op_first->op_type != OP_RV2SV)
7336 kid = kBINOP->op_first; /* get past cmp */
7337 if (kUNOP->op_first->op_type != OP_GV)
7339 kid = kUNOP->op_first; /* get past rv2sv */
7341 if (GvSTASH(gv) != PL_curstash)
7343 gvname = GvNAME(gv);
7344 if (*gvname == 'a' && gvname[1] == '\0')
7346 else if (*gvname == 'b' && gvname[1] == '\0')
7351 kid = k; /* back to cmp */
7352 if (kBINOP->op_last->op_type != OP_RV2SV)
7354 kid = kBINOP->op_last; /* down to 2nd arg */
7355 if (kUNOP->op_first->op_type != OP_GV)
7357 kid = kUNOP->op_first; /* get past rv2sv */
7359 if (GvSTASH(gv) != PL_curstash)
7361 gvname = GvNAME(gv);
7363 ? !(*gvname == 'a' && gvname[1] == '\0')
7364 : !(*gvname == 'b' && gvname[1] == '\0'))
7366 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7368 o->op_private |= OPpSORT_DESCEND;
7369 if (k->op_type == OP_NCMP)
7370 o->op_private |= OPpSORT_NUMERIC;
7371 if (k->op_type == OP_I_NCMP)
7372 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7373 kid = cLISTOPo->op_first->op_sibling;
7374 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7376 op_getmad(kid,o,'S'); /* then delete it */
7378 op_free(kid); /* then delete it */
7383 Perl_ck_split(pTHX_ OP *o)
7388 if (o->op_flags & OPf_STACKED)
7389 return no_fh_allowed(o);
7391 kid = cLISTOPo->op_first;
7392 if (kid->op_type != OP_NULL)
7393 Perl_croak(aTHX_ "panic: ck_split");
7394 kid = kid->op_sibling;
7395 op_free(cLISTOPo->op_first);
7396 cLISTOPo->op_first = kid;
7398 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7399 cLISTOPo->op_last = kid; /* There was only one element previously */
7402 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7403 OP * const sibl = kid->op_sibling;
7404 kid->op_sibling = 0;
7405 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7406 if (cLISTOPo->op_first == cLISTOPo->op_last)
7407 cLISTOPo->op_last = kid;
7408 cLISTOPo->op_first = kid;
7409 kid->op_sibling = sibl;
7412 kid->op_type = OP_PUSHRE;
7413 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7415 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7416 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7417 "Use of /g modifier is meaningless in split");
7420 if (!kid->op_sibling)
7421 append_elem(OP_SPLIT, o, newDEFSVOP());
7423 kid = kid->op_sibling;
7426 if (!kid->op_sibling)
7427 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7428 assert(kid->op_sibling);
7430 kid = kid->op_sibling;
7433 if (kid->op_sibling)
7434 return too_many_arguments(o,OP_DESC(o));
7440 Perl_ck_join(pTHX_ OP *o)
7442 const OP * const kid = cLISTOPo->op_first->op_sibling;
7443 if (kid && kid->op_type == OP_MATCH) {
7444 if (ckWARN(WARN_SYNTAX)) {
7445 const REGEXP *re = PM_GETRE(kPMOP);
7446 const char *pmstr = re ? re->precomp : "STRING";
7447 const STRLEN len = re ? re->prelen : 6;
7448 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7449 "/%.*s/ should probably be written as \"%.*s\"",
7450 (int)len, pmstr, (int)len, pmstr);
7457 Perl_ck_subr(pTHX_ OP *o)
7460 OP *prev = ((cUNOPo->op_first->op_sibling)
7461 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7462 OP *o2 = prev->op_sibling;
7464 const char *proto = NULL;
7465 const char *proto_end = NULL;
7470 I32 contextclass = 0;
7471 const char *e = NULL;
7474 o->op_private |= OPpENTERSUB_HASTARG;
7475 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7476 if (cvop->op_type == OP_RV2CV) {
7478 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7479 op_null(cvop); /* disable rv2cv */
7480 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7481 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7482 GV *gv = cGVOPx_gv(tmpop);
7485 tmpop->op_private |= OPpEARLY_CV;
7489 namegv = CvANON(cv) ? gv : CvGV(cv);
7490 proto = SvPV((SV*)cv, len);
7491 proto_end = proto + len;
7496 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7497 if (o2->op_type == OP_CONST)
7498 o2->op_private &= ~OPpCONST_STRICT;
7499 else if (o2->op_type == OP_LIST) {
7500 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7501 if (sib && sib->op_type == OP_CONST)
7502 sib->op_private &= ~OPpCONST_STRICT;
7505 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7506 if (PERLDB_SUB && PL_curstash != PL_debstash)
7507 o->op_private |= OPpENTERSUB_DB;
7508 while (o2 != cvop) {
7510 if (PL_madskills && o2->op_type == OP_STUB) {
7511 o2 = o2->op_sibling;
7514 if (PL_madskills && o2->op_type == OP_NULL)
7515 o3 = ((UNOP*)o2)->op_first;
7519 if (proto >= proto_end)
7520 return too_many_arguments(o, gv_ename(namegv));
7528 /* _ must be at the end */
7529 if (proto[1] && proto[1] != ';')
7544 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7546 arg == 1 ? "block or sub {}" : "sub {}",
7547 gv_ename(namegv), o3);
7550 /* '*' allows any scalar type, including bareword */
7553 if (o3->op_type == OP_RV2GV)
7554 goto wrapref; /* autoconvert GLOB -> GLOBref */
7555 else if (o3->op_type == OP_CONST)
7556 o3->op_private &= ~OPpCONST_STRICT;
7557 else if (o3->op_type == OP_ENTERSUB) {
7558 /* accidental subroutine, revert to bareword */
7559 OP *gvop = ((UNOP*)o3)->op_first;
7560 if (gvop && gvop->op_type == OP_NULL) {
7561 gvop = ((UNOP*)gvop)->op_first;
7563 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7566 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7567 (gvop = ((UNOP*)gvop)->op_first) &&
7568 gvop->op_type == OP_GV)
7570 GV * const gv = cGVOPx_gv(gvop);
7571 OP * const sibling = o2->op_sibling;
7572 SV * const n = newSVpvs("");
7574 OP * const oldo2 = o2;
7578 gv_fullname4(n, gv, "", FALSE);
7579 o2 = newSVOP(OP_CONST, 0, n);
7580 op_getmad(oldo2,o2,'O');
7581 prev->op_sibling = o2;
7582 o2->op_sibling = sibling;
7598 if (contextclass++ == 0) {
7599 e = strchr(proto, ']');
7600 if (!e || e == proto)
7609 const char *p = proto;
7610 const char *const end = proto;
7612 while (*--p != '[');
7613 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7615 gv_ename(namegv), o3);
7620 if (o3->op_type == OP_RV2GV)
7623 bad_type(arg, "symbol", gv_ename(namegv), o3);
7626 if (o3->op_type == OP_ENTERSUB)
7629 bad_type(arg, "subroutine entry", gv_ename(namegv),
7633 if (o3->op_type == OP_RV2SV ||
7634 o3->op_type == OP_PADSV ||
7635 o3->op_type == OP_HELEM ||
7636 o3->op_type == OP_AELEM)
7639 bad_type(arg, "scalar", gv_ename(namegv), o3);
7642 if (o3->op_type == OP_RV2AV ||
7643 o3->op_type == OP_PADAV)
7646 bad_type(arg, "array", gv_ename(namegv), o3);
7649 if (o3->op_type == OP_RV2HV ||
7650 o3->op_type == OP_PADHV)
7653 bad_type(arg, "hash", gv_ename(namegv), o3);
7658 OP* const sib = kid->op_sibling;
7659 kid->op_sibling = 0;
7660 o2 = newUNOP(OP_REFGEN, 0, kid);
7661 o2->op_sibling = sib;
7662 prev->op_sibling = o2;
7664 if (contextclass && e) {
7679 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7680 gv_ename(namegv), SVfARG(cv));
7685 mod(o2, OP_ENTERSUB);
7687 o2 = o2->op_sibling;
7689 if (o2 == cvop && proto && *proto == '_') {
7690 /* generate an access to $_ */
7692 o2->op_sibling = prev->op_sibling;
7693 prev->op_sibling = o2; /* instead of cvop */
7695 if (proto && !optional && proto_end > proto &&
7696 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7697 return too_few_arguments(o, gv_ename(namegv));
7700 OP * const oldo = o;
7704 o=newSVOP(OP_CONST, 0, newSViv(0));
7705 op_getmad(oldo,o,'O');
7711 Perl_ck_svconst(pTHX_ OP *o)
7713 PERL_UNUSED_CONTEXT;
7714 SvREADONLY_on(cSVOPo->op_sv);
7719 Perl_ck_chdir(pTHX_ OP *o)
7721 if (o->op_flags & OPf_KIDS) {
7722 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7724 if (kid && kid->op_type == OP_CONST &&
7725 (kid->op_private & OPpCONST_BARE))
7727 o->op_flags |= OPf_SPECIAL;
7728 kid->op_private &= ~OPpCONST_STRICT;
7735 Perl_ck_trunc(pTHX_ OP *o)
7737 if (o->op_flags & OPf_KIDS) {
7738 SVOP *kid = (SVOP*)cUNOPo->op_first;
7740 if (kid->op_type == OP_NULL)
7741 kid = (SVOP*)kid->op_sibling;
7742 if (kid && kid->op_type == OP_CONST &&
7743 (kid->op_private & OPpCONST_BARE))
7745 o->op_flags |= OPf_SPECIAL;
7746 kid->op_private &= ~OPpCONST_STRICT;
7753 Perl_ck_unpack(pTHX_ OP *o)
7755 OP *kid = cLISTOPo->op_first;
7756 if (kid->op_sibling) {
7757 kid = kid->op_sibling;
7758 if (!kid->op_sibling)
7759 kid->op_sibling = newDEFSVOP();
7765 Perl_ck_substr(pTHX_ OP *o)
7768 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7769 OP *kid = cLISTOPo->op_first;
7771 if (kid->op_type == OP_NULL)
7772 kid = kid->op_sibling;
7774 kid->op_flags |= OPf_MOD;
7780 /* A peephole optimizer. We visit the ops in the order they're to execute.
7781 * See the comments at the top of this file for more details about when
7782 * peep() is called */
7785 Perl_peep(pTHX_ register OP *o)
7788 register OP* oldop = NULL;
7790 if (!o || o->op_opt)
7794 SAVEVPTR(PL_curcop);
7795 for (; o; o = o->op_next) {
7798 /* By default, this op has now been optimised. A couple of cases below
7799 clear this again. */
7802 switch (o->op_type) {
7806 PL_curcop = ((COP*)o); /* for warnings */
7810 if (cSVOPo->op_private & OPpCONST_STRICT)
7811 no_bareword_allowed(o);
7813 case OP_METHOD_NAMED:
7814 /* Relocate sv to the pad for thread safety.
7815 * Despite being a "constant", the SV is written to,
7816 * for reference counts, sv_upgrade() etc. */
7818 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7819 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7820 /* If op_sv is already a PADTMP then it is being used by
7821 * some pad, so make a copy. */
7822 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7823 SvREADONLY_on(PAD_SVl(ix));
7824 SvREFCNT_dec(cSVOPo->op_sv);
7826 else if (o->op_type == OP_CONST
7827 && cSVOPo->op_sv == &PL_sv_undef) {
7828 /* PL_sv_undef is hack - it's unsafe to store it in the
7829 AV that is the pad, because av_fetch treats values of
7830 PL_sv_undef as a "free" AV entry and will merrily
7831 replace them with a new SV, causing pad_alloc to think
7832 that this pad slot is free. (When, clearly, it is not)
7834 SvOK_off(PAD_SVl(ix));
7835 SvPADTMP_on(PAD_SVl(ix));
7836 SvREADONLY_on(PAD_SVl(ix));
7839 SvREFCNT_dec(PAD_SVl(ix));
7840 SvPADTMP_on(cSVOPo->op_sv);
7841 PAD_SETSV(ix, cSVOPo->op_sv);
7842 /* XXX I don't know how this isn't readonly already. */
7843 SvREADONLY_on(PAD_SVl(ix));
7845 cSVOPo->op_sv = NULL;
7852 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7853 if (o->op_next->op_private & OPpTARGET_MY) {
7854 if (o->op_flags & OPf_STACKED) /* chained concats */
7855 break; /* ignore_optimization */
7857 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7858 o->op_targ = o->op_next->op_targ;
7859 o->op_next->op_targ = 0;
7860 o->op_private |= OPpTARGET_MY;
7863 op_null(o->op_next);
7867 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7868 break; /* Scalar stub must produce undef. List stub is noop */
7872 if (o->op_targ == OP_NEXTSTATE
7873 || o->op_targ == OP_DBSTATE
7874 || o->op_targ == OP_SETSTATE)
7876 PL_curcop = ((COP*)o);
7878 /* XXX: We avoid setting op_seq here to prevent later calls
7879 to peep() from mistakenly concluding that optimisation
7880 has already occurred. This doesn't fix the real problem,
7881 though (See 20010220.007). AMS 20010719 */
7882 /* op_seq functionality is now replaced by op_opt */
7889 if (oldop && o->op_next) {
7890 oldop->op_next = o->op_next;
7898 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7899 OP* const pop = (o->op_type == OP_PADAV) ?
7900 o->op_next : o->op_next->op_next;
7902 if (pop && pop->op_type == OP_CONST &&
7903 ((PL_op = pop->op_next)) &&
7904 pop->op_next->op_type == OP_AELEM &&
7905 !(pop->op_next->op_private &
7906 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7907 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7912 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7913 no_bareword_allowed(pop);
7914 if (o->op_type == OP_GV)
7915 op_null(o->op_next);
7916 op_null(pop->op_next);
7918 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7919 o->op_next = pop->op_next->op_next;
7920 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7921 o->op_private = (U8)i;
7922 if (o->op_type == OP_GV) {
7927 o->op_flags |= OPf_SPECIAL;
7928 o->op_type = OP_AELEMFAST;
7933 if (o->op_next->op_type == OP_RV2SV) {
7934 if (!(o->op_next->op_private & OPpDEREF)) {
7935 op_null(o->op_next);
7936 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7938 o->op_next = o->op_next->op_next;
7939 o->op_type = OP_GVSV;
7940 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7943 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7944 GV * const gv = cGVOPo_gv;
7945 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7946 /* XXX could check prototype here instead of just carping */
7947 SV * const sv = sv_newmortal();
7948 gv_efullname3(sv, gv, NULL);
7949 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7950 "%"SVf"() called too early to check prototype",
7954 else if (o->op_next->op_type == OP_READLINE
7955 && o->op_next->op_next->op_type == OP_CONCAT
7956 && (o->op_next->op_next->op_flags & OPf_STACKED))
7958 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7959 o->op_type = OP_RCATLINE;
7960 o->op_flags |= OPf_STACKED;
7961 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7962 op_null(o->op_next->op_next);
7963 op_null(o->op_next);
7978 while (cLOGOP->op_other->op_type == OP_NULL)
7979 cLOGOP->op_other = cLOGOP->op_other->op_next;
7980 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7985 while (cLOOP->op_redoop->op_type == OP_NULL)
7986 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7987 peep(cLOOP->op_redoop);
7988 while (cLOOP->op_nextop->op_type == OP_NULL)
7989 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7990 peep(cLOOP->op_nextop);
7991 while (cLOOP->op_lastop->op_type == OP_NULL)
7992 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7993 peep(cLOOP->op_lastop);
7997 assert(!(cPMOP->op_pmflags & PMf_ONCE));
7998 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
7999 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8000 cPMOP->op_pmstashstartu.op_pmreplstart
8001 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8002 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8006 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8007 && ckWARN(WARN_SYNTAX))
8009 if (o->op_next->op_sibling) {
8010 const OPCODE type = o->op_next->op_sibling->op_type;
8011 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8012 const line_t oldline = CopLINE(PL_curcop);
8013 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8014 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8015 "Statement unlikely to be reached");
8016 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8017 "\t(Maybe you meant system() when you said exec()?)\n");
8018 CopLINE_set(PL_curcop, oldline);
8029 const char *key = NULL;
8032 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8035 /* Make the CONST have a shared SV */
8036 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8037 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8038 key = SvPV_const(sv, keylen);
8039 lexname = newSVpvn_share(key,
8040 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8046 if ((o->op_private & (OPpLVAL_INTRO)))
8049 rop = (UNOP*)((BINOP*)o)->op_first;
8050 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8052 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8053 if (!SvPAD_TYPED(lexname))
8055 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8056 if (!fields || !GvHV(*fields))
8058 key = SvPV_const(*svp, keylen);
8059 if (!hv_fetch(GvHV(*fields), key,
8060 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8062 Perl_croak(aTHX_ "No such class field \"%s\" "
8063 "in variable %s of type %s",
8064 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8077 SVOP *first_key_op, *key_op;
8079 if ((o->op_private & (OPpLVAL_INTRO))
8080 /* I bet there's always a pushmark... */
8081 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8082 /* hmmm, no optimization if list contains only one key. */
8084 rop = (UNOP*)((LISTOP*)o)->op_last;
8085 if (rop->op_type != OP_RV2HV)
8087 if (rop->op_first->op_type == OP_PADSV)
8088 /* @$hash{qw(keys here)} */
8089 rop = (UNOP*)rop->op_first;
8091 /* @{$hash}{qw(keys here)} */
8092 if (rop->op_first->op_type == OP_SCOPE
8093 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8095 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8101 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8102 if (!SvPAD_TYPED(lexname))
8104 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8105 if (!fields || !GvHV(*fields))
8107 /* Again guessing that the pushmark can be jumped over.... */
8108 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8109 ->op_first->op_sibling;
8110 for (key_op = first_key_op; key_op;
8111 key_op = (SVOP*)key_op->op_sibling) {
8112 if (key_op->op_type != OP_CONST)
8114 svp = cSVOPx_svp(key_op);
8115 key = SvPV_const(*svp, keylen);
8116 if (!hv_fetch(GvHV(*fields), key,
8117 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8119 Perl_croak(aTHX_ "No such class field \"%s\" "
8120 "in variable %s of type %s",
8121 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8128 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8132 /* check that RHS of sort is a single plain array */
8133 OP *oright = cUNOPo->op_first;
8134 if (!oright || oright->op_type != OP_PUSHMARK)
8137 /* reverse sort ... can be optimised. */
8138 if (!cUNOPo->op_sibling) {
8139 /* Nothing follows us on the list. */
8140 OP * const reverse = o->op_next;
8142 if (reverse->op_type == OP_REVERSE &&
8143 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8144 OP * const pushmark = cUNOPx(reverse)->op_first;
8145 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8146 && (cUNOPx(pushmark)->op_sibling == o)) {
8147 /* reverse -> pushmark -> sort */
8148 o->op_private |= OPpSORT_REVERSE;
8150 pushmark->op_next = oright->op_next;
8156 /* make @a = sort @a act in-place */
8158 oright = cUNOPx(oright)->op_sibling;
8161 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8162 oright = cUNOPx(oright)->op_sibling;
8166 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8167 || oright->op_next != o
8168 || (oright->op_private & OPpLVAL_INTRO)
8172 /* o2 follows the chain of op_nexts through the LHS of the
8173 * assign (if any) to the aassign op itself */
8175 if (!o2 || o2->op_type != OP_NULL)
8178 if (!o2 || o2->op_type != OP_PUSHMARK)
8181 if (o2 && o2->op_type == OP_GV)
8184 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8185 || (o2->op_private & OPpLVAL_INTRO)
8190 if (!o2 || o2->op_type != OP_NULL)
8193 if (!o2 || o2->op_type != OP_AASSIGN
8194 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8197 /* check that the sort is the first arg on RHS of assign */
8199 o2 = cUNOPx(o2)->op_first;
8200 if (!o2 || o2->op_type != OP_NULL)
8202 o2 = cUNOPx(o2)->op_first;
8203 if (!o2 || o2->op_type != OP_PUSHMARK)
8205 if (o2->op_sibling != o)
8208 /* check the array is the same on both sides */
8209 if (oleft->op_type == OP_RV2AV) {
8210 if (oright->op_type != OP_RV2AV
8211 || !cUNOPx(oright)->op_first
8212 || cUNOPx(oright)->op_first->op_type != OP_GV
8213 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8214 cGVOPx_gv(cUNOPx(oright)->op_first)
8218 else if (oright->op_type != OP_PADAV
8219 || oright->op_targ != oleft->op_targ
8223 /* transfer MODishness etc from LHS arg to RHS arg */
8224 oright->op_flags = oleft->op_flags;
8225 o->op_private |= OPpSORT_INPLACE;
8227 /* excise push->gv->rv2av->null->aassign */
8228 o2 = o->op_next->op_next;
8229 op_null(o2); /* PUSHMARK */
8231 if (o2->op_type == OP_GV) {
8232 op_null(o2); /* GV */
8235 op_null(o2); /* RV2AV or PADAV */
8236 o2 = o2->op_next->op_next;
8237 op_null(o2); /* AASSIGN */
8239 o->op_next = o2->op_next;
8245 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8247 LISTOP *enter, *exlist;
8249 enter = (LISTOP *) o->op_next;
8252 if (enter->op_type == OP_NULL) {
8253 enter = (LISTOP *) enter->op_next;
8257 /* for $a (...) will have OP_GV then OP_RV2GV here.
8258 for (...) just has an OP_GV. */
8259 if (enter->op_type == OP_GV) {
8260 gvop = (OP *) enter;
8261 enter = (LISTOP *) enter->op_next;
8264 if (enter->op_type == OP_RV2GV) {
8265 enter = (LISTOP *) enter->op_next;
8271 if (enter->op_type != OP_ENTERITER)
8274 iter = enter->op_next;
8275 if (!iter || iter->op_type != OP_ITER)
8278 expushmark = enter->op_first;
8279 if (!expushmark || expushmark->op_type != OP_NULL
8280 || expushmark->op_targ != OP_PUSHMARK)
8283 exlist = (LISTOP *) expushmark->op_sibling;
8284 if (!exlist || exlist->op_type != OP_NULL
8285 || exlist->op_targ != OP_LIST)
8288 if (exlist->op_last != o) {
8289 /* Mmm. Was expecting to point back to this op. */
8292 theirmark = exlist->op_first;
8293 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8296 if (theirmark->op_sibling != o) {
8297 /* There's something between the mark and the reverse, eg
8298 for (1, reverse (...))
8303 ourmark = ((LISTOP *)o)->op_first;
8304 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8307 ourlast = ((LISTOP *)o)->op_last;
8308 if (!ourlast || ourlast->op_next != o)
8311 rv2av = ourmark->op_sibling;
8312 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8313 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8314 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8315 /* We're just reversing a single array. */
8316 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8317 enter->op_flags |= OPf_STACKED;
8320 /* We don't have control over who points to theirmark, so sacrifice
8322 theirmark->op_next = ourmark->op_next;
8323 theirmark->op_flags = ourmark->op_flags;
8324 ourlast->op_next = gvop ? gvop : (OP *) enter;
8327 enter->op_private |= OPpITER_REVERSED;
8328 iter->op_private |= OPpITER_REVERSED;
8335 UNOP *refgen, *rv2cv;
8338 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8341 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8344 rv2gv = ((BINOP *)o)->op_last;
8345 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8348 refgen = (UNOP *)((BINOP *)o)->op_first;
8350 if (!refgen || refgen->op_type != OP_REFGEN)
8353 exlist = (LISTOP *)refgen->op_first;
8354 if (!exlist || exlist->op_type != OP_NULL
8355 || exlist->op_targ != OP_LIST)
8358 if (exlist->op_first->op_type != OP_PUSHMARK)
8361 rv2cv = (UNOP*)exlist->op_last;
8363 if (rv2cv->op_type != OP_RV2CV)
8366 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8367 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8368 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8370 o->op_private |= OPpASSIGN_CV_TO_GV;
8371 rv2gv->op_private |= OPpDONT_INIT_GV;
8372 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8380 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8381 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8391 Perl_custom_op_name(pTHX_ const OP* o)
8394 const IV index = PTR2IV(o->op_ppaddr);
8398 if (!PL_custom_op_names) /* This probably shouldn't happen */
8399 return (char *)PL_op_name[OP_CUSTOM];
8401 keysv = sv_2mortal(newSViv(index));
8403 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8405 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8407 return SvPV_nolen(HeVAL(he));
8411 Perl_custom_op_desc(pTHX_ const OP* o)
8414 const IV index = PTR2IV(o->op_ppaddr);
8418 if (!PL_custom_op_descs)
8419 return (char *)PL_op_desc[OP_CUSTOM];
8421 keysv = sv_2mortal(newSViv(index));
8423 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8425 return (char *)PL_op_desc[OP_CUSTOM];
8427 return SvPV_nolen(HeVAL(he));
8432 /* Efficient sub that returns a constant scalar value. */
8434 const_sv_xsub(pTHX_ CV* cv)
8441 Perl_croak(aTHX_ "usage: %s::%s()",
8442 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8446 ST(0) = (SV*)XSANY.any_ptr;
8452 * c-indentation-style: bsd
8454 * indent-tabs-mode: t
8457 * ex: set ts=8 sts=4 sw=4 noet: