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;
2015 S_scalar_mod_type(const OP *o, I32 type)
2017 assert(o || type != OP_SASSIGN);
2021 if (o->op_type == OP_RV2GV)
2045 case OP_RIGHT_SHIFT:
2066 S_is_handle_constructor(const OP *o, I32 numargs)
2068 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2070 switch (o->op_type) {
2078 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2091 S_refkids(pTHX_ OP *o, I32 type)
2093 if (o && o->op_flags & OPf_KIDS) {
2095 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2102 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2107 PERL_ARGS_ASSERT_DOREF;
2109 if (!o || (PL_parser && PL_parser->error_count))
2112 switch (o->op_type) {
2114 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2115 !(o->op_flags & OPf_STACKED)) {
2116 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2117 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2118 assert(cUNOPo->op_first->op_type == OP_NULL);
2119 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2120 o->op_flags |= OPf_SPECIAL;
2121 o->op_private &= ~1;
2123 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2124 o->op_private |= OPpENTERSUB_DEREF;
2125 o->op_flags |= OPf_MOD;
2131 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2132 doref(kid, type, set_op_ref);
2135 if (type == OP_DEFINED)
2136 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2137 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2140 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2141 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2142 : type == OP_RV2HV ? OPpDEREF_HV
2144 o->op_flags |= OPf_MOD;
2151 o->op_flags |= OPf_REF;
2154 if (type == OP_DEFINED)
2155 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2156 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2162 o->op_flags |= OPf_REF;
2167 if (!(o->op_flags & OPf_KIDS))
2169 doref(cBINOPo->op_first, type, set_op_ref);
2173 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2174 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2175 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2176 : type == OP_RV2HV ? OPpDEREF_HV
2178 o->op_flags |= OPf_MOD;
2188 if (!(o->op_flags & OPf_KIDS))
2190 doref(cLISTOPo->op_last, type, set_op_ref);
2200 S_dup_attrlist(pTHX_ OP *o)
2205 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2207 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2208 * where the first kid is OP_PUSHMARK and the remaining ones
2209 * are OP_CONST. We need to push the OP_CONST values.
2211 if (o->op_type == OP_CONST)
2212 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2214 else if (o->op_type == OP_NULL)
2218 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2220 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2221 if (o->op_type == OP_CONST)
2222 rop = op_append_elem(OP_LIST, rop,
2223 newSVOP(OP_CONST, o->op_flags,
2224 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2231 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2236 PERL_ARGS_ASSERT_APPLY_ATTRS;
2238 /* fake up C<use attributes $pkg,$rv,@attrs> */
2239 ENTER; /* need to protect against side-effects of 'use' */
2240 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2242 #define ATTRSMODULE "attributes"
2243 #define ATTRSMODULE_PM "attributes.pm"
2246 /* Don't force the C<use> if we don't need it. */
2247 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2248 if (svp && *svp != &PL_sv_undef)
2249 NOOP; /* already in %INC */
2251 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2252 newSVpvs(ATTRSMODULE), NULL);
2255 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2256 newSVpvs(ATTRSMODULE),
2258 op_prepend_elem(OP_LIST,
2259 newSVOP(OP_CONST, 0, stashsv),
2260 op_prepend_elem(OP_LIST,
2261 newSVOP(OP_CONST, 0,
2263 dup_attrlist(attrs))));
2269 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2272 OP *pack, *imop, *arg;
2275 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2280 assert(target->op_type == OP_PADSV ||
2281 target->op_type == OP_PADHV ||
2282 target->op_type == OP_PADAV);
2284 /* Ensure that attributes.pm is loaded. */
2285 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2287 /* Need package name for method call. */
2288 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2290 /* Build up the real arg-list. */
2291 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2293 arg = newOP(OP_PADSV, 0);
2294 arg->op_targ = target->op_targ;
2295 arg = op_prepend_elem(OP_LIST,
2296 newSVOP(OP_CONST, 0, stashsv),
2297 op_prepend_elem(OP_LIST,
2298 newUNOP(OP_REFGEN, 0,
2299 op_lvalue(arg, OP_REFGEN)),
2300 dup_attrlist(attrs)));
2302 /* Fake up a method call to import */
2303 meth = newSVpvs_share("import");
2304 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2305 op_append_elem(OP_LIST,
2306 op_prepend_elem(OP_LIST, pack, list(arg)),
2307 newSVOP(OP_METHOD_NAMED, 0, meth)));
2308 imop->op_private |= OPpENTERSUB_NOMOD;
2310 /* Combine the ops. */
2311 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2315 =notfor apidoc apply_attrs_string
2317 Attempts to apply a list of attributes specified by the C<attrstr> and
2318 C<len> arguments to the subroutine identified by the C<cv> argument which
2319 is expected to be associated with the package identified by the C<stashpv>
2320 argument (see L<attributes>). It gets this wrong, though, in that it
2321 does not correctly identify the boundaries of the individual attribute
2322 specifications within C<attrstr>. This is not really intended for the
2323 public API, but has to be listed here for systems such as AIX which
2324 need an explicit export list for symbols. (It's called from XS code
2325 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2326 to respect attribute syntax properly would be welcome.
2332 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2333 const char *attrstr, STRLEN len)
2337 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2340 len = strlen(attrstr);
2344 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2346 const char * const sstr = attrstr;
2347 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2348 attrs = op_append_elem(OP_LIST, attrs,
2349 newSVOP(OP_CONST, 0,
2350 newSVpvn(sstr, attrstr-sstr)));
2354 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2355 newSVpvs(ATTRSMODULE),
2356 NULL, op_prepend_elem(OP_LIST,
2357 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2358 op_prepend_elem(OP_LIST,
2359 newSVOP(OP_CONST, 0,
2360 newRV(MUTABLE_SV(cv))),
2365 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2369 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2371 PERL_ARGS_ASSERT_MY_KID;
2373 if (!o || (PL_parser && PL_parser->error_count))
2377 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2378 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2382 if (type == OP_LIST) {
2384 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2385 my_kid(kid, attrs, imopsp);
2386 } else if (type == OP_UNDEF
2392 } else if (type == OP_RV2SV || /* "our" declaration */
2394 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2395 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2396 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2398 PL_parser->in_my == KEY_our
2400 : PL_parser->in_my == KEY_state ? "state" : "my"));
2402 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2403 PL_parser->in_my = FALSE;
2404 PL_parser->in_my_stash = NULL;
2405 apply_attrs(GvSTASH(gv),
2406 (type == OP_RV2SV ? GvSV(gv) :
2407 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2408 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2411 o->op_private |= OPpOUR_INTRO;
2414 else if (type != OP_PADSV &&
2417 type != OP_PUSHMARK)
2419 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2421 PL_parser->in_my == KEY_our
2423 : PL_parser->in_my == KEY_state ? "state" : "my"));
2426 else if (attrs && type != OP_PUSHMARK) {
2429 PL_parser->in_my = FALSE;
2430 PL_parser->in_my_stash = NULL;
2432 /* check for C<my Dog $spot> when deciding package */
2433 stash = PAD_COMPNAME_TYPE(o->op_targ);
2435 stash = PL_curstash;
2436 apply_attrs_my(stash, o, attrs, imopsp);
2438 o->op_flags |= OPf_MOD;
2439 o->op_private |= OPpLVAL_INTRO;
2441 o->op_private |= OPpPAD_STATE;
2446 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2450 int maybe_scalar = 0;
2452 PERL_ARGS_ASSERT_MY_ATTRS;
2454 /* [perl #17376]: this appears to be premature, and results in code such as
2455 C< our(%x); > executing in list mode rather than void mode */
2457 if (o->op_flags & OPf_PARENS)
2467 o = my_kid(o, attrs, &rops);
2469 if (maybe_scalar && o->op_type == OP_PADSV) {
2470 o = scalar(op_append_list(OP_LIST, rops, o));
2471 o->op_private |= OPpLVAL_INTRO;
2474 /* The listop in rops might have a pushmark at the beginning,
2475 which will mess up list assignment. */
2476 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2477 if (rops->op_type == OP_LIST &&
2478 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2480 OP * const pushmark = lrops->op_first;
2481 lrops->op_first = pushmark->op_sibling;
2484 o = op_append_list(OP_LIST, o, rops);
2487 PL_parser->in_my = FALSE;
2488 PL_parser->in_my_stash = NULL;
2493 Perl_sawparens(pTHX_ OP *o)
2495 PERL_UNUSED_CONTEXT;
2497 o->op_flags |= OPf_PARENS;
2502 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2506 const OPCODE ltype = left->op_type;
2507 const OPCODE rtype = right->op_type;
2509 PERL_ARGS_ASSERT_BIND_MATCH;
2511 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2512 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2514 const char * const desc
2516 rtype == OP_SUBST || rtype == OP_TRANS
2517 || rtype == OP_TRANSR
2519 ? (int)rtype : OP_MATCH];
2520 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2521 ? "@array" : "%hash");
2522 Perl_warner(aTHX_ packWARN(WARN_MISC),
2523 "Applying %s to %s will act on scalar(%s)",
2524 desc, sample, sample);
2527 if (rtype == OP_CONST &&
2528 cSVOPx(right)->op_private & OPpCONST_BARE &&
2529 cSVOPx(right)->op_private & OPpCONST_STRICT)
2531 no_bareword_allowed(right);
2534 /* !~ doesn't make sense with /r, so error on it for now */
2535 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2537 yyerror("Using !~ with s///r doesn't make sense");
2538 if (rtype == OP_TRANSR && type == OP_NOT)
2539 yyerror("Using !~ with tr///r doesn't make sense");
2541 ismatchop = (rtype == OP_MATCH ||
2542 rtype == OP_SUBST ||
2543 rtype == OP_TRANS || rtype == OP_TRANSR)
2544 && !(right->op_flags & OPf_SPECIAL);
2545 if (ismatchop && right->op_private & OPpTARGET_MY) {
2547 right->op_private &= ~OPpTARGET_MY;
2549 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2552 right->op_flags |= OPf_STACKED;
2553 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2554 ! (rtype == OP_TRANS &&
2555 right->op_private & OPpTRANS_IDENTICAL) &&
2556 ! (rtype == OP_SUBST &&
2557 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2558 newleft = op_lvalue(left, rtype);
2561 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2562 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2564 o = op_prepend_elem(rtype, scalar(newleft), right);
2566 return newUNOP(OP_NOT, 0, scalar(o));
2570 return bind_match(type, left,
2571 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2575 Perl_invert(pTHX_ OP *o)
2579 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2583 =for apidoc Amx|OP *|op_scope|OP *o
2585 Wraps up an op tree with some additional ops so that at runtime a dynamic
2586 scope will be created. The original ops run in the new dynamic scope,
2587 and then, provided that they exit normally, the scope will be unwound.
2588 The additional ops used to create and unwind the dynamic scope will
2589 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2590 instead if the ops are simple enough to not need the full dynamic scope
2597 Perl_op_scope(pTHX_ OP *o)
2601 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2602 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2603 o->op_type = OP_LEAVE;
2604 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2606 else if (o->op_type == OP_LINESEQ) {
2608 o->op_type = OP_SCOPE;
2609 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2610 kid = ((LISTOP*)o)->op_first;
2611 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2614 /* The following deals with things like 'do {1 for 1}' */
2615 kid = kid->op_sibling;
2617 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2622 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2628 Perl_block_start(pTHX_ int full)
2631 const int retval = PL_savestack_ix;
2633 pad_block_start(full);
2635 PL_hints &= ~HINT_BLOCK_SCOPE;
2636 SAVECOMPILEWARNINGS();
2637 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2639 CALL_BLOCK_HOOKS(bhk_start, full);
2645 Perl_block_end(pTHX_ I32 floor, OP *seq)
2648 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2649 OP* retval = scalarseq(seq);
2651 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2654 CopHINTS_set(&PL_compiling, PL_hints);
2656 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2659 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2665 =head1 Compile-time scope hooks
2667 =for apidoc Aox||blockhook_register
2669 Register a set of hooks to be called when the Perl lexical scope changes
2670 at compile time. See L<perlguts/"Compile-time scope hooks">.
2676 Perl_blockhook_register(pTHX_ BHK *hk)
2678 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2680 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2687 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2688 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2689 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2692 OP * const o = newOP(OP_PADSV, 0);
2693 o->op_targ = offset;
2699 Perl_newPROG(pTHX_ OP *o)
2703 PERL_ARGS_ASSERT_NEWPROG;
2708 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2709 ((PL_in_eval & EVAL_KEEPERR)
2710 ? OPf_SPECIAL : 0), o);
2711 /* don't use LINKLIST, since PL_eval_root might indirect through
2712 * a rather expensive function call and LINKLIST evaluates its
2713 * argument more than once */
2714 PL_eval_start = op_linklist(PL_eval_root);
2715 PL_eval_root->op_private |= OPpREFCOUNTED;
2716 OpREFCNT_set(PL_eval_root, 1);
2717 PL_eval_root->op_next = 0;
2718 CALL_PEEP(PL_eval_start);
2721 if (o->op_type == OP_STUB) {
2722 PL_comppad_name = 0;
2724 S_op_destroy(aTHX_ o);
2727 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2728 PL_curcop = &PL_compiling;
2729 PL_main_start = LINKLIST(PL_main_root);
2730 PL_main_root->op_private |= OPpREFCOUNTED;
2731 OpREFCNT_set(PL_main_root, 1);
2732 PL_main_root->op_next = 0;
2733 CALL_PEEP(PL_main_start);
2734 finalize_optree(PL_main_root);
2737 /* Register with debugger */
2739 CV * const cv = get_cvs("DB::postponed", 0);
2743 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2745 call_sv(MUTABLE_SV(cv), G_DISCARD);
2752 Perl_localize(pTHX_ OP *o, I32 lex)
2756 PERL_ARGS_ASSERT_LOCALIZE;
2758 if (o->op_flags & OPf_PARENS)
2759 /* [perl #17376]: this appears to be premature, and results in code such as
2760 C< our(%x); > executing in list mode rather than void mode */
2767 if ( PL_parser->bufptr > PL_parser->oldbufptr
2768 && PL_parser->bufptr[-1] == ','
2769 && ckWARN(WARN_PARENTHESIS))
2771 char *s = PL_parser->bufptr;
2774 /* some heuristics to detect a potential error */
2775 while (*s && (strchr(", \t\n", *s)))
2779 if (*s && strchr("@$%*", *s) && *++s
2780 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2783 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2785 while (*s && (strchr(", \t\n", *s)))
2791 if (sigil && (*s == ';' || *s == '=')) {
2792 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2793 "Parentheses missing around \"%s\" list",
2795 ? (PL_parser->in_my == KEY_our
2797 : PL_parser->in_my == KEY_state
2807 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2808 PL_parser->in_my = FALSE;
2809 PL_parser->in_my_stash = NULL;
2814 Perl_jmaybe(pTHX_ OP *o)
2816 PERL_ARGS_ASSERT_JMAYBE;
2818 if (o->op_type == OP_LIST) {
2820 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2821 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2827 S_fold_constants(pTHX_ register OP *o)
2830 register OP * VOL curop;
2832 VOL I32 type = o->op_type;
2837 SV * const oldwarnhook = PL_warnhook;
2838 SV * const olddiehook = PL_diehook;
2842 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2844 if (PL_opargs[type] & OA_RETSCALAR)
2846 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2847 o->op_targ = pad_alloc(type, SVs_PADTMP);
2849 /* integerize op, unless it happens to be C<-foo>.
2850 * XXX should pp_i_negate() do magic string negation instead? */
2851 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2852 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2853 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2855 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2858 if (!(PL_opargs[type] & OA_FOLDCONST))
2863 /* XXX might want a ck_negate() for this */
2864 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2876 /* XXX what about the numeric ops? */
2877 if (PL_hints & HINT_LOCALE)
2882 if (PL_parser && PL_parser->error_count)
2883 goto nope; /* Don't try to run w/ errors */
2885 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2886 const OPCODE type = curop->op_type;
2887 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2889 type != OP_SCALAR &&
2891 type != OP_PUSHMARK)
2897 curop = LINKLIST(o);
2898 old_next = o->op_next;
2902 oldscope = PL_scopestack_ix;
2903 create_eval_scope(G_FAKINGEVAL);
2905 /* Verify that we don't need to save it: */
2906 assert(PL_curcop == &PL_compiling);
2907 StructCopy(&PL_compiling, ¬_compiling, COP);
2908 PL_curcop = ¬_compiling;
2909 /* The above ensures that we run with all the correct hints of the
2910 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2911 assert(IN_PERL_RUNTIME);
2912 PL_warnhook = PERL_WARNHOOK_FATAL;
2919 sv = *(PL_stack_sp--);
2920 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2922 /* Can't simply swipe the SV from the pad, because that relies on
2923 the op being freed "real soon now". Under MAD, this doesn't
2924 happen (see the #ifdef below). */
2927 pad_swipe(o->op_targ, FALSE);
2930 else if (SvTEMP(sv)) { /* grab mortal temp? */
2931 SvREFCNT_inc_simple_void(sv);
2936 /* Something tried to die. Abandon constant folding. */
2937 /* Pretend the error never happened. */
2939 o->op_next = old_next;
2943 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2944 PL_warnhook = oldwarnhook;
2945 PL_diehook = olddiehook;
2946 /* XXX note that this croak may fail as we've already blown away
2947 * the stack - eg any nested evals */
2948 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2951 PL_warnhook = oldwarnhook;
2952 PL_diehook = olddiehook;
2953 PL_curcop = &PL_compiling;
2955 if (PL_scopestack_ix > oldscope)
2956 delete_eval_scope();
2965 if (type == OP_RV2GV)
2966 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2968 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2969 op_getmad(o,newop,'f');
2977 S_gen_constant_list(pTHX_ register OP *o)
2981 const I32 oldtmps_floor = PL_tmps_floor;
2984 if (PL_parser && PL_parser->error_count)
2985 return o; /* Don't attempt to run with errors */
2987 PL_op = curop = LINKLIST(o);
2990 Perl_pp_pushmark(aTHX);
2993 assert (!(curop->op_flags & OPf_SPECIAL));
2994 assert(curop->op_type == OP_RANGE);
2995 Perl_pp_anonlist(aTHX);
2996 PL_tmps_floor = oldtmps_floor;
2998 o->op_type = OP_RV2AV;
2999 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3000 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3001 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3002 o->op_opt = 0; /* needs to be revisited in rpeep() */
3003 curop = ((UNOP*)o)->op_first;
3004 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3006 op_getmad(curop,o,'O');
3015 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3018 if (!o || o->op_type != OP_LIST)
3019 o = newLISTOP(OP_LIST, 0, o, NULL);
3021 o->op_flags &= ~OPf_WANT;
3023 if (!(PL_opargs[type] & OA_MARK))
3024 op_null(cLISTOPo->op_first);
3026 o->op_type = (OPCODE)type;
3027 o->op_ppaddr = PL_ppaddr[type];
3028 o->op_flags |= flags;
3030 o = CHECKOP(type, o);
3031 if (o->op_type != (unsigned)type)
3034 return fold_constants(o);
3038 =head1 Optree Manipulation Functions
3041 /* List constructors */
3044 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3046 Append an item to the list of ops contained directly within a list-type
3047 op, returning the lengthened list. I<first> is the list-type op,
3048 and I<last> is the op to append to the list. I<optype> specifies the
3049 intended opcode for the list. If I<first> is not already a list of the
3050 right type, it will be upgraded into one. If either I<first> or I<last>
3051 is null, the other is returned unchanged.
3057 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3065 if (first->op_type != (unsigned)type
3066 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3068 return newLISTOP(type, 0, first, last);
3071 if (first->op_flags & OPf_KIDS)
3072 ((LISTOP*)first)->op_last->op_sibling = last;
3074 first->op_flags |= OPf_KIDS;
3075 ((LISTOP*)first)->op_first = last;
3077 ((LISTOP*)first)->op_last = last;
3082 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3084 Concatenate the lists of ops contained directly within two list-type ops,
3085 returning the combined list. I<first> and I<last> are the list-type ops
3086 to concatenate. I<optype> specifies the intended opcode for the list.
3087 If either I<first> or I<last> is not already a list of the right type,
3088 it will be upgraded into one. If either I<first> or I<last> is null,
3089 the other is returned unchanged.
3095 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3103 if (first->op_type != (unsigned)type)
3104 return op_prepend_elem(type, first, last);
3106 if (last->op_type != (unsigned)type)
3107 return op_append_elem(type, first, last);
3109 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3110 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3111 first->op_flags |= (last->op_flags & OPf_KIDS);
3114 if (((LISTOP*)last)->op_first && first->op_madprop) {
3115 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3117 while (mp->mad_next)
3119 mp->mad_next = first->op_madprop;
3122 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3125 first->op_madprop = last->op_madprop;
3126 last->op_madprop = 0;
3129 S_op_destroy(aTHX_ last);
3135 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3137 Prepend an item to the list of ops contained directly within a list-type
3138 op, returning the lengthened list. I<first> is the op to prepend to the
3139 list, and I<last> is the list-type op. I<optype> specifies the intended
3140 opcode for the list. If I<last> is not already a list of the right type,
3141 it will be upgraded into one. If either I<first> or I<last> is null,
3142 the other is returned unchanged.
3148 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3156 if (last->op_type == (unsigned)type) {
3157 if (type == OP_LIST) { /* already a PUSHMARK there */
3158 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3159 ((LISTOP*)last)->op_first->op_sibling = first;
3160 if (!(first->op_flags & OPf_PARENS))
3161 last->op_flags &= ~OPf_PARENS;
3164 if (!(last->op_flags & OPf_KIDS)) {
3165 ((LISTOP*)last)->op_last = first;
3166 last->op_flags |= OPf_KIDS;
3168 first->op_sibling = ((LISTOP*)last)->op_first;
3169 ((LISTOP*)last)->op_first = first;
3171 last->op_flags |= OPf_KIDS;
3175 return newLISTOP(type, 0, first, last);
3183 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3186 Newxz(tk, 1, TOKEN);
3187 tk->tk_type = (OPCODE)optype;
3188 tk->tk_type = 12345;
3190 tk->tk_mad = madprop;
3195 Perl_token_free(pTHX_ TOKEN* tk)
3197 PERL_ARGS_ASSERT_TOKEN_FREE;
3199 if (tk->tk_type != 12345)
3201 mad_free(tk->tk_mad);
3206 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3211 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3213 if (tk->tk_type != 12345) {
3214 Perl_warner(aTHX_ packWARN(WARN_MISC),
3215 "Invalid TOKEN object ignored");
3222 /* faked up qw list? */
3224 tm->mad_type == MAD_SV &&
3225 SvPVX((SV *)tm->mad_val)[0] == 'q')
3232 /* pretend constant fold didn't happen? */
3233 if (mp->mad_key == 'f' &&
3234 (o->op_type == OP_CONST ||
3235 o->op_type == OP_GV) )
3237 token_getmad(tk,(OP*)mp->mad_val,slot);
3251 if (mp->mad_key == 'X')
3252 mp->mad_key = slot; /* just change the first one */
3262 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3271 /* pretend constant fold didn't happen? */
3272 if (mp->mad_key == 'f' &&
3273 (o->op_type == OP_CONST ||
3274 o->op_type == OP_GV) )
3276 op_getmad(from,(OP*)mp->mad_val,slot);
3283 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3286 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3292 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3301 /* pretend constant fold didn't happen? */
3302 if (mp->mad_key == 'f' &&
3303 (o->op_type == OP_CONST ||
3304 o->op_type == OP_GV) )
3306 op_getmad(from,(OP*)mp->mad_val,slot);
3313 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3316 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3320 PerlIO_printf(PerlIO_stderr(),
3321 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3327 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3345 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3349 addmad(tm, &(o->op_madprop), slot);
3353 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3374 Perl_newMADsv(pTHX_ char key, SV* sv)
3376 PERL_ARGS_ASSERT_NEWMADSV;
3378 return newMADPROP(key, MAD_SV, sv, 0);
3382 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3384 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3387 mp->mad_vlen = vlen;
3388 mp->mad_type = type;
3390 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3395 Perl_mad_free(pTHX_ MADPROP* mp)
3397 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3401 mad_free(mp->mad_next);
3402 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3403 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3404 switch (mp->mad_type) {
3408 Safefree((char*)mp->mad_val);
3411 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3412 op_free((OP*)mp->mad_val);
3415 sv_free(MUTABLE_SV(mp->mad_val));
3418 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3421 PerlMemShared_free(mp);
3427 =head1 Optree construction
3429 =for apidoc Am|OP *|newNULLLIST
3431 Constructs, checks, and returns a new C<stub> op, which represents an
3432 empty list expression.
3438 Perl_newNULLLIST(pTHX)
3440 return newOP(OP_STUB, 0);
3444 S_force_list(pTHX_ OP *o)
3446 if (!o || o->op_type != OP_LIST)
3447 o = newLISTOP(OP_LIST, 0, o, NULL);
3453 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3455 Constructs, checks, and returns an op of any list type. I<type> is
3456 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3457 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3458 supply up to two ops to be direct children of the list op; they are
3459 consumed by this function and become part of the constructed op tree.
3465 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3470 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3472 NewOp(1101, listop, 1, LISTOP);
3474 listop->op_type = (OPCODE)type;
3475 listop->op_ppaddr = PL_ppaddr[type];
3478 listop->op_flags = (U8)flags;
3482 else if (!first && last)
3485 first->op_sibling = last;
3486 listop->op_first = first;
3487 listop->op_last = last;
3488 if (type == OP_LIST) {
3489 OP* const pushop = newOP(OP_PUSHMARK, 0);
3490 pushop->op_sibling = first;
3491 listop->op_first = pushop;
3492 listop->op_flags |= OPf_KIDS;
3494 listop->op_last = pushop;
3497 return CHECKOP(type, listop);
3501 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3503 Constructs, checks, and returns an op of any base type (any type that
3504 has no extra fields). I<type> is the opcode. I<flags> gives the
3505 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3512 Perl_newOP(pTHX_ I32 type, I32 flags)
3517 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3518 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3519 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3520 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3522 NewOp(1101, o, 1, OP);
3523 o->op_type = (OPCODE)type;
3524 o->op_ppaddr = PL_ppaddr[type];
3525 o->op_flags = (U8)flags;
3527 o->op_latefreed = 0;
3531 o->op_private = (U8)(0 | (flags >> 8));
3532 if (PL_opargs[type] & OA_RETSCALAR)
3534 if (PL_opargs[type] & OA_TARGET)
3535 o->op_targ = pad_alloc(type, SVs_PADTMP);
3536 return CHECKOP(type, o);
3540 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3542 Constructs, checks, and returns an op of any unary type. I<type> is
3543 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3544 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3545 bits, the eight bits of C<op_private>, except that the bit with value 1
3546 is automatically set. I<first> supplies an optional op to be the direct
3547 child of the unary op; it is consumed by this function and become part
3548 of the constructed op tree.
3554 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3559 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3560 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3561 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3562 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3563 || type == OP_SASSIGN
3564 || type == OP_ENTERTRY
3565 || type == OP_NULL );
3568 first = newOP(OP_STUB, 0);
3569 if (PL_opargs[type] & OA_MARK)
3570 first = force_list(first);
3572 NewOp(1101, unop, 1, UNOP);
3573 unop->op_type = (OPCODE)type;
3574 unop->op_ppaddr = PL_ppaddr[type];
3575 unop->op_first = first;
3576 unop->op_flags = (U8)(flags | OPf_KIDS);
3577 unop->op_private = (U8)(1 | (flags >> 8));
3578 unop = (UNOP*) CHECKOP(type, unop);
3582 return fold_constants((OP *) unop);
3586 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3588 Constructs, checks, and returns an op of any binary type. I<type>
3589 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3590 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3591 the eight bits of C<op_private>, except that the bit with value 1 or
3592 2 is automatically set as required. I<first> and I<last> supply up to
3593 two ops to be the direct children of the binary op; they are consumed
3594 by this function and become part of the constructed op tree.
3600 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3605 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3606 || type == OP_SASSIGN || type == OP_NULL );
3608 NewOp(1101, binop, 1, BINOP);
3611 first = newOP(OP_NULL, 0);
3613 binop->op_type = (OPCODE)type;
3614 binop->op_ppaddr = PL_ppaddr[type];
3615 binop->op_first = first;
3616 binop->op_flags = (U8)(flags | OPf_KIDS);
3619 binop->op_private = (U8)(1 | (flags >> 8));
3622 binop->op_private = (U8)(2 | (flags >> 8));
3623 first->op_sibling = last;
3626 binop = (BINOP*)CHECKOP(type, binop);
3627 if (binop->op_next || binop->op_type != (OPCODE)type)
3630 binop->op_last = binop->op_first->op_sibling;
3632 return fold_constants((OP *)binop);
3635 static int uvcompare(const void *a, const void *b)
3636 __attribute__nonnull__(1)
3637 __attribute__nonnull__(2)
3638 __attribute__pure__;
3639 static int uvcompare(const void *a, const void *b)
3641 if (*((const UV *)a) < (*(const UV *)b))
3643 if (*((const UV *)a) > (*(const UV *)b))
3645 if (*((const UV *)a+1) < (*(const UV *)b+1))
3647 if (*((const UV *)a+1) > (*(const UV *)b+1))
3653 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3656 SV * const tstr = ((SVOP*)expr)->op_sv;
3659 (repl->op_type == OP_NULL)
3660 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3662 ((SVOP*)repl)->op_sv;
3665 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3666 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3670 register short *tbl;
3672 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3673 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3674 I32 del = o->op_private & OPpTRANS_DELETE;
3677 PERL_ARGS_ASSERT_PMTRANS;
3679 PL_hints |= HINT_BLOCK_SCOPE;
3682 o->op_private |= OPpTRANS_FROM_UTF;
3685 o->op_private |= OPpTRANS_TO_UTF;
3687 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3688 SV* const listsv = newSVpvs("# comment\n");
3690 const U8* tend = t + tlen;
3691 const U8* rend = r + rlen;
3705 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3706 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3709 const U32 flags = UTF8_ALLOW_DEFAULT;
3713 t = tsave = bytes_to_utf8(t, &len);
3716 if (!to_utf && rlen) {
3718 r = rsave = bytes_to_utf8(r, &len);
3722 /* There are several snags with this code on EBCDIC:
3723 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3724 2. scan_const() in toke.c has encoded chars in native encoding which makes
3725 ranges at least in EBCDIC 0..255 range the bottom odd.
3729 U8 tmpbuf[UTF8_MAXBYTES+1];
3732 Newx(cp, 2*tlen, UV);
3734 transv = newSVpvs("");
3736 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3738 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3740 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3744 cp[2*i+1] = cp[2*i];
3748 qsort(cp, i, 2*sizeof(UV), uvcompare);
3749 for (j = 0; j < i; j++) {
3751 diff = val - nextmin;
3753 t = uvuni_to_utf8(tmpbuf,nextmin);
3754 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3756 U8 range_mark = UTF_TO_NATIVE(0xff);
3757 t = uvuni_to_utf8(tmpbuf, val - 1);
3758 sv_catpvn(transv, (char *)&range_mark, 1);
3759 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3766 t = uvuni_to_utf8(tmpbuf,nextmin);
3767 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3769 U8 range_mark = UTF_TO_NATIVE(0xff);
3770 sv_catpvn(transv, (char *)&range_mark, 1);
3772 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3773 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3774 t = (const U8*)SvPVX_const(transv);
3775 tlen = SvCUR(transv);
3779 else if (!rlen && !del) {
3780 r = t; rlen = tlen; rend = tend;
3783 if ((!rlen && !del) || t == r ||
3784 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3786 o->op_private |= OPpTRANS_IDENTICAL;
3790 while (t < tend || tfirst <= tlast) {
3791 /* see if we need more "t" chars */
3792 if (tfirst > tlast) {
3793 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3795 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3797 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3804 /* now see if we need more "r" chars */
3805 if (rfirst > rlast) {
3807 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3809 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3811 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3820 rfirst = rlast = 0xffffffff;
3824 /* now see which range will peter our first, if either. */
3825 tdiff = tlast - tfirst;
3826 rdiff = rlast - rfirst;
3833 if (rfirst == 0xffffffff) {
3834 diff = tdiff; /* oops, pretend rdiff is infinite */
3836 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3837 (long)tfirst, (long)tlast);
3839 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3843 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3844 (long)tfirst, (long)(tfirst + diff),
3847 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3848 (long)tfirst, (long)rfirst);
3850 if (rfirst + diff > max)
3851 max = rfirst + diff;
3853 grows = (tfirst < rfirst &&
3854 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3866 else if (max > 0xff)
3871 PerlMemShared_free(cPVOPo->op_pv);
3872 cPVOPo->op_pv = NULL;
3874 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3876 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3877 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3878 PAD_SETSV(cPADOPo->op_padix, swash);
3880 SvREADONLY_on(swash);
3882 cSVOPo->op_sv = swash;
3884 SvREFCNT_dec(listsv);
3885 SvREFCNT_dec(transv);
3887 if (!del && havefinal && rlen)
3888 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3889 newSVuv((UV)final), 0);
3892 o->op_private |= OPpTRANS_GROWS;
3898 op_getmad(expr,o,'e');
3899 op_getmad(repl,o,'r');
3907 tbl = (short*)cPVOPo->op_pv;
3909 Zero(tbl, 256, short);
3910 for (i = 0; i < (I32)tlen; i++)
3912 for (i = 0, j = 0; i < 256; i++) {
3914 if (j >= (I32)rlen) {
3923 if (i < 128 && r[j] >= 128)
3933 o->op_private |= OPpTRANS_IDENTICAL;
3935 else if (j >= (I32)rlen)
3940 PerlMemShared_realloc(tbl,
3941 (0x101+rlen-j) * sizeof(short));
3942 cPVOPo->op_pv = (char*)tbl;
3944 tbl[0x100] = (short)(rlen - j);
3945 for (i=0; i < (I32)rlen - j; i++)
3946 tbl[0x101+i] = r[j+i];
3950 if (!rlen && !del) {
3953 o->op_private |= OPpTRANS_IDENTICAL;
3955 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3956 o->op_private |= OPpTRANS_IDENTICAL;
3958 for (i = 0; i < 256; i++)
3960 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3961 if (j >= (I32)rlen) {
3963 if (tbl[t[i]] == -1)
3969 if (tbl[t[i]] == -1) {
3970 if (t[i] < 128 && r[j] >= 128)
3977 if(del && rlen == tlen) {
3978 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3979 } else if(rlen > tlen) {
3980 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3984 o->op_private |= OPpTRANS_GROWS;
3986 op_getmad(expr,o,'e');
3987 op_getmad(repl,o,'r');
3997 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3999 Constructs, checks, and returns an op of any pattern matching type.
4000 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4001 and, shifted up eight bits, the eight bits of C<op_private>.
4007 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4012 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4014 NewOp(1101, pmop, 1, PMOP);
4015 pmop->op_type = (OPCODE)type;
4016 pmop->op_ppaddr = PL_ppaddr[type];
4017 pmop->op_flags = (U8)flags;
4018 pmop->op_private = (U8)(0 | (flags >> 8));
4020 if (PL_hints & HINT_RE_TAINT)
4021 pmop->op_pmflags |= PMf_RETAINT;
4022 if (PL_hints & HINT_LOCALE) {
4023 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4025 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
4026 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4028 if (PL_hints & HINT_RE_FLAGS) {
4029 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4030 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4032 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4033 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4034 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4036 if (reflags && SvOK(reflags)) {
4037 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4043 assert(SvPOK(PL_regex_pad[0]));
4044 if (SvCUR(PL_regex_pad[0])) {
4045 /* Pop off the "packed" IV from the end. */
4046 SV *const repointer_list = PL_regex_pad[0];
4047 const char *p = SvEND(repointer_list) - sizeof(IV);
4048 const IV offset = *((IV*)p);
4050 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4052 SvEND_set(repointer_list, p);
4054 pmop->op_pmoffset = offset;
4055 /* This slot should be free, so assert this: */
4056 assert(PL_regex_pad[offset] == &PL_sv_undef);
4058 SV * const repointer = &PL_sv_undef;
4059 av_push(PL_regex_padav, repointer);
4060 pmop->op_pmoffset = av_len(PL_regex_padav);
4061 PL_regex_pad = AvARRAY(PL_regex_padav);
4065 return CHECKOP(type, pmop);
4068 /* Given some sort of match op o, and an expression expr containing a
4069 * pattern, either compile expr into a regex and attach it to o (if it's
4070 * constant), or convert expr into a runtime regcomp op sequence (if it's
4073 * isreg indicates that the pattern is part of a regex construct, eg
4074 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4075 * split "pattern", which aren't. In the former case, expr will be a list
4076 * if the pattern contains more than one term (eg /a$b/) or if it contains
4077 * a replacement, ie s/// or tr///.
4081 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4086 I32 repl_has_vars = 0;
4090 PERL_ARGS_ASSERT_PMRUNTIME;
4093 o->op_type == OP_SUBST
4094 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4096 /* last element in list is the replacement; pop it */
4098 repl = cLISTOPx(expr)->op_last;
4099 kid = cLISTOPx(expr)->op_first;
4100 while (kid->op_sibling != repl)
4101 kid = kid->op_sibling;
4102 kid->op_sibling = NULL;
4103 cLISTOPx(expr)->op_last = kid;
4106 if (isreg && expr->op_type == OP_LIST &&
4107 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4109 /* convert single element list to element */
4110 OP* const oe = expr;
4111 expr = cLISTOPx(oe)->op_first->op_sibling;
4112 cLISTOPx(oe)->op_first->op_sibling = NULL;
4113 cLISTOPx(oe)->op_last = NULL;
4117 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4118 return pmtrans(o, expr, repl);
4121 reglist = isreg && expr->op_type == OP_LIST;
4125 PL_hints |= HINT_BLOCK_SCOPE;
4128 if (expr->op_type == OP_CONST) {
4129 SV *pat = ((SVOP*)expr)->op_sv;
4130 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4132 if (o->op_flags & OPf_SPECIAL)
4133 pm_flags |= RXf_SPLIT;
4136 assert (SvUTF8(pat));
4137 } else if (SvUTF8(pat)) {
4138 /* Not doing UTF-8, despite what the SV says. Is this only if we're
4139 trapped in use 'bytes'? */
4140 /* Make a copy of the octet sequence, but without the flag on, as
4141 the compiler now honours the SvUTF8 flag on pat. */
4143 const char *const p = SvPV(pat, len);
4144 pat = newSVpvn_flags(p, len, SVs_TEMP);
4147 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4150 op_getmad(expr,(OP*)pm,'e');
4156 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4157 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4159 : OP_REGCMAYBE),0,expr);
4161 NewOp(1101, rcop, 1, LOGOP);
4162 rcop->op_type = OP_REGCOMP;
4163 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4164 rcop->op_first = scalar(expr);
4165 rcop->op_flags |= OPf_KIDS
4166 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4167 | (reglist ? OPf_STACKED : 0);
4168 rcop->op_private = 1;
4171 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4173 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4174 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4176 /* establish postfix order */
4177 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4179 rcop->op_next = expr;
4180 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4183 rcop->op_next = LINKLIST(expr);
4184 expr->op_next = (OP*)rcop;
4187 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4192 if (pm->op_pmflags & PMf_EVAL) {
4194 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4195 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4197 else if (repl->op_type == OP_CONST)
4201 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4202 if (curop->op_type == OP_SCOPE
4203 || curop->op_type == OP_LEAVE
4204 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4205 if (curop->op_type == OP_GV) {
4206 GV * const gv = cGVOPx_gv(curop);
4208 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4211 else if (curop->op_type == OP_RV2CV)
4213 else if (curop->op_type == OP_RV2SV ||
4214 curop->op_type == OP_RV2AV ||
4215 curop->op_type == OP_RV2HV ||
4216 curop->op_type == OP_RV2GV) {
4217 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4220 else if (curop->op_type == OP_PADSV ||
4221 curop->op_type == OP_PADAV ||
4222 curop->op_type == OP_PADHV ||
4223 curop->op_type == OP_PADANY)
4227 else if (curop->op_type == OP_PUSHRE)
4228 NOOP; /* Okay here, dangerous in newASSIGNOP */
4238 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4240 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4241 op_prepend_elem(o->op_type, scalar(repl), o);
4244 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4245 pm->op_pmflags |= PMf_MAYBE_CONST;
4247 NewOp(1101, rcop, 1, LOGOP);
4248 rcop->op_type = OP_SUBSTCONT;
4249 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4250 rcop->op_first = scalar(repl);
4251 rcop->op_flags |= OPf_KIDS;
4252 rcop->op_private = 1;
4255 /* establish postfix order */
4256 rcop->op_next = LINKLIST(repl);
4257 repl->op_next = (OP*)rcop;
4259 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4260 assert(!(pm->op_pmflags & PMf_ONCE));
4261 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4270 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4272 Constructs, checks, and returns an op of any type that involves an
4273 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4274 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4275 takes ownership of one reference to it.
4281 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4286 PERL_ARGS_ASSERT_NEWSVOP;
4288 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4289 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4290 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4292 NewOp(1101, svop, 1, SVOP);
4293 svop->op_type = (OPCODE)type;
4294 svop->op_ppaddr = PL_ppaddr[type];
4296 svop->op_next = (OP*)svop;
4297 svop->op_flags = (U8)flags;
4298 if (PL_opargs[type] & OA_RETSCALAR)
4300 if (PL_opargs[type] & OA_TARGET)
4301 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4302 return CHECKOP(type, svop);
4308 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4310 Constructs, checks, and returns an op of any type that involves a
4311 reference to a pad element. I<type> is the opcode. I<flags> gives the
4312 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4313 is populated with I<sv>; this function takes ownership of one reference
4316 This function only exists if Perl has been compiled to use ithreads.
4322 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4327 PERL_ARGS_ASSERT_NEWPADOP;
4329 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4330 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4331 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4333 NewOp(1101, padop, 1, PADOP);
4334 padop->op_type = (OPCODE)type;
4335 padop->op_ppaddr = PL_ppaddr[type];
4336 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4337 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4338 PAD_SETSV(padop->op_padix, sv);
4341 padop->op_next = (OP*)padop;
4342 padop->op_flags = (U8)flags;
4343 if (PL_opargs[type] & OA_RETSCALAR)
4345 if (PL_opargs[type] & OA_TARGET)
4346 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4347 return CHECKOP(type, padop);
4350 #endif /* !USE_ITHREADS */
4353 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4355 Constructs, checks, and returns an op of any type that involves an
4356 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4357 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4358 reference; calling this function does not transfer ownership of any
4365 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4369 PERL_ARGS_ASSERT_NEWGVOP;
4373 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4375 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4380 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4382 Constructs, checks, and returns an op of any type that involves an
4383 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4384 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4385 must have been allocated using L</PerlMemShared_malloc>; the memory will
4386 be freed when the op is destroyed.
4392 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4397 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4398 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4400 NewOp(1101, pvop, 1, PVOP);
4401 pvop->op_type = (OPCODE)type;
4402 pvop->op_ppaddr = PL_ppaddr[type];
4404 pvop->op_next = (OP*)pvop;
4405 pvop->op_flags = (U8)flags;
4406 if (PL_opargs[type] & OA_RETSCALAR)
4408 if (PL_opargs[type] & OA_TARGET)
4409 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4410 return CHECKOP(type, pvop);
4418 Perl_package(pTHX_ OP *o)
4421 SV *const sv = cSVOPo->op_sv;
4426 PERL_ARGS_ASSERT_PACKAGE;
4428 save_hptr(&PL_curstash);
4429 save_item(PL_curstname);
4431 PL_curstash = gv_stashsv(sv, GV_ADD);
4433 sv_setsv(PL_curstname, sv);
4435 PL_hints |= HINT_BLOCK_SCOPE;
4436 PL_parser->copline = NOLINE;
4437 PL_parser->expect = XSTATE;
4442 if (!PL_madskills) {
4447 pegop = newOP(OP_NULL,0);
4448 op_getmad(o,pegop,'P');
4454 Perl_package_version( pTHX_ OP *v )
4457 U32 savehints = PL_hints;
4458 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4459 PL_hints &= ~HINT_STRICT_VARS;
4460 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4461 PL_hints = savehints;
4470 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4477 OP *pegop = newOP(OP_NULL,0);
4479 SV *use_version = NULL;
4481 PERL_ARGS_ASSERT_UTILIZE;
4483 if (idop->op_type != OP_CONST)
4484 Perl_croak(aTHX_ "Module name must be constant");
4487 op_getmad(idop,pegop,'U');
4492 SV * const vesv = ((SVOP*)version)->op_sv;
4495 op_getmad(version,pegop,'V');
4496 if (!arg && !SvNIOKp(vesv)) {
4503 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4504 Perl_croak(aTHX_ "Version number must be a constant number");
4506 /* Make copy of idop so we don't free it twice */
4507 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4509 /* Fake up a method call to VERSION */
4510 meth = newSVpvs_share("VERSION");
4511 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4512 op_append_elem(OP_LIST,
4513 op_prepend_elem(OP_LIST, pack, list(version)),
4514 newSVOP(OP_METHOD_NAMED, 0, meth)));
4518 /* Fake up an import/unimport */
4519 if (arg && arg->op_type == OP_STUB) {
4521 op_getmad(arg,pegop,'S');
4522 imop = arg; /* no import on explicit () */
4524 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4525 imop = NULL; /* use 5.0; */
4527 use_version = ((SVOP*)idop)->op_sv;
4529 idop->op_private |= OPpCONST_NOVER;
4535 op_getmad(arg,pegop,'A');
4537 /* Make copy of idop so we don't free it twice */
4538 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4540 /* Fake up a method call to import/unimport */
4542 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4543 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4544 op_append_elem(OP_LIST,
4545 op_prepend_elem(OP_LIST, pack, list(arg)),
4546 newSVOP(OP_METHOD_NAMED, 0, meth)));
4549 /* Fake up the BEGIN {}, which does its thing immediately. */
4551 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4554 op_append_elem(OP_LINESEQ,
4555 op_append_elem(OP_LINESEQ,
4556 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4557 newSTATEOP(0, NULL, veop)),
4558 newSTATEOP(0, NULL, imop) ));
4561 /* If we request a version >= 5.9.5, load feature.pm with the
4562 * feature bundle that corresponds to the required version. */
4563 use_version = sv_2mortal(new_version(use_version));
4565 if (vcmp(use_version,
4566 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4567 SV *const importsv = vnormal(use_version);
4568 *SvPVX_mutable(importsv) = ':';
4569 ENTER_with_name("load_feature");
4570 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4571 LEAVE_with_name("load_feature");
4573 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4574 if (vcmp(use_version,
4575 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4576 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4580 /* The "did you use incorrect case?" warning used to be here.
4581 * The problem is that on case-insensitive filesystems one
4582 * might get false positives for "use" (and "require"):
4583 * "use Strict" or "require CARP" will work. This causes
4584 * portability problems for the script: in case-strict
4585 * filesystems the script will stop working.
4587 * The "incorrect case" warning checked whether "use Foo"
4588 * imported "Foo" to your namespace, but that is wrong, too:
4589 * there is no requirement nor promise in the language that
4590 * a Foo.pm should or would contain anything in package "Foo".
4592 * There is very little Configure-wise that can be done, either:
4593 * the case-sensitivity of the build filesystem of Perl does not
4594 * help in guessing the case-sensitivity of the runtime environment.
4597 PL_hints |= HINT_BLOCK_SCOPE;
4598 PL_parser->copline = NOLINE;
4599 PL_parser->expect = XSTATE;
4600 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4601 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4605 if (!PL_madskills) {
4606 /* FIXME - don't allocate pegop if !PL_madskills */
4615 =head1 Embedding Functions
4617 =for apidoc load_module
4619 Loads the module whose name is pointed to by the string part of name.
4620 Note that the actual module name, not its filename, should be given.
4621 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4622 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4623 (or 0 for no flags). ver, if specified, provides version semantics
4624 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4625 arguments can be used to specify arguments to the module's import()
4626 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4627 terminated with a final NULL pointer. Note that this list can only
4628 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4629 Otherwise at least a single NULL pointer to designate the default
4630 import list is required.
4635 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4639 PERL_ARGS_ASSERT_LOAD_MODULE;
4641 va_start(args, ver);
4642 vload_module(flags, name, ver, &args);
4646 #ifdef PERL_IMPLICIT_CONTEXT
4648 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4652 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4653 va_start(args, ver);
4654 vload_module(flags, name, ver, &args);
4660 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4664 OP * const modname = newSVOP(OP_CONST, 0, name);
4666 PERL_ARGS_ASSERT_VLOAD_MODULE;
4668 modname->op_private |= OPpCONST_BARE;
4670 veop = newSVOP(OP_CONST, 0, ver);
4674 if (flags & PERL_LOADMOD_NOIMPORT) {
4675 imop = sawparens(newNULLLIST());
4677 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4678 imop = va_arg(*args, OP*);
4683 sv = va_arg(*args, SV*);
4685 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4686 sv = va_arg(*args, SV*);
4690 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4691 * that it has a PL_parser to play with while doing that, and also
4692 * that it doesn't mess with any existing parser, by creating a tmp
4693 * new parser with lex_start(). This won't actually be used for much,
4694 * since pp_require() will create another parser for the real work. */
4697 SAVEVPTR(PL_curcop);
4698 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4699 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4700 veop, modname, imop);
4705 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4711 PERL_ARGS_ASSERT_DOFILE;
4713 if (!force_builtin) {
4714 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4715 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4716 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4717 gv = gvp ? *gvp : NULL;
4721 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4722 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4723 op_append_elem(OP_LIST, term,
4724 scalar(newUNOP(OP_RV2CV, 0,
4725 newGVOP(OP_GV, 0, gv))))));
4728 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4734 =head1 Optree construction
4736 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4738 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4739 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4740 be set automatically, and, shifted up eight bits, the eight bits of
4741 C<op_private>, except that the bit with value 1 or 2 is automatically
4742 set as required. I<listval> and I<subscript> supply the parameters of
4743 the slice; they are consumed by this function and become part of the
4744 constructed op tree.
4750 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4752 return newBINOP(OP_LSLICE, flags,
4753 list(force_list(subscript)),
4754 list(force_list(listval)) );
4758 S_is_list_assignment(pTHX_ register const OP *o)
4766 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4767 o = cUNOPo->op_first;
4769 flags = o->op_flags;
4771 if (type == OP_COND_EXPR) {
4772 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4773 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4778 yyerror("Assignment to both a list and a scalar");
4782 if (type == OP_LIST &&
4783 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4784 o->op_private & OPpLVAL_INTRO)
4787 if (type == OP_LIST || flags & OPf_PARENS ||
4788 type == OP_RV2AV || type == OP_RV2HV ||
4789 type == OP_ASLICE || type == OP_HSLICE)
4792 if (type == OP_PADAV || type == OP_PADHV)
4795 if (type == OP_RV2SV)
4802 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4804 Constructs, checks, and returns an assignment op. I<left> and I<right>
4805 supply the parameters of the assignment; they are consumed by this
4806 function and become part of the constructed op tree.
4808 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4809 a suitable conditional optree is constructed. If I<optype> is the opcode
4810 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4811 performs the binary operation and assigns the result to the left argument.
4812 Either way, if I<optype> is non-zero then I<flags> has no effect.
4814 If I<optype> is zero, then a plain scalar or list assignment is
4815 constructed. Which type of assignment it is is automatically determined.
4816 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4817 will be set automatically, and, shifted up eight bits, the eight bits
4818 of C<op_private>, except that the bit with value 1 or 2 is automatically
4825 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4831 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4832 return newLOGOP(optype, 0,
4833 op_lvalue(scalar(left), optype),
4834 newUNOP(OP_SASSIGN, 0, scalar(right)));
4837 return newBINOP(optype, OPf_STACKED,
4838 op_lvalue(scalar(left), optype), scalar(right));
4842 if (is_list_assignment(left)) {
4843 static const char no_list_state[] = "Initialization of state variables"
4844 " in list context currently forbidden";
4846 bool maybe_common_vars = TRUE;
4849 /* Grandfathering $[ assignment here. Bletch.*/
4850 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4851 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4852 left = op_lvalue(left, OP_AASSIGN);
4855 else if (left->op_type == OP_CONST) {
4856 deprecate("assignment to $[");
4858 /* Result of assignment is always 1 (or we'd be dead already) */
4859 return newSVOP(OP_CONST, 0, newSViv(1));
4861 curop = list(force_list(left));
4862 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4863 o->op_private = (U8)(0 | (flags >> 8));
4865 if ((left->op_type == OP_LIST
4866 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4868 OP* lop = ((LISTOP*)left)->op_first;
4869 maybe_common_vars = FALSE;
4871 if (lop->op_type == OP_PADSV ||
4872 lop->op_type == OP_PADAV ||
4873 lop->op_type == OP_PADHV ||
4874 lop->op_type == OP_PADANY) {
4875 if (!(lop->op_private & OPpLVAL_INTRO))
4876 maybe_common_vars = TRUE;
4878 if (lop->op_private & OPpPAD_STATE) {
4879 if (left->op_private & OPpLVAL_INTRO) {
4880 /* Each variable in state($a, $b, $c) = ... */
4883 /* Each state variable in
4884 (state $a, my $b, our $c, $d, undef) = ... */
4886 yyerror(no_list_state);
4888 /* Each my variable in
4889 (state $a, my $b, our $c, $d, undef) = ... */
4891 } else if (lop->op_type == OP_UNDEF ||
4892 lop->op_type == OP_PUSHMARK) {
4893 /* undef may be interesting in
4894 (state $a, undef, state $c) */
4896 /* Other ops in the list. */
4897 maybe_common_vars = TRUE;
4899 lop = lop->op_sibling;
4902 else if ((left->op_private & OPpLVAL_INTRO)
4903 && ( left->op_type == OP_PADSV
4904 || left->op_type == OP_PADAV
4905 || left->op_type == OP_PADHV
4906 || left->op_type == OP_PADANY))
4908 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4909 if (left->op_private & OPpPAD_STATE) {
4910 /* All single variable list context state assignments, hence
4920 yyerror(no_list_state);
4924 /* PL_generation sorcery:
4925 * an assignment like ($a,$b) = ($c,$d) is easier than
4926 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4927 * To detect whether there are common vars, the global var
4928 * PL_generation is incremented for each assign op we compile.
4929 * Then, while compiling the assign op, we run through all the
4930 * variables on both sides of the assignment, setting a spare slot
4931 * in each of them to PL_generation. If any of them already have
4932 * that value, we know we've got commonality. We could use a
4933 * single bit marker, but then we'd have to make 2 passes, first
4934 * to clear the flag, then to test and set it. To find somewhere
4935 * to store these values, evil chicanery is done with SvUVX().
4938 if (maybe_common_vars) {
4941 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4942 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4943 if (curop->op_type == OP_GV) {
4944 GV *gv = cGVOPx_gv(curop);
4946 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4948 GvASSIGN_GENERATION_set(gv, PL_generation);
4950 else if (curop->op_type == OP_PADSV ||
4951 curop->op_type == OP_PADAV ||
4952 curop->op_type == OP_PADHV ||
4953 curop->op_type == OP_PADANY)
4955 if (PAD_COMPNAME_GEN(curop->op_targ)
4956 == (STRLEN)PL_generation)
4958 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4961 else if (curop->op_type == OP_RV2CV)
4963 else if (curop->op_type == OP_RV2SV ||
4964 curop->op_type == OP_RV2AV ||
4965 curop->op_type == OP_RV2HV ||
4966 curop->op_type == OP_RV2GV) {
4967 if (lastop->op_type != OP_GV) /* funny deref? */
4970 else if (curop->op_type == OP_PUSHRE) {
4972 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4973 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4975 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4977 GvASSIGN_GENERATION_set(gv, PL_generation);
4981 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4984 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4986 GvASSIGN_GENERATION_set(gv, PL_generation);
4996 o->op_private |= OPpASSIGN_COMMON;
4999 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5000 OP* tmpop = ((LISTOP*)right)->op_first;
5001 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5002 PMOP * const pm = (PMOP*)tmpop;
5003 if (left->op_type == OP_RV2AV &&
5004 !(left->op_private & OPpLVAL_INTRO) &&
5005 !(o->op_private & OPpASSIGN_COMMON) )
5007 tmpop = ((UNOP*)left)->op_first;
5008 if (tmpop->op_type == OP_GV
5010 && !pm->op_pmreplrootu.op_pmtargetoff
5012 && !pm->op_pmreplrootu.op_pmtargetgv
5016 pm->op_pmreplrootu.op_pmtargetoff
5017 = cPADOPx(tmpop)->op_padix;
5018 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5020 pm->op_pmreplrootu.op_pmtargetgv
5021 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5022 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5024 pm->op_pmflags |= PMf_ONCE;
5025 tmpop = cUNOPo->op_first; /* to list (nulled) */
5026 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5027 tmpop->op_sibling = NULL; /* don't free split */
5028 right->op_next = tmpop->op_next; /* fix starting loc */
5029 op_free(o); /* blow off assign */
5030 right->op_flags &= ~OPf_WANT;
5031 /* "I don't know and I don't care." */
5036 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5037 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5039 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5040 if (SvIOK(sv) && SvIVX(sv) == 0)
5041 sv_setiv(sv, PL_modcount+1);
5049 right = newOP(OP_UNDEF, 0);
5050 if (right->op_type == OP_READLINE) {
5051 right->op_flags |= OPf_STACKED;
5052 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5056 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
5057 o = newBINOP(OP_SASSIGN, flags,
5058 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5062 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
5063 deprecate("assignment to $[");
5065 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
5066 o->op_private |= OPpCONST_ARYBASE;
5074 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5076 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5077 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5078 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5079 If I<label> is non-null, it supplies the name of a label to attach to
5080 the state op; this function takes ownership of the memory pointed at by
5081 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5084 If I<o> is null, the state op is returned. Otherwise the state op is
5085 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5086 is consumed by this function and becomes part of the returned op tree.
5092 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5095 const U32 seq = intro_my();
5098 NewOp(1101, cop, 1, COP);
5099 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5100 cop->op_type = OP_DBSTATE;
5101 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5104 cop->op_type = OP_NEXTSTATE;
5105 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5107 cop->op_flags = (U8)flags;
5108 CopHINTS_set(cop, PL_hints);
5110 cop->op_private |= NATIVE_HINTS;
5112 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5113 cop->op_next = (OP*)cop;
5116 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
5117 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
5119 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5120 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5122 Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
5124 PL_hints |= HINT_BLOCK_SCOPE;
5125 /* It seems that we need to defer freeing this pointer, as other parts
5126 of the grammar end up wanting to copy it after this op has been
5131 if (PL_parser && PL_parser->copline == NOLINE)
5132 CopLINE_set(cop, CopLINE(PL_curcop));
5134 CopLINE_set(cop, PL_parser->copline);
5136 PL_parser->copline = NOLINE;
5139 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5141 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5143 CopSTASH_set(cop, PL_curstash);
5145 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5146 /* this line can have a breakpoint - store the cop in IV */
5147 AV *av = CopFILEAVx(PL_curcop);
5149 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5150 if (svp && *svp != &PL_sv_undef ) {
5151 (void)SvIOK_on(*svp);
5152 SvIV_set(*svp, PTR2IV(cop));
5157 if (flags & OPf_SPECIAL)
5159 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5163 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5165 Constructs, checks, and returns a logical (flow control) op. I<type>
5166 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5167 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5168 the eight bits of C<op_private>, except that the bit with value 1 is
5169 automatically set. I<first> supplies the expression controlling the
5170 flow, and I<other> supplies the side (alternate) chain of ops; they are
5171 consumed by this function and become part of the constructed op tree.
5177 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5181 PERL_ARGS_ASSERT_NEWLOGOP;
5183 return new_logop(type, flags, &first, &other);
5187 S_search_const(pTHX_ OP *o)
5189 PERL_ARGS_ASSERT_SEARCH_CONST;
5191 switch (o->op_type) {
5195 if (o->op_flags & OPf_KIDS)
5196 return search_const(cUNOPo->op_first);
5203 if (!(o->op_flags & OPf_KIDS))
5205 kid = cLISTOPo->op_first;
5207 switch (kid->op_type) {
5211 kid = kid->op_sibling;
5214 if (kid != cLISTOPo->op_last)
5220 kid = cLISTOPo->op_last;
5222 return search_const(kid);
5230 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5238 int prepend_not = 0;
5240 PERL_ARGS_ASSERT_NEW_LOGOP;
5245 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5246 return newBINOP(type, flags, scalar(first), scalar(other));
5248 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5250 scalarboolean(first);
5251 /* optimize AND and OR ops that have NOTs as children */
5252 if (first->op_type == OP_NOT
5253 && (first->op_flags & OPf_KIDS)
5254 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5255 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5257 if (type == OP_AND || type == OP_OR) {
5263 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5265 prepend_not = 1; /* prepend a NOT op later */
5269 /* search for a constant op that could let us fold the test */
5270 if ((cstop = search_const(first))) {
5271 if (cstop->op_private & OPpCONST_STRICT)
5272 no_bareword_allowed(cstop);
5273 else if ((cstop->op_private & OPpCONST_BARE))
5274 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5275 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5276 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5277 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5279 if (other->op_type == OP_CONST)
5280 other->op_private |= OPpCONST_SHORTCIRCUIT;
5282 OP *newop = newUNOP(OP_NULL, 0, other);
5283 op_getmad(first, newop, '1');
5284 newop->op_targ = type; /* set "was" field */
5288 if (other->op_type == OP_LEAVE)
5289 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5290 else if (other->op_type == OP_MATCH
5291 || other->op_type == OP_SUBST
5292 || other->op_type == OP_TRANSR
5293 || other->op_type == OP_TRANS)
5294 /* Mark the op as being unbindable with =~ */
5295 other->op_flags |= OPf_SPECIAL;
5299 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5300 const OP *o2 = other;
5301 if ( ! (o2->op_type == OP_LIST
5302 && (( o2 = cUNOPx(o2)->op_first))
5303 && o2->op_type == OP_PUSHMARK
5304 && (( o2 = o2->op_sibling)) )
5307 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5308 || o2->op_type == OP_PADHV)
5309 && o2->op_private & OPpLVAL_INTRO
5310 && !(o2->op_private & OPpPAD_STATE))
5312 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5313 "Deprecated use of my() in false conditional");
5317 if (first->op_type == OP_CONST)
5318 first->op_private |= OPpCONST_SHORTCIRCUIT;
5320 first = newUNOP(OP_NULL, 0, first);
5321 op_getmad(other, first, '2');
5322 first->op_targ = type; /* set "was" field */
5329 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5330 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5332 const OP * const k1 = ((UNOP*)first)->op_first;
5333 const OP * const k2 = k1->op_sibling;
5335 switch (first->op_type)
5338 if (k2 && k2->op_type == OP_READLINE
5339 && (k2->op_flags & OPf_STACKED)
5340 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5342 warnop = k2->op_type;
5347 if (k1->op_type == OP_READDIR
5348 || k1->op_type == OP_GLOB
5349 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5350 || k1->op_type == OP_EACH
5351 || k1->op_type == OP_AEACH)
5353 warnop = ((k1->op_type == OP_NULL)
5354 ? (OPCODE)k1->op_targ : k1->op_type);
5359 const line_t oldline = CopLINE(PL_curcop);
5360 CopLINE_set(PL_curcop, PL_parser->copline);
5361 Perl_warner(aTHX_ packWARN(WARN_MISC),
5362 "Value of %s%s can be \"0\"; test with defined()",
5364 ((warnop == OP_READLINE || warnop == OP_GLOB)
5365 ? " construct" : "() operator"));
5366 CopLINE_set(PL_curcop, oldline);
5373 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5374 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5376 NewOp(1101, logop, 1, LOGOP);
5378 logop->op_type = (OPCODE)type;
5379 logop->op_ppaddr = PL_ppaddr[type];
5380 logop->op_first = first;
5381 logop->op_flags = (U8)(flags | OPf_KIDS);
5382 logop->op_other = LINKLIST(other);
5383 logop->op_private = (U8)(1 | (flags >> 8));
5385 /* establish postfix order */
5386 logop->op_next = LINKLIST(first);
5387 first->op_next = (OP*)logop;
5388 first->op_sibling = other;
5390 CHECKOP(type,logop);
5392 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5399 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5401 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5402 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5403 will be set automatically, and, shifted up eight bits, the eight bits of
5404 C<op_private>, except that the bit with value 1 is automatically set.
5405 I<first> supplies the expression selecting between the two branches,
5406 and I<trueop> and I<falseop> supply the branches; they are consumed by
5407 this function and become part of the constructed op tree.
5413 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5421 PERL_ARGS_ASSERT_NEWCONDOP;
5424 return newLOGOP(OP_AND, 0, first, trueop);
5426 return newLOGOP(OP_OR, 0, first, falseop);
5428 scalarboolean(first);
5429 if ((cstop = search_const(first))) {
5430 /* Left or right arm of the conditional? */
5431 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5432 OP *live = left ? trueop : falseop;
5433 OP *const dead = left ? falseop : trueop;
5434 if (cstop->op_private & OPpCONST_BARE &&
5435 cstop->op_private & OPpCONST_STRICT) {
5436 no_bareword_allowed(cstop);
5439 /* This is all dead code when PERL_MAD is not defined. */
5440 live = newUNOP(OP_NULL, 0, live);
5441 op_getmad(first, live, 'C');
5442 op_getmad(dead, live, left ? 'e' : 't');
5447 if (live->op_type == OP_LEAVE)
5448 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5449 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5450 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5451 /* Mark the op as being unbindable with =~ */
5452 live->op_flags |= OPf_SPECIAL;
5455 NewOp(1101, logop, 1, LOGOP);
5456 logop->op_type = OP_COND_EXPR;
5457 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5458 logop->op_first = first;
5459 logop->op_flags = (U8)(flags | OPf_KIDS);
5460 logop->op_private = (U8)(1 | (flags >> 8));
5461 logop->op_other = LINKLIST(trueop);
5462 logop->op_next = LINKLIST(falseop);
5464 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5467 /* establish postfix order */
5468 start = LINKLIST(first);
5469 first->op_next = (OP*)logop;
5471 first->op_sibling = trueop;
5472 trueop->op_sibling = falseop;
5473 o = newUNOP(OP_NULL, 0, (OP*)logop);
5475 trueop->op_next = falseop->op_next = o;
5482 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5484 Constructs and returns a C<range> op, with subordinate C<flip> and
5485 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5486 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5487 for both the C<flip> and C<range> ops, except that the bit with value
5488 1 is automatically set. I<left> and I<right> supply the expressions
5489 controlling the endpoints of the range; they are consumed by this function
5490 and become part of the constructed op tree.
5496 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5505 PERL_ARGS_ASSERT_NEWRANGE;
5507 NewOp(1101, range, 1, LOGOP);
5509 range->op_type = OP_RANGE;
5510 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5511 range->op_first = left;
5512 range->op_flags = OPf_KIDS;
5513 leftstart = LINKLIST(left);
5514 range->op_other = LINKLIST(right);
5515 range->op_private = (U8)(1 | (flags >> 8));
5517 left->op_sibling = right;
5519 range->op_next = (OP*)range;
5520 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5521 flop = newUNOP(OP_FLOP, 0, flip);
5522 o = newUNOP(OP_NULL, 0, flop);
5524 range->op_next = leftstart;
5526 left->op_next = flip;
5527 right->op_next = flop;
5529 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5530 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5531 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5532 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5534 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5535 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5538 if (!flip->op_private || !flop->op_private)
5539 LINKLIST(o); /* blow off optimizer unless constant */
5545 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5547 Constructs, checks, and returns an op tree expressing a loop. This is
5548 only a loop in the control flow through the op tree; it does not have
5549 the heavyweight loop structure that allows exiting the loop by C<last>
5550 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5551 top-level op, except that some bits will be set automatically as required.
5552 I<expr> supplies the expression controlling loop iteration, and I<block>
5553 supplies the body of the loop; they are consumed by this function and
5554 become part of the constructed op tree. I<debuggable> is currently
5555 unused and should always be 1.
5561 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5566 const bool once = block && block->op_flags & OPf_SPECIAL &&
5567 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5569 PERL_UNUSED_ARG(debuggable);
5572 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5573 return block; /* do {} while 0 does once */
5574 if (expr->op_type == OP_READLINE
5575 || expr->op_type == OP_READDIR
5576 || expr->op_type == OP_GLOB
5577 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5578 expr = newUNOP(OP_DEFINED, 0,
5579 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5580 } else if (expr->op_flags & OPf_KIDS) {
5581 const OP * const k1 = ((UNOP*)expr)->op_first;
5582 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5583 switch (expr->op_type) {
5585 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5586 && (k2->op_flags & OPf_STACKED)
5587 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5588 expr = newUNOP(OP_DEFINED, 0, expr);
5592 if (k1 && (k1->op_type == OP_READDIR
5593 || k1->op_type == OP_GLOB
5594 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5595 || k1->op_type == OP_EACH
5596 || k1->op_type == OP_AEACH))
5597 expr = newUNOP(OP_DEFINED, 0, expr);
5603 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5604 * op, in listop. This is wrong. [perl #27024] */
5606 block = newOP(OP_NULL, 0);
5607 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5608 o = new_logop(OP_AND, 0, &expr, &listop);
5611 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5613 if (once && o != listop)
5614 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5617 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5619 o->op_flags |= flags;
5621 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5626 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5628 Constructs, checks, and returns an op tree expressing a C<while> loop.
5629 This is a heavyweight loop, with structure that allows exiting the loop
5630 by C<last> and suchlike.
5632 I<loop> is an optional preconstructed C<enterloop> op to use in the
5633 loop; if it is null then a suitable op will be constructed automatically.
5634 I<expr> supplies the loop's controlling expression. I<block> supplies the
5635 main body of the loop, and I<cont> optionally supplies a C<continue> block
5636 that operates as a second half of the body. All of these optree inputs
5637 are consumed by this function and become part of the constructed op tree.
5639 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5640 op and, shifted up eight bits, the eight bits of C<op_private> for
5641 the C<leaveloop> op, except that (in both cases) some bits will be set
5642 automatically. I<debuggable> is currently unused and should always be 1.
5643 I<has_my> can be supplied as true to force the
5644 loop body to be enclosed in its own scope.
5650 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5651 OP *expr, OP *block, OP *cont, I32 has_my)
5660 PERL_UNUSED_ARG(debuggable);
5663 if (expr->op_type == OP_READLINE
5664 || expr->op_type == OP_READDIR
5665 || expr->op_type == OP_GLOB
5666 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5667 expr = newUNOP(OP_DEFINED, 0,
5668 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5669 } else if (expr->op_flags & OPf_KIDS) {
5670 const OP * const k1 = ((UNOP*)expr)->op_first;
5671 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5672 switch (expr->op_type) {
5674 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5675 && (k2->op_flags & OPf_STACKED)
5676 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5677 expr = newUNOP(OP_DEFINED, 0, expr);
5681 if (k1 && (k1->op_type == OP_READDIR
5682 || k1->op_type == OP_GLOB
5683 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5684 || k1->op_type == OP_EACH
5685 || k1->op_type == OP_AEACH))
5686 expr = newUNOP(OP_DEFINED, 0, expr);
5693 block = newOP(OP_NULL, 0);
5694 else if (cont || has_my) {
5695 block = op_scope(block);
5699 next = LINKLIST(cont);
5702 OP * const unstack = newOP(OP_UNSTACK, 0);
5705 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5709 listop = op_append_list(OP_LINESEQ, block, cont);
5711 redo = LINKLIST(listop);
5715 o = new_logop(OP_AND, 0, &expr, &listop);
5716 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5717 op_free(expr); /* oops, it's a while (0) */
5719 return NULL; /* listop already freed by new_logop */
5722 ((LISTOP*)listop)->op_last->op_next =
5723 (o == listop ? redo : LINKLIST(o));
5729 NewOp(1101,loop,1,LOOP);
5730 loop->op_type = OP_ENTERLOOP;
5731 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5732 loop->op_private = 0;
5733 loop->op_next = (OP*)loop;
5736 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5738 loop->op_redoop = redo;
5739 loop->op_lastop = o;
5740 o->op_private |= loopflags;
5743 loop->op_nextop = next;
5745 loop->op_nextop = o;
5747 o->op_flags |= flags;
5748 o->op_private |= (flags >> 8);
5753 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5755 Constructs, checks, and returns an op tree expressing a C<foreach>
5756 loop (iteration through a list of values). This is a heavyweight loop,
5757 with structure that allows exiting the loop by C<last> and suchlike.
5759 I<sv> optionally supplies the variable that will be aliased to each
5760 item in turn; if null, it defaults to C<$_> (either lexical or global).
5761 I<expr> supplies the list of values to iterate over. I<block> supplies
5762 the main body of the loop, and I<cont> optionally supplies a C<continue>
5763 block that operates as a second half of the body. All of these optree
5764 inputs are consumed by this function and become part of the constructed
5767 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5768 op and, shifted up eight bits, the eight bits of C<op_private> for
5769 the C<leaveloop> op, except that (in both cases) some bits will be set
5776 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5781 PADOFFSET padoff = 0;
5786 PERL_ARGS_ASSERT_NEWFOROP;
5789 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5790 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5791 sv->op_type = OP_RV2GV;
5792 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5794 /* The op_type check is needed to prevent a possible segfault
5795 * if the loop variable is undeclared and 'strict vars' is in
5796 * effect. This is illegal but is nonetheless parsed, so we
5797 * may reach this point with an OP_CONST where we're expecting
5800 if (cUNOPx(sv)->op_first->op_type == OP_GV
5801 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5802 iterpflags |= OPpITER_DEF;
5804 else if (sv->op_type == OP_PADSV) { /* private variable */
5805 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5806 padoff = sv->op_targ;
5816 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5818 SV *const namesv = PAD_COMPNAME_SV(padoff);
5820 const char *const name = SvPV_const(namesv, len);
5822 if (len == 2 && name[0] == '$' && name[1] == '_')
5823 iterpflags |= OPpITER_DEF;
5827 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5828 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5829 sv = newGVOP(OP_GV, 0, PL_defgv);
5834 iterpflags |= OPpITER_DEF;
5836 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5837 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5838 iterflags |= OPf_STACKED;
5840 else if (expr->op_type == OP_NULL &&
5841 (expr->op_flags & OPf_KIDS) &&
5842 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5844 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5845 * set the STACKED flag to indicate that these values are to be
5846 * treated as min/max values by 'pp_iterinit'.
5848 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5849 LOGOP* const range = (LOGOP*) flip->op_first;
5850 OP* const left = range->op_first;
5851 OP* const right = left->op_sibling;
5854 range->op_flags &= ~OPf_KIDS;
5855 range->op_first = NULL;
5857 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5858 listop->op_first->op_next = range->op_next;
5859 left->op_next = range->op_other;
5860 right->op_next = (OP*)listop;
5861 listop->op_next = listop->op_first;
5864 op_getmad(expr,(OP*)listop,'O');
5868 expr = (OP*)(listop);
5870 iterflags |= OPf_STACKED;
5873 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5876 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5877 op_append_elem(OP_LIST, expr, scalar(sv))));
5878 assert(!loop->op_next);
5879 /* for my $x () sets OPpLVAL_INTRO;
5880 * for our $x () sets OPpOUR_INTRO */
5881 loop->op_private = (U8)iterpflags;
5882 #ifdef PL_OP_SLAB_ALLOC
5885 NewOp(1234,tmp,1,LOOP);
5886 Copy(loop,tmp,1,LISTOP);
5887 S_op_destroy(aTHX_ (OP*)loop);
5891 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5893 loop->op_targ = padoff;
5894 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5896 op_getmad(madsv, (OP*)loop, 'v');
5901 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5903 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5904 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5905 determining the target of the op; it is consumed by this function and
5906 become part of the constructed op tree.
5912 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5917 PERL_ARGS_ASSERT_NEWLOOPEX;
5919 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5921 if (type != OP_GOTO || label->op_type == OP_CONST) {
5922 /* "last()" means "last" */
5923 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5924 o = newOP(type, OPf_SPECIAL);
5926 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5927 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5931 op_getmad(label,o,'L');
5937 /* Check whether it's going to be a goto &function */
5938 if (label->op_type == OP_ENTERSUB
5939 && !(label->op_flags & OPf_STACKED))
5940 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
5941 o = newUNOP(type, OPf_STACKED, label);
5943 PL_hints |= HINT_BLOCK_SCOPE;
5947 /* if the condition is a literal array or hash
5948 (or @{ ... } etc), make a reference to it.
5951 S_ref_array_or_hash(pTHX_ OP *cond)
5954 && (cond->op_type == OP_RV2AV
5955 || cond->op_type == OP_PADAV
5956 || cond->op_type == OP_RV2HV
5957 || cond->op_type == OP_PADHV))
5959 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
5962 && (cond->op_type == OP_ASLICE
5963 || cond->op_type == OP_HSLICE)) {
5965 /* anonlist now needs a list from this op, was previously used in
5967 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5968 cond->op_flags |= OPf_WANT_LIST;
5970 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
5977 /* These construct the optree fragments representing given()
5980 entergiven and enterwhen are LOGOPs; the op_other pointer
5981 points up to the associated leave op. We need this so we
5982 can put it in the context and make break/continue work.
5983 (Also, of course, pp_enterwhen will jump straight to
5984 op_other if the match fails.)
5988 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5989 I32 enter_opcode, I32 leave_opcode,
5990 PADOFFSET entertarg)
5996 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5998 NewOp(1101, enterop, 1, LOGOP);
5999 enterop->op_type = (Optype)enter_opcode;
6000 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6001 enterop->op_flags = (U8) OPf_KIDS;
6002 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6003 enterop->op_private = 0;
6005 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6008 enterop->op_first = scalar(cond);
6009 cond->op_sibling = block;
6011 o->op_next = LINKLIST(cond);
6012 cond->op_next = (OP *) enterop;
6015 /* This is a default {} block */
6016 enterop->op_first = block;
6017 enterop->op_flags |= OPf_SPECIAL;
6019 o->op_next = (OP *) enterop;
6022 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6023 entergiven and enterwhen both
6026 enterop->op_next = LINKLIST(block);
6027 block->op_next = enterop->op_other = o;
6032 /* Does this look like a boolean operation? For these purposes
6033 a boolean operation is:
6034 - a subroutine call [*]
6035 - a logical connective
6036 - a comparison operator
6037 - a filetest operator, with the exception of -s -M -A -C
6038 - defined(), exists() or eof()
6039 - /$re/ or $foo =~ /$re/
6041 [*] possibly surprising
6044 S_looks_like_bool(pTHX_ const OP *o)
6048 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6050 switch(o->op_type) {
6053 return looks_like_bool(cLOGOPo->op_first);
6057 looks_like_bool(cLOGOPo->op_first)
6058 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6063 o->op_flags & OPf_KIDS
6064 && looks_like_bool(cUNOPo->op_first));
6068 case OP_NOT: case OP_XOR:
6070 case OP_EQ: case OP_NE: case OP_LT:
6071 case OP_GT: case OP_LE: case OP_GE:
6073 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6074 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6076 case OP_SEQ: case OP_SNE: case OP_SLT:
6077 case OP_SGT: case OP_SLE: case OP_SGE:
6081 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6082 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6083 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6084 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6085 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6086 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6087 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6088 case OP_FTTEXT: case OP_FTBINARY:
6090 case OP_DEFINED: case OP_EXISTS:
6091 case OP_MATCH: case OP_EOF:
6098 /* Detect comparisons that have been optimized away */
6099 if (cSVOPo->op_sv == &PL_sv_yes
6100 || cSVOPo->op_sv == &PL_sv_no)
6113 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6115 Constructs, checks, and returns an op tree expressing a C<given> block.
6116 I<cond> supplies the expression that will be locally assigned to a lexical
6117 variable, and I<block> supplies the body of the C<given> construct; they
6118 are consumed by this function and become part of the constructed op tree.
6119 I<defsv_off> is the pad offset of the scalar lexical variable that will
6126 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6129 PERL_ARGS_ASSERT_NEWGIVENOP;
6130 return newGIVWHENOP(
6131 ref_array_or_hash(cond),
6133 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6138 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6140 Constructs, checks, and returns an op tree expressing a C<when> block.
6141 I<cond> supplies the test expression, and I<block> supplies the block
6142 that will be executed if the test evaluates to true; they are consumed
6143 by this function and become part of the constructed op tree. I<cond>
6144 will be interpreted DWIMically, often as a comparison against C<$_>,
6145 and may be null to generate a C<default> block.
6151 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6153 const bool cond_llb = (!cond || looks_like_bool(cond));
6156 PERL_ARGS_ASSERT_NEWWHENOP;
6161 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6163 scalar(ref_array_or_hash(cond)));
6166 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6170 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
6173 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
6175 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
6176 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
6177 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
6178 || (p && (len != SvCUR(cv) /* Not the same length. */
6179 || memNE(p, SvPVX_const(cv), len))))
6180 && ckWARN_d(WARN_PROTOTYPE)) {
6181 SV* const msg = sv_newmortal();
6185 gv_efullname3(name = sv_newmortal(), gv, NULL);
6186 sv_setpvs(msg, "Prototype mismatch:");
6188 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6190 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
6192 sv_catpvs(msg, ": none");
6193 sv_catpvs(msg, " vs ");
6195 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
6197 sv_catpvs(msg, "none");
6198 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6202 static void const_sv_xsub(pTHX_ CV* cv);
6206 =head1 Optree Manipulation Functions
6208 =for apidoc cv_const_sv
6210 If C<cv> is a constant sub eligible for inlining. returns the constant
6211 value returned by the sub. Otherwise, returns NULL.
6213 Constant subs can be created with C<newCONSTSUB> or as described in
6214 L<perlsub/"Constant Functions">.
6219 Perl_cv_const_sv(pTHX_ const CV *const cv)
6221 PERL_UNUSED_CONTEXT;
6224 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6226 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6229 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6230 * Can be called in 3 ways:
6233 * look for a single OP_CONST with attached value: return the value
6235 * cv && CvCLONE(cv) && !CvCONST(cv)
6237 * examine the clone prototype, and if contains only a single
6238 * OP_CONST referencing a pad const, or a single PADSV referencing
6239 * an outer lexical, return a non-zero value to indicate the CV is
6240 * a candidate for "constizing" at clone time
6244 * We have just cloned an anon prototype that was marked as a const
6245 * candidate. Try to grab the current value, and in the case of
6246 * PADSV, ignore it if it has multiple references. Return the value.
6250 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6261 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6262 o = cLISTOPo->op_first->op_sibling;
6264 for (; o; o = o->op_next) {
6265 const OPCODE type = o->op_type;
6267 if (sv && o->op_next == o)
6269 if (o->op_next != o) {
6270 if (type == OP_NEXTSTATE
6271 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6272 || type == OP_PUSHMARK)
6274 if (type == OP_DBSTATE)
6277 if (type == OP_LEAVESUB || type == OP_RETURN)
6281 if (type == OP_CONST && cSVOPo->op_sv)
6283 else if (cv && type == OP_CONST) {
6284 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6288 else if (cv && type == OP_PADSV) {
6289 if (CvCONST(cv)) { /* newly cloned anon */
6290 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6291 /* the candidate should have 1 ref from this pad and 1 ref
6292 * from the parent */
6293 if (!sv || SvREFCNT(sv) != 2)
6300 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6301 sv = &PL_sv_undef; /* an arbitrary non-null value */
6316 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6319 /* This would be the return value, but the return cannot be reached. */
6320 OP* pegop = newOP(OP_NULL, 0);
6323 PERL_UNUSED_ARG(floor);
6333 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6335 NORETURN_FUNCTION_END;
6340 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6345 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6346 register CV *cv = NULL;
6348 /* If the subroutine has no body, no attributes, and no builtin attributes
6349 then it's just a sub declaration, and we may be able to get away with
6350 storing with a placeholder scalar in the symbol table, rather than a
6351 full GV and CV. If anything is present then it will take a full CV to
6353 const I32 gv_fetch_flags
6354 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6356 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6357 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6361 assert(proto->op_type == OP_CONST);
6362 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6368 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6370 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6371 SV * const sv = sv_newmortal();
6372 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6373 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6374 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6375 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6377 } else if (PL_curstash) {
6378 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6381 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6385 if (!PL_madskills) {
6394 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6395 maximum a prototype before. */
6396 if (SvTYPE(gv) > SVt_NULL) {
6397 if (!SvPOK((const SV *)gv)
6398 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6400 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6402 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6405 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6407 sv_setiv(MUTABLE_SV(gv), -1);
6409 SvREFCNT_dec(PL_compcv);
6410 cv = PL_compcv = NULL;
6414 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6416 if (!block || !ps || *ps || attrs
6417 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6419 || block->op_type == OP_NULL
6424 const_sv = op_const_sv(block, NULL);
6427 const bool exists = CvROOT(cv) || CvXSUB(cv);
6429 /* if the subroutine doesn't exist and wasn't pre-declared
6430 * with a prototype, assume it will be AUTOLOADed,
6431 * skipping the prototype check
6433 if (exists || SvPOK(cv))
6434 cv_ckproto_len(cv, gv, ps, ps_len);
6435 /* already defined (or promised)? */
6436 if (exists || GvASSUMECV(gv)) {
6439 || block->op_type == OP_NULL
6442 if (CvFLAGS(PL_compcv)) {
6443 /* might have had built-in attrs applied */
6444 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6445 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6446 && ckWARN(WARN_MISC))
6447 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6449 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6450 & ~(CVf_LVALUE * pureperl));
6452 if (attrs) goto attrs;
6453 /* just a "sub foo;" when &foo is already defined */
6454 SAVEFREESV(PL_compcv);
6459 && block->op_type != OP_NULL
6462 if (ckWARN(WARN_REDEFINE)
6464 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6466 const line_t oldline = CopLINE(PL_curcop);
6467 if (PL_parser && PL_parser->copline != NOLINE)
6468 CopLINE_set(PL_curcop, PL_parser->copline);
6469 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6470 CvCONST(cv) ? "Constant subroutine %s redefined"
6471 : "Subroutine %s redefined", name);
6472 CopLINE_set(PL_curcop, oldline);
6475 if (!PL_minus_c) /* keep old one around for madskills */
6478 /* (PL_madskills unset in used file.) */
6486 SvREFCNT_inc_simple_void_NN(const_sv);
6488 assert(!CvROOT(cv) && !CvCONST(cv));
6489 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6490 CvXSUBANY(cv).any_ptr = const_sv;
6491 CvXSUB(cv) = const_sv_xsub;
6497 cv = newCONSTSUB(NULL, name, const_sv);
6499 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6500 (CvGV(cv) && GvSTASH(CvGV(cv)))
6509 SvREFCNT_dec(PL_compcv);
6513 if (cv) { /* must reuse cv if autoloaded */
6514 /* transfer PL_compcv to cv */
6517 && block->op_type != OP_NULL
6520 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6521 AV *const temp_av = CvPADLIST(cv);
6522 CV *const temp_cv = CvOUTSIDE(cv);
6524 assert(!CvWEAKOUTSIDE(cv));
6525 assert(!CvCVGV_RC(cv));
6526 assert(CvGV(cv) == gv);
6529 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6530 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6531 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6532 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6533 CvOUTSIDE(PL_compcv) = temp_cv;
6534 CvPADLIST(PL_compcv) = temp_av;
6537 if (CvFILE(cv) && !CvISXSUB(cv)) {
6538 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
6539 Safefree(CvFILE(cv));
6542 CvFILE_set_from_cop(cv, PL_curcop);
6543 CvSTASH_set(cv, PL_curstash);
6545 /* inner references to PL_compcv must be fixed up ... */
6546 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6547 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6548 ++PL_sub_generation;
6551 /* Might have had built-in attributes applied -- propagate them. */
6552 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6554 /* ... before we throw it away */
6555 SvREFCNT_dec(PL_compcv);
6563 if (strEQ(name, "import")) {
6564 PL_formfeed = MUTABLE_SV(cv);
6565 /* diag_listed_as: SKIPME */
6566 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6570 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6575 CvFILE_set_from_cop(cv, PL_curcop);
6576 CvSTASH_set(cv, PL_curstash);
6580 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6581 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6582 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6586 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6588 if (PL_parser && PL_parser->error_count) {
6592 const char *s = strrchr(name, ':');
6594 if (strEQ(s, "BEGIN")) {
6595 const char not_safe[] =
6596 "BEGIN not safe after errors--compilation aborted";
6597 if (PL_in_eval & EVAL_KEEPERR)
6598 Perl_croak(aTHX_ not_safe);
6600 /* force display of errors found but not reported */
6601 sv_catpv(ERRSV, not_safe);
6602 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6611 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6612 the debugger could be able to set a breakpoint in, so signal to
6613 pp_entereval that it should not throw away any saved lines at scope
6616 PL_breakable_sub_gen++;
6617 /* This makes sub {}; work as expected. */
6618 if (block->op_type == OP_STUB) {
6619 OP* const newblock = newSTATEOP(0, NULL, 0);
6621 op_getmad(block,newblock,'B');
6627 else block->op_attached = 1;
6628 CvROOT(cv) = CvLVALUE(cv)
6629 ? newUNOP(OP_LEAVESUBLV, 0,
6630 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6631 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6632 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6633 OpREFCNT_set(CvROOT(cv), 1);
6634 CvSTART(cv) = LINKLIST(CvROOT(cv));
6635 CvROOT(cv)->op_next = 0;
6636 CALL_PEEP(CvSTART(cv));
6637 finalize_optree(CvROOT(cv));
6639 /* now that optimizer has done its work, adjust pad values */
6641 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6644 assert(!CvCONST(cv));
6645 if (ps && !*ps && op_const_sv(block, cv))
6650 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6651 SV * const tmpstr = sv_newmortal();
6652 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6653 GV_ADDMULTI, SVt_PVHV);
6655 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6658 (long)CopLINE(PL_curcop));
6659 gv_efullname3(tmpstr, gv, NULL);
6660 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6661 SvCUR(tmpstr), sv, 0);
6662 hv = GvHVn(db_postponed);
6663 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6664 CV * const pcv = GvCV(db_postponed);
6670 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6675 if (name && ! (PL_parser && PL_parser->error_count))
6676 process_special_blocks(name, gv, cv);
6681 PL_parser->copline = NOLINE;
6687 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6690 const char *const colon = strrchr(fullname,':');
6691 const char *const name = colon ? colon + 1 : fullname;
6693 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6696 if (strEQ(name, "BEGIN")) {
6697 const I32 oldscope = PL_scopestack_ix;
6699 SAVECOPFILE(&PL_compiling);
6700 SAVECOPLINE(&PL_compiling);
6702 DEBUG_x( dump_sub(gv) );
6703 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6704 GvCV_set(gv,0); /* cv has been hijacked */
6705 call_list(oldscope, PL_beginav);
6707 PL_curcop = &PL_compiling;
6708 CopHINTS_set(&PL_compiling, PL_hints);
6715 if strEQ(name, "END") {
6716 DEBUG_x( dump_sub(gv) );
6717 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6720 } else if (*name == 'U') {
6721 if (strEQ(name, "UNITCHECK")) {
6722 /* It's never too late to run a unitcheck block */
6723 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6727 } else if (*name == 'C') {
6728 if (strEQ(name, "CHECK")) {
6730 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6731 "Too late to run CHECK block");
6732 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6736 } else if (*name == 'I') {
6737 if (strEQ(name, "INIT")) {
6739 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6740 "Too late to run INIT block");
6741 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6747 DEBUG_x( dump_sub(gv) );
6748 GvCV_set(gv,0); /* cv has been hijacked */
6753 =for apidoc newCONSTSUB
6755 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6756 eligible for inlining at compile-time.
6758 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6759 which won't be called if used as a destructor, but will suppress the overhead
6760 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6767 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6772 const char *const file = CopFILE(PL_curcop);
6774 SV *const temp_sv = CopFILESV(PL_curcop);
6775 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6780 if (IN_PERL_RUNTIME) {
6781 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6782 * an op shared between threads. Use a non-shared COP for our
6784 SAVEVPTR(PL_curcop);
6785 PL_curcop = &PL_compiling;
6787 SAVECOPLINE(PL_curcop);
6788 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6791 PL_hints &= ~HINT_BLOCK_SCOPE;
6794 SAVESPTR(PL_curstash);
6795 SAVECOPSTASH(PL_curcop);
6796 PL_curstash = stash;
6797 CopSTASH_set(PL_curcop,stash);
6800 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6801 and so doesn't get free()d. (It's expected to be from the C pre-
6802 processor __FILE__ directive). But we need a dynamically allocated one,
6803 and we need it to get freed. */
6804 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6805 XS_DYNAMIC_FILENAME);
6806 CvXSUBANY(cv).any_ptr = sv;
6811 CopSTASH_free(PL_curcop);
6819 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6820 const char *const filename, const char *const proto,
6823 CV *cv = newXS(name, subaddr, filename);
6825 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6827 if (flags & XS_DYNAMIC_FILENAME) {
6828 /* We need to "make arrangements" (ie cheat) to ensure that the
6829 filename lasts as long as the PVCV we just created, but also doesn't
6831 STRLEN filename_len = strlen(filename);
6832 STRLEN proto_and_file_len = filename_len;
6833 char *proto_and_file;
6837 proto_len = strlen(proto);
6838 proto_and_file_len += proto_len;
6840 Newx(proto_and_file, proto_and_file_len + 1, char);
6841 Copy(proto, proto_and_file, proto_len, char);
6842 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6845 proto_and_file = savepvn(filename, filename_len);
6848 /* This gets free()d. :-) */
6849 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6850 SV_HAS_TRAILING_NUL);
6852 /* This gives us the correct prototype, rather than one with the
6853 file name appended. */
6854 SvCUR_set(cv, proto_len);
6858 CvFILE(cv) = proto_and_file + proto_len;
6860 sv_setpv(MUTABLE_SV(cv), proto);
6866 =for apidoc U||newXS
6868 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6869 static storage, as it is used directly as CvFILE(), without a copy being made.
6875 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6878 GV * const gv = gv_fetchpv(name ? name :
6879 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6880 GV_ADDMULTI, SVt_PVCV);
6883 PERL_ARGS_ASSERT_NEWXS;
6886 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6888 if ((cv = (name ? GvCV(gv) : NULL))) {
6890 /* just a cached method */
6894 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6895 /* already defined (or promised) */
6896 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6897 if (ckWARN(WARN_REDEFINE)) {
6898 GV * const gvcv = CvGV(cv);
6900 HV * const stash = GvSTASH(gvcv);
6902 const char *redefined_name = HvNAME_get(stash);
6903 if ( strEQ(redefined_name,"autouse") ) {
6904 const line_t oldline = CopLINE(PL_curcop);
6905 if (PL_parser && PL_parser->copline != NOLINE)
6906 CopLINE_set(PL_curcop, PL_parser->copline);
6907 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6908 CvCONST(cv) ? "Constant subroutine %s redefined"
6909 : "Subroutine %s redefined"
6911 CopLINE_set(PL_curcop, oldline);
6921 if (cv) /* must reuse cv if autoloaded */
6924 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6928 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6934 (void)gv_fetchfile(filename);
6935 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6936 an external constant string */
6938 CvXSUB(cv) = subaddr;
6941 process_special_blocks(name, gv, cv);
6951 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6956 OP* pegop = newOP(OP_NULL, 0);
6960 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6961 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6964 if ((cv = GvFORM(gv))) {
6965 if (ckWARN(WARN_REDEFINE)) {
6966 const line_t oldline = CopLINE(PL_curcop);
6967 if (PL_parser && PL_parser->copline != NOLINE)
6968 CopLINE_set(PL_curcop, PL_parser->copline);
6970 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6971 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6973 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6974 "Format STDOUT redefined");
6976 CopLINE_set(PL_curcop, oldline);
6983 CvFILE_set_from_cop(cv, PL_curcop);
6986 pad_tidy(padtidy_FORMAT);
6987 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6988 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6989 OpREFCNT_set(CvROOT(cv), 1);
6990 CvSTART(cv) = LINKLIST(CvROOT(cv));
6991 CvROOT(cv)->op_next = 0;
6992 CALL_PEEP(CvSTART(cv));
6993 finalize_optree(CvROOT(cv));
6995 op_getmad(o,pegop,'n');
6996 op_getmad_weak(block, pegop, 'b');
7001 PL_parser->copline = NOLINE;
7009 Perl_newANONLIST(pTHX_ OP *o)
7011 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7015 Perl_newANONHASH(pTHX_ OP *o)
7017 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7021 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7023 return newANONATTRSUB(floor, proto, NULL, block);
7027 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7029 return newUNOP(OP_REFGEN, 0,
7030 newSVOP(OP_ANONCODE, 0,
7031 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7035 Perl_oopsAV(pTHX_ OP *o)
7039 PERL_ARGS_ASSERT_OOPSAV;
7041 switch (o->op_type) {
7043 o->op_type = OP_PADAV;
7044 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7045 return ref(o, OP_RV2AV);
7048 o->op_type = OP_RV2AV;
7049 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7054 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7061 Perl_oopsHV(pTHX_ OP *o)
7065 PERL_ARGS_ASSERT_OOPSHV;
7067 switch (o->op_type) {
7070 o->op_type = OP_PADHV;
7071 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7072 return ref(o, OP_RV2HV);
7076 o->op_type = OP_RV2HV;
7077 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7082 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7089 Perl_newAVREF(pTHX_ OP *o)
7093 PERL_ARGS_ASSERT_NEWAVREF;
7095 if (o->op_type == OP_PADANY) {
7096 o->op_type = OP_PADAV;
7097 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7100 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7101 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7102 "Using an array as a reference is deprecated");
7104 return newUNOP(OP_RV2AV, 0, scalar(o));
7108 Perl_newGVREF(pTHX_ I32 type, OP *o)
7110 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7111 return newUNOP(OP_NULL, 0, o);
7112 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7116 Perl_newHVREF(pTHX_ OP *o)
7120 PERL_ARGS_ASSERT_NEWHVREF;
7122 if (o->op_type == OP_PADANY) {
7123 o->op_type = OP_PADHV;
7124 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7127 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7128 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7129 "Using a hash as a reference is deprecated");
7131 return newUNOP(OP_RV2HV, 0, scalar(o));
7135 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7137 return newUNOP(OP_RV2CV, flags, scalar(o));
7141 Perl_newSVREF(pTHX_ OP *o)
7145 PERL_ARGS_ASSERT_NEWSVREF;
7147 if (o->op_type == OP_PADANY) {
7148 o->op_type = OP_PADSV;
7149 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7152 return newUNOP(OP_RV2SV, 0, scalar(o));
7155 /* Check routines. See the comments at the top of this file for details
7156 * on when these are called */
7159 Perl_ck_anoncode(pTHX_ OP *o)
7161 PERL_ARGS_ASSERT_CK_ANONCODE;
7163 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7165 cSVOPo->op_sv = NULL;
7170 Perl_ck_bitop(pTHX_ OP *o)
7174 PERL_ARGS_ASSERT_CK_BITOP;
7176 #define OP_IS_NUMCOMPARE(op) \
7177 ((op) == OP_LT || (op) == OP_I_LT || \
7178 (op) == OP_GT || (op) == OP_I_GT || \
7179 (op) == OP_LE || (op) == OP_I_LE || \
7180 (op) == OP_GE || (op) == OP_I_GE || \
7181 (op) == OP_EQ || (op) == OP_I_EQ || \
7182 (op) == OP_NE || (op) == OP_I_NE || \
7183 (op) == OP_NCMP || (op) == OP_I_NCMP)
7184 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7185 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7186 && (o->op_type == OP_BIT_OR
7187 || o->op_type == OP_BIT_AND
7188 || o->op_type == OP_BIT_XOR))
7190 const OP * const left = cBINOPo->op_first;
7191 const OP * const right = left->op_sibling;
7192 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7193 (left->op_flags & OPf_PARENS) == 0) ||
7194 (OP_IS_NUMCOMPARE(right->op_type) &&
7195 (right->op_flags & OPf_PARENS) == 0))
7196 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7197 "Possible precedence problem on bitwise %c operator",
7198 o->op_type == OP_BIT_OR ? '|'
7199 : o->op_type == OP_BIT_AND ? '&' : '^'
7206 Perl_ck_concat(pTHX_ OP *o)
7208 const OP * const kid = cUNOPo->op_first;
7210 PERL_ARGS_ASSERT_CK_CONCAT;
7211 PERL_UNUSED_CONTEXT;
7213 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7214 !(kUNOP->op_first->op_flags & OPf_MOD))
7215 o->op_flags |= OPf_STACKED;
7220 Perl_ck_spair(pTHX_ OP *o)
7224 PERL_ARGS_ASSERT_CK_SPAIR;
7226 if (o->op_flags & OPf_KIDS) {
7229 const OPCODE type = o->op_type;
7230 o = modkids(ck_fun(o), type);
7231 kid = cUNOPo->op_first;
7232 newop = kUNOP->op_first->op_sibling;
7234 const OPCODE type = newop->op_type;
7235 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7236 type == OP_PADAV || type == OP_PADHV ||
7237 type == OP_RV2AV || type == OP_RV2HV)
7241 op_getmad(kUNOP->op_first,newop,'K');
7243 op_free(kUNOP->op_first);
7245 kUNOP->op_first = newop;
7247 o->op_ppaddr = PL_ppaddr[++o->op_type];
7252 Perl_ck_delete(pTHX_ OP *o)
7254 PERL_ARGS_ASSERT_CK_DELETE;
7258 if (o->op_flags & OPf_KIDS) {
7259 OP * const kid = cUNOPo->op_first;
7260 switch (kid->op_type) {
7262 o->op_flags |= OPf_SPECIAL;
7265 o->op_private |= OPpSLICE;
7268 o->op_flags |= OPf_SPECIAL;
7273 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7276 if (kid->op_private & OPpLVAL_INTRO)
7277 o->op_private |= OPpLVAL_INTRO;
7284 Perl_ck_die(pTHX_ OP *o)
7286 PERL_ARGS_ASSERT_CK_DIE;
7289 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7295 Perl_ck_eof(pTHX_ OP *o)
7299 PERL_ARGS_ASSERT_CK_EOF;
7301 if (o->op_flags & OPf_KIDS) {
7302 if (cLISTOPo->op_first->op_type == OP_STUB) {
7304 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7306 op_getmad(o,newop,'O');
7318 Perl_ck_eval(pTHX_ OP *o)
7322 PERL_ARGS_ASSERT_CK_EVAL;
7324 PL_hints |= HINT_BLOCK_SCOPE;
7325 if (o->op_flags & OPf_KIDS) {
7326 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7329 o->op_flags &= ~OPf_KIDS;
7332 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7338 cUNOPo->op_first = 0;
7343 NewOp(1101, enter, 1, LOGOP);
7344 enter->op_type = OP_ENTERTRY;
7345 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7346 enter->op_private = 0;
7348 /* establish postfix order */
7349 enter->op_next = (OP*)enter;
7351 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7352 o->op_type = OP_LEAVETRY;
7353 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7354 enter->op_other = o;
7355 op_getmad(oldo,o,'O');
7369 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7370 op_getmad(oldo,o,'O');
7372 o->op_targ = (PADOFFSET)PL_hints;
7373 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7374 /* Store a copy of %^H that pp_entereval can pick up. */
7375 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7376 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7377 cUNOPo->op_first->op_sibling = hhop;
7378 o->op_private |= OPpEVAL_HAS_HH;
7384 Perl_ck_exit(pTHX_ OP *o)
7386 PERL_ARGS_ASSERT_CK_EXIT;
7389 HV * const table = GvHV(PL_hintgv);
7391 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7392 if (svp && *svp && SvTRUE(*svp))
7393 o->op_private |= OPpEXIT_VMSISH;
7395 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7401 Perl_ck_exec(pTHX_ OP *o)
7403 PERL_ARGS_ASSERT_CK_EXEC;
7405 if (o->op_flags & OPf_STACKED) {
7408 kid = cUNOPo->op_first->op_sibling;
7409 if (kid->op_type == OP_RV2GV)
7418 Perl_ck_exists(pTHX_ OP *o)
7422 PERL_ARGS_ASSERT_CK_EXISTS;
7425 if (o->op_flags & OPf_KIDS) {
7426 OP * const kid = cUNOPo->op_first;
7427 if (kid->op_type == OP_ENTERSUB) {
7428 (void) ref(kid, o->op_type);
7429 if (kid->op_type != OP_RV2CV
7430 && !(PL_parser && PL_parser->error_count))
7431 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7433 o->op_private |= OPpEXISTS_SUB;
7435 else if (kid->op_type == OP_AELEM)
7436 o->op_flags |= OPf_SPECIAL;
7437 else if (kid->op_type != OP_HELEM)
7438 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7446 Perl_ck_rvconst(pTHX_ register OP *o)
7449 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7451 PERL_ARGS_ASSERT_CK_RVCONST;
7453 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7454 if (o->op_type == OP_RV2CV)
7455 o->op_private &= ~1;
7457 if (kid->op_type == OP_CONST) {
7460 SV * const kidsv = kid->op_sv;
7462 /* Is it a constant from cv_const_sv()? */
7463 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7464 SV * const rsv = SvRV(kidsv);
7465 const svtype type = SvTYPE(rsv);
7466 const char *badtype = NULL;
7468 switch (o->op_type) {
7470 if (type > SVt_PVMG)
7471 badtype = "a SCALAR";
7474 if (type != SVt_PVAV)
7475 badtype = "an ARRAY";
7478 if (type != SVt_PVHV)
7482 if (type != SVt_PVCV)
7487 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7490 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7491 const char *badthing;
7492 switch (o->op_type) {
7494 badthing = "a SCALAR";
7497 badthing = "an ARRAY";
7500 badthing = "a HASH";
7508 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7509 SVfARG(kidsv), badthing);
7512 * This is a little tricky. We only want to add the symbol if we
7513 * didn't add it in the lexer. Otherwise we get duplicate strict
7514 * warnings. But if we didn't add it in the lexer, we must at
7515 * least pretend like we wanted to add it even if it existed before,
7516 * or we get possible typo warnings. OPpCONST_ENTERED says
7517 * whether the lexer already added THIS instance of this symbol.
7519 iscv = (o->op_type == OP_RV2CV) * 2;
7521 gv = gv_fetchsv(kidsv,
7522 iscv | !(kid->op_private & OPpCONST_ENTERED),
7525 : o->op_type == OP_RV2SV
7527 : o->op_type == OP_RV2AV
7529 : o->op_type == OP_RV2HV
7532 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7534 kid->op_type = OP_GV;
7535 SvREFCNT_dec(kid->op_sv);
7537 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7538 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7539 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7541 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7543 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7545 kid->op_private = 0;
7546 kid->op_ppaddr = PL_ppaddr[OP_GV];
7547 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7555 Perl_ck_ftst(pTHX_ OP *o)
7558 const I32 type = o->op_type;
7560 PERL_ARGS_ASSERT_CK_FTST;
7562 if (o->op_flags & OPf_REF) {
7565 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7566 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7567 const OPCODE kidtype = kid->op_type;
7569 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7570 OP * const newop = newGVOP(type, OPf_REF,
7571 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7573 op_getmad(o,newop,'O');
7579 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7580 o->op_private |= OPpFT_ACCESS;
7581 if (PL_check[kidtype] == Perl_ck_ftst
7582 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7583 o->op_private |= OPpFT_STACKED;
7584 kid->op_private |= OPpFT_STACKING;
7593 if (type == OP_FTTTY)
7594 o = newGVOP(type, OPf_REF, PL_stdingv);
7596 o = newUNOP(type, 0, newDEFSVOP());
7597 op_getmad(oldo,o,'O');
7603 Perl_ck_fun(pTHX_ OP *o)
7606 const int type = o->op_type;
7607 register I32 oa = PL_opargs[type] >> OASHIFT;
7609 PERL_ARGS_ASSERT_CK_FUN;
7611 if (o->op_flags & OPf_STACKED) {
7612 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7615 return no_fh_allowed(o);
7618 if (o->op_flags & OPf_KIDS) {
7619 OP **tokid = &cLISTOPo->op_first;
7620 register OP *kid = cLISTOPo->op_first;
7624 if (kid->op_type == OP_PUSHMARK ||
7625 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7627 tokid = &kid->op_sibling;
7628 kid = kid->op_sibling;
7630 if (!kid && PL_opargs[type] & OA_DEFGV)
7631 *tokid = kid = newDEFSVOP();
7635 sibl = kid->op_sibling;
7637 if (!sibl && kid->op_type == OP_STUB) {
7644 /* list seen where single (scalar) arg expected? */
7645 if (numargs == 1 && !(oa >> 4)
7646 && kid->op_type == OP_LIST && type != OP_SCALAR)
7648 return too_many_arguments(o,PL_op_desc[type]);
7661 if ((type == OP_PUSH || type == OP_UNSHIFT)
7662 && !kid->op_sibling)
7663 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7664 "Useless use of %s with no values",
7667 if (kid->op_type == OP_CONST &&
7668 (kid->op_private & OPpCONST_BARE))
7670 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7671 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7672 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7673 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7674 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7676 op_getmad(kid,newop,'K');
7681 kid->op_sibling = sibl;
7684 else if (kid->op_type == OP_CONST
7685 && ( !SvROK(cSVOPx_sv(kid))
7686 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7688 bad_type(numargs, "array", PL_op_desc[type], kid);
7689 /* Defer checks to run-time if we have a scalar arg */
7690 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7691 op_lvalue(kid, type);
7695 if (kid->op_type == OP_CONST &&
7696 (kid->op_private & OPpCONST_BARE))
7698 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7699 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7700 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7701 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7702 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7704 op_getmad(kid,newop,'K');
7709 kid->op_sibling = sibl;
7712 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7713 bad_type(numargs, "hash", PL_op_desc[type], kid);
7714 op_lvalue(kid, type);
7718 OP * const newop = newUNOP(OP_NULL, 0, kid);
7719 kid->op_sibling = 0;
7721 newop->op_next = newop;
7723 kid->op_sibling = sibl;
7728 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7729 if (kid->op_type == OP_CONST &&
7730 (kid->op_private & OPpCONST_BARE))
7732 OP * const newop = newGVOP(OP_GV, 0,
7733 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7734 if (!(o->op_private & 1) && /* if not unop */
7735 kid == cLISTOPo->op_last)
7736 cLISTOPo->op_last = newop;
7738 op_getmad(kid,newop,'K');
7744 else if (kid->op_type == OP_READLINE) {
7745 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7746 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7749 I32 flags = OPf_SPECIAL;
7753 /* is this op a FH constructor? */
7754 if (is_handle_constructor(o,numargs)) {
7755 const char *name = NULL;
7759 /* Set a flag to tell rv2gv to vivify
7760 * need to "prove" flag does not mean something
7761 * else already - NI-S 1999/05/07
7764 if (kid->op_type == OP_PADSV) {
7766 = PAD_COMPNAME_SV(kid->op_targ);
7767 name = SvPV_const(namesv, len);
7769 else if (kid->op_type == OP_RV2SV
7770 && kUNOP->op_first->op_type == OP_GV)
7772 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7774 len = GvNAMELEN(gv);
7776 else if (kid->op_type == OP_AELEM
7777 || kid->op_type == OP_HELEM)
7780 OP *op = ((BINOP*)kid)->op_first;
7784 const char * const a =
7785 kid->op_type == OP_AELEM ?
7787 if (((op->op_type == OP_RV2AV) ||
7788 (op->op_type == OP_RV2HV)) &&
7789 (firstop = ((UNOP*)op)->op_first) &&
7790 (firstop->op_type == OP_GV)) {
7791 /* packagevar $a[] or $h{} */
7792 GV * const gv = cGVOPx_gv(firstop);
7800 else if (op->op_type == OP_PADAV
7801 || op->op_type == OP_PADHV) {
7802 /* lexicalvar $a[] or $h{} */
7803 const char * const padname =
7804 PAD_COMPNAME_PV(op->op_targ);
7813 name = SvPV_const(tmpstr, len);
7818 name = "__ANONIO__";
7821 op_lvalue(kid, type);
7825 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7826 namesv = PAD_SVl(targ);
7827 SvUPGRADE(namesv, SVt_PV);
7829 sv_setpvs(namesv, "$");
7830 sv_catpvn(namesv, name, len);
7833 kid->op_sibling = 0;
7834 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7835 kid->op_targ = targ;
7836 kid->op_private |= priv;
7838 kid->op_sibling = sibl;
7844 op_lvalue(scalar(kid), type);
7848 tokid = &kid->op_sibling;
7849 kid = kid->op_sibling;
7852 if (kid && kid->op_type != OP_STUB)
7853 return too_many_arguments(o,OP_DESC(o));
7854 o->op_private |= numargs;
7856 /* FIXME - should the numargs move as for the PERL_MAD case? */
7857 o->op_private |= numargs;
7859 return too_many_arguments(o,OP_DESC(o));
7863 else if (PL_opargs[type] & OA_DEFGV) {
7865 OP *newop = newUNOP(type, 0, newDEFSVOP());
7866 op_getmad(o,newop,'O');
7869 /* Ordering of these two is important to keep f_map.t passing. */
7871 return newUNOP(type, 0, newDEFSVOP());
7876 while (oa & OA_OPTIONAL)
7878 if (oa && oa != OA_LIST)
7879 return too_few_arguments(o,OP_DESC(o));
7885 Perl_ck_glob(pTHX_ OP *o)
7890 PERL_ARGS_ASSERT_CK_GLOB;
7893 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7894 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
7896 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7897 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7899 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7902 #if !defined(PERL_EXTERNAL_GLOB)
7903 /* XXX this can be tightened up and made more failsafe. */
7904 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7907 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7908 newSVpvs("File::Glob"), NULL, NULL, NULL);
7909 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7910 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7911 GvCV_set(gv, GvCV(glob_gv));
7912 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7913 GvIMPORTED_CV_on(gv);
7917 #endif /* PERL_EXTERNAL_GLOB */
7919 assert(!(o->op_flags & OPf_SPECIAL));
7920 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7923 * \ null - const(wildcard)
7928 * \ mark - glob - rv2cv
7929 * | \ gv(CORE::GLOBAL::glob)
7931 * \ null - const(wildcard) - const(ix)
7933 o->op_flags |= OPf_SPECIAL;
7934 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
7935 op_append_elem(OP_GLOB, o,
7936 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7937 o = newLISTOP(OP_LIST, 0, o, NULL);
7938 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7939 op_append_elem(OP_LIST, o,
7940 scalar(newUNOP(OP_RV2CV, 0,
7941 newGVOP(OP_GV, 0, gv)))));
7942 o = newUNOP(OP_NULL, 0, ck_subr(o));
7943 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
7946 gv = newGVgen("main");
7948 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7954 Perl_ck_grep(pTHX_ OP *o)
7959 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7962 PERL_ARGS_ASSERT_CK_GREP;
7964 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7965 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7967 if (o->op_flags & OPf_STACKED) {
7970 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7971 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7972 return no_fh_allowed(o);
7973 for (k = kid; k; k = k->op_next) {
7976 NewOp(1101, gwop, 1, LOGOP);
7977 kid->op_next = (OP*)gwop;
7978 o->op_flags &= ~OPf_STACKED;
7980 kid = cLISTOPo->op_first->op_sibling;
7981 if (type == OP_MAPWHILE)
7986 if (PL_parser && PL_parser->error_count)
7988 kid = cLISTOPo->op_first->op_sibling;
7989 if (kid->op_type != OP_NULL)
7990 Perl_croak(aTHX_ "panic: ck_grep");
7991 kid = kUNOP->op_first;
7994 NewOp(1101, gwop, 1, LOGOP);
7995 gwop->op_type = type;
7996 gwop->op_ppaddr = PL_ppaddr[type];
7997 gwop->op_first = listkids(o);
7998 gwop->op_flags |= OPf_KIDS;
7999 gwop->op_other = LINKLIST(kid);
8000 kid->op_next = (OP*)gwop;
8001 offset = pad_findmy_pvs("$_", 0);
8002 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8003 o->op_private = gwop->op_private = 0;
8004 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8007 o->op_private = gwop->op_private = OPpGREP_LEX;
8008 gwop->op_targ = o->op_targ = offset;
8011 kid = cLISTOPo->op_first->op_sibling;
8012 if (!kid || !kid->op_sibling)
8013 return too_few_arguments(o,OP_DESC(o));
8014 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8015 op_lvalue(kid, OP_GREPSTART);
8021 Perl_ck_index(pTHX_ OP *o)
8023 PERL_ARGS_ASSERT_CK_INDEX;
8025 if (o->op_flags & OPf_KIDS) {
8026 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8028 kid = kid->op_sibling; /* get past "big" */
8029 if (kid && kid->op_type == OP_CONST) {
8030 const bool save_taint = PL_tainted;
8031 fbm_compile(((SVOP*)kid)->op_sv, 0);
8032 PL_tainted = save_taint;
8039 Perl_ck_lfun(pTHX_ OP *o)
8041 const OPCODE type = o->op_type;
8043 PERL_ARGS_ASSERT_CK_LFUN;
8045 return modkids(ck_fun(o), type);
8049 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8051 PERL_ARGS_ASSERT_CK_DEFINED;
8053 if ((o->op_flags & OPf_KIDS)) {
8054 switch (cUNOPo->op_first->op_type) {
8056 /* This is needed for
8057 if (defined %stash::)
8058 to work. Do not break Tk.
8060 break; /* Globals via GV can be undef */
8062 case OP_AASSIGN: /* Is this a good idea? */
8063 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8064 "defined(@array) is deprecated");
8065 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8066 "\t(Maybe you should just omit the defined()?)\n");
8070 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8071 "defined(%%hash) is deprecated");
8072 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8073 "\t(Maybe you should just omit the defined()?)\n");
8084 Perl_ck_readline(pTHX_ OP *o)
8086 PERL_ARGS_ASSERT_CK_READLINE;
8088 if (!(o->op_flags & OPf_KIDS)) {
8090 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8092 op_getmad(o,newop,'O');
8102 Perl_ck_rfun(pTHX_ OP *o)
8104 const OPCODE type = o->op_type;
8106 PERL_ARGS_ASSERT_CK_RFUN;
8108 return refkids(ck_fun(o), type);
8112 Perl_ck_listiob(pTHX_ OP *o)
8116 PERL_ARGS_ASSERT_CK_LISTIOB;
8118 kid = cLISTOPo->op_first;
8121 kid = cLISTOPo->op_first;
8123 if (kid->op_type == OP_PUSHMARK)
8124 kid = kid->op_sibling;
8125 if (kid && o->op_flags & OPf_STACKED)
8126 kid = kid->op_sibling;
8127 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8128 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8129 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8130 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8131 cLISTOPo->op_first->op_sibling = kid;
8132 cLISTOPo->op_last = kid;
8133 kid = kid->op_sibling;
8138 op_append_elem(o->op_type, o, newDEFSVOP());
8144 Perl_ck_smartmatch(pTHX_ OP *o)
8147 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8148 if (0 == (o->op_flags & OPf_SPECIAL)) {
8149 OP *first = cBINOPo->op_first;
8150 OP *second = first->op_sibling;
8152 /* Implicitly take a reference to an array or hash */
8153 first->op_sibling = NULL;
8154 first = cBINOPo->op_first = ref_array_or_hash(first);
8155 second = first->op_sibling = ref_array_or_hash(second);
8157 /* Implicitly take a reference to a regular expression */
8158 if (first->op_type == OP_MATCH) {
8159 first->op_type = OP_QR;
8160 first->op_ppaddr = PL_ppaddr[OP_QR];
8162 if (second->op_type == OP_MATCH) {
8163 second->op_type = OP_QR;
8164 second->op_ppaddr = PL_ppaddr[OP_QR];
8173 Perl_ck_sassign(pTHX_ OP *o)
8176 OP * const kid = cLISTOPo->op_first;
8178 PERL_ARGS_ASSERT_CK_SASSIGN;
8180 /* has a disposable target? */
8181 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8182 && !(kid->op_flags & OPf_STACKED)
8183 /* Cannot steal the second time! */
8184 && !(kid->op_private & OPpTARGET_MY)
8185 /* Keep the full thing for madskills */
8189 OP * const kkid = kid->op_sibling;
8191 /* Can just relocate the target. */
8192 if (kkid && kkid->op_type == OP_PADSV
8193 && !(kkid->op_private & OPpLVAL_INTRO))
8195 kid->op_targ = kkid->op_targ;
8197 /* Now we do not need PADSV and SASSIGN. */
8198 kid->op_sibling = o->op_sibling; /* NULL */
8199 cLISTOPo->op_first = NULL;
8202 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8206 if (kid->op_sibling) {
8207 OP *kkid = kid->op_sibling;
8208 /* For state variable assignment, kkid is a list op whose op_last
8210 if ((kkid->op_type == OP_PADSV ||
8211 (kkid->op_type == OP_LIST &&
8212 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8215 && (kkid->op_private & OPpLVAL_INTRO)
8216 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8217 const PADOFFSET target = kkid->op_targ;
8218 OP *const other = newOP(OP_PADSV,
8220 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8221 OP *const first = newOP(OP_NULL, 0);
8222 OP *const nullop = newCONDOP(0, first, o, other);
8223 OP *const condop = first->op_next;
8224 /* hijacking PADSTALE for uninitialized state variables */
8225 SvPADSTALE_on(PAD_SVl(target));
8227 condop->op_type = OP_ONCE;
8228 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8229 condop->op_targ = target;
8230 other->op_targ = target;
8232 /* Because we change the type of the op here, we will skip the
8233 assignment binop->op_last = binop->op_first->op_sibling; at the
8234 end of Perl_newBINOP(). So need to do it here. */
8235 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8244 Perl_ck_match(pTHX_ OP *o)
8248 PERL_ARGS_ASSERT_CK_MATCH;
8250 if (o->op_type != OP_QR && PL_compcv) {
8251 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8252 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8253 o->op_targ = offset;
8254 o->op_private |= OPpTARGET_MY;
8257 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8258 o->op_private |= OPpRUNTIME;
8263 Perl_ck_method(pTHX_ OP *o)
8265 OP * const kid = cUNOPo->op_first;
8267 PERL_ARGS_ASSERT_CK_METHOD;
8269 if (kid->op_type == OP_CONST) {
8270 SV* sv = kSVOP->op_sv;
8271 const char * const method = SvPVX_const(sv);
8272 if (!(strchr(method, ':') || strchr(method, '\''))) {
8274 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8275 sv = newSVpvn_share(method, SvCUR(sv), 0);
8278 kSVOP->op_sv = NULL;
8280 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8282 op_getmad(o,cmop,'O');
8293 Perl_ck_null(pTHX_ OP *o)
8295 PERL_ARGS_ASSERT_CK_NULL;
8296 PERL_UNUSED_CONTEXT;
8301 Perl_ck_open(pTHX_ OP *o)
8304 HV * const table = GvHV(PL_hintgv);
8306 PERL_ARGS_ASSERT_CK_OPEN;
8309 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8312 const char *d = SvPV_const(*svp, len);
8313 const I32 mode = mode_from_discipline(d, len);
8314 if (mode & O_BINARY)
8315 o->op_private |= OPpOPEN_IN_RAW;
8316 else if (mode & O_TEXT)
8317 o->op_private |= OPpOPEN_IN_CRLF;
8320 svp = hv_fetchs(table, "open_OUT", FALSE);
8323 const char *d = SvPV_const(*svp, len);
8324 const I32 mode = mode_from_discipline(d, len);
8325 if (mode & O_BINARY)
8326 o->op_private |= OPpOPEN_OUT_RAW;
8327 else if (mode & O_TEXT)
8328 o->op_private |= OPpOPEN_OUT_CRLF;
8331 if (o->op_type == OP_BACKTICK) {
8332 if (!(o->op_flags & OPf_KIDS)) {
8333 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8335 op_getmad(o,newop,'O');
8344 /* In case of three-arg dup open remove strictness
8345 * from the last arg if it is a bareword. */
8346 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8347 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8351 if ((last->op_type == OP_CONST) && /* The bareword. */
8352 (last->op_private & OPpCONST_BARE) &&
8353 (last->op_private & OPpCONST_STRICT) &&
8354 (oa = first->op_sibling) && /* The fh. */
8355 (oa = oa->op_sibling) && /* The mode. */
8356 (oa->op_type == OP_CONST) &&
8357 SvPOK(((SVOP*)oa)->op_sv) &&
8358 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8359 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8360 (last == oa->op_sibling)) /* The bareword. */
8361 last->op_private &= ~OPpCONST_STRICT;
8367 Perl_ck_repeat(pTHX_ OP *o)
8369 PERL_ARGS_ASSERT_CK_REPEAT;
8371 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8372 o->op_private |= OPpREPEAT_DOLIST;
8373 cBINOPo->op_first = force_list(cBINOPo->op_first);
8381 Perl_ck_require(pTHX_ OP *o)
8386 PERL_ARGS_ASSERT_CK_REQUIRE;
8388 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8389 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8391 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8392 SV * const sv = kid->op_sv;
8393 U32 was_readonly = SvREADONLY(sv);
8400 sv_force_normal_flags(sv, 0);
8401 assert(!SvREADONLY(sv));
8411 for (; s < end; s++) {
8412 if (*s == ':' && s[1] == ':') {
8414 Move(s+2, s+1, end - s - 1, char);
8419 sv_catpvs(sv, ".pm");
8420 SvFLAGS(sv) |= was_readonly;
8424 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8425 /* handle override, if any */
8426 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8427 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8428 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8429 gv = gvp ? *gvp : NULL;
8433 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8434 OP * const kid = cUNOPo->op_first;
8437 cUNOPo->op_first = 0;
8441 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8442 op_append_elem(OP_LIST, kid,
8443 scalar(newUNOP(OP_RV2CV, 0,
8446 op_getmad(o,newop,'O');
8450 return scalar(ck_fun(o));
8454 Perl_ck_return(pTHX_ OP *o)
8459 PERL_ARGS_ASSERT_CK_RETURN;
8461 kid = cLISTOPo->op_first->op_sibling;
8462 if (CvLVALUE(PL_compcv)) {
8463 for (; kid; kid = kid->op_sibling)
8464 op_lvalue(kid, OP_LEAVESUBLV);
8471 Perl_ck_select(pTHX_ OP *o)
8476 PERL_ARGS_ASSERT_CK_SELECT;
8478 if (o->op_flags & OPf_KIDS) {
8479 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8480 if (kid && kid->op_sibling) {
8481 o->op_type = OP_SSELECT;
8482 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8484 return fold_constants(o);
8488 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8489 if (kid && kid->op_type == OP_RV2GV)
8490 kid->op_private &= ~HINT_STRICT_REFS;
8495 Perl_ck_shift(pTHX_ OP *o)
8498 const I32 type = o->op_type;
8500 PERL_ARGS_ASSERT_CK_SHIFT;
8502 if (!(o->op_flags & OPf_KIDS)) {
8505 if (!CvUNIQUE(PL_compcv)) {
8506 o->op_flags |= OPf_SPECIAL;
8510 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8513 OP * const oldo = o;
8514 o = newUNOP(type, 0, scalar(argop));
8515 op_getmad(oldo,o,'O');
8520 return newUNOP(type, 0, scalar(argop));
8523 return scalar(ck_fun(o));
8527 Perl_ck_sort(pTHX_ OP *o)
8532 PERL_ARGS_ASSERT_CK_SORT;
8534 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8535 HV * const hinthv = GvHV(PL_hintgv);
8537 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8539 const I32 sorthints = (I32)SvIV(*svp);
8540 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8541 o->op_private |= OPpSORT_QSORT;
8542 if ((sorthints & HINT_SORT_STABLE) != 0)
8543 o->op_private |= OPpSORT_STABLE;
8548 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8550 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8551 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8553 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8555 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8557 if (kid->op_type == OP_SCOPE) {
8561 else if (kid->op_type == OP_LEAVE) {
8562 if (o->op_type == OP_SORT) {
8563 op_null(kid); /* wipe out leave */
8566 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8567 if (k->op_next == kid)
8569 /* don't descend into loops */
8570 else if (k->op_type == OP_ENTERLOOP
8571 || k->op_type == OP_ENTERITER)
8573 k = cLOOPx(k)->op_lastop;
8578 kid->op_next = 0; /* just disconnect the leave */
8579 k = kLISTOP->op_first;
8584 if (o->op_type == OP_SORT) {
8585 /* provide scalar context for comparison function/block */
8591 o->op_flags |= OPf_SPECIAL;
8593 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8596 firstkid = firstkid->op_sibling;
8599 /* provide list context for arguments */
8600 if (o->op_type == OP_SORT)
8607 S_simplify_sort(pTHX_ OP *o)
8610 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8616 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8618 if (!(o->op_flags & OPf_STACKED))
8620 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8621 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8622 kid = kUNOP->op_first; /* get past null */
8623 if (kid->op_type != OP_SCOPE)
8625 kid = kLISTOP->op_last; /* get past scope */
8626 switch(kid->op_type) {
8634 k = kid; /* remember this node*/
8635 if (kBINOP->op_first->op_type != OP_RV2SV)
8637 kid = kBINOP->op_first; /* get past cmp */
8638 if (kUNOP->op_first->op_type != OP_GV)
8640 kid = kUNOP->op_first; /* get past rv2sv */
8642 if (GvSTASH(gv) != PL_curstash)
8644 gvname = GvNAME(gv);
8645 if (*gvname == 'a' && gvname[1] == '\0')
8647 else if (*gvname == 'b' && gvname[1] == '\0')
8652 kid = k; /* back to cmp */
8653 if (kBINOP->op_last->op_type != OP_RV2SV)
8655 kid = kBINOP->op_last; /* down to 2nd arg */
8656 if (kUNOP->op_first->op_type != OP_GV)
8658 kid = kUNOP->op_first; /* get past rv2sv */
8660 if (GvSTASH(gv) != PL_curstash)
8662 gvname = GvNAME(gv);
8664 ? !(*gvname == 'a' && gvname[1] == '\0')
8665 : !(*gvname == 'b' && gvname[1] == '\0'))
8667 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8669 o->op_private |= OPpSORT_DESCEND;
8670 if (k->op_type == OP_NCMP)
8671 o->op_private |= OPpSORT_NUMERIC;
8672 if (k->op_type == OP_I_NCMP)
8673 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8674 kid = cLISTOPo->op_first->op_sibling;
8675 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8677 op_getmad(kid,o,'S'); /* then delete it */
8679 op_free(kid); /* then delete it */
8684 Perl_ck_split(pTHX_ OP *o)
8689 PERL_ARGS_ASSERT_CK_SPLIT;
8691 if (o->op_flags & OPf_STACKED)
8692 return no_fh_allowed(o);
8694 kid = cLISTOPo->op_first;
8695 if (kid->op_type != OP_NULL)
8696 Perl_croak(aTHX_ "panic: ck_split");
8697 kid = kid->op_sibling;
8698 op_free(cLISTOPo->op_first);
8700 cLISTOPo->op_first = kid;
8702 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8703 cLISTOPo->op_last = kid; /* There was only one element previously */
8706 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8707 OP * const sibl = kid->op_sibling;
8708 kid->op_sibling = 0;
8709 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8710 if (cLISTOPo->op_first == cLISTOPo->op_last)
8711 cLISTOPo->op_last = kid;
8712 cLISTOPo->op_first = kid;
8713 kid->op_sibling = sibl;
8716 kid->op_type = OP_PUSHRE;
8717 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8719 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8720 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8721 "Use of /g modifier is meaningless in split");
8724 if (!kid->op_sibling)
8725 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8727 kid = kid->op_sibling;
8730 if (!kid->op_sibling)
8731 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8732 assert(kid->op_sibling);
8734 kid = kid->op_sibling;
8737 if (kid->op_sibling)
8738 return too_many_arguments(o,OP_DESC(o));
8744 Perl_ck_join(pTHX_ OP *o)
8746 const OP * const kid = cLISTOPo->op_first->op_sibling;
8748 PERL_ARGS_ASSERT_CK_JOIN;
8750 if (kid && kid->op_type == OP_MATCH) {
8751 if (ckWARN(WARN_SYNTAX)) {
8752 const REGEXP *re = PM_GETRE(kPMOP);
8753 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8754 const STRLEN len = re ? RX_PRELEN(re) : 6;
8755 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8756 "/%.*s/ should probably be written as \"%.*s\"",
8757 (int)len, pmstr, (int)len, pmstr);
8764 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8766 Examines an op, which is expected to identify a subroutine at runtime,
8767 and attempts to determine at compile time which subroutine it identifies.
8768 This is normally used during Perl compilation to determine whether
8769 a prototype can be applied to a function call. I<cvop> is the op
8770 being considered, normally an C<rv2cv> op. A pointer to the identified
8771 subroutine is returned, if it could be determined statically, and a null
8772 pointer is returned if it was not possible to determine statically.
8774 Currently, the subroutine can be identified statically if the RV that the
8775 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8776 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8777 suitable if the constant value must be an RV pointing to a CV. Details of
8778 this process may change in future versions of Perl. If the C<rv2cv> op
8779 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8780 the subroutine statically: this flag is used to suppress compile-time
8781 magic on a subroutine call, forcing it to use default runtime behaviour.
8783 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8784 of a GV reference is modified. If a GV was examined and its CV slot was
8785 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8786 If the op is not optimised away, and the CV slot is later populated with
8787 a subroutine having a prototype, that flag eventually triggers the warning
8788 "called too early to check prototype".
8790 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8791 of returning a pointer to the subroutine it returns a pointer to the
8792 GV giving the most appropriate name for the subroutine in this context.
8793 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8794 (C<CvANON>) subroutine that is referenced through a GV it will be the
8795 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8796 A null pointer is returned as usual if there is no statically-determinable
8803 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8808 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8809 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8810 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8811 if (cvop->op_type != OP_RV2CV)
8813 if (cvop->op_private & OPpENTERSUB_AMPER)
8815 if (!(cvop->op_flags & OPf_KIDS))
8817 rvop = cUNOPx(cvop)->op_first;
8818 switch (rvop->op_type) {
8820 gv = cGVOPx_gv(rvop);
8823 if (flags & RV2CVOPCV_MARK_EARLY)
8824 rvop->op_private |= OPpEARLY_CV;
8829 SV *rv = cSVOPx_sv(rvop);
8839 if (SvTYPE((SV*)cv) != SVt_PVCV)
8841 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8842 if (!CvANON(cv) || !gv)
8851 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8853 Performs the default fixup of the arguments part of an C<entersub>
8854 op tree. This consists of applying list context to each of the
8855 argument ops. This is the standard treatment used on a call marked
8856 with C<&>, or a method call, or a call through a subroutine reference,
8857 or any other call where the callee can't be identified at compile time,
8858 or a call where the callee has no prototype.
8864 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8867 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8868 aop = cUNOPx(entersubop)->op_first;
8869 if (!aop->op_sibling)
8870 aop = cUNOPx(aop)->op_first;
8871 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8872 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8874 op_lvalue(aop, OP_ENTERSUB);
8881 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8883 Performs the fixup of the arguments part of an C<entersub> op tree
8884 based on a subroutine prototype. This makes various modifications to
8885 the argument ops, from applying context up to inserting C<refgen> ops,
8886 and checking the number and syntactic types of arguments, as directed by
8887 the prototype. This is the standard treatment used on a subroutine call,
8888 not marked with C<&>, where the callee can be identified at compile time
8889 and has a prototype.
8891 I<protosv> supplies the subroutine prototype to be applied to the call.
8892 It may be a normal defined scalar, of which the string value will be used.
8893 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8894 that has been cast to C<SV*>) which has a prototype. The prototype
8895 supplied, in whichever form, does not need to match the actual callee
8896 referenced by the op tree.
8898 If the argument ops disagree with the prototype, for example by having
8899 an unacceptable number of arguments, a valid op tree is returned anyway.
8900 The error is reflected in the parser state, normally resulting in a single
8901 exception at the top level of parsing which covers all the compilation
8902 errors that occurred. In the error message, the callee is referred to
8903 by the name defined by the I<namegv> parameter.
8909 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8912 const char *proto, *proto_end;
8913 OP *aop, *prev, *cvop;
8916 I32 contextclass = 0;
8917 const char *e = NULL;
8918 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8919 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8920 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8921 proto = SvPV(protosv, proto_len);
8922 proto_end = proto + proto_len;
8923 aop = cUNOPx(entersubop)->op_first;
8924 if (!aop->op_sibling)
8925 aop = cUNOPx(aop)->op_first;
8927 aop = aop->op_sibling;
8928 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8929 while (aop != cvop) {
8931 if (PL_madskills && aop->op_type == OP_STUB) {
8932 aop = aop->op_sibling;
8935 if (PL_madskills && aop->op_type == OP_NULL)
8936 o3 = ((UNOP*)aop)->op_first;
8940 if (proto >= proto_end)
8941 return too_many_arguments(entersubop, gv_ename(namegv));
8949 /* _ must be at the end */
8950 if (proto[1] && proto[1] != ';')
8965 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8967 arg == 1 ? "block or sub {}" : "sub {}",
8968 gv_ename(namegv), o3);
8971 /* '*' allows any scalar type, including bareword */
8974 if (o3->op_type == OP_RV2GV)
8975 goto wrapref; /* autoconvert GLOB -> GLOBref */
8976 else if (o3->op_type == OP_CONST)
8977 o3->op_private &= ~OPpCONST_STRICT;
8978 else if (o3->op_type == OP_ENTERSUB) {
8979 /* accidental subroutine, revert to bareword */
8980 OP *gvop = ((UNOP*)o3)->op_first;
8981 if (gvop && gvop->op_type == OP_NULL) {
8982 gvop = ((UNOP*)gvop)->op_first;
8984 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8987 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8988 (gvop = ((UNOP*)gvop)->op_first) &&
8989 gvop->op_type == OP_GV)
8991 GV * const gv = cGVOPx_gv(gvop);
8992 OP * const sibling = aop->op_sibling;
8993 SV * const n = newSVpvs("");
8995 OP * const oldaop = aop;
8999 gv_fullname4(n, gv, "", FALSE);
9000 aop = newSVOP(OP_CONST, 0, n);
9001 op_getmad(oldaop,aop,'O');
9002 prev->op_sibling = aop;
9003 aop->op_sibling = sibling;
9013 if (o3->op_type == OP_RV2AV ||
9014 o3->op_type == OP_PADAV ||
9015 o3->op_type == OP_RV2HV ||
9016 o3->op_type == OP_PADHV
9031 if (contextclass++ == 0) {
9032 e = strchr(proto, ']');
9033 if (!e || e == proto)
9042 const char *p = proto;
9043 const char *const end = proto;
9046 /* \[$] accepts any scalar lvalue */
9048 && Perl_op_lvalue_flags(aTHX_
9050 OP_READ, /* not entersub */
9053 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
9055 gv_ename(namegv), o3);
9060 if (o3->op_type == OP_RV2GV)
9063 bad_type(arg, "symbol", gv_ename(namegv), o3);
9066 if (o3->op_type == OP_ENTERSUB)
9069 bad_type(arg, "subroutine entry", gv_ename(namegv),
9073 if (o3->op_type == OP_RV2SV ||
9074 o3->op_type == OP_PADSV ||
9075 o3->op_type == OP_HELEM ||
9076 o3->op_type == OP_AELEM)
9078 if (!contextclass) {
9079 /* \$ accepts any scalar lvalue */
9080 if (Perl_op_lvalue_flags(aTHX_
9082 OP_READ, /* not entersub */
9085 bad_type(arg, "scalar", gv_ename(namegv), o3);
9089 if (o3->op_type == OP_RV2AV ||
9090 o3->op_type == OP_PADAV)
9093 bad_type(arg, "array", gv_ename(namegv), o3);
9096 if (o3->op_type == OP_RV2HV ||
9097 o3->op_type == OP_PADHV)
9100 bad_type(arg, "hash", gv_ename(namegv), o3);
9104 OP* const kid = aop;
9105 OP* const sib = kid->op_sibling;
9106 kid->op_sibling = 0;
9107 aop = newUNOP(OP_REFGEN, 0, kid);
9108 aop->op_sibling = sib;
9109 prev->op_sibling = aop;
9111 if (contextclass && e) {
9126 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
9127 gv_ename(namegv), SVfARG(protosv));
9130 op_lvalue(aop, OP_ENTERSUB);
9132 aop = aop->op_sibling;
9134 if (aop == cvop && *proto == '_') {
9135 /* generate an access to $_ */
9137 aop->op_sibling = prev->op_sibling;
9138 prev->op_sibling = aop; /* instead of cvop */
9140 if (!optional && proto_end > proto &&
9141 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9142 return too_few_arguments(entersubop, gv_ename(namegv));
9147 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9149 Performs the fixup of the arguments part of an C<entersub> op tree either
9150 based on a subroutine prototype or using default list-context processing.
9151 This is the standard treatment used on a subroutine call, not marked
9152 with C<&>, where the callee can be identified at compile time.
9154 I<protosv> supplies the subroutine prototype to be applied to the call,
9155 or indicates that there is no prototype. It may be a normal scalar,
9156 in which case if it is defined then the string value will be used
9157 as a prototype, and if it is undefined then there is no prototype.
9158 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9159 that has been cast to C<SV*>), of which the prototype will be used if it
9160 has one. The prototype (or lack thereof) supplied, in whichever form,
9161 does not need to match the actual callee referenced by the op tree.
9163 If the argument ops disagree with the prototype, for example by having
9164 an unacceptable number of arguments, a valid op tree is returned anyway.
9165 The error is reflected in the parser state, normally resulting in a single
9166 exception at the top level of parsing which covers all the compilation
9167 errors that occurred. In the error message, the callee is referred to
9168 by the name defined by the I<namegv> parameter.
9174 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9175 GV *namegv, SV *protosv)
9177 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9178 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9179 return ck_entersub_args_proto(entersubop, namegv, protosv);
9181 return ck_entersub_args_list(entersubop);
9185 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9187 Retrieves the function that will be used to fix up a call to I<cv>.
9188 Specifically, the function is applied to an C<entersub> op tree for a
9189 subroutine call, not marked with C<&>, where the callee can be identified
9190 at compile time as I<cv>.
9192 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9193 argument for it is returned in I<*ckobj_p>. The function is intended
9194 to be called in this manner:
9196 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9198 In this call, I<entersubop> is a pointer to the C<entersub> op,
9199 which may be replaced by the check function, and I<namegv> is a GV
9200 supplying the name that should be used by the check function to refer
9201 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9202 It is permitted to apply the check function in non-standard situations,
9203 such as to a call to a different subroutine or to a method call.
9205 By default, the function is
9206 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9207 and the SV parameter is I<cv> itself. This implements standard
9208 prototype processing. It can be changed, for a particular subroutine,
9209 by L</cv_set_call_checker>.
9215 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9218 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9219 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9221 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9222 *ckobj_p = callmg->mg_obj;
9224 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9230 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9232 Sets the function that will be used to fix up a call to I<cv>.
9233 Specifically, the function is applied to an C<entersub> op tree for a
9234 subroutine call, not marked with C<&>, where the callee can be identified
9235 at compile time as I<cv>.
9237 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9238 for it is supplied in I<ckobj>. The function is intended to be called
9241 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9243 In this call, I<entersubop> is a pointer to the C<entersub> op,
9244 which may be replaced by the check function, and I<namegv> is a GV
9245 supplying the name that should be used by the check function to refer
9246 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9247 It is permitted to apply the check function in non-standard situations,
9248 such as to a call to a different subroutine or to a method call.
9250 The current setting for a particular CV can be retrieved by
9251 L</cv_get_call_checker>.
9257 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9259 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9260 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9261 if (SvMAGICAL((SV*)cv))
9262 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9265 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9266 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9267 if (callmg->mg_flags & MGf_REFCOUNTED) {
9268 SvREFCNT_dec(callmg->mg_obj);
9269 callmg->mg_flags &= ~MGf_REFCOUNTED;
9271 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9272 callmg->mg_obj = ckobj;
9273 if (ckobj != (SV*)cv) {
9274 SvREFCNT_inc_simple_void_NN(ckobj);
9275 callmg->mg_flags |= MGf_REFCOUNTED;
9281 Perl_ck_subr(pTHX_ OP *o)
9287 PERL_ARGS_ASSERT_CK_SUBR;
9289 aop = cUNOPx(o)->op_first;
9290 if (!aop->op_sibling)
9291 aop = cUNOPx(aop)->op_first;
9292 aop = aop->op_sibling;
9293 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9294 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9295 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9297 o->op_private &= ~1;
9298 o->op_private |= OPpENTERSUB_HASTARG;
9299 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9300 if (PERLDB_SUB && PL_curstash != PL_debstash)
9301 o->op_private |= OPpENTERSUB_DB;
9302 if (cvop->op_type == OP_RV2CV) {
9303 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9305 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9306 if (aop->op_type == OP_CONST)
9307 aop->op_private &= ~OPpCONST_STRICT;
9308 else if (aop->op_type == OP_LIST) {
9309 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9310 if (sib && sib->op_type == OP_CONST)
9311 sib->op_private &= ~OPpCONST_STRICT;
9316 return ck_entersub_args_list(o);
9318 Perl_call_checker ckfun;
9320 cv_get_call_checker(cv, &ckfun, &ckobj);
9321 return ckfun(aTHX_ o, namegv, ckobj);
9326 Perl_ck_svconst(pTHX_ OP *o)
9328 PERL_ARGS_ASSERT_CK_SVCONST;
9329 PERL_UNUSED_CONTEXT;
9330 SvREADONLY_on(cSVOPo->op_sv);
9335 Perl_ck_chdir(pTHX_ OP *o)
9337 PERL_ARGS_ASSERT_CK_CHDIR;
9338 if (o->op_flags & OPf_KIDS) {
9339 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9341 if (kid && kid->op_type == OP_CONST &&
9342 (kid->op_private & OPpCONST_BARE))
9344 o->op_flags |= OPf_SPECIAL;
9345 kid->op_private &= ~OPpCONST_STRICT;
9352 Perl_ck_trunc(pTHX_ OP *o)
9354 PERL_ARGS_ASSERT_CK_TRUNC;
9356 if (o->op_flags & OPf_KIDS) {
9357 SVOP *kid = (SVOP*)cUNOPo->op_first;
9359 if (kid->op_type == OP_NULL)
9360 kid = (SVOP*)kid->op_sibling;
9361 if (kid && kid->op_type == OP_CONST &&
9362 (kid->op_private & OPpCONST_BARE))
9364 o->op_flags |= OPf_SPECIAL;
9365 kid->op_private &= ~OPpCONST_STRICT;
9372 Perl_ck_unpack(pTHX_ OP *o)
9374 OP *kid = cLISTOPo->op_first;
9376 PERL_ARGS_ASSERT_CK_UNPACK;
9378 if (kid->op_sibling) {
9379 kid = kid->op_sibling;
9380 if (!kid->op_sibling)
9381 kid->op_sibling = newDEFSVOP();
9387 Perl_ck_substr(pTHX_ OP *o)
9389 PERL_ARGS_ASSERT_CK_SUBSTR;
9392 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9393 OP *kid = cLISTOPo->op_first;
9395 if (kid->op_type == OP_NULL)
9396 kid = kid->op_sibling;
9398 kid->op_flags |= OPf_MOD;
9405 Perl_ck_each(pTHX_ OP *o)
9408 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9409 const unsigned orig_type = o->op_type;
9410 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9411 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9412 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9413 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9415 PERL_ARGS_ASSERT_CK_EACH;
9418 switch (kid->op_type) {
9424 CHANGE_TYPE(o, array_type);
9427 if (kid->op_private == OPpCONST_BARE
9428 || !SvROK(cSVOPx_sv(kid))
9429 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9430 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9432 /* we let ck_fun handle it */
9435 CHANGE_TYPE(o, ref_type);
9439 /* if treating as a reference, defer additional checks to runtime */
9440 return o->op_type == ref_type ? o : ck_fun(o);
9443 /* caller is supposed to assign the return to the
9444 container of the rep_op var */
9446 S_opt_scalarhv(pTHX_ OP *rep_op) {
9450 PERL_ARGS_ASSERT_OPT_SCALARHV;
9452 NewOp(1101, unop, 1, UNOP);
9453 unop->op_type = (OPCODE)OP_BOOLKEYS;
9454 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9455 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9456 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9457 unop->op_first = rep_op;
9458 unop->op_next = rep_op->op_next;
9459 rep_op->op_next = (OP*)unop;
9460 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9461 unop->op_sibling = rep_op->op_sibling;
9462 rep_op->op_sibling = NULL;
9463 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9464 if (rep_op->op_type == OP_PADHV) {
9465 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9466 rep_op->op_flags |= OPf_WANT_LIST;
9471 /* Checks if o acts as an in-place operator on an array. oright points to the
9472 * beginning of the right-hand side. Returns the left-hand side of the
9473 * assignment if o acts in-place, or NULL otherwise. */
9476 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9480 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9483 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9484 || oright->op_next != o
9485 || (oright->op_private & OPpLVAL_INTRO)
9489 /* o2 follows the chain of op_nexts through the LHS of the
9490 * assign (if any) to the aassign op itself */
9492 if (!o2 || o2->op_type != OP_NULL)
9495 if (!o2 || o2->op_type != OP_PUSHMARK)
9498 if (o2 && o2->op_type == OP_GV)
9501 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9502 || (o2->op_private & OPpLVAL_INTRO)
9507 if (!o2 || o2->op_type != OP_NULL)
9510 if (!o2 || o2->op_type != OP_AASSIGN
9511 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9514 /* check that the sort is the first arg on RHS of assign */
9516 o2 = cUNOPx(o2)->op_first;
9517 if (!o2 || o2->op_type != OP_NULL)
9519 o2 = cUNOPx(o2)->op_first;
9520 if (!o2 || o2->op_type != OP_PUSHMARK)
9522 if (o2->op_sibling != o)
9525 /* check the array is the same on both sides */
9526 if (oleft->op_type == OP_RV2AV) {
9527 if (oright->op_type != OP_RV2AV
9528 || !cUNOPx(oright)->op_first
9529 || cUNOPx(oright)->op_first->op_type != OP_GV
9530 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9531 cGVOPx_gv(cUNOPx(oright)->op_first)
9535 else if (oright->op_type != OP_PADAV
9536 || oright->op_targ != oleft->op_targ
9543 #define MAX_DEFERRED 4
9546 if (defer_ix == (MAX_DEFERRED-1)) { \
9547 CALL_RPEEP(defer_queue[defer_base]); \
9548 defer_base = (defer_base + 1) % MAX_DEFERRED; \
9551 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
9553 /* A peephole optimizer. We visit the ops in the order they're to execute.
9554 * See the comments at the top of this file for more details about when
9555 * peep() is called */
9558 Perl_rpeep(pTHX_ register OP *o)
9561 register OP* oldop = NULL;
9562 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
9566 if (!o || o->op_opt)
9570 SAVEVPTR(PL_curcop);
9571 for (;; o = o->op_next) {
9575 while (defer_ix >= 0)
9576 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
9580 /* By default, this op has now been optimised. A couple of cases below
9581 clear this again. */
9584 switch (o->op_type) {
9586 PL_curcop = ((COP*)o); /* for warnings */
9589 PL_curcop = ((COP*)o); /* for warnings */
9591 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9592 to carry two labels. For now, take the easier option, and skip
9593 this optimisation if the first NEXTSTATE has a label. */
9594 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9595 OP *nextop = o->op_next;
9596 while (nextop && nextop->op_type == OP_NULL)
9597 nextop = nextop->op_next;
9599 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9600 COP *firstcop = (COP *)o;
9601 COP *secondcop = (COP *)nextop;
9602 /* We want the COP pointed to by o (and anything else) to
9603 become the next COP down the line. */
9606 firstcop->op_next = secondcop->op_next;
9608 /* Now steal all its pointers, and duplicate the other
9610 firstcop->cop_line = secondcop->cop_line;
9612 firstcop->cop_stashpv = secondcop->cop_stashpv;
9613 firstcop->cop_file = secondcop->cop_file;
9615 firstcop->cop_stash = secondcop->cop_stash;
9616 firstcop->cop_filegv = secondcop->cop_filegv;
9618 firstcop->cop_hints = secondcop->cop_hints;
9619 firstcop->cop_seq = secondcop->cop_seq;
9620 firstcop->cop_warnings = secondcop->cop_warnings;
9621 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9624 secondcop->cop_stashpv = NULL;
9625 secondcop->cop_file = NULL;
9627 secondcop->cop_stash = NULL;
9628 secondcop->cop_filegv = NULL;
9630 secondcop->cop_warnings = NULL;
9631 secondcop->cop_hints_hash = NULL;
9633 /* If we use op_null(), and hence leave an ex-COP, some
9634 warnings are misreported. For example, the compile-time
9635 error in 'use strict; no strict refs;' */
9636 secondcop->op_type = OP_NULL;
9637 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9643 if (cSVOPo->op_private & OPpCONST_STRICT)
9644 no_bareword_allowed(o);
9648 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9649 if (o->op_next->op_private & OPpTARGET_MY) {
9650 if (o->op_flags & OPf_STACKED) /* chained concats */
9651 break; /* ignore_optimization */
9653 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9654 o->op_targ = o->op_next->op_targ;
9655 o->op_next->op_targ = 0;
9656 o->op_private |= OPpTARGET_MY;
9659 op_null(o->op_next);
9663 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9664 break; /* Scalar stub must produce undef. List stub is noop */
9668 if (o->op_targ == OP_NEXTSTATE
9669 || o->op_targ == OP_DBSTATE)
9671 PL_curcop = ((COP*)o);
9673 /* XXX: We avoid setting op_seq here to prevent later calls
9674 to rpeep() from mistakenly concluding that optimisation
9675 has already occurred. This doesn't fix the real problem,
9676 though (See 20010220.007). AMS 20010719 */
9677 /* op_seq functionality is now replaced by op_opt */
9684 if (oldop && o->op_next) {
9685 oldop->op_next = o->op_next;
9693 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9694 OP* const pop = (o->op_type == OP_PADAV) ?
9695 o->op_next : o->op_next->op_next;
9697 if (pop && pop->op_type == OP_CONST &&
9698 ((PL_op = pop->op_next)) &&
9699 pop->op_next->op_type == OP_AELEM &&
9700 !(pop->op_next->op_private &
9701 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9702 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9707 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9708 no_bareword_allowed(pop);
9709 if (o->op_type == OP_GV)
9710 op_null(o->op_next);
9711 op_null(pop->op_next);
9713 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9714 o->op_next = pop->op_next->op_next;
9715 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9716 o->op_private = (U8)i;
9717 if (o->op_type == OP_GV) {
9720 o->op_type = OP_AELEMFAST;
9723 o->op_type = OP_AELEMFAST_LEX;
9728 if (o->op_next->op_type == OP_RV2SV) {
9729 if (!(o->op_next->op_private & OPpDEREF)) {
9730 op_null(o->op_next);
9731 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9733 o->op_next = o->op_next->op_next;
9734 o->op_type = OP_GVSV;
9735 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9738 else if (o->op_next->op_type == OP_READLINE
9739 && o->op_next->op_next->op_type == OP_CONCAT
9740 && (o->op_next->op_next->op_flags & OPf_STACKED))
9742 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9743 o->op_type = OP_RCATLINE;
9744 o->op_flags |= OPf_STACKED;
9745 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9746 op_null(o->op_next->op_next);
9747 op_null(o->op_next);
9757 fop = cUNOP->op_first;
9765 fop = cLOGOP->op_first;
9766 sop = fop->op_sibling;
9767 while (cLOGOP->op_other->op_type == OP_NULL)
9768 cLOGOP->op_other = cLOGOP->op_other->op_next;
9769 while (o->op_next && ( o->op_type == o->op_next->op_type
9770 || o->op_next->op_type == OP_NULL))
9771 o->op_next = o->op_next->op_next;
9772 DEFER(cLOGOP->op_other);
9776 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9778 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9783 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9784 while (nop && nop->op_next) {
9785 switch (nop->op_next->op_type) {
9790 lop = nop = nop->op_next;
9801 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9802 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9803 cLOGOP->op_first = opt_scalarhv(fop);
9804 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9805 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9821 while (cLOGOP->op_other->op_type == OP_NULL)
9822 cLOGOP->op_other = cLOGOP->op_other->op_next;
9823 DEFER(cLOGOP->op_other);
9828 while (cLOOP->op_redoop->op_type == OP_NULL)
9829 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9830 while (cLOOP->op_nextop->op_type == OP_NULL)
9831 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9832 while (cLOOP->op_lastop->op_type == OP_NULL)
9833 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9834 /* a while(1) loop doesn't have an op_next that escapes the
9835 * loop, so we have to explicitly follow the op_lastop to
9836 * process the rest of the code */
9837 DEFER(cLOOP->op_lastop);
9841 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9842 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9843 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9844 cPMOP->op_pmstashstartu.op_pmreplstart
9845 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9846 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
9855 ( oldop->op_type == OP_AELEM
9856 || oldop->op_type == OP_PADSV
9857 || oldop->op_type == OP_RV2SV
9858 || oldop->op_type == OP_RV2GV
9859 || oldop->op_type == OP_HELEM
9861 && (oldop->op_private & OPpDEREF)
9863 || ( oldop->op_type == OP_ENTERSUB
9864 && oldop->op_private & OPpENTERSUB_DEREF )
9867 o->op_private |= OPpDEREFed;
9871 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9875 /* check that RHS of sort is a single plain array */
9876 OP *oright = cUNOPo->op_first;
9877 if (!oright || oright->op_type != OP_PUSHMARK)
9880 /* reverse sort ... can be optimised. */
9881 if (!cUNOPo->op_sibling) {
9882 /* Nothing follows us on the list. */
9883 OP * const reverse = o->op_next;
9885 if (reverse->op_type == OP_REVERSE &&
9886 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9887 OP * const pushmark = cUNOPx(reverse)->op_first;
9888 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9889 && (cUNOPx(pushmark)->op_sibling == o)) {
9890 /* reverse -> pushmark -> sort */
9891 o->op_private |= OPpSORT_REVERSE;
9893 pushmark->op_next = oright->op_next;
9899 /* make @a = sort @a act in-place */
9901 oright = cUNOPx(oright)->op_sibling;
9904 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9905 oright = cUNOPx(oright)->op_sibling;
9908 oleft = is_inplace_av(o, oright);
9912 /* transfer MODishness etc from LHS arg to RHS arg */
9913 oright->op_flags = oleft->op_flags;
9914 o->op_private |= OPpSORT_INPLACE;
9916 /* excise push->gv->rv2av->null->aassign */
9917 o2 = o->op_next->op_next;
9918 op_null(o2); /* PUSHMARK */
9920 if (o2->op_type == OP_GV) {
9921 op_null(o2); /* GV */
9924 op_null(o2); /* RV2AV or PADAV */
9925 o2 = o2->op_next->op_next;
9926 op_null(o2); /* AASSIGN */
9928 o->op_next = o2->op_next;
9934 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9937 LISTOP *enter, *exlist;
9939 /* @a = reverse @a */
9940 if ((oright = cLISTOPo->op_first)
9941 && (oright->op_type == OP_PUSHMARK)
9942 && (oright = oright->op_sibling)
9943 && (oleft = is_inplace_av(o, oright))) {
9946 /* transfer MODishness etc from LHS arg to RHS arg */
9947 oright->op_flags = oleft->op_flags;
9948 o->op_private |= OPpREVERSE_INPLACE;
9950 /* excise push->gv->rv2av->null->aassign */
9951 o2 = o->op_next->op_next;
9952 op_null(o2); /* PUSHMARK */
9954 if (o2->op_type == OP_GV) {
9955 op_null(o2); /* GV */
9958 op_null(o2); /* RV2AV or PADAV */
9959 o2 = o2->op_next->op_next;
9960 op_null(o2); /* AASSIGN */
9962 o->op_next = o2->op_next;
9966 enter = (LISTOP *) o->op_next;
9969 if (enter->op_type == OP_NULL) {
9970 enter = (LISTOP *) enter->op_next;
9974 /* for $a (...) will have OP_GV then OP_RV2GV here.
9975 for (...) just has an OP_GV. */
9976 if (enter->op_type == OP_GV) {
9977 gvop = (OP *) enter;
9978 enter = (LISTOP *) enter->op_next;
9981 if (enter->op_type == OP_RV2GV) {
9982 enter = (LISTOP *) enter->op_next;
9988 if (enter->op_type != OP_ENTERITER)
9991 iter = enter->op_next;
9992 if (!iter || iter->op_type != OP_ITER)
9995 expushmark = enter->op_first;
9996 if (!expushmark || expushmark->op_type != OP_NULL
9997 || expushmark->op_targ != OP_PUSHMARK)
10000 exlist = (LISTOP *) expushmark->op_sibling;
10001 if (!exlist || exlist->op_type != OP_NULL
10002 || exlist->op_targ != OP_LIST)
10005 if (exlist->op_last != o) {
10006 /* Mmm. Was expecting to point back to this op. */
10009 theirmark = exlist->op_first;
10010 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10013 if (theirmark->op_sibling != o) {
10014 /* There's something between the mark and the reverse, eg
10015 for (1, reverse (...))
10020 ourmark = ((LISTOP *)o)->op_first;
10021 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10024 ourlast = ((LISTOP *)o)->op_last;
10025 if (!ourlast || ourlast->op_next != o)
10028 rv2av = ourmark->op_sibling;
10029 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10030 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10031 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10032 /* We're just reversing a single array. */
10033 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10034 enter->op_flags |= OPf_STACKED;
10037 /* We don't have control over who points to theirmark, so sacrifice
10039 theirmark->op_next = ourmark->op_next;
10040 theirmark->op_flags = ourmark->op_flags;
10041 ourlast->op_next = gvop ? gvop : (OP *) enter;
10044 enter->op_private |= OPpITER_REVERSED;
10045 iter->op_private |= OPpITER_REVERSED;
10052 UNOP *refgen, *rv2cv;
10055 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
10058 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
10061 rv2gv = ((BINOP *)o)->op_last;
10062 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
10065 refgen = (UNOP *)((BINOP *)o)->op_first;
10067 if (!refgen || refgen->op_type != OP_REFGEN)
10070 exlist = (LISTOP *)refgen->op_first;
10071 if (!exlist || exlist->op_type != OP_NULL
10072 || exlist->op_targ != OP_LIST)
10075 if (exlist->op_first->op_type != OP_PUSHMARK)
10078 rv2cv = (UNOP*)exlist->op_last;
10080 if (rv2cv->op_type != OP_RV2CV)
10083 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
10084 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
10085 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
10087 o->op_private |= OPpASSIGN_CV_TO_GV;
10088 rv2gv->op_private |= OPpDONT_INIT_GV;
10089 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
10097 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10098 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10103 Perl_cpeep_t cpeep =
10104 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10106 cpeep(aTHX_ o, oldop);
10117 Perl_peep(pTHX_ register OP *o)
10123 =head1 Custom Operators
10125 =for apidoc Ao||custom_op_xop
10126 Return the XOP structure for a given custom op. This function should be
10127 considered internal to OP_NAME and the other access macros: use them instead.
10133 Perl_custom_op_xop(pTHX_ const OP *o)
10139 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10141 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10142 assert(o->op_type == OP_CUSTOM);
10144 /* This is wrong. It assumes a function pointer can be cast to IV,
10145 * which isn't guaranteed, but this is what the old custom OP code
10146 * did. In principle it should be safer to Copy the bytes of the
10147 * pointer into a PV: since the new interface is hidden behind
10148 * functions, this can be changed later if necessary. */
10149 /* Change custom_op_xop if this ever happens */
10150 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10153 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10155 /* assume noone will have just registered a desc */
10156 if (!he && PL_custom_op_names &&
10157 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10162 /* XXX does all this need to be shared mem? */
10163 Newxz(xop, 1, XOP);
10164 pv = SvPV(HeVAL(he), l);
10165 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10166 if (PL_custom_op_descs &&
10167 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10169 pv = SvPV(HeVAL(he), l);
10170 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10172 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10176 if (!he) return &xop_null;
10178 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10183 =for apidoc Ao||custom_op_register
10184 Register a custom op. See L<perlguts/"Custom Operators">.
10190 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10194 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10196 /* see the comment in custom_op_xop */
10197 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10199 if (!PL_custom_ops)
10200 PL_custom_ops = newHV();
10202 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10203 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10207 =head1 Functions in file op.c
10209 =for apidoc core_prototype
10210 This function assigns the prototype of the named core function to C<sv>, or
10211 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10212 NULL if the core function has no prototype.
10214 If the C<name> is not a Perl keyword, it croaks if C<croak> is true, or
10215 returns NULL if C<croak> is false.
10221 Perl_core_prototype(pTHX_ SV *sv, const char *name, const STRLEN len,
10224 const int code = keyword(name, len, 1);
10225 int i = 0, n = 0, seen_question = 0, defgv = 0;
10227 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10228 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10230 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10234 return (SV *)Perl_die(aTHX_
10235 "Can't find an opnumber for \"%s\"", name
10240 if (code > 0) return NULL; /* Not overridable */
10242 if (!sv) sv = sv_newmortal();
10244 #define retsetpvs(x) sv_setpvs(sv, x); return sv
10247 case KEY_and : case KEY_chop: case KEY_chomp:
10248 case KEY_cmp : case KEY_exec: case KEY_eq :
10249 case KEY_ge : case KEY_gt : case KEY_le :
10250 case KEY_lstat : case KEY_lt : case KEY_ne : case KEY_or :
10251 case KEY_stat : case KEY_system: case KEY_x : case KEY_xor:
10253 case KEY_keys: case KEY_values: case KEY_each:
10255 case KEY_push: case KEY_unshift:
10257 case KEY_pop: case KEY_shift:
10260 retsetpvs("+;$$@");
10261 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10269 while (i < MAXO) { /* The slow way. */
10270 if (strEQ(name, PL_op_name[i])
10271 || strEQ(name, PL_op_desc[i]))
10277 return NULL; /* Should not happen... */
10279 defgv = PL_opargs[i] & OA_DEFGV;
10280 oa = PL_opargs[i] >> OASHIFT;
10282 if (oa & OA_OPTIONAL && !seen_question && (!defgv || n)) {
10286 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10287 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10288 /* But globs are already references (kinda) */
10289 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10293 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10294 && !scalar_mod_type(NULL, i)) {
10302 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10305 if (defgv && str[0] == '$')
10308 sv_setpvn(sv, str, n - 1);
10314 /* Efficient sub that returns a constant scalar value. */
10316 const_sv_xsub(pTHX_ CV* cv)
10320 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10324 /* diag_listed_as: SKIPME */
10325 Perl_croak(aTHX_ "usage: %s::%s()",
10326 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10339 * c-indentation-style: bsd
10340 * c-basic-offset: 4
10341 * indent-tabs-mode: t
10344 * ex: set ts=8 sts=4 sw=4 noet: