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)
5104 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5105 o = cLISTOPo->op_first->op_sibling;
5107 for (; o; o = o->op_next) {
5108 const OPCODE type = o->op_type;
5110 if (sv && o->op_next == o)
5112 if (o->op_next != o) {
5113 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5115 if (type == OP_DBSTATE)
5118 if (type == OP_LEAVESUB || type == OP_RETURN)
5122 if (type == OP_CONST && cSVOPo->op_sv)
5124 else if (cv && type == OP_CONST) {
5125 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5129 else if (cv && type == OP_PADSV) {
5130 if (CvCONST(cv)) { /* newly cloned anon */
5131 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5132 /* the candidate should have 1 ref from this pad and 1 ref
5133 * from the parent */
5134 if (!sv || SvREFCNT(sv) != 2)
5141 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5142 sv = &PL_sv_undef; /* an arbitrary non-null value */
5157 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5160 /* This would be the return value, but the return cannot be reached. */
5161 OP* pegop = newOP(OP_NULL, 0);
5164 PERL_UNUSED_ARG(floor);
5174 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5176 NORETURN_FUNCTION_END;
5181 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5183 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5187 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5194 register CV *cv = NULL;
5196 /* If the subroutine has no body, no attributes, and no builtin attributes
5197 then it's just a sub declaration, and we may be able to get away with
5198 storing with a placeholder scalar in the symbol table, rather than a
5199 full GV and CV. If anything is present then it will take a full CV to
5201 const I32 gv_fetch_flags
5202 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5204 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5205 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5208 assert(proto->op_type == OP_CONST);
5209 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5214 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5215 SV * const sv = sv_newmortal();
5216 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5217 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5218 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5219 aname = SvPVX_const(sv);
5224 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5225 : gv_fetchpv(aname ? aname
5226 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5227 gv_fetch_flags, SVt_PVCV);
5229 if (!PL_madskills) {
5238 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5239 maximum a prototype before. */
5240 if (SvTYPE(gv) > SVt_NULL) {
5241 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5242 && ckWARN_d(WARN_PROTOTYPE))
5244 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5246 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5249 sv_setpvn((SV*)gv, ps, ps_len);
5251 sv_setiv((SV*)gv, -1);
5253 SvREFCNT_dec(PL_compcv);
5254 cv = PL_compcv = NULL;
5258 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5260 #ifdef GV_UNIQUE_CHECK
5261 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5262 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5266 if (!block || !ps || *ps || attrs
5267 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5269 || block->op_type == OP_NULL
5274 const_sv = op_const_sv(block, NULL);
5277 const bool exists = CvROOT(cv) || CvXSUB(cv);
5279 #ifdef GV_UNIQUE_CHECK
5280 if (exists && GvUNIQUE(gv)) {
5281 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5285 /* if the subroutine doesn't exist and wasn't pre-declared
5286 * with a prototype, assume it will be AUTOLOADed,
5287 * skipping the prototype check
5289 if (exists || SvPOK(cv))
5290 cv_ckproto_len(cv, gv, ps, ps_len);
5291 /* already defined (or promised)? */
5292 if (exists || GvASSUMECV(gv)) {
5295 || block->op_type == OP_NULL
5298 if (CvFLAGS(PL_compcv)) {
5299 /* might have had built-in attrs applied */
5300 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5302 /* just a "sub foo;" when &foo is already defined */
5303 SAVEFREESV(PL_compcv);
5308 && block->op_type != OP_NULL
5311 if (ckWARN(WARN_REDEFINE)
5313 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5315 const line_t oldline = CopLINE(PL_curcop);
5316 if (PL_parser && PL_parser->copline != NOLINE)
5317 CopLINE_set(PL_curcop, PL_parser->copline);
5318 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5319 CvCONST(cv) ? "Constant subroutine %s redefined"
5320 : "Subroutine %s redefined", name);
5321 CopLINE_set(PL_curcop, oldline);
5324 if (!PL_minus_c) /* keep old one around for madskills */
5327 /* (PL_madskills unset in used file.) */
5335 SvREFCNT_inc_simple_void_NN(const_sv);
5337 assert(!CvROOT(cv) && !CvCONST(cv));
5338 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5339 CvXSUBANY(cv).any_ptr = const_sv;
5340 CvXSUB(cv) = const_sv_xsub;
5346 cv = newCONSTSUB(NULL, name, const_sv);
5348 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5349 (CvGV(cv) && GvSTASH(CvGV(cv)))
5358 SvREFCNT_dec(PL_compcv);
5366 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5367 * before we clobber PL_compcv.
5371 || block->op_type == OP_NULL
5375 /* Might have had built-in attributes applied -- propagate them. */
5376 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5377 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5378 stash = GvSTASH(CvGV(cv));
5379 else if (CvSTASH(cv))
5380 stash = CvSTASH(cv);
5382 stash = PL_curstash;
5385 /* possibly about to re-define existing subr -- ignore old cv */
5386 rcv = (SV*)PL_compcv;
5387 if (name && GvSTASH(gv))
5388 stash = GvSTASH(gv);
5390 stash = PL_curstash;
5392 apply_attrs(stash, rcv, attrs, FALSE);
5394 if (cv) { /* must reuse cv if autoloaded */
5401 || block->op_type == OP_NULL) && !PL_madskills
5404 /* got here with just attrs -- work done, so bug out */
5405 SAVEFREESV(PL_compcv);
5408 /* transfer PL_compcv to cv */
5410 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5411 if (!CvWEAKOUTSIDE(cv))
5412 SvREFCNT_dec(CvOUTSIDE(cv));
5413 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5414 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5415 CvOUTSIDE(PL_compcv) = 0;
5416 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5417 CvPADLIST(PL_compcv) = 0;
5418 /* inner references to PL_compcv must be fixed up ... */
5419 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5420 /* ... before we throw it away */
5421 SvREFCNT_dec(PL_compcv);
5423 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5424 ++PL_sub_generation;
5431 if (strEQ(name, "import")) {
5432 PL_formfeed = (SV*)cv;
5433 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5437 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5441 CvFILE_set_from_cop(cv, PL_curcop);
5442 CvSTASH(cv) = PL_curstash;
5445 sv_setpvn((SV*)cv, ps, ps_len);
5447 if (PL_parser && PL_parser->error_count) {
5451 const char *s = strrchr(name, ':');
5453 if (strEQ(s, "BEGIN")) {
5454 const char not_safe[] =
5455 "BEGIN not safe after errors--compilation aborted";
5456 if (PL_in_eval & EVAL_KEEPERR)
5457 Perl_croak(aTHX_ not_safe);
5459 /* force display of errors found but not reported */
5460 sv_catpv(ERRSV, not_safe);
5461 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5471 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5472 mod(scalarseq(block), OP_LEAVESUBLV));
5473 block->op_attached = 1;
5476 /* This makes sub {}; work as expected. */
5477 if (block->op_type == OP_STUB) {
5478 OP* const newblock = newSTATEOP(0, NULL, 0);
5480 op_getmad(block,newblock,'B');
5487 block->op_attached = 1;
5488 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5490 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5491 OpREFCNT_set(CvROOT(cv), 1);
5492 CvSTART(cv) = LINKLIST(CvROOT(cv));
5493 CvROOT(cv)->op_next = 0;
5494 CALL_PEEP(CvSTART(cv));
5496 /* now that optimizer has done its work, adjust pad values */
5498 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5501 assert(!CvCONST(cv));
5502 if (ps && !*ps && op_const_sv(block, cv))
5506 if (name || aname) {
5507 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5508 SV * const sv = newSV(0);
5509 SV * const tmpstr = sv_newmortal();
5510 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5511 GV_ADDMULTI, SVt_PVHV);
5514 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5516 (long)PL_subline, (long)CopLINE(PL_curcop));
5517 gv_efullname3(tmpstr, gv, NULL);
5518 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5519 hv = GvHVn(db_postponed);
5520 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5521 CV * const pcv = GvCV(db_postponed);
5527 call_sv((SV*)pcv, G_DISCARD);
5532 if (name && ! (PL_parser && PL_parser->error_count))
5533 process_special_blocks(name, gv, cv);
5538 PL_parser->copline = NOLINE;
5544 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5547 const char *const colon = strrchr(fullname,':');
5548 const char *const name = colon ? colon + 1 : fullname;
5551 if (strEQ(name, "BEGIN")) {
5552 const I32 oldscope = PL_scopestack_ix;
5554 SAVECOPFILE(&PL_compiling);
5555 SAVECOPLINE(&PL_compiling);
5557 DEBUG_x( dump_sub(gv) );
5558 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5559 GvCV(gv) = 0; /* cv has been hijacked */
5560 call_list(oldscope, PL_beginav);
5562 PL_curcop = &PL_compiling;
5563 CopHINTS_set(&PL_compiling, PL_hints);
5570 if strEQ(name, "END") {
5571 DEBUG_x( dump_sub(gv) );
5572 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5575 } else if (*name == 'U') {
5576 if (strEQ(name, "UNITCHECK")) {
5577 /* It's never too late to run a unitcheck block */
5578 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5582 } else if (*name == 'C') {
5583 if (strEQ(name, "CHECK")) {
5584 if (PL_main_start && ckWARN(WARN_VOID))
5585 Perl_warner(aTHX_ packWARN(WARN_VOID),
5586 "Too late to run CHECK block");
5587 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5591 } else if (*name == 'I') {
5592 if (strEQ(name, "INIT")) {
5593 if (PL_main_start && ckWARN(WARN_VOID))
5594 Perl_warner(aTHX_ packWARN(WARN_VOID),
5595 "Too late to run INIT block");
5596 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5602 DEBUG_x( dump_sub(gv) );
5603 GvCV(gv) = 0; /* cv has been hijacked */
5608 =for apidoc newCONSTSUB
5610 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5611 eligible for inlining at compile-time.
5617 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5622 const char *const temp_p = CopFILE(PL_curcop);
5623 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5625 SV *const temp_sv = CopFILESV(PL_curcop);
5627 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5629 char *const file = savepvn(temp_p, temp_p ? len : 0);
5633 SAVECOPLINE(PL_curcop);
5634 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5637 PL_hints &= ~HINT_BLOCK_SCOPE;
5640 SAVESPTR(PL_curstash);
5641 SAVECOPSTASH(PL_curcop);
5642 PL_curstash = stash;
5643 CopSTASH_set(PL_curcop,stash);
5646 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5647 and so doesn't get free()d. (It's expected to be from the C pre-
5648 processor __FILE__ directive). But we need a dynamically allocated one,
5649 and we need it to get freed. */
5650 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5651 CvXSUBANY(cv).any_ptr = sv;
5657 CopSTASH_free(PL_curcop);
5665 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5666 const char *const filename, const char *const proto,
5669 CV *cv = newXS(name, subaddr, filename);
5671 if (flags & XS_DYNAMIC_FILENAME) {
5672 /* We need to "make arrangements" (ie cheat) to ensure that the
5673 filename lasts as long as the PVCV we just created, but also doesn't
5675 STRLEN filename_len = strlen(filename);
5676 STRLEN proto_and_file_len = filename_len;
5677 char *proto_and_file;
5681 proto_len = strlen(proto);
5682 proto_and_file_len += proto_len;
5684 Newx(proto_and_file, proto_and_file_len + 1, char);
5685 Copy(proto, proto_and_file, proto_len, char);
5686 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5689 proto_and_file = savepvn(filename, filename_len);
5692 /* This gets free()d. :-) */
5693 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5694 SV_HAS_TRAILING_NUL);
5696 /* This gives us the correct prototype, rather than one with the
5697 file name appended. */
5698 SvCUR_set(cv, proto_len);
5702 CvFILE(cv) = proto_and_file + proto_len;
5704 sv_setpv((SV *)cv, proto);
5710 =for apidoc U||newXS
5712 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5713 static storage, as it is used directly as CvFILE(), without a copy being made.
5719 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5722 GV * const gv = gv_fetchpv(name ? name :
5723 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5724 GV_ADDMULTI, SVt_PVCV);
5728 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5730 if ((cv = (name ? GvCV(gv) : NULL))) {
5732 /* just a cached method */
5736 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5737 /* already defined (or promised) */
5738 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5739 if (ckWARN(WARN_REDEFINE)) {
5740 GV * const gvcv = CvGV(cv);
5742 HV * const stash = GvSTASH(gvcv);
5744 const char *redefined_name = HvNAME_get(stash);
5745 if ( strEQ(redefined_name,"autouse") ) {
5746 const line_t oldline = CopLINE(PL_curcop);
5747 if (PL_parser && PL_parser->copline != NOLINE)
5748 CopLINE_set(PL_curcop, PL_parser->copline);
5749 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5750 CvCONST(cv) ? "Constant subroutine %s redefined"
5751 : "Subroutine %s redefined"
5753 CopLINE_set(PL_curcop, oldline);
5763 if (cv) /* must reuse cv if autoloaded */
5766 cv = (CV*)newSV_type(SVt_PVCV);
5770 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5774 (void)gv_fetchfile(filename);
5775 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5776 an external constant string */
5778 CvXSUB(cv) = subaddr;
5781 process_special_blocks(name, gv, cv);
5793 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5798 OP* pegop = newOP(OP_NULL, 0);
5802 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5803 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5805 #ifdef GV_UNIQUE_CHECK
5807 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5811 if ((cv = GvFORM(gv))) {
5812 if (ckWARN(WARN_REDEFINE)) {
5813 const line_t oldline = CopLINE(PL_curcop);
5814 if (PL_parser && PL_parser->copline != NOLINE)
5815 CopLINE_set(PL_curcop, PL_parser->copline);
5816 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5817 o ? "Format %"SVf" redefined"
5818 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5819 CopLINE_set(PL_curcop, oldline);
5826 CvFILE_set_from_cop(cv, PL_curcop);
5829 pad_tidy(padtidy_FORMAT);
5830 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5831 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5832 OpREFCNT_set(CvROOT(cv), 1);
5833 CvSTART(cv) = LINKLIST(CvROOT(cv));
5834 CvROOT(cv)->op_next = 0;
5835 CALL_PEEP(CvSTART(cv));
5837 op_getmad(o,pegop,'n');
5838 op_getmad_weak(block, pegop, 'b');
5843 PL_parser->copline = NOLINE;
5851 Perl_newANONLIST(pTHX_ OP *o)
5853 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5857 Perl_newANONHASH(pTHX_ OP *o)
5859 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5863 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5865 return newANONATTRSUB(floor, proto, NULL, block);
5869 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5871 return newUNOP(OP_REFGEN, 0,
5872 newSVOP(OP_ANONCODE, 0,
5873 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5877 Perl_oopsAV(pTHX_ OP *o)
5880 switch (o->op_type) {
5882 o->op_type = OP_PADAV;
5883 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5884 return ref(o, OP_RV2AV);
5887 o->op_type = OP_RV2AV;
5888 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5893 if (ckWARN_d(WARN_INTERNAL))
5894 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5901 Perl_oopsHV(pTHX_ OP *o)
5904 switch (o->op_type) {
5907 o->op_type = OP_PADHV;
5908 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5909 return ref(o, OP_RV2HV);
5913 o->op_type = OP_RV2HV;
5914 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5919 if (ckWARN_d(WARN_INTERNAL))
5920 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5927 Perl_newAVREF(pTHX_ OP *o)
5930 if (o->op_type == OP_PADANY) {
5931 o->op_type = OP_PADAV;
5932 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5935 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5936 && ckWARN(WARN_DEPRECATED)) {
5937 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5938 "Using an array as a reference is deprecated");
5940 return newUNOP(OP_RV2AV, 0, scalar(o));
5944 Perl_newGVREF(pTHX_ I32 type, OP *o)
5946 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5947 return newUNOP(OP_NULL, 0, o);
5948 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5952 Perl_newHVREF(pTHX_ OP *o)
5955 if (o->op_type == OP_PADANY) {
5956 o->op_type = OP_PADHV;
5957 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5960 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5961 && ckWARN(WARN_DEPRECATED)) {
5962 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5963 "Using a hash as a reference is deprecated");
5965 return newUNOP(OP_RV2HV, 0, scalar(o));
5969 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5971 return newUNOP(OP_RV2CV, flags, scalar(o));
5975 Perl_newSVREF(pTHX_ OP *o)
5978 if (o->op_type == OP_PADANY) {
5979 o->op_type = OP_PADSV;
5980 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5983 return newUNOP(OP_RV2SV, 0, scalar(o));
5986 /* Check routines. See the comments at the top of this file for details
5987 * on when these are called */
5990 Perl_ck_anoncode(pTHX_ OP *o)
5992 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5994 cSVOPo->op_sv = NULL;
5999 Perl_ck_bitop(pTHX_ OP *o)
6002 #define OP_IS_NUMCOMPARE(op) \
6003 ((op) == OP_LT || (op) == OP_I_LT || \
6004 (op) == OP_GT || (op) == OP_I_GT || \
6005 (op) == OP_LE || (op) == OP_I_LE || \
6006 (op) == OP_GE || (op) == OP_I_GE || \
6007 (op) == OP_EQ || (op) == OP_I_EQ || \
6008 (op) == OP_NE || (op) == OP_I_NE || \
6009 (op) == OP_NCMP || (op) == OP_I_NCMP)
6010 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6011 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6012 && (o->op_type == OP_BIT_OR
6013 || o->op_type == OP_BIT_AND
6014 || o->op_type == OP_BIT_XOR))
6016 const OP * const left = cBINOPo->op_first;
6017 const OP * const right = left->op_sibling;
6018 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6019 (left->op_flags & OPf_PARENS) == 0) ||
6020 (OP_IS_NUMCOMPARE(right->op_type) &&
6021 (right->op_flags & OPf_PARENS) == 0))
6022 if (ckWARN(WARN_PRECEDENCE))
6023 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6024 "Possible precedence problem on bitwise %c operator",
6025 o->op_type == OP_BIT_OR ? '|'
6026 : o->op_type == OP_BIT_AND ? '&' : '^'
6033 Perl_ck_concat(pTHX_ OP *o)
6035 const OP * const kid = cUNOPo->op_first;
6036 PERL_UNUSED_CONTEXT;
6037 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6038 !(kUNOP->op_first->op_flags & OPf_MOD))
6039 o->op_flags |= OPf_STACKED;
6044 Perl_ck_spair(pTHX_ OP *o)
6047 if (o->op_flags & OPf_KIDS) {
6050 const OPCODE type = o->op_type;
6051 o = modkids(ck_fun(o), type);
6052 kid = cUNOPo->op_first;
6053 newop = kUNOP->op_first->op_sibling;
6055 const OPCODE type = newop->op_type;
6056 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6057 type == OP_PADAV || type == OP_PADHV ||
6058 type == OP_RV2AV || type == OP_RV2HV)
6062 op_getmad(kUNOP->op_first,newop,'K');
6064 op_free(kUNOP->op_first);
6066 kUNOP->op_first = newop;
6068 o->op_ppaddr = PL_ppaddr[++o->op_type];
6073 Perl_ck_delete(pTHX_ OP *o)
6077 if (o->op_flags & OPf_KIDS) {
6078 OP * const kid = cUNOPo->op_first;
6079 switch (kid->op_type) {
6081 o->op_flags |= OPf_SPECIAL;
6084 o->op_private |= OPpSLICE;
6087 o->op_flags |= OPf_SPECIAL;
6092 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6101 Perl_ck_die(pTHX_ OP *o)
6104 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6110 Perl_ck_eof(pTHX_ OP *o)
6114 if (o->op_flags & OPf_KIDS) {
6115 if (cLISTOPo->op_first->op_type == OP_STUB) {
6117 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6119 op_getmad(o,newop,'O');
6131 Perl_ck_eval(pTHX_ OP *o)
6134 PL_hints |= HINT_BLOCK_SCOPE;
6135 if (o->op_flags & OPf_KIDS) {
6136 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6139 o->op_flags &= ~OPf_KIDS;
6142 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6148 cUNOPo->op_first = 0;
6153 NewOp(1101, enter, 1, LOGOP);
6154 enter->op_type = OP_ENTERTRY;
6155 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6156 enter->op_private = 0;
6158 /* establish postfix order */
6159 enter->op_next = (OP*)enter;
6161 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6162 o->op_type = OP_LEAVETRY;
6163 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6164 enter->op_other = o;
6165 op_getmad(oldo,o,'O');
6179 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6180 op_getmad(oldo,o,'O');
6182 o->op_targ = (PADOFFSET)PL_hints;
6183 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6184 /* Store a copy of %^H that pp_entereval can pick up.
6185 OPf_SPECIAL flags the opcode as being for this purpose,
6186 so that it in turn will return a copy at every
6188 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6189 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6190 cUNOPo->op_first->op_sibling = hhop;
6191 o->op_private |= OPpEVAL_HAS_HH;
6197 Perl_ck_exit(pTHX_ OP *o)
6200 HV * const table = GvHV(PL_hintgv);
6202 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6203 if (svp && *svp && SvTRUE(*svp))
6204 o->op_private |= OPpEXIT_VMSISH;
6206 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6212 Perl_ck_exec(pTHX_ OP *o)
6214 if (o->op_flags & OPf_STACKED) {
6217 kid = cUNOPo->op_first->op_sibling;
6218 if (kid->op_type == OP_RV2GV)
6227 Perl_ck_exists(pTHX_ OP *o)
6231 if (o->op_flags & OPf_KIDS) {
6232 OP * const kid = cUNOPo->op_first;
6233 if (kid->op_type == OP_ENTERSUB) {
6234 (void) ref(kid, o->op_type);
6235 if (kid->op_type != OP_RV2CV
6236 && !(PL_parser && PL_parser->error_count))
6237 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6239 o->op_private |= OPpEXISTS_SUB;
6241 else if (kid->op_type == OP_AELEM)
6242 o->op_flags |= OPf_SPECIAL;
6243 else if (kid->op_type != OP_HELEM)
6244 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6252 Perl_ck_rvconst(pTHX_ register OP *o)
6255 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6257 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6258 if (o->op_type == OP_RV2CV)
6259 o->op_private &= ~1;
6261 if (kid->op_type == OP_CONST) {
6264 SV * const kidsv = kid->op_sv;
6266 /* Is it a constant from cv_const_sv()? */
6267 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6268 SV * const rsv = SvRV(kidsv);
6269 const svtype type = SvTYPE(rsv);
6270 const char *badtype = NULL;
6272 switch (o->op_type) {
6274 if (type > SVt_PVMG)
6275 badtype = "a SCALAR";
6278 if (type != SVt_PVAV)
6279 badtype = "an ARRAY";
6282 if (type != SVt_PVHV)
6286 if (type != SVt_PVCV)
6291 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6294 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6295 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6296 /* If this is an access to a stash, disable "strict refs", because
6297 * stashes aren't auto-vivified at compile-time (unless we store
6298 * symbols in them), and we don't want to produce a run-time
6299 * stricture error when auto-vivifying the stash. */
6300 const char *s = SvPV_nolen(kidsv);
6301 const STRLEN l = SvCUR(kidsv);
6302 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6303 o->op_private &= ~HINT_STRICT_REFS;
6305 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6306 const char *badthing;
6307 switch (o->op_type) {
6309 badthing = "a SCALAR";
6312 badthing = "an ARRAY";
6315 badthing = "a HASH";
6323 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6324 SVfARG(kidsv), badthing);
6327 * This is a little tricky. We only want to add the symbol if we
6328 * didn't add it in the lexer. Otherwise we get duplicate strict
6329 * warnings. But if we didn't add it in the lexer, we must at
6330 * least pretend like we wanted to add it even if it existed before,
6331 * or we get possible typo warnings. OPpCONST_ENTERED says
6332 * whether the lexer already added THIS instance of this symbol.
6334 iscv = (o->op_type == OP_RV2CV) * 2;
6336 gv = gv_fetchsv(kidsv,
6337 iscv | !(kid->op_private & OPpCONST_ENTERED),
6340 : o->op_type == OP_RV2SV
6342 : o->op_type == OP_RV2AV
6344 : o->op_type == OP_RV2HV
6347 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6349 kid->op_type = OP_GV;
6350 SvREFCNT_dec(kid->op_sv);
6352 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6353 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6354 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6356 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6358 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6360 kid->op_private = 0;
6361 kid->op_ppaddr = PL_ppaddr[OP_GV];
6368 Perl_ck_ftst(pTHX_ OP *o)
6371 const I32 type = o->op_type;
6373 if (o->op_flags & OPf_REF) {
6376 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6377 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6378 const OPCODE kidtype = kid->op_type;
6380 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6381 OP * const newop = newGVOP(type, OPf_REF,
6382 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6384 op_getmad(o,newop,'O');
6390 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6391 o->op_private |= OPpFT_ACCESS;
6392 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6393 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6394 o->op_private |= OPpFT_STACKED;
6402 if (type == OP_FTTTY)
6403 o = newGVOP(type, OPf_REF, PL_stdingv);
6405 o = newUNOP(type, 0, newDEFSVOP());
6406 op_getmad(oldo,o,'O');
6412 Perl_ck_fun(pTHX_ OP *o)
6415 const int type = o->op_type;
6416 register I32 oa = PL_opargs[type] >> OASHIFT;
6418 if (o->op_flags & OPf_STACKED) {
6419 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6422 return no_fh_allowed(o);
6425 if (o->op_flags & OPf_KIDS) {
6426 OP **tokid = &cLISTOPo->op_first;
6427 register OP *kid = cLISTOPo->op_first;
6431 if (kid->op_type == OP_PUSHMARK ||
6432 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6434 tokid = &kid->op_sibling;
6435 kid = kid->op_sibling;
6437 if (!kid && PL_opargs[type] & OA_DEFGV)
6438 *tokid = kid = newDEFSVOP();
6442 sibl = kid->op_sibling;
6444 if (!sibl && kid->op_type == OP_STUB) {
6451 /* list seen where single (scalar) arg expected? */
6452 if (numargs == 1 && !(oa >> 4)
6453 && kid->op_type == OP_LIST && type != OP_SCALAR)
6455 return too_many_arguments(o,PL_op_desc[type]);
6468 if ((type == OP_PUSH || type == OP_UNSHIFT)
6469 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6470 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6471 "Useless use of %s with no values",
6474 if (kid->op_type == OP_CONST &&
6475 (kid->op_private & OPpCONST_BARE))
6477 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6478 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6479 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6480 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6481 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6482 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6484 op_getmad(kid,newop,'K');
6489 kid->op_sibling = sibl;
6492 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6493 bad_type(numargs, "array", PL_op_desc[type], kid);
6497 if (kid->op_type == OP_CONST &&
6498 (kid->op_private & OPpCONST_BARE))
6500 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6501 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6502 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6503 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6504 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6505 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6507 op_getmad(kid,newop,'K');
6512 kid->op_sibling = sibl;
6515 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6516 bad_type(numargs, "hash", PL_op_desc[type], kid);
6521 OP * const newop = newUNOP(OP_NULL, 0, kid);
6522 kid->op_sibling = 0;
6524 newop->op_next = newop;
6526 kid->op_sibling = sibl;
6531 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6532 if (kid->op_type == OP_CONST &&
6533 (kid->op_private & OPpCONST_BARE))
6535 OP * const newop = newGVOP(OP_GV, 0,
6536 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6537 if (!(o->op_private & 1) && /* if not unop */
6538 kid == cLISTOPo->op_last)
6539 cLISTOPo->op_last = newop;
6541 op_getmad(kid,newop,'K');
6547 else if (kid->op_type == OP_READLINE) {
6548 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6549 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6552 I32 flags = OPf_SPECIAL;
6556 /* is this op a FH constructor? */
6557 if (is_handle_constructor(o,numargs)) {
6558 const char *name = NULL;
6562 /* Set a flag to tell rv2gv to vivify
6563 * need to "prove" flag does not mean something
6564 * else already - NI-S 1999/05/07
6567 if (kid->op_type == OP_PADSV) {
6569 = PAD_COMPNAME_SV(kid->op_targ);
6570 name = SvPV_const(namesv, len);
6572 else if (kid->op_type == OP_RV2SV
6573 && kUNOP->op_first->op_type == OP_GV)
6575 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6577 len = GvNAMELEN(gv);
6579 else if (kid->op_type == OP_AELEM
6580 || kid->op_type == OP_HELEM)
6583 OP *op = ((BINOP*)kid)->op_first;
6587 const char * const a =
6588 kid->op_type == OP_AELEM ?
6590 if (((op->op_type == OP_RV2AV) ||
6591 (op->op_type == OP_RV2HV)) &&
6592 (firstop = ((UNOP*)op)->op_first) &&
6593 (firstop->op_type == OP_GV)) {
6594 /* packagevar $a[] or $h{} */
6595 GV * const gv = cGVOPx_gv(firstop);
6603 else if (op->op_type == OP_PADAV
6604 || op->op_type == OP_PADHV) {
6605 /* lexicalvar $a[] or $h{} */
6606 const char * const padname =
6607 PAD_COMPNAME_PV(op->op_targ);
6616 name = SvPV_const(tmpstr, len);
6621 name = "__ANONIO__";
6628 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6629 namesv = PAD_SVl(targ);
6630 SvUPGRADE(namesv, SVt_PV);
6632 sv_setpvn(namesv, "$", 1);
6633 sv_catpvn(namesv, name, len);
6636 kid->op_sibling = 0;
6637 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6638 kid->op_targ = targ;
6639 kid->op_private |= priv;
6641 kid->op_sibling = sibl;
6647 mod(scalar(kid), type);
6651 tokid = &kid->op_sibling;
6652 kid = kid->op_sibling;
6655 if (kid && kid->op_type != OP_STUB)
6656 return too_many_arguments(o,OP_DESC(o));
6657 o->op_private |= numargs;
6659 /* FIXME - should the numargs move as for the PERL_MAD case? */
6660 o->op_private |= numargs;
6662 return too_many_arguments(o,OP_DESC(o));
6666 else if (PL_opargs[type] & OA_DEFGV) {
6668 OP *newop = newUNOP(type, 0, newDEFSVOP());
6669 op_getmad(o,newop,'O');
6672 /* Ordering of these two is important to keep f_map.t passing. */
6674 return newUNOP(type, 0, newDEFSVOP());
6679 while (oa & OA_OPTIONAL)
6681 if (oa && oa != OA_LIST)
6682 return too_few_arguments(o,OP_DESC(o));
6688 Perl_ck_glob(pTHX_ OP *o)
6694 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6695 append_elem(OP_GLOB, o, newDEFSVOP());
6697 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6698 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6700 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6703 #if !defined(PERL_EXTERNAL_GLOB)
6704 /* XXX this can be tightened up and made more failsafe. */
6705 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6708 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6709 newSVpvs("File::Glob"), NULL, NULL, NULL);
6710 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6711 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6712 GvCV(gv) = GvCV(glob_gv);
6713 SvREFCNT_inc_void((SV*)GvCV(gv));
6714 GvIMPORTED_CV_on(gv);
6717 #endif /* PERL_EXTERNAL_GLOB */
6719 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6720 append_elem(OP_GLOB, o,
6721 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6722 o->op_type = OP_LIST;
6723 o->op_ppaddr = PL_ppaddr[OP_LIST];
6724 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6725 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6726 cLISTOPo->op_first->op_targ = 0;
6727 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6728 append_elem(OP_LIST, o,
6729 scalar(newUNOP(OP_RV2CV, 0,
6730 newGVOP(OP_GV, 0, gv)))));
6731 o = newUNOP(OP_NULL, 0, ck_subr(o));
6732 o->op_targ = OP_GLOB; /* hint at what it used to be */
6735 gv = newGVgen("main");
6737 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6743 Perl_ck_grep(pTHX_ OP *o)
6748 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6751 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6752 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
6754 if (o->op_flags & OPf_STACKED) {
6757 kid = cLISTOPo->op_first->op_sibling;
6758 if (!cUNOPx(kid)->op_next)
6759 Perl_croak(aTHX_ "panic: ck_grep");
6760 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6763 NewOp(1101, gwop, 1, LOGOP);
6764 kid->op_next = (OP*)gwop;
6765 o->op_flags &= ~OPf_STACKED;
6767 kid = cLISTOPo->op_first->op_sibling;
6768 if (type == OP_MAPWHILE)
6773 if (PL_parser && PL_parser->error_count)
6775 kid = cLISTOPo->op_first->op_sibling;
6776 if (kid->op_type != OP_NULL)
6777 Perl_croak(aTHX_ "panic: ck_grep");
6778 kid = kUNOP->op_first;
6781 NewOp(1101, gwop, 1, LOGOP);
6782 gwop->op_type = type;
6783 gwop->op_ppaddr = PL_ppaddr[type];
6784 gwop->op_first = listkids(o);
6785 gwop->op_flags |= OPf_KIDS;
6786 gwop->op_other = LINKLIST(kid);
6787 kid->op_next = (OP*)gwop;
6788 offset = pad_findmy("$_");
6789 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6790 o->op_private = gwop->op_private = 0;
6791 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6794 o->op_private = gwop->op_private = OPpGREP_LEX;
6795 gwop->op_targ = o->op_targ = offset;
6798 kid = cLISTOPo->op_first->op_sibling;
6799 if (!kid || !kid->op_sibling)
6800 return too_few_arguments(o,OP_DESC(o));
6801 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6802 mod(kid, OP_GREPSTART);
6808 Perl_ck_index(pTHX_ OP *o)
6810 if (o->op_flags & OPf_KIDS) {
6811 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6813 kid = kid->op_sibling; /* get past "big" */
6814 if (kid && kid->op_type == OP_CONST)
6815 fbm_compile(((SVOP*)kid)->op_sv, 0);
6821 Perl_ck_lengthconst(pTHX_ OP *o)
6823 /* XXX length optimization goes here */
6828 Perl_ck_lfun(pTHX_ OP *o)
6830 const OPCODE type = o->op_type;
6831 return modkids(ck_fun(o), type);
6835 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6837 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6838 switch (cUNOPo->op_first->op_type) {
6840 /* This is needed for
6841 if (defined %stash::)
6842 to work. Do not break Tk.
6844 break; /* Globals via GV can be undef */
6846 case OP_AASSIGN: /* Is this a good idea? */
6847 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6848 "defined(@array) is deprecated");
6849 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6850 "\t(Maybe you should just omit the defined()?)\n");
6853 /* This is needed for
6854 if (defined %stash::)
6855 to work. Do not break Tk.
6857 break; /* Globals via GV can be undef */
6859 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6860 "defined(%%hash) is deprecated");
6861 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6862 "\t(Maybe you should just omit the defined()?)\n");
6873 Perl_ck_readline(pTHX_ OP *o)
6875 if (!(o->op_flags & OPf_KIDS)) {
6877 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6879 op_getmad(o,newop,'O');
6889 Perl_ck_rfun(pTHX_ OP *o)
6891 const OPCODE type = o->op_type;
6892 return refkids(ck_fun(o), type);
6896 Perl_ck_listiob(pTHX_ OP *o)
6900 kid = cLISTOPo->op_first;
6903 kid = cLISTOPo->op_first;
6905 if (kid->op_type == OP_PUSHMARK)
6906 kid = kid->op_sibling;
6907 if (kid && o->op_flags & OPf_STACKED)
6908 kid = kid->op_sibling;
6909 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6910 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6911 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6912 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6913 cLISTOPo->op_first->op_sibling = kid;
6914 cLISTOPo->op_last = kid;
6915 kid = kid->op_sibling;
6920 append_elem(o->op_type, o, newDEFSVOP());
6926 Perl_ck_smartmatch(pTHX_ OP *o)
6929 if (0 == (o->op_flags & OPf_SPECIAL)) {
6930 OP *first = cBINOPo->op_first;
6931 OP *second = first->op_sibling;
6933 /* Implicitly take a reference to an array or hash */
6934 first->op_sibling = NULL;
6935 first = cBINOPo->op_first = ref_array_or_hash(first);
6936 second = first->op_sibling = ref_array_or_hash(second);
6938 /* Implicitly take a reference to a regular expression */
6939 if (first->op_type == OP_MATCH) {
6940 first->op_type = OP_QR;
6941 first->op_ppaddr = PL_ppaddr[OP_QR];
6943 if (second->op_type == OP_MATCH) {
6944 second->op_type = OP_QR;
6945 second->op_ppaddr = PL_ppaddr[OP_QR];
6954 Perl_ck_sassign(pTHX_ OP *o)
6956 OP * const kid = cLISTOPo->op_first;
6957 /* has a disposable target? */
6958 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6959 && !(kid->op_flags & OPf_STACKED)
6960 /* Cannot steal the second time! */
6961 && !(kid->op_private & OPpTARGET_MY)
6962 /* Keep the full thing for madskills */
6966 OP * const kkid = kid->op_sibling;
6968 /* Can just relocate the target. */
6969 if (kkid && kkid->op_type == OP_PADSV
6970 && !(kkid->op_private & OPpLVAL_INTRO))
6972 kid->op_targ = kkid->op_targ;
6974 /* Now we do not need PADSV and SASSIGN. */
6975 kid->op_sibling = o->op_sibling; /* NULL */
6976 cLISTOPo->op_first = NULL;
6979 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6987 Perl_ck_match(pTHX_ OP *o)
6990 if (o->op_type != OP_QR && PL_compcv) {
6991 const PADOFFSET offset = pad_findmy("$_");
6992 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6993 o->op_targ = offset;
6994 o->op_private |= OPpTARGET_MY;
6997 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6998 o->op_private |= OPpRUNTIME;
7003 Perl_ck_method(pTHX_ OP *o)
7005 OP * const kid = cUNOPo->op_first;
7006 if (kid->op_type == OP_CONST) {
7007 SV* sv = kSVOP->op_sv;
7008 const char * const method = SvPVX_const(sv);
7009 if (!(strchr(method, ':') || strchr(method, '\''))) {
7011 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7012 sv = newSVpvn_share(method, SvCUR(sv), 0);
7015 kSVOP->op_sv = NULL;
7017 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7019 op_getmad(o,cmop,'O');
7030 Perl_ck_null(pTHX_ OP *o)
7032 PERL_UNUSED_CONTEXT;
7037 Perl_ck_open(pTHX_ OP *o)
7040 HV * const table = GvHV(PL_hintgv);
7042 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7044 const I32 mode = mode_from_discipline(*svp);
7045 if (mode & O_BINARY)
7046 o->op_private |= OPpOPEN_IN_RAW;
7047 else if (mode & O_TEXT)
7048 o->op_private |= OPpOPEN_IN_CRLF;
7051 svp = hv_fetchs(table, "open_OUT", FALSE);
7053 const I32 mode = mode_from_discipline(*svp);
7054 if (mode & O_BINARY)
7055 o->op_private |= OPpOPEN_OUT_RAW;
7056 else if (mode & O_TEXT)
7057 o->op_private |= OPpOPEN_OUT_CRLF;
7060 if (o->op_type == OP_BACKTICK) {
7061 if (!(o->op_flags & OPf_KIDS)) {
7062 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7064 op_getmad(o,newop,'O');
7073 /* In case of three-arg dup open remove strictness
7074 * from the last arg if it is a bareword. */
7075 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7076 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7080 if ((last->op_type == OP_CONST) && /* The bareword. */
7081 (last->op_private & OPpCONST_BARE) &&
7082 (last->op_private & OPpCONST_STRICT) &&
7083 (oa = first->op_sibling) && /* The fh. */
7084 (oa = oa->op_sibling) && /* The mode. */
7085 (oa->op_type == OP_CONST) &&
7086 SvPOK(((SVOP*)oa)->op_sv) &&
7087 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7088 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7089 (last == oa->op_sibling)) /* The bareword. */
7090 last->op_private &= ~OPpCONST_STRICT;
7096 Perl_ck_repeat(pTHX_ OP *o)
7098 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7099 o->op_private |= OPpREPEAT_DOLIST;
7100 cBINOPo->op_first = force_list(cBINOPo->op_first);
7108 Perl_ck_require(pTHX_ OP *o)
7113 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7114 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7116 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7117 SV * const sv = kid->op_sv;
7118 U32 was_readonly = SvREADONLY(sv);
7123 sv_force_normal_flags(sv, 0);
7124 assert(!SvREADONLY(sv));
7131 for (s = SvPVX(sv); *s; s++) {
7132 if (*s == ':' && s[1] == ':') {
7133 const STRLEN len = strlen(s+2)+1;
7135 Move(s+2, s+1, len, char);
7136 SvCUR_set(sv, SvCUR(sv) - 1);
7139 sv_catpvs(sv, ".pm");
7140 SvFLAGS(sv) |= was_readonly;
7144 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7145 /* handle override, if any */
7146 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7147 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7148 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7149 gv = gvp ? *gvp : NULL;
7153 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7154 OP * const kid = cUNOPo->op_first;
7157 cUNOPo->op_first = 0;
7161 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7162 append_elem(OP_LIST, kid,
7163 scalar(newUNOP(OP_RV2CV, 0,
7166 op_getmad(o,newop,'O');
7174 Perl_ck_return(pTHX_ OP *o)
7177 if (CvLVALUE(PL_compcv)) {
7179 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7180 mod(kid, OP_LEAVESUBLV);
7186 Perl_ck_select(pTHX_ OP *o)
7190 if (o->op_flags & OPf_KIDS) {
7191 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7192 if (kid && kid->op_sibling) {
7193 o->op_type = OP_SSELECT;
7194 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7196 return fold_constants(o);
7200 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7201 if (kid && kid->op_type == OP_RV2GV)
7202 kid->op_private &= ~HINT_STRICT_REFS;
7207 Perl_ck_shift(pTHX_ OP *o)
7210 const I32 type = o->op_type;
7212 if (!(o->op_flags & OPf_KIDS)) {
7214 /* FIXME - this can be refactored to reduce code in #ifdefs */
7216 OP * const oldo = o;
7220 argop = newUNOP(OP_RV2AV, 0,
7221 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7223 o = newUNOP(type, 0, scalar(argop));
7224 op_getmad(oldo,o,'O');
7227 return newUNOP(type, 0, scalar(argop));
7230 return scalar(modkids(ck_fun(o), type));
7234 Perl_ck_sort(pTHX_ OP *o)
7239 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7240 HV * const hinthv = GvHV(PL_hintgv);
7242 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7244 const I32 sorthints = (I32)SvIV(*svp);
7245 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7246 o->op_private |= OPpSORT_QSORT;
7247 if ((sorthints & HINT_SORT_STABLE) != 0)
7248 o->op_private |= OPpSORT_STABLE;
7253 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7255 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7256 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7258 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7260 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7262 if (kid->op_type == OP_SCOPE) {
7266 else if (kid->op_type == OP_LEAVE) {
7267 if (o->op_type == OP_SORT) {
7268 op_null(kid); /* wipe out leave */
7271 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7272 if (k->op_next == kid)
7274 /* don't descend into loops */
7275 else if (k->op_type == OP_ENTERLOOP
7276 || k->op_type == OP_ENTERITER)
7278 k = cLOOPx(k)->op_lastop;
7283 kid->op_next = 0; /* just disconnect the leave */
7284 k = kLISTOP->op_first;
7289 if (o->op_type == OP_SORT) {
7290 /* provide scalar context for comparison function/block */
7296 o->op_flags |= OPf_SPECIAL;
7298 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7301 firstkid = firstkid->op_sibling;
7304 /* provide list context for arguments */
7305 if (o->op_type == OP_SORT)
7312 S_simplify_sort(pTHX_ OP *o)
7315 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7320 if (!(o->op_flags & OPf_STACKED))
7322 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7323 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7324 kid = kUNOP->op_first; /* get past null */
7325 if (kid->op_type != OP_SCOPE)
7327 kid = kLISTOP->op_last; /* get past scope */
7328 switch(kid->op_type) {
7336 k = kid; /* remember this node*/
7337 if (kBINOP->op_first->op_type != OP_RV2SV)
7339 kid = kBINOP->op_first; /* get past cmp */
7340 if (kUNOP->op_first->op_type != OP_GV)
7342 kid = kUNOP->op_first; /* get past rv2sv */
7344 if (GvSTASH(gv) != PL_curstash)
7346 gvname = GvNAME(gv);
7347 if (*gvname == 'a' && gvname[1] == '\0')
7349 else if (*gvname == 'b' && gvname[1] == '\0')
7354 kid = k; /* back to cmp */
7355 if (kBINOP->op_last->op_type != OP_RV2SV)
7357 kid = kBINOP->op_last; /* down to 2nd arg */
7358 if (kUNOP->op_first->op_type != OP_GV)
7360 kid = kUNOP->op_first; /* get past rv2sv */
7362 if (GvSTASH(gv) != PL_curstash)
7364 gvname = GvNAME(gv);
7366 ? !(*gvname == 'a' && gvname[1] == '\0')
7367 : !(*gvname == 'b' && gvname[1] == '\0'))
7369 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7371 o->op_private |= OPpSORT_DESCEND;
7372 if (k->op_type == OP_NCMP)
7373 o->op_private |= OPpSORT_NUMERIC;
7374 if (k->op_type == OP_I_NCMP)
7375 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7376 kid = cLISTOPo->op_first->op_sibling;
7377 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7379 op_getmad(kid,o,'S'); /* then delete it */
7381 op_free(kid); /* then delete it */
7386 Perl_ck_split(pTHX_ OP *o)
7391 if (o->op_flags & OPf_STACKED)
7392 return no_fh_allowed(o);
7394 kid = cLISTOPo->op_first;
7395 if (kid->op_type != OP_NULL)
7396 Perl_croak(aTHX_ "panic: ck_split");
7397 kid = kid->op_sibling;
7398 op_free(cLISTOPo->op_first);
7399 cLISTOPo->op_first = kid;
7401 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7402 cLISTOPo->op_last = kid; /* There was only one element previously */
7405 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7406 OP * const sibl = kid->op_sibling;
7407 kid->op_sibling = 0;
7408 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7409 if (cLISTOPo->op_first == cLISTOPo->op_last)
7410 cLISTOPo->op_last = kid;
7411 cLISTOPo->op_first = kid;
7412 kid->op_sibling = sibl;
7415 kid->op_type = OP_PUSHRE;
7416 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7418 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7419 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7420 "Use of /g modifier is meaningless in split");
7423 if (!kid->op_sibling)
7424 append_elem(OP_SPLIT, o, newDEFSVOP());
7426 kid = kid->op_sibling;
7429 if (!kid->op_sibling)
7430 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7431 assert(kid->op_sibling);
7433 kid = kid->op_sibling;
7436 if (kid->op_sibling)
7437 return too_many_arguments(o,OP_DESC(o));
7443 Perl_ck_join(pTHX_ OP *o)
7445 const OP * const kid = cLISTOPo->op_first->op_sibling;
7446 if (kid && kid->op_type == OP_MATCH) {
7447 if (ckWARN(WARN_SYNTAX)) {
7448 const REGEXP *re = PM_GETRE(kPMOP);
7449 const char *pmstr = re ? re->precomp : "STRING";
7450 const STRLEN len = re ? re->prelen : 6;
7451 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7452 "/%.*s/ should probably be written as \"%.*s\"",
7453 (int)len, pmstr, (int)len, pmstr);
7460 Perl_ck_subr(pTHX_ OP *o)
7463 OP *prev = ((cUNOPo->op_first->op_sibling)
7464 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7465 OP *o2 = prev->op_sibling;
7467 const char *proto = NULL;
7468 const char *proto_end = NULL;
7473 I32 contextclass = 0;
7474 const char *e = NULL;
7477 o->op_private |= OPpENTERSUB_HASTARG;
7478 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7479 if (cvop->op_type == OP_RV2CV) {
7481 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7482 op_null(cvop); /* disable rv2cv */
7483 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7484 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7485 GV *gv = cGVOPx_gv(tmpop);
7488 tmpop->op_private |= OPpEARLY_CV;
7492 namegv = CvANON(cv) ? gv : CvGV(cv);
7493 proto = SvPV((SV*)cv, len);
7494 proto_end = proto + len;
7499 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7500 if (o2->op_type == OP_CONST)
7501 o2->op_private &= ~OPpCONST_STRICT;
7502 else if (o2->op_type == OP_LIST) {
7503 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7504 if (sib && sib->op_type == OP_CONST)
7505 sib->op_private &= ~OPpCONST_STRICT;
7508 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7509 if (PERLDB_SUB && PL_curstash != PL_debstash)
7510 o->op_private |= OPpENTERSUB_DB;
7511 while (o2 != cvop) {
7513 if (PL_madskills && o2->op_type == OP_STUB) {
7514 o2 = o2->op_sibling;
7517 if (PL_madskills && o2->op_type == OP_NULL)
7518 o3 = ((UNOP*)o2)->op_first;
7522 if (proto >= proto_end)
7523 return too_many_arguments(o, gv_ename(namegv));
7531 /* _ must be at the end */
7532 if (proto[1] && proto[1] != ';')
7547 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7549 arg == 1 ? "block or sub {}" : "sub {}",
7550 gv_ename(namegv), o3);
7553 /* '*' allows any scalar type, including bareword */
7556 if (o3->op_type == OP_RV2GV)
7557 goto wrapref; /* autoconvert GLOB -> GLOBref */
7558 else if (o3->op_type == OP_CONST)
7559 o3->op_private &= ~OPpCONST_STRICT;
7560 else if (o3->op_type == OP_ENTERSUB) {
7561 /* accidental subroutine, revert to bareword */
7562 OP *gvop = ((UNOP*)o3)->op_first;
7563 if (gvop && gvop->op_type == OP_NULL) {
7564 gvop = ((UNOP*)gvop)->op_first;
7566 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7569 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7570 (gvop = ((UNOP*)gvop)->op_first) &&
7571 gvop->op_type == OP_GV)
7573 GV * const gv = cGVOPx_gv(gvop);
7574 OP * const sibling = o2->op_sibling;
7575 SV * const n = newSVpvs("");
7577 OP * const oldo2 = o2;
7581 gv_fullname4(n, gv, "", FALSE);
7582 o2 = newSVOP(OP_CONST, 0, n);
7583 op_getmad(oldo2,o2,'O');
7584 prev->op_sibling = o2;
7585 o2->op_sibling = sibling;
7601 if (contextclass++ == 0) {
7602 e = strchr(proto, ']');
7603 if (!e || e == proto)
7612 const char *p = proto;
7613 const char *const end = proto;
7615 while (*--p != '[');
7616 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7618 gv_ename(namegv), o3);
7623 if (o3->op_type == OP_RV2GV)
7626 bad_type(arg, "symbol", gv_ename(namegv), o3);
7629 if (o3->op_type == OP_ENTERSUB)
7632 bad_type(arg, "subroutine entry", gv_ename(namegv),
7636 if (o3->op_type == OP_RV2SV ||
7637 o3->op_type == OP_PADSV ||
7638 o3->op_type == OP_HELEM ||
7639 o3->op_type == OP_AELEM)
7642 bad_type(arg, "scalar", gv_ename(namegv), o3);
7645 if (o3->op_type == OP_RV2AV ||
7646 o3->op_type == OP_PADAV)
7649 bad_type(arg, "array", gv_ename(namegv), o3);
7652 if (o3->op_type == OP_RV2HV ||
7653 o3->op_type == OP_PADHV)
7656 bad_type(arg, "hash", gv_ename(namegv), o3);
7661 OP* const sib = kid->op_sibling;
7662 kid->op_sibling = 0;
7663 o2 = newUNOP(OP_REFGEN, 0, kid);
7664 o2->op_sibling = sib;
7665 prev->op_sibling = o2;
7667 if (contextclass && e) {
7682 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7683 gv_ename(namegv), SVfARG(cv));
7688 mod(o2, OP_ENTERSUB);
7690 o2 = o2->op_sibling;
7692 if (o2 == cvop && proto && *proto == '_') {
7693 /* generate an access to $_ */
7695 o2->op_sibling = prev->op_sibling;
7696 prev->op_sibling = o2; /* instead of cvop */
7698 if (proto && !optional && proto_end > proto &&
7699 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7700 return too_few_arguments(o, gv_ename(namegv));
7703 OP * const oldo = o;
7707 o=newSVOP(OP_CONST, 0, newSViv(0));
7708 op_getmad(oldo,o,'O');
7714 Perl_ck_svconst(pTHX_ OP *o)
7716 PERL_UNUSED_CONTEXT;
7717 SvREADONLY_on(cSVOPo->op_sv);
7722 Perl_ck_chdir(pTHX_ OP *o)
7724 if (o->op_flags & OPf_KIDS) {
7725 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7727 if (kid && kid->op_type == OP_CONST &&
7728 (kid->op_private & OPpCONST_BARE))
7730 o->op_flags |= OPf_SPECIAL;
7731 kid->op_private &= ~OPpCONST_STRICT;
7738 Perl_ck_trunc(pTHX_ OP *o)
7740 if (o->op_flags & OPf_KIDS) {
7741 SVOP *kid = (SVOP*)cUNOPo->op_first;
7743 if (kid->op_type == OP_NULL)
7744 kid = (SVOP*)kid->op_sibling;
7745 if (kid && kid->op_type == OP_CONST &&
7746 (kid->op_private & OPpCONST_BARE))
7748 o->op_flags |= OPf_SPECIAL;
7749 kid->op_private &= ~OPpCONST_STRICT;
7756 Perl_ck_unpack(pTHX_ OP *o)
7758 OP *kid = cLISTOPo->op_first;
7759 if (kid->op_sibling) {
7760 kid = kid->op_sibling;
7761 if (!kid->op_sibling)
7762 kid->op_sibling = newDEFSVOP();
7768 Perl_ck_substr(pTHX_ OP *o)
7771 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7772 OP *kid = cLISTOPo->op_first;
7774 if (kid->op_type == OP_NULL)
7775 kid = kid->op_sibling;
7777 kid->op_flags |= OPf_MOD;
7783 /* A peephole optimizer. We visit the ops in the order they're to execute.
7784 * See the comments at the top of this file for more details about when
7785 * peep() is called */
7788 Perl_peep(pTHX_ register OP *o)
7791 register OP* oldop = NULL;
7793 if (!o || o->op_opt)
7797 SAVEVPTR(PL_curcop);
7798 for (; o; o = o->op_next) {
7801 /* By default, this op has now been optimised. A couple of cases below
7802 clear this again. */
7805 switch (o->op_type) {
7809 PL_curcop = ((COP*)o); /* for warnings */
7813 if (cSVOPo->op_private & OPpCONST_STRICT)
7814 no_bareword_allowed(o);
7816 case OP_METHOD_NAMED:
7817 /* Relocate sv to the pad for thread safety.
7818 * Despite being a "constant", the SV is written to,
7819 * for reference counts, sv_upgrade() etc. */
7821 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7822 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7823 /* If op_sv is already a PADTMP then it is being used by
7824 * some pad, so make a copy. */
7825 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7826 SvREADONLY_on(PAD_SVl(ix));
7827 SvREFCNT_dec(cSVOPo->op_sv);
7829 else if (o->op_type == OP_CONST
7830 && cSVOPo->op_sv == &PL_sv_undef) {
7831 /* PL_sv_undef is hack - it's unsafe to store it in the
7832 AV that is the pad, because av_fetch treats values of
7833 PL_sv_undef as a "free" AV entry and will merrily
7834 replace them with a new SV, causing pad_alloc to think
7835 that this pad slot is free. (When, clearly, it is not)
7837 SvOK_off(PAD_SVl(ix));
7838 SvPADTMP_on(PAD_SVl(ix));
7839 SvREADONLY_on(PAD_SVl(ix));
7842 SvREFCNT_dec(PAD_SVl(ix));
7843 SvPADTMP_on(cSVOPo->op_sv);
7844 PAD_SETSV(ix, cSVOPo->op_sv);
7845 /* XXX I don't know how this isn't readonly already. */
7846 SvREADONLY_on(PAD_SVl(ix));
7848 cSVOPo->op_sv = NULL;
7855 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7856 if (o->op_next->op_private & OPpTARGET_MY) {
7857 if (o->op_flags & OPf_STACKED) /* chained concats */
7858 break; /* ignore_optimization */
7860 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7861 o->op_targ = o->op_next->op_targ;
7862 o->op_next->op_targ = 0;
7863 o->op_private |= OPpTARGET_MY;
7866 op_null(o->op_next);
7870 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7871 break; /* Scalar stub must produce undef. List stub is noop */
7875 if (o->op_targ == OP_NEXTSTATE
7876 || o->op_targ == OP_DBSTATE
7877 || o->op_targ == OP_SETSTATE)
7879 PL_curcop = ((COP*)o);
7881 /* XXX: We avoid setting op_seq here to prevent later calls
7882 to peep() from mistakenly concluding that optimisation
7883 has already occurred. This doesn't fix the real problem,
7884 though (See 20010220.007). AMS 20010719 */
7885 /* op_seq functionality is now replaced by op_opt */
7892 if (oldop && o->op_next) {
7893 oldop->op_next = o->op_next;
7901 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7902 OP* const pop = (o->op_type == OP_PADAV) ?
7903 o->op_next : o->op_next->op_next;
7905 if (pop && pop->op_type == OP_CONST &&
7906 ((PL_op = pop->op_next)) &&
7907 pop->op_next->op_type == OP_AELEM &&
7908 !(pop->op_next->op_private &
7909 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7910 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7915 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7916 no_bareword_allowed(pop);
7917 if (o->op_type == OP_GV)
7918 op_null(o->op_next);
7919 op_null(pop->op_next);
7921 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7922 o->op_next = pop->op_next->op_next;
7923 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7924 o->op_private = (U8)i;
7925 if (o->op_type == OP_GV) {
7930 o->op_flags |= OPf_SPECIAL;
7931 o->op_type = OP_AELEMFAST;
7936 if (o->op_next->op_type == OP_RV2SV) {
7937 if (!(o->op_next->op_private & OPpDEREF)) {
7938 op_null(o->op_next);
7939 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7941 o->op_next = o->op_next->op_next;
7942 o->op_type = OP_GVSV;
7943 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7946 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7947 GV * const gv = cGVOPo_gv;
7948 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7949 /* XXX could check prototype here instead of just carping */
7950 SV * const sv = sv_newmortal();
7951 gv_efullname3(sv, gv, NULL);
7952 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7953 "%"SVf"() called too early to check prototype",
7957 else if (o->op_next->op_type == OP_READLINE
7958 && o->op_next->op_next->op_type == OP_CONCAT
7959 && (o->op_next->op_next->op_flags & OPf_STACKED))
7961 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7962 o->op_type = OP_RCATLINE;
7963 o->op_flags |= OPf_STACKED;
7964 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7965 op_null(o->op_next->op_next);
7966 op_null(o->op_next);
7981 while (cLOGOP->op_other->op_type == OP_NULL)
7982 cLOGOP->op_other = cLOGOP->op_other->op_next;
7983 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7988 while (cLOOP->op_redoop->op_type == OP_NULL)
7989 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7990 peep(cLOOP->op_redoop);
7991 while (cLOOP->op_nextop->op_type == OP_NULL)
7992 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7993 peep(cLOOP->op_nextop);
7994 while (cLOOP->op_lastop->op_type == OP_NULL)
7995 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7996 peep(cLOOP->op_lastop);
8000 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8001 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8002 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8003 cPMOP->op_pmstashstartu.op_pmreplstart
8004 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8005 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8009 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8010 && ckWARN(WARN_SYNTAX))
8012 if (o->op_next->op_sibling) {
8013 const OPCODE type = o->op_next->op_sibling->op_type;
8014 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8015 const line_t oldline = CopLINE(PL_curcop);
8016 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8017 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8018 "Statement unlikely to be reached");
8019 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8020 "\t(Maybe you meant system() when you said exec()?)\n");
8021 CopLINE_set(PL_curcop, oldline);
8032 const char *key = NULL;
8035 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8038 /* Make the CONST have a shared SV */
8039 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8040 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8041 key = SvPV_const(sv, keylen);
8042 lexname = newSVpvn_share(key,
8043 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8049 if ((o->op_private & (OPpLVAL_INTRO)))
8052 rop = (UNOP*)((BINOP*)o)->op_first;
8053 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8055 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8056 if (!SvPAD_TYPED(lexname))
8058 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8059 if (!fields || !GvHV(*fields))
8061 key = SvPV_const(*svp, keylen);
8062 if (!hv_fetch(GvHV(*fields), key,
8063 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8065 Perl_croak(aTHX_ "No such class field \"%s\" "
8066 "in variable %s of type %s",
8067 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8080 SVOP *first_key_op, *key_op;
8082 if ((o->op_private & (OPpLVAL_INTRO))
8083 /* I bet there's always a pushmark... */
8084 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8085 /* hmmm, no optimization if list contains only one key. */
8087 rop = (UNOP*)((LISTOP*)o)->op_last;
8088 if (rop->op_type != OP_RV2HV)
8090 if (rop->op_first->op_type == OP_PADSV)
8091 /* @$hash{qw(keys here)} */
8092 rop = (UNOP*)rop->op_first;
8094 /* @{$hash}{qw(keys here)} */
8095 if (rop->op_first->op_type == OP_SCOPE
8096 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8098 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8104 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8105 if (!SvPAD_TYPED(lexname))
8107 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8108 if (!fields || !GvHV(*fields))
8110 /* Again guessing that the pushmark can be jumped over.... */
8111 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8112 ->op_first->op_sibling;
8113 for (key_op = first_key_op; key_op;
8114 key_op = (SVOP*)key_op->op_sibling) {
8115 if (key_op->op_type != OP_CONST)
8117 svp = cSVOPx_svp(key_op);
8118 key = SvPV_const(*svp, keylen);
8119 if (!hv_fetch(GvHV(*fields), key,
8120 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8122 Perl_croak(aTHX_ "No such class field \"%s\" "
8123 "in variable %s of type %s",
8124 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8131 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8135 /* check that RHS of sort is a single plain array */
8136 OP *oright = cUNOPo->op_first;
8137 if (!oright || oright->op_type != OP_PUSHMARK)
8140 /* reverse sort ... can be optimised. */
8141 if (!cUNOPo->op_sibling) {
8142 /* Nothing follows us on the list. */
8143 OP * const reverse = o->op_next;
8145 if (reverse->op_type == OP_REVERSE &&
8146 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8147 OP * const pushmark = cUNOPx(reverse)->op_first;
8148 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8149 && (cUNOPx(pushmark)->op_sibling == o)) {
8150 /* reverse -> pushmark -> sort */
8151 o->op_private |= OPpSORT_REVERSE;
8153 pushmark->op_next = oright->op_next;
8159 /* make @a = sort @a act in-place */
8161 oright = cUNOPx(oright)->op_sibling;
8164 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8165 oright = cUNOPx(oright)->op_sibling;
8169 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8170 || oright->op_next != o
8171 || (oright->op_private & OPpLVAL_INTRO)
8175 /* o2 follows the chain of op_nexts through the LHS of the
8176 * assign (if any) to the aassign op itself */
8178 if (!o2 || o2->op_type != OP_NULL)
8181 if (!o2 || o2->op_type != OP_PUSHMARK)
8184 if (o2 && o2->op_type == OP_GV)
8187 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8188 || (o2->op_private & OPpLVAL_INTRO)
8193 if (!o2 || o2->op_type != OP_NULL)
8196 if (!o2 || o2->op_type != OP_AASSIGN
8197 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8200 /* check that the sort is the first arg on RHS of assign */
8202 o2 = cUNOPx(o2)->op_first;
8203 if (!o2 || o2->op_type != OP_NULL)
8205 o2 = cUNOPx(o2)->op_first;
8206 if (!o2 || o2->op_type != OP_PUSHMARK)
8208 if (o2->op_sibling != o)
8211 /* check the array is the same on both sides */
8212 if (oleft->op_type == OP_RV2AV) {
8213 if (oright->op_type != OP_RV2AV
8214 || !cUNOPx(oright)->op_first
8215 || cUNOPx(oright)->op_first->op_type != OP_GV
8216 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8217 cGVOPx_gv(cUNOPx(oright)->op_first)
8221 else if (oright->op_type != OP_PADAV
8222 || oright->op_targ != oleft->op_targ
8226 /* transfer MODishness etc from LHS arg to RHS arg */
8227 oright->op_flags = oleft->op_flags;
8228 o->op_private |= OPpSORT_INPLACE;
8230 /* excise push->gv->rv2av->null->aassign */
8231 o2 = o->op_next->op_next;
8232 op_null(o2); /* PUSHMARK */
8234 if (o2->op_type == OP_GV) {
8235 op_null(o2); /* GV */
8238 op_null(o2); /* RV2AV or PADAV */
8239 o2 = o2->op_next->op_next;
8240 op_null(o2); /* AASSIGN */
8242 o->op_next = o2->op_next;
8248 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8250 LISTOP *enter, *exlist;
8252 enter = (LISTOP *) o->op_next;
8255 if (enter->op_type == OP_NULL) {
8256 enter = (LISTOP *) enter->op_next;
8260 /* for $a (...) will have OP_GV then OP_RV2GV here.
8261 for (...) just has an OP_GV. */
8262 if (enter->op_type == OP_GV) {
8263 gvop = (OP *) enter;
8264 enter = (LISTOP *) enter->op_next;
8267 if (enter->op_type == OP_RV2GV) {
8268 enter = (LISTOP *) enter->op_next;
8274 if (enter->op_type != OP_ENTERITER)
8277 iter = enter->op_next;
8278 if (!iter || iter->op_type != OP_ITER)
8281 expushmark = enter->op_first;
8282 if (!expushmark || expushmark->op_type != OP_NULL
8283 || expushmark->op_targ != OP_PUSHMARK)
8286 exlist = (LISTOP *) expushmark->op_sibling;
8287 if (!exlist || exlist->op_type != OP_NULL
8288 || exlist->op_targ != OP_LIST)
8291 if (exlist->op_last != o) {
8292 /* Mmm. Was expecting to point back to this op. */
8295 theirmark = exlist->op_first;
8296 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8299 if (theirmark->op_sibling != o) {
8300 /* There's something between the mark and the reverse, eg
8301 for (1, reverse (...))
8306 ourmark = ((LISTOP *)o)->op_first;
8307 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8310 ourlast = ((LISTOP *)o)->op_last;
8311 if (!ourlast || ourlast->op_next != o)
8314 rv2av = ourmark->op_sibling;
8315 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8316 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8317 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8318 /* We're just reversing a single array. */
8319 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8320 enter->op_flags |= OPf_STACKED;
8323 /* We don't have control over who points to theirmark, so sacrifice
8325 theirmark->op_next = ourmark->op_next;
8326 theirmark->op_flags = ourmark->op_flags;
8327 ourlast->op_next = gvop ? gvop : (OP *) enter;
8330 enter->op_private |= OPpITER_REVERSED;
8331 iter->op_private |= OPpITER_REVERSED;
8338 UNOP *refgen, *rv2cv;
8341 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8344 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8347 rv2gv = ((BINOP *)o)->op_last;
8348 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8351 refgen = (UNOP *)((BINOP *)o)->op_first;
8353 if (!refgen || refgen->op_type != OP_REFGEN)
8356 exlist = (LISTOP *)refgen->op_first;
8357 if (!exlist || exlist->op_type != OP_NULL
8358 || exlist->op_targ != OP_LIST)
8361 if (exlist->op_first->op_type != OP_PUSHMARK)
8364 rv2cv = (UNOP*)exlist->op_last;
8366 if (rv2cv->op_type != OP_RV2CV)
8369 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8370 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8371 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8373 o->op_private |= OPpASSIGN_CV_TO_GV;
8374 rv2gv->op_private |= OPpDONT_INIT_GV;
8375 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8383 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8384 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8394 Perl_custom_op_name(pTHX_ const OP* o)
8397 const IV index = PTR2IV(o->op_ppaddr);
8401 if (!PL_custom_op_names) /* This probably shouldn't happen */
8402 return (char *)PL_op_name[OP_CUSTOM];
8404 keysv = sv_2mortal(newSViv(index));
8406 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8408 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8410 return SvPV_nolen(HeVAL(he));
8414 Perl_custom_op_desc(pTHX_ const OP* o)
8417 const IV index = PTR2IV(o->op_ppaddr);
8421 if (!PL_custom_op_descs)
8422 return (char *)PL_op_desc[OP_CUSTOM];
8424 keysv = sv_2mortal(newSViv(index));
8426 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8428 return (char *)PL_op_desc[OP_CUSTOM];
8430 return SvPV_nolen(HeVAL(he));
8435 /* Efficient sub that returns a constant scalar value. */
8437 const_sv_xsub(pTHX_ CV* cv)
8444 Perl_croak(aTHX_ "usage: %s::%s()",
8445 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8449 ST(0) = (SV*)XSANY.any_ptr;
8455 * c-indentation-style: bsd
8457 * indent-tabs-mode: t
8460 * ex: set ts=8 sts=4 sw=4 noet: