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 && !PL_madskills) {
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 */
4106 op_free(o); /* blow off assign */
4107 right->op_flags &= ~OPf_WANT;
4108 /* "I don't know and I don't care." */
4113 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4114 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4116 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4118 sv_setiv(sv, PL_modcount+1);
4126 right = newOP(OP_UNDEF, 0);
4127 if (right->op_type == OP_READLINE) {
4128 right->op_flags |= OPf_STACKED;
4129 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4132 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4133 o = newBINOP(OP_SASSIGN, flags,
4134 scalar(right), mod(scalar(left), OP_SASSIGN) );
4140 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4141 o->op_private |= OPpCONST_ARYBASE;
4148 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4151 const U32 seq = intro_my();
4154 NewOp(1101, cop, 1, COP);
4155 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4156 cop->op_type = OP_DBSTATE;
4157 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4160 cop->op_type = OP_NEXTSTATE;
4161 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4163 cop->op_flags = (U8)flags;
4164 CopHINTS_set(cop, PL_hints);
4166 cop->op_private |= NATIVE_HINTS;
4168 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4169 cop->op_next = (OP*)cop;
4172 CopLABEL_set(cop, label);
4173 PL_hints |= HINT_BLOCK_SCOPE;
4176 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4177 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4179 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4180 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4181 if (cop->cop_hints_hash) {
4183 cop->cop_hints_hash->refcounted_he_refcnt++;
4184 HINTS_REFCNT_UNLOCK;
4187 if (PL_parser && PL_parser->copline == NOLINE)
4188 CopLINE_set(cop, CopLINE(PL_curcop));
4190 CopLINE_set(cop, PL_parser->copline);
4192 PL_parser->copline = NOLINE;
4195 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4197 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4199 CopSTASH_set(cop, PL_curstash);
4201 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4202 AV *av = CopFILEAVx(PL_curcop);
4204 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4205 if (svp && *svp != &PL_sv_undef ) {
4206 (void)SvIOK_on(*svp);
4207 SvIV_set(*svp, PTR2IV(cop));
4212 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4217 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4220 return new_logop(type, flags, &first, &other);
4224 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4229 OP *first = *firstp;
4230 OP * const other = *otherp;
4232 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4233 return newBINOP(type, flags, scalar(first), scalar(other));
4235 scalarboolean(first);
4236 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4237 if (first->op_type == OP_NOT
4238 && (first->op_flags & OPf_SPECIAL)
4239 && (first->op_flags & OPf_KIDS)
4241 if (type == OP_AND || type == OP_OR) {
4247 first = *firstp = cUNOPo->op_first;
4249 first->op_next = o->op_next;
4250 cUNOPo->op_first = NULL;
4254 if (first->op_type == OP_CONST) {
4255 if (first->op_private & OPpCONST_STRICT)
4256 no_bareword_allowed(first);
4257 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4258 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4259 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4260 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4261 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4263 if (other->op_type == OP_CONST)
4264 other->op_private |= OPpCONST_SHORTCIRCUIT;
4266 OP *newop = newUNOP(OP_NULL, 0, other);
4267 op_getmad(first, newop, '1');
4268 newop->op_targ = type; /* set "was" field */
4275 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4276 const OP *o2 = other;
4277 if ( ! (o2->op_type == OP_LIST
4278 && (( o2 = cUNOPx(o2)->op_first))
4279 && o2->op_type == OP_PUSHMARK
4280 && (( o2 = o2->op_sibling)) )
4283 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4284 || o2->op_type == OP_PADHV)
4285 && o2->op_private & OPpLVAL_INTRO
4286 && ckWARN(WARN_DEPRECATED))
4288 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4289 "Deprecated use of my() in false conditional");
4293 if (first->op_type == OP_CONST)
4294 first->op_private |= OPpCONST_SHORTCIRCUIT;
4296 first = newUNOP(OP_NULL, 0, first);
4297 op_getmad(other, first, '2');
4298 first->op_targ = type; /* set "was" field */
4305 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4306 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4308 const OP * const k1 = ((UNOP*)first)->op_first;
4309 const OP * const k2 = k1->op_sibling;
4311 switch (first->op_type)
4314 if (k2 && k2->op_type == OP_READLINE
4315 && (k2->op_flags & OPf_STACKED)
4316 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4318 warnop = k2->op_type;
4323 if (k1->op_type == OP_READDIR
4324 || k1->op_type == OP_GLOB
4325 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4326 || k1->op_type == OP_EACH)
4328 warnop = ((k1->op_type == OP_NULL)
4329 ? (OPCODE)k1->op_targ : k1->op_type);
4334 const line_t oldline = CopLINE(PL_curcop);
4335 CopLINE_set(PL_curcop, PL_parser->copline);
4336 Perl_warner(aTHX_ packWARN(WARN_MISC),
4337 "Value of %s%s can be \"0\"; test with defined()",
4339 ((warnop == OP_READLINE || warnop == OP_GLOB)
4340 ? " construct" : "() operator"));
4341 CopLINE_set(PL_curcop, oldline);
4348 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4349 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4351 NewOp(1101, logop, 1, LOGOP);
4353 logop->op_type = (OPCODE)type;
4354 logop->op_ppaddr = PL_ppaddr[type];
4355 logop->op_first = first;
4356 logop->op_flags = (U8)(flags | OPf_KIDS);
4357 logop->op_other = LINKLIST(other);
4358 logop->op_private = (U8)(1 | (flags >> 8));
4360 /* establish postfix order */
4361 logop->op_next = LINKLIST(first);
4362 first->op_next = (OP*)logop;
4363 first->op_sibling = other;
4365 CHECKOP(type,logop);
4367 o = newUNOP(OP_NULL, 0, (OP*)logop);
4374 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4382 return newLOGOP(OP_AND, 0, first, trueop);
4384 return newLOGOP(OP_OR, 0, first, falseop);
4386 scalarboolean(first);
4387 if (first->op_type == OP_CONST) {
4388 /* Left or right arm of the conditional? */
4389 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4390 OP *live = left ? trueop : falseop;
4391 OP *const dead = left ? falseop : trueop;
4392 if (first->op_private & OPpCONST_BARE &&
4393 first->op_private & OPpCONST_STRICT) {
4394 no_bareword_allowed(first);
4397 /* This is all dead code when PERL_MAD is not defined. */
4398 live = newUNOP(OP_NULL, 0, live);
4399 op_getmad(first, live, 'C');
4400 op_getmad(dead, live, left ? 'e' : 't');
4407 NewOp(1101, logop, 1, LOGOP);
4408 logop->op_type = OP_COND_EXPR;
4409 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4410 logop->op_first = first;
4411 logop->op_flags = (U8)(flags | OPf_KIDS);
4412 logop->op_private = (U8)(1 | (flags >> 8));
4413 logop->op_other = LINKLIST(trueop);
4414 logop->op_next = LINKLIST(falseop);
4416 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4419 /* establish postfix order */
4420 start = LINKLIST(first);
4421 first->op_next = (OP*)logop;
4423 first->op_sibling = trueop;
4424 trueop->op_sibling = falseop;
4425 o = newUNOP(OP_NULL, 0, (OP*)logop);
4427 trueop->op_next = falseop->op_next = o;
4434 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4443 NewOp(1101, range, 1, LOGOP);
4445 range->op_type = OP_RANGE;
4446 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4447 range->op_first = left;
4448 range->op_flags = OPf_KIDS;
4449 leftstart = LINKLIST(left);
4450 range->op_other = LINKLIST(right);
4451 range->op_private = (U8)(1 | (flags >> 8));
4453 left->op_sibling = right;
4455 range->op_next = (OP*)range;
4456 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4457 flop = newUNOP(OP_FLOP, 0, flip);
4458 o = newUNOP(OP_NULL, 0, flop);
4460 range->op_next = leftstart;
4462 left->op_next = flip;
4463 right->op_next = flop;
4465 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4466 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4467 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4468 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4470 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4471 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4474 if (!flip->op_private || !flop->op_private)
4475 linklist(o); /* blow off optimizer unless constant */
4481 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4486 const bool once = block && block->op_flags & OPf_SPECIAL &&
4487 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4489 PERL_UNUSED_ARG(debuggable);
4492 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4493 return block; /* do {} while 0 does once */
4494 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4495 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4496 expr = newUNOP(OP_DEFINED, 0,
4497 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4498 } else if (expr->op_flags & OPf_KIDS) {
4499 const OP * const k1 = ((UNOP*)expr)->op_first;
4500 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4501 switch (expr->op_type) {
4503 if (k2 && k2->op_type == OP_READLINE
4504 && (k2->op_flags & OPf_STACKED)
4505 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4506 expr = newUNOP(OP_DEFINED, 0, expr);
4510 if (k1 && (k1->op_type == OP_READDIR
4511 || k1->op_type == OP_GLOB
4512 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4513 || k1->op_type == OP_EACH))
4514 expr = newUNOP(OP_DEFINED, 0, expr);
4520 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4521 * op, in listop. This is wrong. [perl #27024] */
4523 block = newOP(OP_NULL, 0);
4524 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4525 o = new_logop(OP_AND, 0, &expr, &listop);
4528 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4530 if (once && o != listop)
4531 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4534 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4536 o->op_flags |= flags;
4538 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4543 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4544 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4553 PERL_UNUSED_ARG(debuggable);
4556 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4557 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4558 expr = newUNOP(OP_DEFINED, 0,
4559 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4560 } else if (expr->op_flags & OPf_KIDS) {
4561 const OP * const k1 = ((UNOP*)expr)->op_first;
4562 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4563 switch (expr->op_type) {
4565 if (k2 && k2->op_type == OP_READLINE
4566 && (k2->op_flags & OPf_STACKED)
4567 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4568 expr = newUNOP(OP_DEFINED, 0, expr);
4572 if (k1 && (k1->op_type == OP_READDIR
4573 || k1->op_type == OP_GLOB
4574 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4575 || k1->op_type == OP_EACH))
4576 expr = newUNOP(OP_DEFINED, 0, expr);
4583 block = newOP(OP_NULL, 0);
4584 else if (cont || has_my) {
4585 block = scope(block);
4589 next = LINKLIST(cont);
4592 OP * const unstack = newOP(OP_UNSTACK, 0);
4595 cont = append_elem(OP_LINESEQ, cont, unstack);
4599 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4601 redo = LINKLIST(listop);
4604 PL_parser->copline = (line_t)whileline;
4606 o = new_logop(OP_AND, 0, &expr, &listop);
4607 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4608 op_free(expr); /* oops, it's a while (0) */
4610 return NULL; /* listop already freed by new_logop */
4613 ((LISTOP*)listop)->op_last->op_next =
4614 (o == listop ? redo : LINKLIST(o));
4620 NewOp(1101,loop,1,LOOP);
4621 loop->op_type = OP_ENTERLOOP;
4622 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4623 loop->op_private = 0;
4624 loop->op_next = (OP*)loop;
4627 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4629 loop->op_redoop = redo;
4630 loop->op_lastop = o;
4631 o->op_private |= loopflags;
4634 loop->op_nextop = next;
4636 loop->op_nextop = o;
4638 o->op_flags |= flags;
4639 o->op_private |= (flags >> 8);
4644 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4649 PADOFFSET padoff = 0;
4655 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4656 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4657 sv->op_type = OP_RV2GV;
4658 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4660 /* The op_type check is needed to prevent a possible segfault
4661 * if the loop variable is undeclared and 'strict vars' is in
4662 * effect. This is illegal but is nonetheless parsed, so we
4663 * may reach this point with an OP_CONST where we're expecting
4666 if (cUNOPx(sv)->op_first->op_type == OP_GV
4667 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4668 iterpflags |= OPpITER_DEF;
4670 else if (sv->op_type == OP_PADSV) { /* private variable */
4671 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4672 padoff = sv->op_targ;
4682 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4684 SV *const namesv = PAD_COMPNAME_SV(padoff);
4686 const char *const name = SvPV_const(namesv, len);
4688 if (len == 2 && name[0] == '$' && name[1] == '_')
4689 iterpflags |= OPpITER_DEF;
4693 const PADOFFSET offset = pad_findmy("$_");
4694 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4695 sv = newGVOP(OP_GV, 0, PL_defgv);
4700 iterpflags |= OPpITER_DEF;
4702 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4703 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4704 iterflags |= OPf_STACKED;
4706 else if (expr->op_type == OP_NULL &&
4707 (expr->op_flags & OPf_KIDS) &&
4708 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4710 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4711 * set the STACKED flag to indicate that these values are to be
4712 * treated as min/max values by 'pp_iterinit'.
4714 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4715 LOGOP* const range = (LOGOP*) flip->op_first;
4716 OP* const left = range->op_first;
4717 OP* const right = left->op_sibling;
4720 range->op_flags &= ~OPf_KIDS;
4721 range->op_first = NULL;
4723 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4724 listop->op_first->op_next = range->op_next;
4725 left->op_next = range->op_other;
4726 right->op_next = (OP*)listop;
4727 listop->op_next = listop->op_first;
4730 op_getmad(expr,(OP*)listop,'O');
4734 expr = (OP*)(listop);
4736 iterflags |= OPf_STACKED;
4739 expr = mod(force_list(expr), OP_GREPSTART);
4742 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4743 append_elem(OP_LIST, expr, scalar(sv))));
4744 assert(!loop->op_next);
4745 /* for my $x () sets OPpLVAL_INTRO;
4746 * for our $x () sets OPpOUR_INTRO */
4747 loop->op_private = (U8)iterpflags;
4748 #ifdef PL_OP_SLAB_ALLOC
4751 NewOp(1234,tmp,1,LOOP);
4752 Copy(loop,tmp,1,LISTOP);
4753 S_op_destroy(aTHX_ (OP*)loop);
4757 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4759 loop->op_targ = padoff;
4760 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4762 op_getmad(madsv, (OP*)loop, 'v');
4763 PL_parser->copline = forline;
4764 return newSTATEOP(0, label, wop);
4768 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4773 if (type != OP_GOTO || label->op_type == OP_CONST) {
4774 /* "last()" means "last" */
4775 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4776 o = newOP(type, OPf_SPECIAL);
4778 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4779 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4783 op_getmad(label,o,'L');
4789 /* Check whether it's going to be a goto &function */
4790 if (label->op_type == OP_ENTERSUB
4791 && !(label->op_flags & OPf_STACKED))
4792 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4793 o = newUNOP(type, OPf_STACKED, label);
4795 PL_hints |= HINT_BLOCK_SCOPE;
4799 /* if the condition is a literal array or hash
4800 (or @{ ... } etc), make a reference to it.
4803 S_ref_array_or_hash(pTHX_ OP *cond)
4806 && (cond->op_type == OP_RV2AV
4807 || cond->op_type == OP_PADAV
4808 || cond->op_type == OP_RV2HV
4809 || cond->op_type == OP_PADHV))
4811 return newUNOP(OP_REFGEN,
4812 0, mod(cond, OP_REFGEN));
4818 /* These construct the optree fragments representing given()
4821 entergiven and enterwhen are LOGOPs; the op_other pointer
4822 points up to the associated leave op. We need this so we
4823 can put it in the context and make break/continue work.
4824 (Also, of course, pp_enterwhen will jump straight to
4825 op_other if the match fails.)
4829 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4830 I32 enter_opcode, I32 leave_opcode,
4831 PADOFFSET entertarg)
4837 NewOp(1101, enterop, 1, LOGOP);
4838 enterop->op_type = enter_opcode;
4839 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4840 enterop->op_flags = (U8) OPf_KIDS;
4841 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4842 enterop->op_private = 0;
4844 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4847 enterop->op_first = scalar(cond);
4848 cond->op_sibling = block;
4850 o->op_next = LINKLIST(cond);
4851 cond->op_next = (OP *) enterop;
4854 /* This is a default {} block */
4855 enterop->op_first = block;
4856 enterop->op_flags |= OPf_SPECIAL;
4858 o->op_next = (OP *) enterop;
4861 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4862 entergiven and enterwhen both
4865 enterop->op_next = LINKLIST(block);
4866 block->op_next = enterop->op_other = o;
4871 /* Does this look like a boolean operation? For these purposes
4872 a boolean operation is:
4873 - a subroutine call [*]
4874 - a logical connective
4875 - a comparison operator
4876 - a filetest operator, with the exception of -s -M -A -C
4877 - defined(), exists() or eof()
4878 - /$re/ or $foo =~ /$re/
4880 [*] possibly surprising
4883 S_looks_like_bool(pTHX_ const OP *o)
4886 switch(o->op_type) {
4888 return looks_like_bool(cLOGOPo->op_first);
4892 looks_like_bool(cLOGOPo->op_first)
4893 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4897 case OP_NOT: case OP_XOR:
4898 /* Note that OP_DOR is not here */
4900 case OP_EQ: case OP_NE: case OP_LT:
4901 case OP_GT: case OP_LE: case OP_GE:
4903 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4904 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4906 case OP_SEQ: case OP_SNE: case OP_SLT:
4907 case OP_SGT: case OP_SLE: case OP_SGE:
4911 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4912 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4913 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4914 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4915 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4916 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4917 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4918 case OP_FTTEXT: case OP_FTBINARY:
4920 case OP_DEFINED: case OP_EXISTS:
4921 case OP_MATCH: case OP_EOF:
4926 /* Detect comparisons that have been optimized away */
4927 if (cSVOPo->op_sv == &PL_sv_yes
4928 || cSVOPo->op_sv == &PL_sv_no)
4939 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4943 return newGIVWHENOP(
4944 ref_array_or_hash(cond),
4946 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4950 /* If cond is null, this is a default {} block */
4952 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4954 const bool cond_llb = (!cond || looks_like_bool(cond));
4960 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4962 scalar(ref_array_or_hash(cond)));
4965 return newGIVWHENOP(
4967 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4968 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4972 =for apidoc cv_undef
4974 Clear out all the active components of a CV. This can happen either
4975 by an explicit C<undef &foo>, or by the reference count going to zero.
4976 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4977 children can still follow the full lexical scope chain.
4983 Perl_cv_undef(pTHX_ CV *cv)
4987 if (CvFILE(cv) && !CvISXSUB(cv)) {
4988 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4989 Safefree(CvFILE(cv));
4994 if (!CvISXSUB(cv) && CvROOT(cv)) {
4995 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4996 Perl_croak(aTHX_ "Can't undef active subroutine");
4999 PAD_SAVE_SETNULLPAD();
5001 op_free(CvROOT(cv));
5006 SvPOK_off((SV*)cv); /* forget prototype */
5011 /* remove CvOUTSIDE unless this is an undef rather than a free */
5012 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5013 if (!CvWEAKOUTSIDE(cv))
5014 SvREFCNT_dec(CvOUTSIDE(cv));
5015 CvOUTSIDE(cv) = NULL;
5018 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5021 if (CvISXSUB(cv) && CvXSUB(cv)) {
5024 /* delete all flags except WEAKOUTSIDE */
5025 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5029 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5032 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5033 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5034 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5035 || (p && (len != SvCUR(cv) /* Not the same length. */
5036 || memNE(p, SvPVX_const(cv), len))))
5037 && ckWARN_d(WARN_PROTOTYPE)) {
5038 SV* const msg = sv_newmortal();
5042 gv_efullname3(name = sv_newmortal(), gv, NULL);
5043 sv_setpvs(msg, "Prototype mismatch:");
5045 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5047 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5049 sv_catpvs(msg, ": none");
5050 sv_catpvs(msg, " vs ");
5052 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5054 sv_catpvs(msg, "none");
5055 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5059 static void const_sv_xsub(pTHX_ CV* cv);
5063 =head1 Optree Manipulation Functions
5065 =for apidoc cv_const_sv
5067 If C<cv> is a constant sub eligible for inlining. returns the constant
5068 value returned by the sub. Otherwise, returns NULL.
5070 Constant subs can be created with C<newCONSTSUB> or as described in
5071 L<perlsub/"Constant Functions">.
5076 Perl_cv_const_sv(pTHX_ CV *cv)
5078 PERL_UNUSED_CONTEXT;
5081 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5083 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5086 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5087 * Can be called in 3 ways:
5090 * look for a single OP_CONST with attached value: return the value
5092 * cv && CvCLONE(cv) && !CvCONST(cv)
5094 * examine the clone prototype, and if contains only a single
5095 * OP_CONST referencing a pad const, or a single PADSV referencing
5096 * an outer lexical, return a non-zero value to indicate the CV is
5097 * a candidate for "constizing" at clone time
5101 * We have just cloned an anon prototype that was marked as a const
5102 * candidiate. Try to grab the current value, and in the case of
5103 * PADSV, ignore it if it has multiple references. Return the value.
5107 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5115 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5116 o = cLISTOPo->op_first->op_sibling;
5118 for (; o; o = o->op_next) {
5119 const OPCODE type = o->op_type;
5121 if (sv && o->op_next == o)
5123 if (o->op_next != o) {
5124 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5126 if (type == OP_DBSTATE)
5129 if (type == OP_LEAVESUB || type == OP_RETURN)
5133 if (type == OP_CONST && cSVOPo->op_sv)
5135 else if (cv && type == OP_CONST) {
5136 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5140 else if (cv && type == OP_PADSV) {
5141 if (CvCONST(cv)) { /* newly cloned anon */
5142 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5143 /* the candidate should have 1 ref from this pad and 1 ref
5144 * from the parent */
5145 if (!sv || SvREFCNT(sv) != 2)
5152 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5153 sv = &PL_sv_undef; /* an arbitrary non-null value */
5168 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5171 /* This would be the return value, but the return cannot be reached. */
5172 OP* pegop = newOP(OP_NULL, 0);
5175 PERL_UNUSED_ARG(floor);
5185 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5187 NORETURN_FUNCTION_END;
5192 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5194 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5198 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5205 register CV *cv = NULL;
5207 /* If the subroutine has no body, no attributes, and no builtin attributes
5208 then it's just a sub declaration, and we may be able to get away with
5209 storing with a placeholder scalar in the symbol table, rather than a
5210 full GV and CV. If anything is present then it will take a full CV to
5212 const I32 gv_fetch_flags
5213 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5215 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5216 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5219 assert(proto->op_type == OP_CONST);
5220 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5225 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5226 SV * const sv = sv_newmortal();
5227 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5228 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5229 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5230 aname = SvPVX_const(sv);
5235 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5236 : gv_fetchpv(aname ? aname
5237 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5238 gv_fetch_flags, SVt_PVCV);
5240 if (!PL_madskills) {
5249 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5250 maximum a prototype before. */
5251 if (SvTYPE(gv) > SVt_NULL) {
5252 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5253 && ckWARN_d(WARN_PROTOTYPE))
5255 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5257 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5260 sv_setpvn((SV*)gv, ps, ps_len);
5262 sv_setiv((SV*)gv, -1);
5264 SvREFCNT_dec(PL_compcv);
5265 cv = PL_compcv = NULL;
5269 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5271 #ifdef GV_UNIQUE_CHECK
5272 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5273 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5277 if (!block || !ps || *ps || attrs
5278 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5280 || block->op_type == OP_NULL
5285 const_sv = op_const_sv(block, NULL);
5288 const bool exists = CvROOT(cv) || CvXSUB(cv);
5290 #ifdef GV_UNIQUE_CHECK
5291 if (exists && GvUNIQUE(gv)) {
5292 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5296 /* if the subroutine doesn't exist and wasn't pre-declared
5297 * with a prototype, assume it will be AUTOLOADed,
5298 * skipping the prototype check
5300 if (exists || SvPOK(cv))
5301 cv_ckproto_len(cv, gv, ps, ps_len);
5302 /* already defined (or promised)? */
5303 if (exists || GvASSUMECV(gv)) {
5306 || block->op_type == OP_NULL
5309 if (CvFLAGS(PL_compcv)) {
5310 /* might have had built-in attrs applied */
5311 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5313 /* just a "sub foo;" when &foo is already defined */
5314 SAVEFREESV(PL_compcv);
5319 && block->op_type != OP_NULL
5322 if (ckWARN(WARN_REDEFINE)
5324 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5326 const line_t oldline = CopLINE(PL_curcop);
5327 if (PL_parser && PL_parser->copline != NOLINE)
5328 CopLINE_set(PL_curcop, PL_parser->copline);
5329 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5330 CvCONST(cv) ? "Constant subroutine %s redefined"
5331 : "Subroutine %s redefined", name);
5332 CopLINE_set(PL_curcop, oldline);
5335 if (!PL_minus_c) /* keep old one around for madskills */
5338 /* (PL_madskills unset in used file.) */
5346 SvREFCNT_inc_simple_void_NN(const_sv);
5348 assert(!CvROOT(cv) && !CvCONST(cv));
5349 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5350 CvXSUBANY(cv).any_ptr = const_sv;
5351 CvXSUB(cv) = const_sv_xsub;
5357 cv = newCONSTSUB(NULL, name, const_sv);
5359 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5360 (CvGV(cv) && GvSTASH(CvGV(cv)))
5369 SvREFCNT_dec(PL_compcv);
5377 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5378 * before we clobber PL_compcv.
5382 || block->op_type == OP_NULL
5386 /* Might have had built-in attributes applied -- propagate them. */
5387 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5388 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5389 stash = GvSTASH(CvGV(cv));
5390 else if (CvSTASH(cv))
5391 stash = CvSTASH(cv);
5393 stash = PL_curstash;
5396 /* possibly about to re-define existing subr -- ignore old cv */
5397 rcv = (SV*)PL_compcv;
5398 if (name && GvSTASH(gv))
5399 stash = GvSTASH(gv);
5401 stash = PL_curstash;
5403 apply_attrs(stash, rcv, attrs, FALSE);
5405 if (cv) { /* must reuse cv if autoloaded */
5412 || block->op_type == OP_NULL) && !PL_madskills
5415 /* got here with just attrs -- work done, so bug out */
5416 SAVEFREESV(PL_compcv);
5419 /* transfer PL_compcv to cv */
5421 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5422 if (!CvWEAKOUTSIDE(cv))
5423 SvREFCNT_dec(CvOUTSIDE(cv));
5424 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5425 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5426 CvOUTSIDE(PL_compcv) = 0;
5427 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5428 CvPADLIST(PL_compcv) = 0;
5429 /* inner references to PL_compcv must be fixed up ... */
5430 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5431 /* ... before we throw it away */
5432 SvREFCNT_dec(PL_compcv);
5434 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5435 ++PL_sub_generation;
5442 if (strEQ(name, "import")) {
5443 PL_formfeed = (SV*)cv;
5444 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5448 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5452 CvFILE_set_from_cop(cv, PL_curcop);
5453 CvSTASH(cv) = PL_curstash;
5456 sv_setpvn((SV*)cv, ps, ps_len);
5458 if (PL_error_count) {
5462 const char *s = strrchr(name, ':');
5464 if (strEQ(s, "BEGIN")) {
5465 const char not_safe[] =
5466 "BEGIN not safe after errors--compilation aborted";
5467 if (PL_in_eval & EVAL_KEEPERR)
5468 Perl_croak(aTHX_ not_safe);
5470 /* force display of errors found but not reported */
5471 sv_catpv(ERRSV, not_safe);
5472 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5482 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5483 mod(scalarseq(block), OP_LEAVESUBLV));
5484 block->op_attached = 1;
5487 /* This makes sub {}; work as expected. */
5488 if (block->op_type == OP_STUB) {
5489 OP* const newblock = newSTATEOP(0, NULL, 0);
5491 op_getmad(block,newblock,'B');
5498 block->op_attached = 1;
5499 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5501 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5502 OpREFCNT_set(CvROOT(cv), 1);
5503 CvSTART(cv) = LINKLIST(CvROOT(cv));
5504 CvROOT(cv)->op_next = 0;
5505 CALL_PEEP(CvSTART(cv));
5507 /* now that optimizer has done its work, adjust pad values */
5509 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5512 assert(!CvCONST(cv));
5513 if (ps && !*ps && op_const_sv(block, cv))
5517 if (name || aname) {
5518 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5519 SV * const sv = newSV(0);
5520 SV * const tmpstr = sv_newmortal();
5521 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5522 GV_ADDMULTI, SVt_PVHV);
5525 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5527 (long)PL_subline, (long)CopLINE(PL_curcop));
5528 gv_efullname3(tmpstr, gv, NULL);
5529 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5530 hv = GvHVn(db_postponed);
5531 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5532 CV * const pcv = GvCV(db_postponed);
5538 call_sv((SV*)pcv, G_DISCARD);
5543 if (name && !PL_error_count)
5544 process_special_blocks(name, gv, cv);
5549 PL_parser->copline = NOLINE;
5555 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5558 const char *const colon = strrchr(fullname,':');
5559 const char *const name = colon ? colon + 1 : fullname;
5562 if (strEQ(name, "BEGIN")) {
5563 const I32 oldscope = PL_scopestack_ix;
5565 SAVECOPFILE(&PL_compiling);
5566 SAVECOPLINE(&PL_compiling);
5568 DEBUG_x( dump_sub(gv) );
5569 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5570 GvCV(gv) = 0; /* cv has been hijacked */
5571 call_list(oldscope, PL_beginav);
5573 PL_curcop = &PL_compiling;
5574 CopHINTS_set(&PL_compiling, PL_hints);
5581 if strEQ(name, "END") {
5582 DEBUG_x( dump_sub(gv) );
5583 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5586 } else if (*name == 'U') {
5587 if (strEQ(name, "UNITCHECK")) {
5588 /* It's never too late to run a unitcheck block */
5589 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5593 } else if (*name == 'C') {
5594 if (strEQ(name, "CHECK")) {
5595 if (PL_main_start && ckWARN(WARN_VOID))
5596 Perl_warner(aTHX_ packWARN(WARN_VOID),
5597 "Too late to run CHECK block");
5598 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5602 } else if (*name == 'I') {
5603 if (strEQ(name, "INIT")) {
5604 if (PL_main_start && ckWARN(WARN_VOID))
5605 Perl_warner(aTHX_ packWARN(WARN_VOID),
5606 "Too late to run INIT block");
5607 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5613 DEBUG_x( dump_sub(gv) );
5614 GvCV(gv) = 0; /* cv has been hijacked */
5619 =for apidoc newCONSTSUB
5621 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5622 eligible for inlining at compile-time.
5628 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5633 const char *const temp_p = CopFILE(PL_curcop);
5634 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5636 SV *const temp_sv = CopFILESV(PL_curcop);
5638 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5640 char *const file = savepvn(temp_p, temp_p ? len : 0);
5644 SAVECOPLINE(PL_curcop);
5645 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5648 PL_hints &= ~HINT_BLOCK_SCOPE;
5651 SAVESPTR(PL_curstash);
5652 SAVECOPSTASH(PL_curcop);
5653 PL_curstash = stash;
5654 CopSTASH_set(PL_curcop,stash);
5657 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5658 and so doesn't get free()d. (It's expected to be from the C pre-
5659 processor __FILE__ directive). But we need a dynamically allocated one,
5660 and we need it to get freed. */
5661 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5662 CvXSUBANY(cv).any_ptr = sv;
5668 CopSTASH_free(PL_curcop);
5676 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5677 const char *const filename, const char *const proto,
5680 CV *cv = newXS(name, subaddr, filename);
5682 if (flags & XS_DYNAMIC_FILENAME) {
5683 /* We need to "make arrangements" (ie cheat) to ensure that the
5684 filename lasts as long as the PVCV we just created, but also doesn't
5686 STRLEN filename_len = strlen(filename);
5687 STRLEN proto_and_file_len = filename_len;
5688 char *proto_and_file;
5692 proto_len = strlen(proto);
5693 proto_and_file_len += proto_len;
5695 Newx(proto_and_file, proto_and_file_len + 1, char);
5696 Copy(proto, proto_and_file, proto_len, char);
5697 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5700 proto_and_file = savepvn(filename, filename_len);
5703 /* This gets free()d. :-) */
5704 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5705 SV_HAS_TRAILING_NUL);
5707 /* This gives us the correct prototype, rather than one with the
5708 file name appended. */
5709 SvCUR_set(cv, proto_len);
5713 CvFILE(cv) = proto_and_file + proto_len;
5715 sv_setpv((SV *)cv, proto);
5721 =for apidoc U||newXS
5723 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5724 static storage, as it is used directly as CvFILE(), without a copy being made.
5730 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5733 GV * const gv = gv_fetchpv(name ? name :
5734 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5735 GV_ADDMULTI, SVt_PVCV);
5739 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5741 if ((cv = (name ? GvCV(gv) : NULL))) {
5743 /* just a cached method */
5747 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5748 /* already defined (or promised) */
5749 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5750 if (ckWARN(WARN_REDEFINE)) {
5751 GV * const gvcv = CvGV(cv);
5753 HV * const stash = GvSTASH(gvcv);
5755 const char *redefined_name = HvNAME_get(stash);
5756 if ( strEQ(redefined_name,"autouse") ) {
5757 const line_t oldline = CopLINE(PL_curcop);
5758 if (PL_parser && PL_parser->copline != NOLINE)
5759 CopLINE_set(PL_curcop, PL_parser->copline);
5760 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5761 CvCONST(cv) ? "Constant subroutine %s redefined"
5762 : "Subroutine %s redefined"
5764 CopLINE_set(PL_curcop, oldline);
5774 if (cv) /* must reuse cv if autoloaded */
5777 cv = (CV*)newSV_type(SVt_PVCV);
5781 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5785 (void)gv_fetchfile(filename);
5786 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5787 an external constant string */
5789 CvXSUB(cv) = subaddr;
5792 process_special_blocks(name, gv, cv);
5804 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5809 OP* pegop = newOP(OP_NULL, 0);
5813 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5814 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5816 #ifdef GV_UNIQUE_CHECK
5818 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5822 if ((cv = GvFORM(gv))) {
5823 if (ckWARN(WARN_REDEFINE)) {
5824 const line_t oldline = CopLINE(PL_curcop);
5825 if (PL_parser && PL_parser->copline != NOLINE)
5826 CopLINE_set(PL_curcop, PL_parser->copline);
5827 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5828 o ? "Format %"SVf" redefined"
5829 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5830 CopLINE_set(PL_curcop, oldline);
5837 CvFILE_set_from_cop(cv, PL_curcop);
5840 pad_tidy(padtidy_FORMAT);
5841 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5842 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5843 OpREFCNT_set(CvROOT(cv), 1);
5844 CvSTART(cv) = LINKLIST(CvROOT(cv));
5845 CvROOT(cv)->op_next = 0;
5846 CALL_PEEP(CvSTART(cv));
5848 op_getmad(o,pegop,'n');
5849 op_getmad_weak(block, pegop, 'b');
5854 PL_parser->copline = NOLINE;
5862 Perl_newANONLIST(pTHX_ OP *o)
5864 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5868 Perl_newANONHASH(pTHX_ OP *o)
5870 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5874 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5876 return newANONATTRSUB(floor, proto, NULL, block);
5880 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5882 return newUNOP(OP_REFGEN, 0,
5883 newSVOP(OP_ANONCODE, 0,
5884 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5888 Perl_oopsAV(pTHX_ OP *o)
5891 switch (o->op_type) {
5893 o->op_type = OP_PADAV;
5894 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5895 return ref(o, OP_RV2AV);
5898 o->op_type = OP_RV2AV;
5899 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5904 if (ckWARN_d(WARN_INTERNAL))
5905 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5912 Perl_oopsHV(pTHX_ OP *o)
5915 switch (o->op_type) {
5918 o->op_type = OP_PADHV;
5919 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5920 return ref(o, OP_RV2HV);
5924 o->op_type = OP_RV2HV;
5925 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5930 if (ckWARN_d(WARN_INTERNAL))
5931 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5938 Perl_newAVREF(pTHX_ OP *o)
5941 if (o->op_type == OP_PADANY) {
5942 o->op_type = OP_PADAV;
5943 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5946 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5947 && ckWARN(WARN_DEPRECATED)) {
5948 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5949 "Using an array as a reference is deprecated");
5951 return newUNOP(OP_RV2AV, 0, scalar(o));
5955 Perl_newGVREF(pTHX_ I32 type, OP *o)
5957 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5958 return newUNOP(OP_NULL, 0, o);
5959 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5963 Perl_newHVREF(pTHX_ OP *o)
5966 if (o->op_type == OP_PADANY) {
5967 o->op_type = OP_PADHV;
5968 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5971 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5972 && ckWARN(WARN_DEPRECATED)) {
5973 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5974 "Using a hash as a reference is deprecated");
5976 return newUNOP(OP_RV2HV, 0, scalar(o));
5980 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5982 return newUNOP(OP_RV2CV, flags, scalar(o));
5986 Perl_newSVREF(pTHX_ OP *o)
5989 if (o->op_type == OP_PADANY) {
5990 o->op_type = OP_PADSV;
5991 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5994 return newUNOP(OP_RV2SV, 0, scalar(o));
5997 /* Check routines. See the comments at the top of this file for details
5998 * on when these are called */
6001 Perl_ck_anoncode(pTHX_ OP *o)
6003 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6005 cSVOPo->op_sv = NULL;
6010 Perl_ck_bitop(pTHX_ OP *o)
6013 #define OP_IS_NUMCOMPARE(op) \
6014 ((op) == OP_LT || (op) == OP_I_LT || \
6015 (op) == OP_GT || (op) == OP_I_GT || \
6016 (op) == OP_LE || (op) == OP_I_LE || \
6017 (op) == OP_GE || (op) == OP_I_GE || \
6018 (op) == OP_EQ || (op) == OP_I_EQ || \
6019 (op) == OP_NE || (op) == OP_I_NE || \
6020 (op) == OP_NCMP || (op) == OP_I_NCMP)
6021 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6022 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6023 && (o->op_type == OP_BIT_OR
6024 || o->op_type == OP_BIT_AND
6025 || o->op_type == OP_BIT_XOR))
6027 const OP * const left = cBINOPo->op_first;
6028 const OP * const right = left->op_sibling;
6029 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6030 (left->op_flags & OPf_PARENS) == 0) ||
6031 (OP_IS_NUMCOMPARE(right->op_type) &&
6032 (right->op_flags & OPf_PARENS) == 0))
6033 if (ckWARN(WARN_PRECEDENCE))
6034 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6035 "Possible precedence problem on bitwise %c operator",
6036 o->op_type == OP_BIT_OR ? '|'
6037 : o->op_type == OP_BIT_AND ? '&' : '^'
6044 Perl_ck_concat(pTHX_ OP *o)
6046 const OP * const kid = cUNOPo->op_first;
6047 PERL_UNUSED_CONTEXT;
6048 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6049 !(kUNOP->op_first->op_flags & OPf_MOD))
6050 o->op_flags |= OPf_STACKED;
6055 Perl_ck_spair(pTHX_ OP *o)
6058 if (o->op_flags & OPf_KIDS) {
6061 const OPCODE type = o->op_type;
6062 o = modkids(ck_fun(o), type);
6063 kid = cUNOPo->op_first;
6064 newop = kUNOP->op_first->op_sibling;
6066 const OPCODE type = newop->op_type;
6067 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6068 type == OP_PADAV || type == OP_PADHV ||
6069 type == OP_RV2AV || type == OP_RV2HV)
6073 op_getmad(kUNOP->op_first,newop,'K');
6075 op_free(kUNOP->op_first);
6077 kUNOP->op_first = newop;
6079 o->op_ppaddr = PL_ppaddr[++o->op_type];
6084 Perl_ck_delete(pTHX_ OP *o)
6088 if (o->op_flags & OPf_KIDS) {
6089 OP * const kid = cUNOPo->op_first;
6090 switch (kid->op_type) {
6092 o->op_flags |= OPf_SPECIAL;
6095 o->op_private |= OPpSLICE;
6098 o->op_flags |= OPf_SPECIAL;
6103 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6112 Perl_ck_die(pTHX_ OP *o)
6115 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6121 Perl_ck_eof(pTHX_ OP *o)
6125 if (o->op_flags & OPf_KIDS) {
6126 if (cLISTOPo->op_first->op_type == OP_STUB) {
6128 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6130 op_getmad(o,newop,'O');
6142 Perl_ck_eval(pTHX_ OP *o)
6145 PL_hints |= HINT_BLOCK_SCOPE;
6146 if (o->op_flags & OPf_KIDS) {
6147 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6150 o->op_flags &= ~OPf_KIDS;
6153 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6159 cUNOPo->op_first = 0;
6164 NewOp(1101, enter, 1, LOGOP);
6165 enter->op_type = OP_ENTERTRY;
6166 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6167 enter->op_private = 0;
6169 /* establish postfix order */
6170 enter->op_next = (OP*)enter;
6172 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6173 o->op_type = OP_LEAVETRY;
6174 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6175 enter->op_other = o;
6176 op_getmad(oldo,o,'O');
6190 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6191 op_getmad(oldo,o,'O');
6193 o->op_targ = (PADOFFSET)PL_hints;
6194 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6195 /* Store a copy of %^H that pp_entereval can pick up.
6196 OPf_SPECIAL flags the opcode as being for this purpose,
6197 so that it in turn will return a copy at every
6199 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6200 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6201 cUNOPo->op_first->op_sibling = hhop;
6202 o->op_private |= OPpEVAL_HAS_HH;
6208 Perl_ck_exit(pTHX_ OP *o)
6211 HV * const table = GvHV(PL_hintgv);
6213 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6214 if (svp && *svp && SvTRUE(*svp))
6215 o->op_private |= OPpEXIT_VMSISH;
6217 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6223 Perl_ck_exec(pTHX_ OP *o)
6225 if (o->op_flags & OPf_STACKED) {
6228 kid = cUNOPo->op_first->op_sibling;
6229 if (kid->op_type == OP_RV2GV)
6238 Perl_ck_exists(pTHX_ OP *o)
6242 if (o->op_flags & OPf_KIDS) {
6243 OP * const kid = cUNOPo->op_first;
6244 if (kid->op_type == OP_ENTERSUB) {
6245 (void) ref(kid, o->op_type);
6246 if (kid->op_type != OP_RV2CV && !PL_error_count)
6247 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6249 o->op_private |= OPpEXISTS_SUB;
6251 else if (kid->op_type == OP_AELEM)
6252 o->op_flags |= OPf_SPECIAL;
6253 else if (kid->op_type != OP_HELEM)
6254 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6262 Perl_ck_rvconst(pTHX_ register OP *o)
6265 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6267 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6268 if (o->op_type == OP_RV2CV)
6269 o->op_private &= ~1;
6271 if (kid->op_type == OP_CONST) {
6274 SV * const kidsv = kid->op_sv;
6276 /* Is it a constant from cv_const_sv()? */
6277 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6278 SV * const rsv = SvRV(kidsv);
6279 const svtype type = SvTYPE(rsv);
6280 const char *badtype = NULL;
6282 switch (o->op_type) {
6284 if (type > SVt_PVMG)
6285 badtype = "a SCALAR";
6288 if (type != SVt_PVAV)
6289 badtype = "an ARRAY";
6292 if (type != SVt_PVHV)
6296 if (type != SVt_PVCV)
6301 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6304 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6305 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6306 /* If this is an access to a stash, disable "strict refs", because
6307 * stashes aren't auto-vivified at compile-time (unless we store
6308 * symbols in them), and we don't want to produce a run-time
6309 * stricture error when auto-vivifying the stash. */
6310 const char *s = SvPV_nolen(kidsv);
6311 const STRLEN l = SvCUR(kidsv);
6312 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6313 o->op_private &= ~HINT_STRICT_REFS;
6315 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6316 const char *badthing;
6317 switch (o->op_type) {
6319 badthing = "a SCALAR";
6322 badthing = "an ARRAY";
6325 badthing = "a HASH";
6333 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6334 SVfARG(kidsv), badthing);
6337 * This is a little tricky. We only want to add the symbol if we
6338 * didn't add it in the lexer. Otherwise we get duplicate strict
6339 * warnings. But if we didn't add it in the lexer, we must at
6340 * least pretend like we wanted to add it even if it existed before,
6341 * or we get possible typo warnings. OPpCONST_ENTERED says
6342 * whether the lexer already added THIS instance of this symbol.
6344 iscv = (o->op_type == OP_RV2CV) * 2;
6346 gv = gv_fetchsv(kidsv,
6347 iscv | !(kid->op_private & OPpCONST_ENTERED),
6350 : o->op_type == OP_RV2SV
6352 : o->op_type == OP_RV2AV
6354 : o->op_type == OP_RV2HV
6357 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6359 kid->op_type = OP_GV;
6360 SvREFCNT_dec(kid->op_sv);
6362 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6363 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6364 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6366 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6368 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6370 kid->op_private = 0;
6371 kid->op_ppaddr = PL_ppaddr[OP_GV];
6378 Perl_ck_ftst(pTHX_ OP *o)
6381 const I32 type = o->op_type;
6383 if (o->op_flags & OPf_REF) {
6386 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6387 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6388 const OPCODE kidtype = kid->op_type;
6390 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6391 OP * const newop = newGVOP(type, OPf_REF,
6392 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6394 op_getmad(o,newop,'O');
6400 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6401 o->op_private |= OPpFT_ACCESS;
6402 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6403 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6404 o->op_private |= OPpFT_STACKED;
6412 if (type == OP_FTTTY)
6413 o = newGVOP(type, OPf_REF, PL_stdingv);
6415 o = newUNOP(type, 0, newDEFSVOP());
6416 op_getmad(oldo,o,'O');
6422 Perl_ck_fun(pTHX_ OP *o)
6425 const int type = o->op_type;
6426 register I32 oa = PL_opargs[type] >> OASHIFT;
6428 if (o->op_flags & OPf_STACKED) {
6429 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6432 return no_fh_allowed(o);
6435 if (o->op_flags & OPf_KIDS) {
6436 OP **tokid = &cLISTOPo->op_first;
6437 register OP *kid = cLISTOPo->op_first;
6441 if (kid->op_type == OP_PUSHMARK ||
6442 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6444 tokid = &kid->op_sibling;
6445 kid = kid->op_sibling;
6447 if (!kid && PL_opargs[type] & OA_DEFGV)
6448 *tokid = kid = newDEFSVOP();
6452 sibl = kid->op_sibling;
6454 if (!sibl && kid->op_type == OP_STUB) {
6461 /* list seen where single (scalar) arg expected? */
6462 if (numargs == 1 && !(oa >> 4)
6463 && kid->op_type == OP_LIST && type != OP_SCALAR)
6465 return too_many_arguments(o,PL_op_desc[type]);
6478 if ((type == OP_PUSH || type == OP_UNSHIFT)
6479 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6480 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6481 "Useless use of %s with no values",
6484 if (kid->op_type == OP_CONST &&
6485 (kid->op_private & OPpCONST_BARE))
6487 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6488 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6489 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6490 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6491 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6492 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6494 op_getmad(kid,newop,'K');
6499 kid->op_sibling = sibl;
6502 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6503 bad_type(numargs, "array", PL_op_desc[type], kid);
6507 if (kid->op_type == OP_CONST &&
6508 (kid->op_private & OPpCONST_BARE))
6510 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6511 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6512 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6513 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6514 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6515 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6517 op_getmad(kid,newop,'K');
6522 kid->op_sibling = sibl;
6525 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6526 bad_type(numargs, "hash", PL_op_desc[type], kid);
6531 OP * const newop = newUNOP(OP_NULL, 0, kid);
6532 kid->op_sibling = 0;
6534 newop->op_next = newop;
6536 kid->op_sibling = sibl;
6541 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6542 if (kid->op_type == OP_CONST &&
6543 (kid->op_private & OPpCONST_BARE))
6545 OP * const newop = newGVOP(OP_GV, 0,
6546 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6547 if (!(o->op_private & 1) && /* if not unop */
6548 kid == cLISTOPo->op_last)
6549 cLISTOPo->op_last = newop;
6551 op_getmad(kid,newop,'K');
6557 else if (kid->op_type == OP_READLINE) {
6558 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6559 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6562 I32 flags = OPf_SPECIAL;
6566 /* is this op a FH constructor? */
6567 if (is_handle_constructor(o,numargs)) {
6568 const char *name = NULL;
6572 /* Set a flag to tell rv2gv to vivify
6573 * need to "prove" flag does not mean something
6574 * else already - NI-S 1999/05/07
6577 if (kid->op_type == OP_PADSV) {
6579 = PAD_COMPNAME_SV(kid->op_targ);
6580 name = SvPV_const(namesv, len);
6582 else if (kid->op_type == OP_RV2SV
6583 && kUNOP->op_first->op_type == OP_GV)
6585 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6587 len = GvNAMELEN(gv);
6589 else if (kid->op_type == OP_AELEM
6590 || kid->op_type == OP_HELEM)
6593 OP *op = ((BINOP*)kid)->op_first;
6597 const char * const a =
6598 kid->op_type == OP_AELEM ?
6600 if (((op->op_type == OP_RV2AV) ||
6601 (op->op_type == OP_RV2HV)) &&
6602 (firstop = ((UNOP*)op)->op_first) &&
6603 (firstop->op_type == OP_GV)) {
6604 /* packagevar $a[] or $h{} */
6605 GV * const gv = cGVOPx_gv(firstop);
6613 else if (op->op_type == OP_PADAV
6614 || op->op_type == OP_PADHV) {
6615 /* lexicalvar $a[] or $h{} */
6616 const char * const padname =
6617 PAD_COMPNAME_PV(op->op_targ);
6626 name = SvPV_const(tmpstr, len);
6631 name = "__ANONIO__";
6638 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6639 namesv = PAD_SVl(targ);
6640 SvUPGRADE(namesv, SVt_PV);
6642 sv_setpvn(namesv, "$", 1);
6643 sv_catpvn(namesv, name, len);
6646 kid->op_sibling = 0;
6647 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6648 kid->op_targ = targ;
6649 kid->op_private |= priv;
6651 kid->op_sibling = sibl;
6657 mod(scalar(kid), type);
6661 tokid = &kid->op_sibling;
6662 kid = kid->op_sibling;
6665 if (kid && kid->op_type != OP_STUB)
6666 return too_many_arguments(o,OP_DESC(o));
6667 o->op_private |= numargs;
6669 /* FIXME - should the numargs move as for the PERL_MAD case? */
6670 o->op_private |= numargs;
6672 return too_many_arguments(o,OP_DESC(o));
6676 else if (PL_opargs[type] & OA_DEFGV) {
6678 OP *newop = newUNOP(type, 0, newDEFSVOP());
6679 op_getmad(o,newop,'O');
6682 /* Ordering of these two is important to keep f_map.t passing. */
6684 return newUNOP(type, 0, newDEFSVOP());
6689 while (oa & OA_OPTIONAL)
6691 if (oa && oa != OA_LIST)
6692 return too_few_arguments(o,OP_DESC(o));
6698 Perl_ck_glob(pTHX_ OP *o)
6704 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6705 append_elem(OP_GLOB, o, newDEFSVOP());
6707 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6708 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6710 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6713 #if !defined(PERL_EXTERNAL_GLOB)
6714 /* XXX this can be tightened up and made more failsafe. */
6715 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6718 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6719 newSVpvs("File::Glob"), NULL, NULL, NULL);
6720 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6721 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6722 GvCV(gv) = GvCV(glob_gv);
6723 SvREFCNT_inc_void((SV*)GvCV(gv));
6724 GvIMPORTED_CV_on(gv);
6727 #endif /* PERL_EXTERNAL_GLOB */
6729 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6730 append_elem(OP_GLOB, o,
6731 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6732 o->op_type = OP_LIST;
6733 o->op_ppaddr = PL_ppaddr[OP_LIST];
6734 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6735 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6736 cLISTOPo->op_first->op_targ = 0;
6737 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6738 append_elem(OP_LIST, o,
6739 scalar(newUNOP(OP_RV2CV, 0,
6740 newGVOP(OP_GV, 0, gv)))));
6741 o = newUNOP(OP_NULL, 0, ck_subr(o));
6742 o->op_targ = OP_GLOB; /* hint at what it used to be */
6745 gv = newGVgen("main");
6747 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6753 Perl_ck_grep(pTHX_ OP *o)
6758 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6761 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6762 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6764 if (o->op_flags & OPf_STACKED) {
6767 kid = cLISTOPo->op_first->op_sibling;
6768 if (!cUNOPx(kid)->op_next)
6769 Perl_croak(aTHX_ "panic: ck_grep");
6770 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6773 NewOp(1101, gwop, 1, LOGOP);
6774 kid->op_next = (OP*)gwop;
6775 o->op_flags &= ~OPf_STACKED;
6777 kid = cLISTOPo->op_first->op_sibling;
6778 if (type == OP_MAPWHILE)
6785 kid = cLISTOPo->op_first->op_sibling;
6786 if (kid->op_type != OP_NULL)
6787 Perl_croak(aTHX_ "panic: ck_grep");
6788 kid = kUNOP->op_first;
6791 NewOp(1101, gwop, 1, LOGOP);
6792 gwop->op_type = type;
6793 gwop->op_ppaddr = PL_ppaddr[type];
6794 gwop->op_first = listkids(o);
6795 gwop->op_flags |= OPf_KIDS;
6796 gwop->op_other = LINKLIST(kid);
6797 kid->op_next = (OP*)gwop;
6798 offset = pad_findmy("$_");
6799 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6800 o->op_private = gwop->op_private = 0;
6801 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6804 o->op_private = gwop->op_private = OPpGREP_LEX;
6805 gwop->op_targ = o->op_targ = offset;
6808 kid = cLISTOPo->op_first->op_sibling;
6809 if (!kid || !kid->op_sibling)
6810 return too_few_arguments(o,OP_DESC(o));
6811 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6812 mod(kid, OP_GREPSTART);
6818 Perl_ck_index(pTHX_ OP *o)
6820 if (o->op_flags & OPf_KIDS) {
6821 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6823 kid = kid->op_sibling; /* get past "big" */
6824 if (kid && kid->op_type == OP_CONST)
6825 fbm_compile(((SVOP*)kid)->op_sv, 0);
6831 Perl_ck_lengthconst(pTHX_ OP *o)
6833 /* XXX length optimization goes here */
6838 Perl_ck_lfun(pTHX_ OP *o)
6840 const OPCODE type = o->op_type;
6841 return modkids(ck_fun(o), type);
6845 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6847 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6848 switch (cUNOPo->op_first->op_type) {
6850 /* This is needed for
6851 if (defined %stash::)
6852 to work. Do not break Tk.
6854 break; /* Globals via GV can be undef */
6856 case OP_AASSIGN: /* Is this a good idea? */
6857 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6858 "defined(@array) is deprecated");
6859 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6860 "\t(Maybe you should just omit the defined()?)\n");
6863 /* This is needed for
6864 if (defined %stash::)
6865 to work. Do not break Tk.
6867 break; /* Globals via GV can be undef */
6869 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6870 "defined(%%hash) is deprecated");
6871 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6872 "\t(Maybe you should just omit the defined()?)\n");
6883 Perl_ck_readline(pTHX_ OP *o)
6885 if (!(o->op_flags & OPf_KIDS)) {
6887 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6889 op_getmad(o,newop,'O');
6899 Perl_ck_rfun(pTHX_ OP *o)
6901 const OPCODE type = o->op_type;
6902 return refkids(ck_fun(o), type);
6906 Perl_ck_listiob(pTHX_ OP *o)
6910 kid = cLISTOPo->op_first;
6913 kid = cLISTOPo->op_first;
6915 if (kid->op_type == OP_PUSHMARK)
6916 kid = kid->op_sibling;
6917 if (kid && o->op_flags & OPf_STACKED)
6918 kid = kid->op_sibling;
6919 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6920 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6921 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6922 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6923 cLISTOPo->op_first->op_sibling = kid;
6924 cLISTOPo->op_last = kid;
6925 kid = kid->op_sibling;
6930 append_elem(o->op_type, o, newDEFSVOP());
6936 Perl_ck_smartmatch(pTHX_ OP *o)
6939 if (0 == (o->op_flags & OPf_SPECIAL)) {
6940 OP *first = cBINOPo->op_first;
6941 OP *second = first->op_sibling;
6943 /* Implicitly take a reference to an array or hash */
6944 first->op_sibling = NULL;
6945 first = cBINOPo->op_first = ref_array_or_hash(first);
6946 second = first->op_sibling = ref_array_or_hash(second);
6948 /* Implicitly take a reference to a regular expression */
6949 if (first->op_type == OP_MATCH) {
6950 first->op_type = OP_QR;
6951 first->op_ppaddr = PL_ppaddr[OP_QR];
6953 if (second->op_type == OP_MATCH) {
6954 second->op_type = OP_QR;
6955 second->op_ppaddr = PL_ppaddr[OP_QR];
6964 Perl_ck_sassign(pTHX_ OP *o)
6966 OP * const kid = cLISTOPo->op_first;
6967 /* has a disposable target? */
6968 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6969 && !(kid->op_flags & OPf_STACKED)
6970 /* Cannot steal the second time! */
6971 && !(kid->op_private & OPpTARGET_MY)
6972 /* Keep the full thing for madskills */
6976 OP * const kkid = kid->op_sibling;
6978 /* Can just relocate the target. */
6979 if (kkid && kkid->op_type == OP_PADSV
6980 && !(kkid->op_private & OPpLVAL_INTRO))
6982 kid->op_targ = kkid->op_targ;
6984 /* Now we do not need PADSV and SASSIGN. */
6985 kid->op_sibling = o->op_sibling; /* NULL */
6986 cLISTOPo->op_first = NULL;
6989 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6997 Perl_ck_match(pTHX_ OP *o)
7000 if (o->op_type != OP_QR && PL_compcv) {
7001 const PADOFFSET offset = pad_findmy("$_");
7002 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7003 o->op_targ = offset;
7004 o->op_private |= OPpTARGET_MY;
7007 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7008 o->op_private |= OPpRUNTIME;
7013 Perl_ck_method(pTHX_ OP *o)
7015 OP * const kid = cUNOPo->op_first;
7016 if (kid->op_type == OP_CONST) {
7017 SV* sv = kSVOP->op_sv;
7018 const char * const method = SvPVX_const(sv);
7019 if (!(strchr(method, ':') || strchr(method, '\''))) {
7021 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7022 sv = newSVpvn_share(method, SvCUR(sv), 0);
7025 kSVOP->op_sv = NULL;
7027 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7029 op_getmad(o,cmop,'O');
7040 Perl_ck_null(pTHX_ OP *o)
7042 PERL_UNUSED_CONTEXT;
7047 Perl_ck_open(pTHX_ OP *o)
7050 HV * const table = GvHV(PL_hintgv);
7052 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7054 const I32 mode = mode_from_discipline(*svp);
7055 if (mode & O_BINARY)
7056 o->op_private |= OPpOPEN_IN_RAW;
7057 else if (mode & O_TEXT)
7058 o->op_private |= OPpOPEN_IN_CRLF;
7061 svp = hv_fetchs(table, "open_OUT", FALSE);
7063 const I32 mode = mode_from_discipline(*svp);
7064 if (mode & O_BINARY)
7065 o->op_private |= OPpOPEN_OUT_RAW;
7066 else if (mode & O_TEXT)
7067 o->op_private |= OPpOPEN_OUT_CRLF;
7070 if (o->op_type == OP_BACKTICK) {
7071 if (!(o->op_flags & OPf_KIDS)) {
7072 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7074 op_getmad(o,newop,'O');
7083 /* In case of three-arg dup open remove strictness
7084 * from the last arg if it is a bareword. */
7085 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7086 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7090 if ((last->op_type == OP_CONST) && /* The bareword. */
7091 (last->op_private & OPpCONST_BARE) &&
7092 (last->op_private & OPpCONST_STRICT) &&
7093 (oa = first->op_sibling) && /* The fh. */
7094 (oa = oa->op_sibling) && /* The mode. */
7095 (oa->op_type == OP_CONST) &&
7096 SvPOK(((SVOP*)oa)->op_sv) &&
7097 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7098 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7099 (last == oa->op_sibling)) /* The bareword. */
7100 last->op_private &= ~OPpCONST_STRICT;
7106 Perl_ck_repeat(pTHX_ OP *o)
7108 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7109 o->op_private |= OPpREPEAT_DOLIST;
7110 cBINOPo->op_first = force_list(cBINOPo->op_first);
7118 Perl_ck_require(pTHX_ OP *o)
7123 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7124 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7126 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7127 SV * const sv = kid->op_sv;
7128 U32 was_readonly = SvREADONLY(sv);
7133 sv_force_normal_flags(sv, 0);
7134 assert(!SvREADONLY(sv));
7141 for (s = SvPVX(sv); *s; s++) {
7142 if (*s == ':' && s[1] == ':') {
7143 const STRLEN len = strlen(s+2)+1;
7145 Move(s+2, s+1, len, char);
7146 SvCUR_set(sv, SvCUR(sv) - 1);
7149 sv_catpvs(sv, ".pm");
7150 SvFLAGS(sv) |= was_readonly;
7154 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7155 /* handle override, if any */
7156 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7157 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7158 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7159 gv = gvp ? *gvp : NULL;
7163 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7164 OP * const kid = cUNOPo->op_first;
7167 cUNOPo->op_first = 0;
7171 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7172 append_elem(OP_LIST, kid,
7173 scalar(newUNOP(OP_RV2CV, 0,
7176 op_getmad(o,newop,'O');
7184 Perl_ck_return(pTHX_ OP *o)
7187 if (CvLVALUE(PL_compcv)) {
7189 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7190 mod(kid, OP_LEAVESUBLV);
7196 Perl_ck_select(pTHX_ OP *o)
7200 if (o->op_flags & OPf_KIDS) {
7201 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7202 if (kid && kid->op_sibling) {
7203 o->op_type = OP_SSELECT;
7204 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7206 return fold_constants(o);
7210 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7211 if (kid && kid->op_type == OP_RV2GV)
7212 kid->op_private &= ~HINT_STRICT_REFS;
7217 Perl_ck_shift(pTHX_ OP *o)
7220 const I32 type = o->op_type;
7222 if (!(o->op_flags & OPf_KIDS)) {
7224 /* FIXME - this can be refactored to reduce code in #ifdefs */
7226 OP * const oldo = o;
7230 argop = newUNOP(OP_RV2AV, 0,
7231 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7233 o = newUNOP(type, 0, scalar(argop));
7234 op_getmad(oldo,o,'O');
7237 return newUNOP(type, 0, scalar(argop));
7240 return scalar(modkids(ck_fun(o), type));
7244 Perl_ck_sort(pTHX_ OP *o)
7249 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7250 HV * const hinthv = GvHV(PL_hintgv);
7252 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7254 const I32 sorthints = (I32)SvIV(*svp);
7255 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7256 o->op_private |= OPpSORT_QSORT;
7257 if ((sorthints & HINT_SORT_STABLE) != 0)
7258 o->op_private |= OPpSORT_STABLE;
7263 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7265 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7266 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7268 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7270 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7272 if (kid->op_type == OP_SCOPE) {
7276 else if (kid->op_type == OP_LEAVE) {
7277 if (o->op_type == OP_SORT) {
7278 op_null(kid); /* wipe out leave */
7281 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7282 if (k->op_next == kid)
7284 /* don't descend into loops */
7285 else if (k->op_type == OP_ENTERLOOP
7286 || k->op_type == OP_ENTERITER)
7288 k = cLOOPx(k)->op_lastop;
7293 kid->op_next = 0; /* just disconnect the leave */
7294 k = kLISTOP->op_first;
7299 if (o->op_type == OP_SORT) {
7300 /* provide scalar context for comparison function/block */
7306 o->op_flags |= OPf_SPECIAL;
7308 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7311 firstkid = firstkid->op_sibling;
7314 /* provide list context for arguments */
7315 if (o->op_type == OP_SORT)
7322 S_simplify_sort(pTHX_ OP *o)
7325 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7330 if (!(o->op_flags & OPf_STACKED))
7332 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7333 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7334 kid = kUNOP->op_first; /* get past null */
7335 if (kid->op_type != OP_SCOPE)
7337 kid = kLISTOP->op_last; /* get past scope */
7338 switch(kid->op_type) {
7346 k = kid; /* remember this node*/
7347 if (kBINOP->op_first->op_type != OP_RV2SV)
7349 kid = kBINOP->op_first; /* get past cmp */
7350 if (kUNOP->op_first->op_type != OP_GV)
7352 kid = kUNOP->op_first; /* get past rv2sv */
7354 if (GvSTASH(gv) != PL_curstash)
7356 gvname = GvNAME(gv);
7357 if (*gvname == 'a' && gvname[1] == '\0')
7359 else if (*gvname == 'b' && gvname[1] == '\0')
7364 kid = k; /* back to cmp */
7365 if (kBINOP->op_last->op_type != OP_RV2SV)
7367 kid = kBINOP->op_last; /* down to 2nd arg */
7368 if (kUNOP->op_first->op_type != OP_GV)
7370 kid = kUNOP->op_first; /* get past rv2sv */
7372 if (GvSTASH(gv) != PL_curstash)
7374 gvname = GvNAME(gv);
7376 ? !(*gvname == 'a' && gvname[1] == '\0')
7377 : !(*gvname == 'b' && gvname[1] == '\0'))
7379 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7381 o->op_private |= OPpSORT_DESCEND;
7382 if (k->op_type == OP_NCMP)
7383 o->op_private |= OPpSORT_NUMERIC;
7384 if (k->op_type == OP_I_NCMP)
7385 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7386 kid = cLISTOPo->op_first->op_sibling;
7387 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7389 op_getmad(kid,o,'S'); /* then delete it */
7391 op_free(kid); /* then delete it */
7396 Perl_ck_split(pTHX_ OP *o)
7401 if (o->op_flags & OPf_STACKED)
7402 return no_fh_allowed(o);
7404 kid = cLISTOPo->op_first;
7405 if (kid->op_type != OP_NULL)
7406 Perl_croak(aTHX_ "panic: ck_split");
7407 kid = kid->op_sibling;
7408 op_free(cLISTOPo->op_first);
7409 cLISTOPo->op_first = kid;
7411 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7412 cLISTOPo->op_last = kid; /* There was only one element previously */
7415 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7416 OP * const sibl = kid->op_sibling;
7417 kid->op_sibling = 0;
7418 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7419 if (cLISTOPo->op_first == cLISTOPo->op_last)
7420 cLISTOPo->op_last = kid;
7421 cLISTOPo->op_first = kid;
7422 kid->op_sibling = sibl;
7425 kid->op_type = OP_PUSHRE;
7426 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7428 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7429 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7430 "Use of /g modifier is meaningless in split");
7433 if (!kid->op_sibling)
7434 append_elem(OP_SPLIT, o, newDEFSVOP());
7436 kid = kid->op_sibling;
7439 if (!kid->op_sibling)
7440 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7441 assert(kid->op_sibling);
7443 kid = kid->op_sibling;
7446 if (kid->op_sibling)
7447 return too_many_arguments(o,OP_DESC(o));
7453 Perl_ck_join(pTHX_ OP *o)
7455 const OP * const kid = cLISTOPo->op_first->op_sibling;
7456 if (kid && kid->op_type == OP_MATCH) {
7457 if (ckWARN(WARN_SYNTAX)) {
7458 const REGEXP *re = PM_GETRE(kPMOP);
7459 const char *pmstr = re ? re->precomp : "STRING";
7460 const STRLEN len = re ? re->prelen : 6;
7461 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7462 "/%.*s/ should probably be written as \"%.*s\"",
7463 (int)len, pmstr, (int)len, pmstr);
7470 Perl_ck_subr(pTHX_ OP *o)
7473 OP *prev = ((cUNOPo->op_first->op_sibling)
7474 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7475 OP *o2 = prev->op_sibling;
7477 const char *proto = NULL;
7478 const char *proto_end = NULL;
7483 I32 contextclass = 0;
7484 const char *e = NULL;
7487 o->op_private |= OPpENTERSUB_HASTARG;
7488 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7489 if (cvop->op_type == OP_RV2CV) {
7491 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7492 op_null(cvop); /* disable rv2cv */
7493 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7494 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7495 GV *gv = cGVOPx_gv(tmpop);
7498 tmpop->op_private |= OPpEARLY_CV;
7502 namegv = CvANON(cv) ? gv : CvGV(cv);
7503 proto = SvPV((SV*)cv, len);
7504 proto_end = proto + len;
7506 if (CvASSERTION(cv)) {
7507 U32 asserthints = 0;
7508 HV *const hinthv = GvHV(PL_hintgv);
7510 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7512 asserthints = SvUV(*svp);
7514 if (asserthints & HINT_ASSERTING) {
7515 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7516 o->op_private |= OPpENTERSUB_DB;
7520 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7521 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7522 "Impossible to activate assertion call");
7529 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7530 if (o2->op_type == OP_CONST)
7531 o2->op_private &= ~OPpCONST_STRICT;
7532 else if (o2->op_type == OP_LIST) {
7533 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7534 if (sib && sib->op_type == OP_CONST)
7535 sib->op_private &= ~OPpCONST_STRICT;
7538 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7539 if (PERLDB_SUB && PL_curstash != PL_debstash)
7540 o->op_private |= OPpENTERSUB_DB;
7541 while (o2 != cvop) {
7543 if (PL_madskills && o2->op_type == OP_STUB) {
7544 o2 = o2->op_sibling;
7547 if (PL_madskills && o2->op_type == OP_NULL)
7548 o3 = ((UNOP*)o2)->op_first;
7552 if (proto >= proto_end)
7553 return too_many_arguments(o, gv_ename(namegv));
7561 /* _ must be at the end */
7562 if (proto[1] && proto[1] != ';')
7577 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7579 arg == 1 ? "block or sub {}" : "sub {}",
7580 gv_ename(namegv), o3);
7583 /* '*' allows any scalar type, including bareword */
7586 if (o3->op_type == OP_RV2GV)
7587 goto wrapref; /* autoconvert GLOB -> GLOBref */
7588 else if (o3->op_type == OP_CONST)
7589 o3->op_private &= ~OPpCONST_STRICT;
7590 else if (o3->op_type == OP_ENTERSUB) {
7591 /* accidental subroutine, revert to bareword */
7592 OP *gvop = ((UNOP*)o3)->op_first;
7593 if (gvop && gvop->op_type == OP_NULL) {
7594 gvop = ((UNOP*)gvop)->op_first;
7596 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7599 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7600 (gvop = ((UNOP*)gvop)->op_first) &&
7601 gvop->op_type == OP_GV)
7603 GV * const gv = cGVOPx_gv(gvop);
7604 OP * const sibling = o2->op_sibling;
7605 SV * const n = newSVpvs("");
7607 OP * const oldo2 = o2;
7611 gv_fullname4(n, gv, "", FALSE);
7612 o2 = newSVOP(OP_CONST, 0, n);
7613 op_getmad(oldo2,o2,'O');
7614 prev->op_sibling = o2;
7615 o2->op_sibling = sibling;
7631 if (contextclass++ == 0) {
7632 e = strchr(proto, ']');
7633 if (!e || e == proto)
7642 const char *p = proto;
7643 const char *const end = proto;
7645 while (*--p != '[');
7646 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7648 gv_ename(namegv), o3);
7653 if (o3->op_type == OP_RV2GV)
7656 bad_type(arg, "symbol", gv_ename(namegv), o3);
7659 if (o3->op_type == OP_ENTERSUB)
7662 bad_type(arg, "subroutine entry", gv_ename(namegv),
7666 if (o3->op_type == OP_RV2SV ||
7667 o3->op_type == OP_PADSV ||
7668 o3->op_type == OP_HELEM ||
7669 o3->op_type == OP_AELEM)
7672 bad_type(arg, "scalar", gv_ename(namegv), o3);
7675 if (o3->op_type == OP_RV2AV ||
7676 o3->op_type == OP_PADAV)
7679 bad_type(arg, "array", gv_ename(namegv), o3);
7682 if (o3->op_type == OP_RV2HV ||
7683 o3->op_type == OP_PADHV)
7686 bad_type(arg, "hash", gv_ename(namegv), o3);
7691 OP* const sib = kid->op_sibling;
7692 kid->op_sibling = 0;
7693 o2 = newUNOP(OP_REFGEN, 0, kid);
7694 o2->op_sibling = sib;
7695 prev->op_sibling = o2;
7697 if (contextclass && e) {
7712 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7713 gv_ename(namegv), SVfARG(cv));
7718 mod(o2, OP_ENTERSUB);
7720 o2 = o2->op_sibling;
7722 if (o2 == cvop && proto && *proto == '_') {
7723 /* generate an access to $_ */
7725 o2->op_sibling = prev->op_sibling;
7726 prev->op_sibling = o2; /* instead of cvop */
7728 if (proto && !optional && proto_end > proto &&
7729 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7730 return too_few_arguments(o, gv_ename(namegv));
7733 OP * const oldo = o;
7737 o=newSVOP(OP_CONST, 0, newSViv(0));
7738 op_getmad(oldo,o,'O');
7744 Perl_ck_svconst(pTHX_ OP *o)
7746 PERL_UNUSED_CONTEXT;
7747 SvREADONLY_on(cSVOPo->op_sv);
7752 Perl_ck_chdir(pTHX_ OP *o)
7754 if (o->op_flags & OPf_KIDS) {
7755 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7757 if (kid && kid->op_type == OP_CONST &&
7758 (kid->op_private & OPpCONST_BARE))
7760 o->op_flags |= OPf_SPECIAL;
7761 kid->op_private &= ~OPpCONST_STRICT;
7768 Perl_ck_trunc(pTHX_ OP *o)
7770 if (o->op_flags & OPf_KIDS) {
7771 SVOP *kid = (SVOP*)cUNOPo->op_first;
7773 if (kid->op_type == OP_NULL)
7774 kid = (SVOP*)kid->op_sibling;
7775 if (kid && kid->op_type == OP_CONST &&
7776 (kid->op_private & OPpCONST_BARE))
7778 o->op_flags |= OPf_SPECIAL;
7779 kid->op_private &= ~OPpCONST_STRICT;
7786 Perl_ck_unpack(pTHX_ OP *o)
7788 OP *kid = cLISTOPo->op_first;
7789 if (kid->op_sibling) {
7790 kid = kid->op_sibling;
7791 if (!kid->op_sibling)
7792 kid->op_sibling = newDEFSVOP();
7798 Perl_ck_substr(pTHX_ OP *o)
7801 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7802 OP *kid = cLISTOPo->op_first;
7804 if (kid->op_type == OP_NULL)
7805 kid = kid->op_sibling;
7807 kid->op_flags |= OPf_MOD;
7813 /* A peephole optimizer. We visit the ops in the order they're to execute.
7814 * See the comments at the top of this file for more details about when
7815 * peep() is called */
7818 Perl_peep(pTHX_ register OP *o)
7821 register OP* oldop = NULL;
7823 if (!o || o->op_opt)
7827 SAVEVPTR(PL_curcop);
7828 for (; o; o = o->op_next) {
7831 /* By default, this op has now been optimised. A couple of cases below
7832 clear this again. */
7835 switch (o->op_type) {
7839 PL_curcop = ((COP*)o); /* for warnings */
7843 if (cSVOPo->op_private & OPpCONST_STRICT)
7844 no_bareword_allowed(o);
7846 case OP_METHOD_NAMED:
7847 /* Relocate sv to the pad for thread safety.
7848 * Despite being a "constant", the SV is written to,
7849 * for reference counts, sv_upgrade() etc. */
7851 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7852 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7853 /* If op_sv is already a PADTMP then it is being used by
7854 * some pad, so make a copy. */
7855 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7856 SvREADONLY_on(PAD_SVl(ix));
7857 SvREFCNT_dec(cSVOPo->op_sv);
7859 else if (o->op_type == OP_CONST
7860 && cSVOPo->op_sv == &PL_sv_undef) {
7861 /* PL_sv_undef is hack - it's unsafe to store it in the
7862 AV that is the pad, because av_fetch treats values of
7863 PL_sv_undef as a "free" AV entry and will merrily
7864 replace them with a new SV, causing pad_alloc to think
7865 that this pad slot is free. (When, clearly, it is not)
7867 SvOK_off(PAD_SVl(ix));
7868 SvPADTMP_on(PAD_SVl(ix));
7869 SvREADONLY_on(PAD_SVl(ix));
7872 SvREFCNT_dec(PAD_SVl(ix));
7873 SvPADTMP_on(cSVOPo->op_sv);
7874 PAD_SETSV(ix, cSVOPo->op_sv);
7875 /* XXX I don't know how this isn't readonly already. */
7876 SvREADONLY_on(PAD_SVl(ix));
7878 cSVOPo->op_sv = NULL;
7885 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7886 if (o->op_next->op_private & OPpTARGET_MY) {
7887 if (o->op_flags & OPf_STACKED) /* chained concats */
7888 break; /* ignore_optimization */
7890 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7891 o->op_targ = o->op_next->op_targ;
7892 o->op_next->op_targ = 0;
7893 o->op_private |= OPpTARGET_MY;
7896 op_null(o->op_next);
7900 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7901 break; /* Scalar stub must produce undef. List stub is noop */
7905 if (o->op_targ == OP_NEXTSTATE
7906 || o->op_targ == OP_DBSTATE
7907 || o->op_targ == OP_SETSTATE)
7909 PL_curcop = ((COP*)o);
7911 /* XXX: We avoid setting op_seq here to prevent later calls
7912 to peep() from mistakenly concluding that optimisation
7913 has already occurred. This doesn't fix the real problem,
7914 though (See 20010220.007). AMS 20010719 */
7915 /* op_seq functionality is now replaced by op_opt */
7922 if (oldop && o->op_next) {
7923 oldop->op_next = o->op_next;
7931 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7932 OP* const pop = (o->op_type == OP_PADAV) ?
7933 o->op_next : o->op_next->op_next;
7935 if (pop && pop->op_type == OP_CONST &&
7936 ((PL_op = pop->op_next)) &&
7937 pop->op_next->op_type == OP_AELEM &&
7938 !(pop->op_next->op_private &
7939 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7940 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7945 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7946 no_bareword_allowed(pop);
7947 if (o->op_type == OP_GV)
7948 op_null(o->op_next);
7949 op_null(pop->op_next);
7951 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7952 o->op_next = pop->op_next->op_next;
7953 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7954 o->op_private = (U8)i;
7955 if (o->op_type == OP_GV) {
7960 o->op_flags |= OPf_SPECIAL;
7961 o->op_type = OP_AELEMFAST;
7966 if (o->op_next->op_type == OP_RV2SV) {
7967 if (!(o->op_next->op_private & OPpDEREF)) {
7968 op_null(o->op_next);
7969 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7971 o->op_next = o->op_next->op_next;
7972 o->op_type = OP_GVSV;
7973 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7976 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7977 GV * const gv = cGVOPo_gv;
7978 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7979 /* XXX could check prototype here instead of just carping */
7980 SV * const sv = sv_newmortal();
7981 gv_efullname3(sv, gv, NULL);
7982 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7983 "%"SVf"() called too early to check prototype",
7987 else if (o->op_next->op_type == OP_READLINE
7988 && o->op_next->op_next->op_type == OP_CONCAT
7989 && (o->op_next->op_next->op_flags & OPf_STACKED))
7991 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7992 o->op_type = OP_RCATLINE;
7993 o->op_flags |= OPf_STACKED;
7994 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7995 op_null(o->op_next->op_next);
7996 op_null(o->op_next);
8011 while (cLOGOP->op_other->op_type == OP_NULL)
8012 cLOGOP->op_other = cLOGOP->op_other->op_next;
8013 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8018 while (cLOOP->op_redoop->op_type == OP_NULL)
8019 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8020 peep(cLOOP->op_redoop);
8021 while (cLOOP->op_nextop->op_type == OP_NULL)
8022 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8023 peep(cLOOP->op_nextop);
8024 while (cLOOP->op_lastop->op_type == OP_NULL)
8025 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8026 peep(cLOOP->op_lastop);
8030 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8031 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8032 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8033 cPMOP->op_pmstashstartu.op_pmreplstart
8034 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8035 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8039 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8040 && ckWARN(WARN_SYNTAX))
8042 if (o->op_next->op_sibling) {
8043 const OPCODE type = o->op_next->op_sibling->op_type;
8044 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8045 const line_t oldline = CopLINE(PL_curcop);
8046 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8047 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8048 "Statement unlikely to be reached");
8049 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8050 "\t(Maybe you meant system() when you said exec()?)\n");
8051 CopLINE_set(PL_curcop, oldline);
8062 const char *key = NULL;
8065 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8068 /* Make the CONST have a shared SV */
8069 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8070 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8071 key = SvPV_const(sv, keylen);
8072 lexname = newSVpvn_share(key,
8073 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8079 if ((o->op_private & (OPpLVAL_INTRO)))
8082 rop = (UNOP*)((BINOP*)o)->op_first;
8083 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8085 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8086 if (!SvPAD_TYPED(lexname))
8088 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8089 if (!fields || !GvHV(*fields))
8091 key = SvPV_const(*svp, keylen);
8092 if (!hv_fetch(GvHV(*fields), key,
8093 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8095 Perl_croak(aTHX_ "No such class field \"%s\" "
8096 "in variable %s of type %s",
8097 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8110 SVOP *first_key_op, *key_op;
8112 if ((o->op_private & (OPpLVAL_INTRO))
8113 /* I bet there's always a pushmark... */
8114 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8115 /* hmmm, no optimization if list contains only one key. */
8117 rop = (UNOP*)((LISTOP*)o)->op_last;
8118 if (rop->op_type != OP_RV2HV)
8120 if (rop->op_first->op_type == OP_PADSV)
8121 /* @$hash{qw(keys here)} */
8122 rop = (UNOP*)rop->op_first;
8124 /* @{$hash}{qw(keys here)} */
8125 if (rop->op_first->op_type == OP_SCOPE
8126 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8128 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8134 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8135 if (!SvPAD_TYPED(lexname))
8137 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8138 if (!fields || !GvHV(*fields))
8140 /* Again guessing that the pushmark can be jumped over.... */
8141 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8142 ->op_first->op_sibling;
8143 for (key_op = first_key_op; key_op;
8144 key_op = (SVOP*)key_op->op_sibling) {
8145 if (key_op->op_type != OP_CONST)
8147 svp = cSVOPx_svp(key_op);
8148 key = SvPV_const(*svp, keylen);
8149 if (!hv_fetch(GvHV(*fields), key,
8150 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8152 Perl_croak(aTHX_ "No such class field \"%s\" "
8153 "in variable %s of type %s",
8154 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8161 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8165 /* check that RHS of sort is a single plain array */
8166 OP *oright = cUNOPo->op_first;
8167 if (!oright || oright->op_type != OP_PUSHMARK)
8170 /* reverse sort ... can be optimised. */
8171 if (!cUNOPo->op_sibling) {
8172 /* Nothing follows us on the list. */
8173 OP * const reverse = o->op_next;
8175 if (reverse->op_type == OP_REVERSE &&
8176 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8177 OP * const pushmark = cUNOPx(reverse)->op_first;
8178 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8179 && (cUNOPx(pushmark)->op_sibling == o)) {
8180 /* reverse -> pushmark -> sort */
8181 o->op_private |= OPpSORT_REVERSE;
8183 pushmark->op_next = oright->op_next;
8189 /* make @a = sort @a act in-place */
8191 oright = cUNOPx(oright)->op_sibling;
8194 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8195 oright = cUNOPx(oright)->op_sibling;
8199 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8200 || oright->op_next != o
8201 || (oright->op_private & OPpLVAL_INTRO)
8205 /* o2 follows the chain of op_nexts through the LHS of the
8206 * assign (if any) to the aassign op itself */
8208 if (!o2 || o2->op_type != OP_NULL)
8211 if (!o2 || o2->op_type != OP_PUSHMARK)
8214 if (o2 && o2->op_type == OP_GV)
8217 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8218 || (o2->op_private & OPpLVAL_INTRO)
8223 if (!o2 || o2->op_type != OP_NULL)
8226 if (!o2 || o2->op_type != OP_AASSIGN
8227 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8230 /* check that the sort is the first arg on RHS of assign */
8232 o2 = cUNOPx(o2)->op_first;
8233 if (!o2 || o2->op_type != OP_NULL)
8235 o2 = cUNOPx(o2)->op_first;
8236 if (!o2 || o2->op_type != OP_PUSHMARK)
8238 if (o2->op_sibling != o)
8241 /* check the array is the same on both sides */
8242 if (oleft->op_type == OP_RV2AV) {
8243 if (oright->op_type != OP_RV2AV
8244 || !cUNOPx(oright)->op_first
8245 || cUNOPx(oright)->op_first->op_type != OP_GV
8246 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8247 cGVOPx_gv(cUNOPx(oright)->op_first)
8251 else if (oright->op_type != OP_PADAV
8252 || oright->op_targ != oleft->op_targ
8256 /* transfer MODishness etc from LHS arg to RHS arg */
8257 oright->op_flags = oleft->op_flags;
8258 o->op_private |= OPpSORT_INPLACE;
8260 /* excise push->gv->rv2av->null->aassign */
8261 o2 = o->op_next->op_next;
8262 op_null(o2); /* PUSHMARK */
8264 if (o2->op_type == OP_GV) {
8265 op_null(o2); /* GV */
8268 op_null(o2); /* RV2AV or PADAV */
8269 o2 = o2->op_next->op_next;
8270 op_null(o2); /* AASSIGN */
8272 o->op_next = o2->op_next;
8278 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8280 LISTOP *enter, *exlist;
8282 enter = (LISTOP *) o->op_next;
8285 if (enter->op_type == OP_NULL) {
8286 enter = (LISTOP *) enter->op_next;
8290 /* for $a (...) will have OP_GV then OP_RV2GV here.
8291 for (...) just has an OP_GV. */
8292 if (enter->op_type == OP_GV) {
8293 gvop = (OP *) enter;
8294 enter = (LISTOP *) enter->op_next;
8297 if (enter->op_type == OP_RV2GV) {
8298 enter = (LISTOP *) enter->op_next;
8304 if (enter->op_type != OP_ENTERITER)
8307 iter = enter->op_next;
8308 if (!iter || iter->op_type != OP_ITER)
8311 expushmark = enter->op_first;
8312 if (!expushmark || expushmark->op_type != OP_NULL
8313 || expushmark->op_targ != OP_PUSHMARK)
8316 exlist = (LISTOP *) expushmark->op_sibling;
8317 if (!exlist || exlist->op_type != OP_NULL
8318 || exlist->op_targ != OP_LIST)
8321 if (exlist->op_last != o) {
8322 /* Mmm. Was expecting to point back to this op. */
8325 theirmark = exlist->op_first;
8326 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8329 if (theirmark->op_sibling != o) {
8330 /* There's something between the mark and the reverse, eg
8331 for (1, reverse (...))
8336 ourmark = ((LISTOP *)o)->op_first;
8337 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8340 ourlast = ((LISTOP *)o)->op_last;
8341 if (!ourlast || ourlast->op_next != o)
8344 rv2av = ourmark->op_sibling;
8345 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8346 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8347 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8348 /* We're just reversing a single array. */
8349 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8350 enter->op_flags |= OPf_STACKED;
8353 /* We don't have control over who points to theirmark, so sacrifice
8355 theirmark->op_next = ourmark->op_next;
8356 theirmark->op_flags = ourmark->op_flags;
8357 ourlast->op_next = gvop ? gvop : (OP *) enter;
8360 enter->op_private |= OPpITER_REVERSED;
8361 iter->op_private |= OPpITER_REVERSED;
8368 UNOP *refgen, *rv2cv;
8371 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8374 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8377 rv2gv = ((BINOP *)o)->op_last;
8378 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8381 refgen = (UNOP *)((BINOP *)o)->op_first;
8383 if (!refgen || refgen->op_type != OP_REFGEN)
8386 exlist = (LISTOP *)refgen->op_first;
8387 if (!exlist || exlist->op_type != OP_NULL
8388 || exlist->op_targ != OP_LIST)
8391 if (exlist->op_first->op_type != OP_PUSHMARK)
8394 rv2cv = (UNOP*)exlist->op_last;
8396 if (rv2cv->op_type != OP_RV2CV)
8399 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8400 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8401 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8403 o->op_private |= OPpASSIGN_CV_TO_GV;
8404 rv2gv->op_private |= OPpDONT_INIT_GV;
8405 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8413 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8414 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8424 Perl_custom_op_name(pTHX_ const OP* o)
8427 const IV index = PTR2IV(o->op_ppaddr);
8431 if (!PL_custom_op_names) /* This probably shouldn't happen */
8432 return (char *)PL_op_name[OP_CUSTOM];
8434 keysv = sv_2mortal(newSViv(index));
8436 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8438 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8440 return SvPV_nolen(HeVAL(he));
8444 Perl_custom_op_desc(pTHX_ const OP* o)
8447 const IV index = PTR2IV(o->op_ppaddr);
8451 if (!PL_custom_op_descs)
8452 return (char *)PL_op_desc[OP_CUSTOM];
8454 keysv = sv_2mortal(newSViv(index));
8456 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8458 return (char *)PL_op_desc[OP_CUSTOM];
8460 return SvPV_nolen(HeVAL(he));
8465 /* Efficient sub that returns a constant scalar value. */
8467 const_sv_xsub(pTHX_ CV* cv)
8474 Perl_croak(aTHX_ "usage: %s::%s()",
8475 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8479 ST(0) = (SV*)XSANY.any_ptr;
8485 * c-indentation-style: bsd
8487 * indent-tabs-mode: t
8490 * ex: set ts=8 sts=4 sw=4 noet: