4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
106 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
107 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
108 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
110 #if defined(PL_OP_SLAB_ALLOC)
112 #ifdef PERL_DEBUG_READONLY_OPS
113 # define PERL_SLAB_SIZE 4096
114 # include <sys/mman.h>
117 #ifndef PERL_SLAB_SIZE
118 #define PERL_SLAB_SIZE 2048
122 Perl_Slab_Alloc(pTHX_ size_t sz)
126 * To make incrementing use count easy PL_OpSlab is an I32 *
127 * To make inserting the link to slab PL_OpPtr is I32 **
128 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
129 * Add an overhead for pointer to slab and round up as a number of pointers
131 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
132 if ((PL_OpSpace -= sz) < 0) {
133 #ifdef PERL_DEBUG_READONLY_OPS
134 /* We need to allocate chunk by chunk so that we can control the VM
136 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
139 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
140 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
142 if(PL_OpPtr == MAP_FAILED) {
143 perror("mmap failed");
148 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
153 /* We reserve the 0'th I32 sized chunk as a use count */
154 PL_OpSlab = (I32 *) PL_OpPtr;
155 /* Reduce size by the use count word, and by the size we need.
156 * Latter is to mimic the '-=' in the if() above
158 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
159 /* Allocation pointer starts at the top.
160 Theory: because we build leaves before trunk allocating at end
161 means that at run time access is cache friendly upward
163 PL_OpPtr += PERL_SLAB_SIZE;
165 #ifdef PERL_DEBUG_READONLY_OPS
166 /* We remember this slab. */
167 /* This implementation isn't efficient, but it is simple. */
168 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
169 PL_slabs[PL_slab_count++] = PL_OpSlab;
170 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
173 assert( PL_OpSpace >= 0 );
174 /* Move the allocation pointer down */
176 assert( PL_OpPtr > (I32 **) PL_OpSlab );
177 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
178 (*PL_OpSlab)++; /* Increment use count of slab */
179 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
180 assert( *PL_OpSlab > 0 );
181 return (void *)(PL_OpPtr + 1);
184 #ifdef PERL_DEBUG_READONLY_OPS
186 Perl_pending_Slabs_to_ro(pTHX) {
187 /* Turn all the allocated op slabs read only. */
188 U32 count = PL_slab_count;
189 I32 **const slabs = PL_slabs;
191 /* Reset the array of pending OP slabs, as we're about to turn this lot
192 read only. Also, do it ahead of the loop in case the warn triggers,
193 and a warn handler has an eval */
198 /* Force a new slab for any further allocation. */
202 void *const start = slabs[count];
203 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
204 if(mprotect(start, size, PROT_READ)) {
205 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
206 start, (unsigned long) size, errno);
214 S_Slab_to_rw(pTHX_ void *op)
216 I32 * const * const ptr = (I32 **) op;
217 I32 * const slab = ptr[-1];
219 PERL_ARGS_ASSERT_SLAB_TO_RW;
221 assert( ptr-1 > (I32 **) slab );
222 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
224 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
225 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
226 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
231 Perl_op_refcnt_inc(pTHX_ OP *o)
242 Perl_op_refcnt_dec(pTHX_ OP *o)
244 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
249 # define Slab_to_rw(op)
253 Perl_Slab_Free(pTHX_ void *op)
255 I32 * const * const ptr = (I32 **) op;
256 I32 * const slab = ptr[-1];
257 PERL_ARGS_ASSERT_SLAB_FREE;
258 assert( ptr-1 > (I32 **) slab );
259 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
262 if (--(*slab) == 0) {
264 # define PerlMemShared PerlMem
267 #ifdef PERL_DEBUG_READONLY_OPS
268 U32 count = PL_slab_count;
269 /* Need to remove this slab from our list of slabs */
272 if (PL_slabs[count] == slab) {
274 /* Found it. Move the entry at the end to overwrite it. */
275 DEBUG_m(PerlIO_printf(Perl_debug_log,
276 "Deallocate %p by moving %p from %lu to %lu\n",
278 PL_slabs[PL_slab_count - 1],
279 PL_slab_count, count));
280 PL_slabs[count] = PL_slabs[--PL_slab_count];
281 /* Could realloc smaller at this point, but probably not
283 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
284 perror("munmap failed");
292 PerlMemShared_free(slab);
294 if (slab == PL_OpSlab) {
301 * In the following definition, the ", (OP*)0" is just to make the compiler
302 * think the expression is of the right type: croak actually does a Siglongjmp.
304 #define CHECKOP(type,o) \
305 ((PL_op_mask && PL_op_mask[type]) \
306 ? ( op_free((OP*)o), \
307 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
309 : PL_check[type](aTHX_ (OP*)o))
311 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
313 #define CHANGE_TYPE(o,type) \
315 o->op_type = (OPCODE)type; \
316 o->op_ppaddr = PL_ppaddr[type]; \
320 S_gv_ename(pTHX_ GV *gv)
322 SV* const tmpsv = sv_newmortal();
324 PERL_ARGS_ASSERT_GV_ENAME;
326 gv_efullname3(tmpsv, gv, NULL);
327 return SvPV_nolen_const(tmpsv);
331 S_no_fh_allowed(pTHX_ OP *o)
333 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
335 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
341 S_too_few_arguments(pTHX_ OP *o, const char *name)
343 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
345 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
350 S_too_many_arguments(pTHX_ OP *o, const char *name)
352 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
354 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
359 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
361 PERL_ARGS_ASSERT_BAD_TYPE;
363 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
364 (int)n, name, t, OP_DESC(kid)));
368 S_no_bareword_allowed(pTHX_ const OP *o)
370 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
373 return; /* various ok barewords are hidden in extra OP_NULL */
374 qerror(Perl_mess(aTHX_
375 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
379 /* "register" allocation */
382 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
386 const bool is_our = (PL_parser->in_my == KEY_our);
388 PERL_ARGS_ASSERT_ALLOCMY;
390 if (flags & ~SVf_UTF8)
391 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
394 /* Until we're using the length for real, cross check that we're being
396 assert(strlen(name) == len);
398 /* complain about "my $<special_var>" etc etc */
402 ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) ||
403 (name[1] == '_' && (*name == '$' || len > 2))))
405 /* name[2] is true if strlen(name) > 2 */
406 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
407 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
408 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
409 PL_parser->in_my == KEY_state ? "state" : "my"));
411 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
412 PL_parser->in_my == KEY_state ? "state" : "my"));
416 /* allocate a spare slot and store the name in that slot */
418 off = pad_add_name_pvn(name, len,
419 (is_our ? padadd_OUR :
420 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
421 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
422 PL_parser->in_my_stash,
424 /* $_ is always in main::, even with our */
425 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
429 /* anon sub prototypes contains state vars should always be cloned,
430 * otherwise the state var would be shared between anon subs */
432 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
433 CvCLONE_on(PL_compcv);
438 /* free the body of an op without examining its contents.
439 * Always use this rather than FreeOp directly */
442 S_op_destroy(pTHX_ OP *o)
444 if (o->op_latefree) {
452 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
454 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
460 Perl_op_free(pTHX_ OP *o)
467 if (o->op_latefreed) {
474 if (o->op_private & OPpREFCOUNTED) {
485 refcnt = OpREFCNT_dec(o);
488 /* Need to find and remove any pattern match ops from the list
489 we maintain for reset(). */
490 find_and_forget_pmops(o);
500 /* Call the op_free hook if it has been set. Do it now so that it's called
501 * at the right time for refcounted ops, but still before all of the kids
505 if (o->op_flags & OPf_KIDS) {
506 register OP *kid, *nextkid;
507 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
508 nextkid = kid->op_sibling; /* Get before next freeing kid */
513 #ifdef PERL_DEBUG_READONLY_OPS
517 /* COP* is not cleared by op_clear() so that we may track line
518 * numbers etc even after null() */
519 if (type == OP_NEXTSTATE || type == OP_DBSTATE
520 || (type == OP_NULL /* the COP might have been null'ed */
521 && ((OPCODE)o->op_targ == OP_NEXTSTATE
522 || (OPCODE)o->op_targ == OP_DBSTATE))) {
527 type = (OPCODE)o->op_targ;
530 if (o->op_latefree) {
536 #ifdef DEBUG_LEAKING_SCALARS
543 Perl_op_clear(pTHX_ OP *o)
548 PERL_ARGS_ASSERT_OP_CLEAR;
551 mad_free(o->op_madprop);
556 switch (o->op_type) {
557 case OP_NULL: /* Was holding old type, if any. */
558 if (PL_madskills && o->op_targ != OP_NULL) {
559 o->op_type = (Optype)o->op_targ;
564 case OP_ENTEREVAL: /* Was holding hints. */
568 if (!(o->op_flags & OPf_REF)
569 || (PL_check[o->op_type] != Perl_ck_ftst))
576 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
581 /* It's possible during global destruction that the GV is freed
582 before the optree. Whilst the SvREFCNT_inc is happy to bump from
583 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
584 will trigger an assertion failure, because the entry to sv_clear
585 checks that the scalar is not already freed. A check of for
586 !SvIS_FREED(gv) turns out to be invalid, because during global
587 destruction the reference count can be forced down to zero
588 (with SVf_BREAK set). In which case raising to 1 and then
589 dropping to 0 triggers cleanup before it should happen. I
590 *think* that this might actually be a general, systematic,
591 weakness of the whole idea of SVf_BREAK, in that code *is*
592 allowed to raise and lower references during global destruction,
593 so any *valid* code that happens to do this during global
594 destruction might well trigger premature cleanup. */
595 bool still_valid = gv && SvREFCNT(gv);
598 SvREFCNT_inc_simple_void(gv);
600 if (cPADOPo->op_padix > 0) {
601 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
602 * may still exist on the pad */
603 pad_swipe(cPADOPo->op_padix, TRUE);
604 cPADOPo->op_padix = 0;
607 SvREFCNT_dec(cSVOPo->op_sv);
608 cSVOPo->op_sv = NULL;
611 int try_downgrade = SvREFCNT(gv) == 2;
614 gv_try_downgrade(gv);
618 case OP_METHOD_NAMED:
621 SvREFCNT_dec(cSVOPo->op_sv);
622 cSVOPo->op_sv = NULL;
625 Even if op_clear does a pad_free for the target of the op,
626 pad_free doesn't actually remove the sv that exists in the pad;
627 instead it lives on. This results in that it could be reused as
628 a target later on when the pad was reallocated.
631 pad_swipe(o->op_targ,1);
640 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
645 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
647 if (cPADOPo->op_padix > 0) {
648 pad_swipe(cPADOPo->op_padix, TRUE);
649 cPADOPo->op_padix = 0;
652 SvREFCNT_dec(cSVOPo->op_sv);
653 cSVOPo->op_sv = NULL;
657 PerlMemShared_free(cPVOPo->op_pv);
658 cPVOPo->op_pv = NULL;
662 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
666 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
667 /* No GvIN_PAD_off here, because other references may still
668 * exist on the pad */
669 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
672 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
678 forget_pmop(cPMOPo, 1);
679 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
680 /* we use the same protection as the "SAFE" version of the PM_ macros
681 * here since sv_clean_all might release some PMOPs
682 * after PL_regex_padav has been cleared
683 * and the clearing of PL_regex_padav needs to
684 * happen before sv_clean_all
687 if(PL_regex_pad) { /* We could be in destruction */
688 const IV offset = (cPMOPo)->op_pmoffset;
689 ReREFCNT_dec(PM_GETRE(cPMOPo));
690 PL_regex_pad[offset] = &PL_sv_undef;
691 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
695 ReREFCNT_dec(PM_GETRE(cPMOPo));
696 PM_SETRE(cPMOPo, NULL);
702 if (o->op_targ > 0) {
703 pad_free(o->op_targ);
709 S_cop_free(pTHX_ COP* cop)
711 PERL_ARGS_ASSERT_COP_FREE;
715 if (! specialWARN(cop->cop_warnings))
716 PerlMemShared_free(cop->cop_warnings);
717 cophh_free(CopHINTHASH_get(cop));
721 S_forget_pmop(pTHX_ PMOP *const o
727 HV * const pmstash = PmopSTASH(o);
729 PERL_ARGS_ASSERT_FORGET_PMOP;
731 if (pmstash && !SvIS_FREED(pmstash)) {
732 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
734 PMOP **const array = (PMOP**) mg->mg_ptr;
735 U32 count = mg->mg_len / sizeof(PMOP**);
740 /* Found it. Move the entry at the end to overwrite it. */
741 array[i] = array[--count];
742 mg->mg_len = count * sizeof(PMOP**);
743 /* Could realloc smaller at this point always, but probably
744 not worth it. Probably worth free()ing if we're the
747 Safefree(mg->mg_ptr);
764 S_find_and_forget_pmops(pTHX_ OP *o)
766 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
768 if (o->op_flags & OPf_KIDS) {
769 OP *kid = cUNOPo->op_first;
771 switch (kid->op_type) {
776 forget_pmop((PMOP*)kid, 0);
778 find_and_forget_pmops(kid);
779 kid = kid->op_sibling;
785 Perl_op_null(pTHX_ OP *o)
789 PERL_ARGS_ASSERT_OP_NULL;
791 if (o->op_type == OP_NULL)
795 o->op_targ = o->op_type;
796 o->op_type = OP_NULL;
797 o->op_ppaddr = PL_ppaddr[OP_NULL];
801 Perl_op_refcnt_lock(pTHX)
809 Perl_op_refcnt_unlock(pTHX)
816 /* Contextualizers */
819 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
821 Applies a syntactic context to an op tree representing an expression.
822 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
823 or C<G_VOID> to specify the context to apply. The modified op tree
830 Perl_op_contextualize(pTHX_ OP *o, I32 context)
832 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
834 case G_SCALAR: return scalar(o);
835 case G_ARRAY: return list(o);
836 case G_VOID: return scalarvoid(o);
838 Perl_croak(aTHX_ "panic: op_contextualize bad context");
844 =head1 Optree Manipulation Functions
846 =for apidoc Am|OP*|op_linklist|OP *o
847 This function is the implementation of the L</LINKLIST> macro. It should
848 not be called directly.
854 Perl_op_linklist(pTHX_ OP *o)
858 PERL_ARGS_ASSERT_OP_LINKLIST;
863 /* establish postfix order */
864 first = cUNOPo->op_first;
867 o->op_next = LINKLIST(first);
870 if (kid->op_sibling) {
871 kid->op_next = LINKLIST(kid->op_sibling);
872 kid = kid->op_sibling;
886 S_scalarkids(pTHX_ OP *o)
888 if (o && o->op_flags & OPf_KIDS) {
890 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
897 S_scalarboolean(pTHX_ OP *o)
901 PERL_ARGS_ASSERT_SCALARBOOLEAN;
903 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
904 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
905 if (ckWARN(WARN_SYNTAX)) {
906 const line_t oldline = CopLINE(PL_curcop);
908 if (PL_parser && PL_parser->copline != NOLINE)
909 CopLINE_set(PL_curcop, PL_parser->copline);
910 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
911 CopLINE_set(PL_curcop, oldline);
918 Perl_scalar(pTHX_ OP *o)
923 /* assumes no premature commitment */
924 if (!o || (PL_parser && PL_parser->error_count)
925 || (o->op_flags & OPf_WANT)
926 || o->op_type == OP_RETURN)
931 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
933 switch (o->op_type) {
935 scalar(cBINOPo->op_first);
940 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
950 if (o->op_flags & OPf_KIDS) {
951 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
957 kid = cLISTOPo->op_first;
959 kid = kid->op_sibling;
962 OP *sib = kid->op_sibling;
963 if (sib && kid->op_type != OP_LEAVEWHEN)
969 PL_curcop = &PL_compiling;
974 kid = cLISTOPo->op_first;
977 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
984 Perl_scalarvoid(pTHX_ OP *o)
988 const char* useless = NULL;
992 PERL_ARGS_ASSERT_SCALARVOID;
994 /* trailing mad null ops don't count as "there" for void processing */
996 o->op_type != OP_NULL &&
998 o->op_sibling->op_type == OP_NULL)
1001 for (sib = o->op_sibling;
1002 sib && sib->op_type == OP_NULL;
1003 sib = sib->op_sibling) ;
1009 if (o->op_type == OP_NEXTSTATE
1010 || o->op_type == OP_DBSTATE
1011 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1012 || o->op_targ == OP_DBSTATE)))
1013 PL_curcop = (COP*)o; /* for warning below */
1015 /* assumes no premature commitment */
1016 want = o->op_flags & OPf_WANT;
1017 if ((want && want != OPf_WANT_SCALAR)
1018 || (PL_parser && PL_parser->error_count)
1019 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1024 if ((o->op_private & OPpTARGET_MY)
1025 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1027 return scalar(o); /* As if inside SASSIGN */
1030 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1032 switch (o->op_type) {
1034 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1038 if (o->op_flags & OPf_STACKED)
1042 if (o->op_private == 4)
1067 case OP_AELEMFAST_LEX:
1086 case OP_GETSOCKNAME:
1087 case OP_GETPEERNAME:
1092 case OP_GETPRIORITY:
1116 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1117 /* Otherwise it's "Useless use of grep iterator" */
1118 useless = OP_DESC(o);
1122 kid = cLISTOPo->op_first;
1123 if (kid && kid->op_type == OP_PUSHRE
1125 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1127 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1129 useless = OP_DESC(o);
1133 kid = cUNOPo->op_first;
1134 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1135 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1138 useless = "negative pattern binding (!~)";
1142 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1143 useless = "non-destructive substitution (s///r)";
1147 useless = "non-destructive transliteration (tr///r)";
1154 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1155 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1156 useless = "a variable";
1161 if (cSVOPo->op_private & OPpCONST_STRICT)
1162 no_bareword_allowed(o);
1164 if (ckWARN(WARN_VOID)) {
1166 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1167 "a constant (%"SVf")", sv));
1168 useless = SvPV_nolen(msv);
1171 useless = "a constant (undef)";
1172 if (o->op_private & OPpCONST_ARYBASE)
1174 /* don't warn on optimised away booleans, eg
1175 * use constant Foo, 5; Foo || print; */
1176 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1178 /* the constants 0 and 1 are permitted as they are
1179 conventionally used as dummies in constructs like
1180 1 while some_condition_with_side_effects; */
1181 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1183 else if (SvPOK(sv)) {
1184 /* perl4's way of mixing documentation and code
1185 (before the invention of POD) was based on a
1186 trick to mix nroff and perl code. The trick was
1187 built upon these three nroff macros being used in
1188 void context. The pink camel has the details in
1189 the script wrapman near page 319. */
1190 const char * const maybe_macro = SvPVX_const(sv);
1191 if (strnEQ(maybe_macro, "di", 2) ||
1192 strnEQ(maybe_macro, "ds", 2) ||
1193 strnEQ(maybe_macro, "ig", 2))
1198 op_null(o); /* don't execute or even remember it */
1202 o->op_type = OP_PREINC; /* pre-increment is faster */
1203 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1207 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1208 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1212 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1213 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1217 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1218 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1223 kid = cLOGOPo->op_first;
1224 if (kid->op_type == OP_NOT
1225 && (kid->op_flags & OPf_KIDS)
1227 if (o->op_type == OP_AND) {
1229 o->op_ppaddr = PL_ppaddr[OP_OR];
1231 o->op_type = OP_AND;
1232 o->op_ppaddr = PL_ppaddr[OP_AND];
1241 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1246 if (o->op_flags & OPf_STACKED)
1253 if (!(o->op_flags & OPf_KIDS))
1264 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1274 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1279 S_listkids(pTHX_ OP *o)
1281 if (o && o->op_flags & OPf_KIDS) {
1283 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1290 Perl_list(pTHX_ OP *o)
1295 /* assumes no premature commitment */
1296 if (!o || (o->op_flags & OPf_WANT)
1297 || (PL_parser && PL_parser->error_count)
1298 || o->op_type == OP_RETURN)
1303 if ((o->op_private & OPpTARGET_MY)
1304 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1306 return o; /* As if inside SASSIGN */
1309 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1311 switch (o->op_type) {
1314 list(cBINOPo->op_first);
1319 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1327 if (!(o->op_flags & OPf_KIDS))
1329 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1330 list(cBINOPo->op_first);
1331 return gen_constant_list(o);
1338 kid = cLISTOPo->op_first;
1340 kid = kid->op_sibling;
1343 OP *sib = kid->op_sibling;
1344 if (sib && kid->op_type != OP_LEAVEWHEN)
1350 PL_curcop = &PL_compiling;
1354 kid = cLISTOPo->op_first;
1361 S_scalarseq(pTHX_ OP *o)
1365 const OPCODE type = o->op_type;
1367 if (type == OP_LINESEQ || type == OP_SCOPE ||
1368 type == OP_LEAVE || type == OP_LEAVETRY)
1371 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1372 if (kid->op_sibling) {
1376 PL_curcop = &PL_compiling;
1378 o->op_flags &= ~OPf_PARENS;
1379 if (PL_hints & HINT_BLOCK_SCOPE)
1380 o->op_flags |= OPf_PARENS;
1383 o = newOP(OP_STUB, 0);
1388 S_modkids(pTHX_ OP *o, I32 type)
1390 if (o && o->op_flags & OPf_KIDS) {
1392 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1393 op_lvalue(kid, type);
1399 =for apidoc finalize_optree
1401 This function finalizes the optree. Should be called directly after
1402 the complete optree is built. It does some additional
1403 checking which can't be done in the normal ck_xxx functions and makes
1404 the tree thread-safe.
1409 Perl_finalize_optree(pTHX_ OP* o)
1411 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1414 SAVEVPTR(PL_curcop);
1422 S_finalize_op(pTHX_ OP* o)
1424 PERL_ARGS_ASSERT_FINALIZE_OP;
1426 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1428 /* Make sure mad ops are also thread-safe */
1429 MADPROP *mp = o->op_madprop;
1431 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1432 OP *prop_op = (OP *) mp->mad_val;
1433 /* We only need "Relocate sv to the pad for thread safety.", but this
1434 easiest way to make sure it traverses everything */
1435 finalize_op(prop_op);
1442 switch (o->op_type) {
1445 PL_curcop = ((COP*)o); /* for warnings */
1448 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
1449 && ckWARN(WARN_SYNTAX))
1451 if (o->op_next->op_sibling) {
1452 const OPCODE type = o->op_next->op_sibling->op_type;
1453 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1454 const line_t oldline = CopLINE(PL_curcop);
1455 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
1456 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1457 "Statement unlikely to be reached");
1458 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1459 "\t(Maybe you meant system() when you said exec()?)\n");
1460 CopLINE_set(PL_curcop, oldline);
1467 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1468 GV * const gv = cGVOPo_gv;
1469 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1470 /* XXX could check prototype here instead of just carping */
1471 SV * const sv = sv_newmortal();
1472 gv_efullname3(sv, gv, NULL);
1473 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1474 "%"SVf"() called too early to check prototype",
1483 case OP_METHOD_NAMED:
1484 /* Relocate sv to the pad for thread safety.
1485 * Despite being a "constant", the SV is written to,
1486 * for reference counts, sv_upgrade() etc. */
1487 if (cSVOPo->op_sv) {
1488 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1489 if (o->op_type != OP_METHOD_NAMED &&
1490 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1492 /* If op_sv is already a PADTMP/MY then it is being used by
1493 * some pad, so make a copy. */
1494 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1495 SvREADONLY_on(PAD_SVl(ix));
1496 SvREFCNT_dec(cSVOPo->op_sv);
1498 else if (o->op_type != OP_METHOD_NAMED
1499 && cSVOPo->op_sv == &PL_sv_undef) {
1500 /* PL_sv_undef is hack - it's unsafe to store it in the
1501 AV that is the pad, because av_fetch treats values of
1502 PL_sv_undef as a "free" AV entry and will merrily
1503 replace them with a new SV, causing pad_alloc to think
1504 that this pad slot is free. (When, clearly, it is not)
1506 SvOK_off(PAD_SVl(ix));
1507 SvPADTMP_on(PAD_SVl(ix));
1508 SvREADONLY_on(PAD_SVl(ix));
1511 SvREFCNT_dec(PAD_SVl(ix));
1512 SvPADTMP_on(cSVOPo->op_sv);
1513 PAD_SETSV(ix, cSVOPo->op_sv);
1514 /* XXX I don't know how this isn't readonly already. */
1515 SvREADONLY_on(PAD_SVl(ix));
1517 cSVOPo->op_sv = NULL;
1528 const char *key = NULL;
1531 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1534 /* Make the CONST have a shared SV */
1535 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1536 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1537 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1538 key = SvPV_const(sv, keylen);
1539 lexname = newSVpvn_share(key,
1540 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1546 if ((o->op_private & (OPpLVAL_INTRO)))
1549 rop = (UNOP*)((BINOP*)o)->op_first;
1550 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1552 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1553 if (!SvPAD_TYPED(lexname))
1555 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1556 if (!fields || !GvHV(*fields))
1558 key = SvPV_const(*svp, keylen);
1559 if (!hv_fetch(GvHV(*fields), key,
1560 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1561 Perl_croak(aTHX_ "No such class field \"%s\" "
1562 "in variable %s of type %s",
1563 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
1575 SVOP *first_key_op, *key_op;
1577 if ((o->op_private & (OPpLVAL_INTRO))
1578 /* I bet there's always a pushmark... */
1579 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1580 /* hmmm, no optimization if list contains only one key. */
1582 rop = (UNOP*)((LISTOP*)o)->op_last;
1583 if (rop->op_type != OP_RV2HV)
1585 if (rop->op_first->op_type == OP_PADSV)
1586 /* @$hash{qw(keys here)} */
1587 rop = (UNOP*)rop->op_first;
1589 /* @{$hash}{qw(keys here)} */
1590 if (rop->op_first->op_type == OP_SCOPE
1591 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1593 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1599 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1600 if (!SvPAD_TYPED(lexname))
1602 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1603 if (!fields || !GvHV(*fields))
1605 /* Again guessing that the pushmark can be jumped over.... */
1606 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1607 ->op_first->op_sibling;
1608 for (key_op = first_key_op; key_op;
1609 key_op = (SVOP*)key_op->op_sibling) {
1610 if (key_op->op_type != OP_CONST)
1612 svp = cSVOPx_svp(key_op);
1613 key = SvPV_const(*svp, keylen);
1614 if (!hv_fetch(GvHV(*fields), key,
1615 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1616 Perl_croak(aTHX_ "No such class field \"%s\" "
1617 "in variable %s of type %s",
1618 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
1624 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1625 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1632 if (o->op_flags & OPf_KIDS) {
1634 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1640 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1642 Propagate lvalue ("modifiable") context to an op and its children.
1643 I<type> represents the context type, roughly based on the type of op that
1644 would do the modifying, although C<local()> is represented by OP_NULL,
1645 because it has no op type of its own (it is signalled by a flag on
1648 This function detects things that can't be modified, such as C<$x+1>, and
1649 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1650 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1652 It also flags things that need to behave specially in an lvalue context,
1653 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1659 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1663 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1666 if (!o || (PL_parser && PL_parser->error_count))
1669 if ((o->op_private & OPpTARGET_MY)
1670 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1675 switch (o->op_type) {
1681 if (!(o->op_private & OPpCONST_ARYBASE))
1684 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1685 CopARYBASE_set(&PL_compiling,
1686 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1690 SAVECOPARYBASE(&PL_compiling);
1691 CopARYBASE_set(&PL_compiling, 0);
1693 else if (type == OP_REFGEN)
1696 Perl_croak(aTHX_ "That use of $[ is unsupported");
1699 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1703 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1704 !(o->op_flags & OPf_STACKED)) {
1705 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1706 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1707 poses, so we need it clear. */
1708 o->op_private &= ~1;
1709 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1710 assert(cUNOPo->op_first->op_type == OP_NULL);
1711 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1714 else if (o->op_private & OPpENTERSUB_NOMOD)
1716 else { /* lvalue subroutine call */
1717 o->op_private |= OPpLVAL_INTRO
1718 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1719 PL_modcount = RETURN_UNLIMITED_NUMBER;
1720 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1721 /* Backward compatibility mode: */
1722 o->op_private |= OPpENTERSUB_INARGS;
1725 else { /* Compile-time error message: */
1726 OP *kid = cUNOPo->op_first;
1730 if (kid->op_type != OP_PUSHMARK) {
1731 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1733 "panic: unexpected lvalue entersub "
1734 "args: type/targ %ld:%"UVuf,
1735 (long)kid->op_type, (UV)kid->op_targ);
1736 kid = kLISTOP->op_first;
1738 while (kid->op_sibling)
1739 kid = kid->op_sibling;
1740 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1742 if (kid->op_type == OP_METHOD_NAMED
1743 || kid->op_type == OP_METHOD)
1747 NewOp(1101, newop, 1, UNOP);
1748 newop->op_type = OP_RV2CV;
1749 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1750 newop->op_first = NULL;
1751 newop->op_next = (OP*)newop;
1752 kid->op_sibling = (OP*)newop;
1753 newop->op_private |= OPpLVAL_INTRO;
1754 newop->op_private &= ~1;
1758 if (kid->op_type != OP_RV2CV)
1760 "panic: unexpected lvalue entersub "
1761 "entry via type/targ %ld:%"UVuf,
1762 (long)kid->op_type, (UV)kid->op_targ);
1763 kid->op_private |= OPpLVAL_INTRO;
1764 break; /* Postpone until runtime */
1768 kid = kUNOP->op_first;
1769 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1770 kid = kUNOP->op_first;
1771 if (kid->op_type == OP_NULL)
1773 "Unexpected constant lvalue entersub "
1774 "entry via type/targ %ld:%"UVuf,
1775 (long)kid->op_type, (UV)kid->op_targ);
1776 if (kid->op_type != OP_GV) {
1777 /* Restore RV2CV to check lvalueness */
1779 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1780 okid->op_next = kid->op_next;
1781 kid->op_next = okid;
1784 okid->op_next = NULL;
1785 okid->op_type = OP_RV2CV;
1787 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1788 okid->op_private |= OPpLVAL_INTRO;
1789 okid->op_private &= ~1;
1793 cv = GvCV(kGVOP_gv);
1803 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1804 /* grep, foreach, subcalls, refgen */
1805 if (type == OP_GREPSTART || type == OP_ENTERSUB
1806 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1808 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1809 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1811 : (o->op_type == OP_ENTERSUB
1812 ? "non-lvalue subroutine call"
1814 type ? PL_op_desc[type] : "local"));
1828 case OP_RIGHT_SHIFT:
1837 if (!(o->op_flags & OPf_STACKED))
1844 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1845 op_lvalue(kid, type);
1850 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1851 PL_modcount = RETURN_UNLIMITED_NUMBER;
1852 return o; /* Treat \(@foo) like ordinary list. */
1856 if (scalar_mod_type(o, type))
1858 ref(cUNOPo->op_first, o->op_type);
1862 if (type == OP_LEAVESUBLV)
1863 o->op_private |= OPpMAYBE_LVSUB;
1869 PL_modcount = RETURN_UNLIMITED_NUMBER;
1872 PL_hints |= HINT_BLOCK_SCOPE;
1873 if (type == OP_LEAVESUBLV)
1874 o->op_private |= OPpMAYBE_LVSUB;
1878 ref(cUNOPo->op_first, o->op_type);
1882 PL_hints |= HINT_BLOCK_SCOPE;
1891 case OP_AELEMFAST_LEX:
1898 PL_modcount = RETURN_UNLIMITED_NUMBER;
1899 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1900 return o; /* Treat \(@foo) like ordinary list. */
1901 if (scalar_mod_type(o, type))
1903 if (type == OP_LEAVESUBLV)
1904 o->op_private |= OPpMAYBE_LVSUB;
1908 if (!type) /* local() */
1909 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1910 PAD_COMPNAME_SV(o->op_targ));
1919 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1923 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1929 if (type == OP_LEAVESUBLV)
1930 o->op_private |= OPpMAYBE_LVSUB;
1931 pad_free(o->op_targ);
1932 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1933 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1934 if (o->op_flags & OPf_KIDS)
1935 op_lvalue(cBINOPo->op_first->op_sibling, type);
1940 ref(cBINOPo->op_first, o->op_type);
1941 if (type == OP_ENTERSUB &&
1942 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1943 o->op_private |= OPpLVAL_DEFER;
1944 if (type == OP_LEAVESUBLV)
1945 o->op_private |= OPpMAYBE_LVSUB;
1955 if (o->op_flags & OPf_KIDS)
1956 op_lvalue(cLISTOPo->op_last, type);
1961 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1963 else if (!(o->op_flags & OPf_KIDS))
1965 if (o->op_targ != OP_LIST) {
1966 op_lvalue(cBINOPo->op_first, type);
1972 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1973 op_lvalue(kid, type);
1977 if (type != OP_LEAVESUBLV)
1979 break; /* op_lvalue()ing was handled by ck_return() */
1982 /* [20011101.069] File test operators interpret OPf_REF to mean that
1983 their argument is a filehandle; thus \stat(".") should not set
1985 if (type == OP_REFGEN &&
1986 PL_check[o->op_type] == Perl_ck_ftst)
1989 if (type != OP_LEAVESUBLV)
1990 o->op_flags |= OPf_MOD;
1992 if (type == OP_AASSIGN || type == OP_SASSIGN)
1993 o->op_flags |= OPf_SPECIAL|OPf_REF;
1994 else if (!type) { /* local() */
1997 o->op_private |= OPpLVAL_INTRO;
1998 o->op_flags &= ~OPf_SPECIAL;
1999 PL_hints |= HINT_BLOCK_SCOPE;
2004 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2005 "Useless localization of %s", OP_DESC(o));
2008 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2009 && type != OP_LEAVESUBLV)
2010 o->op_flags |= OPf_REF;
2014 /* Do not use this. It will be removed after 5.14. */
2016 Perl_mod(pTHX_ OP *o, I32 type)
2018 return op_lvalue(o,type);
2023 S_scalar_mod_type(const OP *o, I32 type)
2025 assert(o || type != OP_SASSIGN);
2029 if (o->op_type == OP_RV2GV)
2053 case OP_RIGHT_SHIFT:
2074 S_is_handle_constructor(const OP *o, I32 numargs)
2076 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2078 switch (o->op_type) {
2086 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2099 S_refkids(pTHX_ OP *o, I32 type)
2101 if (o && o->op_flags & OPf_KIDS) {
2103 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2110 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2115 PERL_ARGS_ASSERT_DOREF;
2117 if (!o || (PL_parser && PL_parser->error_count))
2120 switch (o->op_type) {
2122 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2123 !(o->op_flags & OPf_STACKED)) {
2124 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2125 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2126 assert(cUNOPo->op_first->op_type == OP_NULL);
2127 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2128 o->op_flags |= OPf_SPECIAL;
2129 o->op_private &= ~1;
2131 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2132 o->op_private |= OPpENTERSUB_DEREF;
2133 o->op_flags |= OPf_MOD;
2139 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2140 doref(kid, type, set_op_ref);
2143 if (type == OP_DEFINED)
2144 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2145 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2148 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2149 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2150 : type == OP_RV2HV ? OPpDEREF_HV
2152 o->op_flags |= OPf_MOD;
2159 o->op_flags |= OPf_REF;
2162 if (type == OP_DEFINED)
2163 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2164 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2170 o->op_flags |= OPf_REF;
2175 if (!(o->op_flags & OPf_KIDS))
2177 doref(cBINOPo->op_first, type, set_op_ref);
2181 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2182 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2183 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2184 : type == OP_RV2HV ? OPpDEREF_HV
2186 o->op_flags |= OPf_MOD;
2196 if (!(o->op_flags & OPf_KIDS))
2198 doref(cLISTOPo->op_last, type, set_op_ref);
2208 S_dup_attrlist(pTHX_ OP *o)
2213 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2215 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2216 * where the first kid is OP_PUSHMARK and the remaining ones
2217 * are OP_CONST. We need to push the OP_CONST values.
2219 if (o->op_type == OP_CONST)
2220 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2222 else if (o->op_type == OP_NULL)
2226 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2228 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2229 if (o->op_type == OP_CONST)
2230 rop = op_append_elem(OP_LIST, rop,
2231 newSVOP(OP_CONST, o->op_flags,
2232 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2239 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2244 PERL_ARGS_ASSERT_APPLY_ATTRS;
2246 /* fake up C<use attributes $pkg,$rv,@attrs> */
2247 ENTER; /* need to protect against side-effects of 'use' */
2248 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2250 #define ATTRSMODULE "attributes"
2251 #define ATTRSMODULE_PM "attributes.pm"
2254 /* Don't force the C<use> if we don't need it. */
2255 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2256 if (svp && *svp != &PL_sv_undef)
2257 NOOP; /* already in %INC */
2259 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2260 newSVpvs(ATTRSMODULE), NULL);
2263 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2264 newSVpvs(ATTRSMODULE),
2266 op_prepend_elem(OP_LIST,
2267 newSVOP(OP_CONST, 0, stashsv),
2268 op_prepend_elem(OP_LIST,
2269 newSVOP(OP_CONST, 0,
2271 dup_attrlist(attrs))));
2277 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2280 OP *pack, *imop, *arg;
2283 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2288 assert(target->op_type == OP_PADSV ||
2289 target->op_type == OP_PADHV ||
2290 target->op_type == OP_PADAV);
2292 /* Ensure that attributes.pm is loaded. */
2293 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2295 /* Need package name for method call. */
2296 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2298 /* Build up the real arg-list. */
2299 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2301 arg = newOP(OP_PADSV, 0);
2302 arg->op_targ = target->op_targ;
2303 arg = op_prepend_elem(OP_LIST,
2304 newSVOP(OP_CONST, 0, stashsv),
2305 op_prepend_elem(OP_LIST,
2306 newUNOP(OP_REFGEN, 0,
2307 op_lvalue(arg, OP_REFGEN)),
2308 dup_attrlist(attrs)));
2310 /* Fake up a method call to import */
2311 meth = newSVpvs_share("import");
2312 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2313 op_append_elem(OP_LIST,
2314 op_prepend_elem(OP_LIST, pack, list(arg)),
2315 newSVOP(OP_METHOD_NAMED, 0, meth)));
2316 imop->op_private |= OPpENTERSUB_NOMOD;
2318 /* Combine the ops. */
2319 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2323 =notfor apidoc apply_attrs_string
2325 Attempts to apply a list of attributes specified by the C<attrstr> and
2326 C<len> arguments to the subroutine identified by the C<cv> argument which
2327 is expected to be associated with the package identified by the C<stashpv>
2328 argument (see L<attributes>). It gets this wrong, though, in that it
2329 does not correctly identify the boundaries of the individual attribute
2330 specifications within C<attrstr>. This is not really intended for the
2331 public API, but has to be listed here for systems such as AIX which
2332 need an explicit export list for symbols. (It's called from XS code
2333 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2334 to respect attribute syntax properly would be welcome.
2340 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2341 const char *attrstr, STRLEN len)
2345 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2348 len = strlen(attrstr);
2352 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2354 const char * const sstr = attrstr;
2355 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2356 attrs = op_append_elem(OP_LIST, attrs,
2357 newSVOP(OP_CONST, 0,
2358 newSVpvn(sstr, attrstr-sstr)));
2362 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2363 newSVpvs(ATTRSMODULE),
2364 NULL, op_prepend_elem(OP_LIST,
2365 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2366 op_prepend_elem(OP_LIST,
2367 newSVOP(OP_CONST, 0,
2368 newRV(MUTABLE_SV(cv))),
2373 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2377 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2379 PERL_ARGS_ASSERT_MY_KID;
2381 if (!o || (PL_parser && PL_parser->error_count))
2385 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2386 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2390 if (type == OP_LIST) {
2392 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2393 my_kid(kid, attrs, imopsp);
2394 } else if (type == OP_UNDEF
2400 } else if (type == OP_RV2SV || /* "our" declaration */
2402 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2403 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2404 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2406 PL_parser->in_my == KEY_our
2408 : PL_parser->in_my == KEY_state ? "state" : "my"));
2410 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2411 PL_parser->in_my = FALSE;
2412 PL_parser->in_my_stash = NULL;
2413 apply_attrs(GvSTASH(gv),
2414 (type == OP_RV2SV ? GvSV(gv) :
2415 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2416 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2419 o->op_private |= OPpOUR_INTRO;
2422 else if (type != OP_PADSV &&
2425 type != OP_PUSHMARK)
2427 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2429 PL_parser->in_my == KEY_our
2431 : PL_parser->in_my == KEY_state ? "state" : "my"));
2434 else if (attrs && type != OP_PUSHMARK) {
2437 PL_parser->in_my = FALSE;
2438 PL_parser->in_my_stash = NULL;
2440 /* check for C<my Dog $spot> when deciding package */
2441 stash = PAD_COMPNAME_TYPE(o->op_targ);
2443 stash = PL_curstash;
2444 apply_attrs_my(stash, o, attrs, imopsp);
2446 o->op_flags |= OPf_MOD;
2447 o->op_private |= OPpLVAL_INTRO;
2449 o->op_private |= OPpPAD_STATE;
2454 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2458 int maybe_scalar = 0;
2460 PERL_ARGS_ASSERT_MY_ATTRS;
2462 /* [perl #17376]: this appears to be premature, and results in code such as
2463 C< our(%x); > executing in list mode rather than void mode */
2465 if (o->op_flags & OPf_PARENS)
2475 o = my_kid(o, attrs, &rops);
2477 if (maybe_scalar && o->op_type == OP_PADSV) {
2478 o = scalar(op_append_list(OP_LIST, rops, o));
2479 o->op_private |= OPpLVAL_INTRO;
2482 /* The listop in rops might have a pushmark at the beginning,
2483 which will mess up list assignment. */
2484 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2485 if (rops->op_type == OP_LIST &&
2486 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2488 OP * const pushmark = lrops->op_first;
2489 lrops->op_first = pushmark->op_sibling;
2492 o = op_append_list(OP_LIST, o, rops);
2495 PL_parser->in_my = FALSE;
2496 PL_parser->in_my_stash = NULL;
2501 Perl_sawparens(pTHX_ OP *o)
2503 PERL_UNUSED_CONTEXT;
2505 o->op_flags |= OPf_PARENS;
2510 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2514 const OPCODE ltype = left->op_type;
2515 const OPCODE rtype = right->op_type;
2517 PERL_ARGS_ASSERT_BIND_MATCH;
2519 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2520 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2522 const char * const desc
2524 rtype == OP_SUBST || rtype == OP_TRANS
2525 || rtype == OP_TRANSR
2527 ? (int)rtype : OP_MATCH];
2528 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2529 ? "@array" : "%hash");
2530 Perl_warner(aTHX_ packWARN(WARN_MISC),
2531 "Applying %s to %s will act on scalar(%s)",
2532 desc, sample, sample);
2535 if (rtype == OP_CONST &&
2536 cSVOPx(right)->op_private & OPpCONST_BARE &&
2537 cSVOPx(right)->op_private & OPpCONST_STRICT)
2539 no_bareword_allowed(right);
2542 /* !~ doesn't make sense with /r, so error on it for now */
2543 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2545 yyerror("Using !~ with s///r doesn't make sense");
2546 if (rtype == OP_TRANSR && type == OP_NOT)
2547 yyerror("Using !~ with tr///r doesn't make sense");
2549 ismatchop = (rtype == OP_MATCH ||
2550 rtype == OP_SUBST ||
2551 rtype == OP_TRANS || rtype == OP_TRANSR)
2552 && !(right->op_flags & OPf_SPECIAL);
2553 if (ismatchop && right->op_private & OPpTARGET_MY) {
2555 right->op_private &= ~OPpTARGET_MY;
2557 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2560 right->op_flags |= OPf_STACKED;
2561 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2562 ! (rtype == OP_TRANS &&
2563 right->op_private & OPpTRANS_IDENTICAL) &&
2564 ! (rtype == OP_SUBST &&
2565 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2566 newleft = op_lvalue(left, rtype);
2569 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2570 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2572 o = op_prepend_elem(rtype, scalar(newleft), right);
2574 return newUNOP(OP_NOT, 0, scalar(o));
2578 return bind_match(type, left,
2579 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2583 Perl_invert(pTHX_ OP *o)
2587 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2591 =for apidoc Amx|OP *|op_scope|OP *o
2593 Wraps up an op tree with some additional ops so that at runtime a dynamic
2594 scope will be created. The original ops run in the new dynamic scope,
2595 and then, provided that they exit normally, the scope will be unwound.
2596 The additional ops used to create and unwind the dynamic scope will
2597 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2598 instead if the ops are simple enough to not need the full dynamic scope
2605 Perl_op_scope(pTHX_ OP *o)
2609 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2610 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2611 o->op_type = OP_LEAVE;
2612 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2614 else if (o->op_type == OP_LINESEQ) {
2616 o->op_type = OP_SCOPE;
2617 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2618 kid = ((LISTOP*)o)->op_first;
2619 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2622 /* The following deals with things like 'do {1 for 1}' */
2623 kid = kid->op_sibling;
2625 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2630 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2636 Perl_block_start(pTHX_ int full)
2639 const int retval = PL_savestack_ix;
2641 pad_block_start(full);
2643 PL_hints &= ~HINT_BLOCK_SCOPE;
2644 SAVECOMPILEWARNINGS();
2645 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2647 CALL_BLOCK_HOOKS(bhk_start, full);
2653 Perl_block_end(pTHX_ I32 floor, OP *seq)
2656 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2657 OP* retval = scalarseq(seq);
2659 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2662 CopHINTS_set(&PL_compiling, PL_hints);
2664 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2667 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2673 =head1 Compile-time scope hooks
2675 =for apidoc Aox||blockhook_register
2677 Register a set of hooks to be called when the Perl lexical scope changes
2678 at compile time. See L<perlguts/"Compile-time scope hooks">.
2684 Perl_blockhook_register(pTHX_ BHK *hk)
2686 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2688 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2695 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2696 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2697 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2700 OP * const o = newOP(OP_PADSV, 0);
2701 o->op_targ = offset;
2707 Perl_newPROG(pTHX_ OP *o)
2711 PERL_ARGS_ASSERT_NEWPROG;
2716 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2717 ((PL_in_eval & EVAL_KEEPERR)
2718 ? OPf_SPECIAL : 0), o);
2719 /* don't use LINKLIST, since PL_eval_root might indirect through
2720 * a rather expensive function call and LINKLIST evaluates its
2721 * argument more than once */
2722 PL_eval_start = op_linklist(PL_eval_root);
2723 PL_eval_root->op_private |= OPpREFCOUNTED;
2724 OpREFCNT_set(PL_eval_root, 1);
2725 PL_eval_root->op_next = 0;
2726 CALL_PEEP(PL_eval_start);
2729 if (o->op_type == OP_STUB) {
2730 PL_comppad_name = 0;
2732 S_op_destroy(aTHX_ o);
2735 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2736 PL_curcop = &PL_compiling;
2737 PL_main_start = LINKLIST(PL_main_root);
2738 PL_main_root->op_private |= OPpREFCOUNTED;
2739 OpREFCNT_set(PL_main_root, 1);
2740 PL_main_root->op_next = 0;
2741 CALL_PEEP(PL_main_start);
2742 finalize_optree(PL_main_root);
2745 /* Register with debugger */
2747 CV * const cv = get_cvs("DB::postponed", 0);
2751 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2753 call_sv(MUTABLE_SV(cv), G_DISCARD);
2760 Perl_localize(pTHX_ OP *o, I32 lex)
2764 PERL_ARGS_ASSERT_LOCALIZE;
2766 if (o->op_flags & OPf_PARENS)
2767 /* [perl #17376]: this appears to be premature, and results in code such as
2768 C< our(%x); > executing in list mode rather than void mode */
2775 if ( PL_parser->bufptr > PL_parser->oldbufptr
2776 && PL_parser->bufptr[-1] == ','
2777 && ckWARN(WARN_PARENTHESIS))
2779 char *s = PL_parser->bufptr;
2782 /* some heuristics to detect a potential error */
2783 while (*s && (strchr(", \t\n", *s)))
2787 if (*s && strchr("@$%*", *s) && *++s
2788 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2791 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2793 while (*s && (strchr(", \t\n", *s)))
2799 if (sigil && (*s == ';' || *s == '=')) {
2800 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2801 "Parentheses missing around \"%s\" list",
2803 ? (PL_parser->in_my == KEY_our
2805 : PL_parser->in_my == KEY_state
2815 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2816 PL_parser->in_my = FALSE;
2817 PL_parser->in_my_stash = NULL;
2822 Perl_jmaybe(pTHX_ OP *o)
2824 PERL_ARGS_ASSERT_JMAYBE;
2826 if (o->op_type == OP_LIST) {
2828 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2829 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2835 S_fold_constants(pTHX_ register OP *o)
2838 register OP * VOL curop;
2840 VOL I32 type = o->op_type;
2845 SV * const oldwarnhook = PL_warnhook;
2846 SV * const olddiehook = PL_diehook;
2850 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2852 if (PL_opargs[type] & OA_RETSCALAR)
2854 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2855 o->op_targ = pad_alloc(type, SVs_PADTMP);
2857 /* integerize op, unless it happens to be C<-foo>.
2858 * XXX should pp_i_negate() do magic string negation instead? */
2859 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2860 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2861 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2863 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2866 if (!(PL_opargs[type] & OA_FOLDCONST))
2871 /* XXX might want a ck_negate() for this */
2872 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2884 /* XXX what about the numeric ops? */
2885 if (PL_hints & HINT_LOCALE)
2890 if (PL_parser && PL_parser->error_count)
2891 goto nope; /* Don't try to run w/ errors */
2893 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2894 const OPCODE type = curop->op_type;
2895 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2897 type != OP_SCALAR &&
2899 type != OP_PUSHMARK)
2905 curop = LINKLIST(o);
2906 old_next = o->op_next;
2910 oldscope = PL_scopestack_ix;
2911 create_eval_scope(G_FAKINGEVAL);
2913 /* Verify that we don't need to save it: */
2914 assert(PL_curcop == &PL_compiling);
2915 StructCopy(&PL_compiling, ¬_compiling, COP);
2916 PL_curcop = ¬_compiling;
2917 /* The above ensures that we run with all the correct hints of the
2918 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2919 assert(IN_PERL_RUNTIME);
2920 PL_warnhook = PERL_WARNHOOK_FATAL;
2927 sv = *(PL_stack_sp--);
2928 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2930 /* Can't simply swipe the SV from the pad, because that relies on
2931 the op being freed "real soon now". Under MAD, this doesn't
2932 happen (see the #ifdef below). */
2935 pad_swipe(o->op_targ, FALSE);
2938 else if (SvTEMP(sv)) { /* grab mortal temp? */
2939 SvREFCNT_inc_simple_void(sv);
2944 /* Something tried to die. Abandon constant folding. */
2945 /* Pretend the error never happened. */
2947 o->op_next = old_next;
2951 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2952 PL_warnhook = oldwarnhook;
2953 PL_diehook = olddiehook;
2954 /* XXX note that this croak may fail as we've already blown away
2955 * the stack - eg any nested evals */
2956 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2959 PL_warnhook = oldwarnhook;
2960 PL_diehook = olddiehook;
2961 PL_curcop = &PL_compiling;
2963 if (PL_scopestack_ix > oldscope)
2964 delete_eval_scope();
2973 if (type == OP_RV2GV)
2974 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2976 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2977 op_getmad(o,newop,'f');
2985 S_gen_constant_list(pTHX_ register OP *o)
2989 const I32 oldtmps_floor = PL_tmps_floor;
2992 if (PL_parser && PL_parser->error_count)
2993 return o; /* Don't attempt to run with errors */
2995 PL_op = curop = LINKLIST(o);
2998 Perl_pp_pushmark(aTHX);
3001 assert (!(curop->op_flags & OPf_SPECIAL));
3002 assert(curop->op_type == OP_RANGE);
3003 Perl_pp_anonlist(aTHX);
3004 PL_tmps_floor = oldtmps_floor;
3006 o->op_type = OP_RV2AV;
3007 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3008 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3009 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3010 o->op_opt = 0; /* needs to be revisited in rpeep() */
3011 curop = ((UNOP*)o)->op_first;
3012 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3014 op_getmad(curop,o,'O');
3023 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3026 if (!o || o->op_type != OP_LIST)
3027 o = newLISTOP(OP_LIST, 0, o, NULL);
3029 o->op_flags &= ~OPf_WANT;
3031 if (!(PL_opargs[type] & OA_MARK))
3032 op_null(cLISTOPo->op_first);
3034 o->op_type = (OPCODE)type;
3035 o->op_ppaddr = PL_ppaddr[type];
3036 o->op_flags |= flags;
3038 o = CHECKOP(type, o);
3039 if (o->op_type != (unsigned)type)
3042 return fold_constants(o);
3046 =head1 Optree Manipulation Functions
3049 /* List constructors */
3052 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3054 Append an item to the list of ops contained directly within a list-type
3055 op, returning the lengthened list. I<first> is the list-type op,
3056 and I<last> is the op to append to the list. I<optype> specifies the
3057 intended opcode for the list. If I<first> is not already a list of the
3058 right type, it will be upgraded into one. If either I<first> or I<last>
3059 is null, the other is returned unchanged.
3065 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3073 if (first->op_type != (unsigned)type
3074 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3076 return newLISTOP(type, 0, first, last);
3079 if (first->op_flags & OPf_KIDS)
3080 ((LISTOP*)first)->op_last->op_sibling = last;
3082 first->op_flags |= OPf_KIDS;
3083 ((LISTOP*)first)->op_first = last;
3085 ((LISTOP*)first)->op_last = last;
3090 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3092 Concatenate the lists of ops contained directly within two list-type ops,
3093 returning the combined list. I<first> and I<last> are the list-type ops
3094 to concatenate. I<optype> specifies the intended opcode for the list.
3095 If either I<first> or I<last> is not already a list of the right type,
3096 it will be upgraded into one. If either I<first> or I<last> is null,
3097 the other is returned unchanged.
3103 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3111 if (first->op_type != (unsigned)type)
3112 return op_prepend_elem(type, first, last);
3114 if (last->op_type != (unsigned)type)
3115 return op_append_elem(type, first, last);
3117 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3118 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3119 first->op_flags |= (last->op_flags & OPf_KIDS);
3122 if (((LISTOP*)last)->op_first && first->op_madprop) {
3123 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3125 while (mp->mad_next)
3127 mp->mad_next = first->op_madprop;
3130 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3133 first->op_madprop = last->op_madprop;
3134 last->op_madprop = 0;
3137 S_op_destroy(aTHX_ last);
3143 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3145 Prepend an item to the list of ops contained directly within a list-type
3146 op, returning the lengthened list. I<first> is the op to prepend to the
3147 list, and I<last> is the list-type op. I<optype> specifies the intended
3148 opcode for the list. If I<last> is not already a list of the right type,
3149 it will be upgraded into one. If either I<first> or I<last> is null,
3150 the other is returned unchanged.
3156 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3164 if (last->op_type == (unsigned)type) {
3165 if (type == OP_LIST) { /* already a PUSHMARK there */
3166 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3167 ((LISTOP*)last)->op_first->op_sibling = first;
3168 if (!(first->op_flags & OPf_PARENS))
3169 last->op_flags &= ~OPf_PARENS;
3172 if (!(last->op_flags & OPf_KIDS)) {
3173 ((LISTOP*)last)->op_last = first;
3174 last->op_flags |= OPf_KIDS;
3176 first->op_sibling = ((LISTOP*)last)->op_first;
3177 ((LISTOP*)last)->op_first = first;
3179 last->op_flags |= OPf_KIDS;
3183 return newLISTOP(type, 0, first, last);
3191 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3194 Newxz(tk, 1, TOKEN);
3195 tk->tk_type = (OPCODE)optype;
3196 tk->tk_type = 12345;
3198 tk->tk_mad = madprop;
3203 Perl_token_free(pTHX_ TOKEN* tk)
3205 PERL_ARGS_ASSERT_TOKEN_FREE;
3207 if (tk->tk_type != 12345)
3209 mad_free(tk->tk_mad);
3214 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3219 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3221 if (tk->tk_type != 12345) {
3222 Perl_warner(aTHX_ packWARN(WARN_MISC),
3223 "Invalid TOKEN object ignored");
3230 /* faked up qw list? */
3232 tm->mad_type == MAD_SV &&
3233 SvPVX((SV *)tm->mad_val)[0] == 'q')
3240 /* pretend constant fold didn't happen? */
3241 if (mp->mad_key == 'f' &&
3242 (o->op_type == OP_CONST ||
3243 o->op_type == OP_GV) )
3245 token_getmad(tk,(OP*)mp->mad_val,slot);
3259 if (mp->mad_key == 'X')
3260 mp->mad_key = slot; /* just change the first one */
3270 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3279 /* pretend constant fold didn't happen? */
3280 if (mp->mad_key == 'f' &&
3281 (o->op_type == OP_CONST ||
3282 o->op_type == OP_GV) )
3284 op_getmad(from,(OP*)mp->mad_val,slot);
3291 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3294 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3300 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3309 /* pretend constant fold didn't happen? */
3310 if (mp->mad_key == 'f' &&
3311 (o->op_type == OP_CONST ||
3312 o->op_type == OP_GV) )
3314 op_getmad(from,(OP*)mp->mad_val,slot);
3321 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3324 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3328 PerlIO_printf(PerlIO_stderr(),
3329 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3335 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3353 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3357 addmad(tm, &(o->op_madprop), slot);
3361 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3382 Perl_newMADsv(pTHX_ char key, SV* sv)
3384 PERL_ARGS_ASSERT_NEWMADSV;
3386 return newMADPROP(key, MAD_SV, sv, 0);
3390 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3392 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3395 mp->mad_vlen = vlen;
3396 mp->mad_type = type;
3398 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3403 Perl_mad_free(pTHX_ MADPROP* mp)
3405 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3409 mad_free(mp->mad_next);
3410 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3411 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3412 switch (mp->mad_type) {
3416 Safefree((char*)mp->mad_val);
3419 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3420 op_free((OP*)mp->mad_val);
3423 sv_free(MUTABLE_SV(mp->mad_val));
3426 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3429 PerlMemShared_free(mp);
3435 =head1 Optree construction
3437 =for apidoc Am|OP *|newNULLLIST
3439 Constructs, checks, and returns a new C<stub> op, which represents an
3440 empty list expression.
3446 Perl_newNULLLIST(pTHX)
3448 return newOP(OP_STUB, 0);
3452 S_force_list(pTHX_ OP *o)
3454 if (!o || o->op_type != OP_LIST)
3455 o = newLISTOP(OP_LIST, 0, o, NULL);
3461 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3463 Constructs, checks, and returns an op of any list type. I<type> is
3464 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3465 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3466 supply up to two ops to be direct children of the list op; they are
3467 consumed by this function and become part of the constructed op tree.
3473 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3478 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3480 NewOp(1101, listop, 1, LISTOP);
3482 listop->op_type = (OPCODE)type;
3483 listop->op_ppaddr = PL_ppaddr[type];
3486 listop->op_flags = (U8)flags;
3490 else if (!first && last)
3493 first->op_sibling = last;
3494 listop->op_first = first;
3495 listop->op_last = last;
3496 if (type == OP_LIST) {
3497 OP* const pushop = newOP(OP_PUSHMARK, 0);
3498 pushop->op_sibling = first;
3499 listop->op_first = pushop;
3500 listop->op_flags |= OPf_KIDS;
3502 listop->op_last = pushop;
3505 return CHECKOP(type, listop);
3509 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3511 Constructs, checks, and returns an op of any base type (any type that
3512 has no extra fields). I<type> is the opcode. I<flags> gives the
3513 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3520 Perl_newOP(pTHX_ I32 type, I32 flags)
3525 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3526 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3527 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3528 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3530 NewOp(1101, o, 1, OP);
3531 o->op_type = (OPCODE)type;
3532 o->op_ppaddr = PL_ppaddr[type];
3533 o->op_flags = (U8)flags;
3535 o->op_latefreed = 0;
3539 o->op_private = (U8)(0 | (flags >> 8));
3540 if (PL_opargs[type] & OA_RETSCALAR)
3542 if (PL_opargs[type] & OA_TARGET)
3543 o->op_targ = pad_alloc(type, SVs_PADTMP);
3544 return CHECKOP(type, o);
3548 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3550 Constructs, checks, and returns an op of any unary type. I<type> is
3551 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3552 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3553 bits, the eight bits of C<op_private>, except that the bit with value 1
3554 is automatically set. I<first> supplies an optional op to be the direct
3555 child of the unary op; it is consumed by this function and become part
3556 of the constructed op tree.
3562 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3567 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3568 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3569 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3570 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3571 || type == OP_SASSIGN
3572 || type == OP_ENTERTRY
3573 || type == OP_NULL );
3576 first = newOP(OP_STUB, 0);
3577 if (PL_opargs[type] & OA_MARK)
3578 first = force_list(first);
3580 NewOp(1101, unop, 1, UNOP);
3581 unop->op_type = (OPCODE)type;
3582 unop->op_ppaddr = PL_ppaddr[type];
3583 unop->op_first = first;
3584 unop->op_flags = (U8)(flags | OPf_KIDS);
3585 unop->op_private = (U8)(1 | (flags >> 8));
3586 unop = (UNOP*) CHECKOP(type, unop);
3590 return fold_constants((OP *) unop);
3594 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3596 Constructs, checks, and returns an op of any binary type. I<type>
3597 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3598 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3599 the eight bits of C<op_private>, except that the bit with value 1 or
3600 2 is automatically set as required. I<first> and I<last> supply up to
3601 two ops to be the direct children of the binary op; they are consumed
3602 by this function and become part of the constructed op tree.
3608 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3613 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3614 || type == OP_SASSIGN || type == OP_NULL );
3616 NewOp(1101, binop, 1, BINOP);
3619 first = newOP(OP_NULL, 0);
3621 binop->op_type = (OPCODE)type;
3622 binop->op_ppaddr = PL_ppaddr[type];
3623 binop->op_first = first;
3624 binop->op_flags = (U8)(flags | OPf_KIDS);
3627 binop->op_private = (U8)(1 | (flags >> 8));
3630 binop->op_private = (U8)(2 | (flags >> 8));
3631 first->op_sibling = last;
3634 binop = (BINOP*)CHECKOP(type, binop);
3635 if (binop->op_next || binop->op_type != (OPCODE)type)
3638 binop->op_last = binop->op_first->op_sibling;
3640 return fold_constants((OP *)binop);
3643 static int uvcompare(const void *a, const void *b)
3644 __attribute__nonnull__(1)
3645 __attribute__nonnull__(2)
3646 __attribute__pure__;
3647 static int uvcompare(const void *a, const void *b)
3649 if (*((const UV *)a) < (*(const UV *)b))
3651 if (*((const UV *)a) > (*(const UV *)b))
3653 if (*((const UV *)a+1) < (*(const UV *)b+1))
3655 if (*((const UV *)a+1) > (*(const UV *)b+1))
3661 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3664 SV * const tstr = ((SVOP*)expr)->op_sv;
3667 (repl->op_type == OP_NULL)
3668 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3670 ((SVOP*)repl)->op_sv;
3673 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3674 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3678 register short *tbl;
3680 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3681 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3682 I32 del = o->op_private & OPpTRANS_DELETE;
3685 PERL_ARGS_ASSERT_PMTRANS;
3687 PL_hints |= HINT_BLOCK_SCOPE;
3690 o->op_private |= OPpTRANS_FROM_UTF;
3693 o->op_private |= OPpTRANS_TO_UTF;
3695 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3696 SV* const listsv = newSVpvs("# comment\n");
3698 const U8* tend = t + tlen;
3699 const U8* rend = r + rlen;
3713 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3714 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3717 const U32 flags = UTF8_ALLOW_DEFAULT;
3721 t = tsave = bytes_to_utf8(t, &len);
3724 if (!to_utf && rlen) {
3726 r = rsave = bytes_to_utf8(r, &len);
3730 /* There are several snags with this code on EBCDIC:
3731 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3732 2. scan_const() in toke.c has encoded chars in native encoding which makes
3733 ranges at least in EBCDIC 0..255 range the bottom odd.
3737 U8 tmpbuf[UTF8_MAXBYTES+1];
3740 Newx(cp, 2*tlen, UV);
3742 transv = newSVpvs("");
3744 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3746 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3748 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3752 cp[2*i+1] = cp[2*i];
3756 qsort(cp, i, 2*sizeof(UV), uvcompare);
3757 for (j = 0; j < i; j++) {
3759 diff = val - nextmin;
3761 t = uvuni_to_utf8(tmpbuf,nextmin);
3762 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3764 U8 range_mark = UTF_TO_NATIVE(0xff);
3765 t = uvuni_to_utf8(tmpbuf, val - 1);
3766 sv_catpvn(transv, (char *)&range_mark, 1);
3767 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3774 t = uvuni_to_utf8(tmpbuf,nextmin);
3775 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3777 U8 range_mark = UTF_TO_NATIVE(0xff);
3778 sv_catpvn(transv, (char *)&range_mark, 1);
3780 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3781 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3782 t = (const U8*)SvPVX_const(transv);
3783 tlen = SvCUR(transv);
3787 else if (!rlen && !del) {
3788 r = t; rlen = tlen; rend = tend;
3791 if ((!rlen && !del) || t == r ||
3792 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3794 o->op_private |= OPpTRANS_IDENTICAL;
3798 while (t < tend || tfirst <= tlast) {
3799 /* see if we need more "t" chars */
3800 if (tfirst > tlast) {
3801 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3803 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3805 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3812 /* now see if we need more "r" chars */
3813 if (rfirst > rlast) {
3815 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3817 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3819 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3828 rfirst = rlast = 0xffffffff;
3832 /* now see which range will peter our first, if either. */
3833 tdiff = tlast - tfirst;
3834 rdiff = rlast - rfirst;
3841 if (rfirst == 0xffffffff) {
3842 diff = tdiff; /* oops, pretend rdiff is infinite */
3844 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3845 (long)tfirst, (long)tlast);
3847 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3851 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3852 (long)tfirst, (long)(tfirst + diff),
3855 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3856 (long)tfirst, (long)rfirst);
3858 if (rfirst + diff > max)
3859 max = rfirst + diff;
3861 grows = (tfirst < rfirst &&
3862 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3874 else if (max > 0xff)
3879 PerlMemShared_free(cPVOPo->op_pv);
3880 cPVOPo->op_pv = NULL;
3882 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3884 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3885 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3886 PAD_SETSV(cPADOPo->op_padix, swash);
3888 SvREADONLY_on(swash);
3890 cSVOPo->op_sv = swash;
3892 SvREFCNT_dec(listsv);
3893 SvREFCNT_dec(transv);
3895 if (!del && havefinal && rlen)
3896 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3897 newSVuv((UV)final), 0);
3900 o->op_private |= OPpTRANS_GROWS;
3906 op_getmad(expr,o,'e');
3907 op_getmad(repl,o,'r');
3915 tbl = (short*)cPVOPo->op_pv;
3917 Zero(tbl, 256, short);
3918 for (i = 0; i < (I32)tlen; i++)
3920 for (i = 0, j = 0; i < 256; i++) {
3922 if (j >= (I32)rlen) {
3931 if (i < 128 && r[j] >= 128)
3941 o->op_private |= OPpTRANS_IDENTICAL;
3943 else if (j >= (I32)rlen)
3948 PerlMemShared_realloc(tbl,
3949 (0x101+rlen-j) * sizeof(short));
3950 cPVOPo->op_pv = (char*)tbl;
3952 tbl[0x100] = (short)(rlen - j);
3953 for (i=0; i < (I32)rlen - j; i++)
3954 tbl[0x101+i] = r[j+i];
3958 if (!rlen && !del) {
3961 o->op_private |= OPpTRANS_IDENTICAL;
3963 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3964 o->op_private |= OPpTRANS_IDENTICAL;
3966 for (i = 0; i < 256; i++)
3968 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3969 if (j >= (I32)rlen) {
3971 if (tbl[t[i]] == -1)
3977 if (tbl[t[i]] == -1) {
3978 if (t[i] < 128 && r[j] >= 128)
3985 if(del && rlen == tlen) {
3986 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3987 } else if(rlen > tlen) {
3988 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3992 o->op_private |= OPpTRANS_GROWS;
3994 op_getmad(expr,o,'e');
3995 op_getmad(repl,o,'r');
4005 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4007 Constructs, checks, and returns an op of any pattern matching type.
4008 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4009 and, shifted up eight bits, the eight bits of C<op_private>.
4015 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4020 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4022 NewOp(1101, pmop, 1, PMOP);
4023 pmop->op_type = (OPCODE)type;
4024 pmop->op_ppaddr = PL_ppaddr[type];
4025 pmop->op_flags = (U8)flags;
4026 pmop->op_private = (U8)(0 | (flags >> 8));
4028 if (PL_hints & HINT_RE_TAINT)
4029 pmop->op_pmflags |= PMf_RETAINT;
4030 if (PL_hints & HINT_LOCALE) {
4031 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4033 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
4034 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4036 if (PL_hints & HINT_RE_FLAGS) {
4037 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4038 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4040 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4041 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4042 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4044 if (reflags && SvOK(reflags)) {
4045 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4051 assert(SvPOK(PL_regex_pad[0]));
4052 if (SvCUR(PL_regex_pad[0])) {
4053 /* Pop off the "packed" IV from the end. */
4054 SV *const repointer_list = PL_regex_pad[0];
4055 const char *p = SvEND(repointer_list) - sizeof(IV);
4056 const IV offset = *((IV*)p);
4058 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4060 SvEND_set(repointer_list, p);
4062 pmop->op_pmoffset = offset;
4063 /* This slot should be free, so assert this: */
4064 assert(PL_regex_pad[offset] == &PL_sv_undef);
4066 SV * const repointer = &PL_sv_undef;
4067 av_push(PL_regex_padav, repointer);
4068 pmop->op_pmoffset = av_len(PL_regex_padav);
4069 PL_regex_pad = AvARRAY(PL_regex_padav);
4073 return CHECKOP(type, pmop);
4076 /* Given some sort of match op o, and an expression expr containing a
4077 * pattern, either compile expr into a regex and attach it to o (if it's
4078 * constant), or convert expr into a runtime regcomp op sequence (if it's
4081 * isreg indicates that the pattern is part of a regex construct, eg
4082 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4083 * split "pattern", which aren't. In the former case, expr will be a list
4084 * if the pattern contains more than one term (eg /a$b/) or if it contains
4085 * a replacement, ie s/// or tr///.
4089 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4094 I32 repl_has_vars = 0;
4098 PERL_ARGS_ASSERT_PMRUNTIME;
4101 o->op_type == OP_SUBST
4102 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4104 /* last element in list is the replacement; pop it */
4106 repl = cLISTOPx(expr)->op_last;
4107 kid = cLISTOPx(expr)->op_first;
4108 while (kid->op_sibling != repl)
4109 kid = kid->op_sibling;
4110 kid->op_sibling = NULL;
4111 cLISTOPx(expr)->op_last = kid;
4114 if (isreg && expr->op_type == OP_LIST &&
4115 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4117 /* convert single element list to element */
4118 OP* const oe = expr;
4119 expr = cLISTOPx(oe)->op_first->op_sibling;
4120 cLISTOPx(oe)->op_first->op_sibling = NULL;
4121 cLISTOPx(oe)->op_last = NULL;
4125 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4126 return pmtrans(o, expr, repl);
4129 reglist = isreg && expr->op_type == OP_LIST;
4133 PL_hints |= HINT_BLOCK_SCOPE;
4136 if (expr->op_type == OP_CONST) {
4137 SV *pat = ((SVOP*)expr)->op_sv;
4138 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4140 if (o->op_flags & OPf_SPECIAL)
4141 pm_flags |= RXf_SPLIT;
4144 assert (SvUTF8(pat));
4145 } else if (SvUTF8(pat)) {
4146 /* Not doing UTF-8, despite what the SV says. Is this only if we're
4147 trapped in use 'bytes'? */
4148 /* Make a copy of the octet sequence, but without the flag on, as
4149 the compiler now honours the SvUTF8 flag on pat. */
4151 const char *const p = SvPV(pat, len);
4152 pat = newSVpvn_flags(p, len, SVs_TEMP);
4155 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4158 op_getmad(expr,(OP*)pm,'e');
4164 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4165 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4167 : OP_REGCMAYBE),0,expr);
4169 NewOp(1101, rcop, 1, LOGOP);
4170 rcop->op_type = OP_REGCOMP;
4171 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4172 rcop->op_first = scalar(expr);
4173 rcop->op_flags |= OPf_KIDS
4174 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4175 | (reglist ? OPf_STACKED : 0);
4176 rcop->op_private = 1;
4179 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4181 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4182 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4184 /* establish postfix order */
4185 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4187 rcop->op_next = expr;
4188 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4191 rcop->op_next = LINKLIST(expr);
4192 expr->op_next = (OP*)rcop;
4195 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4200 if (pm->op_pmflags & PMf_EVAL) {
4202 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4203 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4205 else if (repl->op_type == OP_CONST)
4209 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4210 if (curop->op_type == OP_SCOPE
4211 || curop->op_type == OP_LEAVE
4212 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4213 if (curop->op_type == OP_GV) {
4214 GV * const gv = cGVOPx_gv(curop);
4216 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4219 else if (curop->op_type == OP_RV2CV)
4221 else if (curop->op_type == OP_RV2SV ||
4222 curop->op_type == OP_RV2AV ||
4223 curop->op_type == OP_RV2HV ||
4224 curop->op_type == OP_RV2GV) {
4225 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4228 else if (curop->op_type == OP_PADSV ||
4229 curop->op_type == OP_PADAV ||
4230 curop->op_type == OP_PADHV ||
4231 curop->op_type == OP_PADANY)
4235 else if (curop->op_type == OP_PUSHRE)
4236 NOOP; /* Okay here, dangerous in newASSIGNOP */
4246 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4248 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4249 op_prepend_elem(o->op_type, scalar(repl), o);
4252 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4253 pm->op_pmflags |= PMf_MAYBE_CONST;
4255 NewOp(1101, rcop, 1, LOGOP);
4256 rcop->op_type = OP_SUBSTCONT;
4257 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4258 rcop->op_first = scalar(repl);
4259 rcop->op_flags |= OPf_KIDS;
4260 rcop->op_private = 1;
4263 /* establish postfix order */
4264 rcop->op_next = LINKLIST(repl);
4265 repl->op_next = (OP*)rcop;
4267 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4268 assert(!(pm->op_pmflags & PMf_ONCE));
4269 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4278 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4280 Constructs, checks, and returns an op of any type that involves an
4281 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4282 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4283 takes ownership of one reference to it.
4289 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4294 PERL_ARGS_ASSERT_NEWSVOP;
4296 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4297 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4298 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4300 NewOp(1101, svop, 1, SVOP);
4301 svop->op_type = (OPCODE)type;
4302 svop->op_ppaddr = PL_ppaddr[type];
4304 svop->op_next = (OP*)svop;
4305 svop->op_flags = (U8)flags;
4306 if (PL_opargs[type] & OA_RETSCALAR)
4308 if (PL_opargs[type] & OA_TARGET)
4309 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4310 return CHECKOP(type, svop);
4316 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4318 Constructs, checks, and returns an op of any type that involves a
4319 reference to a pad element. I<type> is the opcode. I<flags> gives the
4320 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4321 is populated with I<sv>; this function takes ownership of one reference
4324 This function only exists if Perl has been compiled to use ithreads.
4330 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4335 PERL_ARGS_ASSERT_NEWPADOP;
4337 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4338 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4339 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4341 NewOp(1101, padop, 1, PADOP);
4342 padop->op_type = (OPCODE)type;
4343 padop->op_ppaddr = PL_ppaddr[type];
4344 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4345 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4346 PAD_SETSV(padop->op_padix, sv);
4349 padop->op_next = (OP*)padop;
4350 padop->op_flags = (U8)flags;
4351 if (PL_opargs[type] & OA_RETSCALAR)
4353 if (PL_opargs[type] & OA_TARGET)
4354 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4355 return CHECKOP(type, padop);
4358 #endif /* !USE_ITHREADS */
4361 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4363 Constructs, checks, and returns an op of any type that involves an
4364 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4365 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4366 reference; calling this function does not transfer ownership of any
4373 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4377 PERL_ARGS_ASSERT_NEWGVOP;
4381 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4383 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4388 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4390 Constructs, checks, and returns an op of any type that involves an
4391 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4392 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4393 must have been allocated using L</PerlMemShared_malloc>; the memory will
4394 be freed when the op is destroyed.
4400 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4405 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4406 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4408 NewOp(1101, pvop, 1, PVOP);
4409 pvop->op_type = (OPCODE)type;
4410 pvop->op_ppaddr = PL_ppaddr[type];
4412 pvop->op_next = (OP*)pvop;
4413 pvop->op_flags = (U8)flags;
4414 if (PL_opargs[type] & OA_RETSCALAR)
4416 if (PL_opargs[type] & OA_TARGET)
4417 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4418 return CHECKOP(type, pvop);
4426 Perl_package(pTHX_ OP *o)
4429 SV *const sv = cSVOPo->op_sv;
4434 PERL_ARGS_ASSERT_PACKAGE;
4436 save_hptr(&PL_curstash);
4437 save_item(PL_curstname);
4439 PL_curstash = gv_stashsv(sv, GV_ADD);
4441 sv_setsv(PL_curstname, sv);
4443 PL_hints |= HINT_BLOCK_SCOPE;
4444 PL_parser->copline = NOLINE;
4445 PL_parser->expect = XSTATE;
4450 if (!PL_madskills) {
4455 pegop = newOP(OP_NULL,0);
4456 op_getmad(o,pegop,'P');
4462 Perl_package_version( pTHX_ OP *v )
4465 U32 savehints = PL_hints;
4466 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4467 PL_hints &= ~HINT_STRICT_VARS;
4468 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4469 PL_hints = savehints;
4478 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4485 OP *pegop = newOP(OP_NULL,0);
4487 SV *use_version = NULL;
4489 PERL_ARGS_ASSERT_UTILIZE;
4491 if (idop->op_type != OP_CONST)
4492 Perl_croak(aTHX_ "Module name must be constant");
4495 op_getmad(idop,pegop,'U');
4500 SV * const vesv = ((SVOP*)version)->op_sv;
4503 op_getmad(version,pegop,'V');
4504 if (!arg && !SvNIOKp(vesv)) {
4511 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4512 Perl_croak(aTHX_ "Version number must be a constant number");
4514 /* Make copy of idop so we don't free it twice */
4515 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4517 /* Fake up a method call to VERSION */
4518 meth = newSVpvs_share("VERSION");
4519 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4520 op_append_elem(OP_LIST,
4521 op_prepend_elem(OP_LIST, pack, list(version)),
4522 newSVOP(OP_METHOD_NAMED, 0, meth)));
4526 /* Fake up an import/unimport */
4527 if (arg && arg->op_type == OP_STUB) {
4529 op_getmad(arg,pegop,'S');
4530 imop = arg; /* no import on explicit () */
4532 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4533 imop = NULL; /* use 5.0; */
4535 use_version = ((SVOP*)idop)->op_sv;
4537 idop->op_private |= OPpCONST_NOVER;
4543 op_getmad(arg,pegop,'A');
4545 /* Make copy of idop so we don't free it twice */
4546 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4548 /* Fake up a method call to import/unimport */
4550 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4551 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4552 op_append_elem(OP_LIST,
4553 op_prepend_elem(OP_LIST, pack, list(arg)),
4554 newSVOP(OP_METHOD_NAMED, 0, meth)));
4557 /* Fake up the BEGIN {}, which does its thing immediately. */
4559 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4562 op_append_elem(OP_LINESEQ,
4563 op_append_elem(OP_LINESEQ,
4564 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4565 newSTATEOP(0, NULL, veop)),
4566 newSTATEOP(0, NULL, imop) ));
4569 /* If we request a version >= 5.9.5, load feature.pm with the
4570 * feature bundle that corresponds to the required version. */
4571 use_version = sv_2mortal(new_version(use_version));
4573 if (vcmp(use_version,
4574 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4575 SV *const importsv = vnormal(use_version);
4576 *SvPVX_mutable(importsv) = ':';
4577 ENTER_with_name("load_feature");
4578 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4579 LEAVE_with_name("load_feature");
4581 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4582 if (vcmp(use_version,
4583 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4584 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4588 /* The "did you use incorrect case?" warning used to be here.
4589 * The problem is that on case-insensitive filesystems one
4590 * might get false positives for "use" (and "require"):
4591 * "use Strict" or "require CARP" will work. This causes
4592 * portability problems for the script: in case-strict
4593 * filesystems the script will stop working.
4595 * The "incorrect case" warning checked whether "use Foo"
4596 * imported "Foo" to your namespace, but that is wrong, too:
4597 * there is no requirement nor promise in the language that
4598 * a Foo.pm should or would contain anything in package "Foo".
4600 * There is very little Configure-wise that can be done, either:
4601 * the case-sensitivity of the build filesystem of Perl does not
4602 * help in guessing the case-sensitivity of the runtime environment.
4605 PL_hints |= HINT_BLOCK_SCOPE;
4606 PL_parser->copline = NOLINE;
4607 PL_parser->expect = XSTATE;
4608 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4609 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4613 if (!PL_madskills) {
4614 /* FIXME - don't allocate pegop if !PL_madskills */
4623 =head1 Embedding Functions
4625 =for apidoc load_module
4627 Loads the module whose name is pointed to by the string part of name.
4628 Note that the actual module name, not its filename, should be given.
4629 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4630 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4631 (or 0 for no flags). ver, if specified, provides version semantics
4632 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4633 arguments can be used to specify arguments to the module's import()
4634 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4635 terminated with a final NULL pointer. Note that this list can only
4636 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4637 Otherwise at least a single NULL pointer to designate the default
4638 import list is required.
4643 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4647 PERL_ARGS_ASSERT_LOAD_MODULE;
4649 va_start(args, ver);
4650 vload_module(flags, name, ver, &args);
4654 #ifdef PERL_IMPLICIT_CONTEXT
4656 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4660 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4661 va_start(args, ver);
4662 vload_module(flags, name, ver, &args);
4668 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4672 OP * const modname = newSVOP(OP_CONST, 0, name);
4674 PERL_ARGS_ASSERT_VLOAD_MODULE;
4676 modname->op_private |= OPpCONST_BARE;
4678 veop = newSVOP(OP_CONST, 0, ver);
4682 if (flags & PERL_LOADMOD_NOIMPORT) {
4683 imop = sawparens(newNULLLIST());
4685 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4686 imop = va_arg(*args, OP*);
4691 sv = va_arg(*args, SV*);
4693 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4694 sv = va_arg(*args, SV*);
4698 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4699 * that it has a PL_parser to play with while doing that, and also
4700 * that it doesn't mess with any existing parser, by creating a tmp
4701 * new parser with lex_start(). This won't actually be used for much,
4702 * since pp_require() will create another parser for the real work. */
4705 SAVEVPTR(PL_curcop);
4706 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4707 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4708 veop, modname, imop);
4713 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4719 PERL_ARGS_ASSERT_DOFILE;
4721 if (!force_builtin) {
4722 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4723 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4724 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4725 gv = gvp ? *gvp : NULL;
4729 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4730 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4731 op_append_elem(OP_LIST, term,
4732 scalar(newUNOP(OP_RV2CV, 0,
4733 newGVOP(OP_GV, 0, gv))))));
4736 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4742 =head1 Optree construction
4744 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4746 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4747 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4748 be set automatically, and, shifted up eight bits, the eight bits of
4749 C<op_private>, except that the bit with value 1 or 2 is automatically
4750 set as required. I<listval> and I<subscript> supply the parameters of
4751 the slice; they are consumed by this function and become part of the
4752 constructed op tree.
4758 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4760 return newBINOP(OP_LSLICE, flags,
4761 list(force_list(subscript)),
4762 list(force_list(listval)) );
4766 S_is_list_assignment(pTHX_ register const OP *o)
4774 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4775 o = cUNOPo->op_first;
4777 flags = o->op_flags;
4779 if (type == OP_COND_EXPR) {
4780 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4781 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4786 yyerror("Assignment to both a list and a scalar");
4790 if (type == OP_LIST &&
4791 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4792 o->op_private & OPpLVAL_INTRO)
4795 if (type == OP_LIST || flags & OPf_PARENS ||
4796 type == OP_RV2AV || type == OP_RV2HV ||
4797 type == OP_ASLICE || type == OP_HSLICE)
4800 if (type == OP_PADAV || type == OP_PADHV)
4803 if (type == OP_RV2SV)
4810 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4812 Constructs, checks, and returns an assignment op. I<left> and I<right>
4813 supply the parameters of the assignment; they are consumed by this
4814 function and become part of the constructed op tree.
4816 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4817 a suitable conditional optree is constructed. If I<optype> is the opcode
4818 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4819 performs the binary operation and assigns the result to the left argument.
4820 Either way, if I<optype> is non-zero then I<flags> has no effect.
4822 If I<optype> is zero, then a plain scalar or list assignment is
4823 constructed. Which type of assignment it is is automatically determined.
4824 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4825 will be set automatically, and, shifted up eight bits, the eight bits
4826 of C<op_private>, except that the bit with value 1 or 2 is automatically
4833 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4839 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4840 return newLOGOP(optype, 0,
4841 op_lvalue(scalar(left), optype),
4842 newUNOP(OP_SASSIGN, 0, scalar(right)));
4845 return newBINOP(optype, OPf_STACKED,
4846 op_lvalue(scalar(left), optype), scalar(right));
4850 if (is_list_assignment(left)) {
4851 static const char no_list_state[] = "Initialization of state variables"
4852 " in list context currently forbidden";
4854 bool maybe_common_vars = TRUE;
4857 /* Grandfathering $[ assignment here. Bletch.*/
4858 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4859 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4860 left = op_lvalue(left, OP_AASSIGN);
4863 else if (left->op_type == OP_CONST) {
4864 deprecate("assignment to $[");
4866 /* Result of assignment is always 1 (or we'd be dead already) */
4867 return newSVOP(OP_CONST, 0, newSViv(1));
4869 curop = list(force_list(left));
4870 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4871 o->op_private = (U8)(0 | (flags >> 8));
4873 if ((left->op_type == OP_LIST
4874 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4876 OP* lop = ((LISTOP*)left)->op_first;
4877 maybe_common_vars = FALSE;
4879 if (lop->op_type == OP_PADSV ||
4880 lop->op_type == OP_PADAV ||
4881 lop->op_type == OP_PADHV ||
4882 lop->op_type == OP_PADANY) {
4883 if (!(lop->op_private & OPpLVAL_INTRO))
4884 maybe_common_vars = TRUE;
4886 if (lop->op_private & OPpPAD_STATE) {
4887 if (left->op_private & OPpLVAL_INTRO) {
4888 /* Each variable in state($a, $b, $c) = ... */
4891 /* Each state variable in
4892 (state $a, my $b, our $c, $d, undef) = ... */
4894 yyerror(no_list_state);
4896 /* Each my variable in
4897 (state $a, my $b, our $c, $d, undef) = ... */
4899 } else if (lop->op_type == OP_UNDEF ||
4900 lop->op_type == OP_PUSHMARK) {
4901 /* undef may be interesting in
4902 (state $a, undef, state $c) */
4904 /* Other ops in the list. */
4905 maybe_common_vars = TRUE;
4907 lop = lop->op_sibling;
4910 else if ((left->op_private & OPpLVAL_INTRO)
4911 && ( left->op_type == OP_PADSV
4912 || left->op_type == OP_PADAV
4913 || left->op_type == OP_PADHV
4914 || left->op_type == OP_PADANY))
4916 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4917 if (left->op_private & OPpPAD_STATE) {
4918 /* All single variable list context state assignments, hence
4928 yyerror(no_list_state);
4932 /* PL_generation sorcery:
4933 * an assignment like ($a,$b) = ($c,$d) is easier than
4934 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4935 * To detect whether there are common vars, the global var
4936 * PL_generation is incremented for each assign op we compile.
4937 * Then, while compiling the assign op, we run through all the
4938 * variables on both sides of the assignment, setting a spare slot
4939 * in each of them to PL_generation. If any of them already have
4940 * that value, we know we've got commonality. We could use a
4941 * single bit marker, but then we'd have to make 2 passes, first
4942 * to clear the flag, then to test and set it. To find somewhere
4943 * to store these values, evil chicanery is done with SvUVX().
4946 if (maybe_common_vars) {
4949 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4950 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4951 if (curop->op_type == OP_GV) {
4952 GV *gv = cGVOPx_gv(curop);
4954 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4956 GvASSIGN_GENERATION_set(gv, PL_generation);
4958 else if (curop->op_type == OP_PADSV ||
4959 curop->op_type == OP_PADAV ||
4960 curop->op_type == OP_PADHV ||
4961 curop->op_type == OP_PADANY)
4963 if (PAD_COMPNAME_GEN(curop->op_targ)
4964 == (STRLEN)PL_generation)
4966 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4969 else if (curop->op_type == OP_RV2CV)
4971 else if (curop->op_type == OP_RV2SV ||
4972 curop->op_type == OP_RV2AV ||
4973 curop->op_type == OP_RV2HV ||
4974 curop->op_type == OP_RV2GV) {
4975 if (lastop->op_type != OP_GV) /* funny deref? */
4978 else if (curop->op_type == OP_PUSHRE) {
4980 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4981 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4983 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4985 GvASSIGN_GENERATION_set(gv, PL_generation);
4989 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4992 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4994 GvASSIGN_GENERATION_set(gv, PL_generation);
5004 o->op_private |= OPpASSIGN_COMMON;
5007 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5008 OP* tmpop = ((LISTOP*)right)->op_first;
5009 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5010 PMOP * const pm = (PMOP*)tmpop;
5011 if (left->op_type == OP_RV2AV &&
5012 !(left->op_private & OPpLVAL_INTRO) &&
5013 !(o->op_private & OPpASSIGN_COMMON) )
5015 tmpop = ((UNOP*)left)->op_first;
5016 if (tmpop->op_type == OP_GV
5018 && !pm->op_pmreplrootu.op_pmtargetoff
5020 && !pm->op_pmreplrootu.op_pmtargetgv
5024 pm->op_pmreplrootu.op_pmtargetoff
5025 = cPADOPx(tmpop)->op_padix;
5026 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5028 pm->op_pmreplrootu.op_pmtargetgv
5029 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5030 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5032 pm->op_pmflags |= PMf_ONCE;
5033 tmpop = cUNOPo->op_first; /* to list (nulled) */
5034 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5035 tmpop->op_sibling = NULL; /* don't free split */
5036 right->op_next = tmpop->op_next; /* fix starting loc */
5037 op_free(o); /* blow off assign */
5038 right->op_flags &= ~OPf_WANT;
5039 /* "I don't know and I don't care." */
5044 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5045 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5047 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5048 if (SvIOK(sv) && SvIVX(sv) == 0)
5049 sv_setiv(sv, PL_modcount+1);
5057 right = newOP(OP_UNDEF, 0);
5058 if (right->op_type == OP_READLINE) {
5059 right->op_flags |= OPf_STACKED;
5060 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5064 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
5065 o = newBINOP(OP_SASSIGN, flags,
5066 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5070 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
5071 deprecate("assignment to $[");
5073 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
5074 o->op_private |= OPpCONST_ARYBASE;
5082 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5084 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5085 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5086 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5087 If I<label> is non-null, it supplies the name of a label to attach to
5088 the state op; this function takes ownership of the memory pointed at by
5089 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5092 If I<o> is null, the state op is returned. Otherwise the state op is
5093 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5094 is consumed by this function and becomes part of the returned op tree.
5100 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5103 const U32 seq = intro_my();
5106 NewOp(1101, cop, 1, COP);
5107 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5108 cop->op_type = OP_DBSTATE;
5109 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5112 cop->op_type = OP_NEXTSTATE;
5113 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5115 cop->op_flags = (U8)flags;
5116 CopHINTS_set(cop, PL_hints);
5118 cop->op_private |= NATIVE_HINTS;
5120 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5121 cop->op_next = (OP*)cop;
5124 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
5125 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
5127 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5128 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5130 Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
5132 PL_hints |= HINT_BLOCK_SCOPE;
5133 /* It seems that we need to defer freeing this pointer, as other parts
5134 of the grammar end up wanting to copy it after this op has been
5139 if (PL_parser && PL_parser->copline == NOLINE)
5140 CopLINE_set(cop, CopLINE(PL_curcop));
5142 CopLINE_set(cop, PL_parser->copline);
5144 PL_parser->copline = NOLINE;
5147 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5149 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5151 CopSTASH_set(cop, PL_curstash);
5153 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5154 /* this line can have a breakpoint - store the cop in IV */
5155 AV *av = CopFILEAVx(PL_curcop);
5157 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5158 if (svp && *svp != &PL_sv_undef ) {
5159 (void)SvIOK_on(*svp);
5160 SvIV_set(*svp, PTR2IV(cop));
5165 if (flags & OPf_SPECIAL)
5167 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5171 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5173 Constructs, checks, and returns a logical (flow control) op. I<type>
5174 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5175 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5176 the eight bits of C<op_private>, except that the bit with value 1 is
5177 automatically set. I<first> supplies the expression controlling the
5178 flow, and I<other> supplies the side (alternate) chain of ops; they are
5179 consumed by this function and become part of the constructed op tree.
5185 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5189 PERL_ARGS_ASSERT_NEWLOGOP;
5191 return new_logop(type, flags, &first, &other);
5195 S_search_const(pTHX_ OP *o)
5197 PERL_ARGS_ASSERT_SEARCH_CONST;
5199 switch (o->op_type) {
5203 if (o->op_flags & OPf_KIDS)
5204 return search_const(cUNOPo->op_first);
5211 if (!(o->op_flags & OPf_KIDS))
5213 kid = cLISTOPo->op_first;
5215 switch (kid->op_type) {
5219 kid = kid->op_sibling;
5222 if (kid != cLISTOPo->op_last)
5228 kid = cLISTOPo->op_last;
5230 return search_const(kid);
5238 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5246 int prepend_not = 0;
5248 PERL_ARGS_ASSERT_NEW_LOGOP;
5253 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5254 return newBINOP(type, flags, scalar(first), scalar(other));
5256 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5258 scalarboolean(first);
5259 /* optimize AND and OR ops that have NOTs as children */
5260 if (first->op_type == OP_NOT
5261 && (first->op_flags & OPf_KIDS)
5262 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5263 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5265 if (type == OP_AND || type == OP_OR) {
5271 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5273 prepend_not = 1; /* prepend a NOT op later */
5277 /* search for a constant op that could let us fold the test */
5278 if ((cstop = search_const(first))) {
5279 if (cstop->op_private & OPpCONST_STRICT)
5280 no_bareword_allowed(cstop);
5281 else if ((cstop->op_private & OPpCONST_BARE))
5282 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5283 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5284 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5285 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5287 if (other->op_type == OP_CONST)
5288 other->op_private |= OPpCONST_SHORTCIRCUIT;
5290 OP *newop = newUNOP(OP_NULL, 0, other);
5291 op_getmad(first, newop, '1');
5292 newop->op_targ = type; /* set "was" field */
5296 if (other->op_type == OP_LEAVE)
5297 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5298 else if (other->op_type == OP_MATCH
5299 || other->op_type == OP_SUBST
5300 || other->op_type == OP_TRANSR
5301 || other->op_type == OP_TRANS)
5302 /* Mark the op as being unbindable with =~ */
5303 other->op_flags |= OPf_SPECIAL;
5307 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5308 const OP *o2 = other;
5309 if ( ! (o2->op_type == OP_LIST
5310 && (( o2 = cUNOPx(o2)->op_first))
5311 && o2->op_type == OP_PUSHMARK
5312 && (( o2 = o2->op_sibling)) )
5315 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5316 || o2->op_type == OP_PADHV)
5317 && o2->op_private & OPpLVAL_INTRO
5318 && !(o2->op_private & OPpPAD_STATE))
5320 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5321 "Deprecated use of my() in false conditional");
5325 if (first->op_type == OP_CONST)
5326 first->op_private |= OPpCONST_SHORTCIRCUIT;
5328 first = newUNOP(OP_NULL, 0, first);
5329 op_getmad(other, first, '2');
5330 first->op_targ = type; /* set "was" field */
5337 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5338 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5340 const OP * const k1 = ((UNOP*)first)->op_first;
5341 const OP * const k2 = k1->op_sibling;
5343 switch (first->op_type)
5346 if (k2 && k2->op_type == OP_READLINE
5347 && (k2->op_flags & OPf_STACKED)
5348 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5350 warnop = k2->op_type;
5355 if (k1->op_type == OP_READDIR
5356 || k1->op_type == OP_GLOB
5357 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5358 || k1->op_type == OP_EACH
5359 || k1->op_type == OP_AEACH)
5361 warnop = ((k1->op_type == OP_NULL)
5362 ? (OPCODE)k1->op_targ : k1->op_type);
5367 const line_t oldline = CopLINE(PL_curcop);
5368 CopLINE_set(PL_curcop, PL_parser->copline);
5369 Perl_warner(aTHX_ packWARN(WARN_MISC),
5370 "Value of %s%s can be \"0\"; test with defined()",
5372 ((warnop == OP_READLINE || warnop == OP_GLOB)
5373 ? " construct" : "() operator"));
5374 CopLINE_set(PL_curcop, oldline);
5381 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5382 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5384 NewOp(1101, logop, 1, LOGOP);
5386 logop->op_type = (OPCODE)type;
5387 logop->op_ppaddr = PL_ppaddr[type];
5388 logop->op_first = first;
5389 logop->op_flags = (U8)(flags | OPf_KIDS);
5390 logop->op_other = LINKLIST(other);
5391 logop->op_private = (U8)(1 | (flags >> 8));
5393 /* establish postfix order */
5394 logop->op_next = LINKLIST(first);
5395 first->op_next = (OP*)logop;
5396 first->op_sibling = other;
5398 CHECKOP(type,logop);
5400 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5407 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5409 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5410 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5411 will be set automatically, and, shifted up eight bits, the eight bits of
5412 C<op_private>, except that the bit with value 1 is automatically set.
5413 I<first> supplies the expression selecting between the two branches,
5414 and I<trueop> and I<falseop> supply the branches; they are consumed by
5415 this function and become part of the constructed op tree.
5421 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5429 PERL_ARGS_ASSERT_NEWCONDOP;
5432 return newLOGOP(OP_AND, 0, first, trueop);
5434 return newLOGOP(OP_OR, 0, first, falseop);
5436 scalarboolean(first);
5437 if ((cstop = search_const(first))) {
5438 /* Left or right arm of the conditional? */
5439 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5440 OP *live = left ? trueop : falseop;
5441 OP *const dead = left ? falseop : trueop;
5442 if (cstop->op_private & OPpCONST_BARE &&
5443 cstop->op_private & OPpCONST_STRICT) {
5444 no_bareword_allowed(cstop);
5447 /* This is all dead code when PERL_MAD is not defined. */
5448 live = newUNOP(OP_NULL, 0, live);
5449 op_getmad(first, live, 'C');
5450 op_getmad(dead, live, left ? 'e' : 't');
5455 if (live->op_type == OP_LEAVE)
5456 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5457 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5458 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5459 /* Mark the op as being unbindable with =~ */
5460 live->op_flags |= OPf_SPECIAL;
5463 NewOp(1101, logop, 1, LOGOP);
5464 logop->op_type = OP_COND_EXPR;
5465 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5466 logop->op_first = first;
5467 logop->op_flags = (U8)(flags | OPf_KIDS);
5468 logop->op_private = (U8)(1 | (flags >> 8));
5469 logop->op_other = LINKLIST(trueop);
5470 logop->op_next = LINKLIST(falseop);
5472 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5475 /* establish postfix order */
5476 start = LINKLIST(first);
5477 first->op_next = (OP*)logop;
5479 first->op_sibling = trueop;
5480 trueop->op_sibling = falseop;
5481 o = newUNOP(OP_NULL, 0, (OP*)logop);
5483 trueop->op_next = falseop->op_next = o;
5490 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5492 Constructs and returns a C<range> op, with subordinate C<flip> and
5493 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5494 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5495 for both the C<flip> and C<range> ops, except that the bit with value
5496 1 is automatically set. I<left> and I<right> supply the expressions
5497 controlling the endpoints of the range; they are consumed by this function
5498 and become part of the constructed op tree.
5504 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5513 PERL_ARGS_ASSERT_NEWRANGE;
5515 NewOp(1101, range, 1, LOGOP);
5517 range->op_type = OP_RANGE;
5518 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5519 range->op_first = left;
5520 range->op_flags = OPf_KIDS;
5521 leftstart = LINKLIST(left);
5522 range->op_other = LINKLIST(right);
5523 range->op_private = (U8)(1 | (flags >> 8));
5525 left->op_sibling = right;
5527 range->op_next = (OP*)range;
5528 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5529 flop = newUNOP(OP_FLOP, 0, flip);
5530 o = newUNOP(OP_NULL, 0, flop);
5532 range->op_next = leftstart;
5534 left->op_next = flip;
5535 right->op_next = flop;
5537 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5538 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5539 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5540 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5542 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5543 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5546 if (!flip->op_private || !flop->op_private)
5547 LINKLIST(o); /* blow off optimizer unless constant */
5553 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5555 Constructs, checks, and returns an op tree expressing a loop. This is
5556 only a loop in the control flow through the op tree; it does not have
5557 the heavyweight loop structure that allows exiting the loop by C<last>
5558 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5559 top-level op, except that some bits will be set automatically as required.
5560 I<expr> supplies the expression controlling loop iteration, and I<block>
5561 supplies the body of the loop; they are consumed by this function and
5562 become part of the constructed op tree. I<debuggable> is currently
5563 unused and should always be 1.
5569 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5574 const bool once = block && block->op_flags & OPf_SPECIAL &&
5575 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5577 PERL_UNUSED_ARG(debuggable);
5580 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5581 return block; /* do {} while 0 does once */
5582 if (expr->op_type == OP_READLINE
5583 || expr->op_type == OP_READDIR
5584 || expr->op_type == OP_GLOB
5585 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5586 expr = newUNOP(OP_DEFINED, 0,
5587 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5588 } else if (expr->op_flags & OPf_KIDS) {
5589 const OP * const k1 = ((UNOP*)expr)->op_first;
5590 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5591 switch (expr->op_type) {
5593 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5594 && (k2->op_flags & OPf_STACKED)
5595 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5596 expr = newUNOP(OP_DEFINED, 0, expr);
5600 if (k1 && (k1->op_type == OP_READDIR
5601 || k1->op_type == OP_GLOB
5602 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5603 || k1->op_type == OP_EACH
5604 || k1->op_type == OP_AEACH))
5605 expr = newUNOP(OP_DEFINED, 0, expr);
5611 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5612 * op, in listop. This is wrong. [perl #27024] */
5614 block = newOP(OP_NULL, 0);
5615 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5616 o = new_logop(OP_AND, 0, &expr, &listop);
5619 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5621 if (once && o != listop)
5622 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5625 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5627 o->op_flags |= flags;
5629 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5634 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5636 Constructs, checks, and returns an op tree expressing a C<while> loop.
5637 This is a heavyweight loop, with structure that allows exiting the loop
5638 by C<last> and suchlike.
5640 I<loop> is an optional preconstructed C<enterloop> op to use in the
5641 loop; if it is null then a suitable op will be constructed automatically.
5642 I<expr> supplies the loop's controlling expression. I<block> supplies the
5643 main body of the loop, and I<cont> optionally supplies a C<continue> block
5644 that operates as a second half of the body. All of these optree inputs
5645 are consumed by this function and become part of the constructed op tree.
5647 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5648 op and, shifted up eight bits, the eight bits of C<op_private> for
5649 the C<leaveloop> op, except that (in both cases) some bits will be set
5650 automatically. I<debuggable> is currently unused and should always be 1.
5651 I<has_my> can be supplied as true to force the
5652 loop body to be enclosed in its own scope.
5658 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5659 OP *expr, OP *block, OP *cont, I32 has_my)
5668 PERL_UNUSED_ARG(debuggable);
5671 if (expr->op_type == OP_READLINE
5672 || expr->op_type == OP_READDIR
5673 || expr->op_type == OP_GLOB
5674 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5675 expr = newUNOP(OP_DEFINED, 0,
5676 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5677 } else if (expr->op_flags & OPf_KIDS) {
5678 const OP * const k1 = ((UNOP*)expr)->op_first;
5679 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5680 switch (expr->op_type) {
5682 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5683 && (k2->op_flags & OPf_STACKED)
5684 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5685 expr = newUNOP(OP_DEFINED, 0, expr);
5689 if (k1 && (k1->op_type == OP_READDIR
5690 || k1->op_type == OP_GLOB
5691 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5692 || k1->op_type == OP_EACH
5693 || k1->op_type == OP_AEACH))
5694 expr = newUNOP(OP_DEFINED, 0, expr);
5701 block = newOP(OP_NULL, 0);
5702 else if (cont || has_my) {
5703 block = op_scope(block);
5707 next = LINKLIST(cont);
5710 OP * const unstack = newOP(OP_UNSTACK, 0);
5713 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5717 listop = op_append_list(OP_LINESEQ, block, cont);
5719 redo = LINKLIST(listop);
5723 o = new_logop(OP_AND, 0, &expr, &listop);
5724 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5725 op_free(expr); /* oops, it's a while (0) */
5727 return NULL; /* listop already freed by new_logop */
5730 ((LISTOP*)listop)->op_last->op_next =
5731 (o == listop ? redo : LINKLIST(o));
5737 NewOp(1101,loop,1,LOOP);
5738 loop->op_type = OP_ENTERLOOP;
5739 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5740 loop->op_private = 0;
5741 loop->op_next = (OP*)loop;
5744 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5746 loop->op_redoop = redo;
5747 loop->op_lastop = o;
5748 o->op_private |= loopflags;
5751 loop->op_nextop = next;
5753 loop->op_nextop = o;
5755 o->op_flags |= flags;
5756 o->op_private |= (flags >> 8);
5761 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5763 Constructs, checks, and returns an op tree expressing a C<foreach>
5764 loop (iteration through a list of values). This is a heavyweight loop,
5765 with structure that allows exiting the loop by C<last> and suchlike.
5767 I<sv> optionally supplies the variable that will be aliased to each
5768 item in turn; if null, it defaults to C<$_> (either lexical or global).
5769 I<expr> supplies the list of values to iterate over. I<block> supplies
5770 the main body of the loop, and I<cont> optionally supplies a C<continue>
5771 block that operates as a second half of the body. All of these optree
5772 inputs are consumed by this function and become part of the constructed
5775 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5776 op and, shifted up eight bits, the eight bits of C<op_private> for
5777 the C<leaveloop> op, except that (in both cases) some bits will be set
5784 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5789 PADOFFSET padoff = 0;
5794 PERL_ARGS_ASSERT_NEWFOROP;
5797 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5798 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5799 sv->op_type = OP_RV2GV;
5800 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5802 /* The op_type check is needed to prevent a possible segfault
5803 * if the loop variable is undeclared and 'strict vars' is in
5804 * effect. This is illegal but is nonetheless parsed, so we
5805 * may reach this point with an OP_CONST where we're expecting
5808 if (cUNOPx(sv)->op_first->op_type == OP_GV
5809 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5810 iterpflags |= OPpITER_DEF;
5812 else if (sv->op_type == OP_PADSV) { /* private variable */
5813 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5814 padoff = sv->op_targ;
5824 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5826 SV *const namesv = PAD_COMPNAME_SV(padoff);
5828 const char *const name = SvPV_const(namesv, len);
5830 if (len == 2 && name[0] == '$' && name[1] == '_')
5831 iterpflags |= OPpITER_DEF;
5835 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5836 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5837 sv = newGVOP(OP_GV, 0, PL_defgv);
5842 iterpflags |= OPpITER_DEF;
5844 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5845 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5846 iterflags |= OPf_STACKED;
5848 else if (expr->op_type == OP_NULL &&
5849 (expr->op_flags & OPf_KIDS) &&
5850 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5852 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5853 * set the STACKED flag to indicate that these values are to be
5854 * treated as min/max values by 'pp_iterinit'.
5856 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5857 LOGOP* const range = (LOGOP*) flip->op_first;
5858 OP* const left = range->op_first;
5859 OP* const right = left->op_sibling;
5862 range->op_flags &= ~OPf_KIDS;
5863 range->op_first = NULL;
5865 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5866 listop->op_first->op_next = range->op_next;
5867 left->op_next = range->op_other;
5868 right->op_next = (OP*)listop;
5869 listop->op_next = listop->op_first;
5872 op_getmad(expr,(OP*)listop,'O');
5876 expr = (OP*)(listop);
5878 iterflags |= OPf_STACKED;
5881 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5884 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5885 op_append_elem(OP_LIST, expr, scalar(sv))));
5886 assert(!loop->op_next);
5887 /* for my $x () sets OPpLVAL_INTRO;
5888 * for our $x () sets OPpOUR_INTRO */
5889 loop->op_private = (U8)iterpflags;
5890 #ifdef PL_OP_SLAB_ALLOC
5893 NewOp(1234,tmp,1,LOOP);
5894 Copy(loop,tmp,1,LISTOP);
5895 S_op_destroy(aTHX_ (OP*)loop);
5899 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5901 loop->op_targ = padoff;
5902 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5904 op_getmad(madsv, (OP*)loop, 'v');
5909 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5911 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5912 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5913 determining the target of the op; it is consumed by this function and
5914 become part of the constructed op tree.
5920 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5925 PERL_ARGS_ASSERT_NEWLOOPEX;
5927 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5929 if (type != OP_GOTO || label->op_type == OP_CONST) {
5930 /* "last()" means "last" */
5931 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5932 o = newOP(type, OPf_SPECIAL);
5934 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5935 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5939 op_getmad(label,o,'L');
5945 /* Check whether it's going to be a goto &function */
5946 if (label->op_type == OP_ENTERSUB
5947 && !(label->op_flags & OPf_STACKED))
5948 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
5949 o = newUNOP(type, OPf_STACKED, label);
5951 PL_hints |= HINT_BLOCK_SCOPE;
5955 /* if the condition is a literal array or hash
5956 (or @{ ... } etc), make a reference to it.
5959 S_ref_array_or_hash(pTHX_ OP *cond)
5962 && (cond->op_type == OP_RV2AV
5963 || cond->op_type == OP_PADAV
5964 || cond->op_type == OP_RV2HV
5965 || cond->op_type == OP_PADHV))
5967 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
5970 && (cond->op_type == OP_ASLICE
5971 || cond->op_type == OP_HSLICE)) {
5973 /* anonlist now needs a list from this op, was previously used in
5975 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5976 cond->op_flags |= OPf_WANT_LIST;
5978 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
5985 /* These construct the optree fragments representing given()
5988 entergiven and enterwhen are LOGOPs; the op_other pointer
5989 points up to the associated leave op. We need this so we
5990 can put it in the context and make break/continue work.
5991 (Also, of course, pp_enterwhen will jump straight to
5992 op_other if the match fails.)
5996 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5997 I32 enter_opcode, I32 leave_opcode,
5998 PADOFFSET entertarg)
6004 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6006 NewOp(1101, enterop, 1, LOGOP);
6007 enterop->op_type = (Optype)enter_opcode;
6008 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6009 enterop->op_flags = (U8) OPf_KIDS;
6010 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6011 enterop->op_private = 0;
6013 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6016 enterop->op_first = scalar(cond);
6017 cond->op_sibling = block;
6019 o->op_next = LINKLIST(cond);
6020 cond->op_next = (OP *) enterop;
6023 /* This is a default {} block */
6024 enterop->op_first = block;
6025 enterop->op_flags |= OPf_SPECIAL;
6027 o->op_next = (OP *) enterop;
6030 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6031 entergiven and enterwhen both
6034 enterop->op_next = LINKLIST(block);
6035 block->op_next = enterop->op_other = o;
6040 /* Does this look like a boolean operation? For these purposes
6041 a boolean operation is:
6042 - a subroutine call [*]
6043 - a logical connective
6044 - a comparison operator
6045 - a filetest operator, with the exception of -s -M -A -C
6046 - defined(), exists() or eof()
6047 - /$re/ or $foo =~ /$re/
6049 [*] possibly surprising
6052 S_looks_like_bool(pTHX_ const OP *o)
6056 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6058 switch(o->op_type) {
6061 return looks_like_bool(cLOGOPo->op_first);
6065 looks_like_bool(cLOGOPo->op_first)
6066 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6071 o->op_flags & OPf_KIDS
6072 && looks_like_bool(cUNOPo->op_first));
6076 case OP_NOT: case OP_XOR:
6078 case OP_EQ: case OP_NE: case OP_LT:
6079 case OP_GT: case OP_LE: case OP_GE:
6081 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6082 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6084 case OP_SEQ: case OP_SNE: case OP_SLT:
6085 case OP_SGT: case OP_SLE: case OP_SGE:
6089 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6090 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6091 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6092 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6093 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6094 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6095 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6096 case OP_FTTEXT: case OP_FTBINARY:
6098 case OP_DEFINED: case OP_EXISTS:
6099 case OP_MATCH: case OP_EOF:
6106 /* Detect comparisons that have been optimized away */
6107 if (cSVOPo->op_sv == &PL_sv_yes
6108 || cSVOPo->op_sv == &PL_sv_no)
6121 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6123 Constructs, checks, and returns an op tree expressing a C<given> block.
6124 I<cond> supplies the expression that will be locally assigned to a lexical
6125 variable, and I<block> supplies the body of the C<given> construct; they
6126 are consumed by this function and become part of the constructed op tree.
6127 I<defsv_off> is the pad offset of the scalar lexical variable that will
6134 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6137 PERL_ARGS_ASSERT_NEWGIVENOP;
6138 return newGIVWHENOP(
6139 ref_array_or_hash(cond),
6141 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6146 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6148 Constructs, checks, and returns an op tree expressing a C<when> block.
6149 I<cond> supplies the test expression, and I<block> supplies the block
6150 that will be executed if the test evaluates to true; they are consumed
6151 by this function and become part of the constructed op tree. I<cond>
6152 will be interpreted DWIMically, often as a comparison against C<$_>,
6153 and may be null to generate a C<default> block.
6159 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6161 const bool cond_llb = (!cond || looks_like_bool(cond));
6164 PERL_ARGS_ASSERT_NEWWHENOP;
6169 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6171 scalar(ref_array_or_hash(cond)));
6174 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6178 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
6181 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
6183 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
6184 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
6185 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
6186 || (p && (len != SvCUR(cv) /* Not the same length. */
6187 || memNE(p, SvPVX_const(cv), len))))
6188 && ckWARN_d(WARN_PROTOTYPE)) {
6189 SV* const msg = sv_newmortal();
6193 gv_efullname3(name = sv_newmortal(), gv, NULL);
6194 sv_setpvs(msg, "Prototype mismatch:");
6196 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6198 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
6200 sv_catpvs(msg, ": none");
6201 sv_catpvs(msg, " vs ");
6203 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
6205 sv_catpvs(msg, "none");
6206 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6210 static void const_sv_xsub(pTHX_ CV* cv);
6214 =head1 Optree Manipulation Functions
6216 =for apidoc cv_const_sv
6218 If C<cv> is a constant sub eligible for inlining. returns the constant
6219 value returned by the sub. Otherwise, returns NULL.
6221 Constant subs can be created with C<newCONSTSUB> or as described in
6222 L<perlsub/"Constant Functions">.
6227 Perl_cv_const_sv(pTHX_ const CV *const cv)
6229 PERL_UNUSED_CONTEXT;
6232 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6234 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6237 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6238 * Can be called in 3 ways:
6241 * look for a single OP_CONST with attached value: return the value
6243 * cv && CvCLONE(cv) && !CvCONST(cv)
6245 * examine the clone prototype, and if contains only a single
6246 * OP_CONST referencing a pad const, or a single PADSV referencing
6247 * an outer lexical, return a non-zero value to indicate the CV is
6248 * a candidate for "constizing" at clone time
6252 * We have just cloned an anon prototype that was marked as a const
6253 * candidate. Try to grab the current value, and in the case of
6254 * PADSV, ignore it if it has multiple references. Return the value.
6258 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6269 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6270 o = cLISTOPo->op_first->op_sibling;
6272 for (; o; o = o->op_next) {
6273 const OPCODE type = o->op_type;
6275 if (sv && o->op_next == o)
6277 if (o->op_next != o) {
6278 if (type == OP_NEXTSTATE
6279 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6280 || type == OP_PUSHMARK)
6282 if (type == OP_DBSTATE)
6285 if (type == OP_LEAVESUB || type == OP_RETURN)
6289 if (type == OP_CONST && cSVOPo->op_sv)
6291 else if (cv && type == OP_CONST) {
6292 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6296 else if (cv && type == OP_PADSV) {
6297 if (CvCONST(cv)) { /* newly cloned anon */
6298 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6299 /* the candidate should have 1 ref from this pad and 1 ref
6300 * from the parent */
6301 if (!sv || SvREFCNT(sv) != 2)
6308 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6309 sv = &PL_sv_undef; /* an arbitrary non-null value */
6324 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6327 /* This would be the return value, but the return cannot be reached. */
6328 OP* pegop = newOP(OP_NULL, 0);
6331 PERL_UNUSED_ARG(floor);
6341 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6343 NORETURN_FUNCTION_END;
6348 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6353 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6354 register CV *cv = NULL;
6356 /* If the subroutine has no body, no attributes, and no builtin attributes
6357 then it's just a sub declaration, and we may be able to get away with
6358 storing with a placeholder scalar in the symbol table, rather than a
6359 full GV and CV. If anything is present then it will take a full CV to
6361 const I32 gv_fetch_flags
6362 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6364 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6365 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6369 assert(proto->op_type == OP_CONST);
6370 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6376 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6378 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6379 SV * const sv = sv_newmortal();
6380 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6381 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6382 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6383 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6385 } else if (PL_curstash) {
6386 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6389 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6393 if (!PL_madskills) {
6402 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6403 maximum a prototype before. */
6404 if (SvTYPE(gv) > SVt_NULL) {
6405 if (!SvPOK((const SV *)gv)
6406 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6408 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6410 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6413 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6415 sv_setiv(MUTABLE_SV(gv), -1);
6417 SvREFCNT_dec(PL_compcv);
6418 cv = PL_compcv = NULL;
6422 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6424 if (!block || !ps || *ps || attrs
6425 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6427 || block->op_type == OP_NULL
6432 const_sv = op_const_sv(block, NULL);
6435 const bool exists = CvROOT(cv) || CvXSUB(cv);
6437 /* if the subroutine doesn't exist and wasn't pre-declared
6438 * with a prototype, assume it will be AUTOLOADed,
6439 * skipping the prototype check
6441 if (exists || SvPOK(cv))
6442 cv_ckproto_len(cv, gv, ps, ps_len);
6443 /* already defined (or promised)? */
6444 if (exists || GvASSUMECV(gv)) {
6447 || block->op_type == OP_NULL
6450 if (CvFLAGS(PL_compcv)) {
6451 /* might have had built-in attrs applied */
6452 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6453 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6454 && ckWARN(WARN_MISC))
6455 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6457 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6458 & ~(CVf_LVALUE * pureperl));
6460 if (attrs) goto attrs;
6461 /* just a "sub foo;" when &foo is already defined */
6462 SAVEFREESV(PL_compcv);
6467 && block->op_type != OP_NULL
6470 if (ckWARN(WARN_REDEFINE)
6472 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6474 const line_t oldline = CopLINE(PL_curcop);
6475 if (PL_parser && PL_parser->copline != NOLINE)
6476 CopLINE_set(PL_curcop, PL_parser->copline);
6477 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6478 CvCONST(cv) ? "Constant subroutine %s redefined"
6479 : "Subroutine %s redefined", name);
6480 CopLINE_set(PL_curcop, oldline);
6483 if (!PL_minus_c) /* keep old one around for madskills */
6486 /* (PL_madskills unset in used file.) */
6494 SvREFCNT_inc_simple_void_NN(const_sv);
6496 assert(!CvROOT(cv) && !CvCONST(cv));
6497 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6498 CvXSUBANY(cv).any_ptr = const_sv;
6499 CvXSUB(cv) = const_sv_xsub;
6505 cv = newCONSTSUB(NULL, name, const_sv);
6507 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6508 (CvGV(cv) && GvSTASH(CvGV(cv)))
6517 SvREFCNT_dec(PL_compcv);
6521 if (cv) { /* must reuse cv if autoloaded */
6522 /* transfer PL_compcv to cv */
6525 && block->op_type != OP_NULL
6528 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6529 AV *const temp_av = CvPADLIST(cv);
6530 CV *const temp_cv = CvOUTSIDE(cv);
6532 assert(!CvWEAKOUTSIDE(cv));
6533 assert(!CvCVGV_RC(cv));
6534 assert(CvGV(cv) == gv);
6537 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6538 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6539 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6540 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6541 CvOUTSIDE(PL_compcv) = temp_cv;
6542 CvPADLIST(PL_compcv) = temp_av;
6545 if (CvFILE(cv) && !CvISXSUB(cv)) {
6546 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
6547 Safefree(CvFILE(cv));
6550 CvFILE_set_from_cop(cv, PL_curcop);
6551 CvSTASH_set(cv, PL_curstash);
6553 /* inner references to PL_compcv must be fixed up ... */
6554 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6555 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6556 ++PL_sub_generation;
6559 /* Might have had built-in attributes applied -- propagate them. */
6560 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6562 /* ... before we throw it away */
6563 SvREFCNT_dec(PL_compcv);
6571 if (strEQ(name, "import")) {
6572 PL_formfeed = MUTABLE_SV(cv);
6573 /* diag_listed_as: SKIPME */
6574 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6578 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6583 CvFILE_set_from_cop(cv, PL_curcop);
6584 CvSTASH_set(cv, PL_curstash);
6588 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6589 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6590 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6594 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6596 if (PL_parser && PL_parser->error_count) {
6600 const char *s = strrchr(name, ':');
6602 if (strEQ(s, "BEGIN")) {
6603 const char not_safe[] =
6604 "BEGIN not safe after errors--compilation aborted";
6605 if (PL_in_eval & EVAL_KEEPERR)
6606 Perl_croak(aTHX_ not_safe);
6608 /* force display of errors found but not reported */
6609 sv_catpv(ERRSV, not_safe);
6610 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6619 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6620 the debugger could be able to set a breakpoint in, so signal to
6621 pp_entereval that it should not throw away any saved lines at scope
6624 PL_breakable_sub_gen++;
6625 /* This makes sub {}; work as expected. */
6626 if (block->op_type == OP_STUB) {
6627 OP* const newblock = newSTATEOP(0, NULL, 0);
6629 op_getmad(block,newblock,'B');
6635 else block->op_attached = 1;
6636 CvROOT(cv) = CvLVALUE(cv)
6637 ? newUNOP(OP_LEAVESUBLV, 0,
6638 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6639 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6640 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6641 OpREFCNT_set(CvROOT(cv), 1);
6642 CvSTART(cv) = LINKLIST(CvROOT(cv));
6643 CvROOT(cv)->op_next = 0;
6644 CALL_PEEP(CvSTART(cv));
6645 finalize_optree(CvROOT(cv));
6647 /* now that optimizer has done its work, adjust pad values */
6649 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6652 assert(!CvCONST(cv));
6653 if (ps && !*ps && op_const_sv(block, cv))
6658 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6659 SV * const tmpstr = sv_newmortal();
6660 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6661 GV_ADDMULTI, SVt_PVHV);
6663 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6666 (long)CopLINE(PL_curcop));
6667 gv_efullname3(tmpstr, gv, NULL);
6668 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6669 SvCUR(tmpstr), sv, 0);
6670 hv = GvHVn(db_postponed);
6671 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6672 CV * const pcv = GvCV(db_postponed);
6678 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6683 if (name && ! (PL_parser && PL_parser->error_count))
6684 process_special_blocks(name, gv, cv);
6689 PL_parser->copline = NOLINE;
6695 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6698 const char *const colon = strrchr(fullname,':');
6699 const char *const name = colon ? colon + 1 : fullname;
6701 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6704 if (strEQ(name, "BEGIN")) {
6705 const I32 oldscope = PL_scopestack_ix;
6707 SAVECOPFILE(&PL_compiling);
6708 SAVECOPLINE(&PL_compiling);
6710 DEBUG_x( dump_sub(gv) );
6711 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6712 GvCV_set(gv,0); /* cv has been hijacked */
6713 call_list(oldscope, PL_beginav);
6715 PL_curcop = &PL_compiling;
6716 CopHINTS_set(&PL_compiling, PL_hints);
6723 if strEQ(name, "END") {
6724 DEBUG_x( dump_sub(gv) );
6725 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6728 } else if (*name == 'U') {
6729 if (strEQ(name, "UNITCHECK")) {
6730 /* It's never too late to run a unitcheck block */
6731 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6735 } else if (*name == 'C') {
6736 if (strEQ(name, "CHECK")) {
6738 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6739 "Too late to run CHECK block");
6740 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6744 } else if (*name == 'I') {
6745 if (strEQ(name, "INIT")) {
6747 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6748 "Too late to run INIT block");
6749 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6755 DEBUG_x( dump_sub(gv) );
6756 GvCV_set(gv,0); /* cv has been hijacked */
6761 =for apidoc newCONSTSUB
6763 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6764 eligible for inlining at compile-time.
6766 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6767 which won't be called if used as a destructor, but will suppress the overhead
6768 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6775 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6780 const char *const file = CopFILE(PL_curcop);
6782 SV *const temp_sv = CopFILESV(PL_curcop);
6783 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6788 if (IN_PERL_RUNTIME) {
6789 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6790 * an op shared between threads. Use a non-shared COP for our
6792 SAVEVPTR(PL_curcop);
6793 PL_curcop = &PL_compiling;
6795 SAVECOPLINE(PL_curcop);
6796 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6799 PL_hints &= ~HINT_BLOCK_SCOPE;
6802 SAVESPTR(PL_curstash);
6803 SAVECOPSTASH(PL_curcop);
6804 PL_curstash = stash;
6805 CopSTASH_set(PL_curcop,stash);
6808 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6809 and so doesn't get free()d. (It's expected to be from the C pre-
6810 processor __FILE__ directive). But we need a dynamically allocated one,
6811 and we need it to get freed. */
6812 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6813 XS_DYNAMIC_FILENAME);
6814 CvXSUBANY(cv).any_ptr = sv;
6819 CopSTASH_free(PL_curcop);
6827 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6828 const char *const filename, const char *const proto,
6831 CV *cv = newXS(name, subaddr, filename);
6833 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6835 if (flags & XS_DYNAMIC_FILENAME) {
6836 /* We need to "make arrangements" (ie cheat) to ensure that the
6837 filename lasts as long as the PVCV we just created, but also doesn't
6839 STRLEN filename_len = strlen(filename);
6840 STRLEN proto_and_file_len = filename_len;
6841 char *proto_and_file;
6845 proto_len = strlen(proto);
6846 proto_and_file_len += proto_len;
6848 Newx(proto_and_file, proto_and_file_len + 1, char);
6849 Copy(proto, proto_and_file, proto_len, char);
6850 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6853 proto_and_file = savepvn(filename, filename_len);
6856 /* This gets free()d. :-) */
6857 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6858 SV_HAS_TRAILING_NUL);
6860 /* This gives us the correct prototype, rather than one with the
6861 file name appended. */
6862 SvCUR_set(cv, proto_len);
6866 CvFILE(cv) = proto_and_file + proto_len;
6868 sv_setpv(MUTABLE_SV(cv), proto);
6874 =for apidoc U||newXS
6876 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6877 static storage, as it is used directly as CvFILE(), without a copy being made.
6883 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6886 GV * const gv = gv_fetchpv(name ? name :
6887 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6888 GV_ADDMULTI, SVt_PVCV);
6891 PERL_ARGS_ASSERT_NEWXS;
6894 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6896 if ((cv = (name ? GvCV(gv) : NULL))) {
6898 /* just a cached method */
6902 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6903 /* already defined (or promised) */
6904 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6905 if (ckWARN(WARN_REDEFINE)) {
6906 GV * const gvcv = CvGV(cv);
6908 HV * const stash = GvSTASH(gvcv);
6910 const char *redefined_name = HvNAME_get(stash);
6911 if ( strEQ(redefined_name,"autouse") ) {
6912 const line_t oldline = CopLINE(PL_curcop);
6913 if (PL_parser && PL_parser->copline != NOLINE)
6914 CopLINE_set(PL_curcop, PL_parser->copline);
6915 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6916 CvCONST(cv) ? "Constant subroutine %s redefined"
6917 : "Subroutine %s redefined"
6919 CopLINE_set(PL_curcop, oldline);
6929 if (cv) /* must reuse cv if autoloaded */
6932 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6936 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6942 (void)gv_fetchfile(filename);
6943 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6944 an external constant string */
6946 CvXSUB(cv) = subaddr;
6949 process_special_blocks(name, gv, cv);
6959 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6964 OP* pegop = newOP(OP_NULL, 0);
6968 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6969 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6972 if ((cv = GvFORM(gv))) {
6973 if (ckWARN(WARN_REDEFINE)) {
6974 const line_t oldline = CopLINE(PL_curcop);
6975 if (PL_parser && PL_parser->copline != NOLINE)
6976 CopLINE_set(PL_curcop, PL_parser->copline);
6978 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6979 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6981 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6982 "Format STDOUT redefined");
6984 CopLINE_set(PL_curcop, oldline);
6991 CvFILE_set_from_cop(cv, PL_curcop);
6994 pad_tidy(padtidy_FORMAT);
6995 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6996 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6997 OpREFCNT_set(CvROOT(cv), 1);
6998 CvSTART(cv) = LINKLIST(CvROOT(cv));
6999 CvROOT(cv)->op_next = 0;
7000 CALL_PEEP(CvSTART(cv));
7001 finalize_optree(CvROOT(cv));
7003 op_getmad(o,pegop,'n');
7004 op_getmad_weak(block, pegop, 'b');
7009 PL_parser->copline = NOLINE;
7017 Perl_newANONLIST(pTHX_ OP *o)
7019 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7023 Perl_newANONHASH(pTHX_ OP *o)
7025 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7029 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7031 return newANONATTRSUB(floor, proto, NULL, block);
7035 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7037 return newUNOP(OP_REFGEN, 0,
7038 newSVOP(OP_ANONCODE, 0,
7039 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7043 Perl_oopsAV(pTHX_ OP *o)
7047 PERL_ARGS_ASSERT_OOPSAV;
7049 switch (o->op_type) {
7051 o->op_type = OP_PADAV;
7052 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7053 return ref(o, OP_RV2AV);
7056 o->op_type = OP_RV2AV;
7057 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7062 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7069 Perl_oopsHV(pTHX_ OP *o)
7073 PERL_ARGS_ASSERT_OOPSHV;
7075 switch (o->op_type) {
7078 o->op_type = OP_PADHV;
7079 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7080 return ref(o, OP_RV2HV);
7084 o->op_type = OP_RV2HV;
7085 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7090 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7097 Perl_newAVREF(pTHX_ OP *o)
7101 PERL_ARGS_ASSERT_NEWAVREF;
7103 if (o->op_type == OP_PADANY) {
7104 o->op_type = OP_PADAV;
7105 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7108 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7109 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7110 "Using an array as a reference is deprecated");
7112 return newUNOP(OP_RV2AV, 0, scalar(o));
7116 Perl_newGVREF(pTHX_ I32 type, OP *o)
7118 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7119 return newUNOP(OP_NULL, 0, o);
7120 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7124 Perl_newHVREF(pTHX_ OP *o)
7128 PERL_ARGS_ASSERT_NEWHVREF;
7130 if (o->op_type == OP_PADANY) {
7131 o->op_type = OP_PADHV;
7132 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7135 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7136 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7137 "Using a hash as a reference is deprecated");
7139 return newUNOP(OP_RV2HV, 0, scalar(o));
7143 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7145 return newUNOP(OP_RV2CV, flags, scalar(o));
7149 Perl_newSVREF(pTHX_ OP *o)
7153 PERL_ARGS_ASSERT_NEWSVREF;
7155 if (o->op_type == OP_PADANY) {
7156 o->op_type = OP_PADSV;
7157 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7160 return newUNOP(OP_RV2SV, 0, scalar(o));
7163 /* Check routines. See the comments at the top of this file for details
7164 * on when these are called */
7167 Perl_ck_anoncode(pTHX_ OP *o)
7169 PERL_ARGS_ASSERT_CK_ANONCODE;
7171 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7173 cSVOPo->op_sv = NULL;
7178 Perl_ck_bitop(pTHX_ OP *o)
7182 PERL_ARGS_ASSERT_CK_BITOP;
7184 #define OP_IS_NUMCOMPARE(op) \
7185 ((op) == OP_LT || (op) == OP_I_LT || \
7186 (op) == OP_GT || (op) == OP_I_GT || \
7187 (op) == OP_LE || (op) == OP_I_LE || \
7188 (op) == OP_GE || (op) == OP_I_GE || \
7189 (op) == OP_EQ || (op) == OP_I_EQ || \
7190 (op) == OP_NE || (op) == OP_I_NE || \
7191 (op) == OP_NCMP || (op) == OP_I_NCMP)
7192 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7193 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7194 && (o->op_type == OP_BIT_OR
7195 || o->op_type == OP_BIT_AND
7196 || o->op_type == OP_BIT_XOR))
7198 const OP * const left = cBINOPo->op_first;
7199 const OP * const right = left->op_sibling;
7200 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7201 (left->op_flags & OPf_PARENS) == 0) ||
7202 (OP_IS_NUMCOMPARE(right->op_type) &&
7203 (right->op_flags & OPf_PARENS) == 0))
7204 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7205 "Possible precedence problem on bitwise %c operator",
7206 o->op_type == OP_BIT_OR ? '|'
7207 : o->op_type == OP_BIT_AND ? '&' : '^'
7214 Perl_ck_concat(pTHX_ OP *o)
7216 const OP * const kid = cUNOPo->op_first;
7218 PERL_ARGS_ASSERT_CK_CONCAT;
7219 PERL_UNUSED_CONTEXT;
7221 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7222 !(kUNOP->op_first->op_flags & OPf_MOD))
7223 o->op_flags |= OPf_STACKED;
7228 Perl_ck_spair(pTHX_ OP *o)
7232 PERL_ARGS_ASSERT_CK_SPAIR;
7234 if (o->op_flags & OPf_KIDS) {
7237 const OPCODE type = o->op_type;
7238 o = modkids(ck_fun(o), type);
7239 kid = cUNOPo->op_first;
7240 newop = kUNOP->op_first->op_sibling;
7242 const OPCODE type = newop->op_type;
7243 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7244 type == OP_PADAV || type == OP_PADHV ||
7245 type == OP_RV2AV || type == OP_RV2HV)
7249 op_getmad(kUNOP->op_first,newop,'K');
7251 op_free(kUNOP->op_first);
7253 kUNOP->op_first = newop;
7255 o->op_ppaddr = PL_ppaddr[++o->op_type];
7260 Perl_ck_delete(pTHX_ OP *o)
7262 PERL_ARGS_ASSERT_CK_DELETE;
7266 if (o->op_flags & OPf_KIDS) {
7267 OP * const kid = cUNOPo->op_first;
7268 switch (kid->op_type) {
7270 o->op_flags |= OPf_SPECIAL;
7273 o->op_private |= OPpSLICE;
7276 o->op_flags |= OPf_SPECIAL;
7281 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7284 if (kid->op_private & OPpLVAL_INTRO)
7285 o->op_private |= OPpLVAL_INTRO;
7292 Perl_ck_die(pTHX_ OP *o)
7294 PERL_ARGS_ASSERT_CK_DIE;
7297 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7303 Perl_ck_eof(pTHX_ OP *o)
7307 PERL_ARGS_ASSERT_CK_EOF;
7309 if (o->op_flags & OPf_KIDS) {
7310 if (cLISTOPo->op_first->op_type == OP_STUB) {
7312 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7314 op_getmad(o,newop,'O');
7326 Perl_ck_eval(pTHX_ OP *o)
7330 PERL_ARGS_ASSERT_CK_EVAL;
7332 PL_hints |= HINT_BLOCK_SCOPE;
7333 if (o->op_flags & OPf_KIDS) {
7334 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7337 o->op_flags &= ~OPf_KIDS;
7340 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7346 cUNOPo->op_first = 0;
7351 NewOp(1101, enter, 1, LOGOP);
7352 enter->op_type = OP_ENTERTRY;
7353 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7354 enter->op_private = 0;
7356 /* establish postfix order */
7357 enter->op_next = (OP*)enter;
7359 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7360 o->op_type = OP_LEAVETRY;
7361 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7362 enter->op_other = o;
7363 op_getmad(oldo,o,'O');
7377 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7378 op_getmad(oldo,o,'O');
7380 o->op_targ = (PADOFFSET)PL_hints;
7381 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7382 /* Store a copy of %^H that pp_entereval can pick up. */
7383 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7384 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7385 cUNOPo->op_first->op_sibling = hhop;
7386 o->op_private |= OPpEVAL_HAS_HH;
7392 Perl_ck_exit(pTHX_ OP *o)
7394 PERL_ARGS_ASSERT_CK_EXIT;
7397 HV * const table = GvHV(PL_hintgv);
7399 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7400 if (svp && *svp && SvTRUE(*svp))
7401 o->op_private |= OPpEXIT_VMSISH;
7403 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7409 Perl_ck_exec(pTHX_ OP *o)
7411 PERL_ARGS_ASSERT_CK_EXEC;
7413 if (o->op_flags & OPf_STACKED) {
7416 kid = cUNOPo->op_first->op_sibling;
7417 if (kid->op_type == OP_RV2GV)
7426 Perl_ck_exists(pTHX_ OP *o)
7430 PERL_ARGS_ASSERT_CK_EXISTS;
7433 if (o->op_flags & OPf_KIDS) {
7434 OP * const kid = cUNOPo->op_first;
7435 if (kid->op_type == OP_ENTERSUB) {
7436 (void) ref(kid, o->op_type);
7437 if (kid->op_type != OP_RV2CV
7438 && !(PL_parser && PL_parser->error_count))
7439 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7441 o->op_private |= OPpEXISTS_SUB;
7443 else if (kid->op_type == OP_AELEM)
7444 o->op_flags |= OPf_SPECIAL;
7445 else if (kid->op_type != OP_HELEM)
7446 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7454 Perl_ck_rvconst(pTHX_ register OP *o)
7457 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7459 PERL_ARGS_ASSERT_CK_RVCONST;
7461 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7462 if (o->op_type == OP_RV2CV)
7463 o->op_private &= ~1;
7465 if (kid->op_type == OP_CONST) {
7468 SV * const kidsv = kid->op_sv;
7470 /* Is it a constant from cv_const_sv()? */
7471 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7472 SV * const rsv = SvRV(kidsv);
7473 const svtype type = SvTYPE(rsv);
7474 const char *badtype = NULL;
7476 switch (o->op_type) {
7478 if (type > SVt_PVMG)
7479 badtype = "a SCALAR";
7482 if (type != SVt_PVAV)
7483 badtype = "an ARRAY";
7486 if (type != SVt_PVHV)
7490 if (type != SVt_PVCV)
7495 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7498 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7499 const char *badthing;
7500 switch (o->op_type) {
7502 badthing = "a SCALAR";
7505 badthing = "an ARRAY";
7508 badthing = "a HASH";
7516 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7517 SVfARG(kidsv), badthing);
7520 * This is a little tricky. We only want to add the symbol if we
7521 * didn't add it in the lexer. Otherwise we get duplicate strict
7522 * warnings. But if we didn't add it in the lexer, we must at
7523 * least pretend like we wanted to add it even if it existed before,
7524 * or we get possible typo warnings. OPpCONST_ENTERED says
7525 * whether the lexer already added THIS instance of this symbol.
7527 iscv = (o->op_type == OP_RV2CV) * 2;
7529 gv = gv_fetchsv(kidsv,
7530 iscv | !(kid->op_private & OPpCONST_ENTERED),
7533 : o->op_type == OP_RV2SV
7535 : o->op_type == OP_RV2AV
7537 : o->op_type == OP_RV2HV
7540 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7542 kid->op_type = OP_GV;
7543 SvREFCNT_dec(kid->op_sv);
7545 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7546 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7547 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7549 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7551 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7553 kid->op_private = 0;
7554 kid->op_ppaddr = PL_ppaddr[OP_GV];
7555 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7563 Perl_ck_ftst(pTHX_ OP *o)
7566 const I32 type = o->op_type;
7568 PERL_ARGS_ASSERT_CK_FTST;
7570 if (o->op_flags & OPf_REF) {
7573 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7574 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7575 const OPCODE kidtype = kid->op_type;
7577 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7578 OP * const newop = newGVOP(type, OPf_REF,
7579 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7581 op_getmad(o,newop,'O');
7587 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7588 o->op_private |= OPpFT_ACCESS;
7589 if (PL_check[kidtype] == Perl_ck_ftst
7590 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7591 o->op_private |= OPpFT_STACKED;
7592 kid->op_private |= OPpFT_STACKING;
7601 if (type == OP_FTTTY)
7602 o = newGVOP(type, OPf_REF, PL_stdingv);
7604 o = newUNOP(type, 0, newDEFSVOP());
7605 op_getmad(oldo,o,'O');
7611 Perl_ck_fun(pTHX_ OP *o)
7614 const int type = o->op_type;
7615 register I32 oa = PL_opargs[type] >> OASHIFT;
7617 PERL_ARGS_ASSERT_CK_FUN;
7619 if (o->op_flags & OPf_STACKED) {
7620 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7623 return no_fh_allowed(o);
7626 if (o->op_flags & OPf_KIDS) {
7627 OP **tokid = &cLISTOPo->op_first;
7628 register OP *kid = cLISTOPo->op_first;
7632 if (kid->op_type == OP_PUSHMARK ||
7633 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7635 tokid = &kid->op_sibling;
7636 kid = kid->op_sibling;
7638 if (!kid && PL_opargs[type] & OA_DEFGV)
7639 *tokid = kid = newDEFSVOP();
7643 sibl = kid->op_sibling;
7645 if (!sibl && kid->op_type == OP_STUB) {
7652 /* list seen where single (scalar) arg expected? */
7653 if (numargs == 1 && !(oa >> 4)
7654 && kid->op_type == OP_LIST && type != OP_SCALAR)
7656 return too_many_arguments(o,PL_op_desc[type]);
7669 if ((type == OP_PUSH || type == OP_UNSHIFT)
7670 && !kid->op_sibling)
7671 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7672 "Useless use of %s with no values",
7675 if (kid->op_type == OP_CONST &&
7676 (kid->op_private & OPpCONST_BARE))
7678 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7679 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7680 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7681 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7682 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7684 op_getmad(kid,newop,'K');
7689 kid->op_sibling = sibl;
7692 else if (kid->op_type == OP_CONST
7693 && ( !SvROK(cSVOPx_sv(kid))
7694 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7696 bad_type(numargs, "array", PL_op_desc[type], kid);
7697 /* Defer checks to run-time if we have a scalar arg */
7698 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7699 op_lvalue(kid, type);
7703 if (kid->op_type == OP_CONST &&
7704 (kid->op_private & OPpCONST_BARE))
7706 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7707 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7708 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7709 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7710 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7712 op_getmad(kid,newop,'K');
7717 kid->op_sibling = sibl;
7720 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7721 bad_type(numargs, "hash", PL_op_desc[type], kid);
7722 op_lvalue(kid, type);
7726 OP * const newop = newUNOP(OP_NULL, 0, kid);
7727 kid->op_sibling = 0;
7729 newop->op_next = newop;
7731 kid->op_sibling = sibl;
7736 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7737 if (kid->op_type == OP_CONST &&
7738 (kid->op_private & OPpCONST_BARE))
7740 OP * const newop = newGVOP(OP_GV, 0,
7741 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7742 if (!(o->op_private & 1) && /* if not unop */
7743 kid == cLISTOPo->op_last)
7744 cLISTOPo->op_last = newop;
7746 op_getmad(kid,newop,'K');
7752 else if (kid->op_type == OP_READLINE) {
7753 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7754 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7757 I32 flags = OPf_SPECIAL;
7761 /* is this op a FH constructor? */
7762 if (is_handle_constructor(o,numargs)) {
7763 const char *name = NULL;
7767 /* Set a flag to tell rv2gv to vivify
7768 * need to "prove" flag does not mean something
7769 * else already - NI-S 1999/05/07
7772 if (kid->op_type == OP_PADSV) {
7774 = PAD_COMPNAME_SV(kid->op_targ);
7775 name = SvPV_const(namesv, len);
7777 else if (kid->op_type == OP_RV2SV
7778 && kUNOP->op_first->op_type == OP_GV)
7780 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7782 len = GvNAMELEN(gv);
7784 else if (kid->op_type == OP_AELEM
7785 || kid->op_type == OP_HELEM)
7788 OP *op = ((BINOP*)kid)->op_first;
7792 const char * const a =
7793 kid->op_type == OP_AELEM ?
7795 if (((op->op_type == OP_RV2AV) ||
7796 (op->op_type == OP_RV2HV)) &&
7797 (firstop = ((UNOP*)op)->op_first) &&
7798 (firstop->op_type == OP_GV)) {
7799 /* packagevar $a[] or $h{} */
7800 GV * const gv = cGVOPx_gv(firstop);
7808 else if (op->op_type == OP_PADAV
7809 || op->op_type == OP_PADHV) {
7810 /* lexicalvar $a[] or $h{} */
7811 const char * const padname =
7812 PAD_COMPNAME_PV(op->op_targ);
7821 name = SvPV_const(tmpstr, len);
7826 name = "__ANONIO__";
7829 op_lvalue(kid, type);
7833 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7834 namesv = PAD_SVl(targ);
7835 SvUPGRADE(namesv, SVt_PV);
7837 sv_setpvs(namesv, "$");
7838 sv_catpvn(namesv, name, len);
7841 kid->op_sibling = 0;
7842 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7843 kid->op_targ = targ;
7844 kid->op_private |= priv;
7846 kid->op_sibling = sibl;
7852 op_lvalue(scalar(kid), type);
7856 tokid = &kid->op_sibling;
7857 kid = kid->op_sibling;
7860 if (kid && kid->op_type != OP_STUB)
7861 return too_many_arguments(o,OP_DESC(o));
7862 o->op_private |= numargs;
7864 /* FIXME - should the numargs move as for the PERL_MAD case? */
7865 o->op_private |= numargs;
7867 return too_many_arguments(o,OP_DESC(o));
7871 else if (PL_opargs[type] & OA_DEFGV) {
7873 OP *newop = newUNOP(type, 0, newDEFSVOP());
7874 op_getmad(o,newop,'O');
7877 /* Ordering of these two is important to keep f_map.t passing. */
7879 return newUNOP(type, 0, newDEFSVOP());
7884 while (oa & OA_OPTIONAL)
7886 if (oa && oa != OA_LIST)
7887 return too_few_arguments(o,OP_DESC(o));
7893 Perl_ck_glob(pTHX_ OP *o)
7898 PERL_ARGS_ASSERT_CK_GLOB;
7901 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7902 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
7904 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7905 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7907 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7910 #if !defined(PERL_EXTERNAL_GLOB)
7911 /* XXX this can be tightened up and made more failsafe. */
7912 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7915 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7916 newSVpvs("File::Glob"), NULL, NULL, NULL);
7917 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7918 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7919 GvCV_set(gv, GvCV(glob_gv));
7920 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7921 GvIMPORTED_CV_on(gv);
7925 #endif /* PERL_EXTERNAL_GLOB */
7927 assert(!(o->op_flags & OPf_SPECIAL));
7928 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7931 * \ null - const(wildcard)
7936 * \ mark - glob - rv2cv
7937 * | \ gv(CORE::GLOBAL::glob)
7939 * \ null - const(wildcard) - const(ix)
7941 o->op_flags |= OPf_SPECIAL;
7942 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
7943 op_append_elem(OP_GLOB, o,
7944 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7945 o = newLISTOP(OP_LIST, 0, o, NULL);
7946 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7947 op_append_elem(OP_LIST, o,
7948 scalar(newUNOP(OP_RV2CV, 0,
7949 newGVOP(OP_GV, 0, gv)))));
7950 o = newUNOP(OP_NULL, 0, ck_subr(o));
7951 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
7954 gv = newGVgen("main");
7956 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7962 Perl_ck_grep(pTHX_ OP *o)
7967 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7970 PERL_ARGS_ASSERT_CK_GREP;
7972 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7973 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7975 if (o->op_flags & OPf_STACKED) {
7978 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7979 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7980 return no_fh_allowed(o);
7981 for (k = kid; k; k = k->op_next) {
7984 NewOp(1101, gwop, 1, LOGOP);
7985 kid->op_next = (OP*)gwop;
7986 o->op_flags &= ~OPf_STACKED;
7988 kid = cLISTOPo->op_first->op_sibling;
7989 if (type == OP_MAPWHILE)
7994 if (PL_parser && PL_parser->error_count)
7996 kid = cLISTOPo->op_first->op_sibling;
7997 if (kid->op_type != OP_NULL)
7998 Perl_croak(aTHX_ "panic: ck_grep");
7999 kid = kUNOP->op_first;
8002 NewOp(1101, gwop, 1, LOGOP);
8003 gwop->op_type = type;
8004 gwop->op_ppaddr = PL_ppaddr[type];
8005 gwop->op_first = listkids(o);
8006 gwop->op_flags |= OPf_KIDS;
8007 gwop->op_other = LINKLIST(kid);
8008 kid->op_next = (OP*)gwop;
8009 offset = pad_findmy_pvs("$_", 0);
8010 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8011 o->op_private = gwop->op_private = 0;
8012 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8015 o->op_private = gwop->op_private = OPpGREP_LEX;
8016 gwop->op_targ = o->op_targ = offset;
8019 kid = cLISTOPo->op_first->op_sibling;
8020 if (!kid || !kid->op_sibling)
8021 return too_few_arguments(o,OP_DESC(o));
8022 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8023 op_lvalue(kid, OP_GREPSTART);
8029 Perl_ck_index(pTHX_ OP *o)
8031 PERL_ARGS_ASSERT_CK_INDEX;
8033 if (o->op_flags & OPf_KIDS) {
8034 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8036 kid = kid->op_sibling; /* get past "big" */
8037 if (kid && kid->op_type == OP_CONST) {
8038 const bool save_taint = PL_tainted;
8039 fbm_compile(((SVOP*)kid)->op_sv, 0);
8040 PL_tainted = save_taint;
8047 Perl_ck_lfun(pTHX_ OP *o)
8049 const OPCODE type = o->op_type;
8051 PERL_ARGS_ASSERT_CK_LFUN;
8053 return modkids(ck_fun(o), type);
8057 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8059 PERL_ARGS_ASSERT_CK_DEFINED;
8061 if ((o->op_flags & OPf_KIDS)) {
8062 switch (cUNOPo->op_first->op_type) {
8064 /* This is needed for
8065 if (defined %stash::)
8066 to work. Do not break Tk.
8068 break; /* Globals via GV can be undef */
8070 case OP_AASSIGN: /* Is this a good idea? */
8071 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8072 "defined(@array) is deprecated");
8073 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8074 "\t(Maybe you should just omit the defined()?)\n");
8078 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8079 "defined(%%hash) is deprecated");
8080 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8081 "\t(Maybe you should just omit the defined()?)\n");
8092 Perl_ck_readline(pTHX_ OP *o)
8094 PERL_ARGS_ASSERT_CK_READLINE;
8096 if (!(o->op_flags & OPf_KIDS)) {
8098 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8100 op_getmad(o,newop,'O');
8110 Perl_ck_rfun(pTHX_ OP *o)
8112 const OPCODE type = o->op_type;
8114 PERL_ARGS_ASSERT_CK_RFUN;
8116 return refkids(ck_fun(o), type);
8120 Perl_ck_listiob(pTHX_ OP *o)
8124 PERL_ARGS_ASSERT_CK_LISTIOB;
8126 kid = cLISTOPo->op_first;
8129 kid = cLISTOPo->op_first;
8131 if (kid->op_type == OP_PUSHMARK)
8132 kid = kid->op_sibling;
8133 if (kid && o->op_flags & OPf_STACKED)
8134 kid = kid->op_sibling;
8135 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8136 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8137 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8138 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8139 cLISTOPo->op_first->op_sibling = kid;
8140 cLISTOPo->op_last = kid;
8141 kid = kid->op_sibling;
8146 op_append_elem(o->op_type, o, newDEFSVOP());
8152 Perl_ck_smartmatch(pTHX_ OP *o)
8155 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8156 if (0 == (o->op_flags & OPf_SPECIAL)) {
8157 OP *first = cBINOPo->op_first;
8158 OP *second = first->op_sibling;
8160 /* Implicitly take a reference to an array or hash */
8161 first->op_sibling = NULL;
8162 first = cBINOPo->op_first = ref_array_or_hash(first);
8163 second = first->op_sibling = ref_array_or_hash(second);
8165 /* Implicitly take a reference to a regular expression */
8166 if (first->op_type == OP_MATCH) {
8167 first->op_type = OP_QR;
8168 first->op_ppaddr = PL_ppaddr[OP_QR];
8170 if (second->op_type == OP_MATCH) {
8171 second->op_type = OP_QR;
8172 second->op_ppaddr = PL_ppaddr[OP_QR];
8181 Perl_ck_sassign(pTHX_ OP *o)
8184 OP * const kid = cLISTOPo->op_first;
8186 PERL_ARGS_ASSERT_CK_SASSIGN;
8188 /* has a disposable target? */
8189 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8190 && !(kid->op_flags & OPf_STACKED)
8191 /* Cannot steal the second time! */
8192 && !(kid->op_private & OPpTARGET_MY)
8193 /* Keep the full thing for madskills */
8197 OP * const kkid = kid->op_sibling;
8199 /* Can just relocate the target. */
8200 if (kkid && kkid->op_type == OP_PADSV
8201 && !(kkid->op_private & OPpLVAL_INTRO))
8203 kid->op_targ = kkid->op_targ;
8205 /* Now we do not need PADSV and SASSIGN. */
8206 kid->op_sibling = o->op_sibling; /* NULL */
8207 cLISTOPo->op_first = NULL;
8210 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8214 if (kid->op_sibling) {
8215 OP *kkid = kid->op_sibling;
8216 /* For state variable assignment, kkid is a list op whose op_last
8218 if ((kkid->op_type == OP_PADSV ||
8219 (kkid->op_type == OP_LIST &&
8220 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8223 && (kkid->op_private & OPpLVAL_INTRO)
8224 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8225 const PADOFFSET target = kkid->op_targ;
8226 OP *const other = newOP(OP_PADSV,
8228 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8229 OP *const first = newOP(OP_NULL, 0);
8230 OP *const nullop = newCONDOP(0, first, o, other);
8231 OP *const condop = first->op_next;
8232 /* hijacking PADSTALE for uninitialized state variables */
8233 SvPADSTALE_on(PAD_SVl(target));
8235 condop->op_type = OP_ONCE;
8236 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8237 condop->op_targ = target;
8238 other->op_targ = target;
8240 /* Because we change the type of the op here, we will skip the
8241 assignment binop->op_last = binop->op_first->op_sibling; at the
8242 end of Perl_newBINOP(). So need to do it here. */
8243 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8252 Perl_ck_match(pTHX_ OP *o)
8256 PERL_ARGS_ASSERT_CK_MATCH;
8258 if (o->op_type != OP_QR && PL_compcv) {
8259 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8260 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8261 o->op_targ = offset;
8262 o->op_private |= OPpTARGET_MY;
8265 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8266 o->op_private |= OPpRUNTIME;
8271 Perl_ck_method(pTHX_ OP *o)
8273 OP * const kid = cUNOPo->op_first;
8275 PERL_ARGS_ASSERT_CK_METHOD;
8277 if (kid->op_type == OP_CONST) {
8278 SV* sv = kSVOP->op_sv;
8279 const char * const method = SvPVX_const(sv);
8280 if (!(strchr(method, ':') || strchr(method, '\''))) {
8282 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8283 sv = newSVpvn_share(method, SvCUR(sv), 0);
8286 kSVOP->op_sv = NULL;
8288 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8290 op_getmad(o,cmop,'O');
8301 Perl_ck_null(pTHX_ OP *o)
8303 PERL_ARGS_ASSERT_CK_NULL;
8304 PERL_UNUSED_CONTEXT;
8309 Perl_ck_open(pTHX_ OP *o)
8312 HV * const table = GvHV(PL_hintgv);
8314 PERL_ARGS_ASSERT_CK_OPEN;
8317 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8320 const char *d = SvPV_const(*svp, len);
8321 const I32 mode = mode_from_discipline(d, len);
8322 if (mode & O_BINARY)
8323 o->op_private |= OPpOPEN_IN_RAW;
8324 else if (mode & O_TEXT)
8325 o->op_private |= OPpOPEN_IN_CRLF;
8328 svp = hv_fetchs(table, "open_OUT", FALSE);
8331 const char *d = SvPV_const(*svp, len);
8332 const I32 mode = mode_from_discipline(d, len);
8333 if (mode & O_BINARY)
8334 o->op_private |= OPpOPEN_OUT_RAW;
8335 else if (mode & O_TEXT)
8336 o->op_private |= OPpOPEN_OUT_CRLF;
8339 if (o->op_type == OP_BACKTICK) {
8340 if (!(o->op_flags & OPf_KIDS)) {
8341 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8343 op_getmad(o,newop,'O');
8352 /* In case of three-arg dup open remove strictness
8353 * from the last arg if it is a bareword. */
8354 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8355 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8359 if ((last->op_type == OP_CONST) && /* The bareword. */
8360 (last->op_private & OPpCONST_BARE) &&
8361 (last->op_private & OPpCONST_STRICT) &&
8362 (oa = first->op_sibling) && /* The fh. */
8363 (oa = oa->op_sibling) && /* The mode. */
8364 (oa->op_type == OP_CONST) &&
8365 SvPOK(((SVOP*)oa)->op_sv) &&
8366 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8367 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8368 (last == oa->op_sibling)) /* The bareword. */
8369 last->op_private &= ~OPpCONST_STRICT;
8375 Perl_ck_repeat(pTHX_ OP *o)
8377 PERL_ARGS_ASSERT_CK_REPEAT;
8379 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8380 o->op_private |= OPpREPEAT_DOLIST;
8381 cBINOPo->op_first = force_list(cBINOPo->op_first);
8389 Perl_ck_require(pTHX_ OP *o)
8394 PERL_ARGS_ASSERT_CK_REQUIRE;
8396 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8397 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8399 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8400 SV * const sv = kid->op_sv;
8401 U32 was_readonly = SvREADONLY(sv);
8408 sv_force_normal_flags(sv, 0);
8409 assert(!SvREADONLY(sv));
8419 for (; s < end; s++) {
8420 if (*s == ':' && s[1] == ':') {
8422 Move(s+2, s+1, end - s - 1, char);
8427 sv_catpvs(sv, ".pm");
8428 SvFLAGS(sv) |= was_readonly;
8432 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8433 /* handle override, if any */
8434 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8435 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8436 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8437 gv = gvp ? *gvp : NULL;
8441 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8442 OP * const kid = cUNOPo->op_first;
8445 cUNOPo->op_first = 0;
8449 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8450 op_append_elem(OP_LIST, kid,
8451 scalar(newUNOP(OP_RV2CV, 0,
8454 op_getmad(o,newop,'O');
8458 return scalar(ck_fun(o));
8462 Perl_ck_return(pTHX_ OP *o)
8467 PERL_ARGS_ASSERT_CK_RETURN;
8469 kid = cLISTOPo->op_first->op_sibling;
8470 if (CvLVALUE(PL_compcv)) {
8471 for (; kid; kid = kid->op_sibling)
8472 op_lvalue(kid, OP_LEAVESUBLV);
8479 Perl_ck_select(pTHX_ OP *o)
8484 PERL_ARGS_ASSERT_CK_SELECT;
8486 if (o->op_flags & OPf_KIDS) {
8487 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8488 if (kid && kid->op_sibling) {
8489 o->op_type = OP_SSELECT;
8490 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8492 return fold_constants(o);
8496 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8497 if (kid && kid->op_type == OP_RV2GV)
8498 kid->op_private &= ~HINT_STRICT_REFS;
8503 Perl_ck_shift(pTHX_ OP *o)
8506 const I32 type = o->op_type;
8508 PERL_ARGS_ASSERT_CK_SHIFT;
8510 if (!(o->op_flags & OPf_KIDS)) {
8513 if (!CvUNIQUE(PL_compcv)) {
8514 o->op_flags |= OPf_SPECIAL;
8518 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8521 OP * const oldo = o;
8522 o = newUNOP(type, 0, scalar(argop));
8523 op_getmad(oldo,o,'O');
8528 return newUNOP(type, 0, scalar(argop));
8531 return scalar(ck_fun(o));
8535 Perl_ck_sort(pTHX_ OP *o)
8540 PERL_ARGS_ASSERT_CK_SORT;
8542 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8543 HV * const hinthv = GvHV(PL_hintgv);
8545 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8547 const I32 sorthints = (I32)SvIV(*svp);
8548 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8549 o->op_private |= OPpSORT_QSORT;
8550 if ((sorthints & HINT_SORT_STABLE) != 0)
8551 o->op_private |= OPpSORT_STABLE;
8556 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8558 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8559 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8561 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8563 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8565 if (kid->op_type == OP_SCOPE) {
8569 else if (kid->op_type == OP_LEAVE) {
8570 if (o->op_type == OP_SORT) {
8571 op_null(kid); /* wipe out leave */
8574 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8575 if (k->op_next == kid)
8577 /* don't descend into loops */
8578 else if (k->op_type == OP_ENTERLOOP
8579 || k->op_type == OP_ENTERITER)
8581 k = cLOOPx(k)->op_lastop;
8586 kid->op_next = 0; /* just disconnect the leave */
8587 k = kLISTOP->op_first;
8592 if (o->op_type == OP_SORT) {
8593 /* provide scalar context for comparison function/block */
8599 o->op_flags |= OPf_SPECIAL;
8601 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8604 firstkid = firstkid->op_sibling;
8607 /* provide list context for arguments */
8608 if (o->op_type == OP_SORT)
8615 S_simplify_sort(pTHX_ OP *o)
8618 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8624 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8626 if (!(o->op_flags & OPf_STACKED))
8628 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8629 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8630 kid = kUNOP->op_first; /* get past null */
8631 if (kid->op_type != OP_SCOPE)
8633 kid = kLISTOP->op_last; /* get past scope */
8634 switch(kid->op_type) {
8642 k = kid; /* remember this node*/
8643 if (kBINOP->op_first->op_type != OP_RV2SV)
8645 kid = kBINOP->op_first; /* get past cmp */
8646 if (kUNOP->op_first->op_type != OP_GV)
8648 kid = kUNOP->op_first; /* get past rv2sv */
8650 if (GvSTASH(gv) != PL_curstash)
8652 gvname = GvNAME(gv);
8653 if (*gvname == 'a' && gvname[1] == '\0')
8655 else if (*gvname == 'b' && gvname[1] == '\0')
8660 kid = k; /* back to cmp */
8661 if (kBINOP->op_last->op_type != OP_RV2SV)
8663 kid = kBINOP->op_last; /* down to 2nd arg */
8664 if (kUNOP->op_first->op_type != OP_GV)
8666 kid = kUNOP->op_first; /* get past rv2sv */
8668 if (GvSTASH(gv) != PL_curstash)
8670 gvname = GvNAME(gv);
8672 ? !(*gvname == 'a' && gvname[1] == '\0')
8673 : !(*gvname == 'b' && gvname[1] == '\0'))
8675 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8677 o->op_private |= OPpSORT_DESCEND;
8678 if (k->op_type == OP_NCMP)
8679 o->op_private |= OPpSORT_NUMERIC;
8680 if (k->op_type == OP_I_NCMP)
8681 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8682 kid = cLISTOPo->op_first->op_sibling;
8683 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8685 op_getmad(kid,o,'S'); /* then delete it */
8687 op_free(kid); /* then delete it */
8692 Perl_ck_split(pTHX_ OP *o)
8697 PERL_ARGS_ASSERT_CK_SPLIT;
8699 if (o->op_flags & OPf_STACKED)
8700 return no_fh_allowed(o);
8702 kid = cLISTOPo->op_first;
8703 if (kid->op_type != OP_NULL)
8704 Perl_croak(aTHX_ "panic: ck_split");
8705 kid = kid->op_sibling;
8706 op_free(cLISTOPo->op_first);
8708 cLISTOPo->op_first = kid;
8710 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8711 cLISTOPo->op_last = kid; /* There was only one element previously */
8714 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8715 OP * const sibl = kid->op_sibling;
8716 kid->op_sibling = 0;
8717 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8718 if (cLISTOPo->op_first == cLISTOPo->op_last)
8719 cLISTOPo->op_last = kid;
8720 cLISTOPo->op_first = kid;
8721 kid->op_sibling = sibl;
8724 kid->op_type = OP_PUSHRE;
8725 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8727 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8728 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8729 "Use of /g modifier is meaningless in split");
8732 if (!kid->op_sibling)
8733 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8735 kid = kid->op_sibling;
8738 if (!kid->op_sibling)
8739 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8740 assert(kid->op_sibling);
8742 kid = kid->op_sibling;
8745 if (kid->op_sibling)
8746 return too_many_arguments(o,OP_DESC(o));
8752 Perl_ck_join(pTHX_ OP *o)
8754 const OP * const kid = cLISTOPo->op_first->op_sibling;
8756 PERL_ARGS_ASSERT_CK_JOIN;
8758 if (kid && kid->op_type == OP_MATCH) {
8759 if (ckWARN(WARN_SYNTAX)) {
8760 const REGEXP *re = PM_GETRE(kPMOP);
8761 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8762 const STRLEN len = re ? RX_PRELEN(re) : 6;
8763 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8764 "/%.*s/ should probably be written as \"%.*s\"",
8765 (int)len, pmstr, (int)len, pmstr);
8772 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8774 Examines an op, which is expected to identify a subroutine at runtime,
8775 and attempts to determine at compile time which subroutine it identifies.
8776 This is normally used during Perl compilation to determine whether
8777 a prototype can be applied to a function call. I<cvop> is the op
8778 being considered, normally an C<rv2cv> op. A pointer to the identified
8779 subroutine is returned, if it could be determined statically, and a null
8780 pointer is returned if it was not possible to determine statically.
8782 Currently, the subroutine can be identified statically if the RV that the
8783 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8784 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8785 suitable if the constant value must be an RV pointing to a CV. Details of
8786 this process may change in future versions of Perl. If the C<rv2cv> op
8787 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8788 the subroutine statically: this flag is used to suppress compile-time
8789 magic on a subroutine call, forcing it to use default runtime behaviour.
8791 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8792 of a GV reference is modified. If a GV was examined and its CV slot was
8793 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8794 If the op is not optimised away, and the CV slot is later populated with
8795 a subroutine having a prototype, that flag eventually triggers the warning
8796 "called too early to check prototype".
8798 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8799 of returning a pointer to the subroutine it returns a pointer to the
8800 GV giving the most appropriate name for the subroutine in this context.
8801 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8802 (C<CvANON>) subroutine that is referenced through a GV it will be the
8803 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8804 A null pointer is returned as usual if there is no statically-determinable
8811 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8816 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8817 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8818 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8819 if (cvop->op_type != OP_RV2CV)
8821 if (cvop->op_private & OPpENTERSUB_AMPER)
8823 if (!(cvop->op_flags & OPf_KIDS))
8825 rvop = cUNOPx(cvop)->op_first;
8826 switch (rvop->op_type) {
8828 gv = cGVOPx_gv(rvop);
8831 if (flags & RV2CVOPCV_MARK_EARLY)
8832 rvop->op_private |= OPpEARLY_CV;
8837 SV *rv = cSVOPx_sv(rvop);
8847 if (SvTYPE((SV*)cv) != SVt_PVCV)
8849 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8850 if (!CvANON(cv) || !gv)
8859 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8861 Performs the default fixup of the arguments part of an C<entersub>
8862 op tree. This consists of applying list context to each of the
8863 argument ops. This is the standard treatment used on a call marked
8864 with C<&>, or a method call, or a call through a subroutine reference,
8865 or any other call where the callee can't be identified at compile time,
8866 or a call where the callee has no prototype.
8872 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8875 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8876 aop = cUNOPx(entersubop)->op_first;
8877 if (!aop->op_sibling)
8878 aop = cUNOPx(aop)->op_first;
8879 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8880 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8882 op_lvalue(aop, OP_ENTERSUB);
8889 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8891 Performs the fixup of the arguments part of an C<entersub> op tree
8892 based on a subroutine prototype. This makes various modifications to
8893 the argument ops, from applying context up to inserting C<refgen> ops,
8894 and checking the number and syntactic types of arguments, as directed by
8895 the prototype. This is the standard treatment used on a subroutine call,
8896 not marked with C<&>, where the callee can be identified at compile time
8897 and has a prototype.
8899 I<protosv> supplies the subroutine prototype to be applied to the call.
8900 It may be a normal defined scalar, of which the string value will be used.
8901 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8902 that has been cast to C<SV*>) which has a prototype. The prototype
8903 supplied, in whichever form, does not need to match the actual callee
8904 referenced by the op tree.
8906 If the argument ops disagree with the prototype, for example by having
8907 an unacceptable number of arguments, a valid op tree is returned anyway.
8908 The error is reflected in the parser state, normally resulting in a single
8909 exception at the top level of parsing which covers all the compilation
8910 errors that occurred. In the error message, the callee is referred to
8911 by the name defined by the I<namegv> parameter.
8917 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8920 const char *proto, *proto_end;
8921 OP *aop, *prev, *cvop;
8924 I32 contextclass = 0;
8925 const char *e = NULL;
8926 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8927 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8928 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8929 proto = SvPV(protosv, proto_len);
8930 proto_end = proto + proto_len;
8931 aop = cUNOPx(entersubop)->op_first;
8932 if (!aop->op_sibling)
8933 aop = cUNOPx(aop)->op_first;
8935 aop = aop->op_sibling;
8936 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8937 while (aop != cvop) {
8939 if (PL_madskills && aop->op_type == OP_STUB) {
8940 aop = aop->op_sibling;
8943 if (PL_madskills && aop->op_type == OP_NULL)
8944 o3 = ((UNOP*)aop)->op_first;
8948 if (proto >= proto_end)
8949 return too_many_arguments(entersubop, gv_ename(namegv));
8957 /* _ must be at the end */
8958 if (proto[1] && proto[1] != ';')
8973 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8975 arg == 1 ? "block or sub {}" : "sub {}",
8976 gv_ename(namegv), o3);
8979 /* '*' allows any scalar type, including bareword */
8982 if (o3->op_type == OP_RV2GV)
8983 goto wrapref; /* autoconvert GLOB -> GLOBref */
8984 else if (o3->op_type == OP_CONST)
8985 o3->op_private &= ~OPpCONST_STRICT;
8986 else if (o3->op_type == OP_ENTERSUB) {
8987 /* accidental subroutine, revert to bareword */
8988 OP *gvop = ((UNOP*)o3)->op_first;
8989 if (gvop && gvop->op_type == OP_NULL) {
8990 gvop = ((UNOP*)gvop)->op_first;
8992 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8995 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8996 (gvop = ((UNOP*)gvop)->op_first) &&
8997 gvop->op_type == OP_GV)
8999 GV * const gv = cGVOPx_gv(gvop);
9000 OP * const sibling = aop->op_sibling;
9001 SV * const n = newSVpvs("");
9003 OP * const oldaop = aop;
9007 gv_fullname4(n, gv, "", FALSE);
9008 aop = newSVOP(OP_CONST, 0, n);
9009 op_getmad(oldaop,aop,'O');
9010 prev->op_sibling = aop;
9011 aop->op_sibling = sibling;
9021 if (o3->op_type == OP_RV2AV ||
9022 o3->op_type == OP_PADAV ||
9023 o3->op_type == OP_RV2HV ||
9024 o3->op_type == OP_PADHV
9039 if (contextclass++ == 0) {
9040 e = strchr(proto, ']');
9041 if (!e || e == proto)
9050 const char *p = proto;
9051 const char *const end = proto;
9054 /* \[$] accepts any scalar lvalue */
9056 && Perl_op_lvalue_flags(aTHX_
9058 OP_READ, /* not entersub */
9061 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
9063 gv_ename(namegv), o3);
9068 if (o3->op_type == OP_RV2GV)
9071 bad_type(arg, "symbol", gv_ename(namegv), o3);
9074 if (o3->op_type == OP_ENTERSUB)
9077 bad_type(arg, "subroutine entry", gv_ename(namegv),
9081 if (o3->op_type == OP_RV2SV ||
9082 o3->op_type == OP_PADSV ||
9083 o3->op_type == OP_HELEM ||
9084 o3->op_type == OP_AELEM)
9086 if (!contextclass) {
9087 /* \$ accepts any scalar lvalue */
9088 if (Perl_op_lvalue_flags(aTHX_
9090 OP_READ, /* not entersub */
9093 bad_type(arg, "scalar", gv_ename(namegv), o3);
9097 if (o3->op_type == OP_RV2AV ||
9098 o3->op_type == OP_PADAV)
9101 bad_type(arg, "array", gv_ename(namegv), o3);
9104 if (o3->op_type == OP_RV2HV ||
9105 o3->op_type == OP_PADHV)
9108 bad_type(arg, "hash", gv_ename(namegv), o3);
9112 OP* const kid = aop;
9113 OP* const sib = kid->op_sibling;
9114 kid->op_sibling = 0;
9115 aop = newUNOP(OP_REFGEN, 0, kid);
9116 aop->op_sibling = sib;
9117 prev->op_sibling = aop;
9119 if (contextclass && e) {
9134 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
9135 gv_ename(namegv), SVfARG(protosv));
9138 op_lvalue(aop, OP_ENTERSUB);
9140 aop = aop->op_sibling;
9142 if (aop == cvop && *proto == '_') {
9143 /* generate an access to $_ */
9145 aop->op_sibling = prev->op_sibling;
9146 prev->op_sibling = aop; /* instead of cvop */
9148 if (!optional && proto_end > proto &&
9149 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9150 return too_few_arguments(entersubop, gv_ename(namegv));
9155 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9157 Performs the fixup of the arguments part of an C<entersub> op tree either
9158 based on a subroutine prototype or using default list-context processing.
9159 This is the standard treatment used on a subroutine call, not marked
9160 with C<&>, where the callee can be identified at compile time.
9162 I<protosv> supplies the subroutine prototype to be applied to the call,
9163 or indicates that there is no prototype. It may be a normal scalar,
9164 in which case if it is defined then the string value will be used
9165 as a prototype, and if it is undefined then there is no prototype.
9166 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9167 that has been cast to C<SV*>), of which the prototype will be used if it
9168 has one. The prototype (or lack thereof) supplied, in whichever form,
9169 does not need to match the actual callee referenced by the op tree.
9171 If the argument ops disagree with the prototype, for example by having
9172 an unacceptable number of arguments, a valid op tree is returned anyway.
9173 The error is reflected in the parser state, normally resulting in a single
9174 exception at the top level of parsing which covers all the compilation
9175 errors that occurred. In the error message, the callee is referred to
9176 by the name defined by the I<namegv> parameter.
9182 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9183 GV *namegv, SV *protosv)
9185 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9186 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9187 return ck_entersub_args_proto(entersubop, namegv, protosv);
9189 return ck_entersub_args_list(entersubop);
9193 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9195 Retrieves the function that will be used to fix up a call to I<cv>.
9196 Specifically, the function is applied to an C<entersub> op tree for a
9197 subroutine call, not marked with C<&>, where the callee can be identified
9198 at compile time as I<cv>.
9200 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9201 argument for it is returned in I<*ckobj_p>. The function is intended
9202 to be called in this manner:
9204 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9206 In this call, I<entersubop> is a pointer to the C<entersub> op,
9207 which may be replaced by the check function, and I<namegv> is a GV
9208 supplying the name that should be used by the check function to refer
9209 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9210 It is permitted to apply the check function in non-standard situations,
9211 such as to a call to a different subroutine or to a method call.
9213 By default, the function is
9214 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9215 and the SV parameter is I<cv> itself. This implements standard
9216 prototype processing. It can be changed, for a particular subroutine,
9217 by L</cv_set_call_checker>.
9223 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9226 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9227 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9229 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9230 *ckobj_p = callmg->mg_obj;
9232 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9238 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9240 Sets the function that will be used to fix up a call to I<cv>.
9241 Specifically, the function is applied to an C<entersub> op tree for a
9242 subroutine call, not marked with C<&>, where the callee can be identified
9243 at compile time as I<cv>.
9245 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9246 for it is supplied in I<ckobj>. The function is intended to be called
9249 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9251 In this call, I<entersubop> is a pointer to the C<entersub> op,
9252 which may be replaced by the check function, and I<namegv> is a GV
9253 supplying the name that should be used by the check function to refer
9254 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9255 It is permitted to apply the check function in non-standard situations,
9256 such as to a call to a different subroutine or to a method call.
9258 The current setting for a particular CV can be retrieved by
9259 L</cv_get_call_checker>.
9265 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9267 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9268 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9269 if (SvMAGICAL((SV*)cv))
9270 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9273 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9274 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9275 if (callmg->mg_flags & MGf_REFCOUNTED) {
9276 SvREFCNT_dec(callmg->mg_obj);
9277 callmg->mg_flags &= ~MGf_REFCOUNTED;
9279 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9280 callmg->mg_obj = ckobj;
9281 if (ckobj != (SV*)cv) {
9282 SvREFCNT_inc_simple_void_NN(ckobj);
9283 callmg->mg_flags |= MGf_REFCOUNTED;
9289 Perl_ck_subr(pTHX_ OP *o)
9295 PERL_ARGS_ASSERT_CK_SUBR;
9297 aop = cUNOPx(o)->op_first;
9298 if (!aop->op_sibling)
9299 aop = cUNOPx(aop)->op_first;
9300 aop = aop->op_sibling;
9301 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9302 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9303 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9305 o->op_private &= ~1;
9306 o->op_private |= OPpENTERSUB_HASTARG;
9307 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9308 if (PERLDB_SUB && PL_curstash != PL_debstash)
9309 o->op_private |= OPpENTERSUB_DB;
9310 if (cvop->op_type == OP_RV2CV) {
9311 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9313 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9314 if (aop->op_type == OP_CONST)
9315 aop->op_private &= ~OPpCONST_STRICT;
9316 else if (aop->op_type == OP_LIST) {
9317 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9318 if (sib && sib->op_type == OP_CONST)
9319 sib->op_private &= ~OPpCONST_STRICT;
9324 return ck_entersub_args_list(o);
9326 Perl_call_checker ckfun;
9328 cv_get_call_checker(cv, &ckfun, &ckobj);
9329 return ckfun(aTHX_ o, namegv, ckobj);
9334 Perl_ck_svconst(pTHX_ OP *o)
9336 PERL_ARGS_ASSERT_CK_SVCONST;
9337 PERL_UNUSED_CONTEXT;
9338 SvREADONLY_on(cSVOPo->op_sv);
9343 Perl_ck_chdir(pTHX_ OP *o)
9345 PERL_ARGS_ASSERT_CK_CHDIR;
9346 if (o->op_flags & OPf_KIDS) {
9347 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9349 if (kid && kid->op_type == OP_CONST &&
9350 (kid->op_private & OPpCONST_BARE))
9352 o->op_flags |= OPf_SPECIAL;
9353 kid->op_private &= ~OPpCONST_STRICT;
9360 Perl_ck_trunc(pTHX_ OP *o)
9362 PERL_ARGS_ASSERT_CK_TRUNC;
9364 if (o->op_flags & OPf_KIDS) {
9365 SVOP *kid = (SVOP*)cUNOPo->op_first;
9367 if (kid->op_type == OP_NULL)
9368 kid = (SVOP*)kid->op_sibling;
9369 if (kid && kid->op_type == OP_CONST &&
9370 (kid->op_private & OPpCONST_BARE))
9372 o->op_flags |= OPf_SPECIAL;
9373 kid->op_private &= ~OPpCONST_STRICT;
9380 Perl_ck_unpack(pTHX_ OP *o)
9382 OP *kid = cLISTOPo->op_first;
9384 PERL_ARGS_ASSERT_CK_UNPACK;
9386 if (kid->op_sibling) {
9387 kid = kid->op_sibling;
9388 if (!kid->op_sibling)
9389 kid->op_sibling = newDEFSVOP();
9395 Perl_ck_substr(pTHX_ OP *o)
9397 PERL_ARGS_ASSERT_CK_SUBSTR;
9400 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9401 OP *kid = cLISTOPo->op_first;
9403 if (kid->op_type == OP_NULL)
9404 kid = kid->op_sibling;
9406 kid->op_flags |= OPf_MOD;
9413 Perl_ck_each(pTHX_ OP *o)
9416 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9417 const unsigned orig_type = o->op_type;
9418 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9419 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9420 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9421 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9423 PERL_ARGS_ASSERT_CK_EACH;
9426 switch (kid->op_type) {
9432 CHANGE_TYPE(o, array_type);
9435 if (kid->op_private == OPpCONST_BARE
9436 || !SvROK(cSVOPx_sv(kid))
9437 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9438 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9440 /* we let ck_fun handle it */
9443 CHANGE_TYPE(o, ref_type);
9447 /* if treating as a reference, defer additional checks to runtime */
9448 return o->op_type == ref_type ? o : ck_fun(o);
9451 /* caller is supposed to assign the return to the
9452 container of the rep_op var */
9454 S_opt_scalarhv(pTHX_ OP *rep_op) {
9458 PERL_ARGS_ASSERT_OPT_SCALARHV;
9460 NewOp(1101, unop, 1, UNOP);
9461 unop->op_type = (OPCODE)OP_BOOLKEYS;
9462 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9463 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9464 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9465 unop->op_first = rep_op;
9466 unop->op_next = rep_op->op_next;
9467 rep_op->op_next = (OP*)unop;
9468 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9469 unop->op_sibling = rep_op->op_sibling;
9470 rep_op->op_sibling = NULL;
9471 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9472 if (rep_op->op_type == OP_PADHV) {
9473 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9474 rep_op->op_flags |= OPf_WANT_LIST;
9479 /* Checks if o acts as an in-place operator on an array. oright points to the
9480 * beginning of the right-hand side. Returns the left-hand side of the
9481 * assignment if o acts in-place, or NULL otherwise. */
9484 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9488 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9491 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9492 || oright->op_next != o
9493 || (oright->op_private & OPpLVAL_INTRO)
9497 /* o2 follows the chain of op_nexts through the LHS of the
9498 * assign (if any) to the aassign op itself */
9500 if (!o2 || o2->op_type != OP_NULL)
9503 if (!o2 || o2->op_type != OP_PUSHMARK)
9506 if (o2 && o2->op_type == OP_GV)
9509 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9510 || (o2->op_private & OPpLVAL_INTRO)
9515 if (!o2 || o2->op_type != OP_NULL)
9518 if (!o2 || o2->op_type != OP_AASSIGN
9519 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9522 /* check that the sort is the first arg on RHS of assign */
9524 o2 = cUNOPx(o2)->op_first;
9525 if (!o2 || o2->op_type != OP_NULL)
9527 o2 = cUNOPx(o2)->op_first;
9528 if (!o2 || o2->op_type != OP_PUSHMARK)
9530 if (o2->op_sibling != o)
9533 /* check the array is the same on both sides */
9534 if (oleft->op_type == OP_RV2AV) {
9535 if (oright->op_type != OP_RV2AV
9536 || !cUNOPx(oright)->op_first
9537 || cUNOPx(oright)->op_first->op_type != OP_GV
9538 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9539 cGVOPx_gv(cUNOPx(oright)->op_first)
9543 else if (oright->op_type != OP_PADAV
9544 || oright->op_targ != oleft->op_targ
9551 #define MAX_DEFERRED 4
9554 if (defer_ix == (MAX_DEFERRED-1)) { \
9555 CALL_RPEEP(defer_queue[defer_base]); \
9556 defer_base = (defer_base + 1) % MAX_DEFERRED; \
9559 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
9561 /* A peephole optimizer. We visit the ops in the order they're to execute.
9562 * See the comments at the top of this file for more details about when
9563 * peep() is called */
9566 Perl_rpeep(pTHX_ register OP *o)
9569 register OP* oldop = NULL;
9570 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
9574 if (!o || o->op_opt)
9578 SAVEVPTR(PL_curcop);
9579 for (;; o = o->op_next) {
9583 while (defer_ix >= 0)
9584 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
9588 /* By default, this op has now been optimised. A couple of cases below
9589 clear this again. */
9592 switch (o->op_type) {
9594 PL_curcop = ((COP*)o); /* for warnings */
9597 PL_curcop = ((COP*)o); /* for warnings */
9599 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9600 to carry two labels. For now, take the easier option, and skip
9601 this optimisation if the first NEXTSTATE has a label. */
9602 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9603 OP *nextop = o->op_next;
9604 while (nextop && nextop->op_type == OP_NULL)
9605 nextop = nextop->op_next;
9607 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9608 COP *firstcop = (COP *)o;
9609 COP *secondcop = (COP *)nextop;
9610 /* We want the COP pointed to by o (and anything else) to
9611 become the next COP down the line. */
9614 firstcop->op_next = secondcop->op_next;
9616 /* Now steal all its pointers, and duplicate the other
9618 firstcop->cop_line = secondcop->cop_line;
9620 firstcop->cop_stashpv = secondcop->cop_stashpv;
9621 firstcop->cop_file = secondcop->cop_file;
9623 firstcop->cop_stash = secondcop->cop_stash;
9624 firstcop->cop_filegv = secondcop->cop_filegv;
9626 firstcop->cop_hints = secondcop->cop_hints;
9627 firstcop->cop_seq = secondcop->cop_seq;
9628 firstcop->cop_warnings = secondcop->cop_warnings;
9629 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9632 secondcop->cop_stashpv = NULL;
9633 secondcop->cop_file = NULL;
9635 secondcop->cop_stash = NULL;
9636 secondcop->cop_filegv = NULL;
9638 secondcop->cop_warnings = NULL;
9639 secondcop->cop_hints_hash = NULL;
9641 /* If we use op_null(), and hence leave an ex-COP, some
9642 warnings are misreported. For example, the compile-time
9643 error in 'use strict; no strict refs;' */
9644 secondcop->op_type = OP_NULL;
9645 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9651 if (cSVOPo->op_private & OPpCONST_STRICT)
9652 no_bareword_allowed(o);
9656 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9657 if (o->op_next->op_private & OPpTARGET_MY) {
9658 if (o->op_flags & OPf_STACKED) /* chained concats */
9659 break; /* ignore_optimization */
9661 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9662 o->op_targ = o->op_next->op_targ;
9663 o->op_next->op_targ = 0;
9664 o->op_private |= OPpTARGET_MY;
9667 op_null(o->op_next);
9671 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9672 break; /* Scalar stub must produce undef. List stub is noop */
9676 if (o->op_targ == OP_NEXTSTATE
9677 || o->op_targ == OP_DBSTATE)
9679 PL_curcop = ((COP*)o);
9681 /* XXX: We avoid setting op_seq here to prevent later calls
9682 to rpeep() from mistakenly concluding that optimisation
9683 has already occurred. This doesn't fix the real problem,
9684 though (See 20010220.007). AMS 20010719 */
9685 /* op_seq functionality is now replaced by op_opt */
9692 if (oldop && o->op_next) {
9693 oldop->op_next = o->op_next;
9701 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9702 OP* const pop = (o->op_type == OP_PADAV) ?
9703 o->op_next : o->op_next->op_next;
9705 if (pop && pop->op_type == OP_CONST &&
9706 ((PL_op = pop->op_next)) &&
9707 pop->op_next->op_type == OP_AELEM &&
9708 !(pop->op_next->op_private &
9709 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9710 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9715 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9716 no_bareword_allowed(pop);
9717 if (o->op_type == OP_GV)
9718 op_null(o->op_next);
9719 op_null(pop->op_next);
9721 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9722 o->op_next = pop->op_next->op_next;
9723 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9724 o->op_private = (U8)i;
9725 if (o->op_type == OP_GV) {
9728 o->op_type = OP_AELEMFAST;
9731 o->op_type = OP_AELEMFAST_LEX;
9736 if (o->op_next->op_type == OP_RV2SV) {
9737 if (!(o->op_next->op_private & OPpDEREF)) {
9738 op_null(o->op_next);
9739 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9741 o->op_next = o->op_next->op_next;
9742 o->op_type = OP_GVSV;
9743 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9746 else if (o->op_next->op_type == OP_READLINE
9747 && o->op_next->op_next->op_type == OP_CONCAT
9748 && (o->op_next->op_next->op_flags & OPf_STACKED))
9750 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9751 o->op_type = OP_RCATLINE;
9752 o->op_flags |= OPf_STACKED;
9753 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9754 op_null(o->op_next->op_next);
9755 op_null(o->op_next);
9765 fop = cUNOP->op_first;
9773 fop = cLOGOP->op_first;
9774 sop = fop->op_sibling;
9775 while (cLOGOP->op_other->op_type == OP_NULL)
9776 cLOGOP->op_other = cLOGOP->op_other->op_next;
9777 while (o->op_next && ( o->op_type == o->op_next->op_type
9778 || o->op_next->op_type == OP_NULL))
9779 o->op_next = o->op_next->op_next;
9780 DEFER(cLOGOP->op_other);
9784 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9786 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9791 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9792 while (nop && nop->op_next) {
9793 switch (nop->op_next->op_type) {
9798 lop = nop = nop->op_next;
9809 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9810 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9811 cLOGOP->op_first = opt_scalarhv(fop);
9812 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9813 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9829 while (cLOGOP->op_other->op_type == OP_NULL)
9830 cLOGOP->op_other = cLOGOP->op_other->op_next;
9831 DEFER(cLOGOP->op_other);
9836 while (cLOOP->op_redoop->op_type == OP_NULL)
9837 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9838 while (cLOOP->op_nextop->op_type == OP_NULL)
9839 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9840 while (cLOOP->op_lastop->op_type == OP_NULL)
9841 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9842 /* a while(1) loop doesn't have an op_next that escapes the
9843 * loop, so we have to explicitly follow the op_lastop to
9844 * process the rest of the code */
9845 DEFER(cLOOP->op_lastop);
9849 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9850 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9851 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9852 cPMOP->op_pmstashstartu.op_pmreplstart
9853 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9854 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
9863 ( oldop->op_type == OP_AELEM
9864 || oldop->op_type == OP_PADSV
9865 || oldop->op_type == OP_RV2SV
9866 || oldop->op_type == OP_RV2GV
9867 || oldop->op_type == OP_HELEM
9869 && (oldop->op_private & OPpDEREF)
9871 || ( oldop->op_type == OP_ENTERSUB
9872 && oldop->op_private & OPpENTERSUB_DEREF )
9875 o->op_private |= OPpDEREFed;
9879 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9883 /* check that RHS of sort is a single plain array */
9884 OP *oright = cUNOPo->op_first;
9885 if (!oright || oright->op_type != OP_PUSHMARK)
9888 /* reverse sort ... can be optimised. */
9889 if (!cUNOPo->op_sibling) {
9890 /* Nothing follows us on the list. */
9891 OP * const reverse = o->op_next;
9893 if (reverse->op_type == OP_REVERSE &&
9894 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9895 OP * const pushmark = cUNOPx(reverse)->op_first;
9896 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9897 && (cUNOPx(pushmark)->op_sibling == o)) {
9898 /* reverse -> pushmark -> sort */
9899 o->op_private |= OPpSORT_REVERSE;
9901 pushmark->op_next = oright->op_next;
9907 /* make @a = sort @a act in-place */
9909 oright = cUNOPx(oright)->op_sibling;
9912 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9913 oright = cUNOPx(oright)->op_sibling;
9916 oleft = is_inplace_av(o, oright);
9920 /* transfer MODishness etc from LHS arg to RHS arg */
9921 oright->op_flags = oleft->op_flags;
9922 o->op_private |= OPpSORT_INPLACE;
9924 /* excise push->gv->rv2av->null->aassign */
9925 o2 = o->op_next->op_next;
9926 op_null(o2); /* PUSHMARK */
9928 if (o2->op_type == OP_GV) {
9929 op_null(o2); /* GV */
9932 op_null(o2); /* RV2AV or PADAV */
9933 o2 = o2->op_next->op_next;
9934 op_null(o2); /* AASSIGN */
9936 o->op_next = o2->op_next;
9942 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9945 LISTOP *enter, *exlist;
9947 /* @a = reverse @a */
9948 if ((oright = cLISTOPo->op_first)
9949 && (oright->op_type == OP_PUSHMARK)
9950 && (oright = oright->op_sibling)
9951 && (oleft = is_inplace_av(o, oright))) {
9954 /* transfer MODishness etc from LHS arg to RHS arg */
9955 oright->op_flags = oleft->op_flags;
9956 o->op_private |= OPpREVERSE_INPLACE;
9958 /* excise push->gv->rv2av->null->aassign */
9959 o2 = o->op_next->op_next;
9960 op_null(o2); /* PUSHMARK */
9962 if (o2->op_type == OP_GV) {
9963 op_null(o2); /* GV */
9966 op_null(o2); /* RV2AV or PADAV */
9967 o2 = o2->op_next->op_next;
9968 op_null(o2); /* AASSIGN */
9970 o->op_next = o2->op_next;
9974 enter = (LISTOP *) o->op_next;
9977 if (enter->op_type == OP_NULL) {
9978 enter = (LISTOP *) enter->op_next;
9982 /* for $a (...) will have OP_GV then OP_RV2GV here.
9983 for (...) just has an OP_GV. */
9984 if (enter->op_type == OP_GV) {
9985 gvop = (OP *) enter;
9986 enter = (LISTOP *) enter->op_next;
9989 if (enter->op_type == OP_RV2GV) {
9990 enter = (LISTOP *) enter->op_next;
9996 if (enter->op_type != OP_ENTERITER)
9999 iter = enter->op_next;
10000 if (!iter || iter->op_type != OP_ITER)
10003 expushmark = enter->op_first;
10004 if (!expushmark || expushmark->op_type != OP_NULL
10005 || expushmark->op_targ != OP_PUSHMARK)
10008 exlist = (LISTOP *) expushmark->op_sibling;
10009 if (!exlist || exlist->op_type != OP_NULL
10010 || exlist->op_targ != OP_LIST)
10013 if (exlist->op_last != o) {
10014 /* Mmm. Was expecting to point back to this op. */
10017 theirmark = exlist->op_first;
10018 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10021 if (theirmark->op_sibling != o) {
10022 /* There's something between the mark and the reverse, eg
10023 for (1, reverse (...))
10028 ourmark = ((LISTOP *)o)->op_first;
10029 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10032 ourlast = ((LISTOP *)o)->op_last;
10033 if (!ourlast || ourlast->op_next != o)
10036 rv2av = ourmark->op_sibling;
10037 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10038 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10039 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10040 /* We're just reversing a single array. */
10041 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10042 enter->op_flags |= OPf_STACKED;
10045 /* We don't have control over who points to theirmark, so sacrifice
10047 theirmark->op_next = ourmark->op_next;
10048 theirmark->op_flags = ourmark->op_flags;
10049 ourlast->op_next = gvop ? gvop : (OP *) enter;
10052 enter->op_private |= OPpITER_REVERSED;
10053 iter->op_private |= OPpITER_REVERSED;
10060 UNOP *refgen, *rv2cv;
10063 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
10066 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
10069 rv2gv = ((BINOP *)o)->op_last;
10070 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
10073 refgen = (UNOP *)((BINOP *)o)->op_first;
10075 if (!refgen || refgen->op_type != OP_REFGEN)
10078 exlist = (LISTOP *)refgen->op_first;
10079 if (!exlist || exlist->op_type != OP_NULL
10080 || exlist->op_targ != OP_LIST)
10083 if (exlist->op_first->op_type != OP_PUSHMARK)
10086 rv2cv = (UNOP*)exlist->op_last;
10088 if (rv2cv->op_type != OP_RV2CV)
10091 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
10092 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
10093 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
10095 o->op_private |= OPpASSIGN_CV_TO_GV;
10096 rv2gv->op_private |= OPpDONT_INIT_GV;
10097 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
10105 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10106 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10111 Perl_cpeep_t cpeep =
10112 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10114 cpeep(aTHX_ o, oldop);
10125 Perl_peep(pTHX_ register OP *o)
10131 =head1 Custom Operators
10133 =for apidoc Ao||custom_op_xop
10134 Return the XOP structure for a given custom op. This function should be
10135 considered internal to OP_NAME and the other access macros: use them instead.
10141 Perl_custom_op_xop(pTHX_ const OP *o)
10147 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10149 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10150 assert(o->op_type == OP_CUSTOM);
10152 /* This is wrong. It assumes a function pointer can be cast to IV,
10153 * which isn't guaranteed, but this is what the old custom OP code
10154 * did. In principle it should be safer to Copy the bytes of the
10155 * pointer into a PV: since the new interface is hidden behind
10156 * functions, this can be changed later if necessary. */
10157 /* Change custom_op_xop if this ever happens */
10158 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10161 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10163 /* assume noone will have just registered a desc */
10164 if (!he && PL_custom_op_names &&
10165 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10170 /* XXX does all this need to be shared mem? */
10171 Newxz(xop, 1, XOP);
10172 pv = SvPV(HeVAL(he), l);
10173 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10174 if (PL_custom_op_descs &&
10175 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10177 pv = SvPV(HeVAL(he), l);
10178 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10180 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10184 if (!he) return &xop_null;
10186 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10191 =for apidoc Ao||custom_op_register
10192 Register a custom op. See L<perlguts/"Custom Operators">.
10198 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10202 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10204 /* see the comment in custom_op_xop */
10205 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10207 if (!PL_custom_ops)
10208 PL_custom_ops = newHV();
10210 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10211 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10215 =head1 Functions in file op.c
10217 =for apidoc core_prototype
10218 This function assigns the prototype of the named core function to C<sv>, or
10219 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10220 NULL if the core function has no prototype.
10222 If the C<name> is not a Perl keyword, it croaks if C<croak> is true, or
10223 returns NULL if C<croak> is false.
10229 Perl_core_prototype(pTHX_ SV *sv, const char *name, const STRLEN len,
10232 const int code = keyword(name, len, 1);
10233 int i = 0, n = 0, seen_question = 0, defgv = 0;
10235 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10236 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10238 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10242 return (SV *)Perl_die(aTHX_
10243 "Can't find an opnumber for \"%s\"", name
10248 if (code > 0) return NULL; /* Not overridable */
10250 if (!sv) sv = sv_newmortal();
10252 #define retsetpvs(x) sv_setpvs(sv, x); return sv
10255 case KEY_and : case KEY_chop: case KEY_chomp:
10256 case KEY_cmp : case KEY_exec: case KEY_eq :
10257 case KEY_ge : case KEY_gt : case KEY_le :
10258 case KEY_lstat : case KEY_lt : case KEY_ne : case KEY_or :
10259 case KEY_stat : case KEY_system: case KEY_x : case KEY_xor:
10261 case KEY_keys: case KEY_values: case KEY_each:
10263 case KEY_push: case KEY_unshift:
10265 case KEY_pop: case KEY_shift:
10268 retsetpvs("+;$$@");
10269 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10277 while (i < MAXO) { /* The slow way. */
10278 if (strEQ(name, PL_op_name[i])
10279 || strEQ(name, PL_op_desc[i]))
10285 return NULL; /* Should not happen... */
10287 defgv = PL_opargs[i] & OA_DEFGV;
10288 oa = PL_opargs[i] >> OASHIFT;
10290 if (oa & OA_OPTIONAL && !seen_question && (!defgv || n)) {
10294 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10295 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10296 /* But globs are already references (kinda) */
10297 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10301 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10302 && !scalar_mod_type(NULL, i)) {
10310 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10313 if (defgv && str[0] == '$')
10316 sv_setpvn(sv, str, n - 1);
10322 /* Efficient sub that returns a constant scalar value. */
10324 const_sv_xsub(pTHX_ CV* cv)
10328 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10332 /* diag_listed_as: SKIPME */
10333 Perl_croak(aTHX_ "usage: %s::%s()",
10334 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10347 * c-indentation-style: bsd
10348 * c-basic-offset: 4
10349 * indent-tabs-mode: t
10352 * ex: set ts=8 sts=4 sw=4 noet: