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_ 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",
377 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
380 /* "register" allocation */
383 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
387 const bool is_our = (PL_parser->in_my == KEY_our);
389 PERL_ARGS_ASSERT_ALLOCMY;
391 if (flags & ~SVf_UTF8)
392 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
395 /* Until we're using the length for real, cross check that we're being
397 assert(strlen(name) == len);
399 /* complain about "my $<special_var>" etc etc */
403 ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) ||
404 (name[1] == '_' && (*name == '$' || len > 2))))
406 /* name[2] is true if strlen(name) > 2 */
407 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
408 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
409 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
410 PL_parser->in_my == KEY_state ? "state" : "my"));
412 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
413 PL_parser->in_my == KEY_state ? "state" : "my"));
417 /* allocate a spare slot and store the name in that slot */
419 off = pad_add_name_pvn(name, len,
420 (is_our ? padadd_OUR :
421 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
422 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
423 PL_parser->in_my_stash,
425 /* $_ is always in main::, even with our */
426 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
430 /* anon sub prototypes contains state vars should always be cloned,
431 * otherwise the state var would be shared between anon subs */
433 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
434 CvCLONE_on(PL_compcv);
439 /* free the body of an op without examining its contents.
440 * Always use this rather than FreeOp directly */
443 S_op_destroy(pTHX_ OP *o)
445 if (o->op_latefree) {
453 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
455 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
461 Perl_op_free(pTHX_ OP *o)
468 if (o->op_latefreed) {
475 if (o->op_private & OPpREFCOUNTED) {
486 refcnt = OpREFCNT_dec(o);
489 /* Need to find and remove any pattern match ops from the list
490 we maintain for reset(). */
491 find_and_forget_pmops(o);
501 /* Call the op_free hook if it has been set. Do it now so that it's called
502 * at the right time for refcounted ops, but still before all of the kids
506 if (o->op_flags & OPf_KIDS) {
507 register OP *kid, *nextkid;
508 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
509 nextkid = kid->op_sibling; /* Get before next freeing kid */
514 #ifdef PERL_DEBUG_READONLY_OPS
518 /* COP* is not cleared by op_clear() so that we may track line
519 * numbers etc even after null() */
520 if (type == OP_NEXTSTATE || type == OP_DBSTATE
521 || (type == OP_NULL /* the COP might have been null'ed */
522 && ((OPCODE)o->op_targ == OP_NEXTSTATE
523 || (OPCODE)o->op_targ == OP_DBSTATE))) {
528 type = (OPCODE)o->op_targ;
531 if (o->op_latefree) {
537 #ifdef DEBUG_LEAKING_SCALARS
544 Perl_op_clear(pTHX_ OP *o)
549 PERL_ARGS_ASSERT_OP_CLEAR;
552 mad_free(o->op_madprop);
557 switch (o->op_type) {
558 case OP_NULL: /* Was holding old type, if any. */
559 if (PL_madskills && o->op_targ != OP_NULL) {
560 o->op_type = (Optype)o->op_targ;
565 case OP_ENTEREVAL: /* Was holding hints. */
569 if (!(o->op_flags & OPf_REF)
570 || (PL_check[o->op_type] != Perl_ck_ftst))
577 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
582 /* It's possible during global destruction that the GV is freed
583 before the optree. Whilst the SvREFCNT_inc is happy to bump from
584 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
585 will trigger an assertion failure, because the entry to sv_clear
586 checks that the scalar is not already freed. A check of for
587 !SvIS_FREED(gv) turns out to be invalid, because during global
588 destruction the reference count can be forced down to zero
589 (with SVf_BREAK set). In which case raising to 1 and then
590 dropping to 0 triggers cleanup before it should happen. I
591 *think* that this might actually be a general, systematic,
592 weakness of the whole idea of SVf_BREAK, in that code *is*
593 allowed to raise and lower references during global destruction,
594 so any *valid* code that happens to do this during global
595 destruction might well trigger premature cleanup. */
596 bool still_valid = gv && SvREFCNT(gv);
599 SvREFCNT_inc_simple_void(gv);
601 if (cPADOPo->op_padix > 0) {
602 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
603 * may still exist on the pad */
604 pad_swipe(cPADOPo->op_padix, TRUE);
605 cPADOPo->op_padix = 0;
608 SvREFCNT_dec(cSVOPo->op_sv);
609 cSVOPo->op_sv = NULL;
612 int try_downgrade = SvREFCNT(gv) == 2;
615 gv_try_downgrade(gv);
619 case OP_METHOD_NAMED:
622 SvREFCNT_dec(cSVOPo->op_sv);
623 cSVOPo->op_sv = NULL;
626 Even if op_clear does a pad_free for the target of the op,
627 pad_free doesn't actually remove the sv that exists in the pad;
628 instead it lives on. This results in that it could be reused as
629 a target later on when the pad was reallocated.
632 pad_swipe(o->op_targ,1);
641 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
646 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
648 if (cPADOPo->op_padix > 0) {
649 pad_swipe(cPADOPo->op_padix, TRUE);
650 cPADOPo->op_padix = 0;
653 SvREFCNT_dec(cSVOPo->op_sv);
654 cSVOPo->op_sv = NULL;
658 PerlMemShared_free(cPVOPo->op_pv);
659 cPVOPo->op_pv = NULL;
663 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
667 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
668 /* No GvIN_PAD_off here, because other references may still
669 * exist on the pad */
670 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
673 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
679 forget_pmop(cPMOPo, 1);
680 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
681 /* we use the same protection as the "SAFE" version of the PM_ macros
682 * here since sv_clean_all might release some PMOPs
683 * after PL_regex_padav has been cleared
684 * and the clearing of PL_regex_padav needs to
685 * happen before sv_clean_all
688 if(PL_regex_pad) { /* We could be in destruction */
689 const IV offset = (cPMOPo)->op_pmoffset;
690 ReREFCNT_dec(PM_GETRE(cPMOPo));
691 PL_regex_pad[offset] = &PL_sv_undef;
692 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
696 ReREFCNT_dec(PM_GETRE(cPMOPo));
697 PM_SETRE(cPMOPo, NULL);
703 if (o->op_targ > 0) {
704 pad_free(o->op_targ);
710 S_cop_free(pTHX_ COP* cop)
712 PERL_ARGS_ASSERT_COP_FREE;
716 if (! specialWARN(cop->cop_warnings))
717 PerlMemShared_free(cop->cop_warnings);
718 cophh_free(CopHINTHASH_get(cop));
722 S_forget_pmop(pTHX_ PMOP *const o
728 HV * const pmstash = PmopSTASH(o);
730 PERL_ARGS_ASSERT_FORGET_PMOP;
732 if (pmstash && !SvIS_FREED(pmstash)) {
733 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
735 PMOP **const array = (PMOP**) mg->mg_ptr;
736 U32 count = mg->mg_len / sizeof(PMOP**);
741 /* Found it. Move the entry at the end to overwrite it. */
742 array[i] = array[--count];
743 mg->mg_len = count * sizeof(PMOP**);
744 /* Could realloc smaller at this point always, but probably
745 not worth it. Probably worth free()ing if we're the
748 Safefree(mg->mg_ptr);
765 S_find_and_forget_pmops(pTHX_ OP *o)
767 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
769 if (o->op_flags & OPf_KIDS) {
770 OP *kid = cUNOPo->op_first;
772 switch (kid->op_type) {
777 forget_pmop((PMOP*)kid, 0);
779 find_and_forget_pmops(kid);
780 kid = kid->op_sibling;
786 Perl_op_null(pTHX_ OP *o)
790 PERL_ARGS_ASSERT_OP_NULL;
792 if (o->op_type == OP_NULL)
796 o->op_targ = o->op_type;
797 o->op_type = OP_NULL;
798 o->op_ppaddr = PL_ppaddr[OP_NULL];
802 Perl_op_refcnt_lock(pTHX)
810 Perl_op_refcnt_unlock(pTHX)
817 /* Contextualizers */
820 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
822 Applies a syntactic context to an op tree representing an expression.
823 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
824 or C<G_VOID> to specify the context to apply. The modified op tree
831 Perl_op_contextualize(pTHX_ OP *o, I32 context)
833 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
835 case G_SCALAR: return scalar(o);
836 case G_ARRAY: return list(o);
837 case G_VOID: return scalarvoid(o);
839 Perl_croak(aTHX_ "panic: op_contextualize bad context");
845 =head1 Optree Manipulation Functions
847 =for apidoc Am|OP*|op_linklist|OP *o
848 This function is the implementation of the L</LINKLIST> macro. It should
849 not be called directly.
855 Perl_op_linklist(pTHX_ OP *o)
859 PERL_ARGS_ASSERT_OP_LINKLIST;
864 /* establish postfix order */
865 first = cUNOPo->op_first;
868 o->op_next = LINKLIST(first);
871 if (kid->op_sibling) {
872 kid->op_next = LINKLIST(kid->op_sibling);
873 kid = kid->op_sibling;
887 S_scalarkids(pTHX_ OP *o)
889 if (o && o->op_flags & OPf_KIDS) {
891 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
898 S_scalarboolean(pTHX_ OP *o)
902 PERL_ARGS_ASSERT_SCALARBOOLEAN;
904 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
905 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
906 if (ckWARN(WARN_SYNTAX)) {
907 const line_t oldline = CopLINE(PL_curcop);
909 if (PL_parser && PL_parser->copline != NOLINE)
910 CopLINE_set(PL_curcop, PL_parser->copline);
911 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
912 CopLINE_set(PL_curcop, oldline);
919 Perl_scalar(pTHX_ OP *o)
924 /* assumes no premature commitment */
925 if (!o || (PL_parser && PL_parser->error_count)
926 || (o->op_flags & OPf_WANT)
927 || o->op_type == OP_RETURN)
932 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
934 switch (o->op_type) {
936 scalar(cBINOPo->op_first);
941 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
951 if (o->op_flags & OPf_KIDS) {
952 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
958 kid = cLISTOPo->op_first;
960 kid = kid->op_sibling;
963 OP *sib = kid->op_sibling;
964 if (sib && kid->op_type != OP_LEAVEWHEN)
970 PL_curcop = &PL_compiling;
975 kid = cLISTOPo->op_first;
978 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
985 Perl_scalarvoid(pTHX_ OP *o)
989 const char* useless = NULL;
990 U32 useless_is_utf8 = 0;
994 PERL_ARGS_ASSERT_SCALARVOID;
996 /* trailing mad null ops don't count as "there" for void processing */
998 o->op_type != OP_NULL &&
1000 o->op_sibling->op_type == OP_NULL)
1003 for (sib = o->op_sibling;
1004 sib && sib->op_type == OP_NULL;
1005 sib = sib->op_sibling) ;
1011 if (o->op_type == OP_NEXTSTATE
1012 || o->op_type == OP_DBSTATE
1013 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1014 || o->op_targ == OP_DBSTATE)))
1015 PL_curcop = (COP*)o; /* for warning below */
1017 /* assumes no premature commitment */
1018 want = o->op_flags & OPf_WANT;
1019 if ((want && want != OPf_WANT_SCALAR)
1020 || (PL_parser && PL_parser->error_count)
1021 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1026 if ((o->op_private & OPpTARGET_MY)
1027 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1029 return scalar(o); /* As if inside SASSIGN */
1032 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1034 switch (o->op_type) {
1036 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1040 if (o->op_flags & OPf_STACKED)
1044 if (o->op_private == 4)
1069 case OP_AELEMFAST_LEX:
1088 case OP_GETSOCKNAME:
1089 case OP_GETPEERNAME:
1094 case OP_GETPRIORITY:
1119 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1120 /* Otherwise it's "Useless use of grep iterator" */
1121 useless = OP_DESC(o);
1125 kid = cLISTOPo->op_first;
1126 if (kid && kid->op_type == OP_PUSHRE
1128 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1130 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1132 useless = OP_DESC(o);
1136 kid = cUNOPo->op_first;
1137 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1138 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1141 useless = "negative pattern binding (!~)";
1145 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1146 useless = "non-destructive substitution (s///r)";
1150 useless = "non-destructive transliteration (tr///r)";
1157 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1158 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1159 useless = "a variable";
1164 if (cSVOPo->op_private & OPpCONST_STRICT)
1165 no_bareword_allowed(o);
1167 if (ckWARN(WARN_VOID)) {
1169 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1170 "a constant (%"SVf")", sv));
1171 useless = SvPV_nolen(msv);
1172 useless_is_utf8 = SvUTF8(msv);
1175 useless = "a constant (undef)";
1176 /* don't warn on optimised away booleans, eg
1177 * use constant Foo, 5; Foo || print; */
1178 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1180 /* the constants 0 and 1 are permitted as they are
1181 conventionally used as dummies in constructs like
1182 1 while some_condition_with_side_effects; */
1183 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1185 else if (SvPOK(sv)) {
1186 /* perl4's way of mixing documentation and code
1187 (before the invention of POD) was based on a
1188 trick to mix nroff and perl code. The trick was
1189 built upon these three nroff macros being used in
1190 void context. The pink camel has the details in
1191 the script wrapman near page 319. */
1192 const char * const maybe_macro = SvPVX_const(sv);
1193 if (strnEQ(maybe_macro, "di", 2) ||
1194 strnEQ(maybe_macro, "ds", 2) ||
1195 strnEQ(maybe_macro, "ig", 2))
1200 op_null(o); /* don't execute or even remember it */
1204 o->op_type = OP_PREINC; /* pre-increment is faster */
1205 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1209 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1210 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1214 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1215 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1219 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1220 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1225 UNOP *refgen, *rv2cv;
1228 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1231 rv2gv = ((BINOP *)o)->op_last;
1232 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1235 refgen = (UNOP *)((BINOP *)o)->op_first;
1237 if (!refgen || refgen->op_type != OP_REFGEN)
1240 exlist = (LISTOP *)refgen->op_first;
1241 if (!exlist || exlist->op_type != OP_NULL
1242 || exlist->op_targ != OP_LIST)
1245 if (exlist->op_first->op_type != OP_PUSHMARK)
1248 rv2cv = (UNOP*)exlist->op_last;
1250 if (rv2cv->op_type != OP_RV2CV)
1253 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1254 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1255 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1257 o->op_private |= OPpASSIGN_CV_TO_GV;
1258 rv2gv->op_private |= OPpDONT_INIT_GV;
1259 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1271 kid = cLOGOPo->op_first;
1272 if (kid->op_type == OP_NOT
1273 && (kid->op_flags & OPf_KIDS)
1275 if (o->op_type == OP_AND) {
1277 o->op_ppaddr = PL_ppaddr[OP_OR];
1279 o->op_type = OP_AND;
1280 o->op_ppaddr = PL_ppaddr[OP_AND];
1289 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1294 if (o->op_flags & OPf_STACKED)
1301 if (!(o->op_flags & OPf_KIDS))
1312 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1322 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1323 newSVpvn_flags(useless, strlen(useless),
1324 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1329 S_listkids(pTHX_ OP *o)
1331 if (o && o->op_flags & OPf_KIDS) {
1333 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1340 Perl_list(pTHX_ OP *o)
1345 /* assumes no premature commitment */
1346 if (!o || (o->op_flags & OPf_WANT)
1347 || (PL_parser && PL_parser->error_count)
1348 || o->op_type == OP_RETURN)
1353 if ((o->op_private & OPpTARGET_MY)
1354 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1356 return o; /* As if inside SASSIGN */
1359 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1361 switch (o->op_type) {
1364 list(cBINOPo->op_first);
1369 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1377 if (!(o->op_flags & OPf_KIDS))
1379 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1380 list(cBINOPo->op_first);
1381 return gen_constant_list(o);
1388 kid = cLISTOPo->op_first;
1390 kid = kid->op_sibling;
1393 OP *sib = kid->op_sibling;
1394 if (sib && kid->op_type != OP_LEAVEWHEN)
1400 PL_curcop = &PL_compiling;
1404 kid = cLISTOPo->op_first;
1411 S_scalarseq(pTHX_ OP *o)
1415 const OPCODE type = o->op_type;
1417 if (type == OP_LINESEQ || type == OP_SCOPE ||
1418 type == OP_LEAVE || type == OP_LEAVETRY)
1421 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1422 if (kid->op_sibling) {
1426 PL_curcop = &PL_compiling;
1428 o->op_flags &= ~OPf_PARENS;
1429 if (PL_hints & HINT_BLOCK_SCOPE)
1430 o->op_flags |= OPf_PARENS;
1433 o = newOP(OP_STUB, 0);
1438 S_modkids(pTHX_ OP *o, I32 type)
1440 if (o && o->op_flags & OPf_KIDS) {
1442 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1443 op_lvalue(kid, type);
1449 =for apidoc finalize_optree
1451 This function finalizes the optree. Should be called directly after
1452 the complete optree is built. It does some additional
1453 checking which can't be done in the normal ck_xxx functions and makes
1454 the tree thread-safe.
1459 Perl_finalize_optree(pTHX_ OP* o)
1461 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1464 SAVEVPTR(PL_curcop);
1472 S_finalize_op(pTHX_ OP* o)
1474 PERL_ARGS_ASSERT_FINALIZE_OP;
1476 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1478 /* Make sure mad ops are also thread-safe */
1479 MADPROP *mp = o->op_madprop;
1481 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1482 OP *prop_op = (OP *) mp->mad_val;
1483 /* We only need "Relocate sv to the pad for thread safety.", but this
1484 easiest way to make sure it traverses everything */
1485 if (prop_op->op_type == OP_CONST)
1486 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1487 finalize_op(prop_op);
1494 switch (o->op_type) {
1497 PL_curcop = ((COP*)o); /* for warnings */
1501 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1502 && ckWARN(WARN_SYNTAX))
1504 if (o->op_sibling->op_sibling) {
1505 const OPCODE type = o->op_sibling->op_sibling->op_type;
1506 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1507 const line_t oldline = CopLINE(PL_curcop);
1508 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1509 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1510 "Statement unlikely to be reached");
1511 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1512 "\t(Maybe you meant system() when you said exec()?)\n");
1513 CopLINE_set(PL_curcop, oldline);
1520 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1521 GV * const gv = cGVOPo_gv;
1522 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1523 /* XXX could check prototype here instead of just carping */
1524 SV * const sv = sv_newmortal();
1525 gv_efullname3(sv, gv, NULL);
1526 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1527 "%"SVf"() called too early to check prototype",
1534 if (cSVOPo->op_private & OPpCONST_STRICT)
1535 no_bareword_allowed(o);
1539 case OP_METHOD_NAMED:
1540 /* Relocate sv to the pad for thread safety.
1541 * Despite being a "constant", the SV is written to,
1542 * for reference counts, sv_upgrade() etc. */
1543 if (cSVOPo->op_sv) {
1544 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1545 if (o->op_type != OP_METHOD_NAMED &&
1546 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1548 /* If op_sv is already a PADTMP/MY then it is being used by
1549 * some pad, so make a copy. */
1550 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1551 SvREADONLY_on(PAD_SVl(ix));
1552 SvREFCNT_dec(cSVOPo->op_sv);
1554 else if (o->op_type != OP_METHOD_NAMED
1555 && cSVOPo->op_sv == &PL_sv_undef) {
1556 /* PL_sv_undef is hack - it's unsafe to store it in the
1557 AV that is the pad, because av_fetch treats values of
1558 PL_sv_undef as a "free" AV entry and will merrily
1559 replace them with a new SV, causing pad_alloc to think
1560 that this pad slot is free. (When, clearly, it is not)
1562 SvOK_off(PAD_SVl(ix));
1563 SvPADTMP_on(PAD_SVl(ix));
1564 SvREADONLY_on(PAD_SVl(ix));
1567 SvREFCNT_dec(PAD_SVl(ix));
1568 SvPADTMP_on(cSVOPo->op_sv);
1569 PAD_SETSV(ix, cSVOPo->op_sv);
1570 /* XXX I don't know how this isn't readonly already. */
1571 SvREADONLY_on(PAD_SVl(ix));
1573 cSVOPo->op_sv = NULL;
1584 const char *key = NULL;
1587 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1590 /* Make the CONST have a shared SV */
1591 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1592 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1593 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1594 key = SvPV_const(sv, keylen);
1595 lexname = newSVpvn_share(key,
1596 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1602 if ((o->op_private & (OPpLVAL_INTRO)))
1605 rop = (UNOP*)((BINOP*)o)->op_first;
1606 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1608 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1609 if (!SvPAD_TYPED(lexname))
1611 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1612 if (!fields || !GvHV(*fields))
1614 key = SvPV_const(*svp, keylen);
1615 if (!hv_fetch(GvHV(*fields), key,
1616 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1617 Perl_croak(aTHX_ "No such class field \"%s\" "
1618 "in variable %s of type %s",
1619 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
1631 SVOP *first_key_op, *key_op;
1633 if ((o->op_private & (OPpLVAL_INTRO))
1634 /* I bet there's always a pushmark... */
1635 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1636 /* hmmm, no optimization if list contains only one key. */
1638 rop = (UNOP*)((LISTOP*)o)->op_last;
1639 if (rop->op_type != OP_RV2HV)
1641 if (rop->op_first->op_type == OP_PADSV)
1642 /* @$hash{qw(keys here)} */
1643 rop = (UNOP*)rop->op_first;
1645 /* @{$hash}{qw(keys here)} */
1646 if (rop->op_first->op_type == OP_SCOPE
1647 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1649 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1655 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1656 if (!SvPAD_TYPED(lexname))
1658 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1659 if (!fields || !GvHV(*fields))
1661 /* Again guessing that the pushmark can be jumped over.... */
1662 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1663 ->op_first->op_sibling;
1664 for (key_op = first_key_op; key_op;
1665 key_op = (SVOP*)key_op->op_sibling) {
1666 if (key_op->op_type != OP_CONST)
1668 svp = cSVOPx_svp(key_op);
1669 key = SvPV_const(*svp, keylen);
1670 if (!hv_fetch(GvHV(*fields), key,
1671 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1672 Perl_croak(aTHX_ "No such class field \"%s\" "
1673 "in variable %s of type %s",
1674 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
1680 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1681 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1688 if (o->op_flags & OPf_KIDS) {
1690 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1696 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1698 Propagate lvalue ("modifiable") context to an op and its children.
1699 I<type> represents the context type, roughly based on the type of op that
1700 would do the modifying, although C<local()> is represented by OP_NULL,
1701 because it has no op type of its own (it is signalled by a flag on
1704 This function detects things that can't be modified, such as C<$x+1>, and
1705 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1706 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1708 It also flags things that need to behave specially in an lvalue context,
1709 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1715 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1719 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1722 if (!o || (PL_parser && PL_parser->error_count))
1725 if ((o->op_private & OPpTARGET_MY)
1726 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1731 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1733 switch (o->op_type) {
1739 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1743 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1744 !(o->op_flags & OPf_STACKED)) {
1745 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1746 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1747 poses, so we need it clear. */
1748 o->op_private &= ~1;
1749 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1750 assert(cUNOPo->op_first->op_type == OP_NULL);
1751 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1754 else { /* lvalue subroutine call */
1755 o->op_private |= OPpLVAL_INTRO
1756 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1757 PL_modcount = RETURN_UNLIMITED_NUMBER;
1758 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1759 /* Backward compatibility mode: */
1760 o->op_private |= OPpENTERSUB_INARGS;
1763 else { /* Compile-time error message: */
1764 OP *kid = cUNOPo->op_first;
1768 if (kid->op_type != OP_PUSHMARK) {
1769 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1771 "panic: unexpected lvalue entersub "
1772 "args: type/targ %ld:%"UVuf,
1773 (long)kid->op_type, (UV)kid->op_targ);
1774 kid = kLISTOP->op_first;
1776 while (kid->op_sibling)
1777 kid = kid->op_sibling;
1778 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1780 if (kid->op_type == OP_METHOD_NAMED
1781 || kid->op_type == OP_METHOD)
1785 NewOp(1101, newop, 1, UNOP);
1786 newop->op_type = OP_RV2CV;
1787 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1788 newop->op_first = NULL;
1789 newop->op_next = (OP*)newop;
1790 kid->op_sibling = (OP*)newop;
1791 newop->op_private |= OPpLVAL_INTRO;
1792 newop->op_private &= ~1;
1796 if (kid->op_type != OP_RV2CV)
1798 "panic: unexpected lvalue entersub "
1799 "entry via type/targ %ld:%"UVuf,
1800 (long)kid->op_type, (UV)kid->op_targ);
1801 kid->op_private |= OPpLVAL_INTRO;
1802 break; /* Postpone until runtime */
1806 kid = kUNOP->op_first;
1807 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1808 kid = kUNOP->op_first;
1809 if (kid->op_type == OP_NULL)
1811 "Unexpected constant lvalue entersub "
1812 "entry via type/targ %ld:%"UVuf,
1813 (long)kid->op_type, (UV)kid->op_targ);
1814 if (kid->op_type != OP_GV) {
1815 /* Restore RV2CV to check lvalueness */
1817 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1818 okid->op_next = kid->op_next;
1819 kid->op_next = okid;
1822 okid->op_next = NULL;
1823 okid->op_type = OP_RV2CV;
1825 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1826 okid->op_private |= OPpLVAL_INTRO;
1827 okid->op_private &= ~1;
1831 cv = GvCV(kGVOP_gv);
1841 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1842 /* grep, foreach, subcalls, refgen */
1843 if (type == OP_GREPSTART || type == OP_ENTERSUB
1844 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1846 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1847 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1849 : (o->op_type == OP_ENTERSUB
1850 ? "non-lvalue subroutine call"
1852 type ? PL_op_desc[type] : "local"));
1866 case OP_RIGHT_SHIFT:
1875 if (!(o->op_flags & OPf_STACKED))
1882 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1883 op_lvalue(kid, type);
1888 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1889 PL_modcount = RETURN_UNLIMITED_NUMBER;
1890 return o; /* Treat \(@foo) like ordinary list. */
1894 if (scalar_mod_type(o, type))
1896 ref(cUNOPo->op_first, o->op_type);
1900 if (type == OP_LEAVESUBLV)
1901 o->op_private |= OPpMAYBE_LVSUB;
1907 PL_modcount = RETURN_UNLIMITED_NUMBER;
1910 PL_hints |= HINT_BLOCK_SCOPE;
1911 if (type == OP_LEAVESUBLV)
1912 o->op_private |= OPpMAYBE_LVSUB;
1916 ref(cUNOPo->op_first, o->op_type);
1920 PL_hints |= HINT_BLOCK_SCOPE;
1929 case OP_AELEMFAST_LEX:
1936 PL_modcount = RETURN_UNLIMITED_NUMBER;
1937 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1938 return o; /* Treat \(@foo) like ordinary list. */
1939 if (scalar_mod_type(o, type))
1941 if (type == OP_LEAVESUBLV)
1942 o->op_private |= OPpMAYBE_LVSUB;
1946 if (!type) /* local() */
1947 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1948 PAD_COMPNAME_SV(o->op_targ));
1957 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1961 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1967 if (type == OP_LEAVESUBLV)
1968 o->op_private |= OPpMAYBE_LVSUB;
1969 pad_free(o->op_targ);
1970 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1971 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1972 if (o->op_flags & OPf_KIDS)
1973 op_lvalue(cBINOPo->op_first->op_sibling, type);
1978 ref(cBINOPo->op_first, o->op_type);
1979 if (type == OP_ENTERSUB &&
1980 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1981 o->op_private |= OPpLVAL_DEFER;
1982 if (type == OP_LEAVESUBLV)
1983 o->op_private |= OPpMAYBE_LVSUB;
1993 if (o->op_flags & OPf_KIDS)
1994 op_lvalue(cLISTOPo->op_last, type);
1999 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2001 else if (!(o->op_flags & OPf_KIDS))
2003 if (o->op_targ != OP_LIST) {
2004 op_lvalue(cBINOPo->op_first, type);
2010 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2011 /* elements might be in void context because the list is
2012 in scalar context or because they are attribute sub calls */
2013 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2014 op_lvalue(kid, type);
2018 if (type != OP_LEAVESUBLV)
2020 break; /* op_lvalue()ing was handled by ck_return() */
2023 /* [20011101.069] File test operators interpret OPf_REF to mean that
2024 their argument is a filehandle; thus \stat(".") should not set
2026 if (type == OP_REFGEN &&
2027 PL_check[o->op_type] == Perl_ck_ftst)
2030 if (type != OP_LEAVESUBLV)
2031 o->op_flags |= OPf_MOD;
2033 if (type == OP_AASSIGN || type == OP_SASSIGN)
2034 o->op_flags |= OPf_SPECIAL|OPf_REF;
2035 else if (!type) { /* local() */
2038 o->op_private |= OPpLVAL_INTRO;
2039 o->op_flags &= ~OPf_SPECIAL;
2040 PL_hints |= HINT_BLOCK_SCOPE;
2045 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2046 "Useless localization of %s", OP_DESC(o));
2049 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2050 && type != OP_LEAVESUBLV)
2051 o->op_flags |= OPf_REF;
2056 S_scalar_mod_type(const OP *o, I32 type)
2058 assert(o || type != OP_SASSIGN);
2062 if (o->op_type == OP_RV2GV)
2086 case OP_RIGHT_SHIFT:
2107 S_is_handle_constructor(const OP *o, I32 numargs)
2109 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2111 switch (o->op_type) {
2119 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2132 S_refkids(pTHX_ OP *o, I32 type)
2134 if (o && o->op_flags & OPf_KIDS) {
2136 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2143 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2148 PERL_ARGS_ASSERT_DOREF;
2150 if (!o || (PL_parser && PL_parser->error_count))
2153 switch (o->op_type) {
2155 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2156 !(o->op_flags & OPf_STACKED)) {
2157 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2158 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2159 assert(cUNOPo->op_first->op_type == OP_NULL);
2160 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2161 o->op_flags |= OPf_SPECIAL;
2162 o->op_private &= ~1;
2164 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2165 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2166 : type == OP_RV2HV ? OPpDEREF_HV
2168 o->op_flags |= OPf_MOD;
2174 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2175 doref(kid, type, set_op_ref);
2178 if (type == OP_DEFINED)
2179 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2180 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2183 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2184 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2185 : type == OP_RV2HV ? OPpDEREF_HV
2187 o->op_flags |= OPf_MOD;
2194 o->op_flags |= OPf_REF;
2197 if (type == OP_DEFINED)
2198 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2199 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2205 o->op_flags |= OPf_REF;
2210 if (!(o->op_flags & OPf_KIDS))
2212 doref(cBINOPo->op_first, type, set_op_ref);
2216 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2217 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2218 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2219 : type == OP_RV2HV ? OPpDEREF_HV
2221 o->op_flags |= OPf_MOD;
2231 if (!(o->op_flags & OPf_KIDS))
2233 doref(cLISTOPo->op_last, type, set_op_ref);
2243 S_dup_attrlist(pTHX_ OP *o)
2248 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2250 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2251 * where the first kid is OP_PUSHMARK and the remaining ones
2252 * are OP_CONST. We need to push the OP_CONST values.
2254 if (o->op_type == OP_CONST)
2255 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2257 else if (o->op_type == OP_NULL)
2261 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2263 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2264 if (o->op_type == OP_CONST)
2265 rop = op_append_elem(OP_LIST, rop,
2266 newSVOP(OP_CONST, o->op_flags,
2267 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2274 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2279 PERL_ARGS_ASSERT_APPLY_ATTRS;
2281 /* fake up C<use attributes $pkg,$rv,@attrs> */
2282 ENTER; /* need to protect against side-effects of 'use' */
2283 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2285 #define ATTRSMODULE "attributes"
2286 #define ATTRSMODULE_PM "attributes.pm"
2289 /* Don't force the C<use> if we don't need it. */
2290 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2291 if (svp && *svp != &PL_sv_undef)
2292 NOOP; /* already in %INC */
2294 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2295 newSVpvs(ATTRSMODULE), NULL);
2298 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2299 newSVpvs(ATTRSMODULE),
2301 op_prepend_elem(OP_LIST,
2302 newSVOP(OP_CONST, 0, stashsv),
2303 op_prepend_elem(OP_LIST,
2304 newSVOP(OP_CONST, 0,
2306 dup_attrlist(attrs))));
2312 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2315 OP *pack, *imop, *arg;
2318 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2323 assert(target->op_type == OP_PADSV ||
2324 target->op_type == OP_PADHV ||
2325 target->op_type == OP_PADAV);
2327 /* Ensure that attributes.pm is loaded. */
2328 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2330 /* Need package name for method call. */
2331 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2333 /* Build up the real arg-list. */
2334 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2336 arg = newOP(OP_PADSV, 0);
2337 arg->op_targ = target->op_targ;
2338 arg = op_prepend_elem(OP_LIST,
2339 newSVOP(OP_CONST, 0, stashsv),
2340 op_prepend_elem(OP_LIST,
2341 newUNOP(OP_REFGEN, 0,
2342 op_lvalue(arg, OP_REFGEN)),
2343 dup_attrlist(attrs)));
2345 /* Fake up a method call to import */
2346 meth = newSVpvs_share("import");
2347 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2348 op_append_elem(OP_LIST,
2349 op_prepend_elem(OP_LIST, pack, list(arg)),
2350 newSVOP(OP_METHOD_NAMED, 0, meth)));
2352 /* Combine the ops. */
2353 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2357 =notfor apidoc apply_attrs_string
2359 Attempts to apply a list of attributes specified by the C<attrstr> and
2360 C<len> arguments to the subroutine identified by the C<cv> argument which
2361 is expected to be associated with the package identified by the C<stashpv>
2362 argument (see L<attributes>). It gets this wrong, though, in that it
2363 does not correctly identify the boundaries of the individual attribute
2364 specifications within C<attrstr>. This is not really intended for the
2365 public API, but has to be listed here for systems such as AIX which
2366 need an explicit export list for symbols. (It's called from XS code
2367 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2368 to respect attribute syntax properly would be welcome.
2374 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2375 const char *attrstr, STRLEN len)
2379 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2382 len = strlen(attrstr);
2386 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2388 const char * const sstr = attrstr;
2389 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2390 attrs = op_append_elem(OP_LIST, attrs,
2391 newSVOP(OP_CONST, 0,
2392 newSVpvn(sstr, attrstr-sstr)));
2396 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2397 newSVpvs(ATTRSMODULE),
2398 NULL, op_prepend_elem(OP_LIST,
2399 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2400 op_prepend_elem(OP_LIST,
2401 newSVOP(OP_CONST, 0,
2402 newRV(MUTABLE_SV(cv))),
2407 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2411 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2413 PERL_ARGS_ASSERT_MY_KID;
2415 if (!o || (PL_parser && PL_parser->error_count))
2419 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2420 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2424 if (type == OP_LIST) {
2426 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2427 my_kid(kid, attrs, imopsp);
2428 } else if (type == OP_UNDEF
2434 } else if (type == OP_RV2SV || /* "our" declaration */
2436 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2437 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2438 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2440 PL_parser->in_my == KEY_our
2442 : PL_parser->in_my == KEY_state ? "state" : "my"));
2444 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2445 PL_parser->in_my = FALSE;
2446 PL_parser->in_my_stash = NULL;
2447 apply_attrs(GvSTASH(gv),
2448 (type == OP_RV2SV ? GvSV(gv) :
2449 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2450 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2453 o->op_private |= OPpOUR_INTRO;
2456 else if (type != OP_PADSV &&
2459 type != OP_PUSHMARK)
2461 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2463 PL_parser->in_my == KEY_our
2465 : PL_parser->in_my == KEY_state ? "state" : "my"));
2468 else if (attrs && type != OP_PUSHMARK) {
2471 PL_parser->in_my = FALSE;
2472 PL_parser->in_my_stash = NULL;
2474 /* check for C<my Dog $spot> when deciding package */
2475 stash = PAD_COMPNAME_TYPE(o->op_targ);
2477 stash = PL_curstash;
2478 apply_attrs_my(stash, o, attrs, imopsp);
2480 o->op_flags |= OPf_MOD;
2481 o->op_private |= OPpLVAL_INTRO;
2483 o->op_private |= OPpPAD_STATE;
2488 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2492 int maybe_scalar = 0;
2494 PERL_ARGS_ASSERT_MY_ATTRS;
2496 /* [perl #17376]: this appears to be premature, and results in code such as
2497 C< our(%x); > executing in list mode rather than void mode */
2499 if (o->op_flags & OPf_PARENS)
2509 o = my_kid(o, attrs, &rops);
2511 if (maybe_scalar && o->op_type == OP_PADSV) {
2512 o = scalar(op_append_list(OP_LIST, rops, o));
2513 o->op_private |= OPpLVAL_INTRO;
2516 /* The listop in rops might have a pushmark at the beginning,
2517 which will mess up list assignment. */
2518 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2519 if (rops->op_type == OP_LIST &&
2520 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2522 OP * const pushmark = lrops->op_first;
2523 lrops->op_first = pushmark->op_sibling;
2526 o = op_append_list(OP_LIST, o, rops);
2529 PL_parser->in_my = FALSE;
2530 PL_parser->in_my_stash = NULL;
2535 Perl_sawparens(pTHX_ OP *o)
2537 PERL_UNUSED_CONTEXT;
2539 o->op_flags |= OPf_PARENS;
2544 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2548 const OPCODE ltype = left->op_type;
2549 const OPCODE rtype = right->op_type;
2551 PERL_ARGS_ASSERT_BIND_MATCH;
2553 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2554 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2556 const char * const desc
2558 rtype == OP_SUBST || rtype == OP_TRANS
2559 || rtype == OP_TRANSR
2561 ? (int)rtype : OP_MATCH];
2562 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2565 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2566 ? cUNOPx(left)->op_first->op_type == OP_GV
2567 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2568 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2570 : varname(NULL, isary ? '@' : '%', left->op_targ, NULL, 0, 1);
2572 Perl_warner(aTHX_ packWARN(WARN_MISC),
2573 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2576 const char * const sample = (isary
2577 ? "@array" : "%hash");
2578 Perl_warner(aTHX_ packWARN(WARN_MISC),
2579 "Applying %s to %s will act on scalar(%s)",
2580 desc, sample, sample);
2584 if (rtype == OP_CONST &&
2585 cSVOPx(right)->op_private & OPpCONST_BARE &&
2586 cSVOPx(right)->op_private & OPpCONST_STRICT)
2588 no_bareword_allowed(right);
2591 /* !~ doesn't make sense with /r, so error on it for now */
2592 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2594 yyerror("Using !~ with s///r doesn't make sense");
2595 if (rtype == OP_TRANSR && type == OP_NOT)
2596 yyerror("Using !~ with tr///r doesn't make sense");
2598 ismatchop = (rtype == OP_MATCH ||
2599 rtype == OP_SUBST ||
2600 rtype == OP_TRANS || rtype == OP_TRANSR)
2601 && !(right->op_flags & OPf_SPECIAL);
2602 if (ismatchop && right->op_private & OPpTARGET_MY) {
2604 right->op_private &= ~OPpTARGET_MY;
2606 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2609 right->op_flags |= OPf_STACKED;
2610 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2611 ! (rtype == OP_TRANS &&
2612 right->op_private & OPpTRANS_IDENTICAL) &&
2613 ! (rtype == OP_SUBST &&
2614 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2615 newleft = op_lvalue(left, rtype);
2618 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2619 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2621 o = op_prepend_elem(rtype, scalar(newleft), right);
2623 return newUNOP(OP_NOT, 0, scalar(o));
2627 return bind_match(type, left,
2628 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2632 Perl_invert(pTHX_ OP *o)
2636 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2640 =for apidoc Amx|OP *|op_scope|OP *o
2642 Wraps up an op tree with some additional ops so that at runtime a dynamic
2643 scope will be created. The original ops run in the new dynamic scope,
2644 and then, provided that they exit normally, the scope will be unwound.
2645 The additional ops used to create and unwind the dynamic scope will
2646 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2647 instead if the ops are simple enough to not need the full dynamic scope
2654 Perl_op_scope(pTHX_ OP *o)
2658 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2659 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2660 o->op_type = OP_LEAVE;
2661 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2663 else if (o->op_type == OP_LINESEQ) {
2665 o->op_type = OP_SCOPE;
2666 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2667 kid = ((LISTOP*)o)->op_first;
2668 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2671 /* The following deals with things like 'do {1 for 1}' */
2672 kid = kid->op_sibling;
2674 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2679 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2685 Perl_block_start(pTHX_ int full)
2688 const int retval = PL_savestack_ix;
2690 pad_block_start(full);
2692 PL_hints &= ~HINT_BLOCK_SCOPE;
2693 SAVECOMPILEWARNINGS();
2694 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2696 CALL_BLOCK_HOOKS(bhk_start, full);
2702 Perl_block_end(pTHX_ I32 floor, OP *seq)
2705 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2706 OP* retval = scalarseq(seq);
2708 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2711 CopHINTS_set(&PL_compiling, PL_hints);
2713 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2716 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2722 =head1 Compile-time scope hooks
2724 =for apidoc Aox||blockhook_register
2726 Register a set of hooks to be called when the Perl lexical scope changes
2727 at compile time. See L<perlguts/"Compile-time scope hooks">.
2733 Perl_blockhook_register(pTHX_ BHK *hk)
2735 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2737 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2744 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2745 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2746 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2749 OP * const o = newOP(OP_PADSV, 0);
2750 o->op_targ = offset;
2756 Perl_newPROG(pTHX_ OP *o)
2760 PERL_ARGS_ASSERT_NEWPROG;
2766 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2767 ((PL_in_eval & EVAL_KEEPERR)
2768 ? OPf_SPECIAL : 0), o);
2770 cx = &cxstack[cxstack_ix];
2771 assert(CxTYPE(cx) == CXt_EVAL);
2773 if ((cx->blk_gimme & G_WANT) == G_VOID)
2774 scalarvoid(PL_eval_root);
2775 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2778 scalar(PL_eval_root);
2780 /* don't use LINKLIST, since PL_eval_root might indirect through
2781 * a rather expensive function call and LINKLIST evaluates its
2782 * argument more than once */
2783 PL_eval_start = op_linklist(PL_eval_root);
2784 PL_eval_root->op_private |= OPpREFCOUNTED;
2785 OpREFCNT_set(PL_eval_root, 1);
2786 PL_eval_root->op_next = 0;
2787 CALL_PEEP(PL_eval_start);
2788 finalize_optree(PL_eval_root);
2792 if (o->op_type == OP_STUB) {
2793 PL_comppad_name = 0;
2795 S_op_destroy(aTHX_ o);
2798 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2799 PL_curcop = &PL_compiling;
2800 PL_main_start = LINKLIST(PL_main_root);
2801 PL_main_root->op_private |= OPpREFCOUNTED;
2802 OpREFCNT_set(PL_main_root, 1);
2803 PL_main_root->op_next = 0;
2804 CALL_PEEP(PL_main_start);
2805 finalize_optree(PL_main_root);
2808 /* Register with debugger */
2810 CV * const cv = get_cvs("DB::postponed", 0);
2814 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2816 call_sv(MUTABLE_SV(cv), G_DISCARD);
2823 Perl_localize(pTHX_ OP *o, I32 lex)
2827 PERL_ARGS_ASSERT_LOCALIZE;
2829 if (o->op_flags & OPf_PARENS)
2830 /* [perl #17376]: this appears to be premature, and results in code such as
2831 C< our(%x); > executing in list mode rather than void mode */
2838 if ( PL_parser->bufptr > PL_parser->oldbufptr
2839 && PL_parser->bufptr[-1] == ','
2840 && ckWARN(WARN_PARENTHESIS))
2842 char *s = PL_parser->bufptr;
2845 /* some heuristics to detect a potential error */
2846 while (*s && (strchr(", \t\n", *s)))
2850 if (*s && strchr("@$%*", *s) && *++s
2851 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2854 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2856 while (*s && (strchr(", \t\n", *s)))
2862 if (sigil && (*s == ';' || *s == '=')) {
2863 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2864 "Parentheses missing around \"%s\" list",
2866 ? (PL_parser->in_my == KEY_our
2868 : PL_parser->in_my == KEY_state
2878 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2879 PL_parser->in_my = FALSE;
2880 PL_parser->in_my_stash = NULL;
2885 Perl_jmaybe(pTHX_ OP *o)
2887 PERL_ARGS_ASSERT_JMAYBE;
2889 if (o->op_type == OP_LIST) {
2891 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2892 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2897 PERL_STATIC_INLINE OP *
2898 S_op_std_init(pTHX_ OP *o)
2900 I32 type = o->op_type;
2902 PERL_ARGS_ASSERT_OP_STD_INIT;
2904 if (PL_opargs[type] & OA_RETSCALAR)
2906 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2907 o->op_targ = pad_alloc(type, SVs_PADTMP);
2912 PERL_STATIC_INLINE OP *
2913 S_op_integerize(pTHX_ OP *o)
2915 I32 type = o->op_type;
2917 PERL_ARGS_ASSERT_OP_INTEGERIZE;
2919 /* integerize op, unless it happens to be C<-foo>.
2920 * XXX should pp_i_negate() do magic string negation instead? */
2921 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2922 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2923 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2926 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2929 if (type == OP_NEGATE)
2930 /* XXX might want a ck_negate() for this */
2931 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2937 S_fold_constants(pTHX_ register OP *o)
2940 register OP * VOL curop;
2942 VOL I32 type = o->op_type;
2947 SV * const oldwarnhook = PL_warnhook;
2948 SV * const olddiehook = PL_diehook;
2952 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2954 if (!(PL_opargs[type] & OA_FOLDCONST))
2968 /* XXX what about the numeric ops? */
2969 if (PL_hints & HINT_LOCALE)
2974 if (PL_parser && PL_parser->error_count)
2975 goto nope; /* Don't try to run w/ errors */
2977 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2978 const OPCODE type = curop->op_type;
2979 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2981 type != OP_SCALAR &&
2983 type != OP_PUSHMARK)
2989 curop = LINKLIST(o);
2990 old_next = o->op_next;
2994 oldscope = PL_scopestack_ix;
2995 create_eval_scope(G_FAKINGEVAL);
2997 /* Verify that we don't need to save it: */
2998 assert(PL_curcop == &PL_compiling);
2999 StructCopy(&PL_compiling, ¬_compiling, COP);
3000 PL_curcop = ¬_compiling;
3001 /* The above ensures that we run with all the correct hints of the
3002 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3003 assert(IN_PERL_RUNTIME);
3004 PL_warnhook = PERL_WARNHOOK_FATAL;
3011 sv = *(PL_stack_sp--);
3012 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3014 /* Can't simply swipe the SV from the pad, because that relies on
3015 the op being freed "real soon now". Under MAD, this doesn't
3016 happen (see the #ifdef below). */
3019 pad_swipe(o->op_targ, FALSE);
3022 else if (SvTEMP(sv)) { /* grab mortal temp? */
3023 SvREFCNT_inc_simple_void(sv);
3028 /* Something tried to die. Abandon constant folding. */
3029 /* Pretend the error never happened. */
3031 o->op_next = old_next;
3035 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3036 PL_warnhook = oldwarnhook;
3037 PL_diehook = olddiehook;
3038 /* XXX note that this croak may fail as we've already blown away
3039 * the stack - eg any nested evals */
3040 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3043 PL_warnhook = oldwarnhook;
3044 PL_diehook = olddiehook;
3045 PL_curcop = &PL_compiling;
3047 if (PL_scopestack_ix > oldscope)
3048 delete_eval_scope();
3057 if (type == OP_RV2GV)
3058 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3060 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3061 op_getmad(o,newop,'f');
3069 S_gen_constant_list(pTHX_ register OP *o)
3073 const I32 oldtmps_floor = PL_tmps_floor;
3076 if (PL_parser && PL_parser->error_count)
3077 return o; /* Don't attempt to run with errors */
3079 PL_op = curop = LINKLIST(o);
3082 Perl_pp_pushmark(aTHX);
3085 assert (!(curop->op_flags & OPf_SPECIAL));
3086 assert(curop->op_type == OP_RANGE);
3087 Perl_pp_anonlist(aTHX);
3088 PL_tmps_floor = oldtmps_floor;
3090 o->op_type = OP_RV2AV;
3091 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3092 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3093 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3094 o->op_opt = 0; /* needs to be revisited in rpeep() */
3095 curop = ((UNOP*)o)->op_first;
3096 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3098 op_getmad(curop,o,'O');
3107 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3110 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3111 if (!o || o->op_type != OP_LIST)
3112 o = newLISTOP(OP_LIST, 0, o, NULL);
3114 o->op_flags &= ~OPf_WANT;
3116 if (!(PL_opargs[type] & OA_MARK))
3117 op_null(cLISTOPo->op_first);
3119 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3120 if (kid2 && kid2->op_type == OP_COREARGS) {
3121 op_null(cLISTOPo->op_first);
3122 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3126 o->op_type = (OPCODE)type;
3127 o->op_ppaddr = PL_ppaddr[type];
3128 o->op_flags |= flags;
3130 o = CHECKOP(type, o);
3131 if (o->op_type != (unsigned)type)
3134 return fold_constants(op_integerize(op_std_init(o)));
3138 =head1 Optree Manipulation Functions
3141 /* List constructors */
3144 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3146 Append an item to the list of ops contained directly within a list-type
3147 op, returning the lengthened list. I<first> is the list-type op,
3148 and I<last> is the op to append to the list. I<optype> specifies the
3149 intended opcode for the list. If I<first> is not already a list of the
3150 right type, it will be upgraded into one. If either I<first> or I<last>
3151 is null, the other is returned unchanged.
3157 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3165 if (first->op_type != (unsigned)type
3166 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3168 return newLISTOP(type, 0, first, last);
3171 if (first->op_flags & OPf_KIDS)
3172 ((LISTOP*)first)->op_last->op_sibling = last;
3174 first->op_flags |= OPf_KIDS;
3175 ((LISTOP*)first)->op_first = last;
3177 ((LISTOP*)first)->op_last = last;
3182 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3184 Concatenate the lists of ops contained directly within two list-type ops,
3185 returning the combined list. I<first> and I<last> are the list-type ops
3186 to concatenate. I<optype> specifies the intended opcode for the list.
3187 If either I<first> or I<last> is not already a list of the right type,
3188 it will be upgraded into one. If either I<first> or I<last> is null,
3189 the other is returned unchanged.
3195 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3203 if (first->op_type != (unsigned)type)
3204 return op_prepend_elem(type, first, last);
3206 if (last->op_type != (unsigned)type)
3207 return op_append_elem(type, first, last);
3209 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3210 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3211 first->op_flags |= (last->op_flags & OPf_KIDS);
3214 if (((LISTOP*)last)->op_first && first->op_madprop) {
3215 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3217 while (mp->mad_next)
3219 mp->mad_next = first->op_madprop;
3222 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3225 first->op_madprop = last->op_madprop;
3226 last->op_madprop = 0;
3229 S_op_destroy(aTHX_ last);
3235 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3237 Prepend an item to the list of ops contained directly within a list-type
3238 op, returning the lengthened list. I<first> is the op to prepend to the
3239 list, and I<last> is the list-type op. I<optype> specifies the intended
3240 opcode for the list. If I<last> is not already a list of the right type,
3241 it will be upgraded into one. If either I<first> or I<last> is null,
3242 the other is returned unchanged.
3248 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3256 if (last->op_type == (unsigned)type) {
3257 if (type == OP_LIST) { /* already a PUSHMARK there */
3258 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3259 ((LISTOP*)last)->op_first->op_sibling = first;
3260 if (!(first->op_flags & OPf_PARENS))
3261 last->op_flags &= ~OPf_PARENS;
3264 if (!(last->op_flags & OPf_KIDS)) {
3265 ((LISTOP*)last)->op_last = first;
3266 last->op_flags |= OPf_KIDS;
3268 first->op_sibling = ((LISTOP*)last)->op_first;
3269 ((LISTOP*)last)->op_first = first;
3271 last->op_flags |= OPf_KIDS;
3275 return newLISTOP(type, 0, first, last);
3283 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3286 Newxz(tk, 1, TOKEN);
3287 tk->tk_type = (OPCODE)optype;
3288 tk->tk_type = 12345;
3290 tk->tk_mad = madprop;
3295 Perl_token_free(pTHX_ TOKEN* tk)
3297 PERL_ARGS_ASSERT_TOKEN_FREE;
3299 if (tk->tk_type != 12345)
3301 mad_free(tk->tk_mad);
3306 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3311 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3313 if (tk->tk_type != 12345) {
3314 Perl_warner(aTHX_ packWARN(WARN_MISC),
3315 "Invalid TOKEN object ignored");
3322 /* faked up qw list? */
3324 tm->mad_type == MAD_SV &&
3325 SvPVX((SV *)tm->mad_val)[0] == 'q')
3332 /* pretend constant fold didn't happen? */
3333 if (mp->mad_key == 'f' &&
3334 (o->op_type == OP_CONST ||
3335 o->op_type == OP_GV) )
3337 token_getmad(tk,(OP*)mp->mad_val,slot);
3351 if (mp->mad_key == 'X')
3352 mp->mad_key = slot; /* just change the first one */
3362 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3371 /* pretend constant fold didn't happen? */
3372 if (mp->mad_key == 'f' &&
3373 (o->op_type == OP_CONST ||
3374 o->op_type == OP_GV) )
3376 op_getmad(from,(OP*)mp->mad_val,slot);
3383 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3386 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3392 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3401 /* pretend constant fold didn't happen? */
3402 if (mp->mad_key == 'f' &&
3403 (o->op_type == OP_CONST ||
3404 o->op_type == OP_GV) )
3406 op_getmad(from,(OP*)mp->mad_val,slot);
3413 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3416 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3420 PerlIO_printf(PerlIO_stderr(),
3421 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3427 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3445 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3449 addmad(tm, &(o->op_madprop), slot);
3453 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3474 Perl_newMADsv(pTHX_ char key, SV* sv)
3476 PERL_ARGS_ASSERT_NEWMADSV;
3478 return newMADPROP(key, MAD_SV, sv, 0);
3482 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3484 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3487 mp->mad_vlen = vlen;
3488 mp->mad_type = type;
3490 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3495 Perl_mad_free(pTHX_ MADPROP* mp)
3497 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3501 mad_free(mp->mad_next);
3502 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3503 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3504 switch (mp->mad_type) {
3508 Safefree((char*)mp->mad_val);
3511 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3512 op_free((OP*)mp->mad_val);
3515 sv_free(MUTABLE_SV(mp->mad_val));
3518 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3521 PerlMemShared_free(mp);
3527 =head1 Optree construction
3529 =for apidoc Am|OP *|newNULLLIST
3531 Constructs, checks, and returns a new C<stub> op, which represents an
3532 empty list expression.
3538 Perl_newNULLLIST(pTHX)
3540 return newOP(OP_STUB, 0);
3544 S_force_list(pTHX_ OP *o)
3546 if (!o || o->op_type != OP_LIST)
3547 o = newLISTOP(OP_LIST, 0, o, NULL);
3553 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3555 Constructs, checks, and returns an op of any list type. I<type> is
3556 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3557 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3558 supply up to two ops to be direct children of the list op; they are
3559 consumed by this function and become part of the constructed op tree.
3565 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3570 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3572 NewOp(1101, listop, 1, LISTOP);
3574 listop->op_type = (OPCODE)type;
3575 listop->op_ppaddr = PL_ppaddr[type];
3578 listop->op_flags = (U8)flags;
3582 else if (!first && last)
3585 first->op_sibling = last;
3586 listop->op_first = first;
3587 listop->op_last = last;
3588 if (type == OP_LIST) {
3589 OP* const pushop = newOP(OP_PUSHMARK, 0);
3590 pushop->op_sibling = first;
3591 listop->op_first = pushop;
3592 listop->op_flags |= OPf_KIDS;
3594 listop->op_last = pushop;
3597 return CHECKOP(type, listop);
3601 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3603 Constructs, checks, and returns an op of any base type (any type that
3604 has no extra fields). I<type> is the opcode. I<flags> gives the
3605 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3612 Perl_newOP(pTHX_ I32 type, I32 flags)
3617 if (type == -OP_ENTEREVAL) {
3618 type = OP_ENTEREVAL;
3619 flags |= OPpEVAL_BYTES<<8;
3622 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3623 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3624 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3625 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3627 NewOp(1101, o, 1, OP);
3628 o->op_type = (OPCODE)type;
3629 o->op_ppaddr = PL_ppaddr[type];
3630 o->op_flags = (U8)flags;
3632 o->op_latefreed = 0;
3636 o->op_private = (U8)(0 | (flags >> 8));
3637 if (PL_opargs[type] & OA_RETSCALAR)
3639 if (PL_opargs[type] & OA_TARGET)
3640 o->op_targ = pad_alloc(type, SVs_PADTMP);
3641 return CHECKOP(type, o);
3645 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3647 Constructs, checks, and returns an op of any unary type. I<type> is
3648 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3649 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3650 bits, the eight bits of C<op_private>, except that the bit with value 1
3651 is automatically set. I<first> supplies an optional op to be the direct
3652 child of the unary op; it is consumed by this function and become part
3653 of the constructed op tree.
3659 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3664 if (type == -OP_ENTEREVAL) {
3665 type = OP_ENTEREVAL;
3666 flags |= OPpEVAL_BYTES<<8;
3669 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3670 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3671 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3672 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3673 || type == OP_SASSIGN
3674 || type == OP_ENTERTRY
3675 || type == OP_NULL );
3678 first = newOP(OP_STUB, 0);
3679 if (PL_opargs[type] & OA_MARK)
3680 first = force_list(first);
3682 NewOp(1101, unop, 1, UNOP);
3683 unop->op_type = (OPCODE)type;
3684 unop->op_ppaddr = PL_ppaddr[type];
3685 unop->op_first = first;
3686 unop->op_flags = (U8)(flags | OPf_KIDS);
3687 unop->op_private = (U8)(1 | (flags >> 8));
3688 unop = (UNOP*) CHECKOP(type, unop);
3692 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3696 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3698 Constructs, checks, and returns an op of any binary type. I<type>
3699 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3700 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3701 the eight bits of C<op_private>, except that the bit with value 1 or
3702 2 is automatically set as required. I<first> and I<last> supply up to
3703 two ops to be the direct children of the binary op; they are consumed
3704 by this function and become part of the constructed op tree.
3710 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3715 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3716 || type == OP_SASSIGN || type == OP_NULL );
3718 NewOp(1101, binop, 1, BINOP);
3721 first = newOP(OP_NULL, 0);
3723 binop->op_type = (OPCODE)type;
3724 binop->op_ppaddr = PL_ppaddr[type];
3725 binop->op_first = first;
3726 binop->op_flags = (U8)(flags | OPf_KIDS);
3729 binop->op_private = (U8)(1 | (flags >> 8));
3732 binop->op_private = (U8)(2 | (flags >> 8));
3733 first->op_sibling = last;
3736 binop = (BINOP*)CHECKOP(type, binop);
3737 if (binop->op_next || binop->op_type != (OPCODE)type)
3740 binop->op_last = binop->op_first->op_sibling;
3742 return fold_constants(op_integerize(op_std_init((OP *)binop)));
3745 static int uvcompare(const void *a, const void *b)
3746 __attribute__nonnull__(1)
3747 __attribute__nonnull__(2)
3748 __attribute__pure__;
3749 static int uvcompare(const void *a, const void *b)
3751 if (*((const UV *)a) < (*(const UV *)b))
3753 if (*((const UV *)a) > (*(const UV *)b))
3755 if (*((const UV *)a+1) < (*(const UV *)b+1))
3757 if (*((const UV *)a+1) > (*(const UV *)b+1))
3763 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3766 SV * const tstr = ((SVOP*)expr)->op_sv;
3769 (repl->op_type == OP_NULL)
3770 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3772 ((SVOP*)repl)->op_sv;
3775 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3776 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3780 register short *tbl;
3782 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3783 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3784 I32 del = o->op_private & OPpTRANS_DELETE;
3787 PERL_ARGS_ASSERT_PMTRANS;
3789 PL_hints |= HINT_BLOCK_SCOPE;
3792 o->op_private |= OPpTRANS_FROM_UTF;
3795 o->op_private |= OPpTRANS_TO_UTF;
3797 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3798 SV* const listsv = newSVpvs("# comment\n");
3800 const U8* tend = t + tlen;
3801 const U8* rend = r + rlen;
3815 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3816 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3819 const U32 flags = UTF8_ALLOW_DEFAULT;
3823 t = tsave = bytes_to_utf8(t, &len);
3826 if (!to_utf && rlen) {
3828 r = rsave = bytes_to_utf8(r, &len);
3832 /* There are several snags with this code on EBCDIC:
3833 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3834 2. scan_const() in toke.c has encoded chars in native encoding which makes
3835 ranges at least in EBCDIC 0..255 range the bottom odd.
3839 U8 tmpbuf[UTF8_MAXBYTES+1];
3842 Newx(cp, 2*tlen, UV);
3844 transv = newSVpvs("");
3846 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3848 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3850 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3854 cp[2*i+1] = cp[2*i];
3858 qsort(cp, i, 2*sizeof(UV), uvcompare);
3859 for (j = 0; j < i; j++) {
3861 diff = val - nextmin;
3863 t = uvuni_to_utf8(tmpbuf,nextmin);
3864 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3866 U8 range_mark = UTF_TO_NATIVE(0xff);
3867 t = uvuni_to_utf8(tmpbuf, val - 1);
3868 sv_catpvn(transv, (char *)&range_mark, 1);
3869 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3876 t = uvuni_to_utf8(tmpbuf,nextmin);
3877 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3879 U8 range_mark = UTF_TO_NATIVE(0xff);
3880 sv_catpvn(transv, (char *)&range_mark, 1);
3882 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3883 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3884 t = (const U8*)SvPVX_const(transv);
3885 tlen = SvCUR(transv);
3889 else if (!rlen && !del) {
3890 r = t; rlen = tlen; rend = tend;
3893 if ((!rlen && !del) || t == r ||
3894 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3896 o->op_private |= OPpTRANS_IDENTICAL;
3900 while (t < tend || tfirst <= tlast) {
3901 /* see if we need more "t" chars */
3902 if (tfirst > tlast) {
3903 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3905 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3907 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3914 /* now see if we need more "r" chars */
3915 if (rfirst > rlast) {
3917 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3919 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3921 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3930 rfirst = rlast = 0xffffffff;
3934 /* now see which range will peter our first, if either. */
3935 tdiff = tlast - tfirst;
3936 rdiff = rlast - rfirst;
3943 if (rfirst == 0xffffffff) {
3944 diff = tdiff; /* oops, pretend rdiff is infinite */
3946 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3947 (long)tfirst, (long)tlast);
3949 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3953 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3954 (long)tfirst, (long)(tfirst + diff),
3957 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3958 (long)tfirst, (long)rfirst);
3960 if (rfirst + diff > max)
3961 max = rfirst + diff;
3963 grows = (tfirst < rfirst &&
3964 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3976 else if (max > 0xff)
3981 PerlMemShared_free(cPVOPo->op_pv);
3982 cPVOPo->op_pv = NULL;
3984 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3986 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3987 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3988 PAD_SETSV(cPADOPo->op_padix, swash);
3990 SvREADONLY_on(swash);
3992 cSVOPo->op_sv = swash;
3994 SvREFCNT_dec(listsv);
3995 SvREFCNT_dec(transv);
3997 if (!del && havefinal && rlen)
3998 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3999 newSVuv((UV)final), 0);
4002 o->op_private |= OPpTRANS_GROWS;
4008 op_getmad(expr,o,'e');
4009 op_getmad(repl,o,'r');
4017 tbl = (short*)cPVOPo->op_pv;
4019 Zero(tbl, 256, short);
4020 for (i = 0; i < (I32)tlen; i++)
4022 for (i = 0, j = 0; i < 256; i++) {
4024 if (j >= (I32)rlen) {
4033 if (i < 128 && r[j] >= 128)
4043 o->op_private |= OPpTRANS_IDENTICAL;
4045 else if (j >= (I32)rlen)
4050 PerlMemShared_realloc(tbl,
4051 (0x101+rlen-j) * sizeof(short));
4052 cPVOPo->op_pv = (char*)tbl;
4054 tbl[0x100] = (short)(rlen - j);
4055 for (i=0; i < (I32)rlen - j; i++)
4056 tbl[0x101+i] = r[j+i];
4060 if (!rlen && !del) {
4063 o->op_private |= OPpTRANS_IDENTICAL;
4065 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4066 o->op_private |= OPpTRANS_IDENTICAL;
4068 for (i = 0; i < 256; i++)
4070 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4071 if (j >= (I32)rlen) {
4073 if (tbl[t[i]] == -1)
4079 if (tbl[t[i]] == -1) {
4080 if (t[i] < 128 && r[j] >= 128)
4087 if(del && rlen == tlen) {
4088 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4089 } else if(rlen > tlen) {
4090 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4094 o->op_private |= OPpTRANS_GROWS;
4096 op_getmad(expr,o,'e');
4097 op_getmad(repl,o,'r');
4107 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4109 Constructs, checks, and returns an op of any pattern matching type.
4110 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4111 and, shifted up eight bits, the eight bits of C<op_private>.
4117 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4122 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4124 NewOp(1101, pmop, 1, PMOP);
4125 pmop->op_type = (OPCODE)type;
4126 pmop->op_ppaddr = PL_ppaddr[type];
4127 pmop->op_flags = (U8)flags;
4128 pmop->op_private = (U8)(0 | (flags >> 8));
4130 if (PL_hints & HINT_RE_TAINT)
4131 pmop->op_pmflags |= PMf_RETAINT;
4132 if (PL_hints & HINT_LOCALE) {
4133 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4135 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
4136 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4138 if (PL_hints & HINT_RE_FLAGS) {
4139 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4140 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4142 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4143 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4144 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4146 if (reflags && SvOK(reflags)) {
4147 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4153 assert(SvPOK(PL_regex_pad[0]));
4154 if (SvCUR(PL_regex_pad[0])) {
4155 /* Pop off the "packed" IV from the end. */
4156 SV *const repointer_list = PL_regex_pad[0];
4157 const char *p = SvEND(repointer_list) - sizeof(IV);
4158 const IV offset = *((IV*)p);
4160 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4162 SvEND_set(repointer_list, p);
4164 pmop->op_pmoffset = offset;
4165 /* This slot should be free, so assert this: */
4166 assert(PL_regex_pad[offset] == &PL_sv_undef);
4168 SV * const repointer = &PL_sv_undef;
4169 av_push(PL_regex_padav, repointer);
4170 pmop->op_pmoffset = av_len(PL_regex_padav);
4171 PL_regex_pad = AvARRAY(PL_regex_padav);
4175 return CHECKOP(type, pmop);
4178 /* Given some sort of match op o, and an expression expr containing a
4179 * pattern, either compile expr into a regex and attach it to o (if it's
4180 * constant), or convert expr into a runtime regcomp op sequence (if it's
4183 * isreg indicates that the pattern is part of a regex construct, eg
4184 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4185 * split "pattern", which aren't. In the former case, expr will be a list
4186 * if the pattern contains more than one term (eg /a$b/) or if it contains
4187 * a replacement, ie s/// or tr///.
4191 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4196 I32 repl_has_vars = 0;
4200 PERL_ARGS_ASSERT_PMRUNTIME;
4203 o->op_type == OP_SUBST
4204 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4206 /* last element in list is the replacement; pop it */
4208 repl = cLISTOPx(expr)->op_last;
4209 kid = cLISTOPx(expr)->op_first;
4210 while (kid->op_sibling != repl)
4211 kid = kid->op_sibling;
4212 kid->op_sibling = NULL;
4213 cLISTOPx(expr)->op_last = kid;
4216 if (isreg && expr->op_type == OP_LIST &&
4217 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4219 /* convert single element list to element */
4220 OP* const oe = expr;
4221 expr = cLISTOPx(oe)->op_first->op_sibling;
4222 cLISTOPx(oe)->op_first->op_sibling = NULL;
4223 cLISTOPx(oe)->op_last = NULL;
4227 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4228 return pmtrans(o, expr, repl);
4231 reglist = isreg && expr->op_type == OP_LIST;
4235 PL_hints |= HINT_BLOCK_SCOPE;
4238 if (expr->op_type == OP_CONST) {
4239 SV *pat = ((SVOP*)expr)->op_sv;
4240 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4242 if (o->op_flags & OPf_SPECIAL)
4243 pm_flags |= RXf_SPLIT;
4246 assert (SvUTF8(pat));
4247 } else if (SvUTF8(pat)) {
4248 /* Not doing UTF-8, despite what the SV says. Is this only if we're
4249 trapped in use 'bytes'? */
4250 /* Make a copy of the octet sequence, but without the flag on, as
4251 the compiler now honours the SvUTF8 flag on pat. */
4253 const char *const p = SvPV(pat, len);
4254 pat = newSVpvn_flags(p, len, SVs_TEMP);
4257 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4260 op_getmad(expr,(OP*)pm,'e');
4266 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4267 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4269 : OP_REGCMAYBE),0,expr);
4271 NewOp(1101, rcop, 1, LOGOP);
4272 rcop->op_type = OP_REGCOMP;
4273 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4274 rcop->op_first = scalar(expr);
4275 rcop->op_flags |= OPf_KIDS
4276 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4277 | (reglist ? OPf_STACKED : 0);
4278 rcop->op_private = 1;
4281 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4283 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4284 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4286 /* establish postfix order */
4287 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4289 rcop->op_next = expr;
4290 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4293 rcop->op_next = LINKLIST(expr);
4294 expr->op_next = (OP*)rcop;
4297 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4302 if (pm->op_pmflags & PMf_EVAL) {
4304 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4305 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4307 else if (repl->op_type == OP_CONST)
4311 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4312 if (curop->op_type == OP_SCOPE
4313 || curop->op_type == OP_LEAVE
4314 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4315 if (curop->op_type == OP_GV) {
4316 GV * const gv = cGVOPx_gv(curop);
4318 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4321 else if (curop->op_type == OP_RV2CV)
4323 else if (curop->op_type == OP_RV2SV ||
4324 curop->op_type == OP_RV2AV ||
4325 curop->op_type == OP_RV2HV ||
4326 curop->op_type == OP_RV2GV) {
4327 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4330 else if (curop->op_type == OP_PADSV ||
4331 curop->op_type == OP_PADAV ||
4332 curop->op_type == OP_PADHV ||
4333 curop->op_type == OP_PADANY)
4337 else if (curop->op_type == OP_PUSHRE)
4338 NOOP; /* Okay here, dangerous in newASSIGNOP */
4348 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4350 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4351 op_prepend_elem(o->op_type, scalar(repl), o);
4354 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4355 pm->op_pmflags |= PMf_MAYBE_CONST;
4357 NewOp(1101, rcop, 1, LOGOP);
4358 rcop->op_type = OP_SUBSTCONT;
4359 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4360 rcop->op_first = scalar(repl);
4361 rcop->op_flags |= OPf_KIDS;
4362 rcop->op_private = 1;
4365 /* establish postfix order */
4366 rcop->op_next = LINKLIST(repl);
4367 repl->op_next = (OP*)rcop;
4369 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4370 assert(!(pm->op_pmflags & PMf_ONCE));
4371 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4380 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4382 Constructs, checks, and returns an op of any type that involves an
4383 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4384 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4385 takes ownership of one reference to it.
4391 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4396 PERL_ARGS_ASSERT_NEWSVOP;
4398 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4399 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4400 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4402 NewOp(1101, svop, 1, SVOP);
4403 svop->op_type = (OPCODE)type;
4404 svop->op_ppaddr = PL_ppaddr[type];
4406 svop->op_next = (OP*)svop;
4407 svop->op_flags = (U8)flags;
4408 if (PL_opargs[type] & OA_RETSCALAR)
4410 if (PL_opargs[type] & OA_TARGET)
4411 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4412 return CHECKOP(type, svop);
4418 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4420 Constructs, checks, and returns an op of any type that involves a
4421 reference to a pad element. I<type> is the opcode. I<flags> gives the
4422 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4423 is populated with I<sv>; this function takes ownership of one reference
4426 This function only exists if Perl has been compiled to use ithreads.
4432 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4437 PERL_ARGS_ASSERT_NEWPADOP;
4439 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4440 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4441 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4443 NewOp(1101, padop, 1, PADOP);
4444 padop->op_type = (OPCODE)type;
4445 padop->op_ppaddr = PL_ppaddr[type];
4446 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4447 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4448 PAD_SETSV(padop->op_padix, sv);
4451 padop->op_next = (OP*)padop;
4452 padop->op_flags = (U8)flags;
4453 if (PL_opargs[type] & OA_RETSCALAR)
4455 if (PL_opargs[type] & OA_TARGET)
4456 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4457 return CHECKOP(type, padop);
4460 #endif /* !USE_ITHREADS */
4463 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4465 Constructs, checks, and returns an op of any type that involves an
4466 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4467 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4468 reference; calling this function does not transfer ownership of any
4475 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4479 PERL_ARGS_ASSERT_NEWGVOP;
4483 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4485 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4490 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4492 Constructs, checks, and returns an op of any type that involves an
4493 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4494 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4495 must have been allocated using L</PerlMemShared_malloc>; the memory will
4496 be freed when the op is destroyed.
4502 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4507 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4509 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4511 NewOp(1101, pvop, 1, PVOP);
4512 pvop->op_type = (OPCODE)type;
4513 pvop->op_ppaddr = PL_ppaddr[type];
4515 pvop->op_next = (OP*)pvop;
4516 pvop->op_flags = (U8)flags;
4517 if (PL_opargs[type] & OA_RETSCALAR)
4519 if (PL_opargs[type] & OA_TARGET)
4520 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4521 return CHECKOP(type, pvop);
4529 Perl_package(pTHX_ OP *o)
4532 SV *const sv = cSVOPo->op_sv;
4537 PERL_ARGS_ASSERT_PACKAGE;
4539 SAVEGENERICSV(PL_curstash);
4540 save_item(PL_curstname);
4542 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4544 sv_setsv(PL_curstname, sv);
4546 PL_hints |= HINT_BLOCK_SCOPE;
4547 PL_parser->copline = NOLINE;
4548 PL_parser->expect = XSTATE;
4553 if (!PL_madskills) {
4558 pegop = newOP(OP_NULL,0);
4559 op_getmad(o,pegop,'P');
4565 Perl_package_version( pTHX_ OP *v )
4568 U32 savehints = PL_hints;
4569 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4570 PL_hints &= ~HINT_STRICT_VARS;
4571 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4572 PL_hints = savehints;
4581 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4588 OP *pegop = newOP(OP_NULL,0);
4590 SV *use_version = NULL;
4592 PERL_ARGS_ASSERT_UTILIZE;
4594 if (idop->op_type != OP_CONST)
4595 Perl_croak(aTHX_ "Module name must be constant");
4598 op_getmad(idop,pegop,'U');
4603 SV * const vesv = ((SVOP*)version)->op_sv;
4606 op_getmad(version,pegop,'V');
4607 if (!arg && !SvNIOKp(vesv)) {
4614 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4615 Perl_croak(aTHX_ "Version number must be a constant number");
4617 /* Make copy of idop so we don't free it twice */
4618 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4620 /* Fake up a method call to VERSION */
4621 meth = newSVpvs_share("VERSION");
4622 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4623 op_append_elem(OP_LIST,
4624 op_prepend_elem(OP_LIST, pack, list(version)),
4625 newSVOP(OP_METHOD_NAMED, 0, meth)));
4629 /* Fake up an import/unimport */
4630 if (arg && arg->op_type == OP_STUB) {
4632 op_getmad(arg,pegop,'S');
4633 imop = arg; /* no import on explicit () */
4635 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4636 imop = NULL; /* use 5.0; */
4638 use_version = ((SVOP*)idop)->op_sv;
4640 idop->op_private |= OPpCONST_NOVER;
4646 op_getmad(arg,pegop,'A');
4648 /* Make copy of idop so we don't free it twice */
4649 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4651 /* Fake up a method call to import/unimport */
4653 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4654 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4655 op_append_elem(OP_LIST,
4656 op_prepend_elem(OP_LIST, pack, list(arg)),
4657 newSVOP(OP_METHOD_NAMED, 0, meth)));
4660 /* Fake up the BEGIN {}, which does its thing immediately. */
4662 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4665 op_append_elem(OP_LINESEQ,
4666 op_append_elem(OP_LINESEQ,
4667 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4668 newSTATEOP(0, NULL, veop)),
4669 newSTATEOP(0, NULL, imop) ));
4672 HV * const hinthv = GvHV(PL_hintgv);
4673 const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH);
4676 /* Turn features off */
4677 ENTER_with_name("load_feature");
4678 Perl_load_module(aTHX_
4679 PERL_LOADMOD_DENY, newSVpvs("feature"), NULL, NULL
4682 /* If we request a version >= 5.9.5, load feature.pm with the
4683 * feature bundle that corresponds to the required version. */
4684 use_version = sv_2mortal(new_version(use_version));
4686 if (vcmp(use_version,
4687 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4688 importsv = vnormal(use_version);
4689 *SvPVX_mutable(importsv) = ':';
4691 else importsv = newSVpvs(":default");
4692 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4693 LEAVE_with_name("load_feature");
4694 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4695 if (vcmp(use_version,
4696 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4697 if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
4698 PL_hints |= HINT_STRICT_REFS;
4699 if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
4700 PL_hints |= HINT_STRICT_SUBS;
4701 if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
4702 PL_hints |= HINT_STRICT_VARS;
4704 /* otherwise they are off */
4706 if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
4707 PL_hints &= ~HINT_STRICT_REFS;
4708 if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
4709 PL_hints &= ~HINT_STRICT_SUBS;
4710 if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
4711 PL_hints &= ~HINT_STRICT_VARS;
4715 /* The "did you use incorrect case?" warning used to be here.
4716 * The problem is that on case-insensitive filesystems one
4717 * might get false positives for "use" (and "require"):
4718 * "use Strict" or "require CARP" will work. This causes
4719 * portability problems for the script: in case-strict
4720 * filesystems the script will stop working.
4722 * The "incorrect case" warning checked whether "use Foo"
4723 * imported "Foo" to your namespace, but that is wrong, too:
4724 * there is no requirement nor promise in the language that
4725 * a Foo.pm should or would contain anything in package "Foo".
4727 * There is very little Configure-wise that can be done, either:
4728 * the case-sensitivity of the build filesystem of Perl does not
4729 * help in guessing the case-sensitivity of the runtime environment.
4732 PL_hints |= HINT_BLOCK_SCOPE;
4733 PL_parser->copline = NOLINE;
4734 PL_parser->expect = XSTATE;
4735 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4736 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4740 if (!PL_madskills) {
4741 /* FIXME - don't allocate pegop if !PL_madskills */
4750 =head1 Embedding Functions
4752 =for apidoc load_module
4754 Loads the module whose name is pointed to by the string part of name.
4755 Note that the actual module name, not its filename, should be given.
4756 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4757 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4758 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
4759 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4760 arguments can be used to specify arguments to the module's import()
4761 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4762 terminated with a final NULL pointer. Note that this list can only
4763 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4764 Otherwise at least a single NULL pointer to designate the default
4765 import list is required.
4767 The reference count for each specified C<SV*> parameter is decremented.
4772 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4776 PERL_ARGS_ASSERT_LOAD_MODULE;
4778 va_start(args, ver);
4779 vload_module(flags, name, ver, &args);
4783 #ifdef PERL_IMPLICIT_CONTEXT
4785 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4789 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4790 va_start(args, ver);
4791 vload_module(flags, name, ver, &args);
4797 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4801 OP * const modname = newSVOP(OP_CONST, 0, name);
4803 PERL_ARGS_ASSERT_VLOAD_MODULE;
4805 modname->op_private |= OPpCONST_BARE;
4807 veop = newSVOP(OP_CONST, 0, ver);
4811 if (flags & PERL_LOADMOD_NOIMPORT) {
4812 imop = sawparens(newNULLLIST());
4814 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4815 imop = va_arg(*args, OP*);
4820 sv = va_arg(*args, SV*);
4822 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4823 sv = va_arg(*args, SV*);
4827 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4828 * that it has a PL_parser to play with while doing that, and also
4829 * that it doesn't mess with any existing parser, by creating a tmp
4830 * new parser with lex_start(). This won't actually be used for much,
4831 * since pp_require() will create another parser for the real work. */
4834 SAVEVPTR(PL_curcop);
4835 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4836 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4837 veop, modname, imop);
4842 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4848 PERL_ARGS_ASSERT_DOFILE;
4850 if (!force_builtin) {
4851 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4852 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4853 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4854 gv = gvp ? *gvp : NULL;
4858 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4859 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4860 op_append_elem(OP_LIST, term,
4861 scalar(newUNOP(OP_RV2CV, 0,
4862 newGVOP(OP_GV, 0, gv))))));
4865 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4871 =head1 Optree construction
4873 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4875 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4876 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4877 be set automatically, and, shifted up eight bits, the eight bits of
4878 C<op_private>, except that the bit with value 1 or 2 is automatically
4879 set as required. I<listval> and I<subscript> supply the parameters of
4880 the slice; they are consumed by this function and become part of the
4881 constructed op tree.
4887 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4889 return newBINOP(OP_LSLICE, flags,
4890 list(force_list(subscript)),
4891 list(force_list(listval)) );
4895 S_is_list_assignment(pTHX_ register const OP *o)
4903 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4904 o = cUNOPo->op_first;
4906 flags = o->op_flags;
4908 if (type == OP_COND_EXPR) {
4909 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4910 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4915 yyerror("Assignment to both a list and a scalar");
4919 if (type == OP_LIST &&
4920 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4921 o->op_private & OPpLVAL_INTRO)
4924 if (type == OP_LIST || flags & OPf_PARENS ||
4925 type == OP_RV2AV || type == OP_RV2HV ||
4926 type == OP_ASLICE || type == OP_HSLICE)
4929 if (type == OP_PADAV || type == OP_PADHV)
4932 if (type == OP_RV2SV)
4939 Helper function for newASSIGNOP to detection commonality between the
4940 lhs and the rhs. Marks all variables with PL_generation. If it
4941 returns TRUE the assignment must be able to handle common variables.
4943 PERL_STATIC_INLINE bool
4944 S_aassign_common_vars(pTHX_ OP* o)
4947 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
4948 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4949 if (curop->op_type == OP_GV) {
4950 GV *gv = cGVOPx_gv(curop);
4952 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4954 GvASSIGN_GENERATION_set(gv, PL_generation);
4956 else if (curop->op_type == OP_PADSV ||
4957 curop->op_type == OP_PADAV ||
4958 curop->op_type == OP_PADHV ||
4959 curop->op_type == OP_PADANY)
4961 if (PAD_COMPNAME_GEN(curop->op_targ)
4962 == (STRLEN)PL_generation)
4964 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4967 else if (curop->op_type == OP_RV2CV)
4969 else if (curop->op_type == OP_RV2SV ||
4970 curop->op_type == OP_RV2AV ||
4971 curop->op_type == OP_RV2HV ||
4972 curop->op_type == OP_RV2GV) {
4973 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
4976 else if (curop->op_type == OP_PUSHRE) {
4978 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4979 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4981 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4983 GvASSIGN_GENERATION_set(gv, PL_generation);
4987 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4990 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4992 GvASSIGN_GENERATION_set(gv, PL_generation);
5000 if (curop->op_flags & OPf_KIDS) {
5001 if (aassign_common_vars(curop))
5009 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5011 Constructs, checks, and returns an assignment op. I<left> and I<right>
5012 supply the parameters of the assignment; they are consumed by this
5013 function and become part of the constructed op tree.
5015 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5016 a suitable conditional optree is constructed. If I<optype> is the opcode
5017 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5018 performs the binary operation and assigns the result to the left argument.
5019 Either way, if I<optype> is non-zero then I<flags> has no effect.
5021 If I<optype> is zero, then a plain scalar or list assignment is
5022 constructed. Which type of assignment it is is automatically determined.
5023 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5024 will be set automatically, and, shifted up eight bits, the eight bits
5025 of C<op_private>, except that the bit with value 1 or 2 is automatically
5032 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5038 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5039 return newLOGOP(optype, 0,
5040 op_lvalue(scalar(left), optype),
5041 newUNOP(OP_SASSIGN, 0, scalar(right)));
5044 return newBINOP(optype, OPf_STACKED,
5045 op_lvalue(scalar(left), optype), scalar(right));
5049 if (is_list_assignment(left)) {
5050 static const char no_list_state[] = "Initialization of state variables"
5051 " in list context currently forbidden";
5053 bool maybe_common_vars = TRUE;
5056 left = op_lvalue(left, OP_AASSIGN);
5057 curop = list(force_list(left));
5058 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5059 o->op_private = (U8)(0 | (flags >> 8));
5061 if ((left->op_type == OP_LIST
5062 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5064 OP* lop = ((LISTOP*)left)->op_first;
5065 maybe_common_vars = FALSE;
5067 if (lop->op_type == OP_PADSV ||
5068 lop->op_type == OP_PADAV ||
5069 lop->op_type == OP_PADHV ||
5070 lop->op_type == OP_PADANY) {
5071 if (!(lop->op_private & OPpLVAL_INTRO))
5072 maybe_common_vars = TRUE;
5074 if (lop->op_private & OPpPAD_STATE) {
5075 if (left->op_private & OPpLVAL_INTRO) {
5076 /* Each variable in state($a, $b, $c) = ... */
5079 /* Each state variable in
5080 (state $a, my $b, our $c, $d, undef) = ... */
5082 yyerror(no_list_state);
5084 /* Each my variable in
5085 (state $a, my $b, our $c, $d, undef) = ... */
5087 } else if (lop->op_type == OP_UNDEF ||
5088 lop->op_type == OP_PUSHMARK) {
5089 /* undef may be interesting in
5090 (state $a, undef, state $c) */
5092 /* Other ops in the list. */
5093 maybe_common_vars = TRUE;
5095 lop = lop->op_sibling;
5098 else if ((left->op_private & OPpLVAL_INTRO)
5099 && ( left->op_type == OP_PADSV
5100 || left->op_type == OP_PADAV
5101 || left->op_type == OP_PADHV
5102 || left->op_type == OP_PADANY))
5104 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5105 if (left->op_private & OPpPAD_STATE) {
5106 /* All single variable list context state assignments, hence
5116 yyerror(no_list_state);
5120 /* PL_generation sorcery:
5121 * an assignment like ($a,$b) = ($c,$d) is easier than
5122 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5123 * To detect whether there are common vars, the global var
5124 * PL_generation is incremented for each assign op we compile.
5125 * Then, while compiling the assign op, we run through all the
5126 * variables on both sides of the assignment, setting a spare slot
5127 * in each of them to PL_generation. If any of them already have
5128 * that value, we know we've got commonality. We could use a
5129 * single bit marker, but then we'd have to make 2 passes, first
5130 * to clear the flag, then to test and set it. To find somewhere
5131 * to store these values, evil chicanery is done with SvUVX().
5134 if (maybe_common_vars) {
5136 if (aassign_common_vars(o))
5137 o->op_private |= OPpASSIGN_COMMON;
5141 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5142 OP* tmpop = ((LISTOP*)right)->op_first;
5143 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5144 PMOP * const pm = (PMOP*)tmpop;
5145 if (left->op_type == OP_RV2AV &&
5146 !(left->op_private & OPpLVAL_INTRO) &&
5147 !(o->op_private & OPpASSIGN_COMMON) )
5149 tmpop = ((UNOP*)left)->op_first;
5150 if (tmpop->op_type == OP_GV
5152 && !pm->op_pmreplrootu.op_pmtargetoff
5154 && !pm->op_pmreplrootu.op_pmtargetgv
5158 pm->op_pmreplrootu.op_pmtargetoff
5159 = cPADOPx(tmpop)->op_padix;
5160 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5162 pm->op_pmreplrootu.op_pmtargetgv
5163 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5164 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5166 pm->op_pmflags |= PMf_ONCE;
5167 tmpop = cUNOPo->op_first; /* to list (nulled) */
5168 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5169 tmpop->op_sibling = NULL; /* don't free split */
5170 right->op_next = tmpop->op_next; /* fix starting loc */
5171 op_free(o); /* blow off assign */
5172 right->op_flags &= ~OPf_WANT;
5173 /* "I don't know and I don't care." */
5178 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5179 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5181 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5182 if (SvIOK(sv) && SvIVX(sv) == 0)
5183 sv_setiv(sv, PL_modcount+1);
5191 right = newOP(OP_UNDEF, 0);
5192 if (right->op_type == OP_READLINE) {
5193 right->op_flags |= OPf_STACKED;
5194 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5198 o = newBINOP(OP_SASSIGN, flags,
5199 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5205 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5207 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5208 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5209 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5210 If I<label> is non-null, it supplies the name of a label to attach to
5211 the state op; this function takes ownership of the memory pointed at by
5212 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5215 If I<o> is null, the state op is returned. Otherwise the state op is
5216 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5217 is consumed by this function and becomes part of the returned op tree.
5223 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5226 const U32 seq = intro_my();
5229 NewOp(1101, cop, 1, COP);
5230 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5231 cop->op_type = OP_DBSTATE;
5232 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5235 cop->op_type = OP_NEXTSTATE;
5236 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5238 cop->op_flags = (U8)flags;
5239 CopHINTS_set(cop, PL_hints);
5241 cop->op_private |= NATIVE_HINTS;
5243 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5244 cop->op_next = (OP*)cop;
5247 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5248 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5250 Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
5252 PL_hints |= HINT_BLOCK_SCOPE;
5253 /* It seems that we need to defer freeing this pointer, as other parts
5254 of the grammar end up wanting to copy it after this op has been
5259 if (PL_parser && PL_parser->copline == NOLINE)
5260 CopLINE_set(cop, CopLINE(PL_curcop));
5262 CopLINE_set(cop, PL_parser->copline);
5264 PL_parser->copline = NOLINE;
5267 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5269 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5271 CopSTASH_set(cop, PL_curstash);
5273 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5274 /* this line can have a breakpoint - store the cop in IV */
5275 AV *av = CopFILEAVx(PL_curcop);
5277 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5278 if (svp && *svp != &PL_sv_undef ) {
5279 (void)SvIOK_on(*svp);
5280 SvIV_set(*svp, PTR2IV(cop));
5285 if (flags & OPf_SPECIAL)
5287 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5291 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5293 Constructs, checks, and returns a logical (flow control) op. I<type>
5294 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5295 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5296 the eight bits of C<op_private>, except that the bit with value 1 is
5297 automatically set. I<first> supplies the expression controlling the
5298 flow, and I<other> supplies the side (alternate) chain of ops; they are
5299 consumed by this function and become part of the constructed op tree.
5305 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5309 PERL_ARGS_ASSERT_NEWLOGOP;
5311 return new_logop(type, flags, &first, &other);
5315 S_search_const(pTHX_ OP *o)
5317 PERL_ARGS_ASSERT_SEARCH_CONST;
5319 switch (o->op_type) {
5323 if (o->op_flags & OPf_KIDS)
5324 return search_const(cUNOPo->op_first);
5331 if (!(o->op_flags & OPf_KIDS))
5333 kid = cLISTOPo->op_first;
5335 switch (kid->op_type) {
5339 kid = kid->op_sibling;
5342 if (kid != cLISTOPo->op_last)
5348 kid = cLISTOPo->op_last;
5350 return search_const(kid);
5358 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5366 int prepend_not = 0;
5368 PERL_ARGS_ASSERT_NEW_LOGOP;
5373 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5374 return newBINOP(type, flags, scalar(first), scalar(other));
5376 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5378 scalarboolean(first);
5379 /* optimize AND and OR ops that have NOTs as children */
5380 if (first->op_type == OP_NOT
5381 && (first->op_flags & OPf_KIDS)
5382 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5383 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5385 if (type == OP_AND || type == OP_OR) {
5391 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5393 prepend_not = 1; /* prepend a NOT op later */
5397 /* search for a constant op that could let us fold the test */
5398 if ((cstop = search_const(first))) {
5399 if (cstop->op_private & OPpCONST_STRICT)
5400 no_bareword_allowed(cstop);
5401 else if ((cstop->op_private & OPpCONST_BARE))
5402 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5403 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5404 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5405 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5407 if (other->op_type == OP_CONST)
5408 other->op_private |= OPpCONST_SHORTCIRCUIT;
5410 OP *newop = newUNOP(OP_NULL, 0, other);
5411 op_getmad(first, newop, '1');
5412 newop->op_targ = type; /* set "was" field */
5416 if (other->op_type == OP_LEAVE)
5417 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5418 else if (other->op_type == OP_MATCH
5419 || other->op_type == OP_SUBST
5420 || other->op_type == OP_TRANSR
5421 || other->op_type == OP_TRANS)
5422 /* Mark the op as being unbindable with =~ */
5423 other->op_flags |= OPf_SPECIAL;
5427 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5428 const OP *o2 = other;
5429 if ( ! (o2->op_type == OP_LIST
5430 && (( o2 = cUNOPx(o2)->op_first))
5431 && o2->op_type == OP_PUSHMARK
5432 && (( o2 = o2->op_sibling)) )
5435 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5436 || o2->op_type == OP_PADHV)
5437 && o2->op_private & OPpLVAL_INTRO
5438 && !(o2->op_private & OPpPAD_STATE))
5440 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5441 "Deprecated use of my() in false conditional");
5445 if (first->op_type == OP_CONST)
5446 first->op_private |= OPpCONST_SHORTCIRCUIT;
5448 first = newUNOP(OP_NULL, 0, first);
5449 op_getmad(other, first, '2');
5450 first->op_targ = type; /* set "was" field */
5457 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5458 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5460 const OP * const k1 = ((UNOP*)first)->op_first;
5461 const OP * const k2 = k1->op_sibling;
5463 switch (first->op_type)
5466 if (k2 && k2->op_type == OP_READLINE
5467 && (k2->op_flags & OPf_STACKED)
5468 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5470 warnop = k2->op_type;
5475 if (k1->op_type == OP_READDIR
5476 || k1->op_type == OP_GLOB
5477 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5478 || k1->op_type == OP_EACH
5479 || k1->op_type == OP_AEACH)
5481 warnop = ((k1->op_type == OP_NULL)
5482 ? (OPCODE)k1->op_targ : k1->op_type);
5487 const line_t oldline = CopLINE(PL_curcop);
5488 CopLINE_set(PL_curcop, PL_parser->copline);
5489 Perl_warner(aTHX_ packWARN(WARN_MISC),
5490 "Value of %s%s can be \"0\"; test with defined()",
5492 ((warnop == OP_READLINE || warnop == OP_GLOB)
5493 ? " construct" : "() operator"));
5494 CopLINE_set(PL_curcop, oldline);
5501 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5502 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5504 NewOp(1101, logop, 1, LOGOP);
5506 logop->op_type = (OPCODE)type;
5507 logop->op_ppaddr = PL_ppaddr[type];
5508 logop->op_first = first;
5509 logop->op_flags = (U8)(flags | OPf_KIDS);
5510 logop->op_other = LINKLIST(other);
5511 logop->op_private = (U8)(1 | (flags >> 8));
5513 /* establish postfix order */
5514 logop->op_next = LINKLIST(first);
5515 first->op_next = (OP*)logop;
5516 first->op_sibling = other;
5518 CHECKOP(type,logop);
5520 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5527 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5529 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5530 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5531 will be set automatically, and, shifted up eight bits, the eight bits of
5532 C<op_private>, except that the bit with value 1 is automatically set.
5533 I<first> supplies the expression selecting between the two branches,
5534 and I<trueop> and I<falseop> supply the branches; they are consumed by
5535 this function and become part of the constructed op tree.
5541 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5549 PERL_ARGS_ASSERT_NEWCONDOP;
5552 return newLOGOP(OP_AND, 0, first, trueop);
5554 return newLOGOP(OP_OR, 0, first, falseop);
5556 scalarboolean(first);
5557 if ((cstop = search_const(first))) {
5558 /* Left or right arm of the conditional? */
5559 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5560 OP *live = left ? trueop : falseop;
5561 OP *const dead = left ? falseop : trueop;
5562 if (cstop->op_private & OPpCONST_BARE &&
5563 cstop->op_private & OPpCONST_STRICT) {
5564 no_bareword_allowed(cstop);
5567 /* This is all dead code when PERL_MAD is not defined. */
5568 live = newUNOP(OP_NULL, 0, live);
5569 op_getmad(first, live, 'C');
5570 op_getmad(dead, live, left ? 'e' : 't');
5575 if (live->op_type == OP_LEAVE)
5576 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5577 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5578 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5579 /* Mark the op as being unbindable with =~ */
5580 live->op_flags |= OPf_SPECIAL;
5583 NewOp(1101, logop, 1, LOGOP);
5584 logop->op_type = OP_COND_EXPR;
5585 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5586 logop->op_first = first;
5587 logop->op_flags = (U8)(flags | OPf_KIDS);
5588 logop->op_private = (U8)(1 | (flags >> 8));
5589 logop->op_other = LINKLIST(trueop);
5590 logop->op_next = LINKLIST(falseop);
5592 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5595 /* establish postfix order */
5596 start = LINKLIST(first);
5597 first->op_next = (OP*)logop;
5599 first->op_sibling = trueop;
5600 trueop->op_sibling = falseop;
5601 o = newUNOP(OP_NULL, 0, (OP*)logop);
5603 trueop->op_next = falseop->op_next = o;
5610 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5612 Constructs and returns a C<range> op, with subordinate C<flip> and
5613 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5614 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5615 for both the C<flip> and C<range> ops, except that the bit with value
5616 1 is automatically set. I<left> and I<right> supply the expressions
5617 controlling the endpoints of the range; they are consumed by this function
5618 and become part of the constructed op tree.
5624 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5633 PERL_ARGS_ASSERT_NEWRANGE;
5635 NewOp(1101, range, 1, LOGOP);
5637 range->op_type = OP_RANGE;
5638 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5639 range->op_first = left;
5640 range->op_flags = OPf_KIDS;
5641 leftstart = LINKLIST(left);
5642 range->op_other = LINKLIST(right);
5643 range->op_private = (U8)(1 | (flags >> 8));
5645 left->op_sibling = right;
5647 range->op_next = (OP*)range;
5648 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5649 flop = newUNOP(OP_FLOP, 0, flip);
5650 o = newUNOP(OP_NULL, 0, flop);
5652 range->op_next = leftstart;
5654 left->op_next = flip;
5655 right->op_next = flop;
5657 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5658 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5659 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5660 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5662 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5663 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5665 /* check barewords before they might be optimized aways */
5666 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5667 no_bareword_allowed(left);
5668 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5669 no_bareword_allowed(right);
5672 if (!flip->op_private || !flop->op_private)
5673 LINKLIST(o); /* blow off optimizer unless constant */
5679 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5681 Constructs, checks, and returns an op tree expressing a loop. This is
5682 only a loop in the control flow through the op tree; it does not have
5683 the heavyweight loop structure that allows exiting the loop by C<last>
5684 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5685 top-level op, except that some bits will be set automatically as required.
5686 I<expr> supplies the expression controlling loop iteration, and I<block>
5687 supplies the body of the loop; they are consumed by this function and
5688 become part of the constructed op tree. I<debuggable> is currently
5689 unused and should always be 1.
5695 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5700 const bool once = block && block->op_flags & OPf_SPECIAL &&
5701 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5703 PERL_UNUSED_ARG(debuggable);
5706 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5707 return block; /* do {} while 0 does once */
5708 if (expr->op_type == OP_READLINE
5709 || expr->op_type == OP_READDIR
5710 || expr->op_type == OP_GLOB
5711 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5712 expr = newUNOP(OP_DEFINED, 0,
5713 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5714 } else if (expr->op_flags & OPf_KIDS) {
5715 const OP * const k1 = ((UNOP*)expr)->op_first;
5716 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5717 switch (expr->op_type) {
5719 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5720 && (k2->op_flags & OPf_STACKED)
5721 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5722 expr = newUNOP(OP_DEFINED, 0, expr);
5726 if (k1 && (k1->op_type == OP_READDIR
5727 || k1->op_type == OP_GLOB
5728 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5729 || k1->op_type == OP_EACH
5730 || k1->op_type == OP_AEACH))
5731 expr = newUNOP(OP_DEFINED, 0, expr);
5737 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5738 * op, in listop. This is wrong. [perl #27024] */
5740 block = newOP(OP_NULL, 0);
5741 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5742 o = new_logop(OP_AND, 0, &expr, &listop);
5745 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5747 if (once && o != listop)
5748 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5751 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5753 o->op_flags |= flags;
5755 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5760 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5762 Constructs, checks, and returns an op tree expressing a C<while> loop.
5763 This is a heavyweight loop, with structure that allows exiting the loop
5764 by C<last> and suchlike.
5766 I<loop> is an optional preconstructed C<enterloop> op to use in the
5767 loop; if it is null then a suitable op will be constructed automatically.
5768 I<expr> supplies the loop's controlling expression. I<block> supplies the
5769 main body of the loop, and I<cont> optionally supplies a C<continue> block
5770 that operates as a second half of the body. All of these optree inputs
5771 are consumed by this function and become part of the constructed op tree.
5773 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5774 op and, shifted up eight bits, the eight bits of C<op_private> for
5775 the C<leaveloop> op, except that (in both cases) some bits will be set
5776 automatically. I<debuggable> is currently unused and should always be 1.
5777 I<has_my> can be supplied as true to force the
5778 loop body to be enclosed in its own scope.
5784 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5785 OP *expr, OP *block, OP *cont, I32 has_my)
5794 PERL_UNUSED_ARG(debuggable);
5797 if (expr->op_type == OP_READLINE
5798 || expr->op_type == OP_READDIR
5799 || expr->op_type == OP_GLOB
5800 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5801 expr = newUNOP(OP_DEFINED, 0,
5802 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5803 } else if (expr->op_flags & OPf_KIDS) {
5804 const OP * const k1 = ((UNOP*)expr)->op_first;
5805 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5806 switch (expr->op_type) {
5808 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5809 && (k2->op_flags & OPf_STACKED)
5810 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5811 expr = newUNOP(OP_DEFINED, 0, expr);
5815 if (k1 && (k1->op_type == OP_READDIR
5816 || k1->op_type == OP_GLOB
5817 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5818 || k1->op_type == OP_EACH
5819 || k1->op_type == OP_AEACH))
5820 expr = newUNOP(OP_DEFINED, 0, expr);
5827 block = newOP(OP_NULL, 0);
5828 else if (cont || has_my) {
5829 block = op_scope(block);
5833 next = LINKLIST(cont);
5836 OP * const unstack = newOP(OP_UNSTACK, 0);
5839 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5843 listop = op_append_list(OP_LINESEQ, block, cont);
5845 redo = LINKLIST(listop);
5849 o = new_logop(OP_AND, 0, &expr, &listop);
5850 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5851 op_free(expr); /* oops, it's a while (0) */
5853 return NULL; /* listop already freed by new_logop */
5856 ((LISTOP*)listop)->op_last->op_next =
5857 (o == listop ? redo : LINKLIST(o));
5863 NewOp(1101,loop,1,LOOP);
5864 loop->op_type = OP_ENTERLOOP;
5865 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5866 loop->op_private = 0;
5867 loop->op_next = (OP*)loop;
5870 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5872 loop->op_redoop = redo;
5873 loop->op_lastop = o;
5874 o->op_private |= loopflags;
5877 loop->op_nextop = next;
5879 loop->op_nextop = o;
5881 o->op_flags |= flags;
5882 o->op_private |= (flags >> 8);
5887 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5889 Constructs, checks, and returns an op tree expressing a C<foreach>
5890 loop (iteration through a list of values). This is a heavyweight loop,
5891 with structure that allows exiting the loop by C<last> and suchlike.
5893 I<sv> optionally supplies the variable that will be aliased to each
5894 item in turn; if null, it defaults to C<$_> (either lexical or global).
5895 I<expr> supplies the list of values to iterate over. I<block> supplies
5896 the main body of the loop, and I<cont> optionally supplies a C<continue>
5897 block that operates as a second half of the body. All of these optree
5898 inputs are consumed by this function and become part of the constructed
5901 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5902 op and, shifted up eight bits, the eight bits of C<op_private> for
5903 the C<leaveloop> op, except that (in both cases) some bits will be set
5910 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5915 PADOFFSET padoff = 0;
5920 PERL_ARGS_ASSERT_NEWFOROP;
5923 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5924 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5925 sv->op_type = OP_RV2GV;
5926 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5928 /* The op_type check is needed to prevent a possible segfault
5929 * if the loop variable is undeclared and 'strict vars' is in
5930 * effect. This is illegal but is nonetheless parsed, so we
5931 * may reach this point with an OP_CONST where we're expecting
5934 if (cUNOPx(sv)->op_first->op_type == OP_GV
5935 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5936 iterpflags |= OPpITER_DEF;
5938 else if (sv->op_type == OP_PADSV) { /* private variable */
5939 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5940 padoff = sv->op_targ;
5950 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5952 SV *const namesv = PAD_COMPNAME_SV(padoff);
5954 const char *const name = SvPV_const(namesv, len);
5956 if (len == 2 && name[0] == '$' && name[1] == '_')
5957 iterpflags |= OPpITER_DEF;
5961 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5962 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5963 sv = newGVOP(OP_GV, 0, PL_defgv);
5968 iterpflags |= OPpITER_DEF;
5970 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5971 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5972 iterflags |= OPf_STACKED;
5974 else if (expr->op_type == OP_NULL &&
5975 (expr->op_flags & OPf_KIDS) &&
5976 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5978 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5979 * set the STACKED flag to indicate that these values are to be
5980 * treated as min/max values by 'pp_iterinit'.
5982 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5983 LOGOP* const range = (LOGOP*) flip->op_first;
5984 OP* const left = range->op_first;
5985 OP* const right = left->op_sibling;
5988 range->op_flags &= ~OPf_KIDS;
5989 range->op_first = NULL;
5991 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5992 listop->op_first->op_next = range->op_next;
5993 left->op_next = range->op_other;
5994 right->op_next = (OP*)listop;
5995 listop->op_next = listop->op_first;
5998 op_getmad(expr,(OP*)listop,'O');
6002 expr = (OP*)(listop);
6004 iterflags |= OPf_STACKED;
6007 expr = op_lvalue(force_list(expr), OP_GREPSTART);
6010 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6011 op_append_elem(OP_LIST, expr, scalar(sv))));
6012 assert(!loop->op_next);
6013 /* for my $x () sets OPpLVAL_INTRO;
6014 * for our $x () sets OPpOUR_INTRO */
6015 loop->op_private = (U8)iterpflags;
6016 #ifdef PL_OP_SLAB_ALLOC
6019 NewOp(1234,tmp,1,LOOP);
6020 Copy(loop,tmp,1,LISTOP);
6021 S_op_destroy(aTHX_ (OP*)loop);
6025 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6027 loop->op_targ = padoff;
6028 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6030 op_getmad(madsv, (OP*)loop, 'v');
6035 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6037 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6038 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6039 determining the target of the op; it is consumed by this function and
6040 become part of the constructed op tree.
6046 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6051 PERL_ARGS_ASSERT_NEWLOOPEX;
6053 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6055 if (type != OP_GOTO || label->op_type == OP_CONST) {
6056 /* "last()" means "last" */
6057 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6058 o = newOP(type, OPf_SPECIAL);
6060 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
6061 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6065 op_getmad(label,o,'L');
6071 /* Check whether it's going to be a goto &function */
6072 if (label->op_type == OP_ENTERSUB
6073 && !(label->op_flags & OPf_STACKED))
6074 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6075 o = newUNOP(type, OPf_STACKED, label);
6077 PL_hints |= HINT_BLOCK_SCOPE;
6081 /* if the condition is a literal array or hash
6082 (or @{ ... } etc), make a reference to it.
6085 S_ref_array_or_hash(pTHX_ OP *cond)
6088 && (cond->op_type == OP_RV2AV
6089 || cond->op_type == OP_PADAV
6090 || cond->op_type == OP_RV2HV
6091 || cond->op_type == OP_PADHV))
6093 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6096 && (cond->op_type == OP_ASLICE
6097 || cond->op_type == OP_HSLICE)) {
6099 /* anonlist now needs a list from this op, was previously used in
6101 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6102 cond->op_flags |= OPf_WANT_LIST;
6104 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6111 /* These construct the optree fragments representing given()
6114 entergiven and enterwhen are LOGOPs; the op_other pointer
6115 points up to the associated leave op. We need this so we
6116 can put it in the context and make break/continue work.
6117 (Also, of course, pp_enterwhen will jump straight to
6118 op_other if the match fails.)
6122 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6123 I32 enter_opcode, I32 leave_opcode,
6124 PADOFFSET entertarg)
6130 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6132 NewOp(1101, enterop, 1, LOGOP);
6133 enterop->op_type = (Optype)enter_opcode;
6134 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6135 enterop->op_flags = (U8) OPf_KIDS;
6136 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6137 enterop->op_private = 0;
6139 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6142 enterop->op_first = scalar(cond);
6143 cond->op_sibling = block;
6145 o->op_next = LINKLIST(cond);
6146 cond->op_next = (OP *) enterop;
6149 /* This is a default {} block */
6150 enterop->op_first = block;
6151 enterop->op_flags |= OPf_SPECIAL;
6152 o ->op_flags |= OPf_SPECIAL;
6154 o->op_next = (OP *) enterop;
6157 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6158 entergiven and enterwhen both
6161 enterop->op_next = LINKLIST(block);
6162 block->op_next = enterop->op_other = o;
6167 /* Does this look like a boolean operation? For these purposes
6168 a boolean operation is:
6169 - a subroutine call [*]
6170 - a logical connective
6171 - a comparison operator
6172 - a filetest operator, with the exception of -s -M -A -C
6173 - defined(), exists() or eof()
6174 - /$re/ or $foo =~ /$re/
6176 [*] possibly surprising
6179 S_looks_like_bool(pTHX_ const OP *o)
6183 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6185 switch(o->op_type) {
6188 return looks_like_bool(cLOGOPo->op_first);
6192 looks_like_bool(cLOGOPo->op_first)
6193 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6198 o->op_flags & OPf_KIDS
6199 && looks_like_bool(cUNOPo->op_first));
6203 case OP_NOT: case OP_XOR:
6205 case OP_EQ: case OP_NE: case OP_LT:
6206 case OP_GT: case OP_LE: case OP_GE:
6208 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6209 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6211 case OP_SEQ: case OP_SNE: case OP_SLT:
6212 case OP_SGT: case OP_SLE: case OP_SGE:
6216 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6217 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6218 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6219 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6220 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6221 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6222 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6223 case OP_FTTEXT: case OP_FTBINARY:
6225 case OP_DEFINED: case OP_EXISTS:
6226 case OP_MATCH: case OP_EOF:
6233 /* Detect comparisons that have been optimized away */
6234 if (cSVOPo->op_sv == &PL_sv_yes
6235 || cSVOPo->op_sv == &PL_sv_no)
6248 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6250 Constructs, checks, and returns an op tree expressing a C<given> block.
6251 I<cond> supplies the expression that will be locally assigned to a lexical
6252 variable, and I<block> supplies the body of the C<given> construct; they
6253 are consumed by this function and become part of the constructed op tree.
6254 I<defsv_off> is the pad offset of the scalar lexical variable that will
6261 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6264 PERL_ARGS_ASSERT_NEWGIVENOP;
6265 return newGIVWHENOP(
6266 ref_array_or_hash(cond),
6268 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6273 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6275 Constructs, checks, and returns an op tree expressing a C<when> block.
6276 I<cond> supplies the test expression, and I<block> supplies the block
6277 that will be executed if the test evaluates to true; they are consumed
6278 by this function and become part of the constructed op tree. I<cond>
6279 will be interpreted DWIMically, often as a comparison against C<$_>,
6280 and may be null to generate a C<default> block.
6286 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6288 const bool cond_llb = (!cond || looks_like_bool(cond));
6291 PERL_ARGS_ASSERT_NEWWHENOP;
6296 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6298 scalar(ref_array_or_hash(cond)));
6301 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6305 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6306 const STRLEN len, const U32 flags)
6308 const char * const cvp = CvPROTO(cv);
6309 const STRLEN clen = CvPROTOLEN(cv);
6311 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6313 if (((!p != !cvp) /* One has prototype, one has not. */
6315 (flags & SVf_UTF8) == SvUTF8(cv)
6316 ? len != clen || memNE(cvp, p, len)
6318 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6320 : bytes_cmp_utf8((const U8 *)p, len,
6321 (const U8 *)cvp, clen)
6325 && ckWARN_d(WARN_PROTOTYPE)) {
6326 SV* const msg = sv_newmortal();
6330 gv_efullname3(name = sv_newmortal(), gv, NULL);
6331 sv_setpvs(msg, "Prototype mismatch:");
6333 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6335 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6336 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6339 sv_catpvs(msg, ": none");
6340 sv_catpvs(msg, " vs ");
6342 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6344 sv_catpvs(msg, "none");
6345 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6349 static void const_sv_xsub(pTHX_ CV* cv);
6353 =head1 Optree Manipulation Functions
6355 =for apidoc cv_const_sv
6357 If C<cv> is a constant sub eligible for inlining. returns the constant
6358 value returned by the sub. Otherwise, returns NULL.
6360 Constant subs can be created with C<newCONSTSUB> or as described in
6361 L<perlsub/"Constant Functions">.
6366 Perl_cv_const_sv(pTHX_ const CV *const cv)
6368 PERL_UNUSED_CONTEXT;
6371 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6373 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6376 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6377 * Can be called in 3 ways:
6380 * look for a single OP_CONST with attached value: return the value
6382 * cv && CvCLONE(cv) && !CvCONST(cv)
6384 * examine the clone prototype, and if contains only a single
6385 * OP_CONST referencing a pad const, or a single PADSV referencing
6386 * an outer lexical, return a non-zero value to indicate the CV is
6387 * a candidate for "constizing" at clone time
6391 * We have just cloned an anon prototype that was marked as a const
6392 * candidate. Try to grab the current value, and in the case of
6393 * PADSV, ignore it if it has multiple references. Return the value.
6397 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6408 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6409 o = cLISTOPo->op_first->op_sibling;
6411 for (; o; o = o->op_next) {
6412 const OPCODE type = o->op_type;
6414 if (sv && o->op_next == o)
6416 if (o->op_next != o) {
6417 if (type == OP_NEXTSTATE
6418 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6419 || type == OP_PUSHMARK)
6421 if (type == OP_DBSTATE)
6424 if (type == OP_LEAVESUB || type == OP_RETURN)
6428 if (type == OP_CONST && cSVOPo->op_sv)
6430 else if (cv && type == OP_CONST) {
6431 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6435 else if (cv && type == OP_PADSV) {
6436 if (CvCONST(cv)) { /* newly cloned anon */
6437 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6438 /* the candidate should have 1 ref from this pad and 1 ref
6439 * from the parent */
6440 if (!sv || SvREFCNT(sv) != 2)
6447 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6448 sv = &PL_sv_undef; /* an arbitrary non-null value */
6463 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6466 /* This would be the return value, but the return cannot be reached. */
6467 OP* pegop = newOP(OP_NULL, 0);
6470 PERL_UNUSED_ARG(floor);
6480 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6482 NORETURN_FUNCTION_END;
6487 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6492 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6494 register CV *cv = NULL;
6496 /* If the subroutine has no body, no attributes, and no builtin attributes
6497 then it's just a sub declaration, and we may be able to get away with
6498 storing with a placeholder scalar in the symbol table, rather than a
6499 full GV and CV. If anything is present then it will take a full CV to
6501 const I32 gv_fetch_flags
6502 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6504 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6506 const char * const name = o ? SvPV_const(cSVOPo->op_sv, namlen) : NULL;
6508 bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
6511 assert(proto->op_type == OP_CONST);
6512 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6513 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6519 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6521 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6522 SV * const sv = sv_newmortal();
6523 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6524 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6525 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6526 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6528 } else if (PL_curstash) {
6529 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6532 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6536 if (!PL_madskills) {
6545 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6546 maximum a prototype before. */
6547 if (SvTYPE(gv) > SVt_NULL) {
6548 if (!SvPOK((const SV *)gv)
6549 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6551 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6553 cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
6556 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6557 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
6560 sv_setiv(MUTABLE_SV(gv), -1);
6562 SvREFCNT_dec(PL_compcv);
6563 cv = PL_compcv = NULL;
6567 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6569 if (!block || !ps || *ps || attrs
6570 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6572 || block->op_type == OP_NULL
6577 const_sv = op_const_sv(block, NULL);
6580 const bool exists = CvROOT(cv) || CvXSUB(cv);
6582 /* if the subroutine doesn't exist and wasn't pre-declared
6583 * with a prototype, assume it will be AUTOLOADed,
6584 * skipping the prototype check
6586 if (exists || SvPOK(cv))
6587 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
6588 /* already defined (or promised)? */
6589 if (exists || GvASSUMECV(gv)) {
6592 || block->op_type == OP_NULL
6595 if (CvFLAGS(PL_compcv)) {
6596 /* might have had built-in attrs applied */
6597 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6598 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6599 && ckWARN(WARN_MISC))
6600 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6602 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6603 & ~(CVf_LVALUE * pureperl));
6605 if (attrs) goto attrs;
6606 /* just a "sub foo;" when &foo is already defined */
6607 SAVEFREESV(PL_compcv);
6612 && block->op_type != OP_NULL
6615 const line_t oldline = CopLINE(PL_curcop);
6616 if (PL_parser && PL_parser->copline != NOLINE)
6617 CopLINE_set(PL_curcop, PL_parser->copline);
6618 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
6619 CopLINE_set(PL_curcop, oldline);
6621 if (!PL_minus_c) /* keep old one around for madskills */
6624 /* (PL_madskills unset in used file.) */
6633 SvREFCNT_inc_simple_void_NN(const_sv);
6635 assert(!CvROOT(cv) && !CvCONST(cv));
6636 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6637 CvXSUBANY(cv).any_ptr = const_sv;
6638 CvXSUB(cv) = const_sv_xsub;
6644 cv = newCONSTSUB_flags(
6645 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
6650 (CvGV(cv) && GvSTASH(CvGV(cv)))
6655 if (HvENAME_HEK(stash))
6656 mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
6660 SvREFCNT_dec(PL_compcv);
6664 if (cv) { /* must reuse cv if autoloaded */
6665 /* transfer PL_compcv to cv */
6668 && block->op_type != OP_NULL
6671 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6672 AV *const temp_av = CvPADLIST(cv);
6673 CV *const temp_cv = CvOUTSIDE(cv);
6675 assert(!CvWEAKOUTSIDE(cv));
6676 assert(!CvCVGV_RC(cv));
6677 assert(CvGV(cv) == gv);
6680 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6681 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6682 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6683 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6684 CvOUTSIDE(PL_compcv) = temp_cv;
6685 CvPADLIST(PL_compcv) = temp_av;
6687 if (CvFILE(cv) && CvDYNFILE(cv)) {
6688 Safefree(CvFILE(cv));
6690 CvFILE_set_from_cop(cv, PL_curcop);
6691 CvSTASH_set(cv, PL_curstash);
6693 /* inner references to PL_compcv must be fixed up ... */
6694 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6695 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6696 ++PL_sub_generation;
6699 /* Might have had built-in attributes applied -- propagate them. */
6700 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6702 /* ... before we throw it away */
6703 SvREFCNT_dec(PL_compcv);
6711 if (strEQ(name, "import")) {
6712 PL_formfeed = MUTABLE_SV(cv);
6713 /* diag_listed_as: SKIPME */
6714 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6718 if (HvENAME_HEK(GvSTASH(gv)))
6719 /* sub Foo::bar { (shift)+1 } */
6720 mro_method_changed_in(GvSTASH(gv));
6725 CvFILE_set_from_cop(cv, PL_curcop);
6726 CvSTASH_set(cv, PL_curstash);
6730 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6731 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
6734 if (PL_parser && PL_parser->error_count) {
6738 const char *s = strrchr(name, ':');
6740 if (strEQ(s, "BEGIN")) {
6741 const char not_safe[] =
6742 "BEGIN not safe after errors--compilation aborted";
6743 if (PL_in_eval & EVAL_KEEPERR)
6744 Perl_croak(aTHX_ not_safe);
6746 /* force display of errors found but not reported */
6747 sv_catpv(ERRSV, not_safe);
6748 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6757 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6758 the debugger could be able to set a breakpoint in, so signal to
6759 pp_entereval that it should not throw away any saved lines at scope
6762 PL_breakable_sub_gen++;
6763 /* This makes sub {}; work as expected. */
6764 if (block->op_type == OP_STUB) {
6765 OP* const newblock = newSTATEOP(0, NULL, 0);
6767 op_getmad(block,newblock,'B');
6773 else block->op_attached = 1;
6774 CvROOT(cv) = CvLVALUE(cv)
6775 ? newUNOP(OP_LEAVESUBLV, 0,
6776 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6777 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6778 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6779 OpREFCNT_set(CvROOT(cv), 1);
6780 CvSTART(cv) = LINKLIST(CvROOT(cv));
6781 CvROOT(cv)->op_next = 0;
6782 CALL_PEEP(CvSTART(cv));
6783 finalize_optree(CvROOT(cv));
6785 /* now that optimizer has done its work, adjust pad values */
6787 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6790 assert(!CvCONST(cv));
6791 if (ps && !*ps && op_const_sv(block, cv))
6797 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6798 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6799 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6802 if (block && has_name) {
6803 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6804 SV * const tmpstr = sv_newmortal();
6805 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6806 GV_ADDMULTI, SVt_PVHV);
6808 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6811 (long)CopLINE(PL_curcop));
6812 gv_efullname3(tmpstr, gv, NULL);
6813 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6814 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
6815 hv = GvHVn(db_postponed);
6816 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
6817 CV * const pcv = GvCV(db_postponed);
6823 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6828 if (name && ! (PL_parser && PL_parser->error_count))
6829 process_special_blocks(name, gv, cv);
6834 PL_parser->copline = NOLINE;
6840 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6843 const char *const colon = strrchr(fullname,':');
6844 const char *const name = colon ? colon + 1 : fullname;
6846 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6849 if (strEQ(name, "BEGIN")) {
6850 const I32 oldscope = PL_scopestack_ix;
6852 SAVECOPFILE(&PL_compiling);
6853 SAVECOPLINE(&PL_compiling);
6854 SAVEVPTR(PL_curcop);
6856 DEBUG_x( dump_sub(gv) );
6857 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6858 GvCV_set(gv,0); /* cv has been hijacked */
6859 call_list(oldscope, PL_beginav);
6861 CopHINTS_set(&PL_compiling, PL_hints);
6868 if strEQ(name, "END") {
6869 DEBUG_x( dump_sub(gv) );
6870 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6873 } else if (*name == 'U') {
6874 if (strEQ(name, "UNITCHECK")) {
6875 /* It's never too late to run a unitcheck block */
6876 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6880 } else if (*name == 'C') {
6881 if (strEQ(name, "CHECK")) {
6883 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6884 "Too late to run CHECK block");
6885 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6889 } else if (*name == 'I') {
6890 if (strEQ(name, "INIT")) {
6892 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6893 "Too late to run INIT block");
6894 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6900 DEBUG_x( dump_sub(gv) );
6901 GvCV_set(gv,0); /* cv has been hijacked */
6906 =for apidoc newCONSTSUB
6908 See L</newCONSTSUB_flags>.
6914 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6916 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
6920 =for apidoc newCONSTSUB_flags
6922 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6923 eligible for inlining at compile-time.
6925 Currently, the only useful value for C<flags> is SVf_UTF8.
6927 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6928 which won't be called if used as a destructor, but will suppress the overhead
6929 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6936 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
6942 const char *const file = CopFILE(PL_curcop);
6944 SV *const temp_sv = CopFILESV(PL_curcop);
6945 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6950 if (IN_PERL_RUNTIME) {
6951 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6952 * an op shared between threads. Use a non-shared COP for our
6954 SAVEVPTR(PL_curcop);
6955 SAVECOMPILEWARNINGS();
6956 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6957 PL_curcop = &PL_compiling;
6959 SAVECOPLINE(PL_curcop);
6960 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6963 PL_hints &= ~HINT_BLOCK_SCOPE;
6966 SAVEGENERICSV(PL_curstash);
6967 SAVECOPSTASH(PL_curcop);
6968 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
6969 CopSTASH_set(PL_curcop,stash);
6972 /* file becomes the CvFILE. For an XS, it's usually static storage,
6973 and so doesn't get free()d. (It's expected to be from the C pre-
6974 processor __FILE__ directive). But we need a dynamically allocated one,
6975 and we need it to get freed. */
6976 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
6977 &sv, XS_DYNAMIC_FILENAME | flags);
6978 CvXSUBANY(cv).any_ptr = sv;
6983 CopSTASH_free(PL_curcop);
6991 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6992 const char *const filename, const char *const proto,
6995 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6996 return newXS_len_flags(
6997 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7002 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7003 XSUBADDR_t subaddr, const char *const filename,
7004 const char *const proto, SV **const_svp,
7009 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7012 GV * const gv = name
7014 name,len,GV_ADDMULTI|flags,SVt_PVCV
7017 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
7018 GV_ADDMULTI | flags, SVt_PVCV);
7021 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7023 if ((cv = (name ? GvCV(gv) : NULL))) {
7025 /* just a cached method */
7029 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7030 /* already defined (or promised) */
7031 /* Redundant check that allows us to avoid creating an SV
7032 most of the time: */
7033 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7034 const line_t oldline = CopLINE(PL_curcop);
7035 if (PL_parser && PL_parser->copline != NOLINE)
7036 CopLINE_set(PL_curcop, PL_parser->copline);
7037 report_redefined_cv(newSVpvn_flags(
7038 name,len,(flags&SVf_UTF8)|SVs_TEMP
7041 CopLINE_set(PL_curcop, oldline);
7048 if (cv) /* must reuse cv if autoloaded */
7051 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7055 if (HvENAME_HEK(GvSTASH(gv)))
7056 mro_method_changed_in(GvSTASH(gv)); /* newXS */
7062 (void)gv_fetchfile(filename);
7063 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7064 an external constant string */
7065 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7067 CvXSUB(cv) = subaddr;
7070 process_special_blocks(name, gv, cv);
7073 if (flags & XS_DYNAMIC_FILENAME) {
7074 CvFILE(cv) = savepv(filename);
7077 sv_setpv(MUTABLE_SV(cv), proto);
7082 =for apidoc U||newXS
7084 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7085 static storage, as it is used directly as CvFILE(), without a copy being made.
7091 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7093 PERL_ARGS_ASSERT_NEWXS;
7094 return newXS_flags(name, subaddr, filename, NULL, 0);
7102 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7107 OP* pegop = newOP(OP_NULL, 0);
7111 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7112 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7115 if ((cv = GvFORM(gv))) {
7116 if (ckWARN(WARN_REDEFINE)) {
7117 const line_t oldline = CopLINE(PL_curcop);
7118 if (PL_parser && PL_parser->copline != NOLINE)
7119 CopLINE_set(PL_curcop, PL_parser->copline);
7121 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7122 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7124 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7125 "Format STDOUT redefined");
7127 CopLINE_set(PL_curcop, oldline);
7134 CvFILE_set_from_cop(cv, PL_curcop);
7137 pad_tidy(padtidy_FORMAT);
7138 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7139 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7140 OpREFCNT_set(CvROOT(cv), 1);
7141 CvSTART(cv) = LINKLIST(CvROOT(cv));
7142 CvROOT(cv)->op_next = 0;
7143 CALL_PEEP(CvSTART(cv));
7144 finalize_optree(CvROOT(cv));
7146 op_getmad(o,pegop,'n');
7147 op_getmad_weak(block, pegop, 'b');
7152 PL_parser->copline = NOLINE;
7160 Perl_newANONLIST(pTHX_ OP *o)
7162 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7166 Perl_newANONHASH(pTHX_ OP *o)
7168 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7172 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7174 return newANONATTRSUB(floor, proto, NULL, block);
7178 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7180 return newUNOP(OP_REFGEN, 0,
7181 newSVOP(OP_ANONCODE, 0,
7182 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7186 Perl_oopsAV(pTHX_ OP *o)
7190 PERL_ARGS_ASSERT_OOPSAV;
7192 switch (o->op_type) {
7194 o->op_type = OP_PADAV;
7195 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7196 return ref(o, OP_RV2AV);
7199 o->op_type = OP_RV2AV;
7200 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7205 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7212 Perl_oopsHV(pTHX_ OP *o)
7216 PERL_ARGS_ASSERT_OOPSHV;
7218 switch (o->op_type) {
7221 o->op_type = OP_PADHV;
7222 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7223 return ref(o, OP_RV2HV);
7227 o->op_type = OP_RV2HV;
7228 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7233 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7240 Perl_newAVREF(pTHX_ OP *o)
7244 PERL_ARGS_ASSERT_NEWAVREF;
7246 if (o->op_type == OP_PADANY) {
7247 o->op_type = OP_PADAV;
7248 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7251 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7252 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7253 "Using an array as a reference is deprecated");
7255 return newUNOP(OP_RV2AV, 0, scalar(o));
7259 Perl_newGVREF(pTHX_ I32 type, OP *o)
7261 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7262 return newUNOP(OP_NULL, 0, o);
7263 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7267 Perl_newHVREF(pTHX_ OP *o)
7271 PERL_ARGS_ASSERT_NEWHVREF;
7273 if (o->op_type == OP_PADANY) {
7274 o->op_type = OP_PADHV;
7275 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7278 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7279 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7280 "Using a hash as a reference is deprecated");
7282 return newUNOP(OP_RV2HV, 0, scalar(o));
7286 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7288 return newUNOP(OP_RV2CV, flags, scalar(o));
7292 Perl_newSVREF(pTHX_ OP *o)
7296 PERL_ARGS_ASSERT_NEWSVREF;
7298 if (o->op_type == OP_PADANY) {
7299 o->op_type = OP_PADSV;
7300 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7303 return newUNOP(OP_RV2SV, 0, scalar(o));
7306 /* Check routines. See the comments at the top of this file for details
7307 * on when these are called */
7310 Perl_ck_anoncode(pTHX_ OP *o)
7312 PERL_ARGS_ASSERT_CK_ANONCODE;
7314 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7316 cSVOPo->op_sv = NULL;
7321 Perl_ck_bitop(pTHX_ OP *o)
7325 PERL_ARGS_ASSERT_CK_BITOP;
7327 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7328 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7329 && (o->op_type == OP_BIT_OR
7330 || o->op_type == OP_BIT_AND
7331 || o->op_type == OP_BIT_XOR))
7333 const OP * const left = cBINOPo->op_first;
7334 const OP * const right = left->op_sibling;
7335 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7336 (left->op_flags & OPf_PARENS) == 0) ||
7337 (OP_IS_NUMCOMPARE(right->op_type) &&
7338 (right->op_flags & OPf_PARENS) == 0))
7339 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7340 "Possible precedence problem on bitwise %c operator",
7341 o->op_type == OP_BIT_OR ? '|'
7342 : o->op_type == OP_BIT_AND ? '&' : '^'
7348 PERL_STATIC_INLINE bool
7349 is_dollar_bracket(pTHX_ const OP * const o)
7352 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
7353 && (kid = cUNOPx(o)->op_first)
7354 && kid->op_type == OP_GV
7355 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
7359 Perl_ck_cmp(pTHX_ OP *o)
7361 PERL_ARGS_ASSERT_CK_CMP;
7362 if (ckWARN(WARN_SYNTAX)) {
7363 const OP *kid = cUNOPo->op_first;
7365 is_dollar_bracket(aTHX_ kid)
7366 || ((kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
7368 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7369 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
7375 Perl_ck_concat(pTHX_ OP *o)
7377 const OP * const kid = cUNOPo->op_first;
7379 PERL_ARGS_ASSERT_CK_CONCAT;
7380 PERL_UNUSED_CONTEXT;
7382 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7383 !(kUNOP->op_first->op_flags & OPf_MOD))
7384 o->op_flags |= OPf_STACKED;
7389 Perl_ck_spair(pTHX_ OP *o)
7393 PERL_ARGS_ASSERT_CK_SPAIR;
7395 if (o->op_flags & OPf_KIDS) {
7398 const OPCODE type = o->op_type;
7399 o = modkids(ck_fun(o), type);
7400 kid = cUNOPo->op_first;
7401 newop = kUNOP->op_first->op_sibling;
7403 const OPCODE type = newop->op_type;
7404 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7405 type == OP_PADAV || type == OP_PADHV ||
7406 type == OP_RV2AV || type == OP_RV2HV)
7410 op_getmad(kUNOP->op_first,newop,'K');
7412 op_free(kUNOP->op_first);
7414 kUNOP->op_first = newop;
7416 o->op_ppaddr = PL_ppaddr[++o->op_type];
7421 Perl_ck_delete(pTHX_ OP *o)
7423 PERL_ARGS_ASSERT_CK_DELETE;
7427 if (o->op_flags & OPf_KIDS) {
7428 OP * const kid = cUNOPo->op_first;
7429 switch (kid->op_type) {
7431 o->op_flags |= OPf_SPECIAL;
7434 o->op_private |= OPpSLICE;
7437 o->op_flags |= OPf_SPECIAL;
7442 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7445 if (kid->op_private & OPpLVAL_INTRO)
7446 o->op_private |= OPpLVAL_INTRO;
7453 Perl_ck_die(pTHX_ OP *o)
7455 PERL_ARGS_ASSERT_CK_DIE;
7458 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7464 Perl_ck_eof(pTHX_ OP *o)
7468 PERL_ARGS_ASSERT_CK_EOF;
7470 if (o->op_flags & OPf_KIDS) {
7472 if (cLISTOPo->op_first->op_type == OP_STUB) {
7474 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7476 op_getmad(o,newop,'O');
7483 kid = cLISTOPo->op_first;
7484 if (kid->op_type == OP_RV2GV)
7485 kid->op_private |= OPpALLOW_FAKE;
7491 Perl_ck_eval(pTHX_ OP *o)
7495 PERL_ARGS_ASSERT_CK_EVAL;
7497 PL_hints |= HINT_BLOCK_SCOPE;
7498 if (o->op_flags & OPf_KIDS) {
7499 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7502 o->op_flags &= ~OPf_KIDS;
7505 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7511 cUNOPo->op_first = 0;
7516 NewOp(1101, enter, 1, LOGOP);
7517 enter->op_type = OP_ENTERTRY;
7518 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7519 enter->op_private = 0;
7521 /* establish postfix order */
7522 enter->op_next = (OP*)enter;
7524 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7525 o->op_type = OP_LEAVETRY;
7526 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7527 enter->op_other = o;
7528 op_getmad(oldo,o,'O');
7537 const U8 priv = o->op_private;
7543 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
7544 op_getmad(oldo,o,'O');
7546 o->op_targ = (PADOFFSET)PL_hints;
7547 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7548 if ((PL_hints & HINT_LOCALIZE_HH) != 0
7549 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
7550 /* Store a copy of %^H that pp_entereval can pick up. */
7551 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7552 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7553 cUNOPo->op_first->op_sibling = hhop;
7554 o->op_private |= OPpEVAL_HAS_HH;
7556 if (!(o->op_private & OPpEVAL_BYTES)
7557 && FEATURE_IS_ENABLED("unieval"))
7558 o->op_private |= OPpEVAL_UNICODE;
7564 Perl_ck_exit(pTHX_ OP *o)
7566 PERL_ARGS_ASSERT_CK_EXIT;
7569 HV * const table = GvHV(PL_hintgv);
7571 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7572 if (svp && *svp && SvTRUE(*svp))
7573 o->op_private |= OPpEXIT_VMSISH;
7575 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7581 Perl_ck_exec(pTHX_ OP *o)
7583 PERL_ARGS_ASSERT_CK_EXEC;
7585 if (o->op_flags & OPf_STACKED) {
7588 kid = cUNOPo->op_first->op_sibling;
7589 if (kid->op_type == OP_RV2GV)
7598 Perl_ck_exists(pTHX_ OP *o)
7602 PERL_ARGS_ASSERT_CK_EXISTS;
7605 if (o->op_flags & OPf_KIDS) {
7606 OP * const kid = cUNOPo->op_first;
7607 if (kid->op_type == OP_ENTERSUB) {
7608 (void) ref(kid, o->op_type);
7609 if (kid->op_type != OP_RV2CV
7610 && !(PL_parser && PL_parser->error_count))
7611 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7613 o->op_private |= OPpEXISTS_SUB;
7615 else if (kid->op_type == OP_AELEM)
7616 o->op_flags |= OPf_SPECIAL;
7617 else if (kid->op_type != OP_HELEM)
7618 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7626 Perl_ck_rvconst(pTHX_ register OP *o)
7629 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7631 PERL_ARGS_ASSERT_CK_RVCONST;
7633 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7634 if (o->op_type == OP_RV2CV)
7635 o->op_private &= ~1;
7637 if (kid->op_type == OP_CONST) {
7640 SV * const kidsv = kid->op_sv;
7642 /* Is it a constant from cv_const_sv()? */
7643 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7644 SV * const rsv = SvRV(kidsv);
7645 const svtype type = SvTYPE(rsv);
7646 const char *badtype = NULL;
7648 switch (o->op_type) {
7650 if (type > SVt_PVMG)
7651 badtype = "a SCALAR";
7654 if (type != SVt_PVAV)
7655 badtype = "an ARRAY";
7658 if (type != SVt_PVHV)
7662 if (type != SVt_PVCV)
7667 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7670 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7671 const char *badthing;
7672 switch (o->op_type) {
7674 badthing = "a SCALAR";
7677 badthing = "an ARRAY";
7680 badthing = "a HASH";
7688 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7689 SVfARG(kidsv), badthing);
7692 * This is a little tricky. We only want to add the symbol if we
7693 * didn't add it in the lexer. Otherwise we get duplicate strict
7694 * warnings. But if we didn't add it in the lexer, we must at
7695 * least pretend like we wanted to add it even if it existed before,
7696 * or we get possible typo warnings. OPpCONST_ENTERED says
7697 * whether the lexer already added THIS instance of this symbol.
7699 iscv = (o->op_type == OP_RV2CV) * 2;
7701 gv = gv_fetchsv(kidsv,
7702 iscv | !(kid->op_private & OPpCONST_ENTERED),
7705 : o->op_type == OP_RV2SV
7707 : o->op_type == OP_RV2AV
7709 : o->op_type == OP_RV2HV
7712 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7714 kid->op_type = OP_GV;
7715 SvREFCNT_dec(kid->op_sv);
7717 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7718 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7719 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7721 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7723 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7725 kid->op_private = 0;
7726 kid->op_ppaddr = PL_ppaddr[OP_GV];
7727 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7735 Perl_ck_ftst(pTHX_ OP *o)
7738 const I32 type = o->op_type;
7740 PERL_ARGS_ASSERT_CK_FTST;
7742 if (o->op_flags & OPf_REF) {
7745 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7746 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7747 const OPCODE kidtype = kid->op_type;
7749 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7750 OP * const newop = newGVOP(type, OPf_REF,
7751 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7753 op_getmad(o,newop,'O');
7759 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7760 o->op_private |= OPpFT_ACCESS;
7761 if (PL_check[kidtype] == Perl_ck_ftst
7762 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7763 o->op_private |= OPpFT_STACKED;
7764 kid->op_private |= OPpFT_STACKING;
7773 if (type == OP_FTTTY)
7774 o = newGVOP(type, OPf_REF, PL_stdingv);
7776 o = newUNOP(type, 0, newDEFSVOP());
7777 op_getmad(oldo,o,'O');
7783 Perl_ck_fun(pTHX_ OP *o)
7786 const int type = o->op_type;
7787 register I32 oa = PL_opargs[type] >> OASHIFT;
7789 PERL_ARGS_ASSERT_CK_FUN;
7791 if (o->op_flags & OPf_STACKED) {
7792 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7795 return no_fh_allowed(o);
7798 if (o->op_flags & OPf_KIDS) {
7799 OP **tokid = &cLISTOPo->op_first;
7800 register OP *kid = cLISTOPo->op_first;
7803 bool seen_optional = FALSE;
7805 if (kid->op_type == OP_PUSHMARK ||
7806 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7808 tokid = &kid->op_sibling;
7809 kid = kid->op_sibling;
7811 if (kid && kid->op_type == OP_COREARGS) {
7812 bool optional = FALSE;
7815 if (oa & OA_OPTIONAL) optional = TRUE;
7818 if (optional) o->op_private |= numargs;
7823 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
7824 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
7825 *tokid = kid = newDEFSVOP();
7826 seen_optional = TRUE;
7831 sibl = kid->op_sibling;
7833 if (!sibl && kid->op_type == OP_STUB) {
7840 /* list seen where single (scalar) arg expected? */
7841 if (numargs == 1 && !(oa >> 4)
7842 && kid->op_type == OP_LIST && type != OP_SCALAR)
7844 return too_many_arguments(o,PL_op_desc[type]);
7857 if ((type == OP_PUSH || type == OP_UNSHIFT)
7858 && !kid->op_sibling)
7859 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7860 "Useless use of %s with no values",
7863 if (kid->op_type == OP_CONST &&
7864 (kid->op_private & OPpCONST_BARE))
7866 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7867 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7868 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7869 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7870 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7872 op_getmad(kid,newop,'K');
7877 kid->op_sibling = sibl;
7880 else if (kid->op_type == OP_CONST
7881 && ( !SvROK(cSVOPx_sv(kid))
7882 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7884 bad_type(numargs, "array", PL_op_desc[type], kid);
7885 /* Defer checks to run-time if we have a scalar arg */
7886 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7887 op_lvalue(kid, type);
7891 if (kid->op_type == OP_CONST &&
7892 (kid->op_private & OPpCONST_BARE))
7894 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7895 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7896 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7897 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7898 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7900 op_getmad(kid,newop,'K');
7905 kid->op_sibling = sibl;
7908 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7909 bad_type(numargs, "hash", PL_op_desc[type], kid);
7910 op_lvalue(kid, type);
7914 OP * const newop = newUNOP(OP_NULL, 0, kid);
7915 kid->op_sibling = 0;
7917 newop->op_next = newop;
7919 kid->op_sibling = sibl;
7924 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7925 if (kid->op_type == OP_CONST &&
7926 (kid->op_private & OPpCONST_BARE))
7928 OP * const newop = newGVOP(OP_GV, 0,
7929 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7930 if (!(o->op_private & 1) && /* if not unop */
7931 kid == cLISTOPo->op_last)
7932 cLISTOPo->op_last = newop;
7934 op_getmad(kid,newop,'K');
7940 else if (kid->op_type == OP_READLINE) {
7941 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7942 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7945 I32 flags = OPf_SPECIAL;
7949 /* is this op a FH constructor? */
7950 if (is_handle_constructor(o,numargs)) {
7951 const char *name = NULL;
7954 bool want_dollar = TRUE;
7957 /* Set a flag to tell rv2gv to vivify
7958 * need to "prove" flag does not mean something
7959 * else already - NI-S 1999/05/07
7962 if (kid->op_type == OP_PADSV) {
7964 = PAD_COMPNAME_SV(kid->op_targ);
7965 name = SvPV_const(namesv, len);
7966 name_utf8 = SvUTF8(namesv);
7968 else if (kid->op_type == OP_RV2SV
7969 && kUNOP->op_first->op_type == OP_GV)
7971 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7973 len = GvNAMELEN(gv);
7974 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
7976 else if (kid->op_type == OP_AELEM
7977 || kid->op_type == OP_HELEM)
7980 OP *op = ((BINOP*)kid)->op_first;
7984 const char * const a =
7985 kid->op_type == OP_AELEM ?
7987 if (((op->op_type == OP_RV2AV) ||
7988 (op->op_type == OP_RV2HV)) &&
7989 (firstop = ((UNOP*)op)->op_first) &&
7990 (firstop->op_type == OP_GV)) {
7991 /* packagevar $a[] or $h{} */
7992 GV * const gv = cGVOPx_gv(firstop);
8000 else if (op->op_type == OP_PADAV
8001 || op->op_type == OP_PADHV) {
8002 /* lexicalvar $a[] or $h{} */
8003 const char * const padname =
8004 PAD_COMPNAME_PV(op->op_targ);
8013 name = SvPV_const(tmpstr, len);
8014 name_utf8 = SvUTF8(tmpstr);
8019 name = "__ANONIO__";
8021 want_dollar = FALSE;
8023 op_lvalue(kid, type);
8027 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
8028 namesv = PAD_SVl(targ);
8029 SvUPGRADE(namesv, SVt_PV);
8030 if (want_dollar && *name != '$')
8031 sv_setpvs(namesv, "$");
8032 sv_catpvn(namesv, name, len);
8033 if ( name_utf8 ) SvUTF8_on(namesv);
8036 kid->op_sibling = 0;
8037 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8038 kid->op_targ = targ;
8039 kid->op_private |= priv;
8041 kid->op_sibling = sibl;
8047 op_lvalue(scalar(kid), type);
8051 tokid = &kid->op_sibling;
8052 kid = kid->op_sibling;
8055 if (kid && kid->op_type != OP_STUB)
8056 return too_many_arguments(o,OP_DESC(o));
8057 o->op_private |= numargs;
8059 /* FIXME - should the numargs move as for the PERL_MAD case? */
8060 o->op_private |= numargs;
8062 return too_many_arguments(o,OP_DESC(o));
8066 else if (PL_opargs[type] & OA_DEFGV) {
8068 OP *newop = newUNOP(type, 0, newDEFSVOP());
8069 op_getmad(o,newop,'O');
8072 /* Ordering of these two is important to keep f_map.t passing. */
8074 return newUNOP(type, 0, newDEFSVOP());
8079 while (oa & OA_OPTIONAL)
8081 if (oa && oa != OA_LIST)
8082 return too_few_arguments(o,OP_DESC(o));
8088 Perl_ck_glob(pTHX_ OP *o)
8092 const bool core = o->op_flags & OPf_SPECIAL;
8094 PERL_ARGS_ASSERT_CK_GLOB;
8097 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8098 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8100 if (core) gv = NULL;
8101 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
8102 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8104 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
8107 #if !defined(PERL_EXTERNAL_GLOB)
8108 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8110 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8111 newSVpvs("File::Glob"), NULL, NULL, NULL);
8114 #endif /* !PERL_EXTERNAL_GLOB */
8116 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8119 * \ null - const(wildcard)
8124 * \ mark - glob - rv2cv
8125 * | \ gv(CORE::GLOBAL::glob)
8127 * \ null - const(wildcard) - const(ix)
8129 o->op_flags |= OPf_SPECIAL;
8130 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8131 op_append_elem(OP_GLOB, o,
8132 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
8133 o = newLISTOP(OP_LIST, 0, o, NULL);
8134 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
8135 op_append_elem(OP_LIST, o,
8136 scalar(newUNOP(OP_RV2CV, 0,
8137 newGVOP(OP_GV, 0, gv)))));
8138 o = newUNOP(OP_NULL, 0, ck_subr(o));
8139 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8142 else o->op_flags &= ~OPf_SPECIAL;
8143 gv = newGVgen("main");
8145 #ifndef PERL_EXTERNAL_GLOB
8146 sv_setiv(GvSVn(gv),PL_glob_index++);
8148 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8154 Perl_ck_grep(pTHX_ OP *o)
8159 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8162 PERL_ARGS_ASSERT_CK_GREP;
8164 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8165 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8167 if (o->op_flags & OPf_STACKED) {
8170 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8171 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8172 return no_fh_allowed(o);
8173 for (k = kid; k; k = k->op_next) {
8176 NewOp(1101, gwop, 1, LOGOP);
8177 kid->op_next = (OP*)gwop;
8178 o->op_flags &= ~OPf_STACKED;
8180 kid = cLISTOPo->op_first->op_sibling;
8181 if (type == OP_MAPWHILE)
8186 if (PL_parser && PL_parser->error_count)
8188 kid = cLISTOPo->op_first->op_sibling;
8189 if (kid->op_type != OP_NULL)
8190 Perl_croak(aTHX_ "panic: ck_grep");
8191 kid = kUNOP->op_first;
8194 NewOp(1101, gwop, 1, LOGOP);
8195 gwop->op_type = type;
8196 gwop->op_ppaddr = PL_ppaddr[type];
8197 gwop->op_first = listkids(o);
8198 gwop->op_flags |= OPf_KIDS;
8199 gwop->op_other = LINKLIST(kid);
8200 kid->op_next = (OP*)gwop;
8201 offset = pad_findmy_pvs("$_", 0);
8202 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8203 o->op_private = gwop->op_private = 0;
8204 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8207 o->op_private = gwop->op_private = OPpGREP_LEX;
8208 gwop->op_targ = o->op_targ = offset;
8211 kid = cLISTOPo->op_first->op_sibling;
8212 if (!kid || !kid->op_sibling)
8213 return too_few_arguments(o,OP_DESC(o));
8214 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8215 op_lvalue(kid, OP_GREPSTART);
8221 Perl_ck_index(pTHX_ OP *o)
8223 PERL_ARGS_ASSERT_CK_INDEX;
8225 if (o->op_flags & OPf_KIDS) {
8226 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8228 kid = kid->op_sibling; /* get past "big" */
8229 if (kid && kid->op_type == OP_CONST) {
8230 const bool save_taint = PL_tainted;
8231 fbm_compile(((SVOP*)kid)->op_sv, 0);
8232 PL_tainted = save_taint;
8239 Perl_ck_lfun(pTHX_ OP *o)
8241 const OPCODE type = o->op_type;
8243 PERL_ARGS_ASSERT_CK_LFUN;
8245 return modkids(ck_fun(o), type);
8249 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8251 PERL_ARGS_ASSERT_CK_DEFINED;
8253 if ((o->op_flags & OPf_KIDS)) {
8254 switch (cUNOPo->op_first->op_type) {
8256 /* This is needed for
8257 if (defined %stash::)
8258 to work. Do not break Tk.
8260 break; /* Globals via GV can be undef */
8262 case OP_AASSIGN: /* Is this a good idea? */
8263 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8264 "defined(@array) is deprecated");
8265 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8266 "\t(Maybe you should just omit the defined()?)\n");
8270 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8271 "defined(%%hash) is deprecated");
8272 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8273 "\t(Maybe you should just omit the defined()?)\n");
8284 Perl_ck_readline(pTHX_ OP *o)
8286 PERL_ARGS_ASSERT_CK_READLINE;
8288 if (o->op_flags & OPf_KIDS) {
8289 OP *kid = cLISTOPo->op_first;
8290 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
8294 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8296 op_getmad(o,newop,'O');
8306 Perl_ck_rfun(pTHX_ OP *o)
8308 const OPCODE type = o->op_type;
8310 PERL_ARGS_ASSERT_CK_RFUN;
8312 return refkids(ck_fun(o), type);
8316 Perl_ck_listiob(pTHX_ OP *o)
8320 PERL_ARGS_ASSERT_CK_LISTIOB;
8322 kid = cLISTOPo->op_first;
8325 kid = cLISTOPo->op_first;
8327 if (kid->op_type == OP_PUSHMARK)
8328 kid = kid->op_sibling;
8329 if (kid && o->op_flags & OPf_STACKED)
8330 kid = kid->op_sibling;
8331 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8332 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8333 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8334 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8335 cLISTOPo->op_first->op_sibling = kid;
8336 cLISTOPo->op_last = kid;
8337 kid = kid->op_sibling;
8342 op_append_elem(o->op_type, o, newDEFSVOP());
8348 Perl_ck_smartmatch(pTHX_ OP *o)
8351 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8352 if (0 == (o->op_flags & OPf_SPECIAL)) {
8353 OP *first = cBINOPo->op_first;
8354 OP *second = first->op_sibling;
8356 /* Implicitly take a reference to an array or hash */
8357 first->op_sibling = NULL;
8358 first = cBINOPo->op_first = ref_array_or_hash(first);
8359 second = first->op_sibling = ref_array_or_hash(second);
8361 /* Implicitly take a reference to a regular expression */
8362 if (first->op_type == OP_MATCH) {
8363 first->op_type = OP_QR;
8364 first->op_ppaddr = PL_ppaddr[OP_QR];
8366 if (second->op_type == OP_MATCH) {
8367 second->op_type = OP_QR;
8368 second->op_ppaddr = PL_ppaddr[OP_QR];
8377 Perl_ck_sassign(pTHX_ OP *o)
8380 OP * const kid = cLISTOPo->op_first;
8382 PERL_ARGS_ASSERT_CK_SASSIGN;
8384 /* has a disposable target? */
8385 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8386 && !(kid->op_flags & OPf_STACKED)
8387 /* Cannot steal the second time! */
8388 && !(kid->op_private & OPpTARGET_MY)
8389 /* Keep the full thing for madskills */
8393 OP * const kkid = kid->op_sibling;
8395 /* Can just relocate the target. */
8396 if (kkid && kkid->op_type == OP_PADSV
8397 && !(kkid->op_private & OPpLVAL_INTRO))
8399 kid->op_targ = kkid->op_targ;
8401 /* Now we do not need PADSV and SASSIGN. */
8402 kid->op_sibling = o->op_sibling; /* NULL */
8403 cLISTOPo->op_first = NULL;
8406 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8410 if (kid->op_sibling) {
8411 OP *kkid = kid->op_sibling;
8412 /* For state variable assignment, kkid is a list op whose op_last
8414 if ((kkid->op_type == OP_PADSV ||
8415 (kkid->op_type == OP_LIST &&
8416 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8419 && (kkid->op_private & OPpLVAL_INTRO)
8420 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8421 const PADOFFSET target = kkid->op_targ;
8422 OP *const other = newOP(OP_PADSV,
8424 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8425 OP *const first = newOP(OP_NULL, 0);
8426 OP *const nullop = newCONDOP(0, first, o, other);
8427 OP *const condop = first->op_next;
8428 /* hijacking PADSTALE for uninitialized state variables */
8429 SvPADSTALE_on(PAD_SVl(target));
8431 condop->op_type = OP_ONCE;
8432 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8433 condop->op_targ = target;
8434 other->op_targ = target;
8436 /* Because we change the type of the op here, we will skip the
8437 assignment binop->op_last = binop->op_first->op_sibling; at the
8438 end of Perl_newBINOP(). So need to do it here. */
8439 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8448 Perl_ck_match(pTHX_ OP *o)
8452 PERL_ARGS_ASSERT_CK_MATCH;
8454 if (o->op_type != OP_QR && PL_compcv) {
8455 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8456 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8457 o->op_targ = offset;
8458 o->op_private |= OPpTARGET_MY;
8461 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8462 o->op_private |= OPpRUNTIME;
8467 Perl_ck_method(pTHX_ OP *o)
8469 OP * const kid = cUNOPo->op_first;
8471 PERL_ARGS_ASSERT_CK_METHOD;
8473 if (kid->op_type == OP_CONST) {
8474 SV* sv = kSVOP->op_sv;
8475 const char * const method = SvPVX_const(sv);
8476 if (!(strchr(method, ':') || strchr(method, '\''))) {
8478 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8479 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
8482 kSVOP->op_sv = NULL;
8484 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8486 op_getmad(o,cmop,'O');
8497 Perl_ck_null(pTHX_ OP *o)
8499 PERL_ARGS_ASSERT_CK_NULL;
8500 PERL_UNUSED_CONTEXT;
8505 Perl_ck_open(pTHX_ OP *o)
8508 HV * const table = GvHV(PL_hintgv);
8510 PERL_ARGS_ASSERT_CK_OPEN;
8513 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8516 const char *d = SvPV_const(*svp, len);
8517 const I32 mode = mode_from_discipline(d, len);
8518 if (mode & O_BINARY)
8519 o->op_private |= OPpOPEN_IN_RAW;
8520 else if (mode & O_TEXT)
8521 o->op_private |= OPpOPEN_IN_CRLF;
8524 svp = hv_fetchs(table, "open_OUT", FALSE);
8527 const char *d = SvPV_const(*svp, len);
8528 const I32 mode = mode_from_discipline(d, len);
8529 if (mode & O_BINARY)
8530 o->op_private |= OPpOPEN_OUT_RAW;
8531 else if (mode & O_TEXT)
8532 o->op_private |= OPpOPEN_OUT_CRLF;
8535 if (o->op_type == OP_BACKTICK) {
8536 if (!(o->op_flags & OPf_KIDS)) {
8537 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8539 op_getmad(o,newop,'O');
8548 /* In case of three-arg dup open remove strictness
8549 * from the last arg if it is a bareword. */
8550 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8551 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8555 if ((last->op_type == OP_CONST) && /* The bareword. */
8556 (last->op_private & OPpCONST_BARE) &&
8557 (last->op_private & OPpCONST_STRICT) &&
8558 (oa = first->op_sibling) && /* The fh. */
8559 (oa = oa->op_sibling) && /* The mode. */
8560 (oa->op_type == OP_CONST) &&
8561 SvPOK(((SVOP*)oa)->op_sv) &&
8562 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8563 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8564 (last == oa->op_sibling)) /* The bareword. */
8565 last->op_private &= ~OPpCONST_STRICT;
8571 Perl_ck_repeat(pTHX_ OP *o)
8573 PERL_ARGS_ASSERT_CK_REPEAT;
8575 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8576 o->op_private |= OPpREPEAT_DOLIST;
8577 cBINOPo->op_first = force_list(cBINOPo->op_first);
8585 Perl_ck_require(pTHX_ OP *o)
8590 PERL_ARGS_ASSERT_CK_REQUIRE;
8592 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8593 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8595 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8596 SV * const sv = kid->op_sv;
8597 U32 was_readonly = SvREADONLY(sv);
8604 sv_force_normal_flags(sv, 0);
8605 assert(!SvREADONLY(sv));
8615 for (; s < end; s++) {
8616 if (*s == ':' && s[1] == ':') {
8618 Move(s+2, s+1, end - s - 1, char);
8623 sv_catpvs(sv, ".pm");
8624 SvFLAGS(sv) |= was_readonly;
8628 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8629 /* handle override, if any */
8630 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8631 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8632 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8633 gv = gvp ? *gvp : NULL;
8637 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8639 if (o->op_flags & OPf_KIDS) {
8640 kid = cUNOPo->op_first;
8641 cUNOPo->op_first = NULL;
8649 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8650 op_append_elem(OP_LIST, kid,
8651 scalar(newUNOP(OP_RV2CV, 0,
8654 op_getmad(o,newop,'O');
8658 return scalar(ck_fun(o));
8662 Perl_ck_return(pTHX_ OP *o)
8667 PERL_ARGS_ASSERT_CK_RETURN;
8669 kid = cLISTOPo->op_first->op_sibling;
8670 if (CvLVALUE(PL_compcv)) {
8671 for (; kid; kid = kid->op_sibling)
8672 op_lvalue(kid, OP_LEAVESUBLV);
8679 Perl_ck_select(pTHX_ OP *o)
8684 PERL_ARGS_ASSERT_CK_SELECT;
8686 if (o->op_flags & OPf_KIDS) {
8687 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8688 if (kid && kid->op_sibling) {
8689 o->op_type = OP_SSELECT;
8690 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8692 return fold_constants(op_integerize(op_std_init(o)));
8696 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8697 if (kid && kid->op_type == OP_RV2GV)
8698 kid->op_private &= ~HINT_STRICT_REFS;
8703 Perl_ck_shift(pTHX_ OP *o)
8706 const I32 type = o->op_type;
8708 PERL_ARGS_ASSERT_CK_SHIFT;
8710 if (!(o->op_flags & OPf_KIDS)) {
8713 if (!CvUNIQUE(PL_compcv)) {
8714 o->op_flags |= OPf_SPECIAL;
8718 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8721 OP * const oldo = o;
8722 o = newUNOP(type, 0, scalar(argop));
8723 op_getmad(oldo,o,'O');
8728 return newUNOP(type, 0, scalar(argop));
8731 return scalar(ck_fun(o));
8735 Perl_ck_sort(pTHX_ OP *o)
8740 PERL_ARGS_ASSERT_CK_SORT;
8742 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8743 HV * const hinthv = GvHV(PL_hintgv);
8745 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8747 const I32 sorthints = (I32)SvIV(*svp);
8748 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8749 o->op_private |= OPpSORT_QSORT;
8750 if ((sorthints & HINT_SORT_STABLE) != 0)
8751 o->op_private |= OPpSORT_STABLE;
8756 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8758 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8759 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8761 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8763 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8765 if (kid->op_type == OP_SCOPE) {
8769 else if (kid->op_type == OP_LEAVE) {
8770 if (o->op_type == OP_SORT) {
8771 op_null(kid); /* wipe out leave */
8774 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8775 if (k->op_next == kid)
8777 /* don't descend into loops */
8778 else if (k->op_type == OP_ENTERLOOP
8779 || k->op_type == OP_ENTERITER)
8781 k = cLOOPx(k)->op_lastop;
8786 kid->op_next = 0; /* just disconnect the leave */
8787 k = kLISTOP->op_first;
8792 if (o->op_type == OP_SORT) {
8793 /* provide scalar context for comparison function/block */
8799 o->op_flags |= OPf_SPECIAL;
8801 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8804 firstkid = firstkid->op_sibling;
8807 /* provide list context for arguments */
8808 if (o->op_type == OP_SORT)
8815 S_simplify_sort(pTHX_ OP *o)
8818 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8824 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8826 if (!(o->op_flags & OPf_STACKED))
8828 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8829 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8830 kid = kUNOP->op_first; /* get past null */
8831 if (kid->op_type != OP_SCOPE)
8833 kid = kLISTOP->op_last; /* get past scope */
8834 switch(kid->op_type) {
8842 k = kid; /* remember this node*/
8843 if (kBINOP->op_first->op_type != OP_RV2SV)
8845 kid = kBINOP->op_first; /* get past cmp */
8846 if (kUNOP->op_first->op_type != OP_GV)
8848 kid = kUNOP->op_first; /* get past rv2sv */
8850 if (GvSTASH(gv) != PL_curstash)
8852 gvname = GvNAME(gv);
8853 if (*gvname == 'a' && gvname[1] == '\0')
8855 else if (*gvname == 'b' && gvname[1] == '\0')
8860 kid = k; /* back to cmp */
8861 if (kBINOP->op_last->op_type != OP_RV2SV)
8863 kid = kBINOP->op_last; /* down to 2nd arg */
8864 if (kUNOP->op_first->op_type != OP_GV)
8866 kid = kUNOP->op_first; /* get past rv2sv */
8868 if (GvSTASH(gv) != PL_curstash)
8870 gvname = GvNAME(gv);
8872 ? !(*gvname == 'a' && gvname[1] == '\0')
8873 : !(*gvname == 'b' && gvname[1] == '\0'))
8875 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8877 o->op_private |= OPpSORT_DESCEND;
8878 if (k->op_type == OP_NCMP)
8879 o->op_private |= OPpSORT_NUMERIC;
8880 if (k->op_type == OP_I_NCMP)
8881 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8882 kid = cLISTOPo->op_first->op_sibling;
8883 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8885 op_getmad(kid,o,'S'); /* then delete it */
8887 op_free(kid); /* then delete it */
8892 Perl_ck_split(pTHX_ OP *o)
8897 PERL_ARGS_ASSERT_CK_SPLIT;
8899 if (o->op_flags & OPf_STACKED)
8900 return no_fh_allowed(o);
8902 kid = cLISTOPo->op_first;
8903 if (kid->op_type != OP_NULL)
8904 Perl_croak(aTHX_ "panic: ck_split");
8905 kid = kid->op_sibling;
8906 op_free(cLISTOPo->op_first);
8908 cLISTOPo->op_first = kid;
8910 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8911 cLISTOPo->op_last = kid; /* There was only one element previously */
8914 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8915 OP * const sibl = kid->op_sibling;
8916 kid->op_sibling = 0;
8917 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8918 if (cLISTOPo->op_first == cLISTOPo->op_last)
8919 cLISTOPo->op_last = kid;
8920 cLISTOPo->op_first = kid;
8921 kid->op_sibling = sibl;
8924 kid->op_type = OP_PUSHRE;
8925 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8927 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8928 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8929 "Use of /g modifier is meaningless in split");
8932 if (!kid->op_sibling)
8933 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8935 kid = kid->op_sibling;
8938 if (!kid->op_sibling)
8939 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8940 assert(kid->op_sibling);
8942 kid = kid->op_sibling;
8945 if (kid->op_sibling)
8946 return too_many_arguments(o,OP_DESC(o));
8952 Perl_ck_join(pTHX_ OP *o)
8954 const OP * const kid = cLISTOPo->op_first->op_sibling;
8956 PERL_ARGS_ASSERT_CK_JOIN;
8958 if (kid && kid->op_type == OP_MATCH) {
8959 if (ckWARN(WARN_SYNTAX)) {
8960 const REGEXP *re = PM_GETRE(kPMOP);
8961 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8962 const STRLEN len = re ? RX_PRELEN(re) : 6;
8963 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8964 "/%.*s/ should probably be written as \"%.*s\"",
8965 (int)len, pmstr, (int)len, pmstr);
8972 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8974 Examines an op, which is expected to identify a subroutine at runtime,
8975 and attempts to determine at compile time which subroutine it identifies.
8976 This is normally used during Perl compilation to determine whether
8977 a prototype can be applied to a function call. I<cvop> is the op
8978 being considered, normally an C<rv2cv> op. A pointer to the identified
8979 subroutine is returned, if it could be determined statically, and a null
8980 pointer is returned if it was not possible to determine statically.
8982 Currently, the subroutine can be identified statically if the RV that the
8983 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8984 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8985 suitable if the constant value must be an RV pointing to a CV. Details of
8986 this process may change in future versions of Perl. If the C<rv2cv> op
8987 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8988 the subroutine statically: this flag is used to suppress compile-time
8989 magic on a subroutine call, forcing it to use default runtime behaviour.
8991 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8992 of a GV reference is modified. If a GV was examined and its CV slot was
8993 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8994 If the op is not optimised away, and the CV slot is later populated with
8995 a subroutine having a prototype, that flag eventually triggers the warning
8996 "called too early to check prototype".
8998 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8999 of returning a pointer to the subroutine it returns a pointer to the
9000 GV giving the most appropriate name for the subroutine in this context.
9001 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9002 (C<CvANON>) subroutine that is referenced through a GV it will be the
9003 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
9004 A null pointer is returned as usual if there is no statically-determinable
9011 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9016 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9017 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9018 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9019 if (cvop->op_type != OP_RV2CV)
9021 if (cvop->op_private & OPpENTERSUB_AMPER)
9023 if (!(cvop->op_flags & OPf_KIDS))
9025 rvop = cUNOPx(cvop)->op_first;
9026 switch (rvop->op_type) {
9028 gv = cGVOPx_gv(rvop);
9031 if (flags & RV2CVOPCV_MARK_EARLY)
9032 rvop->op_private |= OPpEARLY_CV;
9037 SV *rv = cSVOPx_sv(rvop);
9047 if (SvTYPE((SV*)cv) != SVt_PVCV)
9049 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9050 if (!CvANON(cv) || !gv)
9059 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9061 Performs the default fixup of the arguments part of an C<entersub>
9062 op tree. This consists of applying list context to each of the
9063 argument ops. This is the standard treatment used on a call marked
9064 with C<&>, or a method call, or a call through a subroutine reference,
9065 or any other call where the callee can't be identified at compile time,
9066 or a call where the callee has no prototype.
9072 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9075 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9076 aop = cUNOPx(entersubop)->op_first;
9077 if (!aop->op_sibling)
9078 aop = cUNOPx(aop)->op_first;
9079 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9080 if (!(PL_madskills && aop->op_type == OP_STUB)) {
9082 op_lvalue(aop, OP_ENTERSUB);
9089 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9091 Performs the fixup of the arguments part of an C<entersub> op tree
9092 based on a subroutine prototype. This makes various modifications to
9093 the argument ops, from applying context up to inserting C<refgen> ops,
9094 and checking the number and syntactic types of arguments, as directed by
9095 the prototype. This is the standard treatment used on a subroutine call,
9096 not marked with C<&>, where the callee can be identified at compile time
9097 and has a prototype.
9099 I<protosv> supplies the subroutine prototype to be applied to the call.
9100 It may be a normal defined scalar, of which the string value will be used.
9101 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9102 that has been cast to C<SV*>) which has a prototype. The prototype
9103 supplied, in whichever form, does not need to match the actual callee
9104 referenced by the op tree.
9106 If the argument ops disagree with the prototype, for example by having
9107 an unacceptable number of arguments, a valid op tree is returned anyway.
9108 The error is reflected in the parser state, normally resulting in a single
9109 exception at the top level of parsing which covers all the compilation
9110 errors that occurred. In the error message, the callee is referred to
9111 by the name defined by the I<namegv> parameter.
9117 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9120 const char *proto, *proto_end;
9121 OP *aop, *prev, *cvop;
9124 I32 contextclass = 0;
9125 const char *e = NULL;
9126 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9127 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9128 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
9129 if (SvTYPE(protosv) == SVt_PVCV)
9130 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9131 else proto = SvPV(protosv, proto_len);
9132 proto_end = proto + proto_len;
9133 aop = cUNOPx(entersubop)->op_first;
9134 if (!aop->op_sibling)
9135 aop = cUNOPx(aop)->op_first;
9137 aop = aop->op_sibling;
9138 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9139 while (aop != cvop) {
9141 if (PL_madskills && aop->op_type == OP_STUB) {
9142 aop = aop->op_sibling;
9145 if (PL_madskills && aop->op_type == OP_NULL)
9146 o3 = ((UNOP*)aop)->op_first;
9150 if (proto >= proto_end)
9151 return too_many_arguments(entersubop, gv_ename(namegv));
9159 /* _ must be at the end */
9160 if (proto[1] && proto[1] != ';')
9175 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9177 arg == 1 ? "block or sub {}" : "sub {}",
9178 gv_ename(namegv), o3);
9181 /* '*' allows any scalar type, including bareword */
9184 if (o3->op_type == OP_RV2GV)
9185 goto wrapref; /* autoconvert GLOB -> GLOBref */
9186 else if (o3->op_type == OP_CONST)
9187 o3->op_private &= ~OPpCONST_STRICT;
9188 else if (o3->op_type == OP_ENTERSUB) {
9189 /* accidental subroutine, revert to bareword */
9190 OP *gvop = ((UNOP*)o3)->op_first;
9191 if (gvop && gvop->op_type == OP_NULL) {
9192 gvop = ((UNOP*)gvop)->op_first;
9194 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9197 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9198 (gvop = ((UNOP*)gvop)->op_first) &&
9199 gvop->op_type == OP_GV)
9201 GV * const gv = cGVOPx_gv(gvop);
9202 OP * const sibling = aop->op_sibling;
9203 SV * const n = newSVpvs("");
9205 OP * const oldaop = aop;
9209 gv_fullname4(n, gv, "", FALSE);
9210 aop = newSVOP(OP_CONST, 0, n);
9211 op_getmad(oldaop,aop,'O');
9212 prev->op_sibling = aop;
9213 aop->op_sibling = sibling;
9223 if (o3->op_type == OP_RV2AV ||
9224 o3->op_type == OP_PADAV ||
9225 o3->op_type == OP_RV2HV ||
9226 o3->op_type == OP_PADHV
9241 if (contextclass++ == 0) {
9242 e = strchr(proto, ']');
9243 if (!e || e == proto)
9252 const char *p = proto;
9253 const char *const end = proto;
9256 /* \[$] accepts any scalar lvalue */
9258 && Perl_op_lvalue_flags(aTHX_
9260 OP_READ, /* not entersub */
9263 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
9265 gv_ename(namegv), o3);
9270 if (o3->op_type == OP_RV2GV)
9273 bad_type(arg, "symbol", gv_ename(namegv), o3);
9276 if (o3->op_type == OP_ENTERSUB)
9279 bad_type(arg, "subroutine entry", gv_ename(namegv),
9283 if (o3->op_type == OP_RV2SV ||
9284 o3->op_type == OP_PADSV ||
9285 o3->op_type == OP_HELEM ||
9286 o3->op_type == OP_AELEM)
9288 if (!contextclass) {
9289 /* \$ accepts any scalar lvalue */
9290 if (Perl_op_lvalue_flags(aTHX_
9292 OP_READ, /* not entersub */
9295 bad_type(arg, "scalar", gv_ename(namegv), o3);
9299 if (o3->op_type == OP_RV2AV ||
9300 o3->op_type == OP_PADAV)
9303 bad_type(arg, "array", gv_ename(namegv), o3);
9306 if (o3->op_type == OP_RV2HV ||
9307 o3->op_type == OP_PADHV)
9310 bad_type(arg, "hash", gv_ename(namegv), o3);
9314 OP* const kid = aop;
9315 OP* const sib = kid->op_sibling;
9316 kid->op_sibling = 0;
9317 aop = newUNOP(OP_REFGEN, 0, kid);
9318 aop->op_sibling = sib;
9319 prev->op_sibling = aop;
9321 if (contextclass && e) {
9336 SV* const tmpsv = sv_newmortal();
9337 gv_efullname3(tmpsv, namegv, NULL);
9338 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9339 SVfARG(tmpsv), SVfARG(protosv));
9343 op_lvalue(aop, OP_ENTERSUB);
9345 aop = aop->op_sibling;
9347 if (aop == cvop && *proto == '_') {
9348 /* generate an access to $_ */
9350 aop->op_sibling = prev->op_sibling;
9351 prev->op_sibling = aop; /* instead of cvop */
9353 if (!optional && proto_end > proto &&
9354 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9355 return too_few_arguments(entersubop, gv_ename(namegv));
9360 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9362 Performs the fixup of the arguments part of an C<entersub> op tree either
9363 based on a subroutine prototype or using default list-context processing.
9364 This is the standard treatment used on a subroutine call, not marked
9365 with C<&>, where the callee can be identified at compile time.
9367 I<protosv> supplies the subroutine prototype to be applied to the call,
9368 or indicates that there is no prototype. It may be a normal scalar,
9369 in which case if it is defined then the string value will be used
9370 as a prototype, and if it is undefined then there is no prototype.
9371 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9372 that has been cast to C<SV*>), of which the prototype will be used if it
9373 has one. The prototype (or lack thereof) supplied, in whichever form,
9374 does not need to match the actual callee referenced by the op tree.
9376 If the argument ops disagree with the prototype, for example by having
9377 an unacceptable number of arguments, a valid op tree is returned anyway.
9378 The error is reflected in the parser state, normally resulting in a single
9379 exception at the top level of parsing which covers all the compilation
9380 errors that occurred. In the error message, the callee is referred to
9381 by the name defined by the I<namegv> parameter.
9387 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9388 GV *namegv, SV *protosv)
9390 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9391 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9392 return ck_entersub_args_proto(entersubop, namegv, protosv);
9394 return ck_entersub_args_list(entersubop);
9398 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9400 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9401 OP *aop = cUNOPx(entersubop)->op_first;
9403 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9407 if (!aop->op_sibling)
9408 aop = cUNOPx(aop)->op_first;
9409 aop = aop->op_sibling;
9410 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9411 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9412 aop = aop->op_sibling;
9416 (void)too_many_arguments(entersubop, GvNAME(namegv));
9418 op_free(entersubop);
9419 switch(GvNAME(namegv)[2]) {
9420 case 'F': return newSVOP(OP_CONST, 0,
9421 newSVpv(CopFILE(PL_curcop),0));
9422 case 'L': return newSVOP(
9425 "%"IVdf, (IV)CopLINE(PL_curcop)
9428 case 'P': return newSVOP(OP_CONST, 0,
9430 ? newSVhek(HvNAME_HEK(PL_curstash))
9441 bool seenarg = FALSE;
9443 if (!aop->op_sibling)
9444 aop = cUNOPx(aop)->op_first;
9447 aop = aop->op_sibling;
9448 prev->op_sibling = NULL;
9451 prev=cvop, cvop = cvop->op_sibling)
9453 if (PL_madskills && cvop->op_sibling
9454 && cvop->op_type != OP_STUB) seenarg = TRUE
9457 prev->op_sibling = NULL;
9458 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9460 if (aop == cvop) aop = NULL;
9461 op_free(entersubop);
9463 if (opnum == OP_ENTEREVAL
9464 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
9465 flags |= OPpEVAL_BYTES <<8;
9467 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9469 case OA_BASEOP_OR_UNOP:
9471 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
9475 if (!PL_madskills || seenarg)
9477 (void)too_many_arguments(aop, GvNAME(namegv));
9480 return opnum == OP_RUNCV
9481 ? newPVOP(OP_RUNCV,0,NULL)
9484 return convert(opnum,0,aop);
9492 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9494 Retrieves the function that will be used to fix up a call to I<cv>.
9495 Specifically, the function is applied to an C<entersub> op tree for a
9496 subroutine call, not marked with C<&>, where the callee can be identified
9497 at compile time as I<cv>.
9499 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9500 argument for it is returned in I<*ckobj_p>. The function is intended
9501 to be called in this manner:
9503 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9505 In this call, I<entersubop> is a pointer to the C<entersub> op,
9506 which may be replaced by the check function, and I<namegv> is a GV
9507 supplying the name that should be used by the check function to refer
9508 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9509 It is permitted to apply the check function in non-standard situations,
9510 such as to a call to a different subroutine or to a method call.
9512 By default, the function is
9513 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9514 and the SV parameter is I<cv> itself. This implements standard
9515 prototype processing. It can be changed, for a particular subroutine,
9516 by L</cv_set_call_checker>.
9522 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9525 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9526 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9528 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9529 *ckobj_p = callmg->mg_obj;
9531 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9537 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9539 Sets the function that will be used to fix up a call to I<cv>.
9540 Specifically, the function is applied to an C<entersub> op tree for a
9541 subroutine call, not marked with C<&>, where the callee can be identified
9542 at compile time as I<cv>.
9544 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9545 for it is supplied in I<ckobj>. The function is intended to be called
9548 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9550 In this call, I<entersubop> is a pointer to the C<entersub> op,
9551 which may be replaced by the check function, and I<namegv> is a GV
9552 supplying the name that should be used by the check function to refer
9553 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9554 It is permitted to apply the check function in non-standard situations,
9555 such as to a call to a different subroutine or to a method call.
9557 The current setting for a particular CV can be retrieved by
9558 L</cv_get_call_checker>.
9564 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9566 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9567 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9568 if (SvMAGICAL((SV*)cv))
9569 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9572 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9573 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9574 if (callmg->mg_flags & MGf_REFCOUNTED) {
9575 SvREFCNT_dec(callmg->mg_obj);
9576 callmg->mg_flags &= ~MGf_REFCOUNTED;
9578 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9579 callmg->mg_obj = ckobj;
9580 if (ckobj != (SV*)cv) {
9581 SvREFCNT_inc_simple_void_NN(ckobj);
9582 callmg->mg_flags |= MGf_REFCOUNTED;
9588 Perl_ck_subr(pTHX_ OP *o)
9594 PERL_ARGS_ASSERT_CK_SUBR;
9596 aop = cUNOPx(o)->op_first;
9597 if (!aop->op_sibling)
9598 aop = cUNOPx(aop)->op_first;
9599 aop = aop->op_sibling;
9600 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9601 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9602 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9604 o->op_private &= ~1;
9605 o->op_private |= OPpENTERSUB_HASTARG;
9606 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9607 if (PERLDB_SUB && PL_curstash != PL_debstash)
9608 o->op_private |= OPpENTERSUB_DB;
9609 if (cvop->op_type == OP_RV2CV) {
9610 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9612 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9613 if (aop->op_type == OP_CONST)
9614 aop->op_private &= ~OPpCONST_STRICT;
9615 else if (aop->op_type == OP_LIST) {
9616 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9617 if (sib && sib->op_type == OP_CONST)
9618 sib->op_private &= ~OPpCONST_STRICT;
9623 return ck_entersub_args_list(o);
9625 Perl_call_checker ckfun;
9627 cv_get_call_checker(cv, &ckfun, &ckobj);
9628 return ckfun(aTHX_ o, namegv, ckobj);
9633 Perl_ck_svconst(pTHX_ OP *o)
9635 PERL_ARGS_ASSERT_CK_SVCONST;
9636 PERL_UNUSED_CONTEXT;
9637 SvREADONLY_on(cSVOPo->op_sv);
9642 Perl_ck_chdir(pTHX_ OP *o)
9644 PERL_ARGS_ASSERT_CK_CHDIR;
9645 if (o->op_flags & OPf_KIDS) {
9646 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9648 if (kid && kid->op_type == OP_CONST &&
9649 (kid->op_private & OPpCONST_BARE))
9651 o->op_flags |= OPf_SPECIAL;
9652 kid->op_private &= ~OPpCONST_STRICT;
9659 Perl_ck_trunc(pTHX_ OP *o)
9661 PERL_ARGS_ASSERT_CK_TRUNC;
9663 if (o->op_flags & OPf_KIDS) {
9664 SVOP *kid = (SVOP*)cUNOPo->op_first;
9666 if (kid->op_type == OP_NULL)
9667 kid = (SVOP*)kid->op_sibling;
9668 if (kid && kid->op_type == OP_CONST &&
9669 (kid->op_private & OPpCONST_BARE))
9671 o->op_flags |= OPf_SPECIAL;
9672 kid->op_private &= ~OPpCONST_STRICT;
9679 Perl_ck_substr(pTHX_ OP *o)
9681 PERL_ARGS_ASSERT_CK_SUBSTR;
9684 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9685 OP *kid = cLISTOPo->op_first;
9687 if (kid->op_type == OP_NULL)
9688 kid = kid->op_sibling;
9690 kid->op_flags |= OPf_MOD;
9697 Perl_ck_tell(pTHX_ OP *o)
9699 PERL_ARGS_ASSERT_CK_TELL;
9701 if (o->op_flags & OPf_KIDS) {
9702 OP *kid = cLISTOPo->op_first;
9703 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
9704 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9710 Perl_ck_each(pTHX_ OP *o)
9713 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9714 const unsigned orig_type = o->op_type;
9715 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9716 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9717 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9718 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9720 PERL_ARGS_ASSERT_CK_EACH;
9723 switch (kid->op_type) {
9729 CHANGE_TYPE(o, array_type);
9732 if (kid->op_private == OPpCONST_BARE
9733 || !SvROK(cSVOPx_sv(kid))
9734 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9735 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9737 /* we let ck_fun handle it */
9740 CHANGE_TYPE(o, ref_type);
9744 /* if treating as a reference, defer additional checks to runtime */
9745 return o->op_type == ref_type ? o : ck_fun(o);
9749 Perl_ck_length(pTHX_ OP *o)
9751 PERL_ARGS_ASSERT_CK_LENGTH;
9755 if (ckWARN(WARN_SYNTAX)) {
9756 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9760 const bool hash = kid->op_type == OP_PADHV
9761 || kid->op_type == OP_RV2HV;
9762 switch (kid->op_type) {
9766 NULL, hash ? '%' : '@', kid->op_targ, NULL, 0, 1
9771 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
9773 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
9775 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
9782 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9783 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
9785 name, hash ? "keys " : "", name
9788 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9789 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
9791 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9792 "length() used on @array (did you mean \"scalar(@array)\"?)");
9799 /* caller is supposed to assign the return to the
9800 container of the rep_op var */
9802 S_opt_scalarhv(pTHX_ OP *rep_op) {
9806 PERL_ARGS_ASSERT_OPT_SCALARHV;
9808 NewOp(1101, unop, 1, UNOP);
9809 unop->op_type = (OPCODE)OP_BOOLKEYS;
9810 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9811 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9812 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9813 unop->op_first = rep_op;
9814 unop->op_next = rep_op->op_next;
9815 rep_op->op_next = (OP*)unop;
9816 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9817 unop->op_sibling = rep_op->op_sibling;
9818 rep_op->op_sibling = NULL;
9819 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9820 if (rep_op->op_type == OP_PADHV) {
9821 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9822 rep_op->op_flags |= OPf_WANT_LIST;
9827 /* Check for in place reverse and sort assignments like "@a = reverse @a"
9828 and modify the optree to make them work inplace */
9831 S_inplace_aassign(pTHX_ OP *o) {
9833 OP *modop, *modop_pushmark;
9835 OP *oleft, *oleft_pushmark;
9837 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
9839 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
9841 assert(cUNOPo->op_first->op_type == OP_NULL);
9842 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
9843 assert(modop_pushmark->op_type == OP_PUSHMARK);
9844 modop = modop_pushmark->op_sibling;
9846 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
9849 /* no other operation except sort/reverse */
9850 if (modop->op_sibling)
9853 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
9854 oright = cUNOPx(modop)->op_first->op_sibling;
9856 if (modop->op_flags & OPf_STACKED) {
9857 /* skip sort subroutine/block */
9858 assert(oright->op_type == OP_NULL);
9859 oright = oright->op_sibling;
9862 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
9863 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
9864 assert(oleft_pushmark->op_type == OP_PUSHMARK);
9865 oleft = oleft_pushmark->op_sibling;
9867 /* Check the lhs is an array */
9869 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
9870 || oleft->op_sibling
9871 || (oleft->op_private & OPpLVAL_INTRO)
9875 /* Only one thing on the rhs */
9876 if (oright->op_sibling)
9879 /* check the array is the same on both sides */
9880 if (oleft->op_type == OP_RV2AV) {
9881 if (oright->op_type != OP_RV2AV
9882 || !cUNOPx(oright)->op_first
9883 || cUNOPx(oright)->op_first->op_type != OP_GV
9884 || cUNOPx(oleft )->op_first->op_type != OP_GV
9885 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9886 cGVOPx_gv(cUNOPx(oright)->op_first)
9890 else if (oright->op_type != OP_PADAV
9891 || oright->op_targ != oleft->op_targ
9895 /* This actually is an inplace assignment */
9897 modop->op_private |= OPpSORT_INPLACE;
9899 /* transfer MODishness etc from LHS arg to RHS arg */
9900 oright->op_flags = oleft->op_flags;
9902 /* remove the aassign op and the lhs */
9904 op_null(oleft_pushmark);
9905 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
9906 op_null(cUNOPx(oleft)->op_first);
9910 #define MAX_DEFERRED 4
9913 if (defer_ix == (MAX_DEFERRED-1)) { \
9914 CALL_RPEEP(defer_queue[defer_base]); \
9915 defer_base = (defer_base + 1) % MAX_DEFERRED; \
9918 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
9920 /* A peephole optimizer. We visit the ops in the order they're to execute.
9921 * See the comments at the top of this file for more details about when
9922 * peep() is called */
9925 Perl_rpeep(pTHX_ register OP *o)
9928 register OP* oldop = NULL;
9929 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
9933 if (!o || o->op_opt)
9937 SAVEVPTR(PL_curcop);
9938 for (;; o = o->op_next) {
9942 while (defer_ix >= 0)
9943 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
9947 /* By default, this op has now been optimised. A couple of cases below
9948 clear this again. */
9951 switch (o->op_type) {
9953 PL_curcop = ((COP*)o); /* for warnings */
9956 PL_curcop = ((COP*)o); /* for warnings */
9958 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9959 to carry two labels. For now, take the easier option, and skip
9960 this optimisation if the first NEXTSTATE has a label. */
9961 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9962 OP *nextop = o->op_next;
9963 while (nextop && nextop->op_type == OP_NULL)
9964 nextop = nextop->op_next;
9966 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9967 COP *firstcop = (COP *)o;
9968 COP *secondcop = (COP *)nextop;
9969 /* We want the COP pointed to by o (and anything else) to
9970 become the next COP down the line. */
9973 firstcop->op_next = secondcop->op_next;
9975 /* Now steal all its pointers, and duplicate the other
9977 firstcop->cop_line = secondcop->cop_line;
9979 firstcop->cop_stashpv = secondcop->cop_stashpv;
9980 firstcop->cop_file = secondcop->cop_file;
9982 firstcop->cop_stash = secondcop->cop_stash;
9983 firstcop->cop_filegv = secondcop->cop_filegv;
9985 firstcop->cop_hints = secondcop->cop_hints;
9986 firstcop->cop_seq = secondcop->cop_seq;
9987 firstcop->cop_warnings = secondcop->cop_warnings;
9988 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9991 secondcop->cop_stashpv = NULL;
9992 secondcop->cop_file = NULL;
9994 secondcop->cop_stash = NULL;
9995 secondcop->cop_filegv = NULL;
9997 secondcop->cop_warnings = NULL;
9998 secondcop->cop_hints_hash = NULL;
10000 /* If we use op_null(), and hence leave an ex-COP, some
10001 warnings are misreported. For example, the compile-time
10002 error in 'use strict; no strict refs;' */
10003 secondcop->op_type = OP_NULL;
10004 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10010 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10011 if (o->op_next->op_private & OPpTARGET_MY) {
10012 if (o->op_flags & OPf_STACKED) /* chained concats */
10013 break; /* ignore_optimization */
10015 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10016 o->op_targ = o->op_next->op_targ;
10017 o->op_next->op_targ = 0;
10018 o->op_private |= OPpTARGET_MY;
10021 op_null(o->op_next);
10025 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10026 break; /* Scalar stub must produce undef. List stub is noop */
10030 if (o->op_targ == OP_NEXTSTATE
10031 || o->op_targ == OP_DBSTATE)
10033 PL_curcop = ((COP*)o);
10035 /* XXX: We avoid setting op_seq here to prevent later calls
10036 to rpeep() from mistakenly concluding that optimisation
10037 has already occurred. This doesn't fix the real problem,
10038 though (See 20010220.007). AMS 20010719 */
10039 /* op_seq functionality is now replaced by op_opt */
10046 if (oldop && o->op_next) {
10047 oldop->op_next = o->op_next;
10055 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
10056 OP* const pop = (o->op_type == OP_PADAV) ?
10057 o->op_next : o->op_next->op_next;
10059 if (pop && pop->op_type == OP_CONST &&
10060 ((PL_op = pop->op_next)) &&
10061 pop->op_next->op_type == OP_AELEM &&
10062 !(pop->op_next->op_private &
10063 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
10064 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
10067 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
10068 no_bareword_allowed(pop);
10069 if (o->op_type == OP_GV)
10070 op_null(o->op_next);
10071 op_null(pop->op_next);
10073 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
10074 o->op_next = pop->op_next->op_next;
10075 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
10076 o->op_private = (U8)i;
10077 if (o->op_type == OP_GV) {
10080 o->op_type = OP_AELEMFAST;
10083 o->op_type = OP_AELEMFAST_LEX;
10088 if (o->op_next->op_type == OP_RV2SV) {
10089 if (!(o->op_next->op_private & OPpDEREF)) {
10090 op_null(o->op_next);
10091 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
10093 o->op_next = o->op_next->op_next;
10094 o->op_type = OP_GVSV;
10095 o->op_ppaddr = PL_ppaddr[OP_GVSV];
10098 else if (o->op_next->op_type == OP_READLINE
10099 && o->op_next->op_next->op_type == OP_CONCAT
10100 && (o->op_next->op_next->op_flags & OPf_STACKED))
10102 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
10103 o->op_type = OP_RCATLINE;
10104 o->op_flags |= OPf_STACKED;
10105 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
10106 op_null(o->op_next->op_next);
10107 op_null(o->op_next);
10117 fop = cUNOP->op_first;
10125 fop = cLOGOP->op_first;
10126 sop = fop->op_sibling;
10127 while (cLOGOP->op_other->op_type == OP_NULL)
10128 cLOGOP->op_other = cLOGOP->op_other->op_next;
10129 while (o->op_next && ( o->op_type == o->op_next->op_type
10130 || o->op_next->op_type == OP_NULL))
10131 o->op_next = o->op_next->op_next;
10132 DEFER(cLOGOP->op_other);
10136 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10138 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
10143 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
10144 while (nop && nop->op_next) {
10145 switch (nop->op_next->op_type) {
10150 lop = nop = nop->op_next;
10153 nop = nop->op_next;
10161 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
10162 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10163 cLOGOP->op_first = opt_scalarhv(fop);
10164 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
10165 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
10181 while (cLOGOP->op_other->op_type == OP_NULL)
10182 cLOGOP->op_other = cLOGOP->op_other->op_next;
10183 DEFER(cLOGOP->op_other);
10188 while (cLOOP->op_redoop->op_type == OP_NULL)
10189 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
10190 while (cLOOP->op_nextop->op_type == OP_NULL)
10191 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
10192 while (cLOOP->op_lastop->op_type == OP_NULL)
10193 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
10194 /* a while(1) loop doesn't have an op_next that escapes the
10195 * loop, so we have to explicitly follow the op_lastop to
10196 * process the rest of the code */
10197 DEFER(cLOOP->op_lastop);
10201 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10202 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10203 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10204 cPMOP->op_pmstashstartu.op_pmreplstart
10205 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
10206 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
10210 /* check that RHS of sort is a single plain array */
10211 OP *oright = cUNOPo->op_first;
10212 if (!oright || oright->op_type != OP_PUSHMARK)
10215 if (o->op_private & OPpSORT_INPLACE)
10218 /* reverse sort ... can be optimised. */
10219 if (!cUNOPo->op_sibling) {
10220 /* Nothing follows us on the list. */
10221 OP * const reverse = o->op_next;
10223 if (reverse->op_type == OP_REVERSE &&
10224 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10225 OP * const pushmark = cUNOPx(reverse)->op_first;
10226 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10227 && (cUNOPx(pushmark)->op_sibling == o)) {
10228 /* reverse -> pushmark -> sort */
10229 o->op_private |= OPpSORT_REVERSE;
10231 pushmark->op_next = oright->op_next;
10241 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10243 LISTOP *enter, *exlist;
10245 if (o->op_private & OPpSORT_INPLACE)
10248 enter = (LISTOP *) o->op_next;
10251 if (enter->op_type == OP_NULL) {
10252 enter = (LISTOP *) enter->op_next;
10256 /* for $a (...) will have OP_GV then OP_RV2GV here.
10257 for (...) just has an OP_GV. */
10258 if (enter->op_type == OP_GV) {
10259 gvop = (OP *) enter;
10260 enter = (LISTOP *) enter->op_next;
10263 if (enter->op_type == OP_RV2GV) {
10264 enter = (LISTOP *) enter->op_next;
10270 if (enter->op_type != OP_ENTERITER)
10273 iter = enter->op_next;
10274 if (!iter || iter->op_type != OP_ITER)
10277 expushmark = enter->op_first;
10278 if (!expushmark || expushmark->op_type != OP_NULL
10279 || expushmark->op_targ != OP_PUSHMARK)
10282 exlist = (LISTOP *) expushmark->op_sibling;
10283 if (!exlist || exlist->op_type != OP_NULL
10284 || exlist->op_targ != OP_LIST)
10287 if (exlist->op_last != o) {
10288 /* Mmm. Was expecting to point back to this op. */
10291 theirmark = exlist->op_first;
10292 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10295 if (theirmark->op_sibling != o) {
10296 /* There's something between the mark and the reverse, eg
10297 for (1, reverse (...))
10302 ourmark = ((LISTOP *)o)->op_first;
10303 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10306 ourlast = ((LISTOP *)o)->op_last;
10307 if (!ourlast || ourlast->op_next != o)
10310 rv2av = ourmark->op_sibling;
10311 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10312 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10313 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10314 /* We're just reversing a single array. */
10315 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10316 enter->op_flags |= OPf_STACKED;
10319 /* We don't have control over who points to theirmark, so sacrifice
10321 theirmark->op_next = ourmark->op_next;
10322 theirmark->op_flags = ourmark->op_flags;
10323 ourlast->op_next = gvop ? gvop : (OP *) enter;
10326 enter->op_private |= OPpITER_REVERSED;
10327 iter->op_private |= OPpITER_REVERSED;
10334 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10335 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10340 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
10342 if (CvUNIQUE(PL_compcv)) sv = &PL_sv_undef;
10344 sv = newRV((SV *)PL_compcv);
10348 o->op_type = OP_CONST;
10349 o->op_ppaddr = PL_ppaddr[OP_CONST];
10350 o->op_flags |= OPf_SPECIAL;
10351 cSVOPo->op_sv = sv;
10356 if (OP_GIMME(o,0) == G_VOID) {
10357 OP *right = cBINOP->op_first;
10359 OP *left = right->op_sibling;
10360 if (left->op_type == OP_SUBSTR
10361 && (left->op_private & 7) < 4) {
10363 cBINOP->op_first = left;
10364 right->op_sibling =
10365 cBINOPx(left)->op_first->op_sibling;
10366 cBINOPx(left)->op_first->op_sibling = right;
10367 left->op_private |= OPpSUBSTR_REPL_FIRST;
10369 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10376 Perl_cpeep_t cpeep =
10377 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10379 cpeep(aTHX_ o, oldop);
10390 Perl_peep(pTHX_ register OP *o)
10396 =head1 Custom Operators
10398 =for apidoc Ao||custom_op_xop
10399 Return the XOP structure for a given custom op. This function should be
10400 considered internal to OP_NAME and the other access macros: use them instead.
10406 Perl_custom_op_xop(pTHX_ const OP *o)
10412 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10414 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10415 assert(o->op_type == OP_CUSTOM);
10417 /* This is wrong. It assumes a function pointer can be cast to IV,
10418 * which isn't guaranteed, but this is what the old custom OP code
10419 * did. In principle it should be safer to Copy the bytes of the
10420 * pointer into a PV: since the new interface is hidden behind
10421 * functions, this can be changed later if necessary. */
10422 /* Change custom_op_xop if this ever happens */
10423 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10426 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10428 /* assume noone will have just registered a desc */
10429 if (!he && PL_custom_op_names &&
10430 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10435 /* XXX does all this need to be shared mem? */
10436 Newxz(xop, 1, XOP);
10437 pv = SvPV(HeVAL(he), l);
10438 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10439 if (PL_custom_op_descs &&
10440 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10442 pv = SvPV(HeVAL(he), l);
10443 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10445 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10449 if (!he) return &xop_null;
10451 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10456 =for apidoc Ao||custom_op_register
10457 Register a custom op. See L<perlguts/"Custom Operators">.
10463 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10467 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10469 /* see the comment in custom_op_xop */
10470 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10472 if (!PL_custom_ops)
10473 PL_custom_ops = newHV();
10475 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10476 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10480 =head1 Functions in file op.c
10482 =for apidoc core_prototype
10483 This function assigns the prototype of the named core function to C<sv>, or
10484 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10485 NULL if the core function has no prototype. C<code> is a code as returned
10486 by C<keyword()>. It must be negative and unequal to -KEY_CORE.
10492 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10495 int i = 0, n = 0, seen_question = 0, defgv = 0;
10497 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10498 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10499 bool nullret = FALSE;
10501 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10503 assert (code < 0 && code != -KEY_CORE);
10505 if (!sv) sv = sv_newmortal();
10507 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10510 case KEY_and : case KEY_chop: case KEY_chomp:
10511 case KEY_cmp : case KEY_exec: case KEY_eq :
10512 case KEY_ge : case KEY_gt : case KEY_le :
10513 case KEY_lt : case KEY_ne : case KEY_or :
10514 case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
10515 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10516 case KEY_keys: retsetpvs("+", OP_KEYS);
10517 case KEY_values: retsetpvs("+", OP_VALUES);
10518 case KEY_each: retsetpvs("+", OP_EACH);
10519 case KEY_push: retsetpvs("+@", OP_PUSH);
10520 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10521 case KEY_pop: retsetpvs(";+", OP_POP);
10522 case KEY_shift: retsetpvs(";+", OP_SHIFT);
10524 retsetpvs("+;$$@", OP_SPLICE);
10525 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10527 case KEY_evalbytes:
10528 name = "entereval"; break;
10536 while (i < MAXO) { /* The slow way. */
10537 if (strEQ(name, PL_op_name[i])
10538 || strEQ(name, PL_op_desc[i]))
10540 if (nullret) { assert(opnum); *opnum = i; return NULL; }
10545 assert(0); return NULL; /* Should not happen... */
10547 defgv = PL_opargs[i] & OA_DEFGV;
10548 oa = PL_opargs[i] >> OASHIFT;
10550 if (oa & OA_OPTIONAL && !seen_question && (
10551 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
10556 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10557 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10558 /* But globs are already references (kinda) */
10559 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10563 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10564 && !scalar_mod_type(NULL, i)) {
10569 if (i == OP_LOCK) str[n++] = '&';
10573 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10574 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10575 str[n-1] = '_'; defgv = 0;
10579 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
10581 sv_setpvn(sv, str, n - 1);
10582 if (opnum) *opnum = i;
10587 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
10590 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
10593 PERL_ARGS_ASSERT_CORESUB_OP;
10597 return op_append_elem(OP_LINESEQ,
10600 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
10604 case OP_SELECT: /* which represents OP_SSELECT as well */
10609 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
10610 newSVOP(OP_CONST, 0, newSVuv(1))
10612 coresub_op(newSVuv((UV)OP_SSELECT), 0,
10614 coresub_op(coreargssv, 0, OP_SELECT)
10618 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10620 return op_append_elem(
10623 opnum == OP_WANTARRAY || opnum == OP_RUNCV
10624 ? OPpOFFBYONE << 8 : 0)
10626 case OA_BASEOP_OR_UNOP:
10627 if (opnum == OP_ENTEREVAL) {
10628 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
10629 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
10631 else o = newUNOP(opnum,0,argop);
10632 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
10635 if (is_handle_constructor(o, 1))
10636 argop->op_private |= OPpCOREARGS_DEREF1;
10640 o = convert(opnum,0,argop);
10641 if (is_handle_constructor(o, 2))
10642 argop->op_private |= OPpCOREARGS_DEREF2;
10643 if (scalar_mod_type(NULL, opnum))
10644 argop->op_private |= OPpCOREARGS_SCALARMOD;
10645 if (opnum == OP_SUBSTR) {
10646 o->op_private |= OPpMAYBE_LVSUB;
10655 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
10656 SV * const *new_const_svp)
10658 const char *hvname;
10659 bool is_const = !!CvCONST(old_cv);
10660 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
10662 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
10664 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
10666 /* They are 2 constant subroutines generated from
10667 the same constant. This probably means that
10668 they are really the "same" proxy subroutine
10669 instantiated in 2 places. Most likely this is
10670 when a constant is exported twice. Don't warn.
10673 (ckWARN(WARN_REDEFINE)
10675 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
10676 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
10677 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
10678 strEQ(hvname, "autouse"))
10682 && ckWARN_d(WARN_REDEFINE)
10683 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
10686 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10688 ? "Constant subroutine %"SVf" redefined"
10689 : "Subroutine %"SVf" redefined",
10695 /* Efficient sub that returns a constant scalar value. */
10697 const_sv_xsub(pTHX_ CV* cv)
10701 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10705 /* diag_listed_as: SKIPME */
10706 Perl_croak(aTHX_ "usage: %s::%s()",
10707 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10720 * c-indentation-style: bsd
10721 * c-basic-offset: 4
10722 * indent-tabs-mode: t
10725 * ex: set ts=8 sts=4 sw=4 noet: