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)
426 if (!o || o->op_static)
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_error_count || (o->op_flags & OPf_WANT)
803 || o->op_type == OP_RETURN)
808 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
810 switch (o->op_type) {
812 scalar(cBINOPo->op_first);
817 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
821 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
822 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
823 deprecate_old("implicit split to @_");
831 if (o->op_flags & OPf_KIDS) {
832 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
838 kid = cLISTOPo->op_first;
840 while ((kid = kid->op_sibling)) {
846 PL_curcop = &PL_compiling;
851 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
857 PL_curcop = &PL_compiling;
860 if (ckWARN(WARN_VOID))
861 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
867 Perl_scalarvoid(pTHX_ OP *o)
871 const char* useless = NULL;
875 /* trailing mad null ops don't count as "there" for void processing */
877 o->op_type != OP_NULL &&
879 o->op_sibling->op_type == OP_NULL)
882 for (sib = o->op_sibling;
883 sib && sib->op_type == OP_NULL;
884 sib = sib->op_sibling) ;
890 if (o->op_type == OP_NEXTSTATE
891 || o->op_type == OP_SETSTATE
892 || o->op_type == OP_DBSTATE
893 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
894 || o->op_targ == OP_SETSTATE
895 || o->op_targ == OP_DBSTATE)))
896 PL_curcop = (COP*)o; /* for warning below */
898 /* assumes no premature commitment */
899 want = o->op_flags & OPf_WANT;
900 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
901 || o->op_type == OP_RETURN)
906 if ((o->op_private & OPpTARGET_MY)
907 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
909 return scalar(o); /* As if inside SASSIGN */
912 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
914 switch (o->op_type) {
916 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
920 if (o->op_flags & OPf_STACKED)
924 if (o->op_private == 4)
996 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
997 useless = OP_DESC(o);
1001 kid = cUNOPo->op_first;
1002 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1003 kid->op_type != OP_TRANS) {
1006 useless = "negative pattern binding (!~)";
1013 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1014 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1015 useless = "a variable";
1020 if (cSVOPo->op_private & OPpCONST_STRICT)
1021 no_bareword_allowed(o);
1023 if (ckWARN(WARN_VOID)) {
1024 useless = "a constant";
1025 if (o->op_private & OPpCONST_ARYBASE)
1027 /* don't warn on optimised away booleans, eg
1028 * use constant Foo, 5; Foo || print; */
1029 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1031 /* the constants 0 and 1 are permitted as they are
1032 conventionally used as dummies in constructs like
1033 1 while some_condition_with_side_effects; */
1034 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1036 else if (SvPOK(sv)) {
1037 /* perl4's way of mixing documentation and code
1038 (before the invention of POD) was based on a
1039 trick to mix nroff and perl code. The trick was
1040 built upon these three nroff macros being used in
1041 void context. The pink camel has the details in
1042 the script wrapman near page 319. */
1043 const char * const maybe_macro = SvPVX_const(sv);
1044 if (strnEQ(maybe_macro, "di", 2) ||
1045 strnEQ(maybe_macro, "ds", 2) ||
1046 strnEQ(maybe_macro, "ig", 2))
1051 op_null(o); /* don't execute or even remember it */
1055 o->op_type = OP_PREINC; /* pre-increment is faster */
1056 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1060 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1061 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1065 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1066 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1070 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1071 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1080 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1085 if (o->op_flags & OPf_STACKED)
1092 if (!(o->op_flags & OPf_KIDS))
1103 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1110 /* all requires must return a boolean value */
1111 o->op_flags &= ~OPf_WANT;
1116 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1117 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1118 deprecate_old("implicit split to @_");
1122 if (useless && ckWARN(WARN_VOID))
1123 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1128 Perl_listkids(pTHX_ OP *o)
1130 if (o && o->op_flags & OPf_KIDS) {
1132 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1139 Perl_list(pTHX_ OP *o)
1144 /* assumes no premature commitment */
1145 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1146 || o->op_type == OP_RETURN)
1151 if ((o->op_private & OPpTARGET_MY)
1152 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1154 return o; /* As if inside SASSIGN */
1157 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1159 switch (o->op_type) {
1162 list(cBINOPo->op_first);
1167 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1175 if (!(o->op_flags & OPf_KIDS))
1177 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1178 list(cBINOPo->op_first);
1179 return gen_constant_list(o);
1186 kid = cLISTOPo->op_first;
1188 while ((kid = kid->op_sibling)) {
1189 if (kid->op_sibling)
1194 PL_curcop = &PL_compiling;
1198 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1199 if (kid->op_sibling)
1204 PL_curcop = &PL_compiling;
1207 /* all requires must return a boolean value */
1208 o->op_flags &= ~OPf_WANT;
1215 Perl_scalarseq(pTHX_ OP *o)
1219 const OPCODE type = o->op_type;
1221 if (type == OP_LINESEQ || type == OP_SCOPE ||
1222 type == OP_LEAVE || type == OP_LEAVETRY)
1225 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1226 if (kid->op_sibling) {
1230 PL_curcop = &PL_compiling;
1232 o->op_flags &= ~OPf_PARENS;
1233 if (PL_hints & HINT_BLOCK_SCOPE)
1234 o->op_flags |= OPf_PARENS;
1237 o = newOP(OP_STUB, 0);
1242 S_modkids(pTHX_ OP *o, I32 type)
1244 if (o && o->op_flags & OPf_KIDS) {
1246 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1252 /* Propagate lvalue ("modifiable") context to an op and its children.
1253 * 'type' represents the context type, roughly based on the type of op that
1254 * would do the modifying, although local() is represented by OP_NULL.
1255 * It's responsible for detecting things that can't be modified, flag
1256 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1257 * might have to vivify a reference in $x), and so on.
1259 * For example, "$a+1 = 2" would cause mod() to be called with o being
1260 * OP_ADD and type being OP_SASSIGN, and would output an error.
1264 Perl_mod(pTHX_ OP *o, I32 type)
1268 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1271 if (!o || PL_error_count)
1274 if ((o->op_private & OPpTARGET_MY)
1275 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1280 switch (o->op_type) {
1286 if (!(o->op_private & OPpCONST_ARYBASE))
1289 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1290 CopARYBASE_set(&PL_compiling,
1291 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1295 SAVECOPARYBASE(&PL_compiling);
1296 CopARYBASE_set(&PL_compiling, 0);
1298 else if (type == OP_REFGEN)
1301 Perl_croak(aTHX_ "That use of $[ is unsupported");
1304 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1308 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1309 !(o->op_flags & OPf_STACKED)) {
1310 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1311 /* The default is to set op_private to the number of children,
1312 which for a UNOP such as RV2CV is always 1. And w're using
1313 the bit for a flag in RV2CV, so we need it clear. */
1314 o->op_private &= ~1;
1315 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1316 assert(cUNOPo->op_first->op_type == OP_NULL);
1317 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1320 else if (o->op_private & OPpENTERSUB_NOMOD)
1322 else { /* lvalue subroutine call */
1323 o->op_private |= OPpLVAL_INTRO;
1324 PL_modcount = RETURN_UNLIMITED_NUMBER;
1325 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1326 /* Backward compatibility mode: */
1327 o->op_private |= OPpENTERSUB_INARGS;
1330 else { /* Compile-time error message: */
1331 OP *kid = cUNOPo->op_first;
1335 if (kid->op_type != OP_PUSHMARK) {
1336 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1338 "panic: unexpected lvalue entersub "
1339 "args: type/targ %ld:%"UVuf,
1340 (long)kid->op_type, (UV)kid->op_targ);
1341 kid = kLISTOP->op_first;
1343 while (kid->op_sibling)
1344 kid = kid->op_sibling;
1345 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1347 if (kid->op_type == OP_METHOD_NAMED
1348 || kid->op_type == OP_METHOD)
1352 NewOp(1101, newop, 1, UNOP);
1353 newop->op_type = OP_RV2CV;
1354 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1355 newop->op_first = NULL;
1356 newop->op_next = (OP*)newop;
1357 kid->op_sibling = (OP*)newop;
1358 newop->op_private |= OPpLVAL_INTRO;
1359 newop->op_private &= ~1;
1363 if (kid->op_type != OP_RV2CV)
1365 "panic: unexpected lvalue entersub "
1366 "entry via type/targ %ld:%"UVuf,
1367 (long)kid->op_type, (UV)kid->op_targ);
1368 kid->op_private |= OPpLVAL_INTRO;
1369 break; /* Postpone until runtime */
1373 kid = kUNOP->op_first;
1374 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1375 kid = kUNOP->op_first;
1376 if (kid->op_type == OP_NULL)
1378 "Unexpected constant lvalue entersub "
1379 "entry via type/targ %ld:%"UVuf,
1380 (long)kid->op_type, (UV)kid->op_targ);
1381 if (kid->op_type != OP_GV) {
1382 /* Restore RV2CV to check lvalueness */
1384 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1385 okid->op_next = kid->op_next;
1386 kid->op_next = okid;
1389 okid->op_next = NULL;
1390 okid->op_type = OP_RV2CV;
1392 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1393 okid->op_private |= OPpLVAL_INTRO;
1394 okid->op_private &= ~1;
1398 cv = GvCV(kGVOP_gv);
1408 /* grep, foreach, subcalls, refgen */
1409 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1411 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1412 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1414 : (o->op_type == OP_ENTERSUB
1415 ? "non-lvalue subroutine call"
1417 type ? PL_op_desc[type] : "local"));
1431 case OP_RIGHT_SHIFT:
1440 if (!(o->op_flags & OPf_STACKED))
1447 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1453 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1454 PL_modcount = RETURN_UNLIMITED_NUMBER;
1455 return o; /* Treat \(@foo) like ordinary list. */
1459 if (scalar_mod_type(o, type))
1461 ref(cUNOPo->op_first, o->op_type);
1465 if (type == OP_LEAVESUBLV)
1466 o->op_private |= OPpMAYBE_LVSUB;
1472 PL_modcount = RETURN_UNLIMITED_NUMBER;
1475 ref(cUNOPo->op_first, o->op_type);
1480 PL_hints |= HINT_BLOCK_SCOPE;
1495 PL_modcount = RETURN_UNLIMITED_NUMBER;
1496 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1497 return o; /* Treat \(@foo) like ordinary list. */
1498 if (scalar_mod_type(o, type))
1500 if (type == OP_LEAVESUBLV)
1501 o->op_private |= OPpMAYBE_LVSUB;
1505 if (!type) /* local() */
1506 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1507 PAD_COMPNAME_PV(o->op_targ));
1515 if (type != OP_SASSIGN)
1519 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1524 if (type == OP_LEAVESUBLV)
1525 o->op_private |= OPpMAYBE_LVSUB;
1527 pad_free(o->op_targ);
1528 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1529 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1530 if (o->op_flags & OPf_KIDS)
1531 mod(cBINOPo->op_first->op_sibling, type);
1536 ref(cBINOPo->op_first, o->op_type);
1537 if (type == OP_ENTERSUB &&
1538 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1539 o->op_private |= OPpLVAL_DEFER;
1540 if (type == OP_LEAVESUBLV)
1541 o->op_private |= OPpMAYBE_LVSUB;
1551 if (o->op_flags & OPf_KIDS)
1552 mod(cLISTOPo->op_last, type);
1557 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1559 else if (!(o->op_flags & OPf_KIDS))
1561 if (o->op_targ != OP_LIST) {
1562 mod(cBINOPo->op_first, type);
1568 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1573 if (type != OP_LEAVESUBLV)
1575 break; /* mod()ing was handled by ck_return() */
1578 /* [20011101.069] File test operators interpret OPf_REF to mean that
1579 their argument is a filehandle; thus \stat(".") should not set
1581 if (type == OP_REFGEN &&
1582 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1585 if (type != OP_LEAVESUBLV)
1586 o->op_flags |= OPf_MOD;
1588 if (type == OP_AASSIGN || type == OP_SASSIGN)
1589 o->op_flags |= OPf_SPECIAL|OPf_REF;
1590 else if (!type) { /* local() */
1593 o->op_private |= OPpLVAL_INTRO;
1594 o->op_flags &= ~OPf_SPECIAL;
1595 PL_hints |= HINT_BLOCK_SCOPE;
1600 if (ckWARN(WARN_SYNTAX)) {
1601 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1602 "Useless localization of %s", OP_DESC(o));
1606 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1607 && type != OP_LEAVESUBLV)
1608 o->op_flags |= OPf_REF;
1613 S_scalar_mod_type(const OP *o, I32 type)
1617 if (o->op_type == OP_RV2GV)
1641 case OP_RIGHT_SHIFT:
1661 S_is_handle_constructor(const OP *o, I32 numargs)
1663 switch (o->op_type) {
1671 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1684 Perl_refkids(pTHX_ OP *o, I32 type)
1686 if (o && o->op_flags & OPf_KIDS) {
1688 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1695 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1700 if (!o || PL_error_count)
1703 switch (o->op_type) {
1705 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1706 !(o->op_flags & OPf_STACKED)) {
1707 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1708 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1709 assert(cUNOPo->op_first->op_type == OP_NULL);
1710 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1711 o->op_flags |= OPf_SPECIAL;
1712 o->op_private &= ~1;
1717 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1718 doref(kid, type, set_op_ref);
1721 if (type == OP_DEFINED)
1722 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1723 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1726 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1727 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1728 : type == OP_RV2HV ? OPpDEREF_HV
1730 o->op_flags |= OPf_MOD;
1737 o->op_flags |= OPf_REF;
1740 if (type == OP_DEFINED)
1741 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1742 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1748 o->op_flags |= OPf_REF;
1753 if (!(o->op_flags & OPf_KIDS))
1755 doref(cBINOPo->op_first, type, set_op_ref);
1759 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1760 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1761 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1762 : type == OP_RV2HV ? OPpDEREF_HV
1764 o->op_flags |= OPf_MOD;
1774 if (!(o->op_flags & OPf_KIDS))
1776 doref(cLISTOPo->op_last, type, set_op_ref);
1786 S_dup_attrlist(pTHX_ OP *o)
1791 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1792 * where the first kid is OP_PUSHMARK and the remaining ones
1793 * are OP_CONST. We need to push the OP_CONST values.
1795 if (o->op_type == OP_CONST)
1796 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1798 else if (o->op_type == OP_NULL)
1802 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1804 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1805 if (o->op_type == OP_CONST)
1806 rop = append_elem(OP_LIST, rop,
1807 newSVOP(OP_CONST, o->op_flags,
1808 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1815 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1820 /* fake up C<use attributes $pkg,$rv,@attrs> */
1821 ENTER; /* need to protect against side-effects of 'use' */
1822 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1824 #define ATTRSMODULE "attributes"
1825 #define ATTRSMODULE_PM "attributes.pm"
1828 /* Don't force the C<use> if we don't need it. */
1829 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1830 if (svp && *svp != &PL_sv_undef)
1831 NOOP; /* already in %INC */
1833 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1834 newSVpvs(ATTRSMODULE), NULL);
1837 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1838 newSVpvs(ATTRSMODULE),
1840 prepend_elem(OP_LIST,
1841 newSVOP(OP_CONST, 0, stashsv),
1842 prepend_elem(OP_LIST,
1843 newSVOP(OP_CONST, 0,
1845 dup_attrlist(attrs))));
1851 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1854 OP *pack, *imop, *arg;
1860 assert(target->op_type == OP_PADSV ||
1861 target->op_type == OP_PADHV ||
1862 target->op_type == OP_PADAV);
1864 /* Ensure that attributes.pm is loaded. */
1865 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1867 /* Need package name for method call. */
1868 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1870 /* Build up the real arg-list. */
1871 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1873 arg = newOP(OP_PADSV, 0);
1874 arg->op_targ = target->op_targ;
1875 arg = prepend_elem(OP_LIST,
1876 newSVOP(OP_CONST, 0, stashsv),
1877 prepend_elem(OP_LIST,
1878 newUNOP(OP_REFGEN, 0,
1879 mod(arg, OP_REFGEN)),
1880 dup_attrlist(attrs)));
1882 /* Fake up a method call to import */
1883 meth = newSVpvs_share("import");
1884 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1885 append_elem(OP_LIST,
1886 prepend_elem(OP_LIST, pack, list(arg)),
1887 newSVOP(OP_METHOD_NAMED, 0, meth)));
1888 imop->op_private |= OPpENTERSUB_NOMOD;
1890 /* Combine the ops. */
1891 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1895 =notfor apidoc apply_attrs_string
1897 Attempts to apply a list of attributes specified by the C<attrstr> and
1898 C<len> arguments to the subroutine identified by the C<cv> argument which
1899 is expected to be associated with the package identified by the C<stashpv>
1900 argument (see L<attributes>). It gets this wrong, though, in that it
1901 does not correctly identify the boundaries of the individual attribute
1902 specifications within C<attrstr>. This is not really intended for the
1903 public API, but has to be listed here for systems such as AIX which
1904 need an explicit export list for symbols. (It's called from XS code
1905 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1906 to respect attribute syntax properly would be welcome.
1912 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1913 const char *attrstr, STRLEN len)
1918 len = strlen(attrstr);
1922 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1924 const char * const sstr = attrstr;
1925 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1926 attrs = append_elem(OP_LIST, attrs,
1927 newSVOP(OP_CONST, 0,
1928 newSVpvn(sstr, attrstr-sstr)));
1932 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1933 newSVpvs(ATTRSMODULE),
1934 NULL, prepend_elem(OP_LIST,
1935 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1936 prepend_elem(OP_LIST,
1937 newSVOP(OP_CONST, 0,
1943 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1948 if (!o || PL_error_count)
1952 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1953 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1957 if (type == OP_LIST) {
1959 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1960 my_kid(kid, attrs, imopsp);
1961 } else if (type == OP_UNDEF
1967 } else if (type == OP_RV2SV || /* "our" declaration */
1969 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1970 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1971 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1973 PL_parser->in_my == KEY_our
1975 : PL_parser->in_my == KEY_state ? "state" : "my"));
1977 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1978 PL_parser->in_my = FALSE;
1979 PL_parser->in_my_stash = NULL;
1980 apply_attrs(GvSTASH(gv),
1981 (type == OP_RV2SV ? GvSV(gv) :
1982 type == OP_RV2AV ? (SV*)GvAV(gv) :
1983 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1986 o->op_private |= OPpOUR_INTRO;
1989 else if (type != OP_PADSV &&
1992 type != OP_PUSHMARK)
1994 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1996 PL_parser->in_my == KEY_our
1998 : PL_parser->in_my == KEY_state ? "state" : "my"));
2001 else if (attrs && type != OP_PUSHMARK) {
2004 PL_parser->in_my = FALSE;
2005 PL_parser->in_my_stash = NULL;
2007 /* check for C<my Dog $spot> when deciding package */
2008 stash = PAD_COMPNAME_TYPE(o->op_targ);
2010 stash = PL_curstash;
2011 apply_attrs_my(stash, o, attrs, imopsp);
2013 o->op_flags |= OPf_MOD;
2014 o->op_private |= OPpLVAL_INTRO;
2015 if (PL_parser->in_my == KEY_state)
2016 o->op_private |= OPpPAD_STATE;
2021 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2025 int maybe_scalar = 0;
2027 /* [perl #17376]: this appears to be premature, and results in code such as
2028 C< our(%x); > executing in list mode rather than void mode */
2030 if (o->op_flags & OPf_PARENS)
2040 o = my_kid(o, attrs, &rops);
2042 if (maybe_scalar && o->op_type == OP_PADSV) {
2043 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2044 o->op_private |= OPpLVAL_INTRO;
2047 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2049 PL_parser->in_my = FALSE;
2050 PL_parser->in_my_stash = NULL;
2055 Perl_my(pTHX_ OP *o)
2057 return my_attrs(o, NULL);
2061 Perl_sawparens(pTHX_ OP *o)
2063 PERL_UNUSED_CONTEXT;
2065 o->op_flags |= OPf_PARENS;
2070 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2074 const OPCODE ltype = left->op_type;
2075 const OPCODE rtype = right->op_type;
2077 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2078 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2080 const char * const desc
2081 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2082 ? (int)rtype : OP_MATCH];
2083 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2084 ? "@array" : "%hash");
2085 Perl_warner(aTHX_ packWARN(WARN_MISC),
2086 "Applying %s to %s will act on scalar(%s)",
2087 desc, sample, sample);
2090 if (rtype == OP_CONST &&
2091 cSVOPx(right)->op_private & OPpCONST_BARE &&
2092 cSVOPx(right)->op_private & OPpCONST_STRICT)
2094 no_bareword_allowed(right);
2097 ismatchop = rtype == OP_MATCH ||
2098 rtype == OP_SUBST ||
2100 if (ismatchop && right->op_private & OPpTARGET_MY) {
2102 right->op_private &= ~OPpTARGET_MY;
2104 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2107 right->op_flags |= OPf_STACKED;
2108 if (rtype != OP_MATCH &&
2109 ! (rtype == OP_TRANS &&
2110 right->op_private & OPpTRANS_IDENTICAL))
2111 newleft = mod(left, rtype);
2114 if (right->op_type == OP_TRANS)
2115 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2117 o = prepend_elem(rtype, scalar(newleft), right);
2119 return newUNOP(OP_NOT, 0, scalar(o));
2123 return bind_match(type, left,
2124 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2128 Perl_invert(pTHX_ OP *o)
2132 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2136 Perl_scope(pTHX_ OP *o)
2140 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2141 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2142 o->op_type = OP_LEAVE;
2143 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2145 else if (o->op_type == OP_LINESEQ) {
2147 o->op_type = OP_SCOPE;
2148 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2149 kid = ((LISTOP*)o)->op_first;
2150 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2153 /* The following deals with things like 'do {1 for 1}' */
2154 kid = kid->op_sibling;
2156 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2161 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2167 Perl_block_start(pTHX_ int full)
2170 const int retval = PL_savestack_ix;
2171 pad_block_start(full);
2173 PL_hints &= ~HINT_BLOCK_SCOPE;
2174 SAVECOMPILEWARNINGS();
2175 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2180 Perl_block_end(pTHX_ I32 floor, OP *seq)
2183 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2184 OP* const retval = scalarseq(seq);
2186 CopHINTS_set(&PL_compiling, PL_hints);
2188 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2197 const PADOFFSET offset = pad_findmy("$_");
2198 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2199 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2202 OP * const o = newOP(OP_PADSV, 0);
2203 o->op_targ = offset;
2209 Perl_newPROG(pTHX_ OP *o)
2215 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2216 ((PL_in_eval & EVAL_KEEPERR)
2217 ? OPf_SPECIAL : 0), o);
2218 PL_eval_start = linklist(PL_eval_root);
2219 PL_eval_root->op_private |= OPpREFCOUNTED;
2220 OpREFCNT_set(PL_eval_root, 1);
2221 PL_eval_root->op_next = 0;
2222 CALL_PEEP(PL_eval_start);
2225 if (o->op_type == OP_STUB) {
2226 PL_comppad_name = 0;
2228 S_op_destroy(aTHX_ o);
2231 PL_main_root = scope(sawparens(scalarvoid(o)));
2232 PL_curcop = &PL_compiling;
2233 PL_main_start = LINKLIST(PL_main_root);
2234 PL_main_root->op_private |= OPpREFCOUNTED;
2235 OpREFCNT_set(PL_main_root, 1);
2236 PL_main_root->op_next = 0;
2237 CALL_PEEP(PL_main_start);
2240 /* Register with debugger */
2243 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2247 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2249 call_sv((SV*)cv, G_DISCARD);
2256 Perl_localize(pTHX_ OP *o, I32 lex)
2259 if (o->op_flags & OPf_PARENS)
2260 /* [perl #17376]: this appears to be premature, and results in code such as
2261 C< our(%x); > executing in list mode rather than void mode */
2268 if ( PL_parser->bufptr > PL_parser->oldbufptr
2269 && PL_parser->bufptr[-1] == ','
2270 && ckWARN(WARN_PARENTHESIS))
2272 char *s = PL_parser->bufptr;
2275 /* some heuristics to detect a potential error */
2276 while (*s && (strchr(", \t\n", *s)))
2280 if (*s && strchr("@$%*", *s) && *++s
2281 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2284 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2286 while (*s && (strchr(", \t\n", *s)))
2292 if (sigil && (*s == ';' || *s == '=')) {
2293 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2294 "Parentheses missing around \"%s\" list",
2296 ? (PL_parser->in_my == KEY_our
2298 : PL_parser->in_my == KEY_state
2308 o = mod(o, OP_NULL); /* a bit kludgey */
2309 PL_parser->in_my = FALSE;
2310 PL_parser->in_my_stash = NULL;
2315 Perl_jmaybe(pTHX_ OP *o)
2317 if (o->op_type == OP_LIST) {
2319 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2320 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2326 Perl_fold_constants(pTHX_ register OP *o)
2331 VOL I32 type = o->op_type;
2336 SV * const oldwarnhook = PL_warnhook;
2337 SV * const olddiehook = PL_diehook;
2340 if (PL_opargs[type] & OA_RETSCALAR)
2342 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2343 o->op_targ = pad_alloc(type, SVs_PADTMP);
2345 /* integerize op, unless it happens to be C<-foo>.
2346 * XXX should pp_i_negate() do magic string negation instead? */
2347 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2348 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2349 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2351 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2354 if (!(PL_opargs[type] & OA_FOLDCONST))
2359 /* XXX might want a ck_negate() for this */
2360 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2371 /* XXX what about the numeric ops? */
2372 if (PL_hints & HINT_LOCALE)
2377 goto nope; /* Don't try to run w/ errors */
2379 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2380 const OPCODE type = curop->op_type;
2381 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2383 type != OP_SCALAR &&
2385 type != OP_PUSHMARK)
2391 curop = LINKLIST(o);
2392 old_next = o->op_next;
2396 oldscope = PL_scopestack_ix;
2397 create_eval_scope(G_FAKINGEVAL);
2399 PL_warnhook = PERL_WARNHOOK_FATAL;
2406 sv = *(PL_stack_sp--);
2407 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2408 pad_swipe(o->op_targ, FALSE);
2409 else if (SvTEMP(sv)) { /* grab mortal temp? */
2410 SvREFCNT_inc_simple_void(sv);
2415 /* Something tried to die. Abandon constant folding. */
2416 /* Pretend the error never happened. */
2417 sv_setpvn(ERRSV,"",0);
2418 o->op_next = old_next;
2422 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2423 PL_warnhook = oldwarnhook;
2424 PL_diehook = olddiehook;
2425 /* XXX note that this croak may fail as we've already blown away
2426 * the stack - eg any nested evals */
2427 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2430 PL_warnhook = oldwarnhook;
2431 PL_diehook = olddiehook;
2433 if (PL_scopestack_ix > oldscope)
2434 delete_eval_scope();
2443 if (type == OP_RV2GV)
2444 newop = newGVOP(OP_GV, 0, (GV*)sv);
2446 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2447 op_getmad(o,newop,'f');
2455 Perl_gen_constant_list(pTHX_ register OP *o)
2459 const I32 oldtmps_floor = PL_tmps_floor;
2463 return o; /* Don't attempt to run with errors */
2465 PL_op = curop = LINKLIST(o);
2471 assert (!(curop->op_flags & OPf_SPECIAL));
2472 assert(curop->op_type == OP_RANGE);
2474 PL_tmps_floor = oldtmps_floor;
2476 o->op_type = OP_RV2AV;
2477 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2478 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2479 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2480 o->op_opt = 0; /* needs to be revisited in peep() */
2481 curop = ((UNOP*)o)->op_first;
2482 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2484 op_getmad(curop,o,'O');
2493 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2496 if (!o || o->op_type != OP_LIST)
2497 o = newLISTOP(OP_LIST, 0, o, NULL);
2499 o->op_flags &= ~OPf_WANT;
2501 if (!(PL_opargs[type] & OA_MARK))
2502 op_null(cLISTOPo->op_first);
2504 o->op_type = (OPCODE)type;
2505 o->op_ppaddr = PL_ppaddr[type];
2506 o->op_flags |= flags;
2508 o = CHECKOP(type, o);
2509 if (o->op_type != (unsigned)type)
2512 return fold_constants(o);
2515 /* List constructors */
2518 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2526 if (first->op_type != (unsigned)type
2527 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2529 return newLISTOP(type, 0, first, last);
2532 if (first->op_flags & OPf_KIDS)
2533 ((LISTOP*)first)->op_last->op_sibling = last;
2535 first->op_flags |= OPf_KIDS;
2536 ((LISTOP*)first)->op_first = last;
2538 ((LISTOP*)first)->op_last = last;
2543 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2551 if (first->op_type != (unsigned)type)
2552 return prepend_elem(type, (OP*)first, (OP*)last);
2554 if (last->op_type != (unsigned)type)
2555 return append_elem(type, (OP*)first, (OP*)last);
2557 first->op_last->op_sibling = last->op_first;
2558 first->op_last = last->op_last;
2559 first->op_flags |= (last->op_flags & OPf_KIDS);
2562 if (last->op_first && first->op_madprop) {
2563 MADPROP *mp = last->op_first->op_madprop;
2565 while (mp->mad_next)
2567 mp->mad_next = first->op_madprop;
2570 last->op_first->op_madprop = first->op_madprop;
2573 first->op_madprop = last->op_madprop;
2574 last->op_madprop = 0;
2577 S_op_destroy(aTHX_ (OP*)last);
2583 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2591 if (last->op_type == (unsigned)type) {
2592 if (type == OP_LIST) { /* already a PUSHMARK there */
2593 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2594 ((LISTOP*)last)->op_first->op_sibling = first;
2595 if (!(first->op_flags & OPf_PARENS))
2596 last->op_flags &= ~OPf_PARENS;
2599 if (!(last->op_flags & OPf_KIDS)) {
2600 ((LISTOP*)last)->op_last = first;
2601 last->op_flags |= OPf_KIDS;
2603 first->op_sibling = ((LISTOP*)last)->op_first;
2604 ((LISTOP*)last)->op_first = first;
2606 last->op_flags |= OPf_KIDS;
2610 return newLISTOP(type, 0, first, last);
2618 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2621 Newxz(tk, 1, TOKEN);
2622 tk->tk_type = (OPCODE)optype;
2623 tk->tk_type = 12345;
2625 tk->tk_mad = madprop;
2630 Perl_token_free(pTHX_ TOKEN* tk)
2632 if (tk->tk_type != 12345)
2634 mad_free(tk->tk_mad);
2639 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2643 if (tk->tk_type != 12345) {
2644 Perl_warner(aTHX_ packWARN(WARN_MISC),
2645 "Invalid TOKEN object ignored");
2652 /* faked up qw list? */
2654 tm->mad_type == MAD_SV &&
2655 SvPVX((SV*)tm->mad_val)[0] == 'q')
2662 /* pretend constant fold didn't happen? */
2663 if (mp->mad_key == 'f' &&
2664 (o->op_type == OP_CONST ||
2665 o->op_type == OP_GV) )
2667 token_getmad(tk,(OP*)mp->mad_val,slot);
2681 if (mp->mad_key == 'X')
2682 mp->mad_key = slot; /* just change the first one */
2692 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2701 /* pretend constant fold didn't happen? */
2702 if (mp->mad_key == 'f' &&
2703 (o->op_type == OP_CONST ||
2704 o->op_type == OP_GV) )
2706 op_getmad(from,(OP*)mp->mad_val,slot);
2713 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2716 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2722 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2731 /* pretend constant fold didn't happen? */
2732 if (mp->mad_key == 'f' &&
2733 (o->op_type == OP_CONST ||
2734 o->op_type == OP_GV) )
2736 op_getmad(from,(OP*)mp->mad_val,slot);
2743 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2746 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2750 PerlIO_printf(PerlIO_stderr(),
2751 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2757 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2775 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2779 addmad(tm, &(o->op_madprop), slot);
2783 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2804 Perl_newMADsv(pTHX_ char key, SV* sv)
2806 return newMADPROP(key, MAD_SV, sv, 0);
2810 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2813 Newxz(mp, 1, MADPROP);
2816 mp->mad_vlen = vlen;
2817 mp->mad_type = type;
2819 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2824 Perl_mad_free(pTHX_ MADPROP* mp)
2826 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2830 mad_free(mp->mad_next);
2831 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2832 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2833 switch (mp->mad_type) {
2837 Safefree((char*)mp->mad_val);
2840 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2841 op_free((OP*)mp->mad_val);
2844 sv_free((SV*)mp->mad_val);
2847 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2856 Perl_newNULLLIST(pTHX)
2858 return newOP(OP_STUB, 0);
2862 Perl_force_list(pTHX_ OP *o)
2864 if (!o || o->op_type != OP_LIST)
2865 o = newLISTOP(OP_LIST, 0, o, NULL);
2871 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2876 NewOp(1101, listop, 1, LISTOP);
2878 listop->op_type = (OPCODE)type;
2879 listop->op_ppaddr = PL_ppaddr[type];
2882 listop->op_flags = (U8)flags;
2886 else if (!first && last)
2889 first->op_sibling = last;
2890 listop->op_first = first;
2891 listop->op_last = last;
2892 if (type == OP_LIST) {
2893 OP* const pushop = newOP(OP_PUSHMARK, 0);
2894 pushop->op_sibling = first;
2895 listop->op_first = pushop;
2896 listop->op_flags |= OPf_KIDS;
2898 listop->op_last = pushop;
2901 return CHECKOP(type, listop);
2905 Perl_newOP(pTHX_ I32 type, I32 flags)
2909 NewOp(1101, o, 1, OP);
2910 o->op_type = (OPCODE)type;
2911 o->op_ppaddr = PL_ppaddr[type];
2912 o->op_flags = (U8)flags;
2914 o->op_latefreed = 0;
2918 o->op_private = (U8)(0 | (flags >> 8));
2919 if (PL_opargs[type] & OA_RETSCALAR)
2921 if (PL_opargs[type] & OA_TARGET)
2922 o->op_targ = pad_alloc(type, SVs_PADTMP);
2923 return CHECKOP(type, o);
2927 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2933 first = newOP(OP_STUB, 0);
2934 if (PL_opargs[type] & OA_MARK)
2935 first = force_list(first);
2937 NewOp(1101, unop, 1, UNOP);
2938 unop->op_type = (OPCODE)type;
2939 unop->op_ppaddr = PL_ppaddr[type];
2940 unop->op_first = first;
2941 unop->op_flags = (U8)(flags | OPf_KIDS);
2942 unop->op_private = (U8)(1 | (flags >> 8));
2943 unop = (UNOP*) CHECKOP(type, unop);
2947 return fold_constants((OP *) unop);
2951 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2955 NewOp(1101, binop, 1, BINOP);
2958 first = newOP(OP_NULL, 0);
2960 binop->op_type = (OPCODE)type;
2961 binop->op_ppaddr = PL_ppaddr[type];
2962 binop->op_first = first;
2963 binop->op_flags = (U8)(flags | OPf_KIDS);
2966 binop->op_private = (U8)(1 | (flags >> 8));
2969 binop->op_private = (U8)(2 | (flags >> 8));
2970 first->op_sibling = last;
2973 binop = (BINOP*)CHECKOP(type, binop);
2974 if (binop->op_next || binop->op_type != (OPCODE)type)
2977 binop->op_last = binop->op_first->op_sibling;
2979 return fold_constants((OP *)binop);
2982 static int uvcompare(const void *a, const void *b)
2983 __attribute__nonnull__(1)
2984 __attribute__nonnull__(2)
2985 __attribute__pure__;
2986 static int uvcompare(const void *a, const void *b)
2988 if (*((const UV *)a) < (*(const UV *)b))
2990 if (*((const UV *)a) > (*(const UV *)b))
2992 if (*((const UV *)a+1) < (*(const UV *)b+1))
2994 if (*((const UV *)a+1) > (*(const UV *)b+1))
3000 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3003 SV * const tstr = ((SVOP*)expr)->op_sv;
3006 (repl->op_type == OP_NULL)
3007 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3009 ((SVOP*)repl)->op_sv;
3012 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3013 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3017 register short *tbl;
3019 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3020 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3021 I32 del = o->op_private & OPpTRANS_DELETE;
3023 PL_hints |= HINT_BLOCK_SCOPE;
3026 o->op_private |= OPpTRANS_FROM_UTF;
3029 o->op_private |= OPpTRANS_TO_UTF;
3031 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3032 SV* const listsv = newSVpvs("# comment\n");
3034 const U8* tend = t + tlen;
3035 const U8* rend = r + rlen;
3049 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3050 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3053 const U32 flags = UTF8_ALLOW_DEFAULT;
3057 t = tsave = bytes_to_utf8(t, &len);
3060 if (!to_utf && rlen) {
3062 r = rsave = bytes_to_utf8(r, &len);
3066 /* There are several snags with this code on EBCDIC:
3067 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3068 2. scan_const() in toke.c has encoded chars in native encoding which makes
3069 ranges at least in EBCDIC 0..255 range the bottom odd.
3073 U8 tmpbuf[UTF8_MAXBYTES+1];
3076 Newx(cp, 2*tlen, UV);
3078 transv = newSVpvs("");
3080 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3082 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3084 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3088 cp[2*i+1] = cp[2*i];
3092 qsort(cp, i, 2*sizeof(UV), uvcompare);
3093 for (j = 0; j < i; j++) {
3095 diff = val - nextmin;
3097 t = uvuni_to_utf8(tmpbuf,nextmin);
3098 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3100 U8 range_mark = UTF_TO_NATIVE(0xff);
3101 t = uvuni_to_utf8(tmpbuf, val - 1);
3102 sv_catpvn(transv, (char *)&range_mark, 1);
3103 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3110 t = uvuni_to_utf8(tmpbuf,nextmin);
3111 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3113 U8 range_mark = UTF_TO_NATIVE(0xff);
3114 sv_catpvn(transv, (char *)&range_mark, 1);
3116 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3117 UNICODE_ALLOW_SUPER);
3118 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3119 t = (const U8*)SvPVX_const(transv);
3120 tlen = SvCUR(transv);
3124 else if (!rlen && !del) {
3125 r = t; rlen = tlen; rend = tend;
3128 if ((!rlen && !del) || t == r ||
3129 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3131 o->op_private |= OPpTRANS_IDENTICAL;
3135 while (t < tend || tfirst <= tlast) {
3136 /* see if we need more "t" chars */
3137 if (tfirst > tlast) {
3138 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3140 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3142 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3149 /* now see if we need more "r" chars */
3150 if (rfirst > rlast) {
3152 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3154 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3156 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3165 rfirst = rlast = 0xffffffff;
3169 /* now see which range will peter our first, if either. */
3170 tdiff = tlast - tfirst;
3171 rdiff = rlast - rfirst;
3178 if (rfirst == 0xffffffff) {
3179 diff = tdiff; /* oops, pretend rdiff is infinite */
3181 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3182 (long)tfirst, (long)tlast);
3184 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3188 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3189 (long)tfirst, (long)(tfirst + diff),
3192 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3193 (long)tfirst, (long)rfirst);
3195 if (rfirst + diff > max)
3196 max = rfirst + diff;
3198 grows = (tfirst < rfirst &&
3199 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3211 else if (max > 0xff)
3216 PerlMemShared_free(cPVOPo->op_pv);
3217 cPVOPo->op_pv = NULL;
3219 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3221 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3222 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3223 PAD_SETSV(cPADOPo->op_padix, swash);
3226 cSVOPo->op_sv = swash;
3228 SvREFCNT_dec(listsv);
3229 SvREFCNT_dec(transv);
3231 if (!del && havefinal && rlen)
3232 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3233 newSVuv((UV)final), 0);
3236 o->op_private |= OPpTRANS_GROWS;
3242 op_getmad(expr,o,'e');
3243 op_getmad(repl,o,'r');
3251 tbl = (short*)cPVOPo->op_pv;
3253 Zero(tbl, 256, short);
3254 for (i = 0; i < (I32)tlen; i++)
3256 for (i = 0, j = 0; i < 256; i++) {
3258 if (j >= (I32)rlen) {
3267 if (i < 128 && r[j] >= 128)
3277 o->op_private |= OPpTRANS_IDENTICAL;
3279 else if (j >= (I32)rlen)
3284 PerlMemShared_realloc(tbl,
3285 (0x101+rlen-j) * sizeof(short));
3286 cPVOPo->op_pv = (char*)tbl;
3288 tbl[0x100] = (short)(rlen - j);
3289 for (i=0; i < (I32)rlen - j; i++)
3290 tbl[0x101+i] = r[j+i];
3294 if (!rlen && !del) {
3297 o->op_private |= OPpTRANS_IDENTICAL;
3299 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3300 o->op_private |= OPpTRANS_IDENTICAL;
3302 for (i = 0; i < 256; i++)
3304 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3305 if (j >= (I32)rlen) {
3307 if (tbl[t[i]] == -1)
3313 if (tbl[t[i]] == -1) {
3314 if (t[i] < 128 && r[j] >= 128)
3321 o->op_private |= OPpTRANS_GROWS;
3323 op_getmad(expr,o,'e');
3324 op_getmad(repl,o,'r');
3334 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3339 NewOp(1101, pmop, 1, PMOP);
3340 pmop->op_type = (OPCODE)type;
3341 pmop->op_ppaddr = PL_ppaddr[type];
3342 pmop->op_flags = (U8)flags;
3343 pmop->op_private = (U8)(0 | (flags >> 8));
3345 if (PL_hints & HINT_RE_TAINT)
3346 pmop->op_pmflags |= PMf_RETAINT;
3347 if (PL_hints & HINT_LOCALE)
3348 pmop->op_pmflags |= PMf_LOCALE;
3352 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3353 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3354 pmop->op_pmoffset = SvIV(repointer);
3355 SvREPADTMP_off(repointer);
3356 sv_setiv(repointer,0);
3358 SV * const repointer = newSViv(0);
3359 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3360 pmop->op_pmoffset = av_len(PL_regex_padav);
3361 PL_regex_pad = AvARRAY(PL_regex_padav);
3365 return CHECKOP(type, pmop);
3368 /* Given some sort of match op o, and an expression expr containing a
3369 * pattern, either compile expr into a regex and attach it to o (if it's
3370 * constant), or convert expr into a runtime regcomp op sequence (if it's
3373 * isreg indicates that the pattern is part of a regex construct, eg
3374 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3375 * split "pattern", which aren't. In the former case, expr will be a list
3376 * if the pattern contains more than one term (eg /a$b/) or if it contains
3377 * a replacement, ie s/// or tr///.
3381 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3386 I32 repl_has_vars = 0;
3390 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3391 /* last element in list is the replacement; pop it */
3393 repl = cLISTOPx(expr)->op_last;
3394 kid = cLISTOPx(expr)->op_first;
3395 while (kid->op_sibling != repl)
3396 kid = kid->op_sibling;
3397 kid->op_sibling = NULL;
3398 cLISTOPx(expr)->op_last = kid;
3401 if (isreg && expr->op_type == OP_LIST &&
3402 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3404 /* convert single element list to element */
3405 OP* const oe = expr;
3406 expr = cLISTOPx(oe)->op_first->op_sibling;
3407 cLISTOPx(oe)->op_first->op_sibling = NULL;
3408 cLISTOPx(oe)->op_last = NULL;
3412 if (o->op_type == OP_TRANS) {
3413 return pmtrans(o, expr, repl);
3416 reglist = isreg && expr->op_type == OP_LIST;
3420 PL_hints |= HINT_BLOCK_SCOPE;
3423 if (expr->op_type == OP_CONST) {
3425 SV * const pat = ((SVOP*)expr)->op_sv;
3426 const char *p = SvPV_const(pat, plen);
3427 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3428 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
3429 U32 was_readonly = SvREADONLY(pat);
3433 sv_force_normal_flags(pat, 0);
3434 assert(!SvREADONLY(pat));
3437 SvREADONLY_off(pat);
3441 sv_setpvn(pat, "\\s+", 3);
3443 SvFLAGS(pat) |= was_readonly;
3445 p = SvPV_const(pat, plen);
3446 pm_flags |= RXf_SKIPWHITE;
3449 pm_flags |= RXf_UTF8;
3450 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3453 op_getmad(expr,(OP*)pm,'e');
3459 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3460 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3462 : OP_REGCMAYBE),0,expr);
3464 NewOp(1101, rcop, 1, LOGOP);
3465 rcop->op_type = OP_REGCOMP;
3466 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3467 rcop->op_first = scalar(expr);
3468 rcop->op_flags |= OPf_KIDS
3469 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3470 | (reglist ? OPf_STACKED : 0);
3471 rcop->op_private = 1;
3474 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3476 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3479 /* establish postfix order */
3480 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3482 rcop->op_next = expr;
3483 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3486 rcop->op_next = LINKLIST(expr);
3487 expr->op_next = (OP*)rcop;
3490 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3495 if (pm->op_pmflags & PMf_EVAL) {
3497 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3498 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3500 else if (repl->op_type == OP_CONST)
3504 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3505 if (curop->op_type == OP_SCOPE
3506 || curop->op_type == OP_LEAVE
3507 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3508 if (curop->op_type == OP_GV) {
3509 GV * const gv = cGVOPx_gv(curop);
3511 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3514 else if (curop->op_type == OP_RV2CV)
3516 else if (curop->op_type == OP_RV2SV ||
3517 curop->op_type == OP_RV2AV ||
3518 curop->op_type == OP_RV2HV ||
3519 curop->op_type == OP_RV2GV) {
3520 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3523 else if (curop->op_type == OP_PADSV ||
3524 curop->op_type == OP_PADAV ||
3525 curop->op_type == OP_PADHV ||
3526 curop->op_type == OP_PADANY)
3530 else if (curop->op_type == OP_PUSHRE)
3531 NOOP; /* Okay here, dangerous in newASSIGNOP */
3541 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3543 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3544 prepend_elem(o->op_type, scalar(repl), o);
3547 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3548 pm->op_pmflags |= PMf_MAYBE_CONST;
3550 NewOp(1101, rcop, 1, LOGOP);
3551 rcop->op_type = OP_SUBSTCONT;
3552 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3553 rcop->op_first = scalar(repl);
3554 rcop->op_flags |= OPf_KIDS;
3555 rcop->op_private = 1;
3558 /* establish postfix order */
3559 rcop->op_next = LINKLIST(repl);
3560 repl->op_next = (OP*)rcop;
3562 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3563 assert(!(pm->op_pmflags & PMf_ONCE));
3564 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3573 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3577 NewOp(1101, svop, 1, SVOP);
3578 svop->op_type = (OPCODE)type;
3579 svop->op_ppaddr = PL_ppaddr[type];
3581 svop->op_next = (OP*)svop;
3582 svop->op_flags = (U8)flags;
3583 if (PL_opargs[type] & OA_RETSCALAR)
3585 if (PL_opargs[type] & OA_TARGET)
3586 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3587 return CHECKOP(type, svop);
3592 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3596 NewOp(1101, padop, 1, PADOP);
3597 padop->op_type = (OPCODE)type;
3598 padop->op_ppaddr = PL_ppaddr[type];
3599 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3600 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3601 PAD_SETSV(padop->op_padix, sv);
3604 padop->op_next = (OP*)padop;
3605 padop->op_flags = (U8)flags;
3606 if (PL_opargs[type] & OA_RETSCALAR)
3608 if (PL_opargs[type] & OA_TARGET)
3609 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3610 return CHECKOP(type, padop);
3615 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3621 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3623 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3628 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3632 NewOp(1101, pvop, 1, PVOP);
3633 pvop->op_type = (OPCODE)type;
3634 pvop->op_ppaddr = PL_ppaddr[type];
3636 pvop->op_next = (OP*)pvop;
3637 pvop->op_flags = (U8)flags;
3638 if (PL_opargs[type] & OA_RETSCALAR)
3640 if (PL_opargs[type] & OA_TARGET)
3641 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3642 return CHECKOP(type, pvop);
3650 Perl_package(pTHX_ OP *o)
3653 SV *const sv = cSVOPo->op_sv;
3658 save_hptr(&PL_curstash);
3659 save_item(PL_curstname);
3661 PL_curstash = gv_stashsv(sv, GV_ADD);
3663 sv_setsv(PL_curstname, sv);
3665 PL_hints |= HINT_BLOCK_SCOPE;
3666 PL_parser->copline = NOLINE;
3667 PL_parser->expect = XSTATE;
3672 if (!PL_madskills) {
3677 pegop = newOP(OP_NULL,0);
3678 op_getmad(o,pegop,'P');
3688 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3695 OP *pegop = newOP(OP_NULL,0);
3698 if (idop->op_type != OP_CONST)
3699 Perl_croak(aTHX_ "Module name must be constant");
3702 op_getmad(idop,pegop,'U');
3707 SV * const vesv = ((SVOP*)version)->op_sv;
3710 op_getmad(version,pegop,'V');
3711 if (!arg && !SvNIOKp(vesv)) {
3718 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3719 Perl_croak(aTHX_ "Version number must be constant number");
3721 /* Make copy of idop so we don't free it twice */
3722 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3724 /* Fake up a method call to VERSION */
3725 meth = newSVpvs_share("VERSION");
3726 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3727 append_elem(OP_LIST,
3728 prepend_elem(OP_LIST, pack, list(version)),
3729 newSVOP(OP_METHOD_NAMED, 0, meth)));
3733 /* Fake up an import/unimport */
3734 if (arg && arg->op_type == OP_STUB) {
3736 op_getmad(arg,pegop,'S');
3737 imop = arg; /* no import on explicit () */
3739 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3740 imop = NULL; /* use 5.0; */
3742 idop->op_private |= OPpCONST_NOVER;
3748 op_getmad(arg,pegop,'A');
3750 /* Make copy of idop so we don't free it twice */
3751 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3753 /* Fake up a method call to import/unimport */
3755 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3756 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3757 append_elem(OP_LIST,
3758 prepend_elem(OP_LIST, pack, list(arg)),
3759 newSVOP(OP_METHOD_NAMED, 0, meth)));
3762 /* Fake up the BEGIN {}, which does its thing immediately. */
3764 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3767 append_elem(OP_LINESEQ,
3768 append_elem(OP_LINESEQ,
3769 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3770 newSTATEOP(0, NULL, veop)),
3771 newSTATEOP(0, NULL, imop) ));
3773 /* The "did you use incorrect case?" warning used to be here.
3774 * The problem is that on case-insensitive filesystems one
3775 * might get false positives for "use" (and "require"):
3776 * "use Strict" or "require CARP" will work. This causes
3777 * portability problems for the script: in case-strict
3778 * filesystems the script will stop working.
3780 * The "incorrect case" warning checked whether "use Foo"
3781 * imported "Foo" to your namespace, but that is wrong, too:
3782 * there is no requirement nor promise in the language that
3783 * a Foo.pm should or would contain anything in package "Foo".
3785 * There is very little Configure-wise that can be done, either:
3786 * the case-sensitivity of the build filesystem of Perl does not
3787 * help in guessing the case-sensitivity of the runtime environment.
3790 PL_hints |= HINT_BLOCK_SCOPE;
3791 PL_parser->copline = NOLINE;
3792 PL_parser->expect = XSTATE;
3793 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3796 if (!PL_madskills) {
3797 /* FIXME - don't allocate pegop if !PL_madskills */
3806 =head1 Embedding Functions
3808 =for apidoc load_module
3810 Loads the module whose name is pointed to by the string part of name.
3811 Note that the actual module name, not its filename, should be given.
3812 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3813 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3814 (or 0 for no flags). ver, if specified, provides version semantics
3815 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3816 arguments can be used to specify arguments to the module's import()
3817 method, similar to C<use Foo::Bar VERSION LIST>.
3822 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3825 va_start(args, ver);
3826 vload_module(flags, name, ver, &args);
3830 #ifdef PERL_IMPLICIT_CONTEXT
3832 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3836 va_start(args, ver);
3837 vload_module(flags, name, ver, &args);
3843 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3848 OP * const modname = newSVOP(OP_CONST, 0, name);
3849 modname->op_private |= OPpCONST_BARE;
3851 veop = newSVOP(OP_CONST, 0, ver);
3855 if (flags & PERL_LOADMOD_NOIMPORT) {
3856 imop = sawparens(newNULLLIST());
3858 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3859 imop = va_arg(*args, OP*);
3864 sv = va_arg(*args, SV*);
3866 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3867 sv = va_arg(*args, SV*);
3871 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3872 * that it has a PL_parser to play with while doing that, and also
3873 * that it doesn't mess with any existing parser, by creating a tmp
3874 * new parser with lex_start(). This won't actually be used for much,
3875 * since pp_require() will create another parser for the real work. */
3878 SAVEVPTR(PL_curcop);
3879 lex_start(NULL, NULL, FALSE);
3880 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3881 veop, modname, imop);
3886 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3892 if (!force_builtin) {
3893 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3894 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3895 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3896 gv = gvp ? *gvp : NULL;
3900 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3901 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3902 append_elem(OP_LIST, term,
3903 scalar(newUNOP(OP_RV2CV, 0,
3904 newGVOP(OP_GV, 0, gv))))));
3907 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3913 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3915 return newBINOP(OP_LSLICE, flags,
3916 list(force_list(subscript)),
3917 list(force_list(listval)) );
3921 S_is_list_assignment(pTHX_ register const OP *o)
3929 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3930 o = cUNOPo->op_first;
3932 flags = o->op_flags;
3934 if (type == OP_COND_EXPR) {
3935 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3936 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3941 yyerror("Assignment to both a list and a scalar");
3945 if (type == OP_LIST &&
3946 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3947 o->op_private & OPpLVAL_INTRO)
3950 if (type == OP_LIST || flags & OPf_PARENS ||
3951 type == OP_RV2AV || type == OP_RV2HV ||
3952 type == OP_ASLICE || type == OP_HSLICE)
3955 if (type == OP_PADAV || type == OP_PADHV)
3958 if (type == OP_RV2SV)
3965 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3971 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3972 return newLOGOP(optype, 0,
3973 mod(scalar(left), optype),
3974 newUNOP(OP_SASSIGN, 0, scalar(right)));
3977 return newBINOP(optype, OPf_STACKED,
3978 mod(scalar(left), optype), scalar(right));
3982 if (is_list_assignment(left)) {
3986 /* Grandfathering $[ assignment here. Bletch.*/
3987 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3988 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3989 left = mod(left, OP_AASSIGN);
3992 else if (left->op_type == OP_CONST) {
3994 /* Result of assignment is always 1 (or we'd be dead already) */
3995 return newSVOP(OP_CONST, 0, newSViv(1));
3997 curop = list(force_list(left));
3998 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3999 o->op_private = (U8)(0 | (flags >> 8));
4001 /* PL_generation sorcery:
4002 * an assignment like ($a,$b) = ($c,$d) is easier than
4003 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4004 * To detect whether there are common vars, the global var
4005 * PL_generation is incremented for each assign op we compile.
4006 * Then, while compiling the assign op, we run through all the
4007 * variables on both sides of the assignment, setting a spare slot
4008 * in each of them to PL_generation. If any of them already have
4009 * that value, we know we've got commonality. We could use a
4010 * single bit marker, but then we'd have to make 2 passes, first
4011 * to clear the flag, then to test and set it. To find somewhere
4012 * to store these values, evil chicanery is done with SvUVX().
4018 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4019 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4020 if (curop->op_type == OP_GV) {
4021 GV *gv = cGVOPx_gv(curop);
4023 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4025 GvASSIGN_GENERATION_set(gv, PL_generation);
4027 else if (curop->op_type == OP_PADSV ||
4028 curop->op_type == OP_PADAV ||
4029 curop->op_type == OP_PADHV ||
4030 curop->op_type == OP_PADANY)
4032 if (PAD_COMPNAME_GEN(curop->op_targ)
4033 == (STRLEN)PL_generation)
4035 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4038 else if (curop->op_type == OP_RV2CV)
4040 else if (curop->op_type == OP_RV2SV ||
4041 curop->op_type == OP_RV2AV ||
4042 curop->op_type == OP_RV2HV ||
4043 curop->op_type == OP_RV2GV) {
4044 if (lastop->op_type != OP_GV) /* funny deref? */
4047 else if (curop->op_type == OP_PUSHRE) {
4049 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4050 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4052 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4054 GvASSIGN_GENERATION_set(gv, PL_generation);
4058 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4061 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4063 GvASSIGN_GENERATION_set(gv, PL_generation);
4073 o->op_private |= OPpASSIGN_COMMON;
4076 if (right && right->op_type == OP_SPLIT) {
4077 OP* tmpop = ((LISTOP*)right)->op_first;
4078 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4079 PMOP * const pm = (PMOP*)tmpop;
4080 if (left->op_type == OP_RV2AV &&
4081 !(left->op_private & OPpLVAL_INTRO) &&
4082 !(o->op_private & OPpASSIGN_COMMON) )
4084 tmpop = ((UNOP*)left)->op_first;
4085 if (tmpop->op_type == OP_GV
4087 && !pm->op_pmreplrootu.op_pmtargetoff
4089 && !pm->op_pmreplrootu.op_pmtargetgv
4093 pm->op_pmreplrootu.op_pmtargetoff
4094 = cPADOPx(tmpop)->op_padix;
4095 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4097 pm->op_pmreplrootu.op_pmtargetgv
4098 = (GV*)cSVOPx(tmpop)->op_sv;
4099 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4101 pm->op_pmflags |= PMf_ONCE;
4102 tmpop = cUNOPo->op_first; /* to list (nulled) */
4103 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4104 tmpop->op_sibling = NULL; /* don't free split */
4105 right->op_next = tmpop->op_next; /* fix starting loc */
4107 op_getmad(o,right,'R'); /* blow off assign */
4109 op_free(o); /* blow off assign */
4111 right->op_flags &= ~OPf_WANT;
4112 /* "I don't know and I don't care." */
4117 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4118 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4120 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4122 sv_setiv(sv, PL_modcount+1);
4130 right = newOP(OP_UNDEF, 0);
4131 if (right->op_type == OP_READLINE) {
4132 right->op_flags |= OPf_STACKED;
4133 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4136 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4137 o = newBINOP(OP_SASSIGN, flags,
4138 scalar(right), mod(scalar(left), OP_SASSIGN) );
4144 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4145 o->op_private |= OPpCONST_ARYBASE;
4152 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4155 const U32 seq = intro_my();
4158 NewOp(1101, cop, 1, COP);
4159 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4160 cop->op_type = OP_DBSTATE;
4161 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4164 cop->op_type = OP_NEXTSTATE;
4165 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4167 cop->op_flags = (U8)flags;
4168 CopHINTS_set(cop, PL_hints);
4170 cop->op_private |= NATIVE_HINTS;
4172 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4173 cop->op_next = (OP*)cop;
4176 CopLABEL_set(cop, label);
4177 PL_hints |= HINT_BLOCK_SCOPE;
4180 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4181 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4183 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4184 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4185 if (cop->cop_hints_hash) {
4187 cop->cop_hints_hash->refcounted_he_refcnt++;
4188 HINTS_REFCNT_UNLOCK;
4191 if (PL_parser && PL_parser->copline == NOLINE)
4192 CopLINE_set(cop, CopLINE(PL_curcop));
4194 CopLINE_set(cop, PL_parser->copline);
4196 PL_parser->copline = NOLINE;
4199 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4201 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4203 CopSTASH_set(cop, PL_curstash);
4205 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4206 AV *av = CopFILEAVx(PL_curcop);
4208 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4209 if (svp && *svp != &PL_sv_undef ) {
4210 (void)SvIOK_on(*svp);
4211 SvIV_set(*svp, PTR2IV(cop));
4216 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4221 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4224 return new_logop(type, flags, &first, &other);
4228 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4233 OP *first = *firstp;
4234 OP * const other = *otherp;
4236 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4237 return newBINOP(type, flags, scalar(first), scalar(other));
4239 scalarboolean(first);
4240 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4241 if (first->op_type == OP_NOT
4242 && (first->op_flags & OPf_SPECIAL)
4243 && (first->op_flags & OPf_KIDS)) {
4244 if (type == OP_AND || type == OP_OR) {
4250 first = *firstp = cUNOPo->op_first;
4252 first->op_next = o->op_next;
4253 cUNOPo->op_first = NULL;
4255 op_getmad(o,first,'O');
4261 if (first->op_type == OP_CONST) {
4262 if (first->op_private & OPpCONST_STRICT)
4263 no_bareword_allowed(first);
4264 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4265 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4266 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4267 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4268 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4270 if (other->op_type == OP_CONST)
4271 other->op_private |= OPpCONST_SHORTCIRCUIT;
4273 OP *newop = newUNOP(OP_NULL, 0, other);
4274 op_getmad(first, newop, '1');
4275 newop->op_targ = type; /* set "was" field */
4282 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4283 const OP *o2 = other;
4284 if ( ! (o2->op_type == OP_LIST
4285 && (( o2 = cUNOPx(o2)->op_first))
4286 && o2->op_type == OP_PUSHMARK
4287 && (( o2 = o2->op_sibling)) )
4290 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4291 || o2->op_type == OP_PADHV)
4292 && o2->op_private & OPpLVAL_INTRO
4293 && ckWARN(WARN_DEPRECATED))
4295 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4296 "Deprecated use of my() in false conditional");
4300 if (first->op_type == OP_CONST)
4301 first->op_private |= OPpCONST_SHORTCIRCUIT;
4303 first = newUNOP(OP_NULL, 0, first);
4304 op_getmad(other, first, '2');
4305 first->op_targ = type; /* set "was" field */
4312 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4313 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4315 const OP * const k1 = ((UNOP*)first)->op_first;
4316 const OP * const k2 = k1->op_sibling;
4318 switch (first->op_type)
4321 if (k2 && k2->op_type == OP_READLINE
4322 && (k2->op_flags & OPf_STACKED)
4323 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4325 warnop = k2->op_type;
4330 if (k1->op_type == OP_READDIR
4331 || k1->op_type == OP_GLOB
4332 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4333 || k1->op_type == OP_EACH)
4335 warnop = ((k1->op_type == OP_NULL)
4336 ? (OPCODE)k1->op_targ : k1->op_type);
4341 const line_t oldline = CopLINE(PL_curcop);
4342 CopLINE_set(PL_curcop, PL_parser->copline);
4343 Perl_warner(aTHX_ packWARN(WARN_MISC),
4344 "Value of %s%s can be \"0\"; test with defined()",
4346 ((warnop == OP_READLINE || warnop == OP_GLOB)
4347 ? " construct" : "() operator"));
4348 CopLINE_set(PL_curcop, oldline);
4355 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4356 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4358 NewOp(1101, logop, 1, LOGOP);
4360 logop->op_type = (OPCODE)type;
4361 logop->op_ppaddr = PL_ppaddr[type];
4362 logop->op_first = first;
4363 logop->op_flags = (U8)(flags | OPf_KIDS);
4364 logop->op_other = LINKLIST(other);
4365 logop->op_private = (U8)(1 | (flags >> 8));
4367 /* establish postfix order */
4368 logop->op_next = LINKLIST(first);
4369 first->op_next = (OP*)logop;
4370 first->op_sibling = other;
4372 CHECKOP(type,logop);
4374 o = newUNOP(OP_NULL, 0, (OP*)logop);
4381 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4389 return newLOGOP(OP_AND, 0, first, trueop);
4391 return newLOGOP(OP_OR, 0, first, falseop);
4393 scalarboolean(first);
4394 if (first->op_type == OP_CONST) {
4395 /* Left or right arm of the conditional? */
4396 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4397 OP *live = left ? trueop : falseop;
4398 OP *const dead = left ? falseop : trueop;
4399 if (first->op_private & OPpCONST_BARE &&
4400 first->op_private & OPpCONST_STRICT) {
4401 no_bareword_allowed(first);
4404 /* This is all dead code when PERL_MAD is not defined. */
4405 live = newUNOP(OP_NULL, 0, live);
4406 op_getmad(first, live, 'C');
4407 op_getmad(dead, live, left ? 'e' : 't');
4414 NewOp(1101, logop, 1, LOGOP);
4415 logop->op_type = OP_COND_EXPR;
4416 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4417 logop->op_first = first;
4418 logop->op_flags = (U8)(flags | OPf_KIDS);
4419 logop->op_private = (U8)(1 | (flags >> 8));
4420 logop->op_other = LINKLIST(trueop);
4421 logop->op_next = LINKLIST(falseop);
4423 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4426 /* establish postfix order */
4427 start = LINKLIST(first);
4428 first->op_next = (OP*)logop;
4430 first->op_sibling = trueop;
4431 trueop->op_sibling = falseop;
4432 o = newUNOP(OP_NULL, 0, (OP*)logop);
4434 trueop->op_next = falseop->op_next = o;
4441 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4450 NewOp(1101, range, 1, LOGOP);
4452 range->op_type = OP_RANGE;
4453 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4454 range->op_first = left;
4455 range->op_flags = OPf_KIDS;
4456 leftstart = LINKLIST(left);
4457 range->op_other = LINKLIST(right);
4458 range->op_private = (U8)(1 | (flags >> 8));
4460 left->op_sibling = right;
4462 range->op_next = (OP*)range;
4463 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4464 flop = newUNOP(OP_FLOP, 0, flip);
4465 o = newUNOP(OP_NULL, 0, flop);
4467 range->op_next = leftstart;
4469 left->op_next = flip;
4470 right->op_next = flop;
4472 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4473 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4474 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4475 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4477 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4478 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4481 if (!flip->op_private || !flop->op_private)
4482 linklist(o); /* blow off optimizer unless constant */
4488 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4493 const bool once = block && block->op_flags & OPf_SPECIAL &&
4494 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4496 PERL_UNUSED_ARG(debuggable);
4499 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4500 return block; /* do {} while 0 does once */
4501 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4502 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4503 expr = newUNOP(OP_DEFINED, 0,
4504 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4505 } else if (expr->op_flags & OPf_KIDS) {
4506 const OP * const k1 = ((UNOP*)expr)->op_first;
4507 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4508 switch (expr->op_type) {
4510 if (k2 && k2->op_type == OP_READLINE
4511 && (k2->op_flags & OPf_STACKED)
4512 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4513 expr = newUNOP(OP_DEFINED, 0, expr);
4517 if (k1 && (k1->op_type == OP_READDIR
4518 || k1->op_type == OP_GLOB
4519 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4520 || k1->op_type == OP_EACH))
4521 expr = newUNOP(OP_DEFINED, 0, expr);
4527 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4528 * op, in listop. This is wrong. [perl #27024] */
4530 block = newOP(OP_NULL, 0);
4531 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4532 o = new_logop(OP_AND, 0, &expr, &listop);
4535 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4537 if (once && o != listop)
4538 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4541 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4543 o->op_flags |= flags;
4545 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4550 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4551 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4560 PERL_UNUSED_ARG(debuggable);
4563 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4564 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4565 expr = newUNOP(OP_DEFINED, 0,
4566 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4567 } else if (expr->op_flags & OPf_KIDS) {
4568 const OP * const k1 = ((UNOP*)expr)->op_first;
4569 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4570 switch (expr->op_type) {
4572 if (k2 && k2->op_type == OP_READLINE
4573 && (k2->op_flags & OPf_STACKED)
4574 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4575 expr = newUNOP(OP_DEFINED, 0, expr);
4579 if (k1 && (k1->op_type == OP_READDIR
4580 || k1->op_type == OP_GLOB
4581 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4582 || k1->op_type == OP_EACH))
4583 expr = newUNOP(OP_DEFINED, 0, expr);
4590 block = newOP(OP_NULL, 0);
4591 else if (cont || has_my) {
4592 block = scope(block);
4596 next = LINKLIST(cont);
4599 OP * const unstack = newOP(OP_UNSTACK, 0);
4602 cont = append_elem(OP_LINESEQ, cont, unstack);
4606 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4608 redo = LINKLIST(listop);
4611 PL_parser->copline = (line_t)whileline;
4613 o = new_logop(OP_AND, 0, &expr, &listop);
4614 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4615 op_free(expr); /* oops, it's a while (0) */
4617 return NULL; /* listop already freed by new_logop */
4620 ((LISTOP*)listop)->op_last->op_next =
4621 (o == listop ? redo : LINKLIST(o));
4627 NewOp(1101,loop,1,LOOP);
4628 loop->op_type = OP_ENTERLOOP;
4629 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4630 loop->op_private = 0;
4631 loop->op_next = (OP*)loop;
4634 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4636 loop->op_redoop = redo;
4637 loop->op_lastop = o;
4638 o->op_private |= loopflags;
4641 loop->op_nextop = next;
4643 loop->op_nextop = o;
4645 o->op_flags |= flags;
4646 o->op_private |= (flags >> 8);
4651 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4656 PADOFFSET padoff = 0;
4662 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4663 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4664 sv->op_type = OP_RV2GV;
4665 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4667 /* The op_type check is needed to prevent a possible segfault
4668 * if the loop variable is undeclared and 'strict vars' is in
4669 * effect. This is illegal but is nonetheless parsed, so we
4670 * may reach this point with an OP_CONST where we're expecting
4673 if (cUNOPx(sv)->op_first->op_type == OP_GV
4674 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4675 iterpflags |= OPpITER_DEF;
4677 else if (sv->op_type == OP_PADSV) { /* private variable */
4678 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4679 padoff = sv->op_targ;
4689 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4691 SV *const namesv = PAD_COMPNAME_SV(padoff);
4693 const char *const name = SvPV_const(namesv, len);
4695 if (len == 2 && name[0] == '$' && name[1] == '_')
4696 iterpflags |= OPpITER_DEF;
4700 const PADOFFSET offset = pad_findmy("$_");
4701 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4702 sv = newGVOP(OP_GV, 0, PL_defgv);
4707 iterpflags |= OPpITER_DEF;
4709 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4710 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4711 iterflags |= OPf_STACKED;
4713 else if (expr->op_type == OP_NULL &&
4714 (expr->op_flags & OPf_KIDS) &&
4715 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4717 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4718 * set the STACKED flag to indicate that these values are to be
4719 * treated as min/max values by 'pp_iterinit'.
4721 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4722 LOGOP* const range = (LOGOP*) flip->op_first;
4723 OP* const left = range->op_first;
4724 OP* const right = left->op_sibling;
4727 range->op_flags &= ~OPf_KIDS;
4728 range->op_first = NULL;
4730 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4731 listop->op_first->op_next = range->op_next;
4732 left->op_next = range->op_other;
4733 right->op_next = (OP*)listop;
4734 listop->op_next = listop->op_first;
4737 op_getmad(expr,(OP*)listop,'O');
4741 expr = (OP*)(listop);
4743 iterflags |= OPf_STACKED;
4746 expr = mod(force_list(expr), OP_GREPSTART);
4749 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4750 append_elem(OP_LIST, expr, scalar(sv))));
4751 assert(!loop->op_next);
4752 /* for my $x () sets OPpLVAL_INTRO;
4753 * for our $x () sets OPpOUR_INTRO */
4754 loop->op_private = (U8)iterpflags;
4755 #ifdef PL_OP_SLAB_ALLOC
4758 NewOp(1234,tmp,1,LOOP);
4759 Copy(loop,tmp,1,LISTOP);
4760 S_op_destroy(aTHX_ (OP*)loop);
4764 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4766 loop->op_targ = padoff;
4767 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4769 op_getmad(madsv, (OP*)loop, 'v');
4770 PL_parser->copline = forline;
4771 return newSTATEOP(0, label, wop);
4775 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4780 if (type != OP_GOTO || label->op_type == OP_CONST) {
4781 /* "last()" means "last" */
4782 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4783 o = newOP(type, OPf_SPECIAL);
4785 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4786 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4790 op_getmad(label,o,'L');
4796 /* Check whether it's going to be a goto &function */
4797 if (label->op_type == OP_ENTERSUB
4798 && !(label->op_flags & OPf_STACKED))
4799 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4800 o = newUNOP(type, OPf_STACKED, label);
4802 PL_hints |= HINT_BLOCK_SCOPE;
4806 /* if the condition is a literal array or hash
4807 (or @{ ... } etc), make a reference to it.
4810 S_ref_array_or_hash(pTHX_ OP *cond)
4813 && (cond->op_type == OP_RV2AV
4814 || cond->op_type == OP_PADAV
4815 || cond->op_type == OP_RV2HV
4816 || cond->op_type == OP_PADHV))
4818 return newUNOP(OP_REFGEN,
4819 0, mod(cond, OP_REFGEN));
4825 /* These construct the optree fragments representing given()
4828 entergiven and enterwhen are LOGOPs; the op_other pointer
4829 points up to the associated leave op. We need this so we
4830 can put it in the context and make break/continue work.
4831 (Also, of course, pp_enterwhen will jump straight to
4832 op_other if the match fails.)
4836 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4837 I32 enter_opcode, I32 leave_opcode,
4838 PADOFFSET entertarg)
4844 NewOp(1101, enterop, 1, LOGOP);
4845 enterop->op_type = enter_opcode;
4846 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4847 enterop->op_flags = (U8) OPf_KIDS;
4848 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4849 enterop->op_private = 0;
4851 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4854 enterop->op_first = scalar(cond);
4855 cond->op_sibling = block;
4857 o->op_next = LINKLIST(cond);
4858 cond->op_next = (OP *) enterop;
4861 /* This is a default {} block */
4862 enterop->op_first = block;
4863 enterop->op_flags |= OPf_SPECIAL;
4865 o->op_next = (OP *) enterop;
4868 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4869 entergiven and enterwhen both
4872 enterop->op_next = LINKLIST(block);
4873 block->op_next = enterop->op_other = o;
4878 /* Does this look like a boolean operation? For these purposes
4879 a boolean operation is:
4880 - a subroutine call [*]
4881 - a logical connective
4882 - a comparison operator
4883 - a filetest operator, with the exception of -s -M -A -C
4884 - defined(), exists() or eof()
4885 - /$re/ or $foo =~ /$re/
4887 [*] possibly surprising
4890 S_looks_like_bool(pTHX_ const OP *o)
4893 switch(o->op_type) {
4895 return looks_like_bool(cLOGOPo->op_first);
4899 looks_like_bool(cLOGOPo->op_first)
4900 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4904 case OP_NOT: case OP_XOR:
4905 /* Note that OP_DOR is not here */
4907 case OP_EQ: case OP_NE: case OP_LT:
4908 case OP_GT: case OP_LE: case OP_GE:
4910 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4911 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4913 case OP_SEQ: case OP_SNE: case OP_SLT:
4914 case OP_SGT: case OP_SLE: case OP_SGE:
4918 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4919 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4920 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4921 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4922 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4923 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4924 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4925 case OP_FTTEXT: case OP_FTBINARY:
4927 case OP_DEFINED: case OP_EXISTS:
4928 case OP_MATCH: case OP_EOF:
4933 /* Detect comparisons that have been optimized away */
4934 if (cSVOPo->op_sv == &PL_sv_yes
4935 || cSVOPo->op_sv == &PL_sv_no)
4946 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4950 return newGIVWHENOP(
4951 ref_array_or_hash(cond),
4953 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4957 /* If cond is null, this is a default {} block */
4959 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4961 const bool cond_llb = (!cond || looks_like_bool(cond));
4967 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4969 scalar(ref_array_or_hash(cond)));
4972 return newGIVWHENOP(
4974 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4975 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4979 =for apidoc cv_undef
4981 Clear out all the active components of a CV. This can happen either
4982 by an explicit C<undef &foo>, or by the reference count going to zero.
4983 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4984 children can still follow the full lexical scope chain.
4990 Perl_cv_undef(pTHX_ CV *cv)
4994 if (CvFILE(cv) && !CvISXSUB(cv)) {
4995 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4996 Safefree(CvFILE(cv));
5001 if (!CvISXSUB(cv) && CvROOT(cv)) {
5002 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5003 Perl_croak(aTHX_ "Can't undef active subroutine");
5006 PAD_SAVE_SETNULLPAD();
5008 op_free(CvROOT(cv));
5013 SvPOK_off((SV*)cv); /* forget prototype */
5018 /* remove CvOUTSIDE unless this is an undef rather than a free */
5019 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5020 if (!CvWEAKOUTSIDE(cv))
5021 SvREFCNT_dec(CvOUTSIDE(cv));
5022 CvOUTSIDE(cv) = NULL;
5025 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5028 if (CvISXSUB(cv) && CvXSUB(cv)) {
5031 /* delete all flags except WEAKOUTSIDE */
5032 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5036 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5039 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5040 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5041 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5042 || (p && (len != SvCUR(cv) /* Not the same length. */
5043 || memNE(p, SvPVX_const(cv), len))))
5044 && ckWARN_d(WARN_PROTOTYPE)) {
5045 SV* const msg = sv_newmortal();
5049 gv_efullname3(name = sv_newmortal(), gv, NULL);
5050 sv_setpvs(msg, "Prototype mismatch:");
5052 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5054 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5056 sv_catpvs(msg, ": none");
5057 sv_catpvs(msg, " vs ");
5059 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5061 sv_catpvs(msg, "none");
5062 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5066 static void const_sv_xsub(pTHX_ CV* cv);
5070 =head1 Optree Manipulation Functions
5072 =for apidoc cv_const_sv
5074 If C<cv> is a constant sub eligible for inlining. returns the constant
5075 value returned by the sub. Otherwise, returns NULL.
5077 Constant subs can be created with C<newCONSTSUB> or as described in
5078 L<perlsub/"Constant Functions">.
5083 Perl_cv_const_sv(pTHX_ CV *cv)
5085 PERL_UNUSED_CONTEXT;
5088 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5090 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5093 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5094 * Can be called in 3 ways:
5097 * look for a single OP_CONST with attached value: return the value
5099 * cv && CvCLONE(cv) && !CvCONST(cv)
5101 * examine the clone prototype, and if contains only a single
5102 * OP_CONST referencing a pad const, or a single PADSV referencing
5103 * an outer lexical, return a non-zero value to indicate the CV is
5104 * a candidate for "constizing" at clone time
5108 * We have just cloned an anon prototype that was marked as a const
5109 * candidiate. Try to grab the current value, and in the case of
5110 * PADSV, ignore it if it has multiple references. Return the value.
5114 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5122 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5123 o = cLISTOPo->op_first->op_sibling;
5125 for (; o; o = o->op_next) {
5126 const OPCODE type = o->op_type;
5128 if (sv && o->op_next == o)
5130 if (o->op_next != o) {
5131 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5133 if (type == OP_DBSTATE)
5136 if (type == OP_LEAVESUB || type == OP_RETURN)
5140 if (type == OP_CONST && cSVOPo->op_sv)
5142 else if (cv && type == OP_CONST) {
5143 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5147 else if (cv && type == OP_PADSV) {
5148 if (CvCONST(cv)) { /* newly cloned anon */
5149 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5150 /* the candidate should have 1 ref from this pad and 1 ref
5151 * from the parent */
5152 if (!sv || SvREFCNT(sv) != 2)
5159 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5160 sv = &PL_sv_undef; /* an arbitrary non-null value */
5175 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5178 /* This would be the return value, but the return cannot be reached. */
5179 OP* pegop = newOP(OP_NULL, 0);
5182 PERL_UNUSED_ARG(floor);
5192 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5194 NORETURN_FUNCTION_END;
5199 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5201 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5205 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5212 register CV *cv = NULL;
5214 /* If the subroutine has no body, no attributes, and no builtin attributes
5215 then it's just a sub declaration, and we may be able to get away with
5216 storing with a placeholder scalar in the symbol table, rather than a
5217 full GV and CV. If anything is present then it will take a full CV to
5219 const I32 gv_fetch_flags
5220 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5222 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5223 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5226 assert(proto->op_type == OP_CONST);
5227 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5232 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5233 SV * const sv = sv_newmortal();
5234 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5235 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5236 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5237 aname = SvPVX_const(sv);
5242 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5243 : gv_fetchpv(aname ? aname
5244 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5245 gv_fetch_flags, SVt_PVCV);
5247 if (!PL_madskills) {
5256 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5257 maximum a prototype before. */
5258 if (SvTYPE(gv) > SVt_NULL) {
5259 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5260 && ckWARN_d(WARN_PROTOTYPE))
5262 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5264 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5267 sv_setpvn((SV*)gv, ps, ps_len);
5269 sv_setiv((SV*)gv, -1);
5271 SvREFCNT_dec(PL_compcv);
5272 cv = PL_compcv = NULL;
5276 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5278 #ifdef GV_UNIQUE_CHECK
5279 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5280 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5284 if (!block || !ps || *ps || attrs
5285 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5287 || block->op_type == OP_NULL
5292 const_sv = op_const_sv(block, NULL);
5295 const bool exists = CvROOT(cv) || CvXSUB(cv);
5297 #ifdef GV_UNIQUE_CHECK
5298 if (exists && GvUNIQUE(gv)) {
5299 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5303 /* if the subroutine doesn't exist and wasn't pre-declared
5304 * with a prototype, assume it will be AUTOLOADed,
5305 * skipping the prototype check
5307 if (exists || SvPOK(cv))
5308 cv_ckproto_len(cv, gv, ps, ps_len);
5309 /* already defined (or promised)? */
5310 if (exists || GvASSUMECV(gv)) {
5313 || block->op_type == OP_NULL
5316 if (CvFLAGS(PL_compcv)) {
5317 /* might have had built-in attrs applied */
5318 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5320 /* just a "sub foo;" when &foo is already defined */
5321 SAVEFREESV(PL_compcv);
5326 && block->op_type != OP_NULL
5329 if (ckWARN(WARN_REDEFINE)
5331 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5333 const line_t oldline = CopLINE(PL_curcop);
5334 if (PL_parser && PL_parser->copline != NOLINE)
5335 CopLINE_set(PL_curcop, PL_parser->copline);
5336 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5337 CvCONST(cv) ? "Constant subroutine %s redefined"
5338 : "Subroutine %s redefined", name);
5339 CopLINE_set(PL_curcop, oldline);
5342 if (!PL_minus_c) /* keep old one around for madskills */
5345 /* (PL_madskills unset in used file.) */
5353 SvREFCNT_inc_simple_void_NN(const_sv);
5355 assert(!CvROOT(cv) && !CvCONST(cv));
5356 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5357 CvXSUBANY(cv).any_ptr = const_sv;
5358 CvXSUB(cv) = const_sv_xsub;
5364 cv = newCONSTSUB(NULL, name, const_sv);
5366 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5367 (CvGV(cv) && GvSTASH(CvGV(cv)))
5376 SvREFCNT_dec(PL_compcv);
5384 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5385 * before we clobber PL_compcv.
5389 || block->op_type == OP_NULL
5393 /* Might have had built-in attributes applied -- propagate them. */
5394 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5395 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5396 stash = GvSTASH(CvGV(cv));
5397 else if (CvSTASH(cv))
5398 stash = CvSTASH(cv);
5400 stash = PL_curstash;
5403 /* possibly about to re-define existing subr -- ignore old cv */
5404 rcv = (SV*)PL_compcv;
5405 if (name && GvSTASH(gv))
5406 stash = GvSTASH(gv);
5408 stash = PL_curstash;
5410 apply_attrs(stash, rcv, attrs, FALSE);
5412 if (cv) { /* must reuse cv if autoloaded */
5419 || block->op_type == OP_NULL) && !PL_madskills
5422 /* got here with just attrs -- work done, so bug out */
5423 SAVEFREESV(PL_compcv);
5426 /* transfer PL_compcv to cv */
5428 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5429 if (!CvWEAKOUTSIDE(cv))
5430 SvREFCNT_dec(CvOUTSIDE(cv));
5431 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5432 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5433 CvOUTSIDE(PL_compcv) = 0;
5434 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5435 CvPADLIST(PL_compcv) = 0;
5436 /* inner references to PL_compcv must be fixed up ... */
5437 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5438 /* ... before we throw it away */
5439 SvREFCNT_dec(PL_compcv);
5441 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5442 ++PL_sub_generation;
5449 if (strEQ(name, "import")) {
5450 PL_formfeed = (SV*)cv;
5451 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5455 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5459 CvFILE_set_from_cop(cv, PL_curcop);
5460 CvSTASH(cv) = PL_curstash;
5463 sv_setpvn((SV*)cv, ps, ps_len);
5465 if (PL_error_count) {
5469 const char *s = strrchr(name, ':');
5471 if (strEQ(s, "BEGIN")) {
5472 const char not_safe[] =
5473 "BEGIN not safe after errors--compilation aborted";
5474 if (PL_in_eval & EVAL_KEEPERR)
5475 Perl_croak(aTHX_ not_safe);
5477 /* force display of errors found but not reported */
5478 sv_catpv(ERRSV, not_safe);
5479 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5489 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5490 mod(scalarseq(block), OP_LEAVESUBLV));
5491 block->op_attached = 1;
5494 /* This makes sub {}; work as expected. */
5495 if (block->op_type == OP_STUB) {
5496 OP* const newblock = newSTATEOP(0, NULL, 0);
5498 op_getmad(block,newblock,'B');
5505 block->op_attached = 1;
5506 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5508 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5509 OpREFCNT_set(CvROOT(cv), 1);
5510 CvSTART(cv) = LINKLIST(CvROOT(cv));
5511 CvROOT(cv)->op_next = 0;
5512 CALL_PEEP(CvSTART(cv));
5514 /* now that optimizer has done its work, adjust pad values */
5516 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5519 assert(!CvCONST(cv));
5520 if (ps && !*ps && op_const_sv(block, cv))
5524 if (name || aname) {
5525 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5526 SV * const sv = newSV(0);
5527 SV * const tmpstr = sv_newmortal();
5528 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5529 GV_ADDMULTI, SVt_PVHV);
5532 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5534 (long)PL_subline, (long)CopLINE(PL_curcop));
5535 gv_efullname3(tmpstr, gv, NULL);
5536 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5537 hv = GvHVn(db_postponed);
5538 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5539 CV * const pcv = GvCV(db_postponed);
5545 call_sv((SV*)pcv, G_DISCARD);
5550 if (name && !PL_error_count)
5551 process_special_blocks(name, gv, cv);
5556 PL_parser->copline = NOLINE;
5562 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5565 const char *const colon = strrchr(fullname,':');
5566 const char *const name = colon ? colon + 1 : fullname;
5569 if (strEQ(name, "BEGIN")) {
5570 const I32 oldscope = PL_scopestack_ix;
5572 SAVECOPFILE(&PL_compiling);
5573 SAVECOPLINE(&PL_compiling);
5575 DEBUG_x( dump_sub(gv) );
5576 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5577 GvCV(gv) = 0; /* cv has been hijacked */
5578 call_list(oldscope, PL_beginav);
5580 PL_curcop = &PL_compiling;
5581 CopHINTS_set(&PL_compiling, PL_hints);
5588 if strEQ(name, "END") {
5589 DEBUG_x( dump_sub(gv) );
5590 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5593 } else if (*name == 'U') {
5594 if (strEQ(name, "UNITCHECK")) {
5595 /* It's never too late to run a unitcheck block */
5596 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5600 } else if (*name == 'C') {
5601 if (strEQ(name, "CHECK")) {
5602 if (PL_main_start && ckWARN(WARN_VOID))
5603 Perl_warner(aTHX_ packWARN(WARN_VOID),
5604 "Too late to run CHECK block");
5605 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5609 } else if (*name == 'I') {
5610 if (strEQ(name, "INIT")) {
5611 if (PL_main_start && ckWARN(WARN_VOID))
5612 Perl_warner(aTHX_ packWARN(WARN_VOID),
5613 "Too late to run INIT block");
5614 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5620 DEBUG_x( dump_sub(gv) );
5621 GvCV(gv) = 0; /* cv has been hijacked */
5626 =for apidoc newCONSTSUB
5628 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5629 eligible for inlining at compile-time.
5635 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5640 const char *const temp_p = CopFILE(PL_curcop);
5641 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5643 SV *const temp_sv = CopFILESV(PL_curcop);
5645 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5647 char *const file = savepvn(temp_p, temp_p ? len : 0);
5651 SAVECOPLINE(PL_curcop);
5652 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5655 PL_hints &= ~HINT_BLOCK_SCOPE;
5658 SAVESPTR(PL_curstash);
5659 SAVECOPSTASH(PL_curcop);
5660 PL_curstash = stash;
5661 CopSTASH_set(PL_curcop,stash);
5664 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5665 and so doesn't get free()d. (It's expected to be from the C pre-
5666 processor __FILE__ directive). But we need a dynamically allocated one,
5667 and we need it to get freed. */
5668 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5669 CvXSUBANY(cv).any_ptr = sv;
5675 CopSTASH_free(PL_curcop);
5683 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5684 const char *const filename, const char *const proto,
5687 CV *cv = newXS(name, subaddr, filename);
5689 if (flags & XS_DYNAMIC_FILENAME) {
5690 /* We need to "make arrangements" (ie cheat) to ensure that the
5691 filename lasts as long as the PVCV we just created, but also doesn't
5693 STRLEN filename_len = strlen(filename);
5694 STRLEN proto_and_file_len = filename_len;
5695 char *proto_and_file;
5699 proto_len = strlen(proto);
5700 proto_and_file_len += proto_len;
5702 Newx(proto_and_file, proto_and_file_len + 1, char);
5703 Copy(proto, proto_and_file, proto_len, char);
5704 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5707 proto_and_file = savepvn(filename, filename_len);
5710 /* This gets free()d. :-) */
5711 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5712 SV_HAS_TRAILING_NUL);
5714 /* This gives us the correct prototype, rather than one with the
5715 file name appended. */
5716 SvCUR_set(cv, proto_len);
5720 CvFILE(cv) = proto_and_file + proto_len;
5722 sv_setpv((SV *)cv, proto);
5728 =for apidoc U||newXS
5730 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5731 static storage, as it is used directly as CvFILE(), without a copy being made.
5737 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5740 GV * const gv = gv_fetchpv(name ? name :
5741 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5742 GV_ADDMULTI, SVt_PVCV);
5746 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5748 if ((cv = (name ? GvCV(gv) : NULL))) {
5750 /* just a cached method */
5754 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5755 /* already defined (or promised) */
5756 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5757 if (ckWARN(WARN_REDEFINE)) {
5758 GV * const gvcv = CvGV(cv);
5760 HV * const stash = GvSTASH(gvcv);
5762 const char *redefined_name = HvNAME_get(stash);
5763 if ( strEQ(redefined_name,"autouse") ) {
5764 const line_t oldline = CopLINE(PL_curcop);
5765 if (PL_parser && PL_parser->copline != NOLINE)
5766 CopLINE_set(PL_curcop, PL_parser->copline);
5767 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5768 CvCONST(cv) ? "Constant subroutine %s redefined"
5769 : "Subroutine %s redefined"
5771 CopLINE_set(PL_curcop, oldline);
5781 if (cv) /* must reuse cv if autoloaded */
5784 cv = (CV*)newSV_type(SVt_PVCV);
5788 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5792 (void)gv_fetchfile(filename);
5793 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5794 an external constant string */
5796 CvXSUB(cv) = subaddr;
5799 process_special_blocks(name, gv, cv);
5811 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5816 OP* pegop = newOP(OP_NULL, 0);
5820 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5821 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5823 #ifdef GV_UNIQUE_CHECK
5825 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5829 if ((cv = GvFORM(gv))) {
5830 if (ckWARN(WARN_REDEFINE)) {
5831 const line_t oldline = CopLINE(PL_curcop);
5832 if (PL_parser && PL_parser->copline != NOLINE)
5833 CopLINE_set(PL_curcop, PL_parser->copline);
5834 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5835 o ? "Format %"SVf" redefined"
5836 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5837 CopLINE_set(PL_curcop, oldline);
5844 CvFILE_set_from_cop(cv, PL_curcop);
5847 pad_tidy(padtidy_FORMAT);
5848 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5849 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5850 OpREFCNT_set(CvROOT(cv), 1);
5851 CvSTART(cv) = LINKLIST(CvROOT(cv));
5852 CvROOT(cv)->op_next = 0;
5853 CALL_PEEP(CvSTART(cv));
5855 op_getmad(o,pegop,'n');
5856 op_getmad_weak(block, pegop, 'b');
5861 PL_parser->copline = NOLINE;
5869 Perl_newANONLIST(pTHX_ OP *o)
5871 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5875 Perl_newANONHASH(pTHX_ OP *o)
5877 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5881 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5883 return newANONATTRSUB(floor, proto, NULL, block);
5887 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5889 return newUNOP(OP_REFGEN, 0,
5890 newSVOP(OP_ANONCODE, 0,
5891 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5895 Perl_oopsAV(pTHX_ OP *o)
5898 switch (o->op_type) {
5900 o->op_type = OP_PADAV;
5901 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5902 return ref(o, OP_RV2AV);
5905 o->op_type = OP_RV2AV;
5906 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5911 if (ckWARN_d(WARN_INTERNAL))
5912 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5919 Perl_oopsHV(pTHX_ OP *o)
5922 switch (o->op_type) {
5925 o->op_type = OP_PADHV;
5926 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5927 return ref(o, OP_RV2HV);
5931 o->op_type = OP_RV2HV;
5932 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5937 if (ckWARN_d(WARN_INTERNAL))
5938 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5945 Perl_newAVREF(pTHX_ OP *o)
5948 if (o->op_type == OP_PADANY) {
5949 o->op_type = OP_PADAV;
5950 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5953 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5954 && ckWARN(WARN_DEPRECATED)) {
5955 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5956 "Using an array as a reference is deprecated");
5958 return newUNOP(OP_RV2AV, 0, scalar(o));
5962 Perl_newGVREF(pTHX_ I32 type, OP *o)
5964 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5965 return newUNOP(OP_NULL, 0, o);
5966 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5970 Perl_newHVREF(pTHX_ OP *o)
5973 if (o->op_type == OP_PADANY) {
5974 o->op_type = OP_PADHV;
5975 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5978 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5979 && ckWARN(WARN_DEPRECATED)) {
5980 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5981 "Using a hash as a reference is deprecated");
5983 return newUNOP(OP_RV2HV, 0, scalar(o));
5987 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5989 return newUNOP(OP_RV2CV, flags, scalar(o));
5993 Perl_newSVREF(pTHX_ OP *o)
5996 if (o->op_type == OP_PADANY) {
5997 o->op_type = OP_PADSV;
5998 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6001 return newUNOP(OP_RV2SV, 0, scalar(o));
6004 /* Check routines. See the comments at the top of this file for details
6005 * on when these are called */
6008 Perl_ck_anoncode(pTHX_ OP *o)
6010 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6012 cSVOPo->op_sv = NULL;
6017 Perl_ck_bitop(pTHX_ OP *o)
6020 #define OP_IS_NUMCOMPARE(op) \
6021 ((op) == OP_LT || (op) == OP_I_LT || \
6022 (op) == OP_GT || (op) == OP_I_GT || \
6023 (op) == OP_LE || (op) == OP_I_LE || \
6024 (op) == OP_GE || (op) == OP_I_GE || \
6025 (op) == OP_EQ || (op) == OP_I_EQ || \
6026 (op) == OP_NE || (op) == OP_I_NE || \
6027 (op) == OP_NCMP || (op) == OP_I_NCMP)
6028 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6029 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6030 && (o->op_type == OP_BIT_OR
6031 || o->op_type == OP_BIT_AND
6032 || o->op_type == OP_BIT_XOR))
6034 const OP * const left = cBINOPo->op_first;
6035 const OP * const right = left->op_sibling;
6036 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6037 (left->op_flags & OPf_PARENS) == 0) ||
6038 (OP_IS_NUMCOMPARE(right->op_type) &&
6039 (right->op_flags & OPf_PARENS) == 0))
6040 if (ckWARN(WARN_PRECEDENCE))
6041 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6042 "Possible precedence problem on bitwise %c operator",
6043 o->op_type == OP_BIT_OR ? '|'
6044 : o->op_type == OP_BIT_AND ? '&' : '^'
6051 Perl_ck_concat(pTHX_ OP *o)
6053 const OP * const kid = cUNOPo->op_first;
6054 PERL_UNUSED_CONTEXT;
6055 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6056 !(kUNOP->op_first->op_flags & OPf_MOD))
6057 o->op_flags |= OPf_STACKED;
6062 Perl_ck_spair(pTHX_ OP *o)
6065 if (o->op_flags & OPf_KIDS) {
6068 const OPCODE type = o->op_type;
6069 o = modkids(ck_fun(o), type);
6070 kid = cUNOPo->op_first;
6071 newop = kUNOP->op_first->op_sibling;
6073 const OPCODE type = newop->op_type;
6074 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6075 type == OP_PADAV || type == OP_PADHV ||
6076 type == OP_RV2AV || type == OP_RV2HV)
6080 op_getmad(kUNOP->op_first,newop,'K');
6082 op_free(kUNOP->op_first);
6084 kUNOP->op_first = newop;
6086 o->op_ppaddr = PL_ppaddr[++o->op_type];
6091 Perl_ck_delete(pTHX_ OP *o)
6095 if (o->op_flags & OPf_KIDS) {
6096 OP * const kid = cUNOPo->op_first;
6097 switch (kid->op_type) {
6099 o->op_flags |= OPf_SPECIAL;
6102 o->op_private |= OPpSLICE;
6105 o->op_flags |= OPf_SPECIAL;
6110 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6119 Perl_ck_die(pTHX_ OP *o)
6122 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6128 Perl_ck_eof(pTHX_ OP *o)
6132 if (o->op_flags & OPf_KIDS) {
6133 if (cLISTOPo->op_first->op_type == OP_STUB) {
6135 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6137 op_getmad(o,newop,'O');
6149 Perl_ck_eval(pTHX_ OP *o)
6152 PL_hints |= HINT_BLOCK_SCOPE;
6153 if (o->op_flags & OPf_KIDS) {
6154 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6157 o->op_flags &= ~OPf_KIDS;
6160 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6166 cUNOPo->op_first = 0;
6171 NewOp(1101, enter, 1, LOGOP);
6172 enter->op_type = OP_ENTERTRY;
6173 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6174 enter->op_private = 0;
6176 /* establish postfix order */
6177 enter->op_next = (OP*)enter;
6179 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6180 o->op_type = OP_LEAVETRY;
6181 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6182 enter->op_other = o;
6183 op_getmad(oldo,o,'O');
6197 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6198 op_getmad(oldo,o,'O');
6200 o->op_targ = (PADOFFSET)PL_hints;
6201 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6202 /* Store a copy of %^H that pp_entereval can pick up.
6203 OPf_SPECIAL flags the opcode as being for this purpose,
6204 so that it in turn will return a copy at every
6206 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6207 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6208 cUNOPo->op_first->op_sibling = hhop;
6209 o->op_private |= OPpEVAL_HAS_HH;
6215 Perl_ck_exit(pTHX_ OP *o)
6218 HV * const table = GvHV(PL_hintgv);
6220 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6221 if (svp && *svp && SvTRUE(*svp))
6222 o->op_private |= OPpEXIT_VMSISH;
6224 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6230 Perl_ck_exec(pTHX_ OP *o)
6232 if (o->op_flags & OPf_STACKED) {
6235 kid = cUNOPo->op_first->op_sibling;
6236 if (kid->op_type == OP_RV2GV)
6245 Perl_ck_exists(pTHX_ OP *o)
6249 if (o->op_flags & OPf_KIDS) {
6250 OP * const kid = cUNOPo->op_first;
6251 if (kid->op_type == OP_ENTERSUB) {
6252 (void) ref(kid, o->op_type);
6253 if (kid->op_type != OP_RV2CV && !PL_error_count)
6254 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6256 o->op_private |= OPpEXISTS_SUB;
6258 else if (kid->op_type == OP_AELEM)
6259 o->op_flags |= OPf_SPECIAL;
6260 else if (kid->op_type != OP_HELEM)
6261 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6269 Perl_ck_rvconst(pTHX_ register OP *o)
6272 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6274 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6275 if (o->op_type == OP_RV2CV)
6276 o->op_private &= ~1;
6278 if (kid->op_type == OP_CONST) {
6281 SV * const kidsv = kid->op_sv;
6283 /* Is it a constant from cv_const_sv()? */
6284 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6285 SV * const rsv = SvRV(kidsv);
6286 const svtype type = SvTYPE(rsv);
6287 const char *badtype = NULL;
6289 switch (o->op_type) {
6291 if (type > SVt_PVMG)
6292 badtype = "a SCALAR";
6295 if (type != SVt_PVAV)
6296 badtype = "an ARRAY";
6299 if (type != SVt_PVHV)
6303 if (type != SVt_PVCV)
6308 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6311 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6312 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6313 /* If this is an access to a stash, disable "strict refs", because
6314 * stashes aren't auto-vivified at compile-time (unless we store
6315 * symbols in them), and we don't want to produce a run-time
6316 * stricture error when auto-vivifying the stash. */
6317 const char *s = SvPV_nolen(kidsv);
6318 const STRLEN l = SvCUR(kidsv);
6319 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6320 o->op_private &= ~HINT_STRICT_REFS;
6322 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6323 const char *badthing;
6324 switch (o->op_type) {
6326 badthing = "a SCALAR";
6329 badthing = "an ARRAY";
6332 badthing = "a HASH";
6340 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6341 SVfARG(kidsv), badthing);
6344 * This is a little tricky. We only want to add the symbol if we
6345 * didn't add it in the lexer. Otherwise we get duplicate strict
6346 * warnings. But if we didn't add it in the lexer, we must at
6347 * least pretend like we wanted to add it even if it existed before,
6348 * or we get possible typo warnings. OPpCONST_ENTERED says
6349 * whether the lexer already added THIS instance of this symbol.
6351 iscv = (o->op_type == OP_RV2CV) * 2;
6353 gv = gv_fetchsv(kidsv,
6354 iscv | !(kid->op_private & OPpCONST_ENTERED),
6357 : o->op_type == OP_RV2SV
6359 : o->op_type == OP_RV2AV
6361 : o->op_type == OP_RV2HV
6364 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6366 kid->op_type = OP_GV;
6367 SvREFCNT_dec(kid->op_sv);
6369 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6370 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6371 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6373 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6375 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6377 kid->op_private = 0;
6378 kid->op_ppaddr = PL_ppaddr[OP_GV];
6385 Perl_ck_ftst(pTHX_ OP *o)
6388 const I32 type = o->op_type;
6390 if (o->op_flags & OPf_REF) {
6393 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6394 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6395 const OPCODE kidtype = kid->op_type;
6397 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6398 OP * const newop = newGVOP(type, OPf_REF,
6399 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6401 op_getmad(o,newop,'O');
6407 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6408 o->op_private |= OPpFT_ACCESS;
6409 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6410 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6411 o->op_private |= OPpFT_STACKED;
6419 if (type == OP_FTTTY)
6420 o = newGVOP(type, OPf_REF, PL_stdingv);
6422 o = newUNOP(type, 0, newDEFSVOP());
6423 op_getmad(oldo,o,'O');
6429 Perl_ck_fun(pTHX_ OP *o)
6432 const int type = o->op_type;
6433 register I32 oa = PL_opargs[type] >> OASHIFT;
6435 if (o->op_flags & OPf_STACKED) {
6436 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6439 return no_fh_allowed(o);
6442 if (o->op_flags & OPf_KIDS) {
6443 OP **tokid = &cLISTOPo->op_first;
6444 register OP *kid = cLISTOPo->op_first;
6448 if (kid->op_type == OP_PUSHMARK ||
6449 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6451 tokid = &kid->op_sibling;
6452 kid = kid->op_sibling;
6454 if (!kid && PL_opargs[type] & OA_DEFGV)
6455 *tokid = kid = newDEFSVOP();
6459 sibl = kid->op_sibling;
6461 if (!sibl && kid->op_type == OP_STUB) {
6468 /* list seen where single (scalar) arg expected? */
6469 if (numargs == 1 && !(oa >> 4)
6470 && kid->op_type == OP_LIST && type != OP_SCALAR)
6472 return too_many_arguments(o,PL_op_desc[type]);
6485 if ((type == OP_PUSH || type == OP_UNSHIFT)
6486 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6487 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6488 "Useless use of %s with no values",
6491 if (kid->op_type == OP_CONST &&
6492 (kid->op_private & OPpCONST_BARE))
6494 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6495 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6496 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6497 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6498 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6499 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6501 op_getmad(kid,newop,'K');
6506 kid->op_sibling = sibl;
6509 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6510 bad_type(numargs, "array", PL_op_desc[type], kid);
6514 if (kid->op_type == OP_CONST &&
6515 (kid->op_private & OPpCONST_BARE))
6517 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6518 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6519 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6520 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6521 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6522 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6524 op_getmad(kid,newop,'K');
6529 kid->op_sibling = sibl;
6532 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6533 bad_type(numargs, "hash", PL_op_desc[type], kid);
6538 OP * const newop = newUNOP(OP_NULL, 0, kid);
6539 kid->op_sibling = 0;
6541 newop->op_next = newop;
6543 kid->op_sibling = sibl;
6548 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6549 if (kid->op_type == OP_CONST &&
6550 (kid->op_private & OPpCONST_BARE))
6552 OP * const newop = newGVOP(OP_GV, 0,
6553 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6554 if (!(o->op_private & 1) && /* if not unop */
6555 kid == cLISTOPo->op_last)
6556 cLISTOPo->op_last = newop;
6558 op_getmad(kid,newop,'K');
6564 else if (kid->op_type == OP_READLINE) {
6565 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6566 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6569 I32 flags = OPf_SPECIAL;
6573 /* is this op a FH constructor? */
6574 if (is_handle_constructor(o,numargs)) {
6575 const char *name = NULL;
6579 /* Set a flag to tell rv2gv to vivify
6580 * need to "prove" flag does not mean something
6581 * else already - NI-S 1999/05/07
6584 if (kid->op_type == OP_PADSV) {
6586 = PAD_COMPNAME_SV(kid->op_targ);
6587 name = SvPV_const(namesv, len);
6589 else if (kid->op_type == OP_RV2SV
6590 && kUNOP->op_first->op_type == OP_GV)
6592 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6594 len = GvNAMELEN(gv);
6596 else if (kid->op_type == OP_AELEM
6597 || kid->op_type == OP_HELEM)
6600 OP *op = ((BINOP*)kid)->op_first;
6604 const char * const a =
6605 kid->op_type == OP_AELEM ?
6607 if (((op->op_type == OP_RV2AV) ||
6608 (op->op_type == OP_RV2HV)) &&
6609 (firstop = ((UNOP*)op)->op_first) &&
6610 (firstop->op_type == OP_GV)) {
6611 /* packagevar $a[] or $h{} */
6612 GV * const gv = cGVOPx_gv(firstop);
6620 else if (op->op_type == OP_PADAV
6621 || op->op_type == OP_PADHV) {
6622 /* lexicalvar $a[] or $h{} */
6623 const char * const padname =
6624 PAD_COMPNAME_PV(op->op_targ);
6633 name = SvPV_const(tmpstr, len);
6638 name = "__ANONIO__";
6645 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6646 namesv = PAD_SVl(targ);
6647 SvUPGRADE(namesv, SVt_PV);
6649 sv_setpvn(namesv, "$", 1);
6650 sv_catpvn(namesv, name, len);
6653 kid->op_sibling = 0;
6654 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6655 kid->op_targ = targ;
6656 kid->op_private |= priv;
6658 kid->op_sibling = sibl;
6664 mod(scalar(kid), type);
6668 tokid = &kid->op_sibling;
6669 kid = kid->op_sibling;
6672 if (kid && kid->op_type != OP_STUB)
6673 return too_many_arguments(o,OP_DESC(o));
6674 o->op_private |= numargs;
6676 /* FIXME - should the numargs move as for the PERL_MAD case? */
6677 o->op_private |= numargs;
6679 return too_many_arguments(o,OP_DESC(o));
6683 else if (PL_opargs[type] & OA_DEFGV) {
6685 OP *newop = newUNOP(type, 0, newDEFSVOP());
6686 op_getmad(o,newop,'O');
6689 /* Ordering of these two is important to keep f_map.t passing. */
6691 return newUNOP(type, 0, newDEFSVOP());
6696 while (oa & OA_OPTIONAL)
6698 if (oa && oa != OA_LIST)
6699 return too_few_arguments(o,OP_DESC(o));
6705 Perl_ck_glob(pTHX_ OP *o)
6711 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6712 append_elem(OP_GLOB, o, newDEFSVOP());
6714 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6715 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6717 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6720 #if !defined(PERL_EXTERNAL_GLOB)
6721 /* XXX this can be tightened up and made more failsafe. */
6722 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6725 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6726 newSVpvs("File::Glob"), NULL, NULL, NULL);
6727 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6728 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6729 GvCV(gv) = GvCV(glob_gv);
6730 SvREFCNT_inc_void((SV*)GvCV(gv));
6731 GvIMPORTED_CV_on(gv);
6734 #endif /* PERL_EXTERNAL_GLOB */
6736 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6737 append_elem(OP_GLOB, o,
6738 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6739 o->op_type = OP_LIST;
6740 o->op_ppaddr = PL_ppaddr[OP_LIST];
6741 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6742 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6743 cLISTOPo->op_first->op_targ = 0;
6744 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6745 append_elem(OP_LIST, o,
6746 scalar(newUNOP(OP_RV2CV, 0,
6747 newGVOP(OP_GV, 0, gv)))));
6748 o = newUNOP(OP_NULL, 0, ck_subr(o));
6749 o->op_targ = OP_GLOB; /* hint at what it used to be */
6752 gv = newGVgen("main");
6754 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6760 Perl_ck_grep(pTHX_ OP *o)
6765 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6768 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6769 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6771 if (o->op_flags & OPf_STACKED) {
6774 kid = cLISTOPo->op_first->op_sibling;
6775 if (!cUNOPx(kid)->op_next)
6776 Perl_croak(aTHX_ "panic: ck_grep");
6777 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6780 NewOp(1101, gwop, 1, LOGOP);
6781 kid->op_next = (OP*)gwop;
6782 o->op_flags &= ~OPf_STACKED;
6784 kid = cLISTOPo->op_first->op_sibling;
6785 if (type == OP_MAPWHILE)
6792 kid = cLISTOPo->op_first->op_sibling;
6793 if (kid->op_type != OP_NULL)
6794 Perl_croak(aTHX_ "panic: ck_grep");
6795 kid = kUNOP->op_first;
6798 NewOp(1101, gwop, 1, LOGOP);
6799 gwop->op_type = type;
6800 gwop->op_ppaddr = PL_ppaddr[type];
6801 gwop->op_first = listkids(o);
6802 gwop->op_flags |= OPf_KIDS;
6803 gwop->op_other = LINKLIST(kid);
6804 kid->op_next = (OP*)gwop;
6805 offset = pad_findmy("$_");
6806 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6807 o->op_private = gwop->op_private = 0;
6808 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6811 o->op_private = gwop->op_private = OPpGREP_LEX;
6812 gwop->op_targ = o->op_targ = offset;
6815 kid = cLISTOPo->op_first->op_sibling;
6816 if (!kid || !kid->op_sibling)
6817 return too_few_arguments(o,OP_DESC(o));
6818 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6819 mod(kid, OP_GREPSTART);
6825 Perl_ck_index(pTHX_ OP *o)
6827 if (o->op_flags & OPf_KIDS) {
6828 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6830 kid = kid->op_sibling; /* get past "big" */
6831 if (kid && kid->op_type == OP_CONST)
6832 fbm_compile(((SVOP*)kid)->op_sv, 0);
6838 Perl_ck_lengthconst(pTHX_ OP *o)
6840 /* XXX length optimization goes here */
6845 Perl_ck_lfun(pTHX_ OP *o)
6847 const OPCODE type = o->op_type;
6848 return modkids(ck_fun(o), type);
6852 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6854 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6855 switch (cUNOPo->op_first->op_type) {
6857 /* This is needed for
6858 if (defined %stash::)
6859 to work. Do not break Tk.
6861 break; /* Globals via GV can be undef */
6863 case OP_AASSIGN: /* Is this a good idea? */
6864 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6865 "defined(@array) is deprecated");
6866 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6867 "\t(Maybe you should just omit the defined()?)\n");
6870 /* This is needed for
6871 if (defined %stash::)
6872 to work. Do not break Tk.
6874 break; /* Globals via GV can be undef */
6876 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6877 "defined(%%hash) is deprecated");
6878 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6879 "\t(Maybe you should just omit the defined()?)\n");
6890 Perl_ck_readline(pTHX_ OP *o)
6892 if (!(o->op_flags & OPf_KIDS)) {
6894 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6896 op_getmad(o,newop,'O');
6906 Perl_ck_rfun(pTHX_ OP *o)
6908 const OPCODE type = o->op_type;
6909 return refkids(ck_fun(o), type);
6913 Perl_ck_listiob(pTHX_ OP *o)
6917 kid = cLISTOPo->op_first;
6920 kid = cLISTOPo->op_first;
6922 if (kid->op_type == OP_PUSHMARK)
6923 kid = kid->op_sibling;
6924 if (kid && o->op_flags & OPf_STACKED)
6925 kid = kid->op_sibling;
6926 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6927 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6928 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6929 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6930 cLISTOPo->op_first->op_sibling = kid;
6931 cLISTOPo->op_last = kid;
6932 kid = kid->op_sibling;
6937 append_elem(o->op_type, o, newDEFSVOP());
6943 Perl_ck_smartmatch(pTHX_ OP *o)
6946 if (0 == (o->op_flags & OPf_SPECIAL)) {
6947 OP *first = cBINOPo->op_first;
6948 OP *second = first->op_sibling;
6950 /* Implicitly take a reference to an array or hash */
6951 first->op_sibling = NULL;
6952 first = cBINOPo->op_first = ref_array_or_hash(first);
6953 second = first->op_sibling = ref_array_or_hash(second);
6955 /* Implicitly take a reference to a regular expression */
6956 if (first->op_type == OP_MATCH) {
6957 first->op_type = OP_QR;
6958 first->op_ppaddr = PL_ppaddr[OP_QR];
6960 if (second->op_type == OP_MATCH) {
6961 second->op_type = OP_QR;
6962 second->op_ppaddr = PL_ppaddr[OP_QR];
6971 Perl_ck_sassign(pTHX_ OP *o)
6973 OP * const kid = cLISTOPo->op_first;
6974 /* has a disposable target? */
6975 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6976 && !(kid->op_flags & OPf_STACKED)
6977 /* Cannot steal the second time! */
6978 && !(kid->op_private & OPpTARGET_MY)
6979 /* Keep the full thing for madskills */
6983 OP * const kkid = kid->op_sibling;
6985 /* Can just relocate the target. */
6986 if (kkid && kkid->op_type == OP_PADSV
6987 && !(kkid->op_private & OPpLVAL_INTRO))
6989 kid->op_targ = kkid->op_targ;
6991 /* Now we do not need PADSV and SASSIGN. */
6992 kid->op_sibling = o->op_sibling; /* NULL */
6993 cLISTOPo->op_first = NULL;
6996 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7004 Perl_ck_match(pTHX_ OP *o)
7007 if (o->op_type != OP_QR && PL_compcv) {
7008 const PADOFFSET offset = pad_findmy("$_");
7009 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7010 o->op_targ = offset;
7011 o->op_private |= OPpTARGET_MY;
7014 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7015 o->op_private |= OPpRUNTIME;
7020 Perl_ck_method(pTHX_ OP *o)
7022 OP * const kid = cUNOPo->op_first;
7023 if (kid->op_type == OP_CONST) {
7024 SV* sv = kSVOP->op_sv;
7025 const char * const method = SvPVX_const(sv);
7026 if (!(strchr(method, ':') || strchr(method, '\''))) {
7028 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7029 sv = newSVpvn_share(method, SvCUR(sv), 0);
7032 kSVOP->op_sv = NULL;
7034 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7036 op_getmad(o,cmop,'O');
7047 Perl_ck_null(pTHX_ OP *o)
7049 PERL_UNUSED_CONTEXT;
7054 Perl_ck_open(pTHX_ OP *o)
7057 HV * const table = GvHV(PL_hintgv);
7059 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7061 const I32 mode = mode_from_discipline(*svp);
7062 if (mode & O_BINARY)
7063 o->op_private |= OPpOPEN_IN_RAW;
7064 else if (mode & O_TEXT)
7065 o->op_private |= OPpOPEN_IN_CRLF;
7068 svp = hv_fetchs(table, "open_OUT", FALSE);
7070 const I32 mode = mode_from_discipline(*svp);
7071 if (mode & O_BINARY)
7072 o->op_private |= OPpOPEN_OUT_RAW;
7073 else if (mode & O_TEXT)
7074 o->op_private |= OPpOPEN_OUT_CRLF;
7077 if (o->op_type == OP_BACKTICK) {
7078 if (!(o->op_flags & OPf_KIDS)) {
7079 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7081 op_getmad(o,newop,'O');
7090 /* In case of three-arg dup open remove strictness
7091 * from the last arg if it is a bareword. */
7092 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7093 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7097 if ((last->op_type == OP_CONST) && /* The bareword. */
7098 (last->op_private & OPpCONST_BARE) &&
7099 (last->op_private & OPpCONST_STRICT) &&
7100 (oa = first->op_sibling) && /* The fh. */
7101 (oa = oa->op_sibling) && /* The mode. */
7102 (oa->op_type == OP_CONST) &&
7103 SvPOK(((SVOP*)oa)->op_sv) &&
7104 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7105 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7106 (last == oa->op_sibling)) /* The bareword. */
7107 last->op_private &= ~OPpCONST_STRICT;
7113 Perl_ck_repeat(pTHX_ OP *o)
7115 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7116 o->op_private |= OPpREPEAT_DOLIST;
7117 cBINOPo->op_first = force_list(cBINOPo->op_first);
7125 Perl_ck_require(pTHX_ OP *o)
7130 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7131 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7133 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7134 SV * const sv = kid->op_sv;
7135 U32 was_readonly = SvREADONLY(sv);
7140 sv_force_normal_flags(sv, 0);
7141 assert(!SvREADONLY(sv));
7148 for (s = SvPVX(sv); *s; s++) {
7149 if (*s == ':' && s[1] == ':') {
7150 const STRLEN len = strlen(s+2)+1;
7152 Move(s+2, s+1, len, char);
7153 SvCUR_set(sv, SvCUR(sv) - 1);
7156 sv_catpvs(sv, ".pm");
7157 SvFLAGS(sv) |= was_readonly;
7161 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7162 /* handle override, if any */
7163 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7164 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7165 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7166 gv = gvp ? *gvp : NULL;
7170 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7171 OP * const kid = cUNOPo->op_first;
7174 cUNOPo->op_first = 0;
7178 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7179 append_elem(OP_LIST, kid,
7180 scalar(newUNOP(OP_RV2CV, 0,
7183 op_getmad(o,newop,'O');
7191 Perl_ck_return(pTHX_ OP *o)
7194 if (CvLVALUE(PL_compcv)) {
7196 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7197 mod(kid, OP_LEAVESUBLV);
7203 Perl_ck_select(pTHX_ OP *o)
7207 if (o->op_flags & OPf_KIDS) {
7208 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7209 if (kid && kid->op_sibling) {
7210 o->op_type = OP_SSELECT;
7211 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7213 return fold_constants(o);
7217 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7218 if (kid && kid->op_type == OP_RV2GV)
7219 kid->op_private &= ~HINT_STRICT_REFS;
7224 Perl_ck_shift(pTHX_ OP *o)
7227 const I32 type = o->op_type;
7229 if (!(o->op_flags & OPf_KIDS)) {
7231 /* FIXME - this can be refactored to reduce code in #ifdefs */
7233 OP * const oldo = o;
7237 argop = newUNOP(OP_RV2AV, 0,
7238 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7240 o = newUNOP(type, 0, scalar(argop));
7241 op_getmad(oldo,o,'O');
7244 return newUNOP(type, 0, scalar(argop));
7247 return scalar(modkids(ck_fun(o), type));
7251 Perl_ck_sort(pTHX_ OP *o)
7256 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7257 HV * const hinthv = GvHV(PL_hintgv);
7259 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7261 const I32 sorthints = (I32)SvIV(*svp);
7262 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7263 o->op_private |= OPpSORT_QSORT;
7264 if ((sorthints & HINT_SORT_STABLE) != 0)
7265 o->op_private |= OPpSORT_STABLE;
7270 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7272 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7273 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7275 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7277 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7279 if (kid->op_type == OP_SCOPE) {
7283 else if (kid->op_type == OP_LEAVE) {
7284 if (o->op_type == OP_SORT) {
7285 op_null(kid); /* wipe out leave */
7288 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7289 if (k->op_next == kid)
7291 /* don't descend into loops */
7292 else if (k->op_type == OP_ENTERLOOP
7293 || k->op_type == OP_ENTERITER)
7295 k = cLOOPx(k)->op_lastop;
7300 kid->op_next = 0; /* just disconnect the leave */
7301 k = kLISTOP->op_first;
7306 if (o->op_type == OP_SORT) {
7307 /* provide scalar context for comparison function/block */
7313 o->op_flags |= OPf_SPECIAL;
7315 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7318 firstkid = firstkid->op_sibling;
7321 /* provide list context for arguments */
7322 if (o->op_type == OP_SORT)
7329 S_simplify_sort(pTHX_ OP *o)
7332 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7337 if (!(o->op_flags & OPf_STACKED))
7339 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7340 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7341 kid = kUNOP->op_first; /* get past null */
7342 if (kid->op_type != OP_SCOPE)
7344 kid = kLISTOP->op_last; /* get past scope */
7345 switch(kid->op_type) {
7353 k = kid; /* remember this node*/
7354 if (kBINOP->op_first->op_type != OP_RV2SV)
7356 kid = kBINOP->op_first; /* get past cmp */
7357 if (kUNOP->op_first->op_type != OP_GV)
7359 kid = kUNOP->op_first; /* get past rv2sv */
7361 if (GvSTASH(gv) != PL_curstash)
7363 gvname = GvNAME(gv);
7364 if (*gvname == 'a' && gvname[1] == '\0')
7366 else if (*gvname == 'b' && gvname[1] == '\0')
7371 kid = k; /* back to cmp */
7372 if (kBINOP->op_last->op_type != OP_RV2SV)
7374 kid = kBINOP->op_last; /* down to 2nd arg */
7375 if (kUNOP->op_first->op_type != OP_GV)
7377 kid = kUNOP->op_first; /* get past rv2sv */
7379 if (GvSTASH(gv) != PL_curstash)
7381 gvname = GvNAME(gv);
7383 ? !(*gvname == 'a' && gvname[1] == '\0')
7384 : !(*gvname == 'b' && gvname[1] == '\0'))
7386 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7388 o->op_private |= OPpSORT_DESCEND;
7389 if (k->op_type == OP_NCMP)
7390 o->op_private |= OPpSORT_NUMERIC;
7391 if (k->op_type == OP_I_NCMP)
7392 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7393 kid = cLISTOPo->op_first->op_sibling;
7394 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7396 op_getmad(kid,o,'S'); /* then delete it */
7398 op_free(kid); /* then delete it */
7403 Perl_ck_split(pTHX_ OP *o)
7408 if (o->op_flags & OPf_STACKED)
7409 return no_fh_allowed(o);
7411 kid = cLISTOPo->op_first;
7412 if (kid->op_type != OP_NULL)
7413 Perl_croak(aTHX_ "panic: ck_split");
7414 kid = kid->op_sibling;
7415 op_free(cLISTOPo->op_first);
7416 cLISTOPo->op_first = kid;
7418 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7419 cLISTOPo->op_last = kid; /* There was only one element previously */
7422 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7423 OP * const sibl = kid->op_sibling;
7424 kid->op_sibling = 0;
7425 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7426 if (cLISTOPo->op_first == cLISTOPo->op_last)
7427 cLISTOPo->op_last = kid;
7428 cLISTOPo->op_first = kid;
7429 kid->op_sibling = sibl;
7432 kid->op_type = OP_PUSHRE;
7433 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7435 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7436 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7437 "Use of /g modifier is meaningless in split");
7440 if (!kid->op_sibling)
7441 append_elem(OP_SPLIT, o, newDEFSVOP());
7443 kid = kid->op_sibling;
7446 if (!kid->op_sibling)
7447 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7448 assert(kid->op_sibling);
7450 kid = kid->op_sibling;
7453 if (kid->op_sibling)
7454 return too_many_arguments(o,OP_DESC(o));
7460 Perl_ck_join(pTHX_ OP *o)
7462 const OP * const kid = cLISTOPo->op_first->op_sibling;
7463 if (kid && kid->op_type == OP_MATCH) {
7464 if (ckWARN(WARN_SYNTAX)) {
7465 const REGEXP *re = PM_GETRE(kPMOP);
7466 const char *pmstr = re ? re->precomp : "STRING";
7467 const STRLEN len = re ? re->prelen : 6;
7468 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7469 "/%.*s/ should probably be written as \"%.*s\"",
7470 (int)len, pmstr, (int)len, pmstr);
7477 Perl_ck_subr(pTHX_ OP *o)
7480 OP *prev = ((cUNOPo->op_first->op_sibling)
7481 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7482 OP *o2 = prev->op_sibling;
7484 const char *proto = NULL;
7485 const char *proto_end = NULL;
7490 I32 contextclass = 0;
7491 const char *e = NULL;
7494 o->op_private |= OPpENTERSUB_HASTARG;
7495 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7496 if (cvop->op_type == OP_RV2CV) {
7498 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7499 op_null(cvop); /* disable rv2cv */
7500 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7501 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7502 GV *gv = cGVOPx_gv(tmpop);
7505 tmpop->op_private |= OPpEARLY_CV;
7509 namegv = CvANON(cv) ? gv : CvGV(cv);
7510 proto = SvPV((SV*)cv, len);
7511 proto_end = proto + len;
7513 if (CvASSERTION(cv)) {
7514 U32 asserthints = 0;
7515 HV *const hinthv = GvHV(PL_hintgv);
7517 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7519 asserthints = SvUV(*svp);
7521 if (asserthints & HINT_ASSERTING) {
7522 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7523 o->op_private |= OPpENTERSUB_DB;
7527 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7528 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7529 "Impossible to activate assertion call");
7536 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7537 if (o2->op_type == OP_CONST)
7538 o2->op_private &= ~OPpCONST_STRICT;
7539 else if (o2->op_type == OP_LIST) {
7540 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7541 if (sib && sib->op_type == OP_CONST)
7542 sib->op_private &= ~OPpCONST_STRICT;
7545 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7546 if (PERLDB_SUB && PL_curstash != PL_debstash)
7547 o->op_private |= OPpENTERSUB_DB;
7548 while (o2 != cvop) {
7550 if (PL_madskills && o2->op_type == OP_STUB) {
7551 o2 = o2->op_sibling;
7554 if (PL_madskills && o2->op_type == OP_NULL)
7555 o3 = ((UNOP*)o2)->op_first;
7559 if (proto >= proto_end)
7560 return too_many_arguments(o, gv_ename(namegv));
7568 /* _ must be at the end */
7569 if (proto[1] && proto[1] != ';')
7584 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7586 arg == 1 ? "block or sub {}" : "sub {}",
7587 gv_ename(namegv), o3);
7590 /* '*' allows any scalar type, including bareword */
7593 if (o3->op_type == OP_RV2GV)
7594 goto wrapref; /* autoconvert GLOB -> GLOBref */
7595 else if (o3->op_type == OP_CONST)
7596 o3->op_private &= ~OPpCONST_STRICT;
7597 else if (o3->op_type == OP_ENTERSUB) {
7598 /* accidental subroutine, revert to bareword */
7599 OP *gvop = ((UNOP*)o3)->op_first;
7600 if (gvop && gvop->op_type == OP_NULL) {
7601 gvop = ((UNOP*)gvop)->op_first;
7603 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7606 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7607 (gvop = ((UNOP*)gvop)->op_first) &&
7608 gvop->op_type == OP_GV)
7610 GV * const gv = cGVOPx_gv(gvop);
7611 OP * const sibling = o2->op_sibling;
7612 SV * const n = newSVpvs("");
7614 OP * const oldo2 = o2;
7618 gv_fullname4(n, gv, "", FALSE);
7619 o2 = newSVOP(OP_CONST, 0, n);
7620 op_getmad(oldo2,o2,'O');
7621 prev->op_sibling = o2;
7622 o2->op_sibling = sibling;
7638 if (contextclass++ == 0) {
7639 e = strchr(proto, ']');
7640 if (!e || e == proto)
7649 const char *p = proto;
7650 const char *const end = proto;
7652 while (*--p != '[');
7653 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7655 gv_ename(namegv), o3);
7660 if (o3->op_type == OP_RV2GV)
7663 bad_type(arg, "symbol", gv_ename(namegv), o3);
7666 if (o3->op_type == OP_ENTERSUB)
7669 bad_type(arg, "subroutine entry", gv_ename(namegv),
7673 if (o3->op_type == OP_RV2SV ||
7674 o3->op_type == OP_PADSV ||
7675 o3->op_type == OP_HELEM ||
7676 o3->op_type == OP_AELEM)
7679 bad_type(arg, "scalar", gv_ename(namegv), o3);
7682 if (o3->op_type == OP_RV2AV ||
7683 o3->op_type == OP_PADAV)
7686 bad_type(arg, "array", gv_ename(namegv), o3);
7689 if (o3->op_type == OP_RV2HV ||
7690 o3->op_type == OP_PADHV)
7693 bad_type(arg, "hash", gv_ename(namegv), o3);
7698 OP* const sib = kid->op_sibling;
7699 kid->op_sibling = 0;
7700 o2 = newUNOP(OP_REFGEN, 0, kid);
7701 o2->op_sibling = sib;
7702 prev->op_sibling = o2;
7704 if (contextclass && e) {
7719 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7720 gv_ename(namegv), SVfARG(cv));
7725 mod(o2, OP_ENTERSUB);
7727 o2 = o2->op_sibling;
7729 if (o2 == cvop && proto && *proto == '_') {
7730 /* generate an access to $_ */
7732 o2->op_sibling = prev->op_sibling;
7733 prev->op_sibling = o2; /* instead of cvop */
7735 if (proto && !optional && proto_end > proto &&
7736 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7737 return too_few_arguments(o, gv_ename(namegv));
7740 OP * const oldo = o;
7744 o=newSVOP(OP_CONST, 0, newSViv(0));
7745 op_getmad(oldo,o,'O');
7751 Perl_ck_svconst(pTHX_ OP *o)
7753 PERL_UNUSED_CONTEXT;
7754 SvREADONLY_on(cSVOPo->op_sv);
7759 Perl_ck_chdir(pTHX_ OP *o)
7761 if (o->op_flags & OPf_KIDS) {
7762 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7764 if (kid && kid->op_type == OP_CONST &&
7765 (kid->op_private & OPpCONST_BARE))
7767 o->op_flags |= OPf_SPECIAL;
7768 kid->op_private &= ~OPpCONST_STRICT;
7775 Perl_ck_trunc(pTHX_ OP *o)
7777 if (o->op_flags & OPf_KIDS) {
7778 SVOP *kid = (SVOP*)cUNOPo->op_first;
7780 if (kid->op_type == OP_NULL)
7781 kid = (SVOP*)kid->op_sibling;
7782 if (kid && kid->op_type == OP_CONST &&
7783 (kid->op_private & OPpCONST_BARE))
7785 o->op_flags |= OPf_SPECIAL;
7786 kid->op_private &= ~OPpCONST_STRICT;
7793 Perl_ck_unpack(pTHX_ OP *o)
7795 OP *kid = cLISTOPo->op_first;
7796 if (kid->op_sibling) {
7797 kid = kid->op_sibling;
7798 if (!kid->op_sibling)
7799 kid->op_sibling = newDEFSVOP();
7805 Perl_ck_substr(pTHX_ OP *o)
7808 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7809 OP *kid = cLISTOPo->op_first;
7811 if (kid->op_type == OP_NULL)
7812 kid = kid->op_sibling;
7814 kid->op_flags |= OPf_MOD;
7820 /* A peephole optimizer. We visit the ops in the order they're to execute.
7821 * See the comments at the top of this file for more details about when
7822 * peep() is called */
7825 Perl_peep(pTHX_ register OP *o)
7828 register OP* oldop = NULL;
7830 if (!o || o->op_opt)
7834 SAVEVPTR(PL_curcop);
7835 for (; o; o = o->op_next) {
7838 /* By default, this op has now been optimised. A couple of cases below
7839 clear this again. */
7842 switch (o->op_type) {
7846 PL_curcop = ((COP*)o); /* for warnings */
7850 if (cSVOPo->op_private & OPpCONST_STRICT)
7851 no_bareword_allowed(o);
7853 case OP_METHOD_NAMED:
7854 /* Relocate sv to the pad for thread safety.
7855 * Despite being a "constant", the SV is written to,
7856 * for reference counts, sv_upgrade() etc. */
7858 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7859 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7860 /* If op_sv is already a PADTMP then it is being used by
7861 * some pad, so make a copy. */
7862 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7863 SvREADONLY_on(PAD_SVl(ix));
7864 SvREFCNT_dec(cSVOPo->op_sv);
7866 else if (o->op_type == OP_CONST
7867 && cSVOPo->op_sv == &PL_sv_undef) {
7868 /* PL_sv_undef is hack - it's unsafe to store it in the
7869 AV that is the pad, because av_fetch treats values of
7870 PL_sv_undef as a "free" AV entry and will merrily
7871 replace them with a new SV, causing pad_alloc to think
7872 that this pad slot is free. (When, clearly, it is not)
7874 SvOK_off(PAD_SVl(ix));
7875 SvPADTMP_on(PAD_SVl(ix));
7876 SvREADONLY_on(PAD_SVl(ix));
7879 SvREFCNT_dec(PAD_SVl(ix));
7880 SvPADTMP_on(cSVOPo->op_sv);
7881 PAD_SETSV(ix, cSVOPo->op_sv);
7882 /* XXX I don't know how this isn't readonly already. */
7883 SvREADONLY_on(PAD_SVl(ix));
7885 cSVOPo->op_sv = NULL;
7892 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7893 if (o->op_next->op_private & OPpTARGET_MY) {
7894 if (o->op_flags & OPf_STACKED) /* chained concats */
7895 break; /* ignore_optimization */
7897 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7898 o->op_targ = o->op_next->op_targ;
7899 o->op_next->op_targ = 0;
7900 o->op_private |= OPpTARGET_MY;
7903 op_null(o->op_next);
7907 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7908 break; /* Scalar stub must produce undef. List stub is noop */
7912 if (o->op_targ == OP_NEXTSTATE
7913 || o->op_targ == OP_DBSTATE
7914 || o->op_targ == OP_SETSTATE)
7916 PL_curcop = ((COP*)o);
7918 /* XXX: We avoid setting op_seq here to prevent later calls
7919 to peep() from mistakenly concluding that optimisation
7920 has already occurred. This doesn't fix the real problem,
7921 though (See 20010220.007). AMS 20010719 */
7922 /* op_seq functionality is now replaced by op_opt */
7929 if (oldop && o->op_next) {
7930 oldop->op_next = o->op_next;
7938 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7939 OP* const pop = (o->op_type == OP_PADAV) ?
7940 o->op_next : o->op_next->op_next;
7942 if (pop && pop->op_type == OP_CONST &&
7943 ((PL_op = pop->op_next)) &&
7944 pop->op_next->op_type == OP_AELEM &&
7945 !(pop->op_next->op_private &
7946 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7947 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7952 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7953 no_bareword_allowed(pop);
7954 if (o->op_type == OP_GV)
7955 op_null(o->op_next);
7956 op_null(pop->op_next);
7958 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7959 o->op_next = pop->op_next->op_next;
7960 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7961 o->op_private = (U8)i;
7962 if (o->op_type == OP_GV) {
7967 o->op_flags |= OPf_SPECIAL;
7968 o->op_type = OP_AELEMFAST;
7973 if (o->op_next->op_type == OP_RV2SV) {
7974 if (!(o->op_next->op_private & OPpDEREF)) {
7975 op_null(o->op_next);
7976 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7978 o->op_next = o->op_next->op_next;
7979 o->op_type = OP_GVSV;
7980 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7983 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7984 GV * const gv = cGVOPo_gv;
7985 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7986 /* XXX could check prototype here instead of just carping */
7987 SV * const sv = sv_newmortal();
7988 gv_efullname3(sv, gv, NULL);
7989 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7990 "%"SVf"() called too early to check prototype",
7994 else if (o->op_next->op_type == OP_READLINE
7995 && o->op_next->op_next->op_type == OP_CONCAT
7996 && (o->op_next->op_next->op_flags & OPf_STACKED))
7998 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7999 o->op_type = OP_RCATLINE;
8000 o->op_flags |= OPf_STACKED;
8001 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8002 op_null(o->op_next->op_next);
8003 op_null(o->op_next);
8018 while (cLOGOP->op_other->op_type == OP_NULL)
8019 cLOGOP->op_other = cLOGOP->op_other->op_next;
8020 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8025 while (cLOOP->op_redoop->op_type == OP_NULL)
8026 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8027 peep(cLOOP->op_redoop);
8028 while (cLOOP->op_nextop->op_type == OP_NULL)
8029 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8030 peep(cLOOP->op_nextop);
8031 while (cLOOP->op_lastop->op_type == OP_NULL)
8032 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8033 peep(cLOOP->op_lastop);
8037 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8038 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8039 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8040 cPMOP->op_pmstashstartu.op_pmreplstart
8041 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8042 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8046 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8047 && ckWARN(WARN_SYNTAX))
8049 if (o->op_next->op_sibling) {
8050 const OPCODE type = o->op_next->op_sibling->op_type;
8051 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8052 const line_t oldline = CopLINE(PL_curcop);
8053 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8054 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8055 "Statement unlikely to be reached");
8056 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8057 "\t(Maybe you meant system() when you said exec()?)\n");
8058 CopLINE_set(PL_curcop, oldline);
8069 const char *key = NULL;
8072 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8075 /* Make the CONST have a shared SV */
8076 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8077 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8078 key = SvPV_const(sv, keylen);
8079 lexname = newSVpvn_share(key,
8080 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8086 if ((o->op_private & (OPpLVAL_INTRO)))
8089 rop = (UNOP*)((BINOP*)o)->op_first;
8090 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8092 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8093 if (!SvPAD_TYPED(lexname))
8095 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8096 if (!fields || !GvHV(*fields))
8098 key = SvPV_const(*svp, keylen);
8099 if (!hv_fetch(GvHV(*fields), key,
8100 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8102 Perl_croak(aTHX_ "No such class field \"%s\" "
8103 "in variable %s of type %s",
8104 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8117 SVOP *first_key_op, *key_op;
8119 if ((o->op_private & (OPpLVAL_INTRO))
8120 /* I bet there's always a pushmark... */
8121 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8122 /* hmmm, no optimization if list contains only one key. */
8124 rop = (UNOP*)((LISTOP*)o)->op_last;
8125 if (rop->op_type != OP_RV2HV)
8127 if (rop->op_first->op_type == OP_PADSV)
8128 /* @$hash{qw(keys here)} */
8129 rop = (UNOP*)rop->op_first;
8131 /* @{$hash}{qw(keys here)} */
8132 if (rop->op_first->op_type == OP_SCOPE
8133 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8135 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8141 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8142 if (!SvPAD_TYPED(lexname))
8144 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8145 if (!fields || !GvHV(*fields))
8147 /* Again guessing that the pushmark can be jumped over.... */
8148 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8149 ->op_first->op_sibling;
8150 for (key_op = first_key_op; key_op;
8151 key_op = (SVOP*)key_op->op_sibling) {
8152 if (key_op->op_type != OP_CONST)
8154 svp = cSVOPx_svp(key_op);
8155 key = SvPV_const(*svp, keylen);
8156 if (!hv_fetch(GvHV(*fields), key,
8157 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8159 Perl_croak(aTHX_ "No such class field \"%s\" "
8160 "in variable %s of type %s",
8161 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8168 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8172 /* check that RHS of sort is a single plain array */
8173 OP *oright = cUNOPo->op_first;
8174 if (!oright || oright->op_type != OP_PUSHMARK)
8177 /* reverse sort ... can be optimised. */
8178 if (!cUNOPo->op_sibling) {
8179 /* Nothing follows us on the list. */
8180 OP * const reverse = o->op_next;
8182 if (reverse->op_type == OP_REVERSE &&
8183 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8184 OP * const pushmark = cUNOPx(reverse)->op_first;
8185 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8186 && (cUNOPx(pushmark)->op_sibling == o)) {
8187 /* reverse -> pushmark -> sort */
8188 o->op_private |= OPpSORT_REVERSE;
8190 pushmark->op_next = oright->op_next;
8196 /* make @a = sort @a act in-place */
8198 oright = cUNOPx(oright)->op_sibling;
8201 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8202 oright = cUNOPx(oright)->op_sibling;
8206 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8207 || oright->op_next != o
8208 || (oright->op_private & OPpLVAL_INTRO)
8212 /* o2 follows the chain of op_nexts through the LHS of the
8213 * assign (if any) to the aassign op itself */
8215 if (!o2 || o2->op_type != OP_NULL)
8218 if (!o2 || o2->op_type != OP_PUSHMARK)
8221 if (o2 && o2->op_type == OP_GV)
8224 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8225 || (o2->op_private & OPpLVAL_INTRO)
8230 if (!o2 || o2->op_type != OP_NULL)
8233 if (!o2 || o2->op_type != OP_AASSIGN
8234 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8237 /* check that the sort is the first arg on RHS of assign */
8239 o2 = cUNOPx(o2)->op_first;
8240 if (!o2 || o2->op_type != OP_NULL)
8242 o2 = cUNOPx(o2)->op_first;
8243 if (!o2 || o2->op_type != OP_PUSHMARK)
8245 if (o2->op_sibling != o)
8248 /* check the array is the same on both sides */
8249 if (oleft->op_type == OP_RV2AV) {
8250 if (oright->op_type != OP_RV2AV
8251 || !cUNOPx(oright)->op_first
8252 || cUNOPx(oright)->op_first->op_type != OP_GV
8253 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8254 cGVOPx_gv(cUNOPx(oright)->op_first)
8258 else if (oright->op_type != OP_PADAV
8259 || oright->op_targ != oleft->op_targ
8263 /* transfer MODishness etc from LHS arg to RHS arg */
8264 oright->op_flags = oleft->op_flags;
8265 o->op_private |= OPpSORT_INPLACE;
8267 /* excise push->gv->rv2av->null->aassign */
8268 o2 = o->op_next->op_next;
8269 op_null(o2); /* PUSHMARK */
8271 if (o2->op_type == OP_GV) {
8272 op_null(o2); /* GV */
8275 op_null(o2); /* RV2AV or PADAV */
8276 o2 = o2->op_next->op_next;
8277 op_null(o2); /* AASSIGN */
8279 o->op_next = o2->op_next;
8285 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8287 LISTOP *enter, *exlist;
8289 enter = (LISTOP *) o->op_next;
8292 if (enter->op_type == OP_NULL) {
8293 enter = (LISTOP *) enter->op_next;
8297 /* for $a (...) will have OP_GV then OP_RV2GV here.
8298 for (...) just has an OP_GV. */
8299 if (enter->op_type == OP_GV) {
8300 gvop = (OP *) enter;
8301 enter = (LISTOP *) enter->op_next;
8304 if (enter->op_type == OP_RV2GV) {
8305 enter = (LISTOP *) enter->op_next;
8311 if (enter->op_type != OP_ENTERITER)
8314 iter = enter->op_next;
8315 if (!iter || iter->op_type != OP_ITER)
8318 expushmark = enter->op_first;
8319 if (!expushmark || expushmark->op_type != OP_NULL
8320 || expushmark->op_targ != OP_PUSHMARK)
8323 exlist = (LISTOP *) expushmark->op_sibling;
8324 if (!exlist || exlist->op_type != OP_NULL
8325 || exlist->op_targ != OP_LIST)
8328 if (exlist->op_last != o) {
8329 /* Mmm. Was expecting to point back to this op. */
8332 theirmark = exlist->op_first;
8333 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8336 if (theirmark->op_sibling != o) {
8337 /* There's something between the mark and the reverse, eg
8338 for (1, reverse (...))
8343 ourmark = ((LISTOP *)o)->op_first;
8344 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8347 ourlast = ((LISTOP *)o)->op_last;
8348 if (!ourlast || ourlast->op_next != o)
8351 rv2av = ourmark->op_sibling;
8352 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8353 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8354 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8355 /* We're just reversing a single array. */
8356 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8357 enter->op_flags |= OPf_STACKED;
8360 /* We don't have control over who points to theirmark, so sacrifice
8362 theirmark->op_next = ourmark->op_next;
8363 theirmark->op_flags = ourmark->op_flags;
8364 ourlast->op_next = gvop ? gvop : (OP *) enter;
8367 enter->op_private |= OPpITER_REVERSED;
8368 iter->op_private |= OPpITER_REVERSED;
8375 UNOP *refgen, *rv2cv;
8378 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8381 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8384 rv2gv = ((BINOP *)o)->op_last;
8385 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8388 refgen = (UNOP *)((BINOP *)o)->op_first;
8390 if (!refgen || refgen->op_type != OP_REFGEN)
8393 exlist = (LISTOP *)refgen->op_first;
8394 if (!exlist || exlist->op_type != OP_NULL
8395 || exlist->op_targ != OP_LIST)
8398 if (exlist->op_first->op_type != OP_PUSHMARK)
8401 rv2cv = (UNOP*)exlist->op_last;
8403 if (rv2cv->op_type != OP_RV2CV)
8406 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8407 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8408 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8410 o->op_private |= OPpASSIGN_CV_TO_GV;
8411 rv2gv->op_private |= OPpDONT_INIT_GV;
8412 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8420 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8421 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8431 Perl_custom_op_name(pTHX_ const OP* o)
8434 const IV index = PTR2IV(o->op_ppaddr);
8438 if (!PL_custom_op_names) /* This probably shouldn't happen */
8439 return (char *)PL_op_name[OP_CUSTOM];
8441 keysv = sv_2mortal(newSViv(index));
8443 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8445 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8447 return SvPV_nolen(HeVAL(he));
8451 Perl_custom_op_desc(pTHX_ const OP* o)
8454 const IV index = PTR2IV(o->op_ppaddr);
8458 if (!PL_custom_op_descs)
8459 return (char *)PL_op_desc[OP_CUSTOM];
8461 keysv = sv_2mortal(newSViv(index));
8463 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8465 return (char *)PL_op_desc[OP_CUSTOM];
8467 return SvPV_nolen(HeVAL(he));
8472 /* Efficient sub that returns a constant scalar value. */
8474 const_sv_xsub(pTHX_ CV* cv)
8481 Perl_croak(aTHX_ "usage: %s::%s()",
8482 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8486 ST(0) = (SV*)XSANY.any_ptr;
8492 * c-indentation-style: bsd
8494 * indent-tabs-mode: t
8497 * ex: set ts=8 sts=4 sw=4 noet: