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) {
2005 op_lvalue(cBINOPo->op_first, type);
2011 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2012 /* elements might be in void context because the list is
2013 in scalar context or because they are attribute sub calls */
2014 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2015 op_lvalue(kid, type);
2019 if (type != OP_LEAVESUBLV)
2021 break; /* op_lvalue()ing was handled by ck_return() */
2024 /* [20011101.069] File test operators interpret OPf_REF to mean that
2025 their argument is a filehandle; thus \stat(".") should not set
2027 if (type == OP_REFGEN &&
2028 PL_check[o->op_type] == Perl_ck_ftst)
2031 if (type != OP_LEAVESUBLV)
2032 o->op_flags |= OPf_MOD;
2034 if (type == OP_AASSIGN || type == OP_SASSIGN)
2035 o->op_flags |= OPf_SPECIAL|OPf_REF;
2036 else if (!type) { /* local() */
2039 o->op_private |= OPpLVAL_INTRO;
2040 o->op_flags &= ~OPf_SPECIAL;
2041 PL_hints |= HINT_BLOCK_SCOPE;
2046 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2047 "Useless localization of %s", OP_DESC(o));
2050 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2051 && type != OP_LEAVESUBLV)
2052 o->op_flags |= OPf_REF;
2057 S_scalar_mod_type(const OP *o, I32 type)
2059 assert(o || type != OP_SASSIGN);
2063 if (o->op_type == OP_RV2GV)
2087 case OP_RIGHT_SHIFT:
2108 S_is_handle_constructor(const OP *o, I32 numargs)
2110 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2112 switch (o->op_type) {
2120 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2133 S_refkids(pTHX_ OP *o, I32 type)
2135 if (o && o->op_flags & OPf_KIDS) {
2137 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2144 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2149 PERL_ARGS_ASSERT_DOREF;
2151 if (!o || (PL_parser && PL_parser->error_count))
2154 switch (o->op_type) {
2156 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2157 !(o->op_flags & OPf_STACKED)) {
2158 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2159 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2160 assert(cUNOPo->op_first->op_type == OP_NULL);
2161 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2162 o->op_flags |= OPf_SPECIAL;
2163 o->op_private &= ~1;
2165 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2166 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2167 : type == OP_RV2HV ? OPpDEREF_HV
2169 o->op_flags |= OPf_MOD;
2175 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2176 doref(kid, type, set_op_ref);
2179 if (type == OP_DEFINED)
2180 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2181 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2184 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2185 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2186 : type == OP_RV2HV ? OPpDEREF_HV
2188 o->op_flags |= OPf_MOD;
2195 o->op_flags |= OPf_REF;
2198 if (type == OP_DEFINED)
2199 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2200 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2206 o->op_flags |= OPf_REF;
2211 if (!(o->op_flags & OPf_KIDS))
2213 doref(cBINOPo->op_first, type, set_op_ref);
2217 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2218 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2219 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2220 : type == OP_RV2HV ? OPpDEREF_HV
2222 o->op_flags |= OPf_MOD;
2232 if (!(o->op_flags & OPf_KIDS))
2234 doref(cLISTOPo->op_last, type, set_op_ref);
2244 S_dup_attrlist(pTHX_ OP *o)
2249 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2251 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2252 * where the first kid is OP_PUSHMARK and the remaining ones
2253 * are OP_CONST. We need to push the OP_CONST values.
2255 if (o->op_type == OP_CONST)
2256 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2258 else if (o->op_type == OP_NULL)
2262 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2264 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2265 if (o->op_type == OP_CONST)
2266 rop = op_append_elem(OP_LIST, rop,
2267 newSVOP(OP_CONST, o->op_flags,
2268 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2275 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2280 PERL_ARGS_ASSERT_APPLY_ATTRS;
2282 /* fake up C<use attributes $pkg,$rv,@attrs> */
2283 ENTER; /* need to protect against side-effects of 'use' */
2284 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2286 #define ATTRSMODULE "attributes"
2287 #define ATTRSMODULE_PM "attributes.pm"
2290 /* Don't force the C<use> if we don't need it. */
2291 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2292 if (svp && *svp != &PL_sv_undef)
2293 NOOP; /* already in %INC */
2295 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2296 newSVpvs(ATTRSMODULE), NULL);
2299 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2300 newSVpvs(ATTRSMODULE),
2302 op_prepend_elem(OP_LIST,
2303 newSVOP(OP_CONST, 0, stashsv),
2304 op_prepend_elem(OP_LIST,
2305 newSVOP(OP_CONST, 0,
2307 dup_attrlist(attrs))));
2313 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2316 OP *pack, *imop, *arg;
2319 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2324 assert(target->op_type == OP_PADSV ||
2325 target->op_type == OP_PADHV ||
2326 target->op_type == OP_PADAV);
2328 /* Ensure that attributes.pm is loaded. */
2329 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2331 /* Need package name for method call. */
2332 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2334 /* Build up the real arg-list. */
2335 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2337 arg = newOP(OP_PADSV, 0);
2338 arg->op_targ = target->op_targ;
2339 arg = op_prepend_elem(OP_LIST,
2340 newSVOP(OP_CONST, 0, stashsv),
2341 op_prepend_elem(OP_LIST,
2342 newUNOP(OP_REFGEN, 0,
2343 op_lvalue(arg, OP_REFGEN)),
2344 dup_attrlist(attrs)));
2346 /* Fake up a method call to import */
2347 meth = newSVpvs_share("import");
2348 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2349 op_append_elem(OP_LIST,
2350 op_prepend_elem(OP_LIST, pack, list(arg)),
2351 newSVOP(OP_METHOD_NAMED, 0, meth)));
2353 /* Combine the ops. */
2354 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2358 =notfor apidoc apply_attrs_string
2360 Attempts to apply a list of attributes specified by the C<attrstr> and
2361 C<len> arguments to the subroutine identified by the C<cv> argument which
2362 is expected to be associated with the package identified by the C<stashpv>
2363 argument (see L<attributes>). It gets this wrong, though, in that it
2364 does not correctly identify the boundaries of the individual attribute
2365 specifications within C<attrstr>. This is not really intended for the
2366 public API, but has to be listed here for systems such as AIX which
2367 need an explicit export list for symbols. (It's called from XS code
2368 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2369 to respect attribute syntax properly would be welcome.
2375 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2376 const char *attrstr, STRLEN len)
2380 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2383 len = strlen(attrstr);
2387 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2389 const char * const sstr = attrstr;
2390 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2391 attrs = op_append_elem(OP_LIST, attrs,
2392 newSVOP(OP_CONST, 0,
2393 newSVpvn(sstr, attrstr-sstr)));
2397 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2398 newSVpvs(ATTRSMODULE),
2399 NULL, op_prepend_elem(OP_LIST,
2400 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2401 op_prepend_elem(OP_LIST,
2402 newSVOP(OP_CONST, 0,
2403 newRV(MUTABLE_SV(cv))),
2408 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2412 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2414 PERL_ARGS_ASSERT_MY_KID;
2416 if (!o || (PL_parser && PL_parser->error_count))
2420 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2421 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2425 if (type == OP_LIST) {
2427 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2428 my_kid(kid, attrs, imopsp);
2429 } else if (type == OP_UNDEF
2435 } else if (type == OP_RV2SV || /* "our" declaration */
2437 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2438 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2439 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2441 PL_parser->in_my == KEY_our
2443 : PL_parser->in_my == KEY_state ? "state" : "my"));
2445 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2446 PL_parser->in_my = FALSE;
2447 PL_parser->in_my_stash = NULL;
2448 apply_attrs(GvSTASH(gv),
2449 (type == OP_RV2SV ? GvSV(gv) :
2450 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2451 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2454 o->op_private |= OPpOUR_INTRO;
2457 else if (type != OP_PADSV &&
2460 type != OP_PUSHMARK)
2462 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2464 PL_parser->in_my == KEY_our
2466 : PL_parser->in_my == KEY_state ? "state" : "my"));
2469 else if (attrs && type != OP_PUSHMARK) {
2472 PL_parser->in_my = FALSE;
2473 PL_parser->in_my_stash = NULL;
2475 /* check for C<my Dog $spot> when deciding package */
2476 stash = PAD_COMPNAME_TYPE(o->op_targ);
2478 stash = PL_curstash;
2479 apply_attrs_my(stash, o, attrs, imopsp);
2481 o->op_flags |= OPf_MOD;
2482 o->op_private |= OPpLVAL_INTRO;
2484 o->op_private |= OPpPAD_STATE;
2489 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2493 int maybe_scalar = 0;
2495 PERL_ARGS_ASSERT_MY_ATTRS;
2497 /* [perl #17376]: this appears to be premature, and results in code such as
2498 C< our(%x); > executing in list mode rather than void mode */
2500 if (o->op_flags & OPf_PARENS)
2510 o = my_kid(o, attrs, &rops);
2512 if (maybe_scalar && o->op_type == OP_PADSV) {
2513 o = scalar(op_append_list(OP_LIST, rops, o));
2514 o->op_private |= OPpLVAL_INTRO;
2517 /* The listop in rops might have a pushmark at the beginning,
2518 which will mess up list assignment. */
2519 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2520 if (rops->op_type == OP_LIST &&
2521 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2523 OP * const pushmark = lrops->op_first;
2524 lrops->op_first = pushmark->op_sibling;
2527 o = op_append_list(OP_LIST, o, rops);
2530 PL_parser->in_my = FALSE;
2531 PL_parser->in_my_stash = NULL;
2536 Perl_sawparens(pTHX_ OP *o)
2538 PERL_UNUSED_CONTEXT;
2540 o->op_flags |= OPf_PARENS;
2545 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2549 const OPCODE ltype = left->op_type;
2550 const OPCODE rtype = right->op_type;
2552 PERL_ARGS_ASSERT_BIND_MATCH;
2554 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2555 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2557 const char * const desc
2559 rtype == OP_SUBST || rtype == OP_TRANS
2560 || rtype == OP_TRANSR
2562 ? (int)rtype : OP_MATCH];
2563 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2566 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2567 ? cUNOPx(left)->op_first->op_type == OP_GV
2568 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2569 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2571 : varname(NULL, isary ? '@' : '%', left->op_targ, NULL, 0, 1);
2573 Perl_warner(aTHX_ packWARN(WARN_MISC),
2574 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2577 const char * const sample = (isary
2578 ? "@array" : "%hash");
2579 Perl_warner(aTHX_ packWARN(WARN_MISC),
2580 "Applying %s to %s will act on scalar(%s)",
2581 desc, sample, sample);
2585 if (rtype == OP_CONST &&
2586 cSVOPx(right)->op_private & OPpCONST_BARE &&
2587 cSVOPx(right)->op_private & OPpCONST_STRICT)
2589 no_bareword_allowed(right);
2592 /* !~ doesn't make sense with /r, so error on it for now */
2593 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2595 yyerror("Using !~ with s///r doesn't make sense");
2596 if (rtype == OP_TRANSR && type == OP_NOT)
2597 yyerror("Using !~ with tr///r doesn't make sense");
2599 ismatchop = (rtype == OP_MATCH ||
2600 rtype == OP_SUBST ||
2601 rtype == OP_TRANS || rtype == OP_TRANSR)
2602 && !(right->op_flags & OPf_SPECIAL);
2603 if (ismatchop && right->op_private & OPpTARGET_MY) {
2605 right->op_private &= ~OPpTARGET_MY;
2607 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2610 right->op_flags |= OPf_STACKED;
2611 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2612 ! (rtype == OP_TRANS &&
2613 right->op_private & OPpTRANS_IDENTICAL) &&
2614 ! (rtype == OP_SUBST &&
2615 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2616 newleft = op_lvalue(left, rtype);
2619 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2620 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2622 o = op_prepend_elem(rtype, scalar(newleft), right);
2624 return newUNOP(OP_NOT, 0, scalar(o));
2628 return bind_match(type, left,
2629 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2633 Perl_invert(pTHX_ OP *o)
2637 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2641 =for apidoc Amx|OP *|op_scope|OP *o
2643 Wraps up an op tree with some additional ops so that at runtime a dynamic
2644 scope will be created. The original ops run in the new dynamic scope,
2645 and then, provided that they exit normally, the scope will be unwound.
2646 The additional ops used to create and unwind the dynamic scope will
2647 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2648 instead if the ops are simple enough to not need the full dynamic scope
2655 Perl_op_scope(pTHX_ OP *o)
2659 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2660 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2661 o->op_type = OP_LEAVE;
2662 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2664 else if (o->op_type == OP_LINESEQ) {
2666 o->op_type = OP_SCOPE;
2667 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2668 kid = ((LISTOP*)o)->op_first;
2669 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2672 /* The following deals with things like 'do {1 for 1}' */
2673 kid = kid->op_sibling;
2675 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2680 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2686 Perl_block_start(pTHX_ int full)
2689 const int retval = PL_savestack_ix;
2691 pad_block_start(full);
2693 PL_hints &= ~HINT_BLOCK_SCOPE;
2694 SAVECOMPILEWARNINGS();
2695 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2697 CALL_BLOCK_HOOKS(bhk_start, full);
2703 Perl_block_end(pTHX_ I32 floor, OP *seq)
2706 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2707 OP* retval = scalarseq(seq);
2709 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2712 CopHINTS_set(&PL_compiling, PL_hints);
2714 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2717 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2723 =head1 Compile-time scope hooks
2725 =for apidoc Aox||blockhook_register
2727 Register a set of hooks to be called when the Perl lexical scope changes
2728 at compile time. See L<perlguts/"Compile-time scope hooks">.
2734 Perl_blockhook_register(pTHX_ BHK *hk)
2736 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2738 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2745 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2746 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2747 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2750 OP * const o = newOP(OP_PADSV, 0);
2751 o->op_targ = offset;
2757 Perl_newPROG(pTHX_ OP *o)
2761 PERL_ARGS_ASSERT_NEWPROG;
2767 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2768 ((PL_in_eval & EVAL_KEEPERR)
2769 ? OPf_SPECIAL : 0), o);
2771 cx = &cxstack[cxstack_ix];
2772 assert(CxTYPE(cx) == CXt_EVAL);
2774 if ((cx->blk_gimme & G_WANT) == G_VOID)
2775 scalarvoid(PL_eval_root);
2776 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2779 scalar(PL_eval_root);
2781 /* don't use LINKLIST, since PL_eval_root might indirect through
2782 * a rather expensive function call and LINKLIST evaluates its
2783 * argument more than once */
2784 PL_eval_start = op_linklist(PL_eval_root);
2785 PL_eval_root->op_private |= OPpREFCOUNTED;
2786 OpREFCNT_set(PL_eval_root, 1);
2787 PL_eval_root->op_next = 0;
2788 CALL_PEEP(PL_eval_start);
2789 finalize_optree(PL_eval_root);
2793 if (o->op_type == OP_STUB) {
2794 PL_comppad_name = 0;
2796 S_op_destroy(aTHX_ o);
2799 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2800 PL_curcop = &PL_compiling;
2801 PL_main_start = LINKLIST(PL_main_root);
2802 PL_main_root->op_private |= OPpREFCOUNTED;
2803 OpREFCNT_set(PL_main_root, 1);
2804 PL_main_root->op_next = 0;
2805 CALL_PEEP(PL_main_start);
2806 finalize_optree(PL_main_root);
2809 /* Register with debugger */
2811 CV * const cv = get_cvs("DB::postponed", 0);
2815 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2817 call_sv(MUTABLE_SV(cv), G_DISCARD);
2824 Perl_localize(pTHX_ OP *o, I32 lex)
2828 PERL_ARGS_ASSERT_LOCALIZE;
2830 if (o->op_flags & OPf_PARENS)
2831 /* [perl #17376]: this appears to be premature, and results in code such as
2832 C< our(%x); > executing in list mode rather than void mode */
2839 if ( PL_parser->bufptr > PL_parser->oldbufptr
2840 && PL_parser->bufptr[-1] == ','
2841 && ckWARN(WARN_PARENTHESIS))
2843 char *s = PL_parser->bufptr;
2846 /* some heuristics to detect a potential error */
2847 while (*s && (strchr(", \t\n", *s)))
2851 if (*s && strchr("@$%*", *s) && *++s
2852 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2855 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2857 while (*s && (strchr(", \t\n", *s)))
2863 if (sigil && (*s == ';' || *s == '=')) {
2864 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2865 "Parentheses missing around \"%s\" list",
2867 ? (PL_parser->in_my == KEY_our
2869 : PL_parser->in_my == KEY_state
2879 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2880 PL_parser->in_my = FALSE;
2881 PL_parser->in_my_stash = NULL;
2886 Perl_jmaybe(pTHX_ OP *o)
2888 PERL_ARGS_ASSERT_JMAYBE;
2890 if (o->op_type == OP_LIST) {
2892 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2893 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2898 PERL_STATIC_INLINE OP *
2899 S_op_std_init(pTHX_ OP *o)
2901 I32 type = o->op_type;
2903 PERL_ARGS_ASSERT_OP_STD_INIT;
2905 if (PL_opargs[type] & OA_RETSCALAR)
2907 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2908 o->op_targ = pad_alloc(type, SVs_PADTMP);
2913 PERL_STATIC_INLINE OP *
2914 S_op_integerize(pTHX_ OP *o)
2916 I32 type = o->op_type;
2918 PERL_ARGS_ASSERT_OP_INTEGERIZE;
2920 /* integerize op, unless it happens to be C<-foo>.
2921 * XXX should pp_i_negate() do magic string negation instead? */
2922 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2923 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2924 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2927 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2930 if (type == OP_NEGATE)
2931 /* XXX might want a ck_negate() for this */
2932 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2938 S_fold_constants(pTHX_ register OP *o)
2941 register OP * VOL curop;
2943 VOL I32 type = o->op_type;
2948 SV * const oldwarnhook = PL_warnhook;
2949 SV * const olddiehook = PL_diehook;
2953 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2955 if (!(PL_opargs[type] & OA_FOLDCONST))
2969 /* XXX what about the numeric ops? */
2970 if (PL_hints & HINT_LOCALE)
2975 if (PL_parser && PL_parser->error_count)
2976 goto nope; /* Don't try to run w/ errors */
2978 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2979 const OPCODE type = curop->op_type;
2980 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2982 type != OP_SCALAR &&
2984 type != OP_PUSHMARK)
2990 curop = LINKLIST(o);
2991 old_next = o->op_next;
2995 oldscope = PL_scopestack_ix;
2996 create_eval_scope(G_FAKINGEVAL);
2998 /* Verify that we don't need to save it: */
2999 assert(PL_curcop == &PL_compiling);
3000 StructCopy(&PL_compiling, ¬_compiling, COP);
3001 PL_curcop = ¬_compiling;
3002 /* The above ensures that we run with all the correct hints of the
3003 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3004 assert(IN_PERL_RUNTIME);
3005 PL_warnhook = PERL_WARNHOOK_FATAL;
3012 sv = *(PL_stack_sp--);
3013 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3015 /* Can't simply swipe the SV from the pad, because that relies on
3016 the op being freed "real soon now". Under MAD, this doesn't
3017 happen (see the #ifdef below). */
3020 pad_swipe(o->op_targ, FALSE);
3023 else if (SvTEMP(sv)) { /* grab mortal temp? */
3024 SvREFCNT_inc_simple_void(sv);
3029 /* Something tried to die. Abandon constant folding. */
3030 /* Pretend the error never happened. */
3032 o->op_next = old_next;
3036 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3037 PL_warnhook = oldwarnhook;
3038 PL_diehook = olddiehook;
3039 /* XXX note that this croak may fail as we've already blown away
3040 * the stack - eg any nested evals */
3041 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3044 PL_warnhook = oldwarnhook;
3045 PL_diehook = olddiehook;
3046 PL_curcop = &PL_compiling;
3048 if (PL_scopestack_ix > oldscope)
3049 delete_eval_scope();
3058 if (type == OP_RV2GV)
3059 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3061 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3062 op_getmad(o,newop,'f');
3070 S_gen_constant_list(pTHX_ register OP *o)
3074 const I32 oldtmps_floor = PL_tmps_floor;
3077 if (PL_parser && PL_parser->error_count)
3078 return o; /* Don't attempt to run with errors */
3080 PL_op = curop = LINKLIST(o);
3083 Perl_pp_pushmark(aTHX);
3086 assert (!(curop->op_flags & OPf_SPECIAL));
3087 assert(curop->op_type == OP_RANGE);
3088 Perl_pp_anonlist(aTHX);
3089 PL_tmps_floor = oldtmps_floor;
3091 o->op_type = OP_RV2AV;
3092 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3093 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3094 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3095 o->op_opt = 0; /* needs to be revisited in rpeep() */
3096 curop = ((UNOP*)o)->op_first;
3097 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3099 op_getmad(curop,o,'O');
3108 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3111 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3112 if (!o || o->op_type != OP_LIST)
3113 o = newLISTOP(OP_LIST, 0, o, NULL);
3115 o->op_flags &= ~OPf_WANT;
3117 if (!(PL_opargs[type] & OA_MARK))
3118 op_null(cLISTOPo->op_first);
3120 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3121 if (kid2 && kid2->op_type == OP_COREARGS) {
3122 op_null(cLISTOPo->op_first);
3123 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3127 o->op_type = (OPCODE)type;
3128 o->op_ppaddr = PL_ppaddr[type];
3129 o->op_flags |= flags;
3131 o = CHECKOP(type, o);
3132 if (o->op_type != (unsigned)type)
3135 return fold_constants(op_integerize(op_std_init(o)));
3139 =head1 Optree Manipulation Functions
3142 /* List constructors */
3145 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3147 Append an item to the list of ops contained directly within a list-type
3148 op, returning the lengthened list. I<first> is the list-type op,
3149 and I<last> is the op to append to the list. I<optype> specifies the
3150 intended opcode for the list. If I<first> is not already a list of the
3151 right type, it will be upgraded into one. If either I<first> or I<last>
3152 is null, the other is returned unchanged.
3158 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3166 if (first->op_type != (unsigned)type
3167 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3169 return newLISTOP(type, 0, first, last);
3172 if (first->op_flags & OPf_KIDS)
3173 ((LISTOP*)first)->op_last->op_sibling = last;
3175 first->op_flags |= OPf_KIDS;
3176 ((LISTOP*)first)->op_first = last;
3178 ((LISTOP*)first)->op_last = last;
3183 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3185 Concatenate the lists of ops contained directly within two list-type ops,
3186 returning the combined list. I<first> and I<last> are the list-type ops
3187 to concatenate. I<optype> specifies the intended opcode for the list.
3188 If either I<first> or I<last> is not already a list of the right type,
3189 it will be upgraded into one. If either I<first> or I<last> is null,
3190 the other is returned unchanged.
3196 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3204 if (first->op_type != (unsigned)type)
3205 return op_prepend_elem(type, first, last);
3207 if (last->op_type != (unsigned)type)
3208 return op_append_elem(type, first, last);
3210 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3211 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3212 first->op_flags |= (last->op_flags & OPf_KIDS);
3215 if (((LISTOP*)last)->op_first && first->op_madprop) {
3216 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3218 while (mp->mad_next)
3220 mp->mad_next = first->op_madprop;
3223 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3226 first->op_madprop = last->op_madprop;
3227 last->op_madprop = 0;
3230 S_op_destroy(aTHX_ last);
3236 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3238 Prepend an item to the list of ops contained directly within a list-type
3239 op, returning the lengthened list. I<first> is the op to prepend to the
3240 list, and I<last> is the list-type op. I<optype> specifies the intended
3241 opcode for the list. If I<last> is not already a list of the right type,
3242 it will be upgraded into one. If either I<first> or I<last> is null,
3243 the other is returned unchanged.
3249 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3257 if (last->op_type == (unsigned)type) {
3258 if (type == OP_LIST) { /* already a PUSHMARK there */
3259 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3260 ((LISTOP*)last)->op_first->op_sibling = first;
3261 if (!(first->op_flags & OPf_PARENS))
3262 last->op_flags &= ~OPf_PARENS;
3265 if (!(last->op_flags & OPf_KIDS)) {
3266 ((LISTOP*)last)->op_last = first;
3267 last->op_flags |= OPf_KIDS;
3269 first->op_sibling = ((LISTOP*)last)->op_first;
3270 ((LISTOP*)last)->op_first = first;
3272 last->op_flags |= OPf_KIDS;
3276 return newLISTOP(type, 0, first, last);
3284 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3287 Newxz(tk, 1, TOKEN);
3288 tk->tk_type = (OPCODE)optype;
3289 tk->tk_type = 12345;
3291 tk->tk_mad = madprop;
3296 Perl_token_free(pTHX_ TOKEN* tk)
3298 PERL_ARGS_ASSERT_TOKEN_FREE;
3300 if (tk->tk_type != 12345)
3302 mad_free(tk->tk_mad);
3307 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3312 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3314 if (tk->tk_type != 12345) {
3315 Perl_warner(aTHX_ packWARN(WARN_MISC),
3316 "Invalid TOKEN object ignored");
3323 /* faked up qw list? */
3325 tm->mad_type == MAD_SV &&
3326 SvPVX((SV *)tm->mad_val)[0] == 'q')
3333 /* pretend constant fold didn't happen? */
3334 if (mp->mad_key == 'f' &&
3335 (o->op_type == OP_CONST ||
3336 o->op_type == OP_GV) )
3338 token_getmad(tk,(OP*)mp->mad_val,slot);
3352 if (mp->mad_key == 'X')
3353 mp->mad_key = slot; /* just change the first one */
3363 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3372 /* pretend constant fold didn't happen? */
3373 if (mp->mad_key == 'f' &&
3374 (o->op_type == OP_CONST ||
3375 o->op_type == OP_GV) )
3377 op_getmad(from,(OP*)mp->mad_val,slot);
3384 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3387 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3393 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3402 /* pretend constant fold didn't happen? */
3403 if (mp->mad_key == 'f' &&
3404 (o->op_type == OP_CONST ||
3405 o->op_type == OP_GV) )
3407 op_getmad(from,(OP*)mp->mad_val,slot);
3414 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3417 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3421 PerlIO_printf(PerlIO_stderr(),
3422 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3428 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3446 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3450 addmad(tm, &(o->op_madprop), slot);
3454 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3475 Perl_newMADsv(pTHX_ char key, SV* sv)
3477 PERL_ARGS_ASSERT_NEWMADSV;
3479 return newMADPROP(key, MAD_SV, sv, 0);
3483 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3485 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3488 mp->mad_vlen = vlen;
3489 mp->mad_type = type;
3491 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3496 Perl_mad_free(pTHX_ MADPROP* mp)
3498 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3502 mad_free(mp->mad_next);
3503 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3504 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3505 switch (mp->mad_type) {
3509 Safefree((char*)mp->mad_val);
3512 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3513 op_free((OP*)mp->mad_val);
3516 sv_free(MUTABLE_SV(mp->mad_val));
3519 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3522 PerlMemShared_free(mp);
3528 =head1 Optree construction
3530 =for apidoc Am|OP *|newNULLLIST
3532 Constructs, checks, and returns a new C<stub> op, which represents an
3533 empty list expression.
3539 Perl_newNULLLIST(pTHX)
3541 return newOP(OP_STUB, 0);
3545 S_force_list(pTHX_ OP *o)
3547 if (!o || o->op_type != OP_LIST)
3548 o = newLISTOP(OP_LIST, 0, o, NULL);
3554 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3556 Constructs, checks, and returns an op of any list type. I<type> is
3557 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3558 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3559 supply up to two ops to be direct children of the list op; they are
3560 consumed by this function and become part of the constructed op tree.
3566 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3571 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3573 NewOp(1101, listop, 1, LISTOP);
3575 listop->op_type = (OPCODE)type;
3576 listop->op_ppaddr = PL_ppaddr[type];
3579 listop->op_flags = (U8)flags;
3583 else if (!first && last)
3586 first->op_sibling = last;
3587 listop->op_first = first;
3588 listop->op_last = last;
3589 if (type == OP_LIST) {
3590 OP* const pushop = newOP(OP_PUSHMARK, 0);
3591 pushop->op_sibling = first;
3592 listop->op_first = pushop;
3593 listop->op_flags |= OPf_KIDS;
3595 listop->op_last = pushop;
3598 return CHECKOP(type, listop);
3602 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3604 Constructs, checks, and returns an op of any base type (any type that
3605 has no extra fields). I<type> is the opcode. I<flags> gives the
3606 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3613 Perl_newOP(pTHX_ I32 type, I32 flags)
3618 if (type == -OP_ENTEREVAL) {
3619 type = OP_ENTEREVAL;
3620 flags |= OPpEVAL_BYTES<<8;
3623 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3624 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3625 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3626 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3628 NewOp(1101, o, 1, OP);
3629 o->op_type = (OPCODE)type;
3630 o->op_ppaddr = PL_ppaddr[type];
3631 o->op_flags = (U8)flags;
3633 o->op_latefreed = 0;
3637 o->op_private = (U8)(0 | (flags >> 8));
3638 if (PL_opargs[type] & OA_RETSCALAR)
3640 if (PL_opargs[type] & OA_TARGET)
3641 o->op_targ = pad_alloc(type, SVs_PADTMP);
3642 return CHECKOP(type, o);
3646 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3648 Constructs, checks, and returns an op of any unary type. I<type> is
3649 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3650 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3651 bits, the eight bits of C<op_private>, except that the bit with value 1
3652 is automatically set. I<first> supplies an optional op to be the direct
3653 child of the unary op; it is consumed by this function and become part
3654 of the constructed op tree.
3660 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3665 if (type == -OP_ENTEREVAL) {
3666 type = OP_ENTEREVAL;
3667 flags |= OPpEVAL_BYTES<<8;
3670 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3671 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3672 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3673 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3674 || type == OP_SASSIGN
3675 || type == OP_ENTERTRY
3676 || type == OP_NULL );
3679 first = newOP(OP_STUB, 0);
3680 if (PL_opargs[type] & OA_MARK)
3681 first = force_list(first);
3683 NewOp(1101, unop, 1, UNOP);
3684 unop->op_type = (OPCODE)type;
3685 unop->op_ppaddr = PL_ppaddr[type];
3686 unop->op_first = first;
3687 unop->op_flags = (U8)(flags | OPf_KIDS);
3688 unop->op_private = (U8)(1 | (flags >> 8));
3689 unop = (UNOP*) CHECKOP(type, unop);
3693 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3697 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3699 Constructs, checks, and returns an op of any binary type. I<type>
3700 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3701 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3702 the eight bits of C<op_private>, except that the bit with value 1 or
3703 2 is automatically set as required. I<first> and I<last> supply up to
3704 two ops to be the direct children of the binary op; they are consumed
3705 by this function and become part of the constructed op tree.
3711 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3716 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3717 || type == OP_SASSIGN || type == OP_NULL );
3719 NewOp(1101, binop, 1, BINOP);
3722 first = newOP(OP_NULL, 0);
3724 binop->op_type = (OPCODE)type;
3725 binop->op_ppaddr = PL_ppaddr[type];
3726 binop->op_first = first;
3727 binop->op_flags = (U8)(flags | OPf_KIDS);
3730 binop->op_private = (U8)(1 | (flags >> 8));
3733 binop->op_private = (U8)(2 | (flags >> 8));
3734 first->op_sibling = last;
3737 binop = (BINOP*)CHECKOP(type, binop);
3738 if (binop->op_next || binop->op_type != (OPCODE)type)
3741 binop->op_last = binop->op_first->op_sibling;
3743 return fold_constants(op_integerize(op_std_init((OP *)binop)));
3746 static int uvcompare(const void *a, const void *b)
3747 __attribute__nonnull__(1)
3748 __attribute__nonnull__(2)
3749 __attribute__pure__;
3750 static int uvcompare(const void *a, const void *b)
3752 if (*((const UV *)a) < (*(const UV *)b))
3754 if (*((const UV *)a) > (*(const UV *)b))
3756 if (*((const UV *)a+1) < (*(const UV *)b+1))
3758 if (*((const UV *)a+1) > (*(const UV *)b+1))
3764 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3767 SV * const tstr = ((SVOP*)expr)->op_sv;
3770 (repl->op_type == OP_NULL)
3771 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3773 ((SVOP*)repl)->op_sv;
3776 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3777 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3781 register short *tbl;
3783 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3784 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3785 I32 del = o->op_private & OPpTRANS_DELETE;
3788 PERL_ARGS_ASSERT_PMTRANS;
3790 PL_hints |= HINT_BLOCK_SCOPE;
3793 o->op_private |= OPpTRANS_FROM_UTF;
3796 o->op_private |= OPpTRANS_TO_UTF;
3798 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3799 SV* const listsv = newSVpvs("# comment\n");
3801 const U8* tend = t + tlen;
3802 const U8* rend = r + rlen;
3816 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3817 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3820 const U32 flags = UTF8_ALLOW_DEFAULT;
3824 t = tsave = bytes_to_utf8(t, &len);
3827 if (!to_utf && rlen) {
3829 r = rsave = bytes_to_utf8(r, &len);
3833 /* There are several snags with this code on EBCDIC:
3834 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3835 2. scan_const() in toke.c has encoded chars in native encoding which makes
3836 ranges at least in EBCDIC 0..255 range the bottom odd.
3840 U8 tmpbuf[UTF8_MAXBYTES+1];
3843 Newx(cp, 2*tlen, UV);
3845 transv = newSVpvs("");
3847 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3849 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3851 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3855 cp[2*i+1] = cp[2*i];
3859 qsort(cp, i, 2*sizeof(UV), uvcompare);
3860 for (j = 0; j < i; j++) {
3862 diff = val - nextmin;
3864 t = uvuni_to_utf8(tmpbuf,nextmin);
3865 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3867 U8 range_mark = UTF_TO_NATIVE(0xff);
3868 t = uvuni_to_utf8(tmpbuf, val - 1);
3869 sv_catpvn(transv, (char *)&range_mark, 1);
3870 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3877 t = uvuni_to_utf8(tmpbuf,nextmin);
3878 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3880 U8 range_mark = UTF_TO_NATIVE(0xff);
3881 sv_catpvn(transv, (char *)&range_mark, 1);
3883 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3884 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3885 t = (const U8*)SvPVX_const(transv);
3886 tlen = SvCUR(transv);
3890 else if (!rlen && !del) {
3891 r = t; rlen = tlen; rend = tend;
3894 if ((!rlen && !del) || t == r ||
3895 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3897 o->op_private |= OPpTRANS_IDENTICAL;
3901 while (t < tend || tfirst <= tlast) {
3902 /* see if we need more "t" chars */
3903 if (tfirst > tlast) {
3904 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3906 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3908 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3915 /* now see if we need more "r" chars */
3916 if (rfirst > rlast) {
3918 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3920 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3922 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3931 rfirst = rlast = 0xffffffff;
3935 /* now see which range will peter our first, if either. */
3936 tdiff = tlast - tfirst;
3937 rdiff = rlast - rfirst;
3944 if (rfirst == 0xffffffff) {
3945 diff = tdiff; /* oops, pretend rdiff is infinite */
3947 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3948 (long)tfirst, (long)tlast);
3950 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3954 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3955 (long)tfirst, (long)(tfirst + diff),
3958 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3959 (long)tfirst, (long)rfirst);
3961 if (rfirst + diff > max)
3962 max = rfirst + diff;
3964 grows = (tfirst < rfirst &&
3965 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3977 else if (max > 0xff)
3982 PerlMemShared_free(cPVOPo->op_pv);
3983 cPVOPo->op_pv = NULL;
3985 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3987 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3988 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3989 PAD_SETSV(cPADOPo->op_padix, swash);
3991 SvREADONLY_on(swash);
3993 cSVOPo->op_sv = swash;
3995 SvREFCNT_dec(listsv);
3996 SvREFCNT_dec(transv);
3998 if (!del && havefinal && rlen)
3999 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4000 newSVuv((UV)final), 0);
4003 o->op_private |= OPpTRANS_GROWS;
4009 op_getmad(expr,o,'e');
4010 op_getmad(repl,o,'r');
4018 tbl = (short*)cPVOPo->op_pv;
4020 Zero(tbl, 256, short);
4021 for (i = 0; i < (I32)tlen; i++)
4023 for (i = 0, j = 0; i < 256; i++) {
4025 if (j >= (I32)rlen) {
4034 if (i < 128 && r[j] >= 128)
4044 o->op_private |= OPpTRANS_IDENTICAL;
4046 else if (j >= (I32)rlen)
4051 PerlMemShared_realloc(tbl,
4052 (0x101+rlen-j) * sizeof(short));
4053 cPVOPo->op_pv = (char*)tbl;
4055 tbl[0x100] = (short)(rlen - j);
4056 for (i=0; i < (I32)rlen - j; i++)
4057 tbl[0x101+i] = r[j+i];
4061 if (!rlen && !del) {
4064 o->op_private |= OPpTRANS_IDENTICAL;
4066 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4067 o->op_private |= OPpTRANS_IDENTICAL;
4069 for (i = 0; i < 256; i++)
4071 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4072 if (j >= (I32)rlen) {
4074 if (tbl[t[i]] == -1)
4080 if (tbl[t[i]] == -1) {
4081 if (t[i] < 128 && r[j] >= 128)
4088 if(del && rlen == tlen) {
4089 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4090 } else if(rlen > tlen) {
4091 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4095 o->op_private |= OPpTRANS_GROWS;
4097 op_getmad(expr,o,'e');
4098 op_getmad(repl,o,'r');
4108 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4110 Constructs, checks, and returns an op of any pattern matching type.
4111 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4112 and, shifted up eight bits, the eight bits of C<op_private>.
4118 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4123 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4125 NewOp(1101, pmop, 1, PMOP);
4126 pmop->op_type = (OPCODE)type;
4127 pmop->op_ppaddr = PL_ppaddr[type];
4128 pmop->op_flags = (U8)flags;
4129 pmop->op_private = (U8)(0 | (flags >> 8));
4131 if (PL_hints & HINT_RE_TAINT)
4132 pmop->op_pmflags |= PMf_RETAINT;
4133 if (PL_hints & HINT_LOCALE) {
4134 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4136 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
4137 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4139 if (PL_hints & HINT_RE_FLAGS) {
4140 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4141 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4143 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4144 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4145 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4147 if (reflags && SvOK(reflags)) {
4148 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4154 assert(SvPOK(PL_regex_pad[0]));
4155 if (SvCUR(PL_regex_pad[0])) {
4156 /* Pop off the "packed" IV from the end. */
4157 SV *const repointer_list = PL_regex_pad[0];
4158 const char *p = SvEND(repointer_list) - sizeof(IV);
4159 const IV offset = *((IV*)p);
4161 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4163 SvEND_set(repointer_list, p);
4165 pmop->op_pmoffset = offset;
4166 /* This slot should be free, so assert this: */
4167 assert(PL_regex_pad[offset] == &PL_sv_undef);
4169 SV * const repointer = &PL_sv_undef;
4170 av_push(PL_regex_padav, repointer);
4171 pmop->op_pmoffset = av_len(PL_regex_padav);
4172 PL_regex_pad = AvARRAY(PL_regex_padav);
4176 return CHECKOP(type, pmop);
4179 /* Given some sort of match op o, and an expression expr containing a
4180 * pattern, either compile expr into a regex and attach it to o (if it's
4181 * constant), or convert expr into a runtime regcomp op sequence (if it's
4184 * isreg indicates that the pattern is part of a regex construct, eg
4185 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4186 * split "pattern", which aren't. In the former case, expr will be a list
4187 * if the pattern contains more than one term (eg /a$b/) or if it contains
4188 * a replacement, ie s/// or tr///.
4192 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4197 I32 repl_has_vars = 0;
4201 PERL_ARGS_ASSERT_PMRUNTIME;
4204 o->op_type == OP_SUBST
4205 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4207 /* last element in list is the replacement; pop it */
4209 repl = cLISTOPx(expr)->op_last;
4210 kid = cLISTOPx(expr)->op_first;
4211 while (kid->op_sibling != repl)
4212 kid = kid->op_sibling;
4213 kid->op_sibling = NULL;
4214 cLISTOPx(expr)->op_last = kid;
4217 if (isreg && expr->op_type == OP_LIST &&
4218 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4220 /* convert single element list to element */
4221 OP* const oe = expr;
4222 expr = cLISTOPx(oe)->op_first->op_sibling;
4223 cLISTOPx(oe)->op_first->op_sibling = NULL;
4224 cLISTOPx(oe)->op_last = NULL;
4228 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4229 return pmtrans(o, expr, repl);
4232 reglist = isreg && expr->op_type == OP_LIST;
4236 PL_hints |= HINT_BLOCK_SCOPE;
4239 if (expr->op_type == OP_CONST) {
4240 SV *pat = ((SVOP*)expr)->op_sv;
4241 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4243 if (o->op_flags & OPf_SPECIAL)
4244 pm_flags |= RXf_SPLIT;
4247 assert (SvUTF8(pat));
4248 } else if (SvUTF8(pat)) {
4249 /* Not doing UTF-8, despite what the SV says. Is this only if we're
4250 trapped in use 'bytes'? */
4251 /* Make a copy of the octet sequence, but without the flag on, as
4252 the compiler now honours the SvUTF8 flag on pat. */
4254 const char *const p = SvPV(pat, len);
4255 pat = newSVpvn_flags(p, len, SVs_TEMP);
4258 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4261 op_getmad(expr,(OP*)pm,'e');
4267 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4268 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4270 : OP_REGCMAYBE),0,expr);
4272 NewOp(1101, rcop, 1, LOGOP);
4273 rcop->op_type = OP_REGCOMP;
4274 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4275 rcop->op_first = scalar(expr);
4276 rcop->op_flags |= OPf_KIDS
4277 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4278 | (reglist ? OPf_STACKED : 0);
4279 rcop->op_private = 1;
4282 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4284 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4285 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4287 /* establish postfix order */
4288 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4290 rcop->op_next = expr;
4291 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4294 rcop->op_next = LINKLIST(expr);
4295 expr->op_next = (OP*)rcop;
4298 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4303 if (pm->op_pmflags & PMf_EVAL) {
4305 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4306 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4308 else if (repl->op_type == OP_CONST)
4312 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4313 if (curop->op_type == OP_SCOPE
4314 || curop->op_type == OP_LEAVE
4315 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4316 if (curop->op_type == OP_GV) {
4317 GV * const gv = cGVOPx_gv(curop);
4319 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4322 else if (curop->op_type == OP_RV2CV)
4324 else if (curop->op_type == OP_RV2SV ||
4325 curop->op_type == OP_RV2AV ||
4326 curop->op_type == OP_RV2HV ||
4327 curop->op_type == OP_RV2GV) {
4328 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4331 else if (curop->op_type == OP_PADSV ||
4332 curop->op_type == OP_PADAV ||
4333 curop->op_type == OP_PADHV ||
4334 curop->op_type == OP_PADANY)
4338 else if (curop->op_type == OP_PUSHRE)
4339 NOOP; /* Okay here, dangerous in newASSIGNOP */
4349 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4351 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4352 op_prepend_elem(o->op_type, scalar(repl), o);
4355 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4356 pm->op_pmflags |= PMf_MAYBE_CONST;
4358 NewOp(1101, rcop, 1, LOGOP);
4359 rcop->op_type = OP_SUBSTCONT;
4360 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4361 rcop->op_first = scalar(repl);
4362 rcop->op_flags |= OPf_KIDS;
4363 rcop->op_private = 1;
4366 /* establish postfix order */
4367 rcop->op_next = LINKLIST(repl);
4368 repl->op_next = (OP*)rcop;
4370 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4371 assert(!(pm->op_pmflags & PMf_ONCE));
4372 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4381 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4383 Constructs, checks, and returns an op of any type that involves an
4384 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4385 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4386 takes ownership of one reference to it.
4392 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4397 PERL_ARGS_ASSERT_NEWSVOP;
4399 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4400 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4401 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4403 NewOp(1101, svop, 1, SVOP);
4404 svop->op_type = (OPCODE)type;
4405 svop->op_ppaddr = PL_ppaddr[type];
4407 svop->op_next = (OP*)svop;
4408 svop->op_flags = (U8)flags;
4409 if (PL_opargs[type] & OA_RETSCALAR)
4411 if (PL_opargs[type] & OA_TARGET)
4412 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4413 return CHECKOP(type, svop);
4419 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4421 Constructs, checks, and returns an op of any type that involves a
4422 reference to a pad element. I<type> is the opcode. I<flags> gives the
4423 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4424 is populated with I<sv>; this function takes ownership of one reference
4427 This function only exists if Perl has been compiled to use ithreads.
4433 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4438 PERL_ARGS_ASSERT_NEWPADOP;
4440 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4441 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4442 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4444 NewOp(1101, padop, 1, PADOP);
4445 padop->op_type = (OPCODE)type;
4446 padop->op_ppaddr = PL_ppaddr[type];
4447 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4448 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4449 PAD_SETSV(padop->op_padix, sv);
4452 padop->op_next = (OP*)padop;
4453 padop->op_flags = (U8)flags;
4454 if (PL_opargs[type] & OA_RETSCALAR)
4456 if (PL_opargs[type] & OA_TARGET)
4457 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4458 return CHECKOP(type, padop);
4461 #endif /* !USE_ITHREADS */
4464 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4466 Constructs, checks, and returns an op of any type that involves an
4467 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4468 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4469 reference; calling this function does not transfer ownership of any
4476 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4480 PERL_ARGS_ASSERT_NEWGVOP;
4484 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4486 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4491 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4493 Constructs, checks, and returns an op of any type that involves an
4494 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4495 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4496 must have been allocated using L</PerlMemShared_malloc>; the memory will
4497 be freed when the op is destroyed.
4503 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4508 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4510 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4512 NewOp(1101, pvop, 1, PVOP);
4513 pvop->op_type = (OPCODE)type;
4514 pvop->op_ppaddr = PL_ppaddr[type];
4516 pvop->op_next = (OP*)pvop;
4517 pvop->op_flags = (U8)flags;
4518 if (PL_opargs[type] & OA_RETSCALAR)
4520 if (PL_opargs[type] & OA_TARGET)
4521 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4522 return CHECKOP(type, pvop);
4530 Perl_package(pTHX_ OP *o)
4533 SV *const sv = cSVOPo->op_sv;
4538 PERL_ARGS_ASSERT_PACKAGE;
4540 SAVEGENERICSV(PL_curstash);
4541 save_item(PL_curstname);
4543 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4545 sv_setsv(PL_curstname, sv);
4547 PL_hints |= HINT_BLOCK_SCOPE;
4548 PL_parser->copline = NOLINE;
4549 PL_parser->expect = XSTATE;
4554 if (!PL_madskills) {
4559 pegop = newOP(OP_NULL,0);
4560 op_getmad(o,pegop,'P');
4566 Perl_package_version( pTHX_ OP *v )
4569 U32 savehints = PL_hints;
4570 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4571 PL_hints &= ~HINT_STRICT_VARS;
4572 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4573 PL_hints = savehints;
4582 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4589 OP *pegop = newOP(OP_NULL,0);
4591 SV *use_version = NULL;
4593 PERL_ARGS_ASSERT_UTILIZE;
4595 if (idop->op_type != OP_CONST)
4596 Perl_croak(aTHX_ "Module name must be constant");
4599 op_getmad(idop,pegop,'U');
4604 SV * const vesv = ((SVOP*)version)->op_sv;
4607 op_getmad(version,pegop,'V');
4608 if (!arg && !SvNIOKp(vesv)) {
4615 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4616 Perl_croak(aTHX_ "Version number must be a constant number");
4618 /* Make copy of idop so we don't free it twice */
4619 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4621 /* Fake up a method call to VERSION */
4622 meth = newSVpvs_share("VERSION");
4623 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4624 op_append_elem(OP_LIST,
4625 op_prepend_elem(OP_LIST, pack, list(version)),
4626 newSVOP(OP_METHOD_NAMED, 0, meth)));
4630 /* Fake up an import/unimport */
4631 if (arg && arg->op_type == OP_STUB) {
4633 op_getmad(arg,pegop,'S');
4634 imop = arg; /* no import on explicit () */
4636 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4637 imop = NULL; /* use 5.0; */
4639 use_version = ((SVOP*)idop)->op_sv;
4641 idop->op_private |= OPpCONST_NOVER;
4647 op_getmad(arg,pegop,'A');
4649 /* Make copy of idop so we don't free it twice */
4650 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4652 /* Fake up a method call to import/unimport */
4654 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4655 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4656 op_append_elem(OP_LIST,
4657 op_prepend_elem(OP_LIST, pack, list(arg)),
4658 newSVOP(OP_METHOD_NAMED, 0, meth)));
4661 /* Fake up the BEGIN {}, which does its thing immediately. */
4663 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4666 op_append_elem(OP_LINESEQ,
4667 op_append_elem(OP_LINESEQ,
4668 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4669 newSTATEOP(0, NULL, veop)),
4670 newSTATEOP(0, NULL, imop) ));
4673 HV * const hinthv = GvHV(PL_hintgv);
4674 const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH);
4677 /* Turn features off */
4678 ENTER_with_name("load_feature");
4679 Perl_load_module(aTHX_
4680 PERL_LOADMOD_DENY, newSVpvs("feature"), NULL, NULL
4683 /* If we request a version >= 5.9.5, load feature.pm with the
4684 * feature bundle that corresponds to the required version. */
4685 use_version = sv_2mortal(new_version(use_version));
4687 if (vcmp(use_version,
4688 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4689 importsv = vnormal(use_version);
4690 *SvPVX_mutable(importsv) = ':';
4692 else importsv = newSVpvs(":default");
4693 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4694 LEAVE_with_name("load_feature");
4695 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4696 if (vcmp(use_version,
4697 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4698 if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
4699 PL_hints |= HINT_STRICT_REFS;
4700 if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
4701 PL_hints |= HINT_STRICT_SUBS;
4702 if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
4703 PL_hints |= HINT_STRICT_VARS;
4705 /* otherwise they are off */
4707 if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
4708 PL_hints &= ~HINT_STRICT_REFS;
4709 if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
4710 PL_hints &= ~HINT_STRICT_SUBS;
4711 if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
4712 PL_hints &= ~HINT_STRICT_VARS;
4716 /* The "did you use incorrect case?" warning used to be here.
4717 * The problem is that on case-insensitive filesystems one
4718 * might get false positives for "use" (and "require"):
4719 * "use Strict" or "require CARP" will work. This causes
4720 * portability problems for the script: in case-strict
4721 * filesystems the script will stop working.
4723 * The "incorrect case" warning checked whether "use Foo"
4724 * imported "Foo" to your namespace, but that is wrong, too:
4725 * there is no requirement nor promise in the language that
4726 * a Foo.pm should or would contain anything in package "Foo".
4728 * There is very little Configure-wise that can be done, either:
4729 * the case-sensitivity of the build filesystem of Perl does not
4730 * help in guessing the case-sensitivity of the runtime environment.
4733 PL_hints |= HINT_BLOCK_SCOPE;
4734 PL_parser->copline = NOLINE;
4735 PL_parser->expect = XSTATE;
4736 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4737 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4741 if (!PL_madskills) {
4742 /* FIXME - don't allocate pegop if !PL_madskills */
4751 =head1 Embedding Functions
4753 =for apidoc load_module
4755 Loads the module whose name is pointed to by the string part of name.
4756 Note that the actual module name, not its filename, should be given.
4757 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4758 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4759 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
4760 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4761 arguments can be used to specify arguments to the module's import()
4762 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4763 terminated with a final NULL pointer. Note that this list can only
4764 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4765 Otherwise at least a single NULL pointer to designate the default
4766 import list is required.
4768 The reference count for each specified C<SV*> parameter is decremented.
4773 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4777 PERL_ARGS_ASSERT_LOAD_MODULE;
4779 va_start(args, ver);
4780 vload_module(flags, name, ver, &args);
4784 #ifdef PERL_IMPLICIT_CONTEXT
4786 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4790 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4791 va_start(args, ver);
4792 vload_module(flags, name, ver, &args);
4798 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4802 OP * const modname = newSVOP(OP_CONST, 0, name);
4804 PERL_ARGS_ASSERT_VLOAD_MODULE;
4806 modname->op_private |= OPpCONST_BARE;
4808 veop = newSVOP(OP_CONST, 0, ver);
4812 if (flags & PERL_LOADMOD_NOIMPORT) {
4813 imop = sawparens(newNULLLIST());
4815 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4816 imop = va_arg(*args, OP*);
4821 sv = va_arg(*args, SV*);
4823 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4824 sv = va_arg(*args, SV*);
4828 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4829 * that it has a PL_parser to play with while doing that, and also
4830 * that it doesn't mess with any existing parser, by creating a tmp
4831 * new parser with lex_start(). This won't actually be used for much,
4832 * since pp_require() will create another parser for the real work. */
4835 SAVEVPTR(PL_curcop);
4836 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4837 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4838 veop, modname, imop);
4843 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4849 PERL_ARGS_ASSERT_DOFILE;
4851 if (!force_builtin) {
4852 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4853 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4854 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4855 gv = gvp ? *gvp : NULL;
4859 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4860 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4861 op_append_elem(OP_LIST, term,
4862 scalar(newUNOP(OP_RV2CV, 0,
4863 newGVOP(OP_GV, 0, gv))))));
4866 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4872 =head1 Optree construction
4874 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4876 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4877 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4878 be set automatically, and, shifted up eight bits, the eight bits of
4879 C<op_private>, except that the bit with value 1 or 2 is automatically
4880 set as required. I<listval> and I<subscript> supply the parameters of
4881 the slice; they are consumed by this function and become part of the
4882 constructed op tree.
4888 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4890 return newBINOP(OP_LSLICE, flags,
4891 list(force_list(subscript)),
4892 list(force_list(listval)) );
4896 S_is_list_assignment(pTHX_ register const OP *o)
4904 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4905 o = cUNOPo->op_first;
4907 flags = o->op_flags;
4909 if (type == OP_COND_EXPR) {
4910 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4911 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4916 yyerror("Assignment to both a list and a scalar");
4920 if (type == OP_LIST &&
4921 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4922 o->op_private & OPpLVAL_INTRO)
4925 if (type == OP_LIST || flags & OPf_PARENS ||
4926 type == OP_RV2AV || type == OP_RV2HV ||
4927 type == OP_ASLICE || type == OP_HSLICE)
4930 if (type == OP_PADAV || type == OP_PADHV)
4933 if (type == OP_RV2SV)
4940 Helper function for newASSIGNOP to detection commonality between the
4941 lhs and the rhs. Marks all variables with PL_generation. If it
4942 returns TRUE the assignment must be able to handle common variables.
4944 PERL_STATIC_INLINE bool
4945 S_aassign_common_vars(pTHX_ OP* o)
4948 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
4949 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4950 if (curop->op_type == OP_GV) {
4951 GV *gv = cGVOPx_gv(curop);
4953 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4955 GvASSIGN_GENERATION_set(gv, PL_generation);
4957 else if (curop->op_type == OP_PADSV ||
4958 curop->op_type == OP_PADAV ||
4959 curop->op_type == OP_PADHV ||
4960 curop->op_type == OP_PADANY)
4962 if (PAD_COMPNAME_GEN(curop->op_targ)
4963 == (STRLEN)PL_generation)
4965 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4968 else if (curop->op_type == OP_RV2CV)
4970 else if (curop->op_type == OP_RV2SV ||
4971 curop->op_type == OP_RV2AV ||
4972 curop->op_type == OP_RV2HV ||
4973 curop->op_type == OP_RV2GV) {
4974 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
4977 else if (curop->op_type == OP_PUSHRE) {
4979 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4980 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4982 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4984 GvASSIGN_GENERATION_set(gv, PL_generation);
4988 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4991 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4993 GvASSIGN_GENERATION_set(gv, PL_generation);
5001 if (curop->op_flags & OPf_KIDS) {
5002 if (aassign_common_vars(curop))
5010 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5012 Constructs, checks, and returns an assignment op. I<left> and I<right>
5013 supply the parameters of the assignment; they are consumed by this
5014 function and become part of the constructed op tree.
5016 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5017 a suitable conditional optree is constructed. If I<optype> is the opcode
5018 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5019 performs the binary operation and assigns the result to the left argument.
5020 Either way, if I<optype> is non-zero then I<flags> has no effect.
5022 If I<optype> is zero, then a plain scalar or list assignment is
5023 constructed. Which type of assignment it is is automatically determined.
5024 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5025 will be set automatically, and, shifted up eight bits, the eight bits
5026 of C<op_private>, except that the bit with value 1 or 2 is automatically
5033 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5039 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5040 return newLOGOP(optype, 0,
5041 op_lvalue(scalar(left), optype),
5042 newUNOP(OP_SASSIGN, 0, scalar(right)));
5045 return newBINOP(optype, OPf_STACKED,
5046 op_lvalue(scalar(left), optype), scalar(right));
5050 if (is_list_assignment(left)) {
5051 static const char no_list_state[] = "Initialization of state variables"
5052 " in list context currently forbidden";
5054 bool maybe_common_vars = TRUE;
5057 left = op_lvalue(left, OP_AASSIGN);
5058 curop = list(force_list(left));
5059 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5060 o->op_private = (U8)(0 | (flags >> 8));
5062 if ((left->op_type == OP_LIST
5063 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5065 OP* lop = ((LISTOP*)left)->op_first;
5066 maybe_common_vars = FALSE;
5068 if (lop->op_type == OP_PADSV ||
5069 lop->op_type == OP_PADAV ||
5070 lop->op_type == OP_PADHV ||
5071 lop->op_type == OP_PADANY) {
5072 if (!(lop->op_private & OPpLVAL_INTRO))
5073 maybe_common_vars = TRUE;
5075 if (lop->op_private & OPpPAD_STATE) {
5076 if (left->op_private & OPpLVAL_INTRO) {
5077 /* Each variable in state($a, $b, $c) = ... */
5080 /* Each state variable in
5081 (state $a, my $b, our $c, $d, undef) = ... */
5083 yyerror(no_list_state);
5085 /* Each my variable in
5086 (state $a, my $b, our $c, $d, undef) = ... */
5088 } else if (lop->op_type == OP_UNDEF ||
5089 lop->op_type == OP_PUSHMARK) {
5090 /* undef may be interesting in
5091 (state $a, undef, state $c) */
5093 /* Other ops in the list. */
5094 maybe_common_vars = TRUE;
5096 lop = lop->op_sibling;
5099 else if ((left->op_private & OPpLVAL_INTRO)
5100 && ( left->op_type == OP_PADSV
5101 || left->op_type == OP_PADAV
5102 || left->op_type == OP_PADHV
5103 || left->op_type == OP_PADANY))
5105 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5106 if (left->op_private & OPpPAD_STATE) {
5107 /* All single variable list context state assignments, hence
5117 yyerror(no_list_state);
5121 /* PL_generation sorcery:
5122 * an assignment like ($a,$b) = ($c,$d) is easier than
5123 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5124 * To detect whether there are common vars, the global var
5125 * PL_generation is incremented for each assign op we compile.
5126 * Then, while compiling the assign op, we run through all the
5127 * variables on both sides of the assignment, setting a spare slot
5128 * in each of them to PL_generation. If any of them already have
5129 * that value, we know we've got commonality. We could use a
5130 * single bit marker, but then we'd have to make 2 passes, first
5131 * to clear the flag, then to test and set it. To find somewhere
5132 * to store these values, evil chicanery is done with SvUVX().
5135 if (maybe_common_vars) {
5137 if (aassign_common_vars(o))
5138 o->op_private |= OPpASSIGN_COMMON;
5142 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5143 OP* tmpop = ((LISTOP*)right)->op_first;
5144 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5145 PMOP * const pm = (PMOP*)tmpop;
5146 if (left->op_type == OP_RV2AV &&
5147 !(left->op_private & OPpLVAL_INTRO) &&
5148 !(o->op_private & OPpASSIGN_COMMON) )
5150 tmpop = ((UNOP*)left)->op_first;
5151 if (tmpop->op_type == OP_GV
5153 && !pm->op_pmreplrootu.op_pmtargetoff
5155 && !pm->op_pmreplrootu.op_pmtargetgv
5159 pm->op_pmreplrootu.op_pmtargetoff
5160 = cPADOPx(tmpop)->op_padix;
5161 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5163 pm->op_pmreplrootu.op_pmtargetgv
5164 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5165 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5167 pm->op_pmflags |= PMf_ONCE;
5168 tmpop = cUNOPo->op_first; /* to list (nulled) */
5169 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5170 tmpop->op_sibling = NULL; /* don't free split */
5171 right->op_next = tmpop->op_next; /* fix starting loc */
5172 op_free(o); /* blow off assign */
5173 right->op_flags &= ~OPf_WANT;
5174 /* "I don't know and I don't care." */
5179 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5180 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5182 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5183 if (SvIOK(sv) && SvIVX(sv) == 0)
5184 sv_setiv(sv, PL_modcount+1);
5192 right = newOP(OP_UNDEF, 0);
5193 if (right->op_type == OP_READLINE) {
5194 right->op_flags |= OPf_STACKED;
5195 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5199 o = newBINOP(OP_SASSIGN, flags,
5200 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5206 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5208 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5209 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5210 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5211 If I<label> is non-null, it supplies the name of a label to attach to
5212 the state op; this function takes ownership of the memory pointed at by
5213 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5216 If I<o> is null, the state op is returned. Otherwise the state op is
5217 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5218 is consumed by this function and becomes part of the returned op tree.
5224 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5227 const U32 seq = intro_my();
5230 NewOp(1101, cop, 1, COP);
5231 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5232 cop->op_type = OP_DBSTATE;
5233 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5236 cop->op_type = OP_NEXTSTATE;
5237 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5239 cop->op_flags = (U8)flags;
5240 CopHINTS_set(cop, PL_hints);
5242 cop->op_private |= NATIVE_HINTS;
5244 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5245 cop->op_next = (OP*)cop;
5248 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5249 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5251 Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
5253 PL_hints |= HINT_BLOCK_SCOPE;
5254 /* It seems that we need to defer freeing this pointer, as other parts
5255 of the grammar end up wanting to copy it after this op has been
5260 if (PL_parser && PL_parser->copline == NOLINE)
5261 CopLINE_set(cop, CopLINE(PL_curcop));
5263 CopLINE_set(cop, PL_parser->copline);
5265 PL_parser->copline = NOLINE;
5268 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5270 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5272 CopSTASH_set(cop, PL_curstash);
5274 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5275 /* this line can have a breakpoint - store the cop in IV */
5276 AV *av = CopFILEAVx(PL_curcop);
5278 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5279 if (svp && *svp != &PL_sv_undef ) {
5280 (void)SvIOK_on(*svp);
5281 SvIV_set(*svp, PTR2IV(cop));
5286 if (flags & OPf_SPECIAL)
5288 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5292 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5294 Constructs, checks, and returns a logical (flow control) op. I<type>
5295 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5296 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5297 the eight bits of C<op_private>, except that the bit with value 1 is
5298 automatically set. I<first> supplies the expression controlling the
5299 flow, and I<other> supplies the side (alternate) chain of ops; they are
5300 consumed by this function and become part of the constructed op tree.
5306 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5310 PERL_ARGS_ASSERT_NEWLOGOP;
5312 return new_logop(type, flags, &first, &other);
5316 S_search_const(pTHX_ OP *o)
5318 PERL_ARGS_ASSERT_SEARCH_CONST;
5320 switch (o->op_type) {
5324 if (o->op_flags & OPf_KIDS)
5325 return search_const(cUNOPo->op_first);
5332 if (!(o->op_flags & OPf_KIDS))
5334 kid = cLISTOPo->op_first;
5336 switch (kid->op_type) {
5340 kid = kid->op_sibling;
5343 if (kid != cLISTOPo->op_last)
5349 kid = cLISTOPo->op_last;
5351 return search_const(kid);
5359 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5367 int prepend_not = 0;
5369 PERL_ARGS_ASSERT_NEW_LOGOP;
5374 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5375 return newBINOP(type, flags, scalar(first), scalar(other));
5377 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5379 scalarboolean(first);
5380 /* optimize AND and OR ops that have NOTs as children */
5381 if (first->op_type == OP_NOT
5382 && (first->op_flags & OPf_KIDS)
5383 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5384 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5386 if (type == OP_AND || type == OP_OR) {
5392 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5394 prepend_not = 1; /* prepend a NOT op later */
5398 /* search for a constant op that could let us fold the test */
5399 if ((cstop = search_const(first))) {
5400 if (cstop->op_private & OPpCONST_STRICT)
5401 no_bareword_allowed(cstop);
5402 else if ((cstop->op_private & OPpCONST_BARE))
5403 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5404 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5405 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5406 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5408 if (other->op_type == OP_CONST)
5409 other->op_private |= OPpCONST_SHORTCIRCUIT;
5411 OP *newop = newUNOP(OP_NULL, 0, other);
5412 op_getmad(first, newop, '1');
5413 newop->op_targ = type; /* set "was" field */
5417 if (other->op_type == OP_LEAVE)
5418 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5419 else if (other->op_type == OP_MATCH
5420 || other->op_type == OP_SUBST
5421 || other->op_type == OP_TRANSR
5422 || other->op_type == OP_TRANS)
5423 /* Mark the op as being unbindable with =~ */
5424 other->op_flags |= OPf_SPECIAL;
5428 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5429 const OP *o2 = other;
5430 if ( ! (o2->op_type == OP_LIST
5431 && (( o2 = cUNOPx(o2)->op_first))
5432 && o2->op_type == OP_PUSHMARK
5433 && (( o2 = o2->op_sibling)) )
5436 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5437 || o2->op_type == OP_PADHV)
5438 && o2->op_private & OPpLVAL_INTRO
5439 && !(o2->op_private & OPpPAD_STATE))
5441 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5442 "Deprecated use of my() in false conditional");
5446 if (first->op_type == OP_CONST)
5447 first->op_private |= OPpCONST_SHORTCIRCUIT;
5449 first = newUNOP(OP_NULL, 0, first);
5450 op_getmad(other, first, '2');
5451 first->op_targ = type; /* set "was" field */
5458 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5459 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5461 const OP * const k1 = ((UNOP*)first)->op_first;
5462 const OP * const k2 = k1->op_sibling;
5464 switch (first->op_type)
5467 if (k2 && k2->op_type == OP_READLINE
5468 && (k2->op_flags & OPf_STACKED)
5469 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5471 warnop = k2->op_type;
5476 if (k1->op_type == OP_READDIR
5477 || k1->op_type == OP_GLOB
5478 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5479 || k1->op_type == OP_EACH
5480 || k1->op_type == OP_AEACH)
5482 warnop = ((k1->op_type == OP_NULL)
5483 ? (OPCODE)k1->op_targ : k1->op_type);
5488 const line_t oldline = CopLINE(PL_curcop);
5489 CopLINE_set(PL_curcop, PL_parser->copline);
5490 Perl_warner(aTHX_ packWARN(WARN_MISC),
5491 "Value of %s%s can be \"0\"; test with defined()",
5493 ((warnop == OP_READLINE || warnop == OP_GLOB)
5494 ? " construct" : "() operator"));
5495 CopLINE_set(PL_curcop, oldline);
5502 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5503 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5505 NewOp(1101, logop, 1, LOGOP);
5507 logop->op_type = (OPCODE)type;
5508 logop->op_ppaddr = PL_ppaddr[type];
5509 logop->op_first = first;
5510 logop->op_flags = (U8)(flags | OPf_KIDS);
5511 logop->op_other = LINKLIST(other);
5512 logop->op_private = (U8)(1 | (flags >> 8));
5514 /* establish postfix order */
5515 logop->op_next = LINKLIST(first);
5516 first->op_next = (OP*)logop;
5517 first->op_sibling = other;
5519 CHECKOP(type,logop);
5521 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5528 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5530 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5531 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5532 will be set automatically, and, shifted up eight bits, the eight bits of
5533 C<op_private>, except that the bit with value 1 is automatically set.
5534 I<first> supplies the expression selecting between the two branches,
5535 and I<trueop> and I<falseop> supply the branches; they are consumed by
5536 this function and become part of the constructed op tree.
5542 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5550 PERL_ARGS_ASSERT_NEWCONDOP;
5553 return newLOGOP(OP_AND, 0, first, trueop);
5555 return newLOGOP(OP_OR, 0, first, falseop);
5557 scalarboolean(first);
5558 if ((cstop = search_const(first))) {
5559 /* Left or right arm of the conditional? */
5560 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5561 OP *live = left ? trueop : falseop;
5562 OP *const dead = left ? falseop : trueop;
5563 if (cstop->op_private & OPpCONST_BARE &&
5564 cstop->op_private & OPpCONST_STRICT) {
5565 no_bareword_allowed(cstop);
5568 /* This is all dead code when PERL_MAD is not defined. */
5569 live = newUNOP(OP_NULL, 0, live);
5570 op_getmad(first, live, 'C');
5571 op_getmad(dead, live, left ? 'e' : 't');
5576 if (live->op_type == OP_LEAVE)
5577 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5578 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5579 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5580 /* Mark the op as being unbindable with =~ */
5581 live->op_flags |= OPf_SPECIAL;
5584 NewOp(1101, logop, 1, LOGOP);
5585 logop->op_type = OP_COND_EXPR;
5586 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5587 logop->op_first = first;
5588 logop->op_flags = (U8)(flags | OPf_KIDS);
5589 logop->op_private = (U8)(1 | (flags >> 8));
5590 logop->op_other = LINKLIST(trueop);
5591 logop->op_next = LINKLIST(falseop);
5593 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5596 /* establish postfix order */
5597 start = LINKLIST(first);
5598 first->op_next = (OP*)logop;
5600 first->op_sibling = trueop;
5601 trueop->op_sibling = falseop;
5602 o = newUNOP(OP_NULL, 0, (OP*)logop);
5604 trueop->op_next = falseop->op_next = o;
5611 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5613 Constructs and returns a C<range> op, with subordinate C<flip> and
5614 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5615 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5616 for both the C<flip> and C<range> ops, except that the bit with value
5617 1 is automatically set. I<left> and I<right> supply the expressions
5618 controlling the endpoints of the range; they are consumed by this function
5619 and become part of the constructed op tree.
5625 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5634 PERL_ARGS_ASSERT_NEWRANGE;
5636 NewOp(1101, range, 1, LOGOP);
5638 range->op_type = OP_RANGE;
5639 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5640 range->op_first = left;
5641 range->op_flags = OPf_KIDS;
5642 leftstart = LINKLIST(left);
5643 range->op_other = LINKLIST(right);
5644 range->op_private = (U8)(1 | (flags >> 8));
5646 left->op_sibling = right;
5648 range->op_next = (OP*)range;
5649 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5650 flop = newUNOP(OP_FLOP, 0, flip);
5651 o = newUNOP(OP_NULL, 0, flop);
5653 range->op_next = leftstart;
5655 left->op_next = flip;
5656 right->op_next = flop;
5658 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5659 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5660 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5661 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5663 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5664 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5666 /* check barewords before they might be optimized aways */
5667 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5668 no_bareword_allowed(left);
5669 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5670 no_bareword_allowed(right);
5673 if (!flip->op_private || !flop->op_private)
5674 LINKLIST(o); /* blow off optimizer unless constant */
5680 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5682 Constructs, checks, and returns an op tree expressing a loop. This is
5683 only a loop in the control flow through the op tree; it does not have
5684 the heavyweight loop structure that allows exiting the loop by C<last>
5685 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5686 top-level op, except that some bits will be set automatically as required.
5687 I<expr> supplies the expression controlling loop iteration, and I<block>
5688 supplies the body of the loop; they are consumed by this function and
5689 become part of the constructed op tree. I<debuggable> is currently
5690 unused and should always be 1.
5696 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5701 const bool once = block && block->op_flags & OPf_SPECIAL &&
5702 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5704 PERL_UNUSED_ARG(debuggable);
5707 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5708 return block; /* do {} while 0 does once */
5709 if (expr->op_type == OP_READLINE
5710 || expr->op_type == OP_READDIR
5711 || expr->op_type == OP_GLOB
5712 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5713 expr = newUNOP(OP_DEFINED, 0,
5714 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5715 } else if (expr->op_flags & OPf_KIDS) {
5716 const OP * const k1 = ((UNOP*)expr)->op_first;
5717 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5718 switch (expr->op_type) {
5720 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5721 && (k2->op_flags & OPf_STACKED)
5722 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5723 expr = newUNOP(OP_DEFINED, 0, expr);
5727 if (k1 && (k1->op_type == OP_READDIR
5728 || k1->op_type == OP_GLOB
5729 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5730 || k1->op_type == OP_EACH
5731 || k1->op_type == OP_AEACH))
5732 expr = newUNOP(OP_DEFINED, 0, expr);
5738 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5739 * op, in listop. This is wrong. [perl #27024] */
5741 block = newOP(OP_NULL, 0);
5742 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5743 o = new_logop(OP_AND, 0, &expr, &listop);
5746 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5748 if (once && o != listop)
5749 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5752 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5754 o->op_flags |= flags;
5756 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5761 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5763 Constructs, checks, and returns an op tree expressing a C<while> loop.
5764 This is a heavyweight loop, with structure that allows exiting the loop
5765 by C<last> and suchlike.
5767 I<loop> is an optional preconstructed C<enterloop> op to use in the
5768 loop; if it is null then a suitable op will be constructed automatically.
5769 I<expr> supplies the loop's controlling expression. I<block> supplies the
5770 main body of the loop, and I<cont> optionally supplies a C<continue> block
5771 that operates as a second half of the body. All of these optree inputs
5772 are consumed by this function and become part of the constructed op tree.
5774 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5775 op and, shifted up eight bits, the eight bits of C<op_private> for
5776 the C<leaveloop> op, except that (in both cases) some bits will be set
5777 automatically. I<debuggable> is currently unused and should always be 1.
5778 I<has_my> can be supplied as true to force the
5779 loop body to be enclosed in its own scope.
5785 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5786 OP *expr, OP *block, OP *cont, I32 has_my)
5795 PERL_UNUSED_ARG(debuggable);
5798 if (expr->op_type == OP_READLINE
5799 || expr->op_type == OP_READDIR
5800 || expr->op_type == OP_GLOB
5801 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5802 expr = newUNOP(OP_DEFINED, 0,
5803 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5804 } else if (expr->op_flags & OPf_KIDS) {
5805 const OP * const k1 = ((UNOP*)expr)->op_first;
5806 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5807 switch (expr->op_type) {
5809 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5810 && (k2->op_flags & OPf_STACKED)
5811 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5812 expr = newUNOP(OP_DEFINED, 0, expr);
5816 if (k1 && (k1->op_type == OP_READDIR
5817 || k1->op_type == OP_GLOB
5818 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5819 || k1->op_type == OP_EACH
5820 || k1->op_type == OP_AEACH))
5821 expr = newUNOP(OP_DEFINED, 0, expr);
5828 block = newOP(OP_NULL, 0);
5829 else if (cont || has_my) {
5830 block = op_scope(block);
5834 next = LINKLIST(cont);
5837 OP * const unstack = newOP(OP_UNSTACK, 0);
5840 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5844 listop = op_append_list(OP_LINESEQ, block, cont);
5846 redo = LINKLIST(listop);
5850 o = new_logop(OP_AND, 0, &expr, &listop);
5851 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5852 op_free(expr); /* oops, it's a while (0) */
5854 return NULL; /* listop already freed by new_logop */
5857 ((LISTOP*)listop)->op_last->op_next =
5858 (o == listop ? redo : LINKLIST(o));
5864 NewOp(1101,loop,1,LOOP);
5865 loop->op_type = OP_ENTERLOOP;
5866 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5867 loop->op_private = 0;
5868 loop->op_next = (OP*)loop;
5871 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5873 loop->op_redoop = redo;
5874 loop->op_lastop = o;
5875 o->op_private |= loopflags;
5878 loop->op_nextop = next;
5880 loop->op_nextop = o;
5882 o->op_flags |= flags;
5883 o->op_private |= (flags >> 8);
5888 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5890 Constructs, checks, and returns an op tree expressing a C<foreach>
5891 loop (iteration through a list of values). This is a heavyweight loop,
5892 with structure that allows exiting the loop by C<last> and suchlike.
5894 I<sv> optionally supplies the variable that will be aliased to each
5895 item in turn; if null, it defaults to C<$_> (either lexical or global).
5896 I<expr> supplies the list of values to iterate over. I<block> supplies
5897 the main body of the loop, and I<cont> optionally supplies a C<continue>
5898 block that operates as a second half of the body. All of these optree
5899 inputs are consumed by this function and become part of the constructed
5902 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5903 op and, shifted up eight bits, the eight bits of C<op_private> for
5904 the C<leaveloop> op, except that (in both cases) some bits will be set
5911 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5916 PADOFFSET padoff = 0;
5921 PERL_ARGS_ASSERT_NEWFOROP;
5924 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5925 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5926 sv->op_type = OP_RV2GV;
5927 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5929 /* The op_type check is needed to prevent a possible segfault
5930 * if the loop variable is undeclared and 'strict vars' is in
5931 * effect. This is illegal but is nonetheless parsed, so we
5932 * may reach this point with an OP_CONST where we're expecting
5935 if (cUNOPx(sv)->op_first->op_type == OP_GV
5936 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5937 iterpflags |= OPpITER_DEF;
5939 else if (sv->op_type == OP_PADSV) { /* private variable */
5940 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5941 padoff = sv->op_targ;
5951 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5953 SV *const namesv = PAD_COMPNAME_SV(padoff);
5955 const char *const name = SvPV_const(namesv, len);
5957 if (len == 2 && name[0] == '$' && name[1] == '_')
5958 iterpflags |= OPpITER_DEF;
5962 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5963 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5964 sv = newGVOP(OP_GV, 0, PL_defgv);
5969 iterpflags |= OPpITER_DEF;
5971 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5972 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5973 iterflags |= OPf_STACKED;
5975 else if (expr->op_type == OP_NULL &&
5976 (expr->op_flags & OPf_KIDS) &&
5977 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5979 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5980 * set the STACKED flag to indicate that these values are to be
5981 * treated as min/max values by 'pp_iterinit'.
5983 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5984 LOGOP* const range = (LOGOP*) flip->op_first;
5985 OP* const left = range->op_first;
5986 OP* const right = left->op_sibling;
5989 range->op_flags &= ~OPf_KIDS;
5990 range->op_first = NULL;
5992 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5993 listop->op_first->op_next = range->op_next;
5994 left->op_next = range->op_other;
5995 right->op_next = (OP*)listop;
5996 listop->op_next = listop->op_first;
5999 op_getmad(expr,(OP*)listop,'O');
6003 expr = (OP*)(listop);
6005 iterflags |= OPf_STACKED;
6008 expr = op_lvalue(force_list(expr), OP_GREPSTART);
6011 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6012 op_append_elem(OP_LIST, expr, scalar(sv))));
6013 assert(!loop->op_next);
6014 /* for my $x () sets OPpLVAL_INTRO;
6015 * for our $x () sets OPpOUR_INTRO */
6016 loop->op_private = (U8)iterpflags;
6017 #ifdef PL_OP_SLAB_ALLOC
6020 NewOp(1234,tmp,1,LOOP);
6021 Copy(loop,tmp,1,LISTOP);
6022 S_op_destroy(aTHX_ (OP*)loop);
6026 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6028 loop->op_targ = padoff;
6029 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6031 op_getmad(madsv, (OP*)loop, 'v');
6036 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6038 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6039 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6040 determining the target of the op; it is consumed by this function and
6041 become part of the constructed op tree.
6047 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6052 PERL_ARGS_ASSERT_NEWLOOPEX;
6054 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6056 if (type != OP_GOTO || label->op_type == OP_CONST) {
6057 /* "last()" means "last" */
6058 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6059 o = newOP(type, OPf_SPECIAL);
6061 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
6062 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6066 op_getmad(label,o,'L');
6072 /* Check whether it's going to be a goto &function */
6073 if (label->op_type == OP_ENTERSUB
6074 && !(label->op_flags & OPf_STACKED))
6075 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6076 o = newUNOP(type, OPf_STACKED, label);
6078 PL_hints |= HINT_BLOCK_SCOPE;
6082 /* if the condition is a literal array or hash
6083 (or @{ ... } etc), make a reference to it.
6086 S_ref_array_or_hash(pTHX_ OP *cond)
6089 && (cond->op_type == OP_RV2AV
6090 || cond->op_type == OP_PADAV
6091 || cond->op_type == OP_RV2HV
6092 || cond->op_type == OP_PADHV))
6094 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6097 && (cond->op_type == OP_ASLICE
6098 || cond->op_type == OP_HSLICE)) {
6100 /* anonlist now needs a list from this op, was previously used in
6102 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6103 cond->op_flags |= OPf_WANT_LIST;
6105 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6112 /* These construct the optree fragments representing given()
6115 entergiven and enterwhen are LOGOPs; the op_other pointer
6116 points up to the associated leave op. We need this so we
6117 can put it in the context and make break/continue work.
6118 (Also, of course, pp_enterwhen will jump straight to
6119 op_other if the match fails.)
6123 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6124 I32 enter_opcode, I32 leave_opcode,
6125 PADOFFSET entertarg)
6131 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6133 NewOp(1101, enterop, 1, LOGOP);
6134 enterop->op_type = (Optype)enter_opcode;
6135 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6136 enterop->op_flags = (U8) OPf_KIDS;
6137 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6138 enterop->op_private = 0;
6140 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6143 enterop->op_first = scalar(cond);
6144 cond->op_sibling = block;
6146 o->op_next = LINKLIST(cond);
6147 cond->op_next = (OP *) enterop;
6150 /* This is a default {} block */
6151 enterop->op_first = block;
6152 enterop->op_flags |= OPf_SPECIAL;
6153 o ->op_flags |= OPf_SPECIAL;
6155 o->op_next = (OP *) enterop;
6158 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6159 entergiven and enterwhen both
6162 enterop->op_next = LINKLIST(block);
6163 block->op_next = enterop->op_other = o;
6168 /* Does this look like a boolean operation? For these purposes
6169 a boolean operation is:
6170 - a subroutine call [*]
6171 - a logical connective
6172 - a comparison operator
6173 - a filetest operator, with the exception of -s -M -A -C
6174 - defined(), exists() or eof()
6175 - /$re/ or $foo =~ /$re/
6177 [*] possibly surprising
6180 S_looks_like_bool(pTHX_ const OP *o)
6184 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6186 switch(o->op_type) {
6189 return looks_like_bool(cLOGOPo->op_first);
6193 looks_like_bool(cLOGOPo->op_first)
6194 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6199 o->op_flags & OPf_KIDS
6200 && looks_like_bool(cUNOPo->op_first));
6204 case OP_NOT: case OP_XOR:
6206 case OP_EQ: case OP_NE: case OP_LT:
6207 case OP_GT: case OP_LE: case OP_GE:
6209 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6210 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6212 case OP_SEQ: case OP_SNE: case OP_SLT:
6213 case OP_SGT: case OP_SLE: case OP_SGE:
6217 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6218 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6219 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6220 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6221 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6222 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6223 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6224 case OP_FTTEXT: case OP_FTBINARY:
6226 case OP_DEFINED: case OP_EXISTS:
6227 case OP_MATCH: case OP_EOF:
6234 /* Detect comparisons that have been optimized away */
6235 if (cSVOPo->op_sv == &PL_sv_yes
6236 || cSVOPo->op_sv == &PL_sv_no)
6249 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6251 Constructs, checks, and returns an op tree expressing a C<given> block.
6252 I<cond> supplies the expression that will be locally assigned to a lexical
6253 variable, and I<block> supplies the body of the C<given> construct; they
6254 are consumed by this function and become part of the constructed op tree.
6255 I<defsv_off> is the pad offset of the scalar lexical variable that will
6262 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6265 PERL_ARGS_ASSERT_NEWGIVENOP;
6266 return newGIVWHENOP(
6267 ref_array_or_hash(cond),
6269 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6274 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6276 Constructs, checks, and returns an op tree expressing a C<when> block.
6277 I<cond> supplies the test expression, and I<block> supplies the block
6278 that will be executed if the test evaluates to true; they are consumed
6279 by this function and become part of the constructed op tree. I<cond>
6280 will be interpreted DWIMically, often as a comparison against C<$_>,
6281 and may be null to generate a C<default> block.
6287 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6289 const bool cond_llb = (!cond || looks_like_bool(cond));
6292 PERL_ARGS_ASSERT_NEWWHENOP;
6297 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6299 scalar(ref_array_or_hash(cond)));
6302 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6306 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6307 const STRLEN len, const U32 flags)
6309 const char * const cvp = CvPROTO(cv);
6310 const STRLEN clen = CvPROTOLEN(cv);
6312 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6314 if (((!p != !cvp) /* One has prototype, one has not. */
6316 (flags & SVf_UTF8) == SvUTF8(cv)
6317 ? len != clen || memNE(cvp, p, len)
6319 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6321 : bytes_cmp_utf8((const U8 *)p, len,
6322 (const U8 *)cvp, clen)
6326 && ckWARN_d(WARN_PROTOTYPE)) {
6327 SV* const msg = sv_newmortal();
6331 gv_efullname3(name = sv_newmortal(), gv, NULL);
6332 sv_setpvs(msg, "Prototype mismatch:");
6334 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6336 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6337 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6340 sv_catpvs(msg, ": none");
6341 sv_catpvs(msg, " vs ");
6343 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6345 sv_catpvs(msg, "none");
6346 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6350 static void const_sv_xsub(pTHX_ CV* cv);
6354 =head1 Optree Manipulation Functions
6356 =for apidoc cv_const_sv
6358 If C<cv> is a constant sub eligible for inlining. returns the constant
6359 value returned by the sub. Otherwise, returns NULL.
6361 Constant subs can be created with C<newCONSTSUB> or as described in
6362 L<perlsub/"Constant Functions">.
6367 Perl_cv_const_sv(pTHX_ const CV *const cv)
6369 PERL_UNUSED_CONTEXT;
6372 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6374 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6377 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6378 * Can be called in 3 ways:
6381 * look for a single OP_CONST with attached value: return the value
6383 * cv && CvCLONE(cv) && !CvCONST(cv)
6385 * examine the clone prototype, and if contains only a single
6386 * OP_CONST referencing a pad const, or a single PADSV referencing
6387 * an outer lexical, return a non-zero value to indicate the CV is
6388 * a candidate for "constizing" at clone time
6392 * We have just cloned an anon prototype that was marked as a const
6393 * candidate. Try to grab the current value, and in the case of
6394 * PADSV, ignore it if it has multiple references. Return the value.
6398 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6409 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6410 o = cLISTOPo->op_first->op_sibling;
6412 for (; o; o = o->op_next) {
6413 const OPCODE type = o->op_type;
6415 if (sv && o->op_next == o)
6417 if (o->op_next != o) {
6418 if (type == OP_NEXTSTATE
6419 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6420 || type == OP_PUSHMARK)
6422 if (type == OP_DBSTATE)
6425 if (type == OP_LEAVESUB || type == OP_RETURN)
6429 if (type == OP_CONST && cSVOPo->op_sv)
6431 else if (cv && type == OP_CONST) {
6432 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6436 else if (cv && type == OP_PADSV) {
6437 if (CvCONST(cv)) { /* newly cloned anon */
6438 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6439 /* the candidate should have 1 ref from this pad and 1 ref
6440 * from the parent */
6441 if (!sv || SvREFCNT(sv) != 2)
6448 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6449 sv = &PL_sv_undef; /* an arbitrary non-null value */
6464 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6467 /* This would be the return value, but the return cannot be reached. */
6468 OP* pegop = newOP(OP_NULL, 0);
6471 PERL_UNUSED_ARG(floor);
6481 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6483 NORETURN_FUNCTION_END;
6488 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6493 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6495 register CV *cv = NULL;
6497 /* If the subroutine has no body, no attributes, and no builtin attributes
6498 then it's just a sub declaration, and we may be able to get away with
6499 storing with a placeholder scalar in the symbol table, rather than a
6500 full GV and CV. If anything is present then it will take a full CV to
6502 const I32 gv_fetch_flags
6503 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6505 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6507 const char * const name = o ? SvPV_const(cSVOPo->op_sv, namlen) : NULL;
6509 bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
6512 assert(proto->op_type == OP_CONST);
6513 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6514 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6520 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6522 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6523 SV * const sv = sv_newmortal();
6524 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6525 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6526 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6527 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6529 } else if (PL_curstash) {
6530 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6533 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6537 if (!PL_madskills) {
6546 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6547 maximum a prototype before. */
6548 if (SvTYPE(gv) > SVt_NULL) {
6549 if (!SvPOK((const SV *)gv)
6550 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6552 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6554 cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
6557 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6558 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
6561 sv_setiv(MUTABLE_SV(gv), -1);
6563 SvREFCNT_dec(PL_compcv);
6564 cv = PL_compcv = NULL;
6568 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6570 if (!block || !ps || *ps || attrs
6571 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6573 || block->op_type == OP_NULL
6578 const_sv = op_const_sv(block, NULL);
6581 const bool exists = CvROOT(cv) || CvXSUB(cv);
6583 /* if the subroutine doesn't exist and wasn't pre-declared
6584 * with a prototype, assume it will be AUTOLOADed,
6585 * skipping the prototype check
6587 if (exists || SvPOK(cv))
6588 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
6589 /* already defined (or promised)? */
6590 if (exists || GvASSUMECV(gv)) {
6593 || block->op_type == OP_NULL
6596 if (CvFLAGS(PL_compcv)) {
6597 /* might have had built-in attrs applied */
6598 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6599 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6600 && ckWARN(WARN_MISC))
6601 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6603 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6604 & ~(CVf_LVALUE * pureperl));
6606 if (attrs) goto attrs;
6607 /* just a "sub foo;" when &foo is already defined */
6608 SAVEFREESV(PL_compcv);
6613 && block->op_type != OP_NULL
6616 const line_t oldline = CopLINE(PL_curcop);
6617 if (PL_parser && PL_parser->copline != NOLINE)
6618 CopLINE_set(PL_curcop, PL_parser->copline);
6619 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
6620 CopLINE_set(PL_curcop, oldline);
6622 if (!PL_minus_c) /* keep old one around for madskills */
6625 /* (PL_madskills unset in used file.) */
6634 SvREFCNT_inc_simple_void_NN(const_sv);
6636 assert(!CvROOT(cv) && !CvCONST(cv));
6637 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6638 CvXSUBANY(cv).any_ptr = const_sv;
6639 CvXSUB(cv) = const_sv_xsub;
6645 cv = newCONSTSUB_flags(
6646 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
6651 (CvGV(cv) && GvSTASH(CvGV(cv)))
6656 if (HvENAME_HEK(stash))
6657 mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
6661 SvREFCNT_dec(PL_compcv);
6665 if (cv) { /* must reuse cv if autoloaded */
6666 /* transfer PL_compcv to cv */
6669 && block->op_type != OP_NULL
6672 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6673 AV *const temp_av = CvPADLIST(cv);
6674 CV *const temp_cv = CvOUTSIDE(cv);
6676 assert(!CvWEAKOUTSIDE(cv));
6677 assert(!CvCVGV_RC(cv));
6678 assert(CvGV(cv) == gv);
6681 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6682 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6683 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6684 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6685 CvOUTSIDE(PL_compcv) = temp_cv;
6686 CvPADLIST(PL_compcv) = temp_av;
6688 if (CvFILE(cv) && CvDYNFILE(cv)) {
6689 Safefree(CvFILE(cv));
6691 CvFILE_set_from_cop(cv, PL_curcop);
6692 CvSTASH_set(cv, PL_curstash);
6694 /* inner references to PL_compcv must be fixed up ... */
6695 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6696 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6697 ++PL_sub_generation;
6700 /* Might have had built-in attributes applied -- propagate them. */
6701 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6703 /* ... before we throw it away */
6704 SvREFCNT_dec(PL_compcv);
6712 if (strEQ(name, "import")) {
6713 PL_formfeed = MUTABLE_SV(cv);
6714 /* diag_listed_as: SKIPME */
6715 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6719 if (HvENAME_HEK(GvSTASH(gv)))
6720 /* sub Foo::bar { (shift)+1 } */
6721 mro_method_changed_in(GvSTASH(gv));
6726 CvFILE_set_from_cop(cv, PL_curcop);
6727 CvSTASH_set(cv, PL_curstash);
6731 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6732 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
6735 if (PL_parser && PL_parser->error_count) {
6739 const char *s = strrchr(name, ':');
6741 if (strEQ(s, "BEGIN")) {
6742 const char not_safe[] =
6743 "BEGIN not safe after errors--compilation aborted";
6744 if (PL_in_eval & EVAL_KEEPERR)
6745 Perl_croak(aTHX_ not_safe);
6747 /* force display of errors found but not reported */
6748 sv_catpv(ERRSV, not_safe);
6749 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6758 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6759 the debugger could be able to set a breakpoint in, so signal to
6760 pp_entereval that it should not throw away any saved lines at scope
6763 PL_breakable_sub_gen++;
6764 /* This makes sub {}; work as expected. */
6765 if (block->op_type == OP_STUB) {
6766 OP* const newblock = newSTATEOP(0, NULL, 0);
6768 op_getmad(block,newblock,'B');
6774 else block->op_attached = 1;
6775 CvROOT(cv) = CvLVALUE(cv)
6776 ? newUNOP(OP_LEAVESUBLV, 0,
6777 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6778 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6779 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6780 OpREFCNT_set(CvROOT(cv), 1);
6781 CvSTART(cv) = LINKLIST(CvROOT(cv));
6782 CvROOT(cv)->op_next = 0;
6783 CALL_PEEP(CvSTART(cv));
6784 finalize_optree(CvROOT(cv));
6786 /* now that optimizer has done its work, adjust pad values */
6788 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6791 assert(!CvCONST(cv));
6792 if (ps && !*ps && op_const_sv(block, cv))
6798 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6799 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6800 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6803 if (block && has_name) {
6804 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6805 SV * const tmpstr = sv_newmortal();
6806 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6807 GV_ADDMULTI, SVt_PVHV);
6809 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6812 (long)CopLINE(PL_curcop));
6813 gv_efullname3(tmpstr, gv, NULL);
6814 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6815 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
6816 hv = GvHVn(db_postponed);
6817 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
6818 CV * const pcv = GvCV(db_postponed);
6824 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6829 if (name && ! (PL_parser && PL_parser->error_count))
6830 process_special_blocks(name, gv, cv);
6835 PL_parser->copline = NOLINE;
6841 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6844 const char *const colon = strrchr(fullname,':');
6845 const char *const name = colon ? colon + 1 : fullname;
6847 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6850 if (strEQ(name, "BEGIN")) {
6851 const I32 oldscope = PL_scopestack_ix;
6853 SAVECOPFILE(&PL_compiling);
6854 SAVECOPLINE(&PL_compiling);
6855 SAVEVPTR(PL_curcop);
6857 DEBUG_x( dump_sub(gv) );
6858 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6859 GvCV_set(gv,0); /* cv has been hijacked */
6860 call_list(oldscope, PL_beginav);
6862 CopHINTS_set(&PL_compiling, PL_hints);
6869 if strEQ(name, "END") {
6870 DEBUG_x( dump_sub(gv) );
6871 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6874 } else if (*name == 'U') {
6875 if (strEQ(name, "UNITCHECK")) {
6876 /* It's never too late to run a unitcheck block */
6877 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6881 } else if (*name == 'C') {
6882 if (strEQ(name, "CHECK")) {
6884 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6885 "Too late to run CHECK block");
6886 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6890 } else if (*name == 'I') {
6891 if (strEQ(name, "INIT")) {
6893 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6894 "Too late to run INIT block");
6895 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6901 DEBUG_x( dump_sub(gv) );
6902 GvCV_set(gv,0); /* cv has been hijacked */
6907 =for apidoc newCONSTSUB
6909 See L</newCONSTSUB_flags>.
6915 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6917 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
6921 =for apidoc newCONSTSUB_flags
6923 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6924 eligible for inlining at compile-time.
6926 Currently, the only useful value for C<flags> is SVf_UTF8.
6928 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6929 which won't be called if used as a destructor, but will suppress the overhead
6930 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6937 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
6943 const char *const file = CopFILE(PL_curcop);
6945 SV *const temp_sv = CopFILESV(PL_curcop);
6946 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6951 if (IN_PERL_RUNTIME) {
6952 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6953 * an op shared between threads. Use a non-shared COP for our
6955 SAVEVPTR(PL_curcop);
6956 SAVECOMPILEWARNINGS();
6957 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6958 PL_curcop = &PL_compiling;
6960 SAVECOPLINE(PL_curcop);
6961 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6964 PL_hints &= ~HINT_BLOCK_SCOPE;
6967 SAVEGENERICSV(PL_curstash);
6968 SAVECOPSTASH(PL_curcop);
6969 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
6970 CopSTASH_set(PL_curcop,stash);
6973 /* file becomes the CvFILE. For an XS, it's usually static storage,
6974 and so doesn't get free()d. (It's expected to be from the C pre-
6975 processor __FILE__ directive). But we need a dynamically allocated one,
6976 and we need it to get freed. */
6977 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
6978 &sv, XS_DYNAMIC_FILENAME | flags);
6979 CvXSUBANY(cv).any_ptr = sv;
6984 CopSTASH_free(PL_curcop);
6992 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6993 const char *const filename, const char *const proto,
6996 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6997 return newXS_len_flags(
6998 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7003 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7004 XSUBADDR_t subaddr, const char *const filename,
7005 const char *const proto, SV **const_svp,
7010 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7013 GV * const gv = name
7015 name,len,GV_ADDMULTI|flags,SVt_PVCV
7018 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
7019 GV_ADDMULTI | flags, SVt_PVCV);
7022 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7024 if ((cv = (name ? GvCV(gv) : NULL))) {
7026 /* just a cached method */
7030 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7031 /* already defined (or promised) */
7032 /* Redundant check that allows us to avoid creating an SV
7033 most of the time: */
7034 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7035 const line_t oldline = CopLINE(PL_curcop);
7036 if (PL_parser && PL_parser->copline != NOLINE)
7037 CopLINE_set(PL_curcop, PL_parser->copline);
7038 report_redefined_cv(newSVpvn_flags(
7039 name,len,(flags&SVf_UTF8)|SVs_TEMP
7042 CopLINE_set(PL_curcop, oldline);
7049 if (cv) /* must reuse cv if autoloaded */
7052 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7056 if (HvENAME_HEK(GvSTASH(gv)))
7057 mro_method_changed_in(GvSTASH(gv)); /* newXS */
7063 (void)gv_fetchfile(filename);
7064 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7065 an external constant string */
7066 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7068 CvXSUB(cv) = subaddr;
7071 process_special_blocks(name, gv, cv);
7074 if (flags & XS_DYNAMIC_FILENAME) {
7075 CvFILE(cv) = savepv(filename);
7078 sv_setpv(MUTABLE_SV(cv), proto);
7083 =for apidoc U||newXS
7085 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7086 static storage, as it is used directly as CvFILE(), without a copy being made.
7092 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7094 PERL_ARGS_ASSERT_NEWXS;
7095 return newXS_flags(name, subaddr, filename, NULL, 0);
7103 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7108 OP* pegop = newOP(OP_NULL, 0);
7112 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7113 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7116 if ((cv = GvFORM(gv))) {
7117 if (ckWARN(WARN_REDEFINE)) {
7118 const line_t oldline = CopLINE(PL_curcop);
7119 if (PL_parser && PL_parser->copline != NOLINE)
7120 CopLINE_set(PL_curcop, PL_parser->copline);
7122 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7123 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7125 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7126 "Format STDOUT redefined");
7128 CopLINE_set(PL_curcop, oldline);
7135 CvFILE_set_from_cop(cv, PL_curcop);
7138 pad_tidy(padtidy_FORMAT);
7139 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7140 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7141 OpREFCNT_set(CvROOT(cv), 1);
7142 CvSTART(cv) = LINKLIST(CvROOT(cv));
7143 CvROOT(cv)->op_next = 0;
7144 CALL_PEEP(CvSTART(cv));
7145 finalize_optree(CvROOT(cv));
7147 op_getmad(o,pegop,'n');
7148 op_getmad_weak(block, pegop, 'b');
7153 PL_parser->copline = NOLINE;
7161 Perl_newANONLIST(pTHX_ OP *o)
7163 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7167 Perl_newANONHASH(pTHX_ OP *o)
7169 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7173 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7175 return newANONATTRSUB(floor, proto, NULL, block);
7179 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7181 return newUNOP(OP_REFGEN, 0,
7182 newSVOP(OP_ANONCODE, 0,
7183 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7187 Perl_oopsAV(pTHX_ OP *o)
7191 PERL_ARGS_ASSERT_OOPSAV;
7193 switch (o->op_type) {
7195 o->op_type = OP_PADAV;
7196 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7197 return ref(o, OP_RV2AV);
7200 o->op_type = OP_RV2AV;
7201 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7206 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7213 Perl_oopsHV(pTHX_ OP *o)
7217 PERL_ARGS_ASSERT_OOPSHV;
7219 switch (o->op_type) {
7222 o->op_type = OP_PADHV;
7223 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7224 return ref(o, OP_RV2HV);
7228 o->op_type = OP_RV2HV;
7229 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7234 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7241 Perl_newAVREF(pTHX_ OP *o)
7245 PERL_ARGS_ASSERT_NEWAVREF;
7247 if (o->op_type == OP_PADANY) {
7248 o->op_type = OP_PADAV;
7249 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7252 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7253 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7254 "Using an array as a reference is deprecated");
7256 return newUNOP(OP_RV2AV, 0, scalar(o));
7260 Perl_newGVREF(pTHX_ I32 type, OP *o)
7262 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7263 return newUNOP(OP_NULL, 0, o);
7264 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7268 Perl_newHVREF(pTHX_ OP *o)
7272 PERL_ARGS_ASSERT_NEWHVREF;
7274 if (o->op_type == OP_PADANY) {
7275 o->op_type = OP_PADHV;
7276 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7279 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7280 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7281 "Using a hash as a reference is deprecated");
7283 return newUNOP(OP_RV2HV, 0, scalar(o));
7287 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7289 return newUNOP(OP_RV2CV, flags, scalar(o));
7293 Perl_newSVREF(pTHX_ OP *o)
7297 PERL_ARGS_ASSERT_NEWSVREF;
7299 if (o->op_type == OP_PADANY) {
7300 o->op_type = OP_PADSV;
7301 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7304 return newUNOP(OP_RV2SV, 0, scalar(o));
7307 /* Check routines. See the comments at the top of this file for details
7308 * on when these are called */
7311 Perl_ck_anoncode(pTHX_ OP *o)
7313 PERL_ARGS_ASSERT_CK_ANONCODE;
7315 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7317 cSVOPo->op_sv = NULL;
7322 Perl_ck_bitop(pTHX_ OP *o)
7326 PERL_ARGS_ASSERT_CK_BITOP;
7328 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7329 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7330 && (o->op_type == OP_BIT_OR
7331 || o->op_type == OP_BIT_AND
7332 || o->op_type == OP_BIT_XOR))
7334 const OP * const left = cBINOPo->op_first;
7335 const OP * const right = left->op_sibling;
7336 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7337 (left->op_flags & OPf_PARENS) == 0) ||
7338 (OP_IS_NUMCOMPARE(right->op_type) &&
7339 (right->op_flags & OPf_PARENS) == 0))
7340 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7341 "Possible precedence problem on bitwise %c operator",
7342 o->op_type == OP_BIT_OR ? '|'
7343 : o->op_type == OP_BIT_AND ? '&' : '^'
7349 PERL_STATIC_INLINE bool
7350 is_dollar_bracket(pTHX_ const OP * const o)
7353 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
7354 && (kid = cUNOPx(o)->op_first)
7355 && kid->op_type == OP_GV
7356 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
7360 Perl_ck_cmp(pTHX_ OP *o)
7362 PERL_ARGS_ASSERT_CK_CMP;
7363 if (ckWARN(WARN_SYNTAX)) {
7364 const OP *kid = cUNOPo->op_first;
7366 is_dollar_bracket(aTHX_ kid)
7367 || ((kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
7369 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7370 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
7376 Perl_ck_concat(pTHX_ OP *o)
7378 const OP * const kid = cUNOPo->op_first;
7380 PERL_ARGS_ASSERT_CK_CONCAT;
7381 PERL_UNUSED_CONTEXT;
7383 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7384 !(kUNOP->op_first->op_flags & OPf_MOD))
7385 o->op_flags |= OPf_STACKED;
7390 Perl_ck_spair(pTHX_ OP *o)
7394 PERL_ARGS_ASSERT_CK_SPAIR;
7396 if (o->op_flags & OPf_KIDS) {
7399 const OPCODE type = o->op_type;
7400 o = modkids(ck_fun(o), type);
7401 kid = cUNOPo->op_first;
7402 newop = kUNOP->op_first->op_sibling;
7404 const OPCODE type = newop->op_type;
7405 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7406 type == OP_PADAV || type == OP_PADHV ||
7407 type == OP_RV2AV || type == OP_RV2HV)
7411 op_getmad(kUNOP->op_first,newop,'K');
7413 op_free(kUNOP->op_first);
7415 kUNOP->op_first = newop;
7417 o->op_ppaddr = PL_ppaddr[++o->op_type];
7422 Perl_ck_delete(pTHX_ OP *o)
7424 PERL_ARGS_ASSERT_CK_DELETE;
7428 if (o->op_flags & OPf_KIDS) {
7429 OP * const kid = cUNOPo->op_first;
7430 switch (kid->op_type) {
7432 o->op_flags |= OPf_SPECIAL;
7435 o->op_private |= OPpSLICE;
7438 o->op_flags |= OPf_SPECIAL;
7443 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7446 if (kid->op_private & OPpLVAL_INTRO)
7447 o->op_private |= OPpLVAL_INTRO;
7454 Perl_ck_die(pTHX_ OP *o)
7456 PERL_ARGS_ASSERT_CK_DIE;
7459 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7465 Perl_ck_eof(pTHX_ OP *o)
7469 PERL_ARGS_ASSERT_CK_EOF;
7471 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');
7488 Perl_ck_eval(pTHX_ OP *o)
7492 PERL_ARGS_ASSERT_CK_EVAL;
7494 PL_hints |= HINT_BLOCK_SCOPE;
7495 if (o->op_flags & OPf_KIDS) {
7496 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7499 o->op_flags &= ~OPf_KIDS;
7502 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7508 cUNOPo->op_first = 0;
7513 NewOp(1101, enter, 1, LOGOP);
7514 enter->op_type = OP_ENTERTRY;
7515 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7516 enter->op_private = 0;
7518 /* establish postfix order */
7519 enter->op_next = (OP*)enter;
7521 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7522 o->op_type = OP_LEAVETRY;
7523 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7524 enter->op_other = o;
7525 op_getmad(oldo,o,'O');
7534 const U8 priv = o->op_private;
7540 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
7541 op_getmad(oldo,o,'O');
7543 o->op_targ = (PADOFFSET)PL_hints;
7544 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7545 if ((PL_hints & HINT_LOCALIZE_HH) != 0
7546 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
7547 /* Store a copy of %^H that pp_entereval can pick up. */
7548 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7549 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7550 cUNOPo->op_first->op_sibling = hhop;
7551 o->op_private |= OPpEVAL_HAS_HH;
7553 if (!(o->op_private & OPpEVAL_BYTES)
7554 && FEATURE_IS_ENABLED("unieval"))
7555 o->op_private |= OPpEVAL_UNICODE;
7561 Perl_ck_exit(pTHX_ OP *o)
7563 PERL_ARGS_ASSERT_CK_EXIT;
7566 HV * const table = GvHV(PL_hintgv);
7568 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7569 if (svp && *svp && SvTRUE(*svp))
7570 o->op_private |= OPpEXIT_VMSISH;
7572 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7578 Perl_ck_exec(pTHX_ OP *o)
7580 PERL_ARGS_ASSERT_CK_EXEC;
7582 if (o->op_flags & OPf_STACKED) {
7585 kid = cUNOPo->op_first->op_sibling;
7586 if (kid->op_type == OP_RV2GV)
7595 Perl_ck_exists(pTHX_ OP *o)
7599 PERL_ARGS_ASSERT_CK_EXISTS;
7602 if (o->op_flags & OPf_KIDS) {
7603 OP * const kid = cUNOPo->op_first;
7604 if (kid->op_type == OP_ENTERSUB) {
7605 (void) ref(kid, o->op_type);
7606 if (kid->op_type != OP_RV2CV
7607 && !(PL_parser && PL_parser->error_count))
7608 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7610 o->op_private |= OPpEXISTS_SUB;
7612 else if (kid->op_type == OP_AELEM)
7613 o->op_flags |= OPf_SPECIAL;
7614 else if (kid->op_type != OP_HELEM)
7615 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7623 Perl_ck_rvconst(pTHX_ register OP *o)
7626 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7628 PERL_ARGS_ASSERT_CK_RVCONST;
7630 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7631 if (o->op_type == OP_RV2CV)
7632 o->op_private &= ~1;
7634 if (kid->op_type == OP_CONST) {
7637 SV * const kidsv = kid->op_sv;
7639 /* Is it a constant from cv_const_sv()? */
7640 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7641 SV * const rsv = SvRV(kidsv);
7642 const svtype type = SvTYPE(rsv);
7643 const char *badtype = NULL;
7645 switch (o->op_type) {
7647 if (type > SVt_PVMG)
7648 badtype = "a SCALAR";
7651 if (type != SVt_PVAV)
7652 badtype = "an ARRAY";
7655 if (type != SVt_PVHV)
7659 if (type != SVt_PVCV)
7664 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7667 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7668 const char *badthing;
7669 switch (o->op_type) {
7671 badthing = "a SCALAR";
7674 badthing = "an ARRAY";
7677 badthing = "a HASH";
7685 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7686 SVfARG(kidsv), badthing);
7689 * This is a little tricky. We only want to add the symbol if we
7690 * didn't add it in the lexer. Otherwise we get duplicate strict
7691 * warnings. But if we didn't add it in the lexer, we must at
7692 * least pretend like we wanted to add it even if it existed before,
7693 * or we get possible typo warnings. OPpCONST_ENTERED says
7694 * whether the lexer already added THIS instance of this symbol.
7696 iscv = (o->op_type == OP_RV2CV) * 2;
7698 gv = gv_fetchsv(kidsv,
7699 iscv | !(kid->op_private & OPpCONST_ENTERED),
7702 : o->op_type == OP_RV2SV
7704 : o->op_type == OP_RV2AV
7706 : o->op_type == OP_RV2HV
7709 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7711 kid->op_type = OP_GV;
7712 SvREFCNT_dec(kid->op_sv);
7714 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7715 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7716 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7718 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7720 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7722 kid->op_private = 0;
7723 kid->op_ppaddr = PL_ppaddr[OP_GV];
7724 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7732 Perl_ck_ftst(pTHX_ OP *o)
7735 const I32 type = o->op_type;
7737 PERL_ARGS_ASSERT_CK_FTST;
7739 if (o->op_flags & OPf_REF) {
7742 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7743 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7744 const OPCODE kidtype = kid->op_type;
7746 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7747 OP * const newop = newGVOP(type, OPf_REF,
7748 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7750 op_getmad(o,newop,'O');
7756 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7757 o->op_private |= OPpFT_ACCESS;
7758 if (PL_check[kidtype] == Perl_ck_ftst
7759 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7760 o->op_private |= OPpFT_STACKED;
7761 kid->op_private |= OPpFT_STACKING;
7770 if (type == OP_FTTTY)
7771 o = newGVOP(type, OPf_REF, PL_stdingv);
7773 o = newUNOP(type, 0, newDEFSVOP());
7774 op_getmad(oldo,o,'O');
7780 Perl_ck_fun(pTHX_ OP *o)
7783 const int type = o->op_type;
7784 register I32 oa = PL_opargs[type] >> OASHIFT;
7786 PERL_ARGS_ASSERT_CK_FUN;
7788 if (o->op_flags & OPf_STACKED) {
7789 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7792 return no_fh_allowed(o);
7795 if (o->op_flags & OPf_KIDS) {
7796 OP **tokid = &cLISTOPo->op_first;
7797 register OP *kid = cLISTOPo->op_first;
7800 bool seen_optional = FALSE;
7802 if (kid->op_type == OP_PUSHMARK ||
7803 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7805 tokid = &kid->op_sibling;
7806 kid = kid->op_sibling;
7808 if (kid && kid->op_type == OP_COREARGS) {
7809 bool optional = FALSE;
7812 if (oa & OA_OPTIONAL) optional = TRUE;
7815 if (optional) o->op_private |= numargs;
7820 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
7821 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
7822 *tokid = kid = newDEFSVOP();
7823 seen_optional = TRUE;
7828 sibl = kid->op_sibling;
7830 if (!sibl && kid->op_type == OP_STUB) {
7837 /* list seen where single (scalar) arg expected? */
7838 if (numargs == 1 && !(oa >> 4)
7839 && kid->op_type == OP_LIST && type != OP_SCALAR)
7841 return too_many_arguments(o,PL_op_desc[type]);
7854 if ((type == OP_PUSH || type == OP_UNSHIFT)
7855 && !kid->op_sibling)
7856 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7857 "Useless use of %s with no values",
7860 if (kid->op_type == OP_CONST &&
7861 (kid->op_private & OPpCONST_BARE))
7863 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7864 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7865 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7866 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7867 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7869 op_getmad(kid,newop,'K');
7874 kid->op_sibling = sibl;
7877 else if (kid->op_type == OP_CONST
7878 && ( !SvROK(cSVOPx_sv(kid))
7879 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7881 bad_type(numargs, "array", PL_op_desc[type], kid);
7882 /* Defer checks to run-time if we have a scalar arg */
7883 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7884 op_lvalue(kid, type);
7888 if (kid->op_type == OP_CONST &&
7889 (kid->op_private & OPpCONST_BARE))
7891 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7892 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7893 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7894 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7895 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7897 op_getmad(kid,newop,'K');
7902 kid->op_sibling = sibl;
7905 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7906 bad_type(numargs, "hash", PL_op_desc[type], kid);
7907 op_lvalue(kid, type);
7911 OP * const newop = newUNOP(OP_NULL, 0, kid);
7912 kid->op_sibling = 0;
7914 newop->op_next = newop;
7916 kid->op_sibling = sibl;
7921 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7922 if (kid->op_type == OP_CONST &&
7923 (kid->op_private & OPpCONST_BARE))
7925 OP * const newop = newGVOP(OP_GV, 0,
7926 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7927 if (!(o->op_private & 1) && /* if not unop */
7928 kid == cLISTOPo->op_last)
7929 cLISTOPo->op_last = newop;
7931 op_getmad(kid,newop,'K');
7937 else if (kid->op_type == OP_READLINE) {
7938 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7939 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7942 I32 flags = OPf_SPECIAL;
7946 /* is this op a FH constructor? */
7947 if (is_handle_constructor(o,numargs)) {
7948 const char *name = NULL;
7951 bool want_dollar = TRUE;
7954 /* Set a flag to tell rv2gv to vivify
7955 * need to "prove" flag does not mean something
7956 * else already - NI-S 1999/05/07
7959 if (kid->op_type == OP_PADSV) {
7961 = PAD_COMPNAME_SV(kid->op_targ);
7962 name = SvPV_const(namesv, len);
7963 name_utf8 = SvUTF8(namesv);
7965 else if (kid->op_type == OP_RV2SV
7966 && kUNOP->op_first->op_type == OP_GV)
7968 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7970 len = GvNAMELEN(gv);
7971 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
7973 else if (kid->op_type == OP_AELEM
7974 || kid->op_type == OP_HELEM)
7977 OP *op = ((BINOP*)kid)->op_first;
7981 const char * const a =
7982 kid->op_type == OP_AELEM ?
7984 if (((op->op_type == OP_RV2AV) ||
7985 (op->op_type == OP_RV2HV)) &&
7986 (firstop = ((UNOP*)op)->op_first) &&
7987 (firstop->op_type == OP_GV)) {
7988 /* packagevar $a[] or $h{} */
7989 GV * const gv = cGVOPx_gv(firstop);
7997 else if (op->op_type == OP_PADAV
7998 || op->op_type == OP_PADHV) {
7999 /* lexicalvar $a[] or $h{} */
8000 const char * const padname =
8001 PAD_COMPNAME_PV(op->op_targ);
8010 name = SvPV_const(tmpstr, len);
8011 name_utf8 = SvUTF8(tmpstr);
8016 name = "__ANONIO__";
8018 want_dollar = FALSE;
8020 op_lvalue(kid, type);
8024 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
8025 namesv = PAD_SVl(targ);
8026 SvUPGRADE(namesv, SVt_PV);
8027 if (want_dollar && *name != '$')
8028 sv_setpvs(namesv, "$");
8029 sv_catpvn(namesv, name, len);
8030 if ( name_utf8 ) SvUTF8_on(namesv);
8033 kid->op_sibling = 0;
8034 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8035 kid->op_targ = targ;
8036 kid->op_private |= priv;
8038 kid->op_sibling = sibl;
8044 op_lvalue(scalar(kid), type);
8048 tokid = &kid->op_sibling;
8049 kid = kid->op_sibling;
8052 if (kid && kid->op_type != OP_STUB)
8053 return too_many_arguments(o,OP_DESC(o));
8054 o->op_private |= numargs;
8056 /* FIXME - should the numargs move as for the PERL_MAD case? */
8057 o->op_private |= numargs;
8059 return too_many_arguments(o,OP_DESC(o));
8063 else if (PL_opargs[type] & OA_DEFGV) {
8065 OP *newop = newUNOP(type, 0, newDEFSVOP());
8066 op_getmad(o,newop,'O');
8069 /* Ordering of these two is important to keep f_map.t passing. */
8071 return newUNOP(type, 0, newDEFSVOP());
8076 while (oa & OA_OPTIONAL)
8078 if (oa && oa != OA_LIST)
8079 return too_few_arguments(o,OP_DESC(o));
8085 Perl_ck_glob(pTHX_ OP *o)
8089 const bool core = o->op_flags & OPf_SPECIAL;
8091 PERL_ARGS_ASSERT_CK_GLOB;
8094 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8095 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8097 if (core) gv = NULL;
8098 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
8099 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8101 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
8104 #if !defined(PERL_EXTERNAL_GLOB)
8105 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8107 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8108 newSVpvs("File::Glob"), NULL, NULL, NULL);
8111 #endif /* !PERL_EXTERNAL_GLOB */
8113 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8116 * \ null - const(wildcard)
8121 * \ mark - glob - rv2cv
8122 * | \ gv(CORE::GLOBAL::glob)
8124 * \ null - const(wildcard) - const(ix)
8126 o->op_flags |= OPf_SPECIAL;
8127 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8128 op_append_elem(OP_GLOB, o,
8129 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
8130 o = newLISTOP(OP_LIST, 0, o, NULL);
8131 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
8132 op_append_elem(OP_LIST, o,
8133 scalar(newUNOP(OP_RV2CV, 0,
8134 newGVOP(OP_GV, 0, gv)))));
8135 o = newUNOP(OP_NULL, 0, ck_subr(o));
8136 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8139 else o->op_flags &= ~OPf_SPECIAL;
8140 gv = newGVgen("main");
8142 #ifndef PERL_EXTERNAL_GLOB
8143 sv_setiv(GvSVn(gv),PL_glob_index++);
8145 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8151 Perl_ck_grep(pTHX_ OP *o)
8156 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8159 PERL_ARGS_ASSERT_CK_GREP;
8161 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8162 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8164 if (o->op_flags & OPf_STACKED) {
8167 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8168 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8169 return no_fh_allowed(o);
8170 for (k = kid; k; k = k->op_next) {
8173 NewOp(1101, gwop, 1, LOGOP);
8174 kid->op_next = (OP*)gwop;
8175 o->op_flags &= ~OPf_STACKED;
8177 kid = cLISTOPo->op_first->op_sibling;
8178 if (type == OP_MAPWHILE)
8183 if (PL_parser && PL_parser->error_count)
8185 kid = cLISTOPo->op_first->op_sibling;
8186 if (kid->op_type != OP_NULL)
8187 Perl_croak(aTHX_ "panic: ck_grep");
8188 kid = kUNOP->op_first;
8191 NewOp(1101, gwop, 1, LOGOP);
8192 gwop->op_type = type;
8193 gwop->op_ppaddr = PL_ppaddr[type];
8194 gwop->op_first = listkids(o);
8195 gwop->op_flags |= OPf_KIDS;
8196 gwop->op_other = LINKLIST(kid);
8197 kid->op_next = (OP*)gwop;
8198 offset = pad_findmy_pvs("$_", 0);
8199 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8200 o->op_private = gwop->op_private = 0;
8201 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8204 o->op_private = gwop->op_private = OPpGREP_LEX;
8205 gwop->op_targ = o->op_targ = offset;
8208 kid = cLISTOPo->op_first->op_sibling;
8209 if (!kid || !kid->op_sibling)
8210 return too_few_arguments(o,OP_DESC(o));
8211 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8212 op_lvalue(kid, OP_GREPSTART);
8218 Perl_ck_index(pTHX_ OP *o)
8220 PERL_ARGS_ASSERT_CK_INDEX;
8222 if (o->op_flags & OPf_KIDS) {
8223 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8225 kid = kid->op_sibling; /* get past "big" */
8226 if (kid && kid->op_type == OP_CONST) {
8227 const bool save_taint = PL_tainted;
8228 fbm_compile(((SVOP*)kid)->op_sv, 0);
8229 PL_tainted = save_taint;
8236 Perl_ck_lfun(pTHX_ OP *o)
8238 const OPCODE type = o->op_type;
8240 PERL_ARGS_ASSERT_CK_LFUN;
8242 return modkids(ck_fun(o), type);
8246 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8248 PERL_ARGS_ASSERT_CK_DEFINED;
8250 if ((o->op_flags & OPf_KIDS)) {
8251 switch (cUNOPo->op_first->op_type) {
8253 /* This is needed for
8254 if (defined %stash::)
8255 to work. Do not break Tk.
8257 break; /* Globals via GV can be undef */
8259 case OP_AASSIGN: /* Is this a good idea? */
8260 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8261 "defined(@array) is deprecated");
8262 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8263 "\t(Maybe you should just omit the defined()?)\n");
8267 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8268 "defined(%%hash) is deprecated");
8269 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8270 "\t(Maybe you should just omit the defined()?)\n");
8281 Perl_ck_readline(pTHX_ OP *o)
8283 PERL_ARGS_ASSERT_CK_READLINE;
8285 if (!(o->op_flags & OPf_KIDS)) {
8287 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8289 op_getmad(o,newop,'O');
8299 Perl_ck_rfun(pTHX_ OP *o)
8301 const OPCODE type = o->op_type;
8303 PERL_ARGS_ASSERT_CK_RFUN;
8305 return refkids(ck_fun(o), type);
8309 Perl_ck_listiob(pTHX_ OP *o)
8313 PERL_ARGS_ASSERT_CK_LISTIOB;
8315 kid = cLISTOPo->op_first;
8318 kid = cLISTOPo->op_first;
8320 if (kid->op_type == OP_PUSHMARK)
8321 kid = kid->op_sibling;
8322 if (kid && o->op_flags & OPf_STACKED)
8323 kid = kid->op_sibling;
8324 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8325 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8326 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8327 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8328 cLISTOPo->op_first->op_sibling = kid;
8329 cLISTOPo->op_last = kid;
8330 kid = kid->op_sibling;
8335 op_append_elem(o->op_type, o, newDEFSVOP());
8341 Perl_ck_smartmatch(pTHX_ OP *o)
8344 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8345 if (0 == (o->op_flags & OPf_SPECIAL)) {
8346 OP *first = cBINOPo->op_first;
8347 OP *second = first->op_sibling;
8349 /* Implicitly take a reference to an array or hash */
8350 first->op_sibling = NULL;
8351 first = cBINOPo->op_first = ref_array_or_hash(first);
8352 second = first->op_sibling = ref_array_or_hash(second);
8354 /* Implicitly take a reference to a regular expression */
8355 if (first->op_type == OP_MATCH) {
8356 first->op_type = OP_QR;
8357 first->op_ppaddr = PL_ppaddr[OP_QR];
8359 if (second->op_type == OP_MATCH) {
8360 second->op_type = OP_QR;
8361 second->op_ppaddr = PL_ppaddr[OP_QR];
8370 Perl_ck_sassign(pTHX_ OP *o)
8373 OP * const kid = cLISTOPo->op_first;
8375 PERL_ARGS_ASSERT_CK_SASSIGN;
8377 /* has a disposable target? */
8378 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8379 && !(kid->op_flags & OPf_STACKED)
8380 /* Cannot steal the second time! */
8381 && !(kid->op_private & OPpTARGET_MY)
8382 /* Keep the full thing for madskills */
8386 OP * const kkid = kid->op_sibling;
8388 /* Can just relocate the target. */
8389 if (kkid && kkid->op_type == OP_PADSV
8390 && !(kkid->op_private & OPpLVAL_INTRO))
8392 kid->op_targ = kkid->op_targ;
8394 /* Now we do not need PADSV and SASSIGN. */
8395 kid->op_sibling = o->op_sibling; /* NULL */
8396 cLISTOPo->op_first = NULL;
8399 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8403 if (kid->op_sibling) {
8404 OP *kkid = kid->op_sibling;
8405 /* For state variable assignment, kkid is a list op whose op_last
8407 if ((kkid->op_type == OP_PADSV ||
8408 (kkid->op_type == OP_LIST &&
8409 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8412 && (kkid->op_private & OPpLVAL_INTRO)
8413 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8414 const PADOFFSET target = kkid->op_targ;
8415 OP *const other = newOP(OP_PADSV,
8417 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8418 OP *const first = newOP(OP_NULL, 0);
8419 OP *const nullop = newCONDOP(0, first, o, other);
8420 OP *const condop = first->op_next;
8421 /* hijacking PADSTALE for uninitialized state variables */
8422 SvPADSTALE_on(PAD_SVl(target));
8424 condop->op_type = OP_ONCE;
8425 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8426 condop->op_targ = target;
8427 other->op_targ = target;
8429 /* Because we change the type of the op here, we will skip the
8430 assignment binop->op_last = binop->op_first->op_sibling; at the
8431 end of Perl_newBINOP(). So need to do it here. */
8432 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8441 Perl_ck_match(pTHX_ OP *o)
8445 PERL_ARGS_ASSERT_CK_MATCH;
8447 if (o->op_type != OP_QR && PL_compcv) {
8448 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8449 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8450 o->op_targ = offset;
8451 o->op_private |= OPpTARGET_MY;
8454 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8455 o->op_private |= OPpRUNTIME;
8460 Perl_ck_method(pTHX_ OP *o)
8462 OP * const kid = cUNOPo->op_first;
8464 PERL_ARGS_ASSERT_CK_METHOD;
8466 if (kid->op_type == OP_CONST) {
8467 SV* sv = kSVOP->op_sv;
8468 const char * const method = SvPVX_const(sv);
8469 if (!(strchr(method, ':') || strchr(method, '\''))) {
8471 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8472 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
8475 kSVOP->op_sv = NULL;
8477 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8479 op_getmad(o,cmop,'O');
8490 Perl_ck_null(pTHX_ OP *o)
8492 PERL_ARGS_ASSERT_CK_NULL;
8493 PERL_UNUSED_CONTEXT;
8498 Perl_ck_open(pTHX_ OP *o)
8501 HV * const table = GvHV(PL_hintgv);
8503 PERL_ARGS_ASSERT_CK_OPEN;
8506 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8509 const char *d = SvPV_const(*svp, len);
8510 const I32 mode = mode_from_discipline(d, len);
8511 if (mode & O_BINARY)
8512 o->op_private |= OPpOPEN_IN_RAW;
8513 else if (mode & O_TEXT)
8514 o->op_private |= OPpOPEN_IN_CRLF;
8517 svp = hv_fetchs(table, "open_OUT", FALSE);
8520 const char *d = SvPV_const(*svp, len);
8521 const I32 mode = mode_from_discipline(d, len);
8522 if (mode & O_BINARY)
8523 o->op_private |= OPpOPEN_OUT_RAW;
8524 else if (mode & O_TEXT)
8525 o->op_private |= OPpOPEN_OUT_CRLF;
8528 if (o->op_type == OP_BACKTICK) {
8529 if (!(o->op_flags & OPf_KIDS)) {
8530 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8532 op_getmad(o,newop,'O');
8541 /* In case of three-arg dup open remove strictness
8542 * from the last arg if it is a bareword. */
8543 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8544 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8548 if ((last->op_type == OP_CONST) && /* The bareword. */
8549 (last->op_private & OPpCONST_BARE) &&
8550 (last->op_private & OPpCONST_STRICT) &&
8551 (oa = first->op_sibling) && /* The fh. */
8552 (oa = oa->op_sibling) && /* The mode. */
8553 (oa->op_type == OP_CONST) &&
8554 SvPOK(((SVOP*)oa)->op_sv) &&
8555 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8556 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8557 (last == oa->op_sibling)) /* The bareword. */
8558 last->op_private &= ~OPpCONST_STRICT;
8564 Perl_ck_repeat(pTHX_ OP *o)
8566 PERL_ARGS_ASSERT_CK_REPEAT;
8568 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8569 o->op_private |= OPpREPEAT_DOLIST;
8570 cBINOPo->op_first = force_list(cBINOPo->op_first);
8578 Perl_ck_require(pTHX_ OP *o)
8583 PERL_ARGS_ASSERT_CK_REQUIRE;
8585 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8586 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8588 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8589 SV * const sv = kid->op_sv;
8590 U32 was_readonly = SvREADONLY(sv);
8597 sv_force_normal_flags(sv, 0);
8598 assert(!SvREADONLY(sv));
8608 for (; s < end; s++) {
8609 if (*s == ':' && s[1] == ':') {
8611 Move(s+2, s+1, end - s - 1, char);
8616 sv_catpvs(sv, ".pm");
8617 SvFLAGS(sv) |= was_readonly;
8621 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8622 /* handle override, if any */
8623 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8624 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8625 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8626 gv = gvp ? *gvp : NULL;
8630 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8632 if (o->op_flags & OPf_KIDS) {
8633 kid = cUNOPo->op_first;
8634 cUNOPo->op_first = NULL;
8642 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8643 op_append_elem(OP_LIST, kid,
8644 scalar(newUNOP(OP_RV2CV, 0,
8647 op_getmad(o,newop,'O');
8651 return scalar(ck_fun(o));
8655 Perl_ck_return(pTHX_ OP *o)
8660 PERL_ARGS_ASSERT_CK_RETURN;
8662 kid = cLISTOPo->op_first->op_sibling;
8663 if (CvLVALUE(PL_compcv)) {
8664 for (; kid; kid = kid->op_sibling)
8665 op_lvalue(kid, OP_LEAVESUBLV);
8672 Perl_ck_select(pTHX_ OP *o)
8677 PERL_ARGS_ASSERT_CK_SELECT;
8679 if (o->op_flags & OPf_KIDS) {
8680 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8681 if (kid && kid->op_sibling) {
8682 o->op_type = OP_SSELECT;
8683 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8685 return fold_constants(op_integerize(op_std_init(o)));
8689 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8690 if (kid && kid->op_type == OP_RV2GV)
8691 kid->op_private &= ~HINT_STRICT_REFS;
8696 Perl_ck_shift(pTHX_ OP *o)
8699 const I32 type = o->op_type;
8701 PERL_ARGS_ASSERT_CK_SHIFT;
8703 if (!(o->op_flags & OPf_KIDS)) {
8706 if (!CvUNIQUE(PL_compcv)) {
8707 o->op_flags |= OPf_SPECIAL;
8711 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8714 OP * const oldo = o;
8715 o = newUNOP(type, 0, scalar(argop));
8716 op_getmad(oldo,o,'O');
8721 return newUNOP(type, 0, scalar(argop));
8724 return scalar(ck_fun(o));
8728 Perl_ck_sort(pTHX_ OP *o)
8733 PERL_ARGS_ASSERT_CK_SORT;
8735 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8736 HV * const hinthv = GvHV(PL_hintgv);
8738 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8740 const I32 sorthints = (I32)SvIV(*svp);
8741 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8742 o->op_private |= OPpSORT_QSORT;
8743 if ((sorthints & HINT_SORT_STABLE) != 0)
8744 o->op_private |= OPpSORT_STABLE;
8749 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8751 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8752 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8754 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8756 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8758 if (kid->op_type == OP_SCOPE) {
8762 else if (kid->op_type == OP_LEAVE) {
8763 if (o->op_type == OP_SORT) {
8764 op_null(kid); /* wipe out leave */
8767 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8768 if (k->op_next == kid)
8770 /* don't descend into loops */
8771 else if (k->op_type == OP_ENTERLOOP
8772 || k->op_type == OP_ENTERITER)
8774 k = cLOOPx(k)->op_lastop;
8779 kid->op_next = 0; /* just disconnect the leave */
8780 k = kLISTOP->op_first;
8785 if (o->op_type == OP_SORT) {
8786 /* provide scalar context for comparison function/block */
8792 o->op_flags |= OPf_SPECIAL;
8794 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8797 firstkid = firstkid->op_sibling;
8800 /* provide list context for arguments */
8801 if (o->op_type == OP_SORT)
8808 S_simplify_sort(pTHX_ OP *o)
8811 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8817 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8819 if (!(o->op_flags & OPf_STACKED))
8821 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8822 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8823 kid = kUNOP->op_first; /* get past null */
8824 if (kid->op_type != OP_SCOPE)
8826 kid = kLISTOP->op_last; /* get past scope */
8827 switch(kid->op_type) {
8835 k = kid; /* remember this node*/
8836 if (kBINOP->op_first->op_type != OP_RV2SV)
8838 kid = kBINOP->op_first; /* get past cmp */
8839 if (kUNOP->op_first->op_type != OP_GV)
8841 kid = kUNOP->op_first; /* get past rv2sv */
8843 if (GvSTASH(gv) != PL_curstash)
8845 gvname = GvNAME(gv);
8846 if (*gvname == 'a' && gvname[1] == '\0')
8848 else if (*gvname == 'b' && gvname[1] == '\0')
8853 kid = k; /* back to cmp */
8854 if (kBINOP->op_last->op_type != OP_RV2SV)
8856 kid = kBINOP->op_last; /* down to 2nd arg */
8857 if (kUNOP->op_first->op_type != OP_GV)
8859 kid = kUNOP->op_first; /* get past rv2sv */
8861 if (GvSTASH(gv) != PL_curstash)
8863 gvname = GvNAME(gv);
8865 ? !(*gvname == 'a' && gvname[1] == '\0')
8866 : !(*gvname == 'b' && gvname[1] == '\0'))
8868 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8870 o->op_private |= OPpSORT_DESCEND;
8871 if (k->op_type == OP_NCMP)
8872 o->op_private |= OPpSORT_NUMERIC;
8873 if (k->op_type == OP_I_NCMP)
8874 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8875 kid = cLISTOPo->op_first->op_sibling;
8876 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8878 op_getmad(kid,o,'S'); /* then delete it */
8880 op_free(kid); /* then delete it */
8885 Perl_ck_split(pTHX_ OP *o)
8890 PERL_ARGS_ASSERT_CK_SPLIT;
8892 if (o->op_flags & OPf_STACKED)
8893 return no_fh_allowed(o);
8895 kid = cLISTOPo->op_first;
8896 if (kid->op_type != OP_NULL)
8897 Perl_croak(aTHX_ "panic: ck_split");
8898 kid = kid->op_sibling;
8899 op_free(cLISTOPo->op_first);
8901 cLISTOPo->op_first = kid;
8903 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8904 cLISTOPo->op_last = kid; /* There was only one element previously */
8907 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8908 OP * const sibl = kid->op_sibling;
8909 kid->op_sibling = 0;
8910 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8911 if (cLISTOPo->op_first == cLISTOPo->op_last)
8912 cLISTOPo->op_last = kid;
8913 cLISTOPo->op_first = kid;
8914 kid->op_sibling = sibl;
8917 kid->op_type = OP_PUSHRE;
8918 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8920 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8921 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8922 "Use of /g modifier is meaningless in split");
8925 if (!kid->op_sibling)
8926 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8928 kid = kid->op_sibling;
8931 if (!kid->op_sibling)
8932 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8933 assert(kid->op_sibling);
8935 kid = kid->op_sibling;
8938 if (kid->op_sibling)
8939 return too_many_arguments(o,OP_DESC(o));
8945 Perl_ck_join(pTHX_ OP *o)
8947 const OP * const kid = cLISTOPo->op_first->op_sibling;
8949 PERL_ARGS_ASSERT_CK_JOIN;
8951 if (kid && kid->op_type == OP_MATCH) {
8952 if (ckWARN(WARN_SYNTAX)) {
8953 const REGEXP *re = PM_GETRE(kPMOP);
8954 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8955 const STRLEN len = re ? RX_PRELEN(re) : 6;
8956 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8957 "/%.*s/ should probably be written as \"%.*s\"",
8958 (int)len, pmstr, (int)len, pmstr);
8965 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8967 Examines an op, which is expected to identify a subroutine at runtime,
8968 and attempts to determine at compile time which subroutine it identifies.
8969 This is normally used during Perl compilation to determine whether
8970 a prototype can be applied to a function call. I<cvop> is the op
8971 being considered, normally an C<rv2cv> op. A pointer to the identified
8972 subroutine is returned, if it could be determined statically, and a null
8973 pointer is returned if it was not possible to determine statically.
8975 Currently, the subroutine can be identified statically if the RV that the
8976 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8977 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8978 suitable if the constant value must be an RV pointing to a CV. Details of
8979 this process may change in future versions of Perl. If the C<rv2cv> op
8980 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8981 the subroutine statically: this flag is used to suppress compile-time
8982 magic on a subroutine call, forcing it to use default runtime behaviour.
8984 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8985 of a GV reference is modified. If a GV was examined and its CV slot was
8986 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8987 If the op is not optimised away, and the CV slot is later populated with
8988 a subroutine having a prototype, that flag eventually triggers the warning
8989 "called too early to check prototype".
8991 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8992 of returning a pointer to the subroutine it returns a pointer to the
8993 GV giving the most appropriate name for the subroutine in this context.
8994 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8995 (C<CvANON>) subroutine that is referenced through a GV it will be the
8996 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8997 A null pointer is returned as usual if there is no statically-determinable
9004 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9009 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9010 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9011 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9012 if (cvop->op_type != OP_RV2CV)
9014 if (cvop->op_private & OPpENTERSUB_AMPER)
9016 if (!(cvop->op_flags & OPf_KIDS))
9018 rvop = cUNOPx(cvop)->op_first;
9019 switch (rvop->op_type) {
9021 gv = cGVOPx_gv(rvop);
9024 if (flags & RV2CVOPCV_MARK_EARLY)
9025 rvop->op_private |= OPpEARLY_CV;
9030 SV *rv = cSVOPx_sv(rvop);
9040 if (SvTYPE((SV*)cv) != SVt_PVCV)
9042 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9043 if (!CvANON(cv) || !gv)
9052 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9054 Performs the default fixup of the arguments part of an C<entersub>
9055 op tree. This consists of applying list context to each of the
9056 argument ops. This is the standard treatment used on a call marked
9057 with C<&>, or a method call, or a call through a subroutine reference,
9058 or any other call where the callee can't be identified at compile time,
9059 or a call where the callee has no prototype.
9065 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9068 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9069 aop = cUNOPx(entersubop)->op_first;
9070 if (!aop->op_sibling)
9071 aop = cUNOPx(aop)->op_first;
9072 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9073 if (!(PL_madskills && aop->op_type == OP_STUB)) {
9075 op_lvalue(aop, OP_ENTERSUB);
9082 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9084 Performs the fixup of the arguments part of an C<entersub> op tree
9085 based on a subroutine prototype. This makes various modifications to
9086 the argument ops, from applying context up to inserting C<refgen> ops,
9087 and checking the number and syntactic types of arguments, as directed by
9088 the prototype. This is the standard treatment used on a subroutine call,
9089 not marked with C<&>, where the callee can be identified at compile time
9090 and has a prototype.
9092 I<protosv> supplies the subroutine prototype to be applied to the call.
9093 It may be a normal defined scalar, of which the string value will be used.
9094 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9095 that has been cast to C<SV*>) which has a prototype. The prototype
9096 supplied, in whichever form, does not need to match the actual callee
9097 referenced by the op tree.
9099 If the argument ops disagree with the prototype, for example by having
9100 an unacceptable number of arguments, a valid op tree is returned anyway.
9101 The error is reflected in the parser state, normally resulting in a single
9102 exception at the top level of parsing which covers all the compilation
9103 errors that occurred. In the error message, the callee is referred to
9104 by the name defined by the I<namegv> parameter.
9110 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9113 const char *proto, *proto_end;
9114 OP *aop, *prev, *cvop;
9117 I32 contextclass = 0;
9118 const char *e = NULL;
9119 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9120 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9121 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
9122 if (SvTYPE(protosv) == SVt_PVCV)
9123 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9124 else proto = SvPV(protosv, proto_len);
9125 proto_end = proto + proto_len;
9126 aop = cUNOPx(entersubop)->op_first;
9127 if (!aop->op_sibling)
9128 aop = cUNOPx(aop)->op_first;
9130 aop = aop->op_sibling;
9131 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9132 while (aop != cvop) {
9134 if (PL_madskills && aop->op_type == OP_STUB) {
9135 aop = aop->op_sibling;
9138 if (PL_madskills && aop->op_type == OP_NULL)
9139 o3 = ((UNOP*)aop)->op_first;
9143 if (proto >= proto_end)
9144 return too_many_arguments(entersubop, gv_ename(namegv));
9152 /* _ must be at the end */
9153 if (proto[1] && proto[1] != ';')
9168 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9170 arg == 1 ? "block or sub {}" : "sub {}",
9171 gv_ename(namegv), o3);
9174 /* '*' allows any scalar type, including bareword */
9177 if (o3->op_type == OP_RV2GV)
9178 goto wrapref; /* autoconvert GLOB -> GLOBref */
9179 else if (o3->op_type == OP_CONST)
9180 o3->op_private &= ~OPpCONST_STRICT;
9181 else if (o3->op_type == OP_ENTERSUB) {
9182 /* accidental subroutine, revert to bareword */
9183 OP *gvop = ((UNOP*)o3)->op_first;
9184 if (gvop && gvop->op_type == OP_NULL) {
9185 gvop = ((UNOP*)gvop)->op_first;
9187 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9190 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9191 (gvop = ((UNOP*)gvop)->op_first) &&
9192 gvop->op_type == OP_GV)
9194 GV * const gv = cGVOPx_gv(gvop);
9195 OP * const sibling = aop->op_sibling;
9196 SV * const n = newSVpvs("");
9198 OP * const oldaop = aop;
9202 gv_fullname4(n, gv, "", FALSE);
9203 aop = newSVOP(OP_CONST, 0, n);
9204 op_getmad(oldaop,aop,'O');
9205 prev->op_sibling = aop;
9206 aop->op_sibling = sibling;
9216 if (o3->op_type == OP_RV2AV ||
9217 o3->op_type == OP_PADAV ||
9218 o3->op_type == OP_RV2HV ||
9219 o3->op_type == OP_PADHV
9234 if (contextclass++ == 0) {
9235 e = strchr(proto, ']');
9236 if (!e || e == proto)
9245 const char *p = proto;
9246 const char *const end = proto;
9249 /* \[$] accepts any scalar lvalue */
9251 && Perl_op_lvalue_flags(aTHX_
9253 OP_READ, /* not entersub */
9256 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
9258 gv_ename(namegv), o3);
9263 if (o3->op_type == OP_RV2GV)
9266 bad_type(arg, "symbol", gv_ename(namegv), o3);
9269 if (o3->op_type == OP_ENTERSUB)
9272 bad_type(arg, "subroutine entry", gv_ename(namegv),
9276 if (o3->op_type == OP_RV2SV ||
9277 o3->op_type == OP_PADSV ||
9278 o3->op_type == OP_HELEM ||
9279 o3->op_type == OP_AELEM)
9281 if (!contextclass) {
9282 /* \$ accepts any scalar lvalue */
9283 if (Perl_op_lvalue_flags(aTHX_
9285 OP_READ, /* not entersub */
9288 bad_type(arg, "scalar", gv_ename(namegv), o3);
9292 if (o3->op_type == OP_RV2AV ||
9293 o3->op_type == OP_PADAV)
9296 bad_type(arg, "array", gv_ename(namegv), o3);
9299 if (o3->op_type == OP_RV2HV ||
9300 o3->op_type == OP_PADHV)
9303 bad_type(arg, "hash", gv_ename(namegv), o3);
9307 OP* const kid = aop;
9308 OP* const sib = kid->op_sibling;
9309 kid->op_sibling = 0;
9310 aop = newUNOP(OP_REFGEN, 0, kid);
9311 aop->op_sibling = sib;
9312 prev->op_sibling = aop;
9314 if (contextclass && e) {
9329 SV* const tmpsv = sv_newmortal();
9330 gv_efullname3(tmpsv, namegv, NULL);
9331 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9332 SVfARG(tmpsv), SVfARG(protosv));
9336 op_lvalue(aop, OP_ENTERSUB);
9338 aop = aop->op_sibling;
9340 if (aop == cvop && *proto == '_') {
9341 /* generate an access to $_ */
9343 aop->op_sibling = prev->op_sibling;
9344 prev->op_sibling = aop; /* instead of cvop */
9346 if (!optional && proto_end > proto &&
9347 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9348 return too_few_arguments(entersubop, gv_ename(namegv));
9353 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9355 Performs the fixup of the arguments part of an C<entersub> op tree either
9356 based on a subroutine prototype or using default list-context processing.
9357 This is the standard treatment used on a subroutine call, not marked
9358 with C<&>, where the callee can be identified at compile time.
9360 I<protosv> supplies the subroutine prototype to be applied to the call,
9361 or indicates that there is no prototype. It may be a normal scalar,
9362 in which case if it is defined then the string value will be used
9363 as a prototype, and if it is undefined then there is no prototype.
9364 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9365 that has been cast to C<SV*>), of which the prototype will be used if it
9366 has one. The prototype (or lack thereof) supplied, in whichever form,
9367 does not need to match the actual callee referenced by the op tree.
9369 If the argument ops disagree with the prototype, for example by having
9370 an unacceptable number of arguments, a valid op tree is returned anyway.
9371 The error is reflected in the parser state, normally resulting in a single
9372 exception at the top level of parsing which covers all the compilation
9373 errors that occurred. In the error message, the callee is referred to
9374 by the name defined by the I<namegv> parameter.
9380 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9381 GV *namegv, SV *protosv)
9383 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9384 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9385 return ck_entersub_args_proto(entersubop, namegv, protosv);
9387 return ck_entersub_args_list(entersubop);
9391 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9393 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9394 OP *aop = cUNOPx(entersubop)->op_first;
9396 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9400 if (!aop->op_sibling)
9401 aop = cUNOPx(aop)->op_first;
9402 aop = aop->op_sibling;
9403 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9404 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9405 aop = aop->op_sibling;
9409 (void)too_many_arguments(entersubop, GvNAME(namegv));
9411 op_free(entersubop);
9412 switch(GvNAME(namegv)[2]) {
9413 case 'F': return newSVOP(OP_CONST, 0,
9414 newSVpv(CopFILE(PL_curcop),0));
9415 case 'L': return newSVOP(
9418 "%"IVdf, (IV)CopLINE(PL_curcop)
9421 case 'P': return newSVOP(OP_CONST, 0,
9423 ? newSVhek(HvNAME_HEK(PL_curstash))
9434 bool seenarg = FALSE;
9436 if (!aop->op_sibling)
9437 aop = cUNOPx(aop)->op_first;
9440 aop = aop->op_sibling;
9441 prev->op_sibling = NULL;
9444 prev=cvop, cvop = cvop->op_sibling)
9446 if (PL_madskills && cvop->op_sibling
9447 && cvop->op_type != OP_STUB) seenarg = TRUE
9450 prev->op_sibling = NULL;
9451 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9453 if (aop == cvop) aop = NULL;
9454 op_free(entersubop);
9456 if (opnum == OP_ENTEREVAL
9457 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
9458 flags |= OPpEVAL_BYTES <<8;
9460 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9462 case OA_BASEOP_OR_UNOP:
9464 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
9468 if (!PL_madskills || seenarg)
9470 (void)too_many_arguments(aop, GvNAME(namegv));
9473 return opnum == OP_RUNCV
9474 ? newPVOP(OP_RUNCV,0,NULL)
9477 return convert(opnum,0,aop);
9485 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9487 Retrieves the function that will be used to fix up a call to I<cv>.
9488 Specifically, the function is applied to an C<entersub> op tree for a
9489 subroutine call, not marked with C<&>, where the callee can be identified
9490 at compile time as I<cv>.
9492 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9493 argument for it is returned in I<*ckobj_p>. The function is intended
9494 to be called in this manner:
9496 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9498 In this call, I<entersubop> is a pointer to the C<entersub> op,
9499 which may be replaced by the check function, and I<namegv> is a GV
9500 supplying the name that should be used by the check function to refer
9501 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9502 It is permitted to apply the check function in non-standard situations,
9503 such as to a call to a different subroutine or to a method call.
9505 By default, the function is
9506 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9507 and the SV parameter is I<cv> itself. This implements standard
9508 prototype processing. It can be changed, for a particular subroutine,
9509 by L</cv_set_call_checker>.
9515 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9518 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9519 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9521 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9522 *ckobj_p = callmg->mg_obj;
9524 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9530 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9532 Sets the function that will be used to fix up a call to I<cv>.
9533 Specifically, the function is applied to an C<entersub> op tree for a
9534 subroutine call, not marked with C<&>, where the callee can be identified
9535 at compile time as I<cv>.
9537 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9538 for it is supplied in I<ckobj>. The function is intended to be called
9541 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9543 In this call, I<entersubop> is a pointer to the C<entersub> op,
9544 which may be replaced by the check function, and I<namegv> is a GV
9545 supplying the name that should be used by the check function to refer
9546 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9547 It is permitted to apply the check function in non-standard situations,
9548 such as to a call to a different subroutine or to a method call.
9550 The current setting for a particular CV can be retrieved by
9551 L</cv_get_call_checker>.
9557 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9559 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9560 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9561 if (SvMAGICAL((SV*)cv))
9562 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9565 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9566 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9567 if (callmg->mg_flags & MGf_REFCOUNTED) {
9568 SvREFCNT_dec(callmg->mg_obj);
9569 callmg->mg_flags &= ~MGf_REFCOUNTED;
9571 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9572 callmg->mg_obj = ckobj;
9573 if (ckobj != (SV*)cv) {
9574 SvREFCNT_inc_simple_void_NN(ckobj);
9575 callmg->mg_flags |= MGf_REFCOUNTED;
9581 Perl_ck_subr(pTHX_ OP *o)
9587 PERL_ARGS_ASSERT_CK_SUBR;
9589 aop = cUNOPx(o)->op_first;
9590 if (!aop->op_sibling)
9591 aop = cUNOPx(aop)->op_first;
9592 aop = aop->op_sibling;
9593 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9594 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9595 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9597 o->op_private &= ~1;
9598 o->op_private |= OPpENTERSUB_HASTARG;
9599 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9600 if (PERLDB_SUB && PL_curstash != PL_debstash)
9601 o->op_private |= OPpENTERSUB_DB;
9602 if (cvop->op_type == OP_RV2CV) {
9603 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9605 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9606 if (aop->op_type == OP_CONST)
9607 aop->op_private &= ~OPpCONST_STRICT;
9608 else if (aop->op_type == OP_LIST) {
9609 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9610 if (sib && sib->op_type == OP_CONST)
9611 sib->op_private &= ~OPpCONST_STRICT;
9616 return ck_entersub_args_list(o);
9618 Perl_call_checker ckfun;
9620 cv_get_call_checker(cv, &ckfun, &ckobj);
9621 return ckfun(aTHX_ o, namegv, ckobj);
9626 Perl_ck_svconst(pTHX_ OP *o)
9628 PERL_ARGS_ASSERT_CK_SVCONST;
9629 PERL_UNUSED_CONTEXT;
9630 SvREADONLY_on(cSVOPo->op_sv);
9635 Perl_ck_chdir(pTHX_ OP *o)
9637 PERL_ARGS_ASSERT_CK_CHDIR;
9638 if (o->op_flags & OPf_KIDS) {
9639 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9641 if (kid && kid->op_type == OP_CONST &&
9642 (kid->op_private & OPpCONST_BARE))
9644 o->op_flags |= OPf_SPECIAL;
9645 kid->op_private &= ~OPpCONST_STRICT;
9652 Perl_ck_trunc(pTHX_ OP *o)
9654 PERL_ARGS_ASSERT_CK_TRUNC;
9656 if (o->op_flags & OPf_KIDS) {
9657 SVOP *kid = (SVOP*)cUNOPo->op_first;
9659 if (kid->op_type == OP_NULL)
9660 kid = (SVOP*)kid->op_sibling;
9661 if (kid && kid->op_type == OP_CONST &&
9662 (kid->op_private & OPpCONST_BARE))
9664 o->op_flags |= OPf_SPECIAL;
9665 kid->op_private &= ~OPpCONST_STRICT;
9672 Perl_ck_substr(pTHX_ OP *o)
9674 PERL_ARGS_ASSERT_CK_SUBSTR;
9677 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9678 OP *kid = cLISTOPo->op_first;
9680 if (kid->op_type == OP_NULL)
9681 kid = kid->op_sibling;
9683 kid->op_flags |= OPf_MOD;
9690 Perl_ck_tell(pTHX_ OP *o)
9693 PERL_ARGS_ASSERT_CK_TELL;
9695 kid = cLISTOPo->op_first;
9696 if (kid && kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9701 Perl_ck_each(pTHX_ OP *o)
9704 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9705 const unsigned orig_type = o->op_type;
9706 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9707 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9708 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9709 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9711 PERL_ARGS_ASSERT_CK_EACH;
9714 switch (kid->op_type) {
9720 CHANGE_TYPE(o, array_type);
9723 if (kid->op_private == OPpCONST_BARE
9724 || !SvROK(cSVOPx_sv(kid))
9725 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9726 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9728 /* we let ck_fun handle it */
9731 CHANGE_TYPE(o, ref_type);
9735 /* if treating as a reference, defer additional checks to runtime */
9736 return o->op_type == ref_type ? o : ck_fun(o);
9740 Perl_ck_length(pTHX_ OP *o)
9742 PERL_ARGS_ASSERT_CK_LENGTH;
9746 if (ckWARN(WARN_SYNTAX)) {
9747 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9751 const bool hash = kid->op_type == OP_PADHV
9752 || kid->op_type == OP_RV2HV;
9753 switch (kid->op_type) {
9757 NULL, hash ? '%' : '@', kid->op_targ, NULL, 0, 1
9762 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
9764 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
9766 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
9773 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9774 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
9776 name, hash ? "keys " : "", name
9779 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9780 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
9782 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9783 "length() used on @array (did you mean \"scalar(@array)\"?)");
9790 /* caller is supposed to assign the return to the
9791 container of the rep_op var */
9793 S_opt_scalarhv(pTHX_ OP *rep_op) {
9797 PERL_ARGS_ASSERT_OPT_SCALARHV;
9799 NewOp(1101, unop, 1, UNOP);
9800 unop->op_type = (OPCODE)OP_BOOLKEYS;
9801 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9802 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9803 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9804 unop->op_first = rep_op;
9805 unop->op_next = rep_op->op_next;
9806 rep_op->op_next = (OP*)unop;
9807 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9808 unop->op_sibling = rep_op->op_sibling;
9809 rep_op->op_sibling = NULL;
9810 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9811 if (rep_op->op_type == OP_PADHV) {
9812 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9813 rep_op->op_flags |= OPf_WANT_LIST;
9818 /* Check for in place reverse and sort assignments like "@a = reverse @a"
9819 and modify the optree to make them work inplace */
9822 S_inplace_aassign(pTHX_ OP *o) {
9824 OP *modop, *modop_pushmark;
9826 OP *oleft, *oleft_pushmark;
9828 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
9830 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
9832 assert(cUNOPo->op_first->op_type == OP_NULL);
9833 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
9834 assert(modop_pushmark->op_type == OP_PUSHMARK);
9835 modop = modop_pushmark->op_sibling;
9837 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
9840 /* no other operation except sort/reverse */
9841 if (modop->op_sibling)
9844 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
9845 oright = cUNOPx(modop)->op_first->op_sibling;
9847 if (modop->op_flags & OPf_STACKED) {
9848 /* skip sort subroutine/block */
9849 assert(oright->op_type == OP_NULL);
9850 oright = oright->op_sibling;
9853 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
9854 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
9855 assert(oleft_pushmark->op_type == OP_PUSHMARK);
9856 oleft = oleft_pushmark->op_sibling;
9858 /* Check the lhs is an array */
9860 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
9861 || oleft->op_sibling
9862 || (oleft->op_private & OPpLVAL_INTRO)
9866 /* Only one thing on the rhs */
9867 if (oright->op_sibling)
9870 /* check the array is the same on both sides */
9871 if (oleft->op_type == OP_RV2AV) {
9872 if (oright->op_type != OP_RV2AV
9873 || !cUNOPx(oright)->op_first
9874 || cUNOPx(oright)->op_first->op_type != OP_GV
9875 || cUNOPx(oleft )->op_first->op_type != OP_GV
9876 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9877 cGVOPx_gv(cUNOPx(oright)->op_first)
9881 else if (oright->op_type != OP_PADAV
9882 || oright->op_targ != oleft->op_targ
9886 /* This actually is an inplace assignment */
9888 modop->op_private |= OPpSORT_INPLACE;
9890 /* transfer MODishness etc from LHS arg to RHS arg */
9891 oright->op_flags = oleft->op_flags;
9893 /* remove the aassign op and the lhs */
9895 op_null(oleft_pushmark);
9896 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
9897 op_null(cUNOPx(oleft)->op_first);
9901 #define MAX_DEFERRED 4
9904 if (defer_ix == (MAX_DEFERRED-1)) { \
9905 CALL_RPEEP(defer_queue[defer_base]); \
9906 defer_base = (defer_base + 1) % MAX_DEFERRED; \
9909 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
9911 /* A peephole optimizer. We visit the ops in the order they're to execute.
9912 * See the comments at the top of this file for more details about when
9913 * peep() is called */
9916 Perl_rpeep(pTHX_ register OP *o)
9919 register OP* oldop = NULL;
9920 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
9924 if (!o || o->op_opt)
9928 SAVEVPTR(PL_curcop);
9929 for (;; o = o->op_next) {
9933 while (defer_ix >= 0)
9934 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
9938 /* By default, this op has now been optimised. A couple of cases below
9939 clear this again. */
9942 switch (o->op_type) {
9944 PL_curcop = ((COP*)o); /* for warnings */
9947 PL_curcop = ((COP*)o); /* for warnings */
9949 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9950 to carry two labels. For now, take the easier option, and skip
9951 this optimisation if the first NEXTSTATE has a label. */
9952 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9953 OP *nextop = o->op_next;
9954 while (nextop && nextop->op_type == OP_NULL)
9955 nextop = nextop->op_next;
9957 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9958 COP *firstcop = (COP *)o;
9959 COP *secondcop = (COP *)nextop;
9960 /* We want the COP pointed to by o (and anything else) to
9961 become the next COP down the line. */
9964 firstcop->op_next = secondcop->op_next;
9966 /* Now steal all its pointers, and duplicate the other
9968 firstcop->cop_line = secondcop->cop_line;
9970 firstcop->cop_stashpv = secondcop->cop_stashpv;
9971 firstcop->cop_file = secondcop->cop_file;
9973 firstcop->cop_stash = secondcop->cop_stash;
9974 firstcop->cop_filegv = secondcop->cop_filegv;
9976 firstcop->cop_hints = secondcop->cop_hints;
9977 firstcop->cop_seq = secondcop->cop_seq;
9978 firstcop->cop_warnings = secondcop->cop_warnings;
9979 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9982 secondcop->cop_stashpv = NULL;
9983 secondcop->cop_file = NULL;
9985 secondcop->cop_stash = NULL;
9986 secondcop->cop_filegv = NULL;
9988 secondcop->cop_warnings = NULL;
9989 secondcop->cop_hints_hash = NULL;
9991 /* If we use op_null(), and hence leave an ex-COP, some
9992 warnings are misreported. For example, the compile-time
9993 error in 'use strict; no strict refs;' */
9994 secondcop->op_type = OP_NULL;
9995 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10001 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10002 if (o->op_next->op_private & OPpTARGET_MY) {
10003 if (o->op_flags & OPf_STACKED) /* chained concats */
10004 break; /* ignore_optimization */
10006 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10007 o->op_targ = o->op_next->op_targ;
10008 o->op_next->op_targ = 0;
10009 o->op_private |= OPpTARGET_MY;
10012 op_null(o->op_next);
10016 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10017 break; /* Scalar stub must produce undef. List stub is noop */
10021 if (o->op_targ == OP_NEXTSTATE
10022 || o->op_targ == OP_DBSTATE)
10024 PL_curcop = ((COP*)o);
10026 /* XXX: We avoid setting op_seq here to prevent later calls
10027 to rpeep() from mistakenly concluding that optimisation
10028 has already occurred. This doesn't fix the real problem,
10029 though (See 20010220.007). AMS 20010719 */
10030 /* op_seq functionality is now replaced by op_opt */
10037 if (oldop && o->op_next) {
10038 oldop->op_next = o->op_next;
10046 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
10047 OP* const pop = (o->op_type == OP_PADAV) ?
10048 o->op_next : o->op_next->op_next;
10050 if (pop && pop->op_type == OP_CONST &&
10051 ((PL_op = pop->op_next)) &&
10052 pop->op_next->op_type == OP_AELEM &&
10053 !(pop->op_next->op_private &
10054 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
10055 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
10058 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
10059 no_bareword_allowed(pop);
10060 if (o->op_type == OP_GV)
10061 op_null(o->op_next);
10062 op_null(pop->op_next);
10064 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
10065 o->op_next = pop->op_next->op_next;
10066 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
10067 o->op_private = (U8)i;
10068 if (o->op_type == OP_GV) {
10071 o->op_type = OP_AELEMFAST;
10074 o->op_type = OP_AELEMFAST_LEX;
10079 if (o->op_next->op_type == OP_RV2SV) {
10080 if (!(o->op_next->op_private & OPpDEREF)) {
10081 op_null(o->op_next);
10082 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
10084 o->op_next = o->op_next->op_next;
10085 o->op_type = OP_GVSV;
10086 o->op_ppaddr = PL_ppaddr[OP_GVSV];
10089 else if (o->op_next->op_type == OP_READLINE
10090 && o->op_next->op_next->op_type == OP_CONCAT
10091 && (o->op_next->op_next->op_flags & OPf_STACKED))
10093 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
10094 o->op_type = OP_RCATLINE;
10095 o->op_flags |= OPf_STACKED;
10096 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
10097 op_null(o->op_next->op_next);
10098 op_null(o->op_next);
10108 fop = cUNOP->op_first;
10116 fop = cLOGOP->op_first;
10117 sop = fop->op_sibling;
10118 while (cLOGOP->op_other->op_type == OP_NULL)
10119 cLOGOP->op_other = cLOGOP->op_other->op_next;
10120 while (o->op_next && ( o->op_type == o->op_next->op_type
10121 || o->op_next->op_type == OP_NULL))
10122 o->op_next = o->op_next->op_next;
10123 DEFER(cLOGOP->op_other);
10127 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10129 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
10134 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
10135 while (nop && nop->op_next) {
10136 switch (nop->op_next->op_type) {
10141 lop = nop = nop->op_next;
10144 nop = nop->op_next;
10152 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
10153 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10154 cLOGOP->op_first = opt_scalarhv(fop);
10155 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
10156 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
10172 while (cLOGOP->op_other->op_type == OP_NULL)
10173 cLOGOP->op_other = cLOGOP->op_other->op_next;
10174 DEFER(cLOGOP->op_other);
10179 while (cLOOP->op_redoop->op_type == OP_NULL)
10180 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
10181 while (cLOOP->op_nextop->op_type == OP_NULL)
10182 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
10183 while (cLOOP->op_lastop->op_type == OP_NULL)
10184 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
10185 /* a while(1) loop doesn't have an op_next that escapes the
10186 * loop, so we have to explicitly follow the op_lastop to
10187 * process the rest of the code */
10188 DEFER(cLOOP->op_lastop);
10192 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10193 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10194 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10195 cPMOP->op_pmstashstartu.op_pmreplstart
10196 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
10197 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
10201 /* check that RHS of sort is a single plain array */
10202 OP *oright = cUNOPo->op_first;
10203 if (!oright || oright->op_type != OP_PUSHMARK)
10206 if (o->op_private & OPpSORT_INPLACE)
10209 /* reverse sort ... can be optimised. */
10210 if (!cUNOPo->op_sibling) {
10211 /* Nothing follows us on the list. */
10212 OP * const reverse = o->op_next;
10214 if (reverse->op_type == OP_REVERSE &&
10215 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10216 OP * const pushmark = cUNOPx(reverse)->op_first;
10217 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10218 && (cUNOPx(pushmark)->op_sibling == o)) {
10219 /* reverse -> pushmark -> sort */
10220 o->op_private |= OPpSORT_REVERSE;
10222 pushmark->op_next = oright->op_next;
10232 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10234 LISTOP *enter, *exlist;
10236 if (o->op_private & OPpSORT_INPLACE)
10239 enter = (LISTOP *) o->op_next;
10242 if (enter->op_type == OP_NULL) {
10243 enter = (LISTOP *) enter->op_next;
10247 /* for $a (...) will have OP_GV then OP_RV2GV here.
10248 for (...) just has an OP_GV. */
10249 if (enter->op_type == OP_GV) {
10250 gvop = (OP *) enter;
10251 enter = (LISTOP *) enter->op_next;
10254 if (enter->op_type == OP_RV2GV) {
10255 enter = (LISTOP *) enter->op_next;
10261 if (enter->op_type != OP_ENTERITER)
10264 iter = enter->op_next;
10265 if (!iter || iter->op_type != OP_ITER)
10268 expushmark = enter->op_first;
10269 if (!expushmark || expushmark->op_type != OP_NULL
10270 || expushmark->op_targ != OP_PUSHMARK)
10273 exlist = (LISTOP *) expushmark->op_sibling;
10274 if (!exlist || exlist->op_type != OP_NULL
10275 || exlist->op_targ != OP_LIST)
10278 if (exlist->op_last != o) {
10279 /* Mmm. Was expecting to point back to this op. */
10282 theirmark = exlist->op_first;
10283 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10286 if (theirmark->op_sibling != o) {
10287 /* There's something between the mark and the reverse, eg
10288 for (1, reverse (...))
10293 ourmark = ((LISTOP *)o)->op_first;
10294 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10297 ourlast = ((LISTOP *)o)->op_last;
10298 if (!ourlast || ourlast->op_next != o)
10301 rv2av = ourmark->op_sibling;
10302 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10303 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10304 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10305 /* We're just reversing a single array. */
10306 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10307 enter->op_flags |= OPf_STACKED;
10310 /* We don't have control over who points to theirmark, so sacrifice
10312 theirmark->op_next = ourmark->op_next;
10313 theirmark->op_flags = ourmark->op_flags;
10314 ourlast->op_next = gvop ? gvop : (OP *) enter;
10317 enter->op_private |= OPpITER_REVERSED;
10318 iter->op_private |= OPpITER_REVERSED;
10325 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10326 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10331 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
10333 if (CvUNIQUE(PL_compcv)) sv = &PL_sv_undef;
10335 sv = newRV((SV *)PL_compcv);
10339 o->op_type = OP_CONST;
10340 o->op_ppaddr = PL_ppaddr[OP_CONST];
10341 o->op_flags |= OPf_SPECIAL;
10342 cSVOPo->op_sv = sv;
10347 if (OP_GIMME(o,0) == G_VOID) {
10348 OP *right = cBINOP->op_first;
10350 OP *left = right->op_sibling;
10351 if (left->op_type == OP_SUBSTR
10352 && (left->op_private & 7) < 4) {
10354 cBINOP->op_first = left;
10355 right->op_sibling =
10356 cBINOPx(left)->op_first->op_sibling;
10357 cBINOPx(left)->op_first->op_sibling = right;
10358 left->op_private |= OPpSUBSTR_REPL_FIRST;
10360 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10367 Perl_cpeep_t cpeep =
10368 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10370 cpeep(aTHX_ o, oldop);
10381 Perl_peep(pTHX_ register OP *o)
10387 =head1 Custom Operators
10389 =for apidoc Ao||custom_op_xop
10390 Return the XOP structure for a given custom op. This function should be
10391 considered internal to OP_NAME and the other access macros: use them instead.
10397 Perl_custom_op_xop(pTHX_ const OP *o)
10403 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10405 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10406 assert(o->op_type == OP_CUSTOM);
10408 /* This is wrong. It assumes a function pointer can be cast to IV,
10409 * which isn't guaranteed, but this is what the old custom OP code
10410 * did. In principle it should be safer to Copy the bytes of the
10411 * pointer into a PV: since the new interface is hidden behind
10412 * functions, this can be changed later if necessary. */
10413 /* Change custom_op_xop if this ever happens */
10414 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10417 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10419 /* assume noone will have just registered a desc */
10420 if (!he && PL_custom_op_names &&
10421 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10426 /* XXX does all this need to be shared mem? */
10427 Newxz(xop, 1, XOP);
10428 pv = SvPV(HeVAL(he), l);
10429 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10430 if (PL_custom_op_descs &&
10431 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10433 pv = SvPV(HeVAL(he), l);
10434 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10436 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10440 if (!he) return &xop_null;
10442 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10447 =for apidoc Ao||custom_op_register
10448 Register a custom op. See L<perlguts/"Custom Operators">.
10454 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10458 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10460 /* see the comment in custom_op_xop */
10461 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10463 if (!PL_custom_ops)
10464 PL_custom_ops = newHV();
10466 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10467 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10471 =head1 Functions in file op.c
10473 =for apidoc core_prototype
10474 This function assigns the prototype of the named core function to C<sv>, or
10475 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10476 NULL if the core function has no prototype. C<code> is a code as returned
10477 by C<keyword()>. It must be negative and unequal to -KEY_CORE.
10483 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10486 int i = 0, n = 0, seen_question = 0, defgv = 0;
10488 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10489 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10490 bool nullret = FALSE;
10492 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10494 assert (code < 0 && code != -KEY_CORE);
10496 if (!sv) sv = sv_newmortal();
10498 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10501 case KEY_and : case KEY_chop: case KEY_chomp:
10502 case KEY_cmp : case KEY_exec: case KEY_eq :
10503 case KEY_ge : case KEY_gt : case KEY_le :
10504 case KEY_lt : case KEY_ne : case KEY_or :
10505 case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
10506 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10507 case KEY_keys: retsetpvs("+", OP_KEYS);
10508 case KEY_values: retsetpvs("+", OP_VALUES);
10509 case KEY_each: retsetpvs("+", OP_EACH);
10510 case KEY_push: retsetpvs("+@", OP_PUSH);
10511 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10512 case KEY_pop: retsetpvs(";+", OP_POP);
10513 case KEY_shift: retsetpvs(";+", OP_SHIFT);
10515 retsetpvs("+;$$@", OP_SPLICE);
10516 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10518 case KEY_evalbytes:
10519 name = "entereval"; break;
10527 while (i < MAXO) { /* The slow way. */
10528 if (strEQ(name, PL_op_name[i])
10529 || strEQ(name, PL_op_desc[i]))
10531 if (nullret) { assert(opnum); *opnum = i; return NULL; }
10536 assert(0); return NULL; /* Should not happen... */
10538 defgv = PL_opargs[i] & OA_DEFGV;
10539 oa = PL_opargs[i] >> OASHIFT;
10541 if (oa & OA_OPTIONAL && !seen_question && (
10542 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
10547 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10548 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10549 /* But globs are already references (kinda) */
10550 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10554 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10555 && !scalar_mod_type(NULL, i)) {
10560 if (i == OP_LOCK) str[n++] = '&';
10564 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10565 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10566 str[n-1] = '_'; defgv = 0;
10570 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
10572 sv_setpvn(sv, str, n - 1);
10573 if (opnum) *opnum = i;
10578 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
10581 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
10584 PERL_ARGS_ASSERT_CORESUB_OP;
10588 return op_append_elem(OP_LINESEQ,
10591 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
10595 case OP_SELECT: /* which represents OP_SSELECT as well */
10600 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
10601 newSVOP(OP_CONST, 0, newSVuv(1))
10603 coresub_op(newSVuv((UV)OP_SSELECT), 0,
10605 coresub_op(coreargssv, 0, OP_SELECT)
10609 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10611 return op_append_elem(
10614 opnum == OP_WANTARRAY || opnum == OP_RUNCV
10615 ? OPpOFFBYONE << 8 : 0)
10617 case OA_BASEOP_OR_UNOP:
10618 if (opnum == OP_ENTEREVAL) {
10619 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
10620 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
10622 else o = newUNOP(opnum,0,argop);
10623 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
10626 if (is_handle_constructor(o, 1))
10627 argop->op_private |= OPpCOREARGS_DEREF1;
10631 o = convert(opnum,0,argop);
10632 if (is_handle_constructor(o, 2))
10633 argop->op_private |= OPpCOREARGS_DEREF2;
10634 if (scalar_mod_type(NULL, opnum))
10635 argop->op_private |= OPpCOREARGS_SCALARMOD;
10636 if (opnum == OP_SUBSTR) {
10637 o->op_private |= OPpMAYBE_LVSUB;
10646 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
10647 SV * const *new_const_svp)
10649 const char *hvname;
10650 bool is_const = !!CvCONST(old_cv);
10651 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
10653 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
10655 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
10657 /* They are 2 constant subroutines generated from
10658 the same constant. This probably means that
10659 they are really the "same" proxy subroutine
10660 instantiated in 2 places. Most likely this is
10661 when a constant is exported twice. Don't warn.
10664 (ckWARN(WARN_REDEFINE)
10666 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
10667 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
10668 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
10669 strEQ(hvname, "autouse"))
10673 && ckWARN_d(WARN_REDEFINE)
10674 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
10677 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10679 ? "Constant subroutine %"SVf" redefined"
10680 : "Subroutine %"SVf" redefined",
10686 /* Efficient sub that returns a constant scalar value. */
10688 const_sv_xsub(pTHX_ CV* cv)
10692 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10696 /* diag_listed_as: SKIPME */
10697 Perl_croak(aTHX_ "usage: %s::%s()",
10698 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10711 * c-indentation-style: bsd
10712 * c-basic-offset: 4
10713 * indent-tabs-mode: t
10716 * ex: set ts=8 sts=4 sw=4 noet: