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:
1118 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1119 /* Otherwise it's "Useless use of grep iterator" */
1120 useless = OP_DESC(o);
1124 kid = cLISTOPo->op_first;
1125 if (kid && kid->op_type == OP_PUSHRE
1127 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1129 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1131 useless = OP_DESC(o);
1135 kid = cUNOPo->op_first;
1136 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1137 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1140 useless = "negative pattern binding (!~)";
1144 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1145 useless = "non-destructive substitution (s///r)";
1149 useless = "non-destructive transliteration (tr///r)";
1156 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1157 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1158 useless = "a variable";
1163 if (cSVOPo->op_private & OPpCONST_STRICT)
1164 no_bareword_allowed(o);
1166 if (ckWARN(WARN_VOID)) {
1168 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1169 "a constant (%"SVf")", sv));
1170 useless = SvPV_nolen(msv);
1171 useless_is_utf8 = SvUTF8(msv);
1174 useless = "a constant (undef)";
1175 /* don't warn on optimised away booleans, eg
1176 * use constant Foo, 5; Foo || print; */
1177 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1179 /* the constants 0 and 1 are permitted as they are
1180 conventionally used as dummies in constructs like
1181 1 while some_condition_with_side_effects; */
1182 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1184 else if (SvPOK(sv)) {
1185 /* perl4's way of mixing documentation and code
1186 (before the invention of POD) was based on a
1187 trick to mix nroff and perl code. The trick was
1188 built upon these three nroff macros being used in
1189 void context. The pink camel has the details in
1190 the script wrapman near page 319. */
1191 const char * const maybe_macro = SvPVX_const(sv);
1192 if (strnEQ(maybe_macro, "di", 2) ||
1193 strnEQ(maybe_macro, "ds", 2) ||
1194 strnEQ(maybe_macro, "ig", 2))
1199 op_null(o); /* don't execute or even remember it */
1203 o->op_type = OP_PREINC; /* pre-increment is faster */
1204 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1208 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1209 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1213 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1214 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1218 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1219 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1224 UNOP *refgen, *rv2cv;
1227 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1230 rv2gv = ((BINOP *)o)->op_last;
1231 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1234 refgen = (UNOP *)((BINOP *)o)->op_first;
1236 if (!refgen || refgen->op_type != OP_REFGEN)
1239 exlist = (LISTOP *)refgen->op_first;
1240 if (!exlist || exlist->op_type != OP_NULL
1241 || exlist->op_targ != OP_LIST)
1244 if (exlist->op_first->op_type != OP_PUSHMARK)
1247 rv2cv = (UNOP*)exlist->op_last;
1249 if (rv2cv->op_type != OP_RV2CV)
1252 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1253 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1254 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1256 o->op_private |= OPpASSIGN_CV_TO_GV;
1257 rv2gv->op_private |= OPpDONT_INIT_GV;
1258 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1270 kid = cLOGOPo->op_first;
1271 if (kid->op_type == OP_NOT
1272 && (kid->op_flags & OPf_KIDS)
1274 if (o->op_type == OP_AND) {
1276 o->op_ppaddr = PL_ppaddr[OP_OR];
1278 o->op_type = OP_AND;
1279 o->op_ppaddr = PL_ppaddr[OP_AND];
1288 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1293 if (o->op_flags & OPf_STACKED)
1300 if (!(o->op_flags & OPf_KIDS))
1311 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1321 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1322 newSVpvn_flags(useless, strlen(useless),
1323 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1328 S_listkids(pTHX_ OP *o)
1330 if (o && o->op_flags & OPf_KIDS) {
1332 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1339 Perl_list(pTHX_ OP *o)
1344 /* assumes no premature commitment */
1345 if (!o || (o->op_flags & OPf_WANT)
1346 || (PL_parser && PL_parser->error_count)
1347 || o->op_type == OP_RETURN)
1352 if ((o->op_private & OPpTARGET_MY)
1353 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1355 return o; /* As if inside SASSIGN */
1358 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1360 switch (o->op_type) {
1363 list(cBINOPo->op_first);
1368 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1376 if (!(o->op_flags & OPf_KIDS))
1378 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1379 list(cBINOPo->op_first);
1380 return gen_constant_list(o);
1387 kid = cLISTOPo->op_first;
1389 kid = kid->op_sibling;
1392 OP *sib = kid->op_sibling;
1393 if (sib && kid->op_type != OP_LEAVEWHEN)
1399 PL_curcop = &PL_compiling;
1403 kid = cLISTOPo->op_first;
1410 S_scalarseq(pTHX_ OP *o)
1414 const OPCODE type = o->op_type;
1416 if (type == OP_LINESEQ || type == OP_SCOPE ||
1417 type == OP_LEAVE || type == OP_LEAVETRY)
1420 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1421 if (kid->op_sibling) {
1425 PL_curcop = &PL_compiling;
1427 o->op_flags &= ~OPf_PARENS;
1428 if (PL_hints & HINT_BLOCK_SCOPE)
1429 o->op_flags |= OPf_PARENS;
1432 o = newOP(OP_STUB, 0);
1437 S_modkids(pTHX_ OP *o, I32 type)
1439 if (o && o->op_flags & OPf_KIDS) {
1441 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1442 op_lvalue(kid, type);
1448 =for apidoc finalize_optree
1450 This function finalizes the optree. Should be called directly after
1451 the complete optree is built. It does some additional
1452 checking which can't be done in the normal ck_xxx functions and makes
1453 the tree thread-safe.
1458 Perl_finalize_optree(pTHX_ OP* o)
1460 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1463 SAVEVPTR(PL_curcop);
1471 S_finalize_op(pTHX_ OP* o)
1473 PERL_ARGS_ASSERT_FINALIZE_OP;
1475 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1477 /* Make sure mad ops are also thread-safe */
1478 MADPROP *mp = o->op_madprop;
1480 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1481 OP *prop_op = (OP *) mp->mad_val;
1482 /* We only need "Relocate sv to the pad for thread safety.", but this
1483 easiest way to make sure it traverses everything */
1484 if (prop_op->op_type == OP_CONST)
1485 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1486 finalize_op(prop_op);
1493 switch (o->op_type) {
1496 PL_curcop = ((COP*)o); /* for warnings */
1500 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1501 && ckWARN(WARN_SYNTAX))
1503 if (o->op_sibling->op_sibling) {
1504 const OPCODE type = o->op_sibling->op_sibling->op_type;
1505 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1506 const line_t oldline = CopLINE(PL_curcop);
1507 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1508 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1509 "Statement unlikely to be reached");
1510 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1511 "\t(Maybe you meant system() when you said exec()?)\n");
1512 CopLINE_set(PL_curcop, oldline);
1519 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1520 GV * const gv = cGVOPo_gv;
1521 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1522 /* XXX could check prototype here instead of just carping */
1523 SV * const sv = sv_newmortal();
1524 gv_efullname3(sv, gv, NULL);
1525 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1526 "%"SVf"() called too early to check prototype",
1533 if (cSVOPo->op_private & OPpCONST_STRICT)
1534 no_bareword_allowed(o);
1538 case OP_METHOD_NAMED:
1539 /* Relocate sv to the pad for thread safety.
1540 * Despite being a "constant", the SV is written to,
1541 * for reference counts, sv_upgrade() etc. */
1542 if (cSVOPo->op_sv) {
1543 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1544 if (o->op_type != OP_METHOD_NAMED &&
1545 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1547 /* If op_sv is already a PADTMP/MY then it is being used by
1548 * some pad, so make a copy. */
1549 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1550 SvREADONLY_on(PAD_SVl(ix));
1551 SvREFCNT_dec(cSVOPo->op_sv);
1553 else if (o->op_type != OP_METHOD_NAMED
1554 && cSVOPo->op_sv == &PL_sv_undef) {
1555 /* PL_sv_undef is hack - it's unsafe to store it in the
1556 AV that is the pad, because av_fetch treats values of
1557 PL_sv_undef as a "free" AV entry and will merrily
1558 replace them with a new SV, causing pad_alloc to think
1559 that this pad slot is free. (When, clearly, it is not)
1561 SvOK_off(PAD_SVl(ix));
1562 SvPADTMP_on(PAD_SVl(ix));
1563 SvREADONLY_on(PAD_SVl(ix));
1566 SvREFCNT_dec(PAD_SVl(ix));
1567 SvPADTMP_on(cSVOPo->op_sv);
1568 PAD_SETSV(ix, cSVOPo->op_sv);
1569 /* XXX I don't know how this isn't readonly already. */
1570 SvREADONLY_on(PAD_SVl(ix));
1572 cSVOPo->op_sv = NULL;
1583 const char *key = NULL;
1586 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1589 /* Make the CONST have a shared SV */
1590 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1591 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1592 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1593 key = SvPV_const(sv, keylen);
1594 lexname = newSVpvn_share(key,
1595 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1601 if ((o->op_private & (OPpLVAL_INTRO)))
1604 rop = (UNOP*)((BINOP*)o)->op_first;
1605 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1607 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1608 if (!SvPAD_TYPED(lexname))
1610 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1611 if (!fields || !GvHV(*fields))
1613 key = SvPV_const(*svp, keylen);
1614 if (!hv_fetch(GvHV(*fields), key,
1615 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1616 Perl_croak(aTHX_ "No such class field \"%s\" "
1617 "in variable %s of type %s",
1618 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
1630 SVOP *first_key_op, *key_op;
1632 if ((o->op_private & (OPpLVAL_INTRO))
1633 /* I bet there's always a pushmark... */
1634 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1635 /* hmmm, no optimization if list contains only one key. */
1637 rop = (UNOP*)((LISTOP*)o)->op_last;
1638 if (rop->op_type != OP_RV2HV)
1640 if (rop->op_first->op_type == OP_PADSV)
1641 /* @$hash{qw(keys here)} */
1642 rop = (UNOP*)rop->op_first;
1644 /* @{$hash}{qw(keys here)} */
1645 if (rop->op_first->op_type == OP_SCOPE
1646 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1648 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1654 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1655 if (!SvPAD_TYPED(lexname))
1657 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1658 if (!fields || !GvHV(*fields))
1660 /* Again guessing that the pushmark can be jumped over.... */
1661 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1662 ->op_first->op_sibling;
1663 for (key_op = first_key_op; key_op;
1664 key_op = (SVOP*)key_op->op_sibling) {
1665 if (key_op->op_type != OP_CONST)
1667 svp = cSVOPx_svp(key_op);
1668 key = SvPV_const(*svp, keylen);
1669 if (!hv_fetch(GvHV(*fields), key,
1670 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1671 Perl_croak(aTHX_ "No such class field \"%s\" "
1672 "in variable %s of type %s",
1673 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
1679 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1680 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1687 if (o->op_flags & OPf_KIDS) {
1689 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1695 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1697 Propagate lvalue ("modifiable") context to an op and its children.
1698 I<type> represents the context type, roughly based on the type of op that
1699 would do the modifying, although C<local()> is represented by OP_NULL,
1700 because it has no op type of its own (it is signalled by a flag on
1703 This function detects things that can't be modified, such as C<$x+1>, and
1704 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1705 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1707 It also flags things that need to behave specially in an lvalue context,
1708 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1714 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1718 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1721 if (!o || (PL_parser && PL_parser->error_count))
1724 if ((o->op_private & OPpTARGET_MY)
1725 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1730 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1732 switch (o->op_type) {
1738 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1742 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1743 !(o->op_flags & OPf_STACKED)) {
1744 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1745 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1746 poses, so we need it clear. */
1747 o->op_private &= ~1;
1748 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1749 assert(cUNOPo->op_first->op_type == OP_NULL);
1750 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1753 else { /* lvalue subroutine call */
1754 o->op_private |= OPpLVAL_INTRO
1755 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1756 PL_modcount = RETURN_UNLIMITED_NUMBER;
1757 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1758 /* Backward compatibility mode: */
1759 o->op_private |= OPpENTERSUB_INARGS;
1762 else { /* Compile-time error message: */
1763 OP *kid = cUNOPo->op_first;
1767 if (kid->op_type != OP_PUSHMARK) {
1768 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1770 "panic: unexpected lvalue entersub "
1771 "args: type/targ %ld:%"UVuf,
1772 (long)kid->op_type, (UV)kid->op_targ);
1773 kid = kLISTOP->op_first;
1775 while (kid->op_sibling)
1776 kid = kid->op_sibling;
1777 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1779 if (kid->op_type == OP_METHOD_NAMED
1780 || kid->op_type == OP_METHOD)
1784 NewOp(1101, newop, 1, UNOP);
1785 newop->op_type = OP_RV2CV;
1786 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1787 newop->op_first = NULL;
1788 newop->op_next = (OP*)newop;
1789 kid->op_sibling = (OP*)newop;
1790 newop->op_private |= OPpLVAL_INTRO;
1791 newop->op_private &= ~1;
1795 if (kid->op_type != OP_RV2CV)
1797 "panic: unexpected lvalue entersub "
1798 "entry via type/targ %ld:%"UVuf,
1799 (long)kid->op_type, (UV)kid->op_targ);
1800 kid->op_private |= OPpLVAL_INTRO;
1801 break; /* Postpone until runtime */
1805 kid = kUNOP->op_first;
1806 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1807 kid = kUNOP->op_first;
1808 if (kid->op_type == OP_NULL)
1810 "Unexpected constant lvalue entersub "
1811 "entry via type/targ %ld:%"UVuf,
1812 (long)kid->op_type, (UV)kid->op_targ);
1813 if (kid->op_type != OP_GV) {
1814 /* Restore RV2CV to check lvalueness */
1816 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1817 okid->op_next = kid->op_next;
1818 kid->op_next = okid;
1821 okid->op_next = NULL;
1822 okid->op_type = OP_RV2CV;
1824 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1825 okid->op_private |= OPpLVAL_INTRO;
1826 okid->op_private &= ~1;
1830 cv = GvCV(kGVOP_gv);
1840 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1841 /* grep, foreach, subcalls, refgen */
1842 if (type == OP_GREPSTART || type == OP_ENTERSUB
1843 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1845 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1846 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1848 : (o->op_type == OP_ENTERSUB
1849 ? "non-lvalue subroutine call"
1851 type ? PL_op_desc[type] : "local"));
1865 case OP_RIGHT_SHIFT:
1874 if (!(o->op_flags & OPf_STACKED))
1881 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1882 op_lvalue(kid, type);
1887 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1888 PL_modcount = RETURN_UNLIMITED_NUMBER;
1889 return o; /* Treat \(@foo) like ordinary list. */
1893 if (scalar_mod_type(o, type))
1895 ref(cUNOPo->op_first, o->op_type);
1899 if (type == OP_LEAVESUBLV)
1900 o->op_private |= OPpMAYBE_LVSUB;
1906 PL_modcount = RETURN_UNLIMITED_NUMBER;
1909 PL_hints |= HINT_BLOCK_SCOPE;
1910 if (type == OP_LEAVESUBLV)
1911 o->op_private |= OPpMAYBE_LVSUB;
1915 ref(cUNOPo->op_first, o->op_type);
1919 PL_hints |= HINT_BLOCK_SCOPE;
1928 case OP_AELEMFAST_LEX:
1935 PL_modcount = RETURN_UNLIMITED_NUMBER;
1936 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1937 return o; /* Treat \(@foo) like ordinary list. */
1938 if (scalar_mod_type(o, type))
1940 if (type == OP_LEAVESUBLV)
1941 o->op_private |= OPpMAYBE_LVSUB;
1945 if (!type) /* local() */
1946 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1947 PAD_COMPNAME_SV(o->op_targ));
1956 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1960 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1966 if (type == OP_LEAVESUBLV)
1967 o->op_private |= OPpMAYBE_LVSUB;
1968 pad_free(o->op_targ);
1969 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1970 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1971 if (o->op_flags & OPf_KIDS)
1972 op_lvalue(cBINOPo->op_first->op_sibling, type);
1977 ref(cBINOPo->op_first, o->op_type);
1978 if (type == OP_ENTERSUB &&
1979 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1980 o->op_private |= OPpLVAL_DEFER;
1981 if (type == OP_LEAVESUBLV)
1982 o->op_private |= OPpMAYBE_LVSUB;
1992 if (o->op_flags & OPf_KIDS)
1993 op_lvalue(cLISTOPo->op_last, type);
1998 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2000 else if (!(o->op_flags & OPf_KIDS))
2002 if (o->op_targ != OP_LIST) {
2003 op_lvalue(cBINOPo->op_first, type);
2009 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2010 /* elements might be in void context because the list is
2011 in scalar context or because they are attribute sub calls */
2012 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2013 op_lvalue(kid, type);
2017 if (type != OP_LEAVESUBLV)
2019 break; /* op_lvalue()ing was handled by ck_return() */
2022 /* [20011101.069] File test operators interpret OPf_REF to mean that
2023 their argument is a filehandle; thus \stat(".") should not set
2025 if (type == OP_REFGEN &&
2026 PL_check[o->op_type] == Perl_ck_ftst)
2029 if (type != OP_LEAVESUBLV)
2030 o->op_flags |= OPf_MOD;
2032 if (type == OP_AASSIGN || type == OP_SASSIGN)
2033 o->op_flags |= OPf_SPECIAL|OPf_REF;
2034 else if (!type) { /* local() */
2037 o->op_private |= OPpLVAL_INTRO;
2038 o->op_flags &= ~OPf_SPECIAL;
2039 PL_hints |= HINT_BLOCK_SCOPE;
2044 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2045 "Useless localization of %s", OP_DESC(o));
2048 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2049 && type != OP_LEAVESUBLV)
2050 o->op_flags |= OPf_REF;
2055 S_scalar_mod_type(const OP *o, I32 type)
2057 assert(o || type != OP_SASSIGN);
2061 if (o->op_type == OP_RV2GV)
2085 case OP_RIGHT_SHIFT:
2106 S_is_handle_constructor(const OP *o, I32 numargs)
2108 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2110 switch (o->op_type) {
2118 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2131 S_refkids(pTHX_ OP *o, I32 type)
2133 if (o && o->op_flags & OPf_KIDS) {
2135 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2142 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2147 PERL_ARGS_ASSERT_DOREF;
2149 if (!o || (PL_parser && PL_parser->error_count))
2152 switch (o->op_type) {
2154 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2155 !(o->op_flags & OPf_STACKED)) {
2156 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2157 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2158 assert(cUNOPo->op_first->op_type == OP_NULL);
2159 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2160 o->op_flags |= OPf_SPECIAL;
2161 o->op_private &= ~1;
2163 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2164 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2165 : type == OP_RV2HV ? OPpDEREF_HV
2167 o->op_flags |= OPf_MOD;
2173 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2174 doref(kid, type, set_op_ref);
2177 if (type == OP_DEFINED)
2178 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2179 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2182 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2183 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2184 : type == OP_RV2HV ? OPpDEREF_HV
2186 o->op_flags |= OPf_MOD;
2193 o->op_flags |= OPf_REF;
2196 if (type == OP_DEFINED)
2197 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2198 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2204 o->op_flags |= OPf_REF;
2209 if (!(o->op_flags & OPf_KIDS))
2211 doref(cBINOPo->op_first, type, set_op_ref);
2215 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2216 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2217 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2218 : type == OP_RV2HV ? OPpDEREF_HV
2220 o->op_flags |= OPf_MOD;
2230 if (!(o->op_flags & OPf_KIDS))
2232 doref(cLISTOPo->op_last, type, set_op_ref);
2242 S_dup_attrlist(pTHX_ OP *o)
2247 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2249 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2250 * where the first kid is OP_PUSHMARK and the remaining ones
2251 * are OP_CONST. We need to push the OP_CONST values.
2253 if (o->op_type == OP_CONST)
2254 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2256 else if (o->op_type == OP_NULL)
2260 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2262 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2263 if (o->op_type == OP_CONST)
2264 rop = op_append_elem(OP_LIST, rop,
2265 newSVOP(OP_CONST, o->op_flags,
2266 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2273 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2278 PERL_ARGS_ASSERT_APPLY_ATTRS;
2280 /* fake up C<use attributes $pkg,$rv,@attrs> */
2281 ENTER; /* need to protect against side-effects of 'use' */
2282 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2284 #define ATTRSMODULE "attributes"
2285 #define ATTRSMODULE_PM "attributes.pm"
2288 /* Don't force the C<use> if we don't need it. */
2289 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2290 if (svp && *svp != &PL_sv_undef)
2291 NOOP; /* already in %INC */
2293 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2294 newSVpvs(ATTRSMODULE), NULL);
2297 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2298 newSVpvs(ATTRSMODULE),
2300 op_prepend_elem(OP_LIST,
2301 newSVOP(OP_CONST, 0, stashsv),
2302 op_prepend_elem(OP_LIST,
2303 newSVOP(OP_CONST, 0,
2305 dup_attrlist(attrs))));
2311 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2314 OP *pack, *imop, *arg;
2317 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2322 assert(target->op_type == OP_PADSV ||
2323 target->op_type == OP_PADHV ||
2324 target->op_type == OP_PADAV);
2326 /* Ensure that attributes.pm is loaded. */
2327 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2329 /* Need package name for method call. */
2330 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2332 /* Build up the real arg-list. */
2333 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2335 arg = newOP(OP_PADSV, 0);
2336 arg->op_targ = target->op_targ;
2337 arg = op_prepend_elem(OP_LIST,
2338 newSVOP(OP_CONST, 0, stashsv),
2339 op_prepend_elem(OP_LIST,
2340 newUNOP(OP_REFGEN, 0,
2341 op_lvalue(arg, OP_REFGEN)),
2342 dup_attrlist(attrs)));
2344 /* Fake up a method call to import */
2345 meth = newSVpvs_share("import");
2346 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2347 op_append_elem(OP_LIST,
2348 op_prepend_elem(OP_LIST, pack, list(arg)),
2349 newSVOP(OP_METHOD_NAMED, 0, meth)));
2351 /* Combine the ops. */
2352 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2356 =notfor apidoc apply_attrs_string
2358 Attempts to apply a list of attributes specified by the C<attrstr> and
2359 C<len> arguments to the subroutine identified by the C<cv> argument which
2360 is expected to be associated with the package identified by the C<stashpv>
2361 argument (see L<attributes>). It gets this wrong, though, in that it
2362 does not correctly identify the boundaries of the individual attribute
2363 specifications within C<attrstr>. This is not really intended for the
2364 public API, but has to be listed here for systems such as AIX which
2365 need an explicit export list for symbols. (It's called from XS code
2366 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2367 to respect attribute syntax properly would be welcome.
2373 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2374 const char *attrstr, STRLEN len)
2378 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2381 len = strlen(attrstr);
2385 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2387 const char * const sstr = attrstr;
2388 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2389 attrs = op_append_elem(OP_LIST, attrs,
2390 newSVOP(OP_CONST, 0,
2391 newSVpvn(sstr, attrstr-sstr)));
2395 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2396 newSVpvs(ATTRSMODULE),
2397 NULL, op_prepend_elem(OP_LIST,
2398 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2399 op_prepend_elem(OP_LIST,
2400 newSVOP(OP_CONST, 0,
2401 newRV(MUTABLE_SV(cv))),
2406 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2410 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2412 PERL_ARGS_ASSERT_MY_KID;
2414 if (!o || (PL_parser && PL_parser->error_count))
2418 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2419 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2423 if (type == OP_LIST) {
2425 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2426 my_kid(kid, attrs, imopsp);
2427 } else if (type == OP_UNDEF
2433 } else if (type == OP_RV2SV || /* "our" declaration */
2435 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2436 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2437 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2439 PL_parser->in_my == KEY_our
2441 : PL_parser->in_my == KEY_state ? "state" : "my"));
2443 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2444 PL_parser->in_my = FALSE;
2445 PL_parser->in_my_stash = NULL;
2446 apply_attrs(GvSTASH(gv),
2447 (type == OP_RV2SV ? GvSV(gv) :
2448 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2449 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2452 o->op_private |= OPpOUR_INTRO;
2455 else if (type != OP_PADSV &&
2458 type != OP_PUSHMARK)
2460 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2462 PL_parser->in_my == KEY_our
2464 : PL_parser->in_my == KEY_state ? "state" : "my"));
2467 else if (attrs && type != OP_PUSHMARK) {
2470 PL_parser->in_my = FALSE;
2471 PL_parser->in_my_stash = NULL;
2473 /* check for C<my Dog $spot> when deciding package */
2474 stash = PAD_COMPNAME_TYPE(o->op_targ);
2476 stash = PL_curstash;
2477 apply_attrs_my(stash, o, attrs, imopsp);
2479 o->op_flags |= OPf_MOD;
2480 o->op_private |= OPpLVAL_INTRO;
2482 o->op_private |= OPpPAD_STATE;
2487 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2491 int maybe_scalar = 0;
2493 PERL_ARGS_ASSERT_MY_ATTRS;
2495 /* [perl #17376]: this appears to be premature, and results in code such as
2496 C< our(%x); > executing in list mode rather than void mode */
2498 if (o->op_flags & OPf_PARENS)
2508 o = my_kid(o, attrs, &rops);
2510 if (maybe_scalar && o->op_type == OP_PADSV) {
2511 o = scalar(op_append_list(OP_LIST, rops, o));
2512 o->op_private |= OPpLVAL_INTRO;
2515 /* The listop in rops might have a pushmark at the beginning,
2516 which will mess up list assignment. */
2517 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2518 if (rops->op_type == OP_LIST &&
2519 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2521 OP * const pushmark = lrops->op_first;
2522 lrops->op_first = pushmark->op_sibling;
2525 o = op_append_list(OP_LIST, o, rops);
2528 PL_parser->in_my = FALSE;
2529 PL_parser->in_my_stash = NULL;
2534 Perl_sawparens(pTHX_ OP *o)
2536 PERL_UNUSED_CONTEXT;
2538 o->op_flags |= OPf_PARENS;
2543 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2547 const OPCODE ltype = left->op_type;
2548 const OPCODE rtype = right->op_type;
2550 PERL_ARGS_ASSERT_BIND_MATCH;
2552 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2553 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2555 const char * const desc
2557 rtype == OP_SUBST || rtype == OP_TRANS
2558 || rtype == OP_TRANSR
2560 ? (int)rtype : OP_MATCH];
2561 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2564 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2565 ? cUNOPx(left)->op_first->op_type == OP_GV
2566 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2567 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2569 : varname(NULL, isary ? '@' : '%', left->op_targ, NULL, 0, 1);
2571 Perl_warner(aTHX_ packWARN(WARN_MISC),
2572 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2575 const char * const sample = (isary
2576 ? "@array" : "%hash");
2577 Perl_warner(aTHX_ packWARN(WARN_MISC),
2578 "Applying %s to %s will act on scalar(%s)",
2579 desc, sample, sample);
2583 if (rtype == OP_CONST &&
2584 cSVOPx(right)->op_private & OPpCONST_BARE &&
2585 cSVOPx(right)->op_private & OPpCONST_STRICT)
2587 no_bareword_allowed(right);
2590 /* !~ doesn't make sense with /r, so error on it for now */
2591 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2593 yyerror("Using !~ with s///r doesn't make sense");
2594 if (rtype == OP_TRANSR && type == OP_NOT)
2595 yyerror("Using !~ with tr///r doesn't make sense");
2597 ismatchop = (rtype == OP_MATCH ||
2598 rtype == OP_SUBST ||
2599 rtype == OP_TRANS || rtype == OP_TRANSR)
2600 && !(right->op_flags & OPf_SPECIAL);
2601 if (ismatchop && right->op_private & OPpTARGET_MY) {
2603 right->op_private &= ~OPpTARGET_MY;
2605 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2608 right->op_flags |= OPf_STACKED;
2609 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2610 ! (rtype == OP_TRANS &&
2611 right->op_private & OPpTRANS_IDENTICAL) &&
2612 ! (rtype == OP_SUBST &&
2613 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2614 newleft = op_lvalue(left, rtype);
2617 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2618 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2620 o = op_prepend_elem(rtype, scalar(newleft), right);
2622 return newUNOP(OP_NOT, 0, scalar(o));
2626 return bind_match(type, left,
2627 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2631 Perl_invert(pTHX_ OP *o)
2635 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2639 =for apidoc Amx|OP *|op_scope|OP *o
2641 Wraps up an op tree with some additional ops so that at runtime a dynamic
2642 scope will be created. The original ops run in the new dynamic scope,
2643 and then, provided that they exit normally, the scope will be unwound.
2644 The additional ops used to create and unwind the dynamic scope will
2645 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2646 instead if the ops are simple enough to not need the full dynamic scope
2653 Perl_op_scope(pTHX_ OP *o)
2657 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2658 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2659 o->op_type = OP_LEAVE;
2660 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2662 else if (o->op_type == OP_LINESEQ) {
2664 o->op_type = OP_SCOPE;
2665 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2666 kid = ((LISTOP*)o)->op_first;
2667 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2670 /* The following deals with things like 'do {1 for 1}' */
2671 kid = kid->op_sibling;
2673 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2678 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2684 Perl_block_start(pTHX_ int full)
2687 const int retval = PL_savestack_ix;
2689 pad_block_start(full);
2691 PL_hints &= ~HINT_BLOCK_SCOPE;
2692 SAVECOMPILEWARNINGS();
2693 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2695 CALL_BLOCK_HOOKS(bhk_start, full);
2701 Perl_block_end(pTHX_ I32 floor, OP *seq)
2704 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2705 OP* retval = scalarseq(seq);
2707 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2710 CopHINTS_set(&PL_compiling, PL_hints);
2712 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2715 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2721 =head1 Compile-time scope hooks
2723 =for apidoc Aox||blockhook_register
2725 Register a set of hooks to be called when the Perl lexical scope changes
2726 at compile time. See L<perlguts/"Compile-time scope hooks">.
2732 Perl_blockhook_register(pTHX_ BHK *hk)
2734 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2736 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2743 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2744 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2745 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2748 OP * const o = newOP(OP_PADSV, 0);
2749 o->op_targ = offset;
2755 Perl_newPROG(pTHX_ OP *o)
2759 PERL_ARGS_ASSERT_NEWPROG;
2765 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2766 ((PL_in_eval & EVAL_KEEPERR)
2767 ? OPf_SPECIAL : 0), o);
2769 cx = &cxstack[cxstack_ix];
2770 assert(CxTYPE(cx) == CXt_EVAL);
2772 if ((cx->blk_gimme & G_WANT) == G_VOID)
2773 scalarvoid(PL_eval_root);
2774 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2777 scalar(PL_eval_root);
2779 /* don't use LINKLIST, since PL_eval_root might indirect through
2780 * a rather expensive function call and LINKLIST evaluates its
2781 * argument more than once */
2782 PL_eval_start = op_linklist(PL_eval_root);
2783 PL_eval_root->op_private |= OPpREFCOUNTED;
2784 OpREFCNT_set(PL_eval_root, 1);
2785 PL_eval_root->op_next = 0;
2786 CALL_PEEP(PL_eval_start);
2787 finalize_optree(PL_eval_root);
2791 if (o->op_type == OP_STUB) {
2792 PL_comppad_name = 0;
2794 S_op_destroy(aTHX_ o);
2797 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2798 PL_curcop = &PL_compiling;
2799 PL_main_start = LINKLIST(PL_main_root);
2800 PL_main_root->op_private |= OPpREFCOUNTED;
2801 OpREFCNT_set(PL_main_root, 1);
2802 PL_main_root->op_next = 0;
2803 CALL_PEEP(PL_main_start);
2804 finalize_optree(PL_main_root);
2807 /* Register with debugger */
2809 CV * const cv = get_cvs("DB::postponed", 0);
2813 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2815 call_sv(MUTABLE_SV(cv), G_DISCARD);
2822 Perl_localize(pTHX_ OP *o, I32 lex)
2826 PERL_ARGS_ASSERT_LOCALIZE;
2828 if (o->op_flags & OPf_PARENS)
2829 /* [perl #17376]: this appears to be premature, and results in code such as
2830 C< our(%x); > executing in list mode rather than void mode */
2837 if ( PL_parser->bufptr > PL_parser->oldbufptr
2838 && PL_parser->bufptr[-1] == ','
2839 && ckWARN(WARN_PARENTHESIS))
2841 char *s = PL_parser->bufptr;
2844 /* some heuristics to detect a potential error */
2845 while (*s && (strchr(", \t\n", *s)))
2849 if (*s && strchr("@$%*", *s) && *++s
2850 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2853 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2855 while (*s && (strchr(", \t\n", *s)))
2861 if (sigil && (*s == ';' || *s == '=')) {
2862 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2863 "Parentheses missing around \"%s\" list",
2865 ? (PL_parser->in_my == KEY_our
2867 : PL_parser->in_my == KEY_state
2877 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2878 PL_parser->in_my = FALSE;
2879 PL_parser->in_my_stash = NULL;
2884 Perl_jmaybe(pTHX_ OP *o)
2886 PERL_ARGS_ASSERT_JMAYBE;
2888 if (o->op_type == OP_LIST) {
2890 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2891 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2896 PERL_STATIC_INLINE OP *
2897 S_op_std_init(pTHX_ OP *o)
2899 I32 type = o->op_type;
2901 PERL_ARGS_ASSERT_OP_STD_INIT;
2903 if (PL_opargs[type] & OA_RETSCALAR)
2905 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2906 o->op_targ = pad_alloc(type, SVs_PADTMP);
2911 PERL_STATIC_INLINE OP *
2912 S_op_integerize(pTHX_ OP *o)
2914 I32 type = o->op_type;
2916 PERL_ARGS_ASSERT_OP_INTEGERIZE;
2918 /* integerize op, unless it happens to be C<-foo>.
2919 * XXX should pp_i_negate() do magic string negation instead? */
2920 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2921 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2922 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2925 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2928 if (type == OP_NEGATE)
2929 /* XXX might want a ck_negate() for this */
2930 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2936 S_fold_constants(pTHX_ register OP *o)
2939 register OP * VOL curop;
2941 VOL I32 type = o->op_type;
2946 SV * const oldwarnhook = PL_warnhook;
2947 SV * const olddiehook = PL_diehook;
2951 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2953 if (!(PL_opargs[type] & OA_FOLDCONST))
2967 /* XXX what about the numeric ops? */
2968 if (PL_hints & HINT_LOCALE)
2973 if (PL_parser && PL_parser->error_count)
2974 goto nope; /* Don't try to run w/ errors */
2976 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2977 const OPCODE type = curop->op_type;
2978 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2980 type != OP_SCALAR &&
2982 type != OP_PUSHMARK)
2988 curop = LINKLIST(o);
2989 old_next = o->op_next;
2993 oldscope = PL_scopestack_ix;
2994 create_eval_scope(G_FAKINGEVAL);
2996 /* Verify that we don't need to save it: */
2997 assert(PL_curcop == &PL_compiling);
2998 StructCopy(&PL_compiling, ¬_compiling, COP);
2999 PL_curcop = ¬_compiling;
3000 /* The above ensures that we run with all the correct hints of the
3001 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3002 assert(IN_PERL_RUNTIME);
3003 PL_warnhook = PERL_WARNHOOK_FATAL;
3010 sv = *(PL_stack_sp--);
3011 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3013 /* Can't simply swipe the SV from the pad, because that relies on
3014 the op being freed "real soon now". Under MAD, this doesn't
3015 happen (see the #ifdef below). */
3018 pad_swipe(o->op_targ, FALSE);
3021 else if (SvTEMP(sv)) { /* grab mortal temp? */
3022 SvREFCNT_inc_simple_void(sv);
3027 /* Something tried to die. Abandon constant folding. */
3028 /* Pretend the error never happened. */
3030 o->op_next = old_next;
3034 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3035 PL_warnhook = oldwarnhook;
3036 PL_diehook = olddiehook;
3037 /* XXX note that this croak may fail as we've already blown away
3038 * the stack - eg any nested evals */
3039 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3042 PL_warnhook = oldwarnhook;
3043 PL_diehook = olddiehook;
3044 PL_curcop = &PL_compiling;
3046 if (PL_scopestack_ix > oldscope)
3047 delete_eval_scope();
3056 if (type == OP_RV2GV)
3057 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3059 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3060 op_getmad(o,newop,'f');
3068 S_gen_constant_list(pTHX_ register OP *o)
3072 const I32 oldtmps_floor = PL_tmps_floor;
3075 if (PL_parser && PL_parser->error_count)
3076 return o; /* Don't attempt to run with errors */
3078 PL_op = curop = LINKLIST(o);
3081 Perl_pp_pushmark(aTHX);
3084 assert (!(curop->op_flags & OPf_SPECIAL));
3085 assert(curop->op_type == OP_RANGE);
3086 Perl_pp_anonlist(aTHX);
3087 PL_tmps_floor = oldtmps_floor;
3089 o->op_type = OP_RV2AV;
3090 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3091 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3092 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3093 o->op_opt = 0; /* needs to be revisited in rpeep() */
3094 curop = ((UNOP*)o)->op_first;
3095 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3097 op_getmad(curop,o,'O');
3106 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3109 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3110 if (!o || o->op_type != OP_LIST)
3111 o = newLISTOP(OP_LIST, 0, o, NULL);
3113 o->op_flags &= ~OPf_WANT;
3115 if (!(PL_opargs[type] & OA_MARK))
3116 op_null(cLISTOPo->op_first);
3118 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3119 if (kid2 && kid2->op_type == OP_COREARGS) {
3120 op_null(cLISTOPo->op_first);
3121 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3125 o->op_type = (OPCODE)type;
3126 o->op_ppaddr = PL_ppaddr[type];
3127 o->op_flags |= flags;
3129 o = CHECKOP(type, o);
3130 if (o->op_type != (unsigned)type)
3133 return fold_constants(op_integerize(op_std_init(o)));
3137 =head1 Optree Manipulation Functions
3140 /* List constructors */
3143 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3145 Append an item to the list of ops contained directly within a list-type
3146 op, returning the lengthened list. I<first> is the list-type op,
3147 and I<last> is the op to append to the list. I<optype> specifies the
3148 intended opcode for the list. If I<first> is not already a list of the
3149 right type, it will be upgraded into one. If either I<first> or I<last>
3150 is null, the other is returned unchanged.
3156 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3164 if (first->op_type != (unsigned)type
3165 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3167 return newLISTOP(type, 0, first, last);
3170 if (first->op_flags & OPf_KIDS)
3171 ((LISTOP*)first)->op_last->op_sibling = last;
3173 first->op_flags |= OPf_KIDS;
3174 ((LISTOP*)first)->op_first = last;
3176 ((LISTOP*)first)->op_last = last;
3181 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3183 Concatenate the lists of ops contained directly within two list-type ops,
3184 returning the combined list. I<first> and I<last> are the list-type ops
3185 to concatenate. I<optype> specifies the intended opcode for the list.
3186 If either I<first> or I<last> is not already a list of the right type,
3187 it will be upgraded into one. If either I<first> or I<last> is null,
3188 the other is returned unchanged.
3194 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3202 if (first->op_type != (unsigned)type)
3203 return op_prepend_elem(type, first, last);
3205 if (last->op_type != (unsigned)type)
3206 return op_append_elem(type, first, last);
3208 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3209 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3210 first->op_flags |= (last->op_flags & OPf_KIDS);
3213 if (((LISTOP*)last)->op_first && first->op_madprop) {
3214 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3216 while (mp->mad_next)
3218 mp->mad_next = first->op_madprop;
3221 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3224 first->op_madprop = last->op_madprop;
3225 last->op_madprop = 0;
3228 S_op_destroy(aTHX_ last);
3234 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3236 Prepend an item to the list of ops contained directly within a list-type
3237 op, returning the lengthened list. I<first> is the op to prepend to the
3238 list, and I<last> is the list-type op. I<optype> specifies the intended
3239 opcode for the list. If I<last> is not already a list of the right type,
3240 it will be upgraded into one. If either I<first> or I<last> is null,
3241 the other is returned unchanged.
3247 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3255 if (last->op_type == (unsigned)type) {
3256 if (type == OP_LIST) { /* already a PUSHMARK there */
3257 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3258 ((LISTOP*)last)->op_first->op_sibling = first;
3259 if (!(first->op_flags & OPf_PARENS))
3260 last->op_flags &= ~OPf_PARENS;
3263 if (!(last->op_flags & OPf_KIDS)) {
3264 ((LISTOP*)last)->op_last = first;
3265 last->op_flags |= OPf_KIDS;
3267 first->op_sibling = ((LISTOP*)last)->op_first;
3268 ((LISTOP*)last)->op_first = first;
3270 last->op_flags |= OPf_KIDS;
3274 return newLISTOP(type, 0, first, last);
3282 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3285 Newxz(tk, 1, TOKEN);
3286 tk->tk_type = (OPCODE)optype;
3287 tk->tk_type = 12345;
3289 tk->tk_mad = madprop;
3294 Perl_token_free(pTHX_ TOKEN* tk)
3296 PERL_ARGS_ASSERT_TOKEN_FREE;
3298 if (tk->tk_type != 12345)
3300 mad_free(tk->tk_mad);
3305 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3310 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3312 if (tk->tk_type != 12345) {
3313 Perl_warner(aTHX_ packWARN(WARN_MISC),
3314 "Invalid TOKEN object ignored");
3321 /* faked up qw list? */
3323 tm->mad_type == MAD_SV &&
3324 SvPVX((SV *)tm->mad_val)[0] == 'q')
3331 /* pretend constant fold didn't happen? */
3332 if (mp->mad_key == 'f' &&
3333 (o->op_type == OP_CONST ||
3334 o->op_type == OP_GV) )
3336 token_getmad(tk,(OP*)mp->mad_val,slot);
3350 if (mp->mad_key == 'X')
3351 mp->mad_key = slot; /* just change the first one */
3361 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3370 /* pretend constant fold didn't happen? */
3371 if (mp->mad_key == 'f' &&
3372 (o->op_type == OP_CONST ||
3373 o->op_type == OP_GV) )
3375 op_getmad(from,(OP*)mp->mad_val,slot);
3382 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3385 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3391 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3400 /* pretend constant fold didn't happen? */
3401 if (mp->mad_key == 'f' &&
3402 (o->op_type == OP_CONST ||
3403 o->op_type == OP_GV) )
3405 op_getmad(from,(OP*)mp->mad_val,slot);
3412 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3415 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3419 PerlIO_printf(PerlIO_stderr(),
3420 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3426 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3444 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3448 addmad(tm, &(o->op_madprop), slot);
3452 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3473 Perl_newMADsv(pTHX_ char key, SV* sv)
3475 PERL_ARGS_ASSERT_NEWMADSV;
3477 return newMADPROP(key, MAD_SV, sv, 0);
3481 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3483 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3486 mp->mad_vlen = vlen;
3487 mp->mad_type = type;
3489 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3494 Perl_mad_free(pTHX_ MADPROP* mp)
3496 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3500 mad_free(mp->mad_next);
3501 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3502 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3503 switch (mp->mad_type) {
3507 Safefree((char*)mp->mad_val);
3510 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3511 op_free((OP*)mp->mad_val);
3514 sv_free(MUTABLE_SV(mp->mad_val));
3517 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3520 PerlMemShared_free(mp);
3526 =head1 Optree construction
3528 =for apidoc Am|OP *|newNULLLIST
3530 Constructs, checks, and returns a new C<stub> op, which represents an
3531 empty list expression.
3537 Perl_newNULLLIST(pTHX)
3539 return newOP(OP_STUB, 0);
3543 S_force_list(pTHX_ OP *o)
3545 if (!o || o->op_type != OP_LIST)
3546 o = newLISTOP(OP_LIST, 0, o, NULL);
3552 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3554 Constructs, checks, and returns an op of any list type. I<type> is
3555 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3556 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3557 supply up to two ops to be direct children of the list op; they are
3558 consumed by this function and become part of the constructed op tree.
3564 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3569 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3571 NewOp(1101, listop, 1, LISTOP);
3573 listop->op_type = (OPCODE)type;
3574 listop->op_ppaddr = PL_ppaddr[type];
3577 listop->op_flags = (U8)flags;
3581 else if (!first && last)
3584 first->op_sibling = last;
3585 listop->op_first = first;
3586 listop->op_last = last;
3587 if (type == OP_LIST) {
3588 OP* const pushop = newOP(OP_PUSHMARK, 0);
3589 pushop->op_sibling = first;
3590 listop->op_first = pushop;
3591 listop->op_flags |= OPf_KIDS;
3593 listop->op_last = pushop;
3596 return CHECKOP(type, listop);
3600 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3602 Constructs, checks, and returns an op of any base type (any type that
3603 has no extra fields). I<type> is the opcode. I<flags> gives the
3604 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3611 Perl_newOP(pTHX_ I32 type, I32 flags)
3616 if (type == -OP_ENTEREVAL) {
3617 type = OP_ENTEREVAL;
3618 flags |= OPpEVAL_BYTES<<8;
3621 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3622 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3623 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3624 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3626 NewOp(1101, o, 1, OP);
3627 o->op_type = (OPCODE)type;
3628 o->op_ppaddr = PL_ppaddr[type];
3629 o->op_flags = (U8)flags;
3631 o->op_latefreed = 0;
3635 o->op_private = (U8)(0 | (flags >> 8));
3636 if (PL_opargs[type] & OA_RETSCALAR)
3638 if (PL_opargs[type] & OA_TARGET)
3639 o->op_targ = pad_alloc(type, SVs_PADTMP);
3640 return CHECKOP(type, o);
3644 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3646 Constructs, checks, and returns an op of any unary type. I<type> is
3647 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3648 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3649 bits, the eight bits of C<op_private>, except that the bit with value 1
3650 is automatically set. I<first> supplies an optional op to be the direct
3651 child of the unary op; it is consumed by this function and become part
3652 of the constructed op tree.
3658 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3663 if (type == -OP_ENTEREVAL) {
3664 type = OP_ENTEREVAL;
3665 flags |= OPpEVAL_BYTES<<8;
3668 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3669 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3670 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3671 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3672 || type == OP_SASSIGN
3673 || type == OP_ENTERTRY
3674 || type == OP_NULL );
3677 first = newOP(OP_STUB, 0);
3678 if (PL_opargs[type] & OA_MARK)
3679 first = force_list(first);
3681 NewOp(1101, unop, 1, UNOP);
3682 unop->op_type = (OPCODE)type;
3683 unop->op_ppaddr = PL_ppaddr[type];
3684 unop->op_first = first;
3685 unop->op_flags = (U8)(flags | OPf_KIDS);
3686 unop->op_private = (U8)(1 | (flags >> 8));
3687 unop = (UNOP*) CHECKOP(type, unop);
3691 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3695 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3697 Constructs, checks, and returns an op of any binary type. I<type>
3698 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3699 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3700 the eight bits of C<op_private>, except that the bit with value 1 or
3701 2 is automatically set as required. I<first> and I<last> supply up to
3702 two ops to be the direct children of the binary op; they are consumed
3703 by this function and become part of the constructed op tree.
3709 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3714 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3715 || type == OP_SASSIGN || type == OP_NULL );
3717 NewOp(1101, binop, 1, BINOP);
3720 first = newOP(OP_NULL, 0);
3722 binop->op_type = (OPCODE)type;
3723 binop->op_ppaddr = PL_ppaddr[type];
3724 binop->op_first = first;
3725 binop->op_flags = (U8)(flags | OPf_KIDS);
3728 binop->op_private = (U8)(1 | (flags >> 8));
3731 binop->op_private = (U8)(2 | (flags >> 8));
3732 first->op_sibling = last;
3735 binop = (BINOP*)CHECKOP(type, binop);
3736 if (binop->op_next || binop->op_type != (OPCODE)type)
3739 binop->op_last = binop->op_first->op_sibling;
3741 return fold_constants(op_integerize(op_std_init((OP *)binop)));
3744 static int uvcompare(const void *a, const void *b)
3745 __attribute__nonnull__(1)
3746 __attribute__nonnull__(2)
3747 __attribute__pure__;
3748 static int uvcompare(const void *a, const void *b)
3750 if (*((const UV *)a) < (*(const UV *)b))
3752 if (*((const UV *)a) > (*(const UV *)b))
3754 if (*((const UV *)a+1) < (*(const UV *)b+1))
3756 if (*((const UV *)a+1) > (*(const UV *)b+1))
3762 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3765 SV * const tstr = ((SVOP*)expr)->op_sv;
3768 (repl->op_type == OP_NULL)
3769 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3771 ((SVOP*)repl)->op_sv;
3774 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3775 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3779 register short *tbl;
3781 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3782 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3783 I32 del = o->op_private & OPpTRANS_DELETE;
3786 PERL_ARGS_ASSERT_PMTRANS;
3788 PL_hints |= HINT_BLOCK_SCOPE;
3791 o->op_private |= OPpTRANS_FROM_UTF;
3794 o->op_private |= OPpTRANS_TO_UTF;
3796 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3797 SV* const listsv = newSVpvs("# comment\n");
3799 const U8* tend = t + tlen;
3800 const U8* rend = r + rlen;
3814 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3815 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3818 const U32 flags = UTF8_ALLOW_DEFAULT;
3822 t = tsave = bytes_to_utf8(t, &len);
3825 if (!to_utf && rlen) {
3827 r = rsave = bytes_to_utf8(r, &len);
3831 /* There are several snags with this code on EBCDIC:
3832 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3833 2. scan_const() in toke.c has encoded chars in native encoding which makes
3834 ranges at least in EBCDIC 0..255 range the bottom odd.
3838 U8 tmpbuf[UTF8_MAXBYTES+1];
3841 Newx(cp, 2*tlen, UV);
3843 transv = newSVpvs("");
3845 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3847 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3849 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3853 cp[2*i+1] = cp[2*i];
3857 qsort(cp, i, 2*sizeof(UV), uvcompare);
3858 for (j = 0; j < i; j++) {
3860 diff = val - nextmin;
3862 t = uvuni_to_utf8(tmpbuf,nextmin);
3863 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3865 U8 range_mark = UTF_TO_NATIVE(0xff);
3866 t = uvuni_to_utf8(tmpbuf, val - 1);
3867 sv_catpvn(transv, (char *)&range_mark, 1);
3868 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3875 t = uvuni_to_utf8(tmpbuf,nextmin);
3876 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3878 U8 range_mark = UTF_TO_NATIVE(0xff);
3879 sv_catpvn(transv, (char *)&range_mark, 1);
3881 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3882 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3883 t = (const U8*)SvPVX_const(transv);
3884 tlen = SvCUR(transv);
3888 else if (!rlen && !del) {
3889 r = t; rlen = tlen; rend = tend;
3892 if ((!rlen && !del) || t == r ||
3893 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3895 o->op_private |= OPpTRANS_IDENTICAL;
3899 while (t < tend || tfirst <= tlast) {
3900 /* see if we need more "t" chars */
3901 if (tfirst > tlast) {
3902 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3904 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3906 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3913 /* now see if we need more "r" chars */
3914 if (rfirst > rlast) {
3916 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3918 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3920 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3929 rfirst = rlast = 0xffffffff;
3933 /* now see which range will peter our first, if either. */
3934 tdiff = tlast - tfirst;
3935 rdiff = rlast - rfirst;
3942 if (rfirst == 0xffffffff) {
3943 diff = tdiff; /* oops, pretend rdiff is infinite */
3945 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3946 (long)tfirst, (long)tlast);
3948 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3952 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3953 (long)tfirst, (long)(tfirst + diff),
3956 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3957 (long)tfirst, (long)rfirst);
3959 if (rfirst + diff > max)
3960 max = rfirst + diff;
3962 grows = (tfirst < rfirst &&
3963 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3975 else if (max > 0xff)
3980 PerlMemShared_free(cPVOPo->op_pv);
3981 cPVOPo->op_pv = NULL;
3983 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3985 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3986 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3987 PAD_SETSV(cPADOPo->op_padix, swash);
3989 SvREADONLY_on(swash);
3991 cSVOPo->op_sv = swash;
3993 SvREFCNT_dec(listsv);
3994 SvREFCNT_dec(transv);
3996 if (!del && havefinal && rlen)
3997 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3998 newSVuv((UV)final), 0);
4001 o->op_private |= OPpTRANS_GROWS;
4007 op_getmad(expr,o,'e');
4008 op_getmad(repl,o,'r');
4016 tbl = (short*)cPVOPo->op_pv;
4018 Zero(tbl, 256, short);
4019 for (i = 0; i < (I32)tlen; i++)
4021 for (i = 0, j = 0; i < 256; i++) {
4023 if (j >= (I32)rlen) {
4032 if (i < 128 && r[j] >= 128)
4042 o->op_private |= OPpTRANS_IDENTICAL;
4044 else if (j >= (I32)rlen)
4049 PerlMemShared_realloc(tbl,
4050 (0x101+rlen-j) * sizeof(short));
4051 cPVOPo->op_pv = (char*)tbl;
4053 tbl[0x100] = (short)(rlen - j);
4054 for (i=0; i < (I32)rlen - j; i++)
4055 tbl[0x101+i] = r[j+i];
4059 if (!rlen && !del) {
4062 o->op_private |= OPpTRANS_IDENTICAL;
4064 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4065 o->op_private |= OPpTRANS_IDENTICAL;
4067 for (i = 0; i < 256; i++)
4069 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4070 if (j >= (I32)rlen) {
4072 if (tbl[t[i]] == -1)
4078 if (tbl[t[i]] == -1) {
4079 if (t[i] < 128 && r[j] >= 128)
4086 if(del && rlen == tlen) {
4087 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4088 } else if(rlen > tlen) {
4089 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4093 o->op_private |= OPpTRANS_GROWS;
4095 op_getmad(expr,o,'e');
4096 op_getmad(repl,o,'r');
4106 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4108 Constructs, checks, and returns an op of any pattern matching type.
4109 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4110 and, shifted up eight bits, the eight bits of C<op_private>.
4116 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4121 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4123 NewOp(1101, pmop, 1, PMOP);
4124 pmop->op_type = (OPCODE)type;
4125 pmop->op_ppaddr = PL_ppaddr[type];
4126 pmop->op_flags = (U8)flags;
4127 pmop->op_private = (U8)(0 | (flags >> 8));
4129 if (PL_hints & HINT_RE_TAINT)
4130 pmop->op_pmflags |= PMf_RETAINT;
4131 if (PL_hints & HINT_LOCALE) {
4132 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4134 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
4135 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4137 if (PL_hints & HINT_RE_FLAGS) {
4138 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4139 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4141 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4142 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4143 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4145 if (reflags && SvOK(reflags)) {
4146 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4152 assert(SvPOK(PL_regex_pad[0]));
4153 if (SvCUR(PL_regex_pad[0])) {
4154 /* Pop off the "packed" IV from the end. */
4155 SV *const repointer_list = PL_regex_pad[0];
4156 const char *p = SvEND(repointer_list) - sizeof(IV);
4157 const IV offset = *((IV*)p);
4159 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4161 SvEND_set(repointer_list, p);
4163 pmop->op_pmoffset = offset;
4164 /* This slot should be free, so assert this: */
4165 assert(PL_regex_pad[offset] == &PL_sv_undef);
4167 SV * const repointer = &PL_sv_undef;
4168 av_push(PL_regex_padav, repointer);
4169 pmop->op_pmoffset = av_len(PL_regex_padav);
4170 PL_regex_pad = AvARRAY(PL_regex_padav);
4174 return CHECKOP(type, pmop);
4177 /* Given some sort of match op o, and an expression expr containing a
4178 * pattern, either compile expr into a regex and attach it to o (if it's
4179 * constant), or convert expr into a runtime regcomp op sequence (if it's
4182 * isreg indicates that the pattern is part of a regex construct, eg
4183 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4184 * split "pattern", which aren't. In the former case, expr will be a list
4185 * if the pattern contains more than one term (eg /a$b/) or if it contains
4186 * a replacement, ie s/// or tr///.
4190 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4195 I32 repl_has_vars = 0;
4199 PERL_ARGS_ASSERT_PMRUNTIME;
4202 o->op_type == OP_SUBST
4203 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4205 /* last element in list is the replacement; pop it */
4207 repl = cLISTOPx(expr)->op_last;
4208 kid = cLISTOPx(expr)->op_first;
4209 while (kid->op_sibling != repl)
4210 kid = kid->op_sibling;
4211 kid->op_sibling = NULL;
4212 cLISTOPx(expr)->op_last = kid;
4215 if (isreg && expr->op_type == OP_LIST &&
4216 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4218 /* convert single element list to element */
4219 OP* const oe = expr;
4220 expr = cLISTOPx(oe)->op_first->op_sibling;
4221 cLISTOPx(oe)->op_first->op_sibling = NULL;
4222 cLISTOPx(oe)->op_last = NULL;
4226 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4227 return pmtrans(o, expr, repl);
4230 reglist = isreg && expr->op_type == OP_LIST;
4234 PL_hints |= HINT_BLOCK_SCOPE;
4237 if (expr->op_type == OP_CONST) {
4238 SV *pat = ((SVOP*)expr)->op_sv;
4239 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4241 if (o->op_flags & OPf_SPECIAL)
4242 pm_flags |= RXf_SPLIT;
4245 assert (SvUTF8(pat));
4246 } else if (SvUTF8(pat)) {
4247 /* Not doing UTF-8, despite what the SV says. Is this only if we're
4248 trapped in use 'bytes'? */
4249 /* Make a copy of the octet sequence, but without the flag on, as
4250 the compiler now honours the SvUTF8 flag on pat. */
4252 const char *const p = SvPV(pat, len);
4253 pat = newSVpvn_flags(p, len, SVs_TEMP);
4256 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4259 op_getmad(expr,(OP*)pm,'e');
4265 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4266 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4268 : OP_REGCMAYBE),0,expr);
4270 NewOp(1101, rcop, 1, LOGOP);
4271 rcop->op_type = OP_REGCOMP;
4272 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4273 rcop->op_first = scalar(expr);
4274 rcop->op_flags |= OPf_KIDS
4275 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4276 | (reglist ? OPf_STACKED : 0);
4277 rcop->op_private = 1;
4280 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4282 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4283 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4285 /* establish postfix order */
4286 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4288 rcop->op_next = expr;
4289 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4292 rcop->op_next = LINKLIST(expr);
4293 expr->op_next = (OP*)rcop;
4296 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4301 if (pm->op_pmflags & PMf_EVAL) {
4303 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4304 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4306 else if (repl->op_type == OP_CONST)
4310 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4311 if (curop->op_type == OP_SCOPE
4312 || curop->op_type == OP_LEAVE
4313 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4314 if (curop->op_type == OP_GV) {
4315 GV * const gv = cGVOPx_gv(curop);
4317 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4320 else if (curop->op_type == OP_RV2CV)
4322 else if (curop->op_type == OP_RV2SV ||
4323 curop->op_type == OP_RV2AV ||
4324 curop->op_type == OP_RV2HV ||
4325 curop->op_type == OP_RV2GV) {
4326 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4329 else if (curop->op_type == OP_PADSV ||
4330 curop->op_type == OP_PADAV ||
4331 curop->op_type == OP_PADHV ||
4332 curop->op_type == OP_PADANY)
4336 else if (curop->op_type == OP_PUSHRE)
4337 NOOP; /* Okay here, dangerous in newASSIGNOP */
4347 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4349 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4350 op_prepend_elem(o->op_type, scalar(repl), o);
4353 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4354 pm->op_pmflags |= PMf_MAYBE_CONST;
4356 NewOp(1101, rcop, 1, LOGOP);
4357 rcop->op_type = OP_SUBSTCONT;
4358 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4359 rcop->op_first = scalar(repl);
4360 rcop->op_flags |= OPf_KIDS;
4361 rcop->op_private = 1;
4364 /* establish postfix order */
4365 rcop->op_next = LINKLIST(repl);
4366 repl->op_next = (OP*)rcop;
4368 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4369 assert(!(pm->op_pmflags & PMf_ONCE));
4370 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4379 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4381 Constructs, checks, and returns an op of any type that involves an
4382 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4383 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4384 takes ownership of one reference to it.
4390 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4395 PERL_ARGS_ASSERT_NEWSVOP;
4397 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4398 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4399 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4401 NewOp(1101, svop, 1, SVOP);
4402 svop->op_type = (OPCODE)type;
4403 svop->op_ppaddr = PL_ppaddr[type];
4405 svop->op_next = (OP*)svop;
4406 svop->op_flags = (U8)flags;
4407 if (PL_opargs[type] & OA_RETSCALAR)
4409 if (PL_opargs[type] & OA_TARGET)
4410 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4411 return CHECKOP(type, svop);
4417 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4419 Constructs, checks, and returns an op of any type that involves a
4420 reference to a pad element. I<type> is the opcode. I<flags> gives the
4421 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4422 is populated with I<sv>; this function takes ownership of one reference
4425 This function only exists if Perl has been compiled to use ithreads.
4431 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4436 PERL_ARGS_ASSERT_NEWPADOP;
4438 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4439 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4440 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4442 NewOp(1101, padop, 1, PADOP);
4443 padop->op_type = (OPCODE)type;
4444 padop->op_ppaddr = PL_ppaddr[type];
4445 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4446 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4447 PAD_SETSV(padop->op_padix, sv);
4450 padop->op_next = (OP*)padop;
4451 padop->op_flags = (U8)flags;
4452 if (PL_opargs[type] & OA_RETSCALAR)
4454 if (PL_opargs[type] & OA_TARGET)
4455 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4456 return CHECKOP(type, padop);
4459 #endif /* !USE_ITHREADS */
4462 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4464 Constructs, checks, and returns an op of any type that involves an
4465 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4466 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4467 reference; calling this function does not transfer ownership of any
4474 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4478 PERL_ARGS_ASSERT_NEWGVOP;
4482 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4484 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4489 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4491 Constructs, checks, and returns an op of any type that involves an
4492 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4493 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4494 must have been allocated using L</PerlMemShared_malloc>; the memory will
4495 be freed when the op is destroyed.
4501 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4506 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4507 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4509 NewOp(1101, pvop, 1, PVOP);
4510 pvop->op_type = (OPCODE)type;
4511 pvop->op_ppaddr = PL_ppaddr[type];
4513 pvop->op_next = (OP*)pvop;
4514 pvop->op_flags = (U8)flags;
4515 if (PL_opargs[type] & OA_RETSCALAR)
4517 if (PL_opargs[type] & OA_TARGET)
4518 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4519 return CHECKOP(type, pvop);
4527 Perl_package(pTHX_ OP *o)
4530 SV *const sv = cSVOPo->op_sv;
4535 PERL_ARGS_ASSERT_PACKAGE;
4537 SAVEGENERICSV(PL_curstash);
4538 save_item(PL_curstname);
4540 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4542 sv_setsv(PL_curstname, sv);
4544 PL_hints |= HINT_BLOCK_SCOPE;
4545 PL_parser->copline = NOLINE;
4546 PL_parser->expect = XSTATE;
4551 if (!PL_madskills) {
4556 pegop = newOP(OP_NULL,0);
4557 op_getmad(o,pegop,'P');
4563 Perl_package_version( pTHX_ OP *v )
4566 U32 savehints = PL_hints;
4567 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4568 PL_hints &= ~HINT_STRICT_VARS;
4569 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4570 PL_hints = savehints;
4579 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4586 OP *pegop = newOP(OP_NULL,0);
4588 SV *use_version = NULL;
4590 PERL_ARGS_ASSERT_UTILIZE;
4592 if (idop->op_type != OP_CONST)
4593 Perl_croak(aTHX_ "Module name must be constant");
4596 op_getmad(idop,pegop,'U');
4601 SV * const vesv = ((SVOP*)version)->op_sv;
4604 op_getmad(version,pegop,'V');
4605 if (!arg && !SvNIOKp(vesv)) {
4612 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4613 Perl_croak(aTHX_ "Version number must be a constant number");
4615 /* Make copy of idop so we don't free it twice */
4616 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4618 /* Fake up a method call to VERSION */
4619 meth = newSVpvs_share("VERSION");
4620 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4621 op_append_elem(OP_LIST,
4622 op_prepend_elem(OP_LIST, pack, list(version)),
4623 newSVOP(OP_METHOD_NAMED, 0, meth)));
4627 /* Fake up an import/unimport */
4628 if (arg && arg->op_type == OP_STUB) {
4630 op_getmad(arg,pegop,'S');
4631 imop = arg; /* no import on explicit () */
4633 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4634 imop = NULL; /* use 5.0; */
4636 use_version = ((SVOP*)idop)->op_sv;
4638 idop->op_private |= OPpCONST_NOVER;
4644 op_getmad(arg,pegop,'A');
4646 /* Make copy of idop so we don't free it twice */
4647 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4649 /* Fake up a method call to import/unimport */
4651 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4652 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4653 op_append_elem(OP_LIST,
4654 op_prepend_elem(OP_LIST, pack, list(arg)),
4655 newSVOP(OP_METHOD_NAMED, 0, meth)));
4658 /* Fake up the BEGIN {}, which does its thing immediately. */
4660 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4663 op_append_elem(OP_LINESEQ,
4664 op_append_elem(OP_LINESEQ,
4665 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4666 newSTATEOP(0, NULL, veop)),
4667 newSTATEOP(0, NULL, imop) ));
4670 /* If we request a version >= 5.9.5, load feature.pm with the
4671 * feature bundle that corresponds to the required version. */
4672 use_version = sv_2mortal(new_version(use_version));
4674 if (vcmp(use_version,
4675 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4676 SV *const importsv = vnormal(use_version);
4677 *SvPVX_mutable(importsv) = ':';
4678 ENTER_with_name("load_feature");
4679 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4680 LEAVE_with_name("load_feature");
4682 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4683 if (vcmp(use_version,
4684 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4685 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4689 /* The "did you use incorrect case?" warning used to be here.
4690 * The problem is that on case-insensitive filesystems one
4691 * might get false positives for "use" (and "require"):
4692 * "use Strict" or "require CARP" will work. This causes
4693 * portability problems for the script: in case-strict
4694 * filesystems the script will stop working.
4696 * The "incorrect case" warning checked whether "use Foo"
4697 * imported "Foo" to your namespace, but that is wrong, too:
4698 * there is no requirement nor promise in the language that
4699 * a Foo.pm should or would contain anything in package "Foo".
4701 * There is very little Configure-wise that can be done, either:
4702 * the case-sensitivity of the build filesystem of Perl does not
4703 * help in guessing the case-sensitivity of the runtime environment.
4706 PL_hints |= HINT_BLOCK_SCOPE;
4707 PL_parser->copline = NOLINE;
4708 PL_parser->expect = XSTATE;
4709 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4710 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4714 if (!PL_madskills) {
4715 /* FIXME - don't allocate pegop if !PL_madskills */
4724 =head1 Embedding Functions
4726 =for apidoc load_module
4728 Loads the module whose name is pointed to by the string part of name.
4729 Note that the actual module name, not its filename, should be given.
4730 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4731 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4732 (or 0 for no flags). ver, if specified, provides version semantics
4733 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4734 arguments can be used to specify arguments to the module's import()
4735 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4736 terminated with a final NULL pointer. Note that this list can only
4737 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4738 Otherwise at least a single NULL pointer to designate the default
4739 import list is required.
4744 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4748 PERL_ARGS_ASSERT_LOAD_MODULE;
4750 va_start(args, ver);
4751 vload_module(flags, name, ver, &args);
4755 #ifdef PERL_IMPLICIT_CONTEXT
4757 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4761 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4762 va_start(args, ver);
4763 vload_module(flags, name, ver, &args);
4769 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4773 OP * const modname = newSVOP(OP_CONST, 0, name);
4775 PERL_ARGS_ASSERT_VLOAD_MODULE;
4777 modname->op_private |= OPpCONST_BARE;
4779 veop = newSVOP(OP_CONST, 0, ver);
4783 if (flags & PERL_LOADMOD_NOIMPORT) {
4784 imop = sawparens(newNULLLIST());
4786 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4787 imop = va_arg(*args, OP*);
4792 sv = va_arg(*args, SV*);
4794 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4795 sv = va_arg(*args, SV*);
4799 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4800 * that it has a PL_parser to play with while doing that, and also
4801 * that it doesn't mess with any existing parser, by creating a tmp
4802 * new parser with lex_start(). This won't actually be used for much,
4803 * since pp_require() will create another parser for the real work. */
4806 SAVEVPTR(PL_curcop);
4807 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4808 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4809 veop, modname, imop);
4814 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4820 PERL_ARGS_ASSERT_DOFILE;
4822 if (!force_builtin) {
4823 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4824 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4825 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4826 gv = gvp ? *gvp : NULL;
4830 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4831 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4832 op_append_elem(OP_LIST, term,
4833 scalar(newUNOP(OP_RV2CV, 0,
4834 newGVOP(OP_GV, 0, gv))))));
4837 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4843 =head1 Optree construction
4845 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4847 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4848 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4849 be set automatically, and, shifted up eight bits, the eight bits of
4850 C<op_private>, except that the bit with value 1 or 2 is automatically
4851 set as required. I<listval> and I<subscript> supply the parameters of
4852 the slice; they are consumed by this function and become part of the
4853 constructed op tree.
4859 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4861 return newBINOP(OP_LSLICE, flags,
4862 list(force_list(subscript)),
4863 list(force_list(listval)) );
4867 S_is_list_assignment(pTHX_ register const OP *o)
4875 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4876 o = cUNOPo->op_first;
4878 flags = o->op_flags;
4880 if (type == OP_COND_EXPR) {
4881 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4882 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4887 yyerror("Assignment to both a list and a scalar");
4891 if (type == OP_LIST &&
4892 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4893 o->op_private & OPpLVAL_INTRO)
4896 if (type == OP_LIST || flags & OPf_PARENS ||
4897 type == OP_RV2AV || type == OP_RV2HV ||
4898 type == OP_ASLICE || type == OP_HSLICE)
4901 if (type == OP_PADAV || type == OP_PADHV)
4904 if (type == OP_RV2SV)
4911 Helper function for newASSIGNOP to detection commonality between the
4912 lhs and the rhs. Marks all variables with PL_generation. If it
4913 returns TRUE the assignment must be able to handle common variables.
4915 PERL_STATIC_INLINE bool
4916 S_aassign_common_vars(pTHX_ OP* o)
4919 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
4920 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4921 if (curop->op_type == OP_GV) {
4922 GV *gv = cGVOPx_gv(curop);
4924 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4926 GvASSIGN_GENERATION_set(gv, PL_generation);
4928 else if (curop->op_type == OP_PADSV ||
4929 curop->op_type == OP_PADAV ||
4930 curop->op_type == OP_PADHV ||
4931 curop->op_type == OP_PADANY)
4933 if (PAD_COMPNAME_GEN(curop->op_targ)
4934 == (STRLEN)PL_generation)
4936 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4939 else if (curop->op_type == OP_RV2CV)
4941 else if (curop->op_type == OP_RV2SV ||
4942 curop->op_type == OP_RV2AV ||
4943 curop->op_type == OP_RV2HV ||
4944 curop->op_type == OP_RV2GV) {
4945 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
4948 else if (curop->op_type == OP_PUSHRE) {
4950 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4951 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4953 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4955 GvASSIGN_GENERATION_set(gv, PL_generation);
4959 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4962 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4964 GvASSIGN_GENERATION_set(gv, PL_generation);
4972 if (curop->op_flags & OPf_KIDS) {
4973 if (aassign_common_vars(curop))
4981 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4983 Constructs, checks, and returns an assignment op. I<left> and I<right>
4984 supply the parameters of the assignment; they are consumed by this
4985 function and become part of the constructed op tree.
4987 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4988 a suitable conditional optree is constructed. If I<optype> is the opcode
4989 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4990 performs the binary operation and assigns the result to the left argument.
4991 Either way, if I<optype> is non-zero then I<flags> has no effect.
4993 If I<optype> is zero, then a plain scalar or list assignment is
4994 constructed. Which type of assignment it is is automatically determined.
4995 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4996 will be set automatically, and, shifted up eight bits, the eight bits
4997 of C<op_private>, except that the bit with value 1 or 2 is automatically
5004 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5010 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5011 return newLOGOP(optype, 0,
5012 op_lvalue(scalar(left), optype),
5013 newUNOP(OP_SASSIGN, 0, scalar(right)));
5016 return newBINOP(optype, OPf_STACKED,
5017 op_lvalue(scalar(left), optype), scalar(right));
5021 if (is_list_assignment(left)) {
5022 static const char no_list_state[] = "Initialization of state variables"
5023 " in list context currently forbidden";
5025 bool maybe_common_vars = TRUE;
5028 left = op_lvalue(left, OP_AASSIGN);
5029 curop = list(force_list(left));
5030 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5031 o->op_private = (U8)(0 | (flags >> 8));
5033 if ((left->op_type == OP_LIST
5034 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5036 OP* lop = ((LISTOP*)left)->op_first;
5037 maybe_common_vars = FALSE;
5039 if (lop->op_type == OP_PADSV ||
5040 lop->op_type == OP_PADAV ||
5041 lop->op_type == OP_PADHV ||
5042 lop->op_type == OP_PADANY) {
5043 if (!(lop->op_private & OPpLVAL_INTRO))
5044 maybe_common_vars = TRUE;
5046 if (lop->op_private & OPpPAD_STATE) {
5047 if (left->op_private & OPpLVAL_INTRO) {
5048 /* Each variable in state($a, $b, $c) = ... */
5051 /* Each state variable in
5052 (state $a, my $b, our $c, $d, undef) = ... */
5054 yyerror(no_list_state);
5056 /* Each my variable in
5057 (state $a, my $b, our $c, $d, undef) = ... */
5059 } else if (lop->op_type == OP_UNDEF ||
5060 lop->op_type == OP_PUSHMARK) {
5061 /* undef may be interesting in
5062 (state $a, undef, state $c) */
5064 /* Other ops in the list. */
5065 maybe_common_vars = TRUE;
5067 lop = lop->op_sibling;
5070 else if ((left->op_private & OPpLVAL_INTRO)
5071 && ( left->op_type == OP_PADSV
5072 || left->op_type == OP_PADAV
5073 || left->op_type == OP_PADHV
5074 || left->op_type == OP_PADANY))
5076 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5077 if (left->op_private & OPpPAD_STATE) {
5078 /* All single variable list context state assignments, hence
5088 yyerror(no_list_state);
5092 /* PL_generation sorcery:
5093 * an assignment like ($a,$b) = ($c,$d) is easier than
5094 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5095 * To detect whether there are common vars, the global var
5096 * PL_generation is incremented for each assign op we compile.
5097 * Then, while compiling the assign op, we run through all the
5098 * variables on both sides of the assignment, setting a spare slot
5099 * in each of them to PL_generation. If any of them already have
5100 * that value, we know we've got commonality. We could use a
5101 * single bit marker, but then we'd have to make 2 passes, first
5102 * to clear the flag, then to test and set it. To find somewhere
5103 * to store these values, evil chicanery is done with SvUVX().
5106 if (maybe_common_vars) {
5108 if (aassign_common_vars(o))
5109 o->op_private |= OPpASSIGN_COMMON;
5113 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5114 OP* tmpop = ((LISTOP*)right)->op_first;
5115 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5116 PMOP * const pm = (PMOP*)tmpop;
5117 if (left->op_type == OP_RV2AV &&
5118 !(left->op_private & OPpLVAL_INTRO) &&
5119 !(o->op_private & OPpASSIGN_COMMON) )
5121 tmpop = ((UNOP*)left)->op_first;
5122 if (tmpop->op_type == OP_GV
5124 && !pm->op_pmreplrootu.op_pmtargetoff
5126 && !pm->op_pmreplrootu.op_pmtargetgv
5130 pm->op_pmreplrootu.op_pmtargetoff
5131 = cPADOPx(tmpop)->op_padix;
5132 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5134 pm->op_pmreplrootu.op_pmtargetgv
5135 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5136 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5138 pm->op_pmflags |= PMf_ONCE;
5139 tmpop = cUNOPo->op_first; /* to list (nulled) */
5140 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5141 tmpop->op_sibling = NULL; /* don't free split */
5142 right->op_next = tmpop->op_next; /* fix starting loc */
5143 op_free(o); /* blow off assign */
5144 right->op_flags &= ~OPf_WANT;
5145 /* "I don't know and I don't care." */
5150 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5151 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5153 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5154 if (SvIOK(sv) && SvIVX(sv) == 0)
5155 sv_setiv(sv, PL_modcount+1);
5163 right = newOP(OP_UNDEF, 0);
5164 if (right->op_type == OP_READLINE) {
5165 right->op_flags |= OPf_STACKED;
5166 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5170 o = newBINOP(OP_SASSIGN, flags,
5171 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5177 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5179 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5180 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5181 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5182 If I<label> is non-null, it supplies the name of a label to attach to
5183 the state op; this function takes ownership of the memory pointed at by
5184 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5187 If I<o> is null, the state op is returned. Otherwise the state op is
5188 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5189 is consumed by this function and becomes part of the returned op tree.
5195 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5198 const U32 seq = intro_my();
5201 NewOp(1101, cop, 1, COP);
5202 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5203 cop->op_type = OP_DBSTATE;
5204 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5207 cop->op_type = OP_NEXTSTATE;
5208 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5210 cop->op_flags = (U8)flags;
5211 CopHINTS_set(cop, PL_hints);
5213 cop->op_private |= NATIVE_HINTS;
5215 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5216 cop->op_next = (OP*)cop;
5219 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5220 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5222 Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
5224 PL_hints |= HINT_BLOCK_SCOPE;
5225 /* It seems that we need to defer freeing this pointer, as other parts
5226 of the grammar end up wanting to copy it after this op has been
5231 if (PL_parser && PL_parser->copline == NOLINE)
5232 CopLINE_set(cop, CopLINE(PL_curcop));
5234 CopLINE_set(cop, PL_parser->copline);
5236 PL_parser->copline = NOLINE;
5239 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5241 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5243 CopSTASH_set(cop, PL_curstash);
5245 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5246 /* this line can have a breakpoint - store the cop in IV */
5247 AV *av = CopFILEAVx(PL_curcop);
5249 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5250 if (svp && *svp != &PL_sv_undef ) {
5251 (void)SvIOK_on(*svp);
5252 SvIV_set(*svp, PTR2IV(cop));
5257 if (flags & OPf_SPECIAL)
5259 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5263 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5265 Constructs, checks, and returns a logical (flow control) op. I<type>
5266 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5267 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5268 the eight bits of C<op_private>, except that the bit with value 1 is
5269 automatically set. I<first> supplies the expression controlling the
5270 flow, and I<other> supplies the side (alternate) chain of ops; they are
5271 consumed by this function and become part of the constructed op tree.
5277 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5281 PERL_ARGS_ASSERT_NEWLOGOP;
5283 return new_logop(type, flags, &first, &other);
5287 S_search_const(pTHX_ OP *o)
5289 PERL_ARGS_ASSERT_SEARCH_CONST;
5291 switch (o->op_type) {
5295 if (o->op_flags & OPf_KIDS)
5296 return search_const(cUNOPo->op_first);
5303 if (!(o->op_flags & OPf_KIDS))
5305 kid = cLISTOPo->op_first;
5307 switch (kid->op_type) {
5311 kid = kid->op_sibling;
5314 if (kid != cLISTOPo->op_last)
5320 kid = cLISTOPo->op_last;
5322 return search_const(kid);
5330 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5338 int prepend_not = 0;
5340 PERL_ARGS_ASSERT_NEW_LOGOP;
5345 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5346 return newBINOP(type, flags, scalar(first), scalar(other));
5348 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5350 scalarboolean(first);
5351 /* optimize AND and OR ops that have NOTs as children */
5352 if (first->op_type == OP_NOT
5353 && (first->op_flags & OPf_KIDS)
5354 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5355 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5357 if (type == OP_AND || type == OP_OR) {
5363 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5365 prepend_not = 1; /* prepend a NOT op later */
5369 /* search for a constant op that could let us fold the test */
5370 if ((cstop = search_const(first))) {
5371 if (cstop->op_private & OPpCONST_STRICT)
5372 no_bareword_allowed(cstop);
5373 else if ((cstop->op_private & OPpCONST_BARE))
5374 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5375 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5376 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5377 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5379 if (other->op_type == OP_CONST)
5380 other->op_private |= OPpCONST_SHORTCIRCUIT;
5382 OP *newop = newUNOP(OP_NULL, 0, other);
5383 op_getmad(first, newop, '1');
5384 newop->op_targ = type; /* set "was" field */
5388 if (other->op_type == OP_LEAVE)
5389 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5390 else if (other->op_type == OP_MATCH
5391 || other->op_type == OP_SUBST
5392 || other->op_type == OP_TRANSR
5393 || other->op_type == OP_TRANS)
5394 /* Mark the op as being unbindable with =~ */
5395 other->op_flags |= OPf_SPECIAL;
5399 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5400 const OP *o2 = other;
5401 if ( ! (o2->op_type == OP_LIST
5402 && (( o2 = cUNOPx(o2)->op_first))
5403 && o2->op_type == OP_PUSHMARK
5404 && (( o2 = o2->op_sibling)) )
5407 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5408 || o2->op_type == OP_PADHV)
5409 && o2->op_private & OPpLVAL_INTRO
5410 && !(o2->op_private & OPpPAD_STATE))
5412 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5413 "Deprecated use of my() in false conditional");
5417 if (first->op_type == OP_CONST)
5418 first->op_private |= OPpCONST_SHORTCIRCUIT;
5420 first = newUNOP(OP_NULL, 0, first);
5421 op_getmad(other, first, '2');
5422 first->op_targ = type; /* set "was" field */
5429 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5430 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5432 const OP * const k1 = ((UNOP*)first)->op_first;
5433 const OP * const k2 = k1->op_sibling;
5435 switch (first->op_type)
5438 if (k2 && k2->op_type == OP_READLINE
5439 && (k2->op_flags & OPf_STACKED)
5440 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5442 warnop = k2->op_type;
5447 if (k1->op_type == OP_READDIR
5448 || k1->op_type == OP_GLOB
5449 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5450 || k1->op_type == OP_EACH
5451 || k1->op_type == OP_AEACH)
5453 warnop = ((k1->op_type == OP_NULL)
5454 ? (OPCODE)k1->op_targ : k1->op_type);
5459 const line_t oldline = CopLINE(PL_curcop);
5460 CopLINE_set(PL_curcop, PL_parser->copline);
5461 Perl_warner(aTHX_ packWARN(WARN_MISC),
5462 "Value of %s%s can be \"0\"; test with defined()",
5464 ((warnop == OP_READLINE || warnop == OP_GLOB)
5465 ? " construct" : "() operator"));
5466 CopLINE_set(PL_curcop, oldline);
5473 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5474 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5476 NewOp(1101, logop, 1, LOGOP);
5478 logop->op_type = (OPCODE)type;
5479 logop->op_ppaddr = PL_ppaddr[type];
5480 logop->op_first = first;
5481 logop->op_flags = (U8)(flags | OPf_KIDS);
5482 logop->op_other = LINKLIST(other);
5483 logop->op_private = (U8)(1 | (flags >> 8));
5485 /* establish postfix order */
5486 logop->op_next = LINKLIST(first);
5487 first->op_next = (OP*)logop;
5488 first->op_sibling = other;
5490 CHECKOP(type,logop);
5492 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5499 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5501 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5502 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5503 will be set automatically, and, shifted up eight bits, the eight bits of
5504 C<op_private>, except that the bit with value 1 is automatically set.
5505 I<first> supplies the expression selecting between the two branches,
5506 and I<trueop> and I<falseop> supply the branches; they are consumed by
5507 this function and become part of the constructed op tree.
5513 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5521 PERL_ARGS_ASSERT_NEWCONDOP;
5524 return newLOGOP(OP_AND, 0, first, trueop);
5526 return newLOGOP(OP_OR, 0, first, falseop);
5528 scalarboolean(first);
5529 if ((cstop = search_const(first))) {
5530 /* Left or right arm of the conditional? */
5531 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5532 OP *live = left ? trueop : falseop;
5533 OP *const dead = left ? falseop : trueop;
5534 if (cstop->op_private & OPpCONST_BARE &&
5535 cstop->op_private & OPpCONST_STRICT) {
5536 no_bareword_allowed(cstop);
5539 /* This is all dead code when PERL_MAD is not defined. */
5540 live = newUNOP(OP_NULL, 0, live);
5541 op_getmad(first, live, 'C');
5542 op_getmad(dead, live, left ? 'e' : 't');
5547 if (live->op_type == OP_LEAVE)
5548 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5549 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5550 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5551 /* Mark the op as being unbindable with =~ */
5552 live->op_flags |= OPf_SPECIAL;
5555 NewOp(1101, logop, 1, LOGOP);
5556 logop->op_type = OP_COND_EXPR;
5557 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5558 logop->op_first = first;
5559 logop->op_flags = (U8)(flags | OPf_KIDS);
5560 logop->op_private = (U8)(1 | (flags >> 8));
5561 logop->op_other = LINKLIST(trueop);
5562 logop->op_next = LINKLIST(falseop);
5564 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5567 /* establish postfix order */
5568 start = LINKLIST(first);
5569 first->op_next = (OP*)logop;
5571 first->op_sibling = trueop;
5572 trueop->op_sibling = falseop;
5573 o = newUNOP(OP_NULL, 0, (OP*)logop);
5575 trueop->op_next = falseop->op_next = o;
5582 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5584 Constructs and returns a C<range> op, with subordinate C<flip> and
5585 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5586 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5587 for both the C<flip> and C<range> ops, except that the bit with value
5588 1 is automatically set. I<left> and I<right> supply the expressions
5589 controlling the endpoints of the range; they are consumed by this function
5590 and become part of the constructed op tree.
5596 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5605 PERL_ARGS_ASSERT_NEWRANGE;
5607 NewOp(1101, range, 1, LOGOP);
5609 range->op_type = OP_RANGE;
5610 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5611 range->op_first = left;
5612 range->op_flags = OPf_KIDS;
5613 leftstart = LINKLIST(left);
5614 range->op_other = LINKLIST(right);
5615 range->op_private = (U8)(1 | (flags >> 8));
5617 left->op_sibling = right;
5619 range->op_next = (OP*)range;
5620 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5621 flop = newUNOP(OP_FLOP, 0, flip);
5622 o = newUNOP(OP_NULL, 0, flop);
5624 range->op_next = leftstart;
5626 left->op_next = flip;
5627 right->op_next = flop;
5629 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5630 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5631 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5632 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5634 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5635 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5637 /* check barewords before they might be optimized aways */
5638 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5639 no_bareword_allowed(left);
5640 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5641 no_bareword_allowed(right);
5644 if (!flip->op_private || !flop->op_private)
5645 LINKLIST(o); /* blow off optimizer unless constant */
5651 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5653 Constructs, checks, and returns an op tree expressing a loop. This is
5654 only a loop in the control flow through the op tree; it does not have
5655 the heavyweight loop structure that allows exiting the loop by C<last>
5656 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5657 top-level op, except that some bits will be set automatically as required.
5658 I<expr> supplies the expression controlling loop iteration, and I<block>
5659 supplies the body of the loop; they are consumed by this function and
5660 become part of the constructed op tree. I<debuggable> is currently
5661 unused and should always be 1.
5667 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5672 const bool once = block && block->op_flags & OPf_SPECIAL &&
5673 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5675 PERL_UNUSED_ARG(debuggable);
5678 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5679 return block; /* do {} while 0 does once */
5680 if (expr->op_type == OP_READLINE
5681 || expr->op_type == OP_READDIR
5682 || expr->op_type == OP_GLOB
5683 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5684 expr = newUNOP(OP_DEFINED, 0,
5685 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5686 } else if (expr->op_flags & OPf_KIDS) {
5687 const OP * const k1 = ((UNOP*)expr)->op_first;
5688 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5689 switch (expr->op_type) {
5691 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5692 && (k2->op_flags & OPf_STACKED)
5693 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5694 expr = newUNOP(OP_DEFINED, 0, expr);
5698 if (k1 && (k1->op_type == OP_READDIR
5699 || k1->op_type == OP_GLOB
5700 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5701 || k1->op_type == OP_EACH
5702 || k1->op_type == OP_AEACH))
5703 expr = newUNOP(OP_DEFINED, 0, expr);
5709 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5710 * op, in listop. This is wrong. [perl #27024] */
5712 block = newOP(OP_NULL, 0);
5713 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5714 o = new_logop(OP_AND, 0, &expr, &listop);
5717 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5719 if (once && o != listop)
5720 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5723 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5725 o->op_flags |= flags;
5727 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5732 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5734 Constructs, checks, and returns an op tree expressing a C<while> loop.
5735 This is a heavyweight loop, with structure that allows exiting the loop
5736 by C<last> and suchlike.
5738 I<loop> is an optional preconstructed C<enterloop> op to use in the
5739 loop; if it is null then a suitable op will be constructed automatically.
5740 I<expr> supplies the loop's controlling expression. I<block> supplies the
5741 main body of the loop, and I<cont> optionally supplies a C<continue> block
5742 that operates as a second half of the body. All of these optree inputs
5743 are consumed by this function and become part of the constructed op tree.
5745 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5746 op and, shifted up eight bits, the eight bits of C<op_private> for
5747 the C<leaveloop> op, except that (in both cases) some bits will be set
5748 automatically. I<debuggable> is currently unused and should always be 1.
5749 I<has_my> can be supplied as true to force the
5750 loop body to be enclosed in its own scope.
5756 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5757 OP *expr, OP *block, OP *cont, I32 has_my)
5766 PERL_UNUSED_ARG(debuggable);
5769 if (expr->op_type == OP_READLINE
5770 || expr->op_type == OP_READDIR
5771 || expr->op_type == OP_GLOB
5772 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5773 expr = newUNOP(OP_DEFINED, 0,
5774 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5775 } else if (expr->op_flags & OPf_KIDS) {
5776 const OP * const k1 = ((UNOP*)expr)->op_first;
5777 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5778 switch (expr->op_type) {
5780 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5781 && (k2->op_flags & OPf_STACKED)
5782 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5783 expr = newUNOP(OP_DEFINED, 0, expr);
5787 if (k1 && (k1->op_type == OP_READDIR
5788 || k1->op_type == OP_GLOB
5789 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5790 || k1->op_type == OP_EACH
5791 || k1->op_type == OP_AEACH))
5792 expr = newUNOP(OP_DEFINED, 0, expr);
5799 block = newOP(OP_NULL, 0);
5800 else if (cont || has_my) {
5801 block = op_scope(block);
5805 next = LINKLIST(cont);
5808 OP * const unstack = newOP(OP_UNSTACK, 0);
5811 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5815 listop = op_append_list(OP_LINESEQ, block, cont);
5817 redo = LINKLIST(listop);
5821 o = new_logop(OP_AND, 0, &expr, &listop);
5822 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5823 op_free(expr); /* oops, it's a while (0) */
5825 return NULL; /* listop already freed by new_logop */
5828 ((LISTOP*)listop)->op_last->op_next =
5829 (o == listop ? redo : LINKLIST(o));
5835 NewOp(1101,loop,1,LOOP);
5836 loop->op_type = OP_ENTERLOOP;
5837 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5838 loop->op_private = 0;
5839 loop->op_next = (OP*)loop;
5842 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5844 loop->op_redoop = redo;
5845 loop->op_lastop = o;
5846 o->op_private |= loopflags;
5849 loop->op_nextop = next;
5851 loop->op_nextop = o;
5853 o->op_flags |= flags;
5854 o->op_private |= (flags >> 8);
5859 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5861 Constructs, checks, and returns an op tree expressing a C<foreach>
5862 loop (iteration through a list of values). This is a heavyweight loop,
5863 with structure that allows exiting the loop by C<last> and suchlike.
5865 I<sv> optionally supplies the variable that will be aliased to each
5866 item in turn; if null, it defaults to C<$_> (either lexical or global).
5867 I<expr> supplies the list of values to iterate over. I<block> supplies
5868 the main body of the loop, and I<cont> optionally supplies a C<continue>
5869 block that operates as a second half of the body. All of these optree
5870 inputs are consumed by this function and become part of the constructed
5873 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5874 op and, shifted up eight bits, the eight bits of C<op_private> for
5875 the C<leaveloop> op, except that (in both cases) some bits will be set
5882 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5887 PADOFFSET padoff = 0;
5892 PERL_ARGS_ASSERT_NEWFOROP;
5895 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5896 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5897 sv->op_type = OP_RV2GV;
5898 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5900 /* The op_type check is needed to prevent a possible segfault
5901 * if the loop variable is undeclared and 'strict vars' is in
5902 * effect. This is illegal but is nonetheless parsed, so we
5903 * may reach this point with an OP_CONST where we're expecting
5906 if (cUNOPx(sv)->op_first->op_type == OP_GV
5907 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5908 iterpflags |= OPpITER_DEF;
5910 else if (sv->op_type == OP_PADSV) { /* private variable */
5911 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5912 padoff = sv->op_targ;
5922 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5924 SV *const namesv = PAD_COMPNAME_SV(padoff);
5926 const char *const name = SvPV_const(namesv, len);
5928 if (len == 2 && name[0] == '$' && name[1] == '_')
5929 iterpflags |= OPpITER_DEF;
5933 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5934 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5935 sv = newGVOP(OP_GV, 0, PL_defgv);
5940 iterpflags |= OPpITER_DEF;
5942 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5943 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5944 iterflags |= OPf_STACKED;
5946 else if (expr->op_type == OP_NULL &&
5947 (expr->op_flags & OPf_KIDS) &&
5948 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5950 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5951 * set the STACKED flag to indicate that these values are to be
5952 * treated as min/max values by 'pp_iterinit'.
5954 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5955 LOGOP* const range = (LOGOP*) flip->op_first;
5956 OP* const left = range->op_first;
5957 OP* const right = left->op_sibling;
5960 range->op_flags &= ~OPf_KIDS;
5961 range->op_first = NULL;
5963 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5964 listop->op_first->op_next = range->op_next;
5965 left->op_next = range->op_other;
5966 right->op_next = (OP*)listop;
5967 listop->op_next = listop->op_first;
5970 op_getmad(expr,(OP*)listop,'O');
5974 expr = (OP*)(listop);
5976 iterflags |= OPf_STACKED;
5979 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5982 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5983 op_append_elem(OP_LIST, expr, scalar(sv))));
5984 assert(!loop->op_next);
5985 /* for my $x () sets OPpLVAL_INTRO;
5986 * for our $x () sets OPpOUR_INTRO */
5987 loop->op_private = (U8)iterpflags;
5988 #ifdef PL_OP_SLAB_ALLOC
5991 NewOp(1234,tmp,1,LOOP);
5992 Copy(loop,tmp,1,LISTOP);
5993 S_op_destroy(aTHX_ (OP*)loop);
5997 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5999 loop->op_targ = padoff;
6000 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6002 op_getmad(madsv, (OP*)loop, 'v');
6007 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6009 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6010 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6011 determining the target of the op; it is consumed by this function and
6012 become part of the constructed op tree.
6018 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6023 PERL_ARGS_ASSERT_NEWLOOPEX;
6025 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6027 if (type != OP_GOTO || label->op_type == OP_CONST) {
6028 /* "last()" means "last" */
6029 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6030 o = newOP(type, OPf_SPECIAL);
6032 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
6033 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6037 op_getmad(label,o,'L');
6043 /* Check whether it's going to be a goto &function */
6044 if (label->op_type == OP_ENTERSUB
6045 && !(label->op_flags & OPf_STACKED))
6046 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6047 o = newUNOP(type, OPf_STACKED, label);
6049 PL_hints |= HINT_BLOCK_SCOPE;
6053 /* if the condition is a literal array or hash
6054 (or @{ ... } etc), make a reference to it.
6057 S_ref_array_or_hash(pTHX_ OP *cond)
6060 && (cond->op_type == OP_RV2AV
6061 || cond->op_type == OP_PADAV
6062 || cond->op_type == OP_RV2HV
6063 || cond->op_type == OP_PADHV))
6065 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6068 && (cond->op_type == OP_ASLICE
6069 || cond->op_type == OP_HSLICE)) {
6071 /* anonlist now needs a list from this op, was previously used in
6073 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6074 cond->op_flags |= OPf_WANT_LIST;
6076 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6083 /* These construct the optree fragments representing given()
6086 entergiven and enterwhen are LOGOPs; the op_other pointer
6087 points up to the associated leave op. We need this so we
6088 can put it in the context and make break/continue work.
6089 (Also, of course, pp_enterwhen will jump straight to
6090 op_other if the match fails.)
6094 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6095 I32 enter_opcode, I32 leave_opcode,
6096 PADOFFSET entertarg)
6102 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6104 NewOp(1101, enterop, 1, LOGOP);
6105 enterop->op_type = (Optype)enter_opcode;
6106 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6107 enterop->op_flags = (U8) OPf_KIDS;
6108 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6109 enterop->op_private = 0;
6111 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6114 enterop->op_first = scalar(cond);
6115 cond->op_sibling = block;
6117 o->op_next = LINKLIST(cond);
6118 cond->op_next = (OP *) enterop;
6121 /* This is a default {} block */
6122 enterop->op_first = block;
6123 enterop->op_flags |= OPf_SPECIAL;
6125 o->op_next = (OP *) enterop;
6128 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6129 entergiven and enterwhen both
6132 enterop->op_next = LINKLIST(block);
6133 block->op_next = enterop->op_other = o;
6138 /* Does this look like a boolean operation? For these purposes
6139 a boolean operation is:
6140 - a subroutine call [*]
6141 - a logical connective
6142 - a comparison operator
6143 - a filetest operator, with the exception of -s -M -A -C
6144 - defined(), exists() or eof()
6145 - /$re/ or $foo =~ /$re/
6147 [*] possibly surprising
6150 S_looks_like_bool(pTHX_ const OP *o)
6154 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6156 switch(o->op_type) {
6159 return looks_like_bool(cLOGOPo->op_first);
6163 looks_like_bool(cLOGOPo->op_first)
6164 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6169 o->op_flags & OPf_KIDS
6170 && looks_like_bool(cUNOPo->op_first));
6174 case OP_NOT: case OP_XOR:
6176 case OP_EQ: case OP_NE: case OP_LT:
6177 case OP_GT: case OP_LE: case OP_GE:
6179 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6180 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6182 case OP_SEQ: case OP_SNE: case OP_SLT:
6183 case OP_SGT: case OP_SLE: case OP_SGE:
6187 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6188 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6189 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6190 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6191 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6192 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6193 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6194 case OP_FTTEXT: case OP_FTBINARY:
6196 case OP_DEFINED: case OP_EXISTS:
6197 case OP_MATCH: case OP_EOF:
6204 /* Detect comparisons that have been optimized away */
6205 if (cSVOPo->op_sv == &PL_sv_yes
6206 || cSVOPo->op_sv == &PL_sv_no)
6219 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6221 Constructs, checks, and returns an op tree expressing a C<given> block.
6222 I<cond> supplies the expression that will be locally assigned to a lexical
6223 variable, and I<block> supplies the body of the C<given> construct; they
6224 are consumed by this function and become part of the constructed op tree.
6225 I<defsv_off> is the pad offset of the scalar lexical variable that will
6232 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6235 PERL_ARGS_ASSERT_NEWGIVENOP;
6236 return newGIVWHENOP(
6237 ref_array_or_hash(cond),
6239 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6244 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6246 Constructs, checks, and returns an op tree expressing a C<when> block.
6247 I<cond> supplies the test expression, and I<block> supplies the block
6248 that will be executed if the test evaluates to true; they are consumed
6249 by this function and become part of the constructed op tree. I<cond>
6250 will be interpreted DWIMically, often as a comparison against C<$_>,
6251 and may be null to generate a C<default> block.
6257 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6259 const bool cond_llb = (!cond || looks_like_bool(cond));
6262 PERL_ARGS_ASSERT_NEWWHENOP;
6267 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6269 scalar(ref_array_or_hash(cond)));
6272 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6276 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6277 const STRLEN len, const U32 flags)
6279 const char * const cvp = CvPROTO(cv);
6280 const STRLEN clen = CvPROTOLEN(cv);
6282 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6284 if (((!p != !cvp) /* One has prototype, one has not. */
6286 (flags & SVf_UTF8) == SvUTF8(cv)
6287 ? len != clen || memNE(cvp, p, len)
6289 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6291 : bytes_cmp_utf8((const U8 *)p, len,
6292 (const U8 *)cvp, clen)
6296 && ckWARN_d(WARN_PROTOTYPE)) {
6297 SV* const msg = sv_newmortal();
6301 gv_efullname3(name = sv_newmortal(), gv, NULL);
6302 sv_setpvs(msg, "Prototype mismatch:");
6304 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6306 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6307 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6310 sv_catpvs(msg, ": none");
6311 sv_catpvs(msg, " vs ");
6313 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6315 sv_catpvs(msg, "none");
6316 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6320 static void const_sv_xsub(pTHX_ CV* cv);
6324 =head1 Optree Manipulation Functions
6326 =for apidoc cv_const_sv
6328 If C<cv> is a constant sub eligible for inlining. returns the constant
6329 value returned by the sub. Otherwise, returns NULL.
6331 Constant subs can be created with C<newCONSTSUB> or as described in
6332 L<perlsub/"Constant Functions">.
6337 Perl_cv_const_sv(pTHX_ const CV *const cv)
6339 PERL_UNUSED_CONTEXT;
6342 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6344 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6347 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6348 * Can be called in 3 ways:
6351 * look for a single OP_CONST with attached value: return the value
6353 * cv && CvCLONE(cv) && !CvCONST(cv)
6355 * examine the clone prototype, and if contains only a single
6356 * OP_CONST referencing a pad const, or a single PADSV referencing
6357 * an outer lexical, return a non-zero value to indicate the CV is
6358 * a candidate for "constizing" at clone time
6362 * We have just cloned an anon prototype that was marked as a const
6363 * candidate. Try to grab the current value, and in the case of
6364 * PADSV, ignore it if it has multiple references. Return the value.
6368 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6379 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6380 o = cLISTOPo->op_first->op_sibling;
6382 for (; o; o = o->op_next) {
6383 const OPCODE type = o->op_type;
6385 if (sv && o->op_next == o)
6387 if (o->op_next != o) {
6388 if (type == OP_NEXTSTATE
6389 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6390 || type == OP_PUSHMARK)
6392 if (type == OP_DBSTATE)
6395 if (type == OP_LEAVESUB || type == OP_RETURN)
6399 if (type == OP_CONST && cSVOPo->op_sv)
6401 else if (cv && type == OP_CONST) {
6402 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6406 else if (cv && type == OP_PADSV) {
6407 if (CvCONST(cv)) { /* newly cloned anon */
6408 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6409 /* the candidate should have 1 ref from this pad and 1 ref
6410 * from the parent */
6411 if (!sv || SvREFCNT(sv) != 2)
6418 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6419 sv = &PL_sv_undef; /* an arbitrary non-null value */
6434 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6437 /* This would be the return value, but the return cannot be reached. */
6438 OP* pegop = newOP(OP_NULL, 0);
6441 PERL_UNUSED_ARG(floor);
6451 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6453 NORETURN_FUNCTION_END;
6458 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6463 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6465 register CV *cv = NULL;
6467 /* If the subroutine has no body, no attributes, and no builtin attributes
6468 then it's just a sub declaration, and we may be able to get away with
6469 storing with a placeholder scalar in the symbol table, rather than a
6470 full GV and CV. If anything is present then it will take a full CV to
6472 const I32 gv_fetch_flags
6473 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6475 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6477 const char * const name = o ? SvPV_const(cSVOPo->op_sv, namlen) : NULL;
6479 bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
6482 assert(proto->op_type == OP_CONST);
6483 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6484 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6490 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6492 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6493 SV * const sv = sv_newmortal();
6494 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6495 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6496 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6497 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6499 } else if (PL_curstash) {
6500 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6503 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6507 if (!PL_madskills) {
6516 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6517 maximum a prototype before. */
6518 if (SvTYPE(gv) > SVt_NULL) {
6519 if (!SvPOK((const SV *)gv)
6520 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6522 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6524 cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
6527 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6528 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
6531 sv_setiv(MUTABLE_SV(gv), -1);
6533 SvREFCNT_dec(PL_compcv);
6534 cv = PL_compcv = NULL;
6538 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6540 if (!block || !ps || *ps || attrs
6541 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6543 || block->op_type == OP_NULL
6548 const_sv = op_const_sv(block, NULL);
6551 const bool exists = CvROOT(cv) || CvXSUB(cv);
6553 /* if the subroutine doesn't exist and wasn't pre-declared
6554 * with a prototype, assume it will be AUTOLOADed,
6555 * skipping the prototype check
6557 if (exists || SvPOK(cv))
6558 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
6559 /* already defined (or promised)? */
6560 if (exists || GvASSUMECV(gv)) {
6563 || block->op_type == OP_NULL
6566 if (CvFLAGS(PL_compcv)) {
6567 /* might have had built-in attrs applied */
6568 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6569 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6570 && ckWARN(WARN_MISC))
6571 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6573 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6574 & ~(CVf_LVALUE * pureperl));
6576 if (attrs) goto attrs;
6577 /* just a "sub foo;" when &foo is already defined */
6578 SAVEFREESV(PL_compcv);
6583 && block->op_type != OP_NULL
6586 const line_t oldline = CopLINE(PL_curcop);
6587 if (PL_parser && PL_parser->copline != NOLINE)
6588 CopLINE_set(PL_curcop, PL_parser->copline);
6589 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
6590 CopLINE_set(PL_curcop, oldline);
6592 if (!PL_minus_c) /* keep old one around for madskills */
6595 /* (PL_madskills unset in used file.) */
6604 SvREFCNT_inc_simple_void_NN(const_sv);
6606 assert(!CvROOT(cv) && !CvCONST(cv));
6607 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6608 CvXSUBANY(cv).any_ptr = const_sv;
6609 CvXSUB(cv) = const_sv_xsub;
6615 cv = newCONSTSUB_flags(
6616 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
6621 (CvGV(cv) && GvSTASH(CvGV(cv)))
6626 if (HvENAME_HEK(stash))
6627 mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
6631 SvREFCNT_dec(PL_compcv);
6635 if (cv) { /* must reuse cv if autoloaded */
6636 /* transfer PL_compcv to cv */
6639 && block->op_type != OP_NULL
6642 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6643 AV *const temp_av = CvPADLIST(cv);
6644 CV *const temp_cv = CvOUTSIDE(cv);
6646 assert(!CvWEAKOUTSIDE(cv));
6647 assert(!CvCVGV_RC(cv));
6648 assert(CvGV(cv) == gv);
6651 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6652 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6653 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6654 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6655 CvOUTSIDE(PL_compcv) = temp_cv;
6656 CvPADLIST(PL_compcv) = temp_av;
6658 if (CvFILE(cv) && CvDYNFILE(cv)) {
6659 Safefree(CvFILE(cv));
6661 CvFILE_set_from_cop(cv, PL_curcop);
6662 CvSTASH_set(cv, PL_curstash);
6664 /* inner references to PL_compcv must be fixed up ... */
6665 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6666 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6667 ++PL_sub_generation;
6670 /* Might have had built-in attributes applied -- propagate them. */
6671 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6673 /* ... before we throw it away */
6674 SvREFCNT_dec(PL_compcv);
6682 if (strEQ(name, "import")) {
6683 PL_formfeed = MUTABLE_SV(cv);
6684 /* diag_listed_as: SKIPME */
6685 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6689 if (HvENAME_HEK(GvSTASH(gv)))
6690 /* sub Foo::bar { (shift)+1 } */
6691 mro_method_changed_in(GvSTASH(gv));
6696 CvFILE_set_from_cop(cv, PL_curcop);
6697 CvSTASH_set(cv, PL_curstash);
6701 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6702 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
6705 if (PL_parser && PL_parser->error_count) {
6709 const char *s = strrchr(name, ':');
6711 if (strEQ(s, "BEGIN")) {
6712 const char not_safe[] =
6713 "BEGIN not safe after errors--compilation aborted";
6714 if (PL_in_eval & EVAL_KEEPERR)
6715 Perl_croak(aTHX_ not_safe);
6717 /* force display of errors found but not reported */
6718 sv_catpv(ERRSV, not_safe);
6719 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6728 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6729 the debugger could be able to set a breakpoint in, so signal to
6730 pp_entereval that it should not throw away any saved lines at scope
6733 PL_breakable_sub_gen++;
6734 /* This makes sub {}; work as expected. */
6735 if (block->op_type == OP_STUB) {
6736 OP* const newblock = newSTATEOP(0, NULL, 0);
6738 op_getmad(block,newblock,'B');
6744 else block->op_attached = 1;
6745 CvROOT(cv) = CvLVALUE(cv)
6746 ? newUNOP(OP_LEAVESUBLV, 0,
6747 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6748 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6749 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6750 OpREFCNT_set(CvROOT(cv), 1);
6751 CvSTART(cv) = LINKLIST(CvROOT(cv));
6752 CvROOT(cv)->op_next = 0;
6753 CALL_PEEP(CvSTART(cv));
6754 finalize_optree(CvROOT(cv));
6756 /* now that optimizer has done its work, adjust pad values */
6758 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6761 assert(!CvCONST(cv));
6762 if (ps && !*ps && op_const_sv(block, cv))
6768 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6769 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6770 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6773 if (block && has_name) {
6774 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6775 SV * const tmpstr = sv_newmortal();
6776 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6777 GV_ADDMULTI, SVt_PVHV);
6779 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6782 (long)CopLINE(PL_curcop));
6783 gv_efullname3(tmpstr, gv, NULL);
6784 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6785 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
6786 hv = GvHVn(db_postponed);
6787 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
6788 CV * const pcv = GvCV(db_postponed);
6794 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6799 if (name && ! (PL_parser && PL_parser->error_count))
6800 process_special_blocks(name, gv, cv);
6805 PL_parser->copline = NOLINE;
6811 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6814 const char *const colon = strrchr(fullname,':');
6815 const char *const name = colon ? colon + 1 : fullname;
6817 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6820 if (strEQ(name, "BEGIN")) {
6821 const I32 oldscope = PL_scopestack_ix;
6823 SAVECOPFILE(&PL_compiling);
6824 SAVECOPLINE(&PL_compiling);
6825 SAVEVPTR(PL_curcop);
6827 DEBUG_x( dump_sub(gv) );
6828 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6829 GvCV_set(gv,0); /* cv has been hijacked */
6830 call_list(oldscope, PL_beginav);
6832 CopHINTS_set(&PL_compiling, PL_hints);
6839 if strEQ(name, "END") {
6840 DEBUG_x( dump_sub(gv) );
6841 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6844 } else if (*name == 'U') {
6845 if (strEQ(name, "UNITCHECK")) {
6846 /* It's never too late to run a unitcheck block */
6847 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6851 } else if (*name == 'C') {
6852 if (strEQ(name, "CHECK")) {
6854 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6855 "Too late to run CHECK block");
6856 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6860 } else if (*name == 'I') {
6861 if (strEQ(name, "INIT")) {
6863 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6864 "Too late to run INIT block");
6865 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6871 DEBUG_x( dump_sub(gv) );
6872 GvCV_set(gv,0); /* cv has been hijacked */
6877 =for apidoc newCONSTSUB
6879 See L</newCONSTSUB_flags>.
6885 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6887 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
6891 =for apidoc newCONSTSUB_flags
6893 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6894 eligible for inlining at compile-time.
6896 Currently, the only useful value for C<flags> is SVf_UTF8.
6898 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6899 which won't be called if used as a destructor, but will suppress the overhead
6900 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6907 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
6913 const char *const file = CopFILE(PL_curcop);
6915 SV *const temp_sv = CopFILESV(PL_curcop);
6916 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6921 if (IN_PERL_RUNTIME) {
6922 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6923 * an op shared between threads. Use a non-shared COP for our
6925 SAVEVPTR(PL_curcop);
6926 SAVECOMPILEWARNINGS();
6927 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6928 PL_curcop = &PL_compiling;
6930 SAVECOPLINE(PL_curcop);
6931 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6934 PL_hints &= ~HINT_BLOCK_SCOPE;
6937 SAVEGENERICSV(PL_curstash);
6938 SAVECOPSTASH(PL_curcop);
6939 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
6940 CopSTASH_set(PL_curcop,stash);
6943 /* file becomes the CvFILE. For an XS, it's usually static storage,
6944 and so doesn't get free()d. (It's expected to be from the C pre-
6945 processor __FILE__ directive). But we need a dynamically allocated one,
6946 and we need it to get freed. */
6947 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
6948 &sv, XS_DYNAMIC_FILENAME | flags);
6949 CvXSUBANY(cv).any_ptr = sv;
6954 CopSTASH_free(PL_curcop);
6962 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6963 const char *const filename, const char *const proto,
6966 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6967 return newXS_len_flags(
6968 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
6973 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
6974 XSUBADDR_t subaddr, const char *const filename,
6975 const char *const proto, SV **const_svp,
6980 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
6983 GV * const gv = name
6985 name,len,GV_ADDMULTI|flags,SVt_PVCV
6988 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6989 GV_ADDMULTI | flags, SVt_PVCV);
6992 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6994 if ((cv = (name ? GvCV(gv) : NULL))) {
6996 /* just a cached method */
7000 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7001 /* already defined (or promised) */
7002 /* Reduntant check that allows us to avoid creating an SV
7003 most of the time: */
7004 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7005 const line_t oldline = CopLINE(PL_curcop);
7006 if (PL_parser && PL_parser->copline != NOLINE)
7007 CopLINE_set(PL_curcop, PL_parser->copline);
7008 report_redefined_cv(newSVpvn_flags(
7009 name,len,(flags&SVf_UTF8)|SVs_TEMP
7012 CopLINE_set(PL_curcop, oldline);
7019 if (cv) /* must reuse cv if autoloaded */
7022 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7026 if (HvENAME_HEK(GvSTASH(gv)))
7027 mro_method_changed_in(GvSTASH(gv)); /* newXS */
7033 (void)gv_fetchfile(filename);
7034 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7035 an external constant string */
7036 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7038 CvXSUB(cv) = subaddr;
7041 process_special_blocks(name, gv, cv);
7044 if (flags & XS_DYNAMIC_FILENAME) {
7045 CvFILE(cv) = savepv(filename);
7048 sv_setpv(MUTABLE_SV(cv), proto);
7053 =for apidoc U||newXS
7055 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7056 static storage, as it is used directly as CvFILE(), without a copy being made.
7062 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7064 PERL_ARGS_ASSERT_NEWXS;
7065 return newXS_flags(name, subaddr, filename, NULL, 0);
7073 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7078 OP* pegop = newOP(OP_NULL, 0);
7082 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7083 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7086 if ((cv = GvFORM(gv))) {
7087 if (ckWARN(WARN_REDEFINE)) {
7088 const line_t oldline = CopLINE(PL_curcop);
7089 if (PL_parser && PL_parser->copline != NOLINE)
7090 CopLINE_set(PL_curcop, PL_parser->copline);
7092 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7093 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7095 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7096 "Format STDOUT redefined");
7098 CopLINE_set(PL_curcop, oldline);
7105 CvFILE_set_from_cop(cv, PL_curcop);
7108 pad_tidy(padtidy_FORMAT);
7109 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7110 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7111 OpREFCNT_set(CvROOT(cv), 1);
7112 CvSTART(cv) = LINKLIST(CvROOT(cv));
7113 CvROOT(cv)->op_next = 0;
7114 CALL_PEEP(CvSTART(cv));
7115 finalize_optree(CvROOT(cv));
7117 op_getmad(o,pegop,'n');
7118 op_getmad_weak(block, pegop, 'b');
7123 PL_parser->copline = NOLINE;
7131 Perl_newANONLIST(pTHX_ OP *o)
7133 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7137 Perl_newANONHASH(pTHX_ OP *o)
7139 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7143 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7145 return newANONATTRSUB(floor, proto, NULL, block);
7149 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7151 return newUNOP(OP_REFGEN, 0,
7152 newSVOP(OP_ANONCODE, 0,
7153 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7157 Perl_oopsAV(pTHX_ OP *o)
7161 PERL_ARGS_ASSERT_OOPSAV;
7163 switch (o->op_type) {
7165 o->op_type = OP_PADAV;
7166 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7167 return ref(o, OP_RV2AV);
7170 o->op_type = OP_RV2AV;
7171 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7176 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7183 Perl_oopsHV(pTHX_ OP *o)
7187 PERL_ARGS_ASSERT_OOPSHV;
7189 switch (o->op_type) {
7192 o->op_type = OP_PADHV;
7193 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7194 return ref(o, OP_RV2HV);
7198 o->op_type = OP_RV2HV;
7199 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7204 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7211 Perl_newAVREF(pTHX_ OP *o)
7215 PERL_ARGS_ASSERT_NEWAVREF;
7217 if (o->op_type == OP_PADANY) {
7218 o->op_type = OP_PADAV;
7219 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7222 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7223 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7224 "Using an array as a reference is deprecated");
7226 return newUNOP(OP_RV2AV, 0, scalar(o));
7230 Perl_newGVREF(pTHX_ I32 type, OP *o)
7232 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7233 return newUNOP(OP_NULL, 0, o);
7234 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7238 Perl_newHVREF(pTHX_ OP *o)
7242 PERL_ARGS_ASSERT_NEWHVREF;
7244 if (o->op_type == OP_PADANY) {
7245 o->op_type = OP_PADHV;
7246 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7249 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7250 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7251 "Using a hash as a reference is deprecated");
7253 return newUNOP(OP_RV2HV, 0, scalar(o));
7257 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7259 return newUNOP(OP_RV2CV, flags, scalar(o));
7263 Perl_newSVREF(pTHX_ OP *o)
7267 PERL_ARGS_ASSERT_NEWSVREF;
7269 if (o->op_type == OP_PADANY) {
7270 o->op_type = OP_PADSV;
7271 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7274 return newUNOP(OP_RV2SV, 0, scalar(o));
7277 /* Check routines. See the comments at the top of this file for details
7278 * on when these are called */
7281 Perl_ck_anoncode(pTHX_ OP *o)
7283 PERL_ARGS_ASSERT_CK_ANONCODE;
7285 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7287 cSVOPo->op_sv = NULL;
7292 Perl_ck_bitop(pTHX_ OP *o)
7296 PERL_ARGS_ASSERT_CK_BITOP;
7298 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7299 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7300 && (o->op_type == OP_BIT_OR
7301 || o->op_type == OP_BIT_AND
7302 || o->op_type == OP_BIT_XOR))
7304 const OP * const left = cBINOPo->op_first;
7305 const OP * const right = left->op_sibling;
7306 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7307 (left->op_flags & OPf_PARENS) == 0) ||
7308 (OP_IS_NUMCOMPARE(right->op_type) &&
7309 (right->op_flags & OPf_PARENS) == 0))
7310 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7311 "Possible precedence problem on bitwise %c operator",
7312 o->op_type == OP_BIT_OR ? '|'
7313 : o->op_type == OP_BIT_AND ? '&' : '^'
7319 PERL_STATIC_INLINE bool
7320 is_dollar_bracket(pTHX_ const OP * const o)
7323 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
7324 && (kid = cUNOPx(o)->op_first)
7325 && kid->op_type == OP_GV
7326 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
7330 Perl_ck_cmp(pTHX_ OP *o)
7332 PERL_ARGS_ASSERT_CK_CMP;
7333 if (ckWARN(WARN_SYNTAX)) {
7334 const OP *kid = cUNOPo->op_first;
7336 is_dollar_bracket(aTHX_ kid)
7337 || ((kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
7339 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7340 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
7346 Perl_ck_concat(pTHX_ OP *o)
7348 const OP * const kid = cUNOPo->op_first;
7350 PERL_ARGS_ASSERT_CK_CONCAT;
7351 PERL_UNUSED_CONTEXT;
7353 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7354 !(kUNOP->op_first->op_flags & OPf_MOD))
7355 o->op_flags |= OPf_STACKED;
7360 Perl_ck_spair(pTHX_ OP *o)
7364 PERL_ARGS_ASSERT_CK_SPAIR;
7366 if (o->op_flags & OPf_KIDS) {
7369 const OPCODE type = o->op_type;
7370 o = modkids(ck_fun(o), type);
7371 kid = cUNOPo->op_first;
7372 newop = kUNOP->op_first->op_sibling;
7374 const OPCODE type = newop->op_type;
7375 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7376 type == OP_PADAV || type == OP_PADHV ||
7377 type == OP_RV2AV || type == OP_RV2HV)
7381 op_getmad(kUNOP->op_first,newop,'K');
7383 op_free(kUNOP->op_first);
7385 kUNOP->op_first = newop;
7387 o->op_ppaddr = PL_ppaddr[++o->op_type];
7392 Perl_ck_delete(pTHX_ OP *o)
7394 PERL_ARGS_ASSERT_CK_DELETE;
7398 if (o->op_flags & OPf_KIDS) {
7399 OP * const kid = cUNOPo->op_first;
7400 switch (kid->op_type) {
7402 o->op_flags |= OPf_SPECIAL;
7405 o->op_private |= OPpSLICE;
7408 o->op_flags |= OPf_SPECIAL;
7413 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7416 if (kid->op_private & OPpLVAL_INTRO)
7417 o->op_private |= OPpLVAL_INTRO;
7424 Perl_ck_die(pTHX_ OP *o)
7426 PERL_ARGS_ASSERT_CK_DIE;
7429 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7435 Perl_ck_eof(pTHX_ OP *o)
7439 PERL_ARGS_ASSERT_CK_EOF;
7441 if (o->op_flags & OPf_KIDS) {
7442 if (cLISTOPo->op_first->op_type == OP_STUB) {
7444 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7446 op_getmad(o,newop,'O');
7458 Perl_ck_eval(pTHX_ OP *o)
7462 PERL_ARGS_ASSERT_CK_EVAL;
7464 PL_hints |= HINT_BLOCK_SCOPE;
7465 if (o->op_flags & OPf_KIDS) {
7466 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7469 o->op_flags &= ~OPf_KIDS;
7472 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7478 cUNOPo->op_first = 0;
7483 NewOp(1101, enter, 1, LOGOP);
7484 enter->op_type = OP_ENTERTRY;
7485 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7486 enter->op_private = 0;
7488 /* establish postfix order */
7489 enter->op_next = (OP*)enter;
7491 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7492 o->op_type = OP_LEAVETRY;
7493 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7494 enter->op_other = o;
7495 op_getmad(oldo,o,'O');
7504 const U8 priv = o->op_private;
7510 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
7511 op_getmad(oldo,o,'O');
7513 o->op_targ = (PADOFFSET)PL_hints;
7514 if ((PL_hints & HINT_LOCALIZE_HH) != 0
7515 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
7516 /* Store a copy of %^H that pp_entereval can pick up. */
7517 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7518 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7519 cUNOPo->op_first->op_sibling = hhop;
7520 o->op_private |= OPpEVAL_HAS_HH;
7522 if (!(o->op_private & OPpEVAL_BYTES)
7523 && FEATURE_IS_ENABLED("unieval"))
7524 o->op_private |= OPpEVAL_UNICODE;
7530 Perl_ck_exit(pTHX_ OP *o)
7532 PERL_ARGS_ASSERT_CK_EXIT;
7535 HV * const table = GvHV(PL_hintgv);
7537 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7538 if (svp && *svp && SvTRUE(*svp))
7539 o->op_private |= OPpEXIT_VMSISH;
7541 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7547 Perl_ck_exec(pTHX_ OP *o)
7549 PERL_ARGS_ASSERT_CK_EXEC;
7551 if (o->op_flags & OPf_STACKED) {
7554 kid = cUNOPo->op_first->op_sibling;
7555 if (kid->op_type == OP_RV2GV)
7564 Perl_ck_exists(pTHX_ OP *o)
7568 PERL_ARGS_ASSERT_CK_EXISTS;
7571 if (o->op_flags & OPf_KIDS) {
7572 OP * const kid = cUNOPo->op_first;
7573 if (kid->op_type == OP_ENTERSUB) {
7574 (void) ref(kid, o->op_type);
7575 if (kid->op_type != OP_RV2CV
7576 && !(PL_parser && PL_parser->error_count))
7577 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7579 o->op_private |= OPpEXISTS_SUB;
7581 else if (kid->op_type == OP_AELEM)
7582 o->op_flags |= OPf_SPECIAL;
7583 else if (kid->op_type != OP_HELEM)
7584 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7592 Perl_ck_rvconst(pTHX_ register OP *o)
7595 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7597 PERL_ARGS_ASSERT_CK_RVCONST;
7599 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7600 if (o->op_type == OP_RV2CV)
7601 o->op_private &= ~1;
7603 if (kid->op_type == OP_CONST) {
7606 SV * const kidsv = kid->op_sv;
7608 /* Is it a constant from cv_const_sv()? */
7609 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7610 SV * const rsv = SvRV(kidsv);
7611 const svtype type = SvTYPE(rsv);
7612 const char *badtype = NULL;
7614 switch (o->op_type) {
7616 if (type > SVt_PVMG)
7617 badtype = "a SCALAR";
7620 if (type != SVt_PVAV)
7621 badtype = "an ARRAY";
7624 if (type != SVt_PVHV)
7628 if (type != SVt_PVCV)
7633 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7636 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7637 const char *badthing;
7638 switch (o->op_type) {
7640 badthing = "a SCALAR";
7643 badthing = "an ARRAY";
7646 badthing = "a HASH";
7654 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7655 SVfARG(kidsv), badthing);
7658 * This is a little tricky. We only want to add the symbol if we
7659 * didn't add it in the lexer. Otherwise we get duplicate strict
7660 * warnings. But if we didn't add it in the lexer, we must at
7661 * least pretend like we wanted to add it even if it existed before,
7662 * or we get possible typo warnings. OPpCONST_ENTERED says
7663 * whether the lexer already added THIS instance of this symbol.
7665 iscv = (o->op_type == OP_RV2CV) * 2;
7667 gv = gv_fetchsv(kidsv,
7668 iscv | !(kid->op_private & OPpCONST_ENTERED),
7671 : o->op_type == OP_RV2SV
7673 : o->op_type == OP_RV2AV
7675 : o->op_type == OP_RV2HV
7678 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7680 kid->op_type = OP_GV;
7681 SvREFCNT_dec(kid->op_sv);
7683 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7684 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7685 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7687 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7689 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7691 kid->op_private = 0;
7692 kid->op_ppaddr = PL_ppaddr[OP_GV];
7693 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7701 Perl_ck_ftst(pTHX_ OP *o)
7704 const I32 type = o->op_type;
7706 PERL_ARGS_ASSERT_CK_FTST;
7708 if (o->op_flags & OPf_REF) {
7711 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7712 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7713 const OPCODE kidtype = kid->op_type;
7715 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7716 OP * const newop = newGVOP(type, OPf_REF,
7717 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7719 op_getmad(o,newop,'O');
7725 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7726 o->op_private |= OPpFT_ACCESS;
7727 if (PL_check[kidtype] == Perl_ck_ftst
7728 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7729 o->op_private |= OPpFT_STACKED;
7730 kid->op_private |= OPpFT_STACKING;
7739 if (type == OP_FTTTY)
7740 o = newGVOP(type, OPf_REF, PL_stdingv);
7742 o = newUNOP(type, 0, newDEFSVOP());
7743 op_getmad(oldo,o,'O');
7749 Perl_ck_fun(pTHX_ OP *o)
7752 const int type = o->op_type;
7753 register I32 oa = PL_opargs[type] >> OASHIFT;
7755 PERL_ARGS_ASSERT_CK_FUN;
7757 if (o->op_flags & OPf_STACKED) {
7758 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7761 return no_fh_allowed(o);
7764 if (o->op_flags & OPf_KIDS) {
7765 OP **tokid = &cLISTOPo->op_first;
7766 register OP *kid = cLISTOPo->op_first;
7769 bool seen_optional = FALSE;
7771 if (kid->op_type == OP_PUSHMARK ||
7772 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7774 tokid = &kid->op_sibling;
7775 kid = kid->op_sibling;
7777 if (kid && kid->op_type == OP_COREARGS) {
7778 bool optional = FALSE;
7781 if (oa & OA_OPTIONAL) optional = TRUE;
7784 if (optional) o->op_private |= numargs;
7789 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
7790 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
7791 *tokid = kid = newDEFSVOP();
7792 seen_optional = TRUE;
7797 sibl = kid->op_sibling;
7799 if (!sibl && kid->op_type == OP_STUB) {
7806 /* list seen where single (scalar) arg expected? */
7807 if (numargs == 1 && !(oa >> 4)
7808 && kid->op_type == OP_LIST && type != OP_SCALAR)
7810 return too_many_arguments(o,PL_op_desc[type]);
7823 if ((type == OP_PUSH || type == OP_UNSHIFT)
7824 && !kid->op_sibling)
7825 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7826 "Useless use of %s with no values",
7829 if (kid->op_type == OP_CONST &&
7830 (kid->op_private & OPpCONST_BARE))
7832 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7833 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7834 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7835 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7836 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7838 op_getmad(kid,newop,'K');
7843 kid->op_sibling = sibl;
7846 else if (kid->op_type == OP_CONST
7847 && ( !SvROK(cSVOPx_sv(kid))
7848 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7850 bad_type(numargs, "array", PL_op_desc[type], kid);
7851 /* Defer checks to run-time if we have a scalar arg */
7852 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7853 op_lvalue(kid, type);
7857 if (kid->op_type == OP_CONST &&
7858 (kid->op_private & OPpCONST_BARE))
7860 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7861 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7862 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7863 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7864 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7866 op_getmad(kid,newop,'K');
7871 kid->op_sibling = sibl;
7874 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7875 bad_type(numargs, "hash", PL_op_desc[type], kid);
7876 op_lvalue(kid, type);
7880 OP * const newop = newUNOP(OP_NULL, 0, kid);
7881 kid->op_sibling = 0;
7883 newop->op_next = newop;
7885 kid->op_sibling = sibl;
7890 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7891 if (kid->op_type == OP_CONST &&
7892 (kid->op_private & OPpCONST_BARE))
7894 OP * const newop = newGVOP(OP_GV, 0,
7895 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7896 if (!(o->op_private & 1) && /* if not unop */
7897 kid == cLISTOPo->op_last)
7898 cLISTOPo->op_last = newop;
7900 op_getmad(kid,newop,'K');
7906 else if (kid->op_type == OP_READLINE) {
7907 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7908 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7911 I32 flags = OPf_SPECIAL;
7915 /* is this op a FH constructor? */
7916 if (is_handle_constructor(o,numargs)) {
7917 const char *name = NULL;
7922 /* Set a flag to tell rv2gv to vivify
7923 * need to "prove" flag does not mean something
7924 * else already - NI-S 1999/05/07
7927 if (kid->op_type == OP_PADSV) {
7929 = PAD_COMPNAME_SV(kid->op_targ);
7930 name = SvPV_const(namesv, len);
7931 name_utf8 = SvUTF8(namesv);
7933 else if (kid->op_type == OP_RV2SV
7934 && kUNOP->op_first->op_type == OP_GV)
7936 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7938 len = GvNAMELEN(gv);
7939 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
7941 else if (kid->op_type == OP_AELEM
7942 || kid->op_type == OP_HELEM)
7945 OP *op = ((BINOP*)kid)->op_first;
7949 const char * const a =
7950 kid->op_type == OP_AELEM ?
7952 if (((op->op_type == OP_RV2AV) ||
7953 (op->op_type == OP_RV2HV)) &&
7954 (firstop = ((UNOP*)op)->op_first) &&
7955 (firstop->op_type == OP_GV)) {
7956 /* packagevar $a[] or $h{} */
7957 GV * const gv = cGVOPx_gv(firstop);
7965 else if (op->op_type == OP_PADAV
7966 || op->op_type == OP_PADHV) {
7967 /* lexicalvar $a[] or $h{} */
7968 const char * const padname =
7969 PAD_COMPNAME_PV(op->op_targ);
7978 name = SvPV_const(tmpstr, len);
7979 name_utf8 = SvUTF8(tmpstr);
7984 name = "__ANONIO__";
7987 op_lvalue(kid, type);
7991 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7992 namesv = PAD_SVl(targ);
7993 SvUPGRADE(namesv, SVt_PV);
7995 sv_setpvs(namesv, "$");
7996 sv_catpvn(namesv, name, len);
7997 if ( name_utf8 ) SvUTF8_on(namesv);
8000 kid->op_sibling = 0;
8001 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8002 kid->op_targ = targ;
8003 kid->op_private |= priv;
8005 kid->op_sibling = sibl;
8011 op_lvalue(scalar(kid), type);
8015 tokid = &kid->op_sibling;
8016 kid = kid->op_sibling;
8019 if (kid && kid->op_type != OP_STUB)
8020 return too_many_arguments(o,OP_DESC(o));
8021 o->op_private |= numargs;
8023 /* FIXME - should the numargs move as for the PERL_MAD case? */
8024 o->op_private |= numargs;
8026 return too_many_arguments(o,OP_DESC(o));
8030 else if (PL_opargs[type] & OA_DEFGV) {
8032 OP *newop = newUNOP(type, 0, newDEFSVOP());
8033 op_getmad(o,newop,'O');
8036 /* Ordering of these two is important to keep f_map.t passing. */
8038 return newUNOP(type, 0, newDEFSVOP());
8043 while (oa & OA_OPTIONAL)
8045 if (oa && oa != OA_LIST)
8046 return too_few_arguments(o,OP_DESC(o));
8052 Perl_ck_glob(pTHX_ OP *o)
8056 const bool core = o->op_flags & OPf_SPECIAL;
8058 PERL_ARGS_ASSERT_CK_GLOB;
8061 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8062 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8064 if (core) gv = NULL;
8065 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
8066 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8068 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
8071 #if !defined(PERL_EXTERNAL_GLOB)
8072 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8074 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8075 newSVpvs("File::Glob"), NULL, NULL, NULL);
8078 #endif /* !PERL_EXTERNAL_GLOB */
8080 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8083 * \ null - const(wildcard)
8088 * \ mark - glob - rv2cv
8089 * | \ gv(CORE::GLOBAL::glob)
8091 * \ null - const(wildcard) - const(ix)
8093 o->op_flags |= OPf_SPECIAL;
8094 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8095 op_append_elem(OP_GLOB, o,
8096 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
8097 o = newLISTOP(OP_LIST, 0, o, NULL);
8098 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
8099 op_append_elem(OP_LIST, o,
8100 scalar(newUNOP(OP_RV2CV, 0,
8101 newGVOP(OP_GV, 0, gv)))));
8102 o = newUNOP(OP_NULL, 0, ck_subr(o));
8103 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8106 else o->op_flags &= ~OPf_SPECIAL;
8107 gv = newGVgen("main");
8109 #ifndef PERL_EXTERNAL_GLOB
8110 sv_setiv(GvSVn(gv),PL_glob_index++);
8112 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8118 Perl_ck_grep(pTHX_ OP *o)
8123 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8126 PERL_ARGS_ASSERT_CK_GREP;
8128 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8129 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8131 if (o->op_flags & OPf_STACKED) {
8134 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8135 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8136 return no_fh_allowed(o);
8137 for (k = kid; k; k = k->op_next) {
8140 NewOp(1101, gwop, 1, LOGOP);
8141 kid->op_next = (OP*)gwop;
8142 o->op_flags &= ~OPf_STACKED;
8144 kid = cLISTOPo->op_first->op_sibling;
8145 if (type == OP_MAPWHILE)
8150 if (PL_parser && PL_parser->error_count)
8152 kid = cLISTOPo->op_first->op_sibling;
8153 if (kid->op_type != OP_NULL)
8154 Perl_croak(aTHX_ "panic: ck_grep");
8155 kid = kUNOP->op_first;
8158 NewOp(1101, gwop, 1, LOGOP);
8159 gwop->op_type = type;
8160 gwop->op_ppaddr = PL_ppaddr[type];
8161 gwop->op_first = listkids(o);
8162 gwop->op_flags |= OPf_KIDS;
8163 gwop->op_other = LINKLIST(kid);
8164 kid->op_next = (OP*)gwop;
8165 offset = pad_findmy_pvs("$_", 0);
8166 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8167 o->op_private = gwop->op_private = 0;
8168 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8171 o->op_private = gwop->op_private = OPpGREP_LEX;
8172 gwop->op_targ = o->op_targ = offset;
8175 kid = cLISTOPo->op_first->op_sibling;
8176 if (!kid || !kid->op_sibling)
8177 return too_few_arguments(o,OP_DESC(o));
8178 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8179 op_lvalue(kid, OP_GREPSTART);
8185 Perl_ck_index(pTHX_ OP *o)
8187 PERL_ARGS_ASSERT_CK_INDEX;
8189 if (o->op_flags & OPf_KIDS) {
8190 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8192 kid = kid->op_sibling; /* get past "big" */
8193 if (kid && kid->op_type == OP_CONST) {
8194 const bool save_taint = PL_tainted;
8195 fbm_compile(((SVOP*)kid)->op_sv, 0);
8196 PL_tainted = save_taint;
8203 Perl_ck_lfun(pTHX_ OP *o)
8205 const OPCODE type = o->op_type;
8207 PERL_ARGS_ASSERT_CK_LFUN;
8209 return modkids(ck_fun(o), type);
8213 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8215 PERL_ARGS_ASSERT_CK_DEFINED;
8217 if ((o->op_flags & OPf_KIDS)) {
8218 switch (cUNOPo->op_first->op_type) {
8220 /* This is needed for
8221 if (defined %stash::)
8222 to work. Do not break Tk.
8224 break; /* Globals via GV can be undef */
8226 case OP_AASSIGN: /* Is this a good idea? */
8227 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8228 "defined(@array) is deprecated");
8229 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8230 "\t(Maybe you should just omit the defined()?)\n");
8234 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8235 "defined(%%hash) is deprecated");
8236 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8237 "\t(Maybe you should just omit the defined()?)\n");
8248 Perl_ck_readline(pTHX_ OP *o)
8250 PERL_ARGS_ASSERT_CK_READLINE;
8252 if (!(o->op_flags & OPf_KIDS)) {
8254 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8256 op_getmad(o,newop,'O');
8266 Perl_ck_rfun(pTHX_ OP *o)
8268 const OPCODE type = o->op_type;
8270 PERL_ARGS_ASSERT_CK_RFUN;
8272 return refkids(ck_fun(o), type);
8276 Perl_ck_listiob(pTHX_ OP *o)
8280 PERL_ARGS_ASSERT_CK_LISTIOB;
8282 kid = cLISTOPo->op_first;
8285 kid = cLISTOPo->op_first;
8287 if (kid->op_type == OP_PUSHMARK)
8288 kid = kid->op_sibling;
8289 if (kid && o->op_flags & OPf_STACKED)
8290 kid = kid->op_sibling;
8291 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8292 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8293 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8294 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8295 cLISTOPo->op_first->op_sibling = kid;
8296 cLISTOPo->op_last = kid;
8297 kid = kid->op_sibling;
8302 op_append_elem(o->op_type, o, newDEFSVOP());
8308 Perl_ck_smartmatch(pTHX_ OP *o)
8311 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8312 if (0 == (o->op_flags & OPf_SPECIAL)) {
8313 OP *first = cBINOPo->op_first;
8314 OP *second = first->op_sibling;
8316 /* Implicitly take a reference to an array or hash */
8317 first->op_sibling = NULL;
8318 first = cBINOPo->op_first = ref_array_or_hash(first);
8319 second = first->op_sibling = ref_array_or_hash(second);
8321 /* Implicitly take a reference to a regular expression */
8322 if (first->op_type == OP_MATCH) {
8323 first->op_type = OP_QR;
8324 first->op_ppaddr = PL_ppaddr[OP_QR];
8326 if (second->op_type == OP_MATCH) {
8327 second->op_type = OP_QR;
8328 second->op_ppaddr = PL_ppaddr[OP_QR];
8337 Perl_ck_sassign(pTHX_ OP *o)
8340 OP * const kid = cLISTOPo->op_first;
8342 PERL_ARGS_ASSERT_CK_SASSIGN;
8344 /* has a disposable target? */
8345 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8346 && !(kid->op_flags & OPf_STACKED)
8347 /* Cannot steal the second time! */
8348 && !(kid->op_private & OPpTARGET_MY)
8349 /* Keep the full thing for madskills */
8353 OP * const kkid = kid->op_sibling;
8355 /* Can just relocate the target. */
8356 if (kkid && kkid->op_type == OP_PADSV
8357 && !(kkid->op_private & OPpLVAL_INTRO))
8359 kid->op_targ = kkid->op_targ;
8361 /* Now we do not need PADSV and SASSIGN. */
8362 kid->op_sibling = o->op_sibling; /* NULL */
8363 cLISTOPo->op_first = NULL;
8366 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8370 if (kid->op_sibling) {
8371 OP *kkid = kid->op_sibling;
8372 /* For state variable assignment, kkid is a list op whose op_last
8374 if ((kkid->op_type == OP_PADSV ||
8375 (kkid->op_type == OP_LIST &&
8376 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8379 && (kkid->op_private & OPpLVAL_INTRO)
8380 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8381 const PADOFFSET target = kkid->op_targ;
8382 OP *const other = newOP(OP_PADSV,
8384 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8385 OP *const first = newOP(OP_NULL, 0);
8386 OP *const nullop = newCONDOP(0, first, o, other);
8387 OP *const condop = first->op_next;
8388 /* hijacking PADSTALE for uninitialized state variables */
8389 SvPADSTALE_on(PAD_SVl(target));
8391 condop->op_type = OP_ONCE;
8392 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8393 condop->op_targ = target;
8394 other->op_targ = target;
8396 /* Because we change the type of the op here, we will skip the
8397 assignment binop->op_last = binop->op_first->op_sibling; at the
8398 end of Perl_newBINOP(). So need to do it here. */
8399 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8408 Perl_ck_match(pTHX_ OP *o)
8412 PERL_ARGS_ASSERT_CK_MATCH;
8414 if (o->op_type != OP_QR && PL_compcv) {
8415 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8416 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8417 o->op_targ = offset;
8418 o->op_private |= OPpTARGET_MY;
8421 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8422 o->op_private |= OPpRUNTIME;
8427 Perl_ck_method(pTHX_ OP *o)
8429 OP * const kid = cUNOPo->op_first;
8431 PERL_ARGS_ASSERT_CK_METHOD;
8433 if (kid->op_type == OP_CONST) {
8434 SV* sv = kSVOP->op_sv;
8435 const char * const method = SvPVX_const(sv);
8436 if (!(strchr(method, ':') || strchr(method, '\''))) {
8438 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8439 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
8442 kSVOP->op_sv = NULL;
8444 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8446 op_getmad(o,cmop,'O');
8457 Perl_ck_null(pTHX_ OP *o)
8459 PERL_ARGS_ASSERT_CK_NULL;
8460 PERL_UNUSED_CONTEXT;
8465 Perl_ck_open(pTHX_ OP *o)
8468 HV * const table = GvHV(PL_hintgv);
8470 PERL_ARGS_ASSERT_CK_OPEN;
8473 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8476 const char *d = SvPV_const(*svp, len);
8477 const I32 mode = mode_from_discipline(d, len);
8478 if (mode & O_BINARY)
8479 o->op_private |= OPpOPEN_IN_RAW;
8480 else if (mode & O_TEXT)
8481 o->op_private |= OPpOPEN_IN_CRLF;
8484 svp = hv_fetchs(table, "open_OUT", FALSE);
8487 const char *d = SvPV_const(*svp, len);
8488 const I32 mode = mode_from_discipline(d, len);
8489 if (mode & O_BINARY)
8490 o->op_private |= OPpOPEN_OUT_RAW;
8491 else if (mode & O_TEXT)
8492 o->op_private |= OPpOPEN_OUT_CRLF;
8495 if (o->op_type == OP_BACKTICK) {
8496 if (!(o->op_flags & OPf_KIDS)) {
8497 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8499 op_getmad(o,newop,'O');
8508 /* In case of three-arg dup open remove strictness
8509 * from the last arg if it is a bareword. */
8510 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8511 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8515 if ((last->op_type == OP_CONST) && /* The bareword. */
8516 (last->op_private & OPpCONST_BARE) &&
8517 (last->op_private & OPpCONST_STRICT) &&
8518 (oa = first->op_sibling) && /* The fh. */
8519 (oa = oa->op_sibling) && /* The mode. */
8520 (oa->op_type == OP_CONST) &&
8521 SvPOK(((SVOP*)oa)->op_sv) &&
8522 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8523 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8524 (last == oa->op_sibling)) /* The bareword. */
8525 last->op_private &= ~OPpCONST_STRICT;
8531 Perl_ck_repeat(pTHX_ OP *o)
8533 PERL_ARGS_ASSERT_CK_REPEAT;
8535 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8536 o->op_private |= OPpREPEAT_DOLIST;
8537 cBINOPo->op_first = force_list(cBINOPo->op_first);
8545 Perl_ck_require(pTHX_ OP *o)
8550 PERL_ARGS_ASSERT_CK_REQUIRE;
8552 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8553 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8555 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8556 SV * const sv = kid->op_sv;
8557 U32 was_readonly = SvREADONLY(sv);
8564 sv_force_normal_flags(sv, 0);
8565 assert(!SvREADONLY(sv));
8575 for (; s < end; s++) {
8576 if (*s == ':' && s[1] == ':') {
8578 Move(s+2, s+1, end - s - 1, char);
8583 sv_catpvs(sv, ".pm");
8584 SvFLAGS(sv) |= was_readonly;
8588 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8589 /* handle override, if any */
8590 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8591 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8592 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8593 gv = gvp ? *gvp : NULL;
8597 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8599 if (o->op_flags & OPf_KIDS) {
8600 kid = cUNOPo->op_first;
8601 cUNOPo->op_first = NULL;
8609 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8610 op_append_elem(OP_LIST, kid,
8611 scalar(newUNOP(OP_RV2CV, 0,
8614 op_getmad(o,newop,'O');
8618 return scalar(ck_fun(o));
8622 Perl_ck_return(pTHX_ OP *o)
8627 PERL_ARGS_ASSERT_CK_RETURN;
8629 kid = cLISTOPo->op_first->op_sibling;
8630 if (CvLVALUE(PL_compcv)) {
8631 for (; kid; kid = kid->op_sibling)
8632 op_lvalue(kid, OP_LEAVESUBLV);
8639 Perl_ck_select(pTHX_ OP *o)
8644 PERL_ARGS_ASSERT_CK_SELECT;
8646 if (o->op_flags & OPf_KIDS) {
8647 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8648 if (kid && kid->op_sibling) {
8649 o->op_type = OP_SSELECT;
8650 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8652 return fold_constants(op_integerize(op_std_init(o)));
8656 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8657 if (kid && kid->op_type == OP_RV2GV)
8658 kid->op_private &= ~HINT_STRICT_REFS;
8663 Perl_ck_shift(pTHX_ OP *o)
8666 const I32 type = o->op_type;
8668 PERL_ARGS_ASSERT_CK_SHIFT;
8670 if (!(o->op_flags & OPf_KIDS)) {
8673 if (!CvUNIQUE(PL_compcv)) {
8674 o->op_flags |= OPf_SPECIAL;
8678 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8681 OP * const oldo = o;
8682 o = newUNOP(type, 0, scalar(argop));
8683 op_getmad(oldo,o,'O');
8688 return newUNOP(type, 0, scalar(argop));
8691 return scalar(ck_fun(o));
8695 Perl_ck_sort(pTHX_ OP *o)
8700 PERL_ARGS_ASSERT_CK_SORT;
8702 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8703 HV * const hinthv = GvHV(PL_hintgv);
8705 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8707 const I32 sorthints = (I32)SvIV(*svp);
8708 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8709 o->op_private |= OPpSORT_QSORT;
8710 if ((sorthints & HINT_SORT_STABLE) != 0)
8711 o->op_private |= OPpSORT_STABLE;
8716 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8718 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8719 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8721 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8723 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8725 if (kid->op_type == OP_SCOPE) {
8729 else if (kid->op_type == OP_LEAVE) {
8730 if (o->op_type == OP_SORT) {
8731 op_null(kid); /* wipe out leave */
8734 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8735 if (k->op_next == kid)
8737 /* don't descend into loops */
8738 else if (k->op_type == OP_ENTERLOOP
8739 || k->op_type == OP_ENTERITER)
8741 k = cLOOPx(k)->op_lastop;
8746 kid->op_next = 0; /* just disconnect the leave */
8747 k = kLISTOP->op_first;
8752 if (o->op_type == OP_SORT) {
8753 /* provide scalar context for comparison function/block */
8759 o->op_flags |= OPf_SPECIAL;
8761 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8764 firstkid = firstkid->op_sibling;
8767 /* provide list context for arguments */
8768 if (o->op_type == OP_SORT)
8775 S_simplify_sort(pTHX_ OP *o)
8778 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8784 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8786 if (!(o->op_flags & OPf_STACKED))
8788 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8789 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8790 kid = kUNOP->op_first; /* get past null */
8791 if (kid->op_type != OP_SCOPE)
8793 kid = kLISTOP->op_last; /* get past scope */
8794 switch(kid->op_type) {
8802 k = kid; /* remember this node*/
8803 if (kBINOP->op_first->op_type != OP_RV2SV)
8805 kid = kBINOP->op_first; /* get past cmp */
8806 if (kUNOP->op_first->op_type != OP_GV)
8808 kid = kUNOP->op_first; /* get past rv2sv */
8810 if (GvSTASH(gv) != PL_curstash)
8812 gvname = GvNAME(gv);
8813 if (*gvname == 'a' && gvname[1] == '\0')
8815 else if (*gvname == 'b' && gvname[1] == '\0')
8820 kid = k; /* back to cmp */
8821 if (kBINOP->op_last->op_type != OP_RV2SV)
8823 kid = kBINOP->op_last; /* down to 2nd arg */
8824 if (kUNOP->op_first->op_type != OP_GV)
8826 kid = kUNOP->op_first; /* get past rv2sv */
8828 if (GvSTASH(gv) != PL_curstash)
8830 gvname = GvNAME(gv);
8832 ? !(*gvname == 'a' && gvname[1] == '\0')
8833 : !(*gvname == 'b' && gvname[1] == '\0'))
8835 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8837 o->op_private |= OPpSORT_DESCEND;
8838 if (k->op_type == OP_NCMP)
8839 o->op_private |= OPpSORT_NUMERIC;
8840 if (k->op_type == OP_I_NCMP)
8841 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8842 kid = cLISTOPo->op_first->op_sibling;
8843 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8845 op_getmad(kid,o,'S'); /* then delete it */
8847 op_free(kid); /* then delete it */
8852 Perl_ck_split(pTHX_ OP *o)
8857 PERL_ARGS_ASSERT_CK_SPLIT;
8859 if (o->op_flags & OPf_STACKED)
8860 return no_fh_allowed(o);
8862 kid = cLISTOPo->op_first;
8863 if (kid->op_type != OP_NULL)
8864 Perl_croak(aTHX_ "panic: ck_split");
8865 kid = kid->op_sibling;
8866 op_free(cLISTOPo->op_first);
8868 cLISTOPo->op_first = kid;
8870 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8871 cLISTOPo->op_last = kid; /* There was only one element previously */
8874 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8875 OP * const sibl = kid->op_sibling;
8876 kid->op_sibling = 0;
8877 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8878 if (cLISTOPo->op_first == cLISTOPo->op_last)
8879 cLISTOPo->op_last = kid;
8880 cLISTOPo->op_first = kid;
8881 kid->op_sibling = sibl;
8884 kid->op_type = OP_PUSHRE;
8885 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8887 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8888 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8889 "Use of /g modifier is meaningless in split");
8892 if (!kid->op_sibling)
8893 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8895 kid = kid->op_sibling;
8898 if (!kid->op_sibling)
8899 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8900 assert(kid->op_sibling);
8902 kid = kid->op_sibling;
8905 if (kid->op_sibling)
8906 return too_many_arguments(o,OP_DESC(o));
8912 Perl_ck_join(pTHX_ OP *o)
8914 const OP * const kid = cLISTOPo->op_first->op_sibling;
8916 PERL_ARGS_ASSERT_CK_JOIN;
8918 if (kid && kid->op_type == OP_MATCH) {
8919 if (ckWARN(WARN_SYNTAX)) {
8920 const REGEXP *re = PM_GETRE(kPMOP);
8921 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8922 const STRLEN len = re ? RX_PRELEN(re) : 6;
8923 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8924 "/%.*s/ should probably be written as \"%.*s\"",
8925 (int)len, pmstr, (int)len, pmstr);
8932 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8934 Examines an op, which is expected to identify a subroutine at runtime,
8935 and attempts to determine at compile time which subroutine it identifies.
8936 This is normally used during Perl compilation to determine whether
8937 a prototype can be applied to a function call. I<cvop> is the op
8938 being considered, normally an C<rv2cv> op. A pointer to the identified
8939 subroutine is returned, if it could be determined statically, and a null
8940 pointer is returned if it was not possible to determine statically.
8942 Currently, the subroutine can be identified statically if the RV that the
8943 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8944 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8945 suitable if the constant value must be an RV pointing to a CV. Details of
8946 this process may change in future versions of Perl. If the C<rv2cv> op
8947 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8948 the subroutine statically: this flag is used to suppress compile-time
8949 magic on a subroutine call, forcing it to use default runtime behaviour.
8951 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8952 of a GV reference is modified. If a GV was examined and its CV slot was
8953 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8954 If the op is not optimised away, and the CV slot is later populated with
8955 a subroutine having a prototype, that flag eventually triggers the warning
8956 "called too early to check prototype".
8958 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8959 of returning a pointer to the subroutine it returns a pointer to the
8960 GV giving the most appropriate name for the subroutine in this context.
8961 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8962 (C<CvANON>) subroutine that is referenced through a GV it will be the
8963 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8964 A null pointer is returned as usual if there is no statically-determinable
8971 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8976 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8977 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8978 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8979 if (cvop->op_type != OP_RV2CV)
8981 if (cvop->op_private & OPpENTERSUB_AMPER)
8983 if (!(cvop->op_flags & OPf_KIDS))
8985 rvop = cUNOPx(cvop)->op_first;
8986 switch (rvop->op_type) {
8988 gv = cGVOPx_gv(rvop);
8991 if (flags & RV2CVOPCV_MARK_EARLY)
8992 rvop->op_private |= OPpEARLY_CV;
8997 SV *rv = cSVOPx_sv(rvop);
9007 if (SvTYPE((SV*)cv) != SVt_PVCV)
9009 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9010 if (!CvANON(cv) || !gv)
9019 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9021 Performs the default fixup of the arguments part of an C<entersub>
9022 op tree. This consists of applying list context to each of the
9023 argument ops. This is the standard treatment used on a call marked
9024 with C<&>, or a method call, or a call through a subroutine reference,
9025 or any other call where the callee can't be identified at compile time,
9026 or a call where the callee has no prototype.
9032 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9035 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9036 aop = cUNOPx(entersubop)->op_first;
9037 if (!aop->op_sibling)
9038 aop = cUNOPx(aop)->op_first;
9039 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9040 if (!(PL_madskills && aop->op_type == OP_STUB)) {
9042 op_lvalue(aop, OP_ENTERSUB);
9049 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9051 Performs the fixup of the arguments part of an C<entersub> op tree
9052 based on a subroutine prototype. This makes various modifications to
9053 the argument ops, from applying context up to inserting C<refgen> ops,
9054 and checking the number and syntactic types of arguments, as directed by
9055 the prototype. This is the standard treatment used on a subroutine call,
9056 not marked with C<&>, where the callee can be identified at compile time
9057 and has a prototype.
9059 I<protosv> supplies the subroutine prototype to be applied to the call.
9060 It may be a normal defined scalar, of which the string value will be used.
9061 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9062 that has been cast to C<SV*>) which has a prototype. The prototype
9063 supplied, in whichever form, does not need to match the actual callee
9064 referenced by the op tree.
9066 If the argument ops disagree with the prototype, for example by having
9067 an unacceptable number of arguments, a valid op tree is returned anyway.
9068 The error is reflected in the parser state, normally resulting in a single
9069 exception at the top level of parsing which covers all the compilation
9070 errors that occurred. In the error message, the callee is referred to
9071 by the name defined by the I<namegv> parameter.
9077 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9080 const char *proto, *proto_end;
9081 OP *aop, *prev, *cvop;
9084 I32 contextclass = 0;
9085 const char *e = NULL;
9086 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9087 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9088 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
9089 if (SvTYPE(protosv) == SVt_PVCV)
9090 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9091 else proto = SvPV(protosv, proto_len);
9092 proto_end = proto + proto_len;
9093 aop = cUNOPx(entersubop)->op_first;
9094 if (!aop->op_sibling)
9095 aop = cUNOPx(aop)->op_first;
9097 aop = aop->op_sibling;
9098 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9099 while (aop != cvop) {
9101 if (PL_madskills && aop->op_type == OP_STUB) {
9102 aop = aop->op_sibling;
9105 if (PL_madskills && aop->op_type == OP_NULL)
9106 o3 = ((UNOP*)aop)->op_first;
9110 if (proto >= proto_end)
9111 return too_many_arguments(entersubop, gv_ename(namegv));
9119 /* _ must be at the end */
9120 if (proto[1] && proto[1] != ';')
9135 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9137 arg == 1 ? "block or sub {}" : "sub {}",
9138 gv_ename(namegv), o3);
9141 /* '*' allows any scalar type, including bareword */
9144 if (o3->op_type == OP_RV2GV)
9145 goto wrapref; /* autoconvert GLOB -> GLOBref */
9146 else if (o3->op_type == OP_CONST)
9147 o3->op_private &= ~OPpCONST_STRICT;
9148 else if (o3->op_type == OP_ENTERSUB) {
9149 /* accidental subroutine, revert to bareword */
9150 OP *gvop = ((UNOP*)o3)->op_first;
9151 if (gvop && gvop->op_type == OP_NULL) {
9152 gvop = ((UNOP*)gvop)->op_first;
9154 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9157 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9158 (gvop = ((UNOP*)gvop)->op_first) &&
9159 gvop->op_type == OP_GV)
9161 GV * const gv = cGVOPx_gv(gvop);
9162 OP * const sibling = aop->op_sibling;
9163 SV * const n = newSVpvs("");
9165 OP * const oldaop = aop;
9169 gv_fullname4(n, gv, "", FALSE);
9170 aop = newSVOP(OP_CONST, 0, n);
9171 op_getmad(oldaop,aop,'O');
9172 prev->op_sibling = aop;
9173 aop->op_sibling = sibling;
9183 if (o3->op_type == OP_RV2AV ||
9184 o3->op_type == OP_PADAV ||
9185 o3->op_type == OP_RV2HV ||
9186 o3->op_type == OP_PADHV
9201 if (contextclass++ == 0) {
9202 e = strchr(proto, ']');
9203 if (!e || e == proto)
9212 const char *p = proto;
9213 const char *const end = proto;
9216 /* \[$] accepts any scalar lvalue */
9218 && Perl_op_lvalue_flags(aTHX_
9220 OP_READ, /* not entersub */
9223 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
9225 gv_ename(namegv), o3);
9230 if (o3->op_type == OP_RV2GV)
9233 bad_type(arg, "symbol", gv_ename(namegv), o3);
9236 if (o3->op_type == OP_ENTERSUB)
9239 bad_type(arg, "subroutine entry", gv_ename(namegv),
9243 if (o3->op_type == OP_RV2SV ||
9244 o3->op_type == OP_PADSV ||
9245 o3->op_type == OP_HELEM ||
9246 o3->op_type == OP_AELEM)
9248 if (!contextclass) {
9249 /* \$ accepts any scalar lvalue */
9250 if (Perl_op_lvalue_flags(aTHX_
9252 OP_READ, /* not entersub */
9255 bad_type(arg, "scalar", gv_ename(namegv), o3);
9259 if (o3->op_type == OP_RV2AV ||
9260 o3->op_type == OP_PADAV)
9263 bad_type(arg, "array", gv_ename(namegv), o3);
9266 if (o3->op_type == OP_RV2HV ||
9267 o3->op_type == OP_PADHV)
9270 bad_type(arg, "hash", gv_ename(namegv), o3);
9274 OP* const kid = aop;
9275 OP* const sib = kid->op_sibling;
9276 kid->op_sibling = 0;
9277 aop = newUNOP(OP_REFGEN, 0, kid);
9278 aop->op_sibling = sib;
9279 prev->op_sibling = aop;
9281 if (contextclass && e) {
9296 SV* const tmpsv = sv_newmortal();
9297 gv_efullname3(tmpsv, namegv, NULL);
9298 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9299 SVfARG(tmpsv), SVfARG(protosv));
9303 op_lvalue(aop, OP_ENTERSUB);
9305 aop = aop->op_sibling;
9307 if (aop == cvop && *proto == '_') {
9308 /* generate an access to $_ */
9310 aop->op_sibling = prev->op_sibling;
9311 prev->op_sibling = aop; /* instead of cvop */
9313 if (!optional && proto_end > proto &&
9314 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9315 return too_few_arguments(entersubop, gv_ename(namegv));
9320 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9322 Performs the fixup of the arguments part of an C<entersub> op tree either
9323 based on a subroutine prototype or using default list-context processing.
9324 This is the standard treatment used on a subroutine call, not marked
9325 with C<&>, where the callee can be identified at compile time.
9327 I<protosv> supplies the subroutine prototype to be applied to the call,
9328 or indicates that there is no prototype. It may be a normal scalar,
9329 in which case if it is defined then the string value will be used
9330 as a prototype, and if it is undefined then there is no prototype.
9331 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9332 that has been cast to C<SV*>), of which the prototype will be used if it
9333 has one. The prototype (or lack thereof) supplied, in whichever form,
9334 does not need to match the actual callee referenced by the op tree.
9336 If the argument ops disagree with the prototype, for example by having
9337 an unacceptable number of arguments, a valid op tree is returned anyway.
9338 The error is reflected in the parser state, normally resulting in a single
9339 exception at the top level of parsing which covers all the compilation
9340 errors that occurred. In the error message, the callee is referred to
9341 by the name defined by the I<namegv> parameter.
9347 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9348 GV *namegv, SV *protosv)
9350 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9351 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9352 return ck_entersub_args_proto(entersubop, namegv, protosv);
9354 return ck_entersub_args_list(entersubop);
9358 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9360 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9361 OP *aop = cUNOPx(entersubop)->op_first;
9363 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9367 if (!aop->op_sibling)
9368 aop = cUNOPx(aop)->op_first;
9369 aop = aop->op_sibling;
9370 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9371 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9372 aop = aop->op_sibling;
9376 (void)too_many_arguments(entersubop, GvNAME(namegv));
9378 op_free(entersubop);
9379 switch(GvNAME(namegv)[2]) {
9380 case 'F': return newSVOP(OP_CONST, 0,
9381 newSVpv(CopFILE(PL_curcop),0));
9382 case 'L': return newSVOP(
9385 "%"IVdf, (IV)CopLINE(PL_curcop)
9388 case 'P': return newSVOP(OP_CONST, 0,
9390 ? newSVhek(HvNAME_HEK(PL_curstash))
9401 bool seenarg = FALSE;
9403 if (!aop->op_sibling)
9404 aop = cUNOPx(aop)->op_first;
9407 aop = aop->op_sibling;
9408 prev->op_sibling = NULL;
9411 prev=cvop, cvop = cvop->op_sibling)
9413 if (PL_madskills && cvop->op_sibling
9414 && cvop->op_type != OP_STUB) seenarg = TRUE
9417 prev->op_sibling = NULL;
9418 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9420 if (aop == cvop) aop = NULL;
9421 op_free(entersubop);
9423 if (opnum == OP_ENTEREVAL
9424 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
9425 flags |= OPpEVAL_BYTES <<8;
9427 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9429 case OA_BASEOP_OR_UNOP:
9431 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
9435 if (!PL_madskills || seenarg)
9437 (void)too_many_arguments(aop, GvNAME(namegv));
9440 return newOP(opnum,0);
9442 return convert(opnum,0,aop);
9450 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9452 Retrieves the function that will be used to fix up a call to I<cv>.
9453 Specifically, the function is applied to an C<entersub> op tree for a
9454 subroutine call, not marked with C<&>, where the callee can be identified
9455 at compile time as I<cv>.
9457 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9458 argument for it is returned in I<*ckobj_p>. The function is intended
9459 to be called in this manner:
9461 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9463 In this call, I<entersubop> is a pointer to the C<entersub> op,
9464 which may be replaced by the check function, and I<namegv> is a GV
9465 supplying the name that should be used by the check function to refer
9466 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9467 It is permitted to apply the check function in non-standard situations,
9468 such as to a call to a different subroutine or to a method call.
9470 By default, the function is
9471 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9472 and the SV parameter is I<cv> itself. This implements standard
9473 prototype processing. It can be changed, for a particular subroutine,
9474 by L</cv_set_call_checker>.
9480 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9483 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9484 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9486 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9487 *ckobj_p = callmg->mg_obj;
9489 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9495 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9497 Sets the function that will be used to fix up a call to I<cv>.
9498 Specifically, the function is applied to an C<entersub> op tree for a
9499 subroutine call, not marked with C<&>, where the callee can be identified
9500 at compile time as I<cv>.
9502 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9503 for it is supplied in I<ckobj>. The function is intended to be called
9506 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9508 In this call, I<entersubop> is a pointer to the C<entersub> op,
9509 which may be replaced by the check function, and I<namegv> is a GV
9510 supplying the name that should be used by the check function to refer
9511 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9512 It is permitted to apply the check function in non-standard situations,
9513 such as to a call to a different subroutine or to a method call.
9515 The current setting for a particular CV can be retrieved by
9516 L</cv_get_call_checker>.
9522 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9524 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9525 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9526 if (SvMAGICAL((SV*)cv))
9527 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9530 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9531 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9532 if (callmg->mg_flags & MGf_REFCOUNTED) {
9533 SvREFCNT_dec(callmg->mg_obj);
9534 callmg->mg_flags &= ~MGf_REFCOUNTED;
9536 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9537 callmg->mg_obj = ckobj;
9538 if (ckobj != (SV*)cv) {
9539 SvREFCNT_inc_simple_void_NN(ckobj);
9540 callmg->mg_flags |= MGf_REFCOUNTED;
9546 Perl_ck_subr(pTHX_ OP *o)
9552 PERL_ARGS_ASSERT_CK_SUBR;
9554 aop = cUNOPx(o)->op_first;
9555 if (!aop->op_sibling)
9556 aop = cUNOPx(aop)->op_first;
9557 aop = aop->op_sibling;
9558 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9559 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9560 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9562 o->op_private &= ~1;
9563 o->op_private |= OPpENTERSUB_HASTARG;
9564 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9565 if (PERLDB_SUB && PL_curstash != PL_debstash)
9566 o->op_private |= OPpENTERSUB_DB;
9567 if (cvop->op_type == OP_RV2CV) {
9568 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9570 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9571 if (aop->op_type == OP_CONST)
9572 aop->op_private &= ~OPpCONST_STRICT;
9573 else if (aop->op_type == OP_LIST) {
9574 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9575 if (sib && sib->op_type == OP_CONST)
9576 sib->op_private &= ~OPpCONST_STRICT;
9581 return ck_entersub_args_list(o);
9583 Perl_call_checker ckfun;
9585 cv_get_call_checker(cv, &ckfun, &ckobj);
9586 return ckfun(aTHX_ o, namegv, ckobj);
9591 Perl_ck_svconst(pTHX_ OP *o)
9593 PERL_ARGS_ASSERT_CK_SVCONST;
9594 PERL_UNUSED_CONTEXT;
9595 SvREADONLY_on(cSVOPo->op_sv);
9600 Perl_ck_chdir(pTHX_ OP *o)
9602 PERL_ARGS_ASSERT_CK_CHDIR;
9603 if (o->op_flags & OPf_KIDS) {
9604 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9606 if (kid && kid->op_type == OP_CONST &&
9607 (kid->op_private & OPpCONST_BARE))
9609 o->op_flags |= OPf_SPECIAL;
9610 kid->op_private &= ~OPpCONST_STRICT;
9617 Perl_ck_trunc(pTHX_ OP *o)
9619 PERL_ARGS_ASSERT_CK_TRUNC;
9621 if (o->op_flags & OPf_KIDS) {
9622 SVOP *kid = (SVOP*)cUNOPo->op_first;
9624 if (kid->op_type == OP_NULL)
9625 kid = (SVOP*)kid->op_sibling;
9626 if (kid && kid->op_type == OP_CONST &&
9627 (kid->op_private & OPpCONST_BARE))
9629 o->op_flags |= OPf_SPECIAL;
9630 kid->op_private &= ~OPpCONST_STRICT;
9637 Perl_ck_substr(pTHX_ OP *o)
9639 PERL_ARGS_ASSERT_CK_SUBSTR;
9642 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9643 OP *kid = cLISTOPo->op_first;
9645 if (kid->op_type == OP_NULL)
9646 kid = kid->op_sibling;
9648 kid->op_flags |= OPf_MOD;
9655 Perl_ck_each(pTHX_ OP *o)
9658 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9659 const unsigned orig_type = o->op_type;
9660 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9661 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9662 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9663 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9665 PERL_ARGS_ASSERT_CK_EACH;
9668 switch (kid->op_type) {
9674 CHANGE_TYPE(o, array_type);
9677 if (kid->op_private == OPpCONST_BARE
9678 || !SvROK(cSVOPx_sv(kid))
9679 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9680 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9682 /* we let ck_fun handle it */
9685 CHANGE_TYPE(o, ref_type);
9689 /* if treating as a reference, defer additional checks to runtime */
9690 return o->op_type == ref_type ? o : ck_fun(o);
9694 Perl_ck_length(pTHX_ OP *o)
9696 PERL_ARGS_ASSERT_CK_LENGTH;
9700 if (ckWARN(WARN_SYNTAX)) {
9701 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9705 const bool hash = kid->op_type == OP_PADHV
9706 || kid->op_type == OP_RV2HV;
9707 switch (kid->op_type) {
9711 NULL, hash ? '%' : '@', kid->op_targ, NULL, 0, 1
9716 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
9718 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
9720 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
9727 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9728 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
9730 name, hash ? "keys " : "", name
9733 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9734 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
9736 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9737 "length() used on @array (did you mean \"scalar(@array)\"?)");
9744 /* caller is supposed to assign the return to the
9745 container of the rep_op var */
9747 S_opt_scalarhv(pTHX_ OP *rep_op) {
9751 PERL_ARGS_ASSERT_OPT_SCALARHV;
9753 NewOp(1101, unop, 1, UNOP);
9754 unop->op_type = (OPCODE)OP_BOOLKEYS;
9755 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9756 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9757 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9758 unop->op_first = rep_op;
9759 unop->op_next = rep_op->op_next;
9760 rep_op->op_next = (OP*)unop;
9761 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9762 unop->op_sibling = rep_op->op_sibling;
9763 rep_op->op_sibling = NULL;
9764 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9765 if (rep_op->op_type == OP_PADHV) {
9766 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9767 rep_op->op_flags |= OPf_WANT_LIST;
9772 /* Check for in place reverse and sort assignments like "@a = reverse @a"
9773 and modify the optree to make them work inplace */
9776 S_inplace_aassign(pTHX_ OP *o) {
9778 OP *modop, *modop_pushmark;
9780 OP *oleft, *oleft_pushmark;
9782 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
9784 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
9786 assert(cUNOPo->op_first->op_type == OP_NULL);
9787 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
9788 assert(modop_pushmark->op_type == OP_PUSHMARK);
9789 modop = modop_pushmark->op_sibling;
9791 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
9794 /* no other operation except sort/reverse */
9795 if (modop->op_sibling)
9798 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
9799 oright = cUNOPx(modop)->op_first->op_sibling;
9801 if (modop->op_flags & OPf_STACKED) {
9802 /* skip sort subroutine/block */
9803 assert(oright->op_type == OP_NULL);
9804 oright = oright->op_sibling;
9807 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
9808 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
9809 assert(oleft_pushmark->op_type == OP_PUSHMARK);
9810 oleft = oleft_pushmark->op_sibling;
9812 /* Check the lhs is an array */
9814 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
9815 || oleft->op_sibling
9816 || (oleft->op_private & OPpLVAL_INTRO)
9820 /* Only one thing on the rhs */
9821 if (oright->op_sibling)
9824 /* check the array is the same on both sides */
9825 if (oleft->op_type == OP_RV2AV) {
9826 if (oright->op_type != OP_RV2AV
9827 || !cUNOPx(oright)->op_first
9828 || cUNOPx(oright)->op_first->op_type != OP_GV
9829 || cUNOPx(oleft )->op_first->op_type != OP_GV
9830 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9831 cGVOPx_gv(cUNOPx(oright)->op_first)
9835 else if (oright->op_type != OP_PADAV
9836 || oright->op_targ != oleft->op_targ
9840 /* This actually is an inplace assignment */
9842 modop->op_private |= OPpSORT_INPLACE;
9844 /* transfer MODishness etc from LHS arg to RHS arg */
9845 oright->op_flags = oleft->op_flags;
9847 /* remove the aassign op and the lhs */
9849 op_null(oleft_pushmark);
9850 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
9851 op_null(cUNOPx(oleft)->op_first);
9855 #define MAX_DEFERRED 4
9858 if (defer_ix == (MAX_DEFERRED-1)) { \
9859 CALL_RPEEP(defer_queue[defer_base]); \
9860 defer_base = (defer_base + 1) % MAX_DEFERRED; \
9863 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
9865 /* A peephole optimizer. We visit the ops in the order they're to execute.
9866 * See the comments at the top of this file for more details about when
9867 * peep() is called */
9870 Perl_rpeep(pTHX_ register OP *o)
9873 register OP* oldop = NULL;
9874 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
9878 if (!o || o->op_opt)
9882 SAVEVPTR(PL_curcop);
9883 for (;; o = o->op_next) {
9887 while (defer_ix >= 0)
9888 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
9892 /* By default, this op has now been optimised. A couple of cases below
9893 clear this again. */
9896 switch (o->op_type) {
9898 PL_curcop = ((COP*)o); /* for warnings */
9901 PL_curcop = ((COP*)o); /* for warnings */
9903 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9904 to carry two labels. For now, take the easier option, and skip
9905 this optimisation if the first NEXTSTATE has a label. */
9906 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9907 OP *nextop = o->op_next;
9908 while (nextop && nextop->op_type == OP_NULL)
9909 nextop = nextop->op_next;
9911 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9912 COP *firstcop = (COP *)o;
9913 COP *secondcop = (COP *)nextop;
9914 /* We want the COP pointed to by o (and anything else) to
9915 become the next COP down the line. */
9918 firstcop->op_next = secondcop->op_next;
9920 /* Now steal all its pointers, and duplicate the other
9922 firstcop->cop_line = secondcop->cop_line;
9924 firstcop->cop_stashpv = secondcop->cop_stashpv;
9925 firstcop->cop_file = secondcop->cop_file;
9927 firstcop->cop_stash = secondcop->cop_stash;
9928 firstcop->cop_filegv = secondcop->cop_filegv;
9930 firstcop->cop_hints = secondcop->cop_hints;
9931 firstcop->cop_seq = secondcop->cop_seq;
9932 firstcop->cop_warnings = secondcop->cop_warnings;
9933 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9936 secondcop->cop_stashpv = NULL;
9937 secondcop->cop_file = NULL;
9939 secondcop->cop_stash = NULL;
9940 secondcop->cop_filegv = NULL;
9942 secondcop->cop_warnings = NULL;
9943 secondcop->cop_hints_hash = NULL;
9945 /* If we use op_null(), and hence leave an ex-COP, some
9946 warnings are misreported. For example, the compile-time
9947 error in 'use strict; no strict refs;' */
9948 secondcop->op_type = OP_NULL;
9949 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9955 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9956 if (o->op_next->op_private & OPpTARGET_MY) {
9957 if (o->op_flags & OPf_STACKED) /* chained concats */
9958 break; /* ignore_optimization */
9960 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9961 o->op_targ = o->op_next->op_targ;
9962 o->op_next->op_targ = 0;
9963 o->op_private |= OPpTARGET_MY;
9966 op_null(o->op_next);
9970 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9971 break; /* Scalar stub must produce undef. List stub is noop */
9975 if (o->op_targ == OP_NEXTSTATE
9976 || o->op_targ == OP_DBSTATE)
9978 PL_curcop = ((COP*)o);
9980 /* XXX: We avoid setting op_seq here to prevent later calls
9981 to rpeep() from mistakenly concluding that optimisation
9982 has already occurred. This doesn't fix the real problem,
9983 though (See 20010220.007). AMS 20010719 */
9984 /* op_seq functionality is now replaced by op_opt */
9991 if (oldop && o->op_next) {
9992 oldop->op_next = o->op_next;
10000 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
10001 OP* const pop = (o->op_type == OP_PADAV) ?
10002 o->op_next : o->op_next->op_next;
10004 if (pop && pop->op_type == OP_CONST &&
10005 ((PL_op = pop->op_next)) &&
10006 pop->op_next->op_type == OP_AELEM &&
10007 !(pop->op_next->op_private &
10008 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
10009 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
10012 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
10013 no_bareword_allowed(pop);
10014 if (o->op_type == OP_GV)
10015 op_null(o->op_next);
10016 op_null(pop->op_next);
10018 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
10019 o->op_next = pop->op_next->op_next;
10020 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
10021 o->op_private = (U8)i;
10022 if (o->op_type == OP_GV) {
10025 o->op_type = OP_AELEMFAST;
10028 o->op_type = OP_AELEMFAST_LEX;
10033 if (o->op_next->op_type == OP_RV2SV) {
10034 if (!(o->op_next->op_private & OPpDEREF)) {
10035 op_null(o->op_next);
10036 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
10038 o->op_next = o->op_next->op_next;
10039 o->op_type = OP_GVSV;
10040 o->op_ppaddr = PL_ppaddr[OP_GVSV];
10043 else if (o->op_next->op_type == OP_READLINE
10044 && o->op_next->op_next->op_type == OP_CONCAT
10045 && (o->op_next->op_next->op_flags & OPf_STACKED))
10047 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
10048 o->op_type = OP_RCATLINE;
10049 o->op_flags |= OPf_STACKED;
10050 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
10051 op_null(o->op_next->op_next);
10052 op_null(o->op_next);
10062 fop = cUNOP->op_first;
10070 fop = cLOGOP->op_first;
10071 sop = fop->op_sibling;
10072 while (cLOGOP->op_other->op_type == OP_NULL)
10073 cLOGOP->op_other = cLOGOP->op_other->op_next;
10074 while (o->op_next && ( o->op_type == o->op_next->op_type
10075 || o->op_next->op_type == OP_NULL))
10076 o->op_next = o->op_next->op_next;
10077 DEFER(cLOGOP->op_other);
10081 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10083 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
10088 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
10089 while (nop && nop->op_next) {
10090 switch (nop->op_next->op_type) {
10095 lop = nop = nop->op_next;
10098 nop = nop->op_next;
10106 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
10107 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10108 cLOGOP->op_first = opt_scalarhv(fop);
10109 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
10110 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
10126 while (cLOGOP->op_other->op_type == OP_NULL)
10127 cLOGOP->op_other = cLOGOP->op_other->op_next;
10128 DEFER(cLOGOP->op_other);
10133 while (cLOOP->op_redoop->op_type == OP_NULL)
10134 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
10135 while (cLOOP->op_nextop->op_type == OP_NULL)
10136 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
10137 while (cLOOP->op_lastop->op_type == OP_NULL)
10138 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
10139 /* a while(1) loop doesn't have an op_next that escapes the
10140 * loop, so we have to explicitly follow the op_lastop to
10141 * process the rest of the code */
10142 DEFER(cLOOP->op_lastop);
10146 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10147 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10148 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10149 cPMOP->op_pmstashstartu.op_pmreplstart
10150 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
10151 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
10155 /* check that RHS of sort is a single plain array */
10156 OP *oright = cUNOPo->op_first;
10157 if (!oright || oright->op_type != OP_PUSHMARK)
10160 if (o->op_private & OPpSORT_INPLACE)
10163 /* reverse sort ... can be optimised. */
10164 if (!cUNOPo->op_sibling) {
10165 /* Nothing follows us on the list. */
10166 OP * const reverse = o->op_next;
10168 if (reverse->op_type == OP_REVERSE &&
10169 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10170 OP * const pushmark = cUNOPx(reverse)->op_first;
10171 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10172 && (cUNOPx(pushmark)->op_sibling == o)) {
10173 /* reverse -> pushmark -> sort */
10174 o->op_private |= OPpSORT_REVERSE;
10176 pushmark->op_next = oright->op_next;
10186 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10188 LISTOP *enter, *exlist;
10190 if (o->op_private & OPpSORT_INPLACE)
10193 enter = (LISTOP *) o->op_next;
10196 if (enter->op_type == OP_NULL) {
10197 enter = (LISTOP *) enter->op_next;
10201 /* for $a (...) will have OP_GV then OP_RV2GV here.
10202 for (...) just has an OP_GV. */
10203 if (enter->op_type == OP_GV) {
10204 gvop = (OP *) enter;
10205 enter = (LISTOP *) enter->op_next;
10208 if (enter->op_type == OP_RV2GV) {
10209 enter = (LISTOP *) enter->op_next;
10215 if (enter->op_type != OP_ENTERITER)
10218 iter = enter->op_next;
10219 if (!iter || iter->op_type != OP_ITER)
10222 expushmark = enter->op_first;
10223 if (!expushmark || expushmark->op_type != OP_NULL
10224 || expushmark->op_targ != OP_PUSHMARK)
10227 exlist = (LISTOP *) expushmark->op_sibling;
10228 if (!exlist || exlist->op_type != OP_NULL
10229 || exlist->op_targ != OP_LIST)
10232 if (exlist->op_last != o) {
10233 /* Mmm. Was expecting to point back to this op. */
10236 theirmark = exlist->op_first;
10237 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10240 if (theirmark->op_sibling != o) {
10241 /* There's something between the mark and the reverse, eg
10242 for (1, reverse (...))
10247 ourmark = ((LISTOP *)o)->op_first;
10248 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10251 ourlast = ((LISTOP *)o)->op_last;
10252 if (!ourlast || ourlast->op_next != o)
10255 rv2av = ourmark->op_sibling;
10256 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10257 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10258 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10259 /* We're just reversing a single array. */
10260 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10261 enter->op_flags |= OPf_STACKED;
10264 /* We don't have control over who points to theirmark, so sacrifice
10266 theirmark->op_next = ourmark->op_next;
10267 theirmark->op_flags = ourmark->op_flags;
10268 ourlast->op_next = gvop ? gvop : (OP *) enter;
10271 enter->op_private |= OPpITER_REVERSED;
10272 iter->op_private |= OPpITER_REVERSED;
10279 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10280 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10285 Perl_cpeep_t cpeep =
10286 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10288 cpeep(aTHX_ o, oldop);
10299 Perl_peep(pTHX_ register OP *o)
10305 =head1 Custom Operators
10307 =for apidoc Ao||custom_op_xop
10308 Return the XOP structure for a given custom op. This function should be
10309 considered internal to OP_NAME and the other access macros: use them instead.
10315 Perl_custom_op_xop(pTHX_ const OP *o)
10321 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10323 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10324 assert(o->op_type == OP_CUSTOM);
10326 /* This is wrong. It assumes a function pointer can be cast to IV,
10327 * which isn't guaranteed, but this is what the old custom OP code
10328 * did. In principle it should be safer to Copy the bytes of the
10329 * pointer into a PV: since the new interface is hidden behind
10330 * functions, this can be changed later if necessary. */
10331 /* Change custom_op_xop if this ever happens */
10332 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10335 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10337 /* assume noone will have just registered a desc */
10338 if (!he && PL_custom_op_names &&
10339 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10344 /* XXX does all this need to be shared mem? */
10345 Newxz(xop, 1, XOP);
10346 pv = SvPV(HeVAL(he), l);
10347 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10348 if (PL_custom_op_descs &&
10349 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10351 pv = SvPV(HeVAL(he), l);
10352 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10354 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10358 if (!he) return &xop_null;
10360 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10365 =for apidoc Ao||custom_op_register
10366 Register a custom op. See L<perlguts/"Custom Operators">.
10372 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10376 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10378 /* see the comment in custom_op_xop */
10379 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10381 if (!PL_custom_ops)
10382 PL_custom_ops = newHV();
10384 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10385 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10389 =head1 Functions in file op.c
10391 =for apidoc core_prototype
10392 This function assigns the prototype of the named core function to C<sv>, or
10393 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10394 NULL if the core function has no prototype. C<code> is a code as returned
10395 by C<keyword()>. It must be negative and unequal to -KEY_CORE.
10401 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10404 int i = 0, n = 0, seen_question = 0, defgv = 0;
10406 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10407 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10408 bool nullret = FALSE;
10410 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10412 assert (code < 0 && code != -KEY_CORE);
10414 if (!sv) sv = sv_newmortal();
10416 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10419 case KEY_and : case KEY_chop: case KEY_chomp:
10420 case KEY_cmp : case KEY_exec: case KEY_eq :
10421 case KEY_ge : case KEY_gt : case KEY_le :
10422 case KEY_lt : case KEY_ne : case KEY_or :
10423 case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
10424 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10425 case KEY_keys: retsetpvs("+", OP_KEYS);
10426 case KEY_values: retsetpvs("+", OP_VALUES);
10427 case KEY_each: retsetpvs("+", OP_EACH);
10428 case KEY_push: retsetpvs("+@", OP_PUSH);
10429 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10430 case KEY_pop: retsetpvs(";+", OP_POP);
10431 case KEY_shift: retsetpvs(";+", OP_SHIFT);
10433 retsetpvs("+;$$@", OP_SPLICE);
10434 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10436 case KEY_evalbytes:
10437 name = "entereval"; break;
10445 while (i < MAXO) { /* The slow way. */
10446 if (strEQ(name, PL_op_name[i])
10447 || strEQ(name, PL_op_desc[i]))
10449 if (nullret) { assert(opnum); *opnum = i; return NULL; }
10454 assert(0); return NULL; /* Should not happen... */
10456 defgv = PL_opargs[i] & OA_DEFGV;
10457 oa = PL_opargs[i] >> OASHIFT;
10459 if (oa & OA_OPTIONAL && !seen_question && (
10460 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
10465 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10466 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10467 /* But globs are already references (kinda) */
10468 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10472 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10473 && !scalar_mod_type(NULL, i)) {
10478 if (i == OP_LOCK) str[n++] = '&';
10482 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10483 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10484 str[n-1] = '_'; defgv = 0;
10488 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
10490 sv_setpvn(sv, str, n - 1);
10491 if (opnum) *opnum = i;
10496 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
10499 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
10502 PERL_ARGS_ASSERT_CORESUB_OP;
10506 return op_append_elem(OP_LINESEQ,
10509 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
10513 case OP_SELECT: /* which represents OP_SSELECT as well */
10518 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
10519 newSVOP(OP_CONST, 0, newSVuv(1))
10521 coresub_op(newSVuv((UV)OP_SSELECT), 0,
10523 coresub_op(coreargssv, 0, OP_SELECT)
10527 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10529 return op_append_elem(
10532 opnum == OP_WANTARRAY || opnum == OP_RUNCV
10533 ? OPpOFFBYONE << 8 : 0)
10535 case OA_BASEOP_OR_UNOP:
10536 if (opnum == OP_ENTEREVAL) {
10537 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
10538 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
10540 else o = newUNOP(opnum,0,argop);
10541 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
10544 if (is_handle_constructor(o, 1))
10545 argop->op_private |= OPpCOREARGS_DEREF1;
10549 o = convert(opnum,0,argop);
10550 if (is_handle_constructor(o, 2))
10551 argop->op_private |= OPpCOREARGS_DEREF2;
10552 if (scalar_mod_type(NULL, opnum))
10553 argop->op_private |= OPpCOREARGS_SCALARMOD;
10554 if (opnum == OP_SUBSTR) {
10555 o->op_private |= OPpMAYBE_LVSUB;
10564 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
10565 SV * const *new_const_svp)
10567 const char *hvname;
10568 bool is_const = !!CvCONST(old_cv);
10569 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
10571 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
10573 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
10575 /* They are 2 constant subroutines generated from
10576 the same constant. This probably means that
10577 they are really the "same" proxy subroutine
10578 instantiated in 2 places. Most likely this is
10579 when a constant is exported twice. Don't warn.
10582 (ckWARN(WARN_REDEFINE)
10584 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
10585 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
10586 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
10587 strEQ(hvname, "autouse"))
10591 && ckWARN_d(WARN_REDEFINE)
10592 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
10595 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10597 ? "Constant subroutine %"SVf" redefined"
10598 : "Subroutine %"SVf" redefined",
10604 /* Efficient sub that returns a constant scalar value. */
10606 const_sv_xsub(pTHX_ CV* cv)
10610 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10614 /* diag_listed_as: SKIPME */
10615 Perl_croak(aTHX_ "usage: %s::%s()",
10616 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10629 * c-indentation-style: bsd
10630 * c-basic-offset: 4
10631 * indent-tabs-mode: t
10634 * ex: set ts=8 sts=4 sw=4 noet: