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"
107 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
108 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
109 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
111 #if defined(PL_OP_SLAB_ALLOC)
113 #ifdef PERL_DEBUG_READONLY_OPS
114 # define PERL_SLAB_SIZE 4096
115 # include <sys/mman.h>
118 #ifndef PERL_SLAB_SIZE
119 #define PERL_SLAB_SIZE 2048
123 Perl_Slab_Alloc(pTHX_ size_t sz)
127 * To make incrementing use count easy PL_OpSlab is an I32 *
128 * To make inserting the link to slab PL_OpPtr is I32 **
129 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
130 * Add an overhead for pointer to slab and round up as a number of pointers
132 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
133 if ((PL_OpSpace -= sz) < 0) {
134 #ifdef PERL_DEBUG_READONLY_OPS
135 /* We need to allocate chunk by chunk so that we can control the VM
137 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
138 MAP_ANON|MAP_PRIVATE, -1, 0);
140 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
141 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
143 if(PL_OpPtr == MAP_FAILED) {
144 perror("mmap failed");
149 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
154 /* We reserve the 0'th I32 sized chunk as a use count */
155 PL_OpSlab = (I32 *) PL_OpPtr;
156 /* Reduce size by the use count word, and by the size we need.
157 * Latter is to mimic the '-=' in the if() above
159 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
160 /* Allocation pointer starts at the top.
161 Theory: because we build leaves before trunk allocating at end
162 means that at run time access is cache friendly upward
164 PL_OpPtr += PERL_SLAB_SIZE;
166 #ifdef PERL_DEBUG_READONLY_OPS
167 /* We remember this slab. */
168 /* This implementation isn't efficient, but it is simple. */
169 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
170 PL_slabs[PL_slab_count++] = PL_OpSlab;
171 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
174 assert( PL_OpSpace >= 0 );
175 /* Move the allocation pointer down */
177 assert( PL_OpPtr > (I32 **) PL_OpSlab );
178 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
179 (*PL_OpSlab)++; /* Increment use count of slab */
180 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
181 assert( *PL_OpSlab > 0 );
182 return (void *)(PL_OpPtr + 1);
185 #ifdef PERL_DEBUG_READONLY_OPS
187 Perl_pending_Slabs_to_ro(pTHX) {
188 /* Turn all the allocated op slabs read only. */
189 U32 count = PL_slab_count;
190 I32 **const slabs = PL_slabs;
192 /* Reset the array of pending OP slabs, as we're about to turn this lot
193 read only. Also, do it ahead of the loop in case the warn triggers,
194 and a warn handler has an eval */
199 /* Force a new slab for any further allocation. */
203 void *const start = slabs[count];
204 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
205 if(mprotect(start, size, PROT_READ)) {
206 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
207 start, (unsigned long) size, errno);
215 S_Slab_to_rw(pTHX_ void *op)
217 I32 * const * const ptr = (I32 **) op;
218 I32 * const slab = ptr[-1];
220 PERL_ARGS_ASSERT_SLAB_TO_RW;
222 assert( ptr-1 > (I32 **) slab );
223 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
225 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
226 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
227 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
232 Perl_op_refcnt_inc(pTHX_ OP *o)
243 Perl_op_refcnt_dec(pTHX_ OP *o)
245 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
250 # define Slab_to_rw(op)
254 Perl_Slab_Free(pTHX_ void *op)
256 I32 * const * const ptr = (I32 **) op;
257 I32 * const slab = ptr[-1];
258 PERL_ARGS_ASSERT_SLAB_FREE;
259 assert( ptr-1 > (I32 **) slab );
260 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
263 if (--(*slab) == 0) {
265 # define PerlMemShared PerlMem
268 #ifdef PERL_DEBUG_READONLY_OPS
269 U32 count = PL_slab_count;
270 /* Need to remove this slab from our list of slabs */
273 if (PL_slabs[count] == slab) {
275 /* Found it. Move the entry at the end to overwrite it. */
276 DEBUG_m(PerlIO_printf(Perl_debug_log,
277 "Deallocate %p by moving %p from %lu to %lu\n",
279 PL_slabs[PL_slab_count - 1],
280 PL_slab_count, count));
281 PL_slabs[count] = PL_slabs[--PL_slab_count];
282 /* Could realloc smaller at this point, but probably not
284 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
285 perror("munmap failed");
293 PerlMemShared_free(slab);
295 if (slab == PL_OpSlab) {
302 * In the following definition, the ", (OP*)0" is just to make the compiler
303 * think the expression is of the right type: croak actually does a Siglongjmp.
305 #define CHECKOP(type,o) \
306 ((PL_op_mask && PL_op_mask[type]) \
307 ? ( op_free((OP*)o), \
308 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
310 : PL_check[type](aTHX_ (OP*)o))
312 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
314 #define CHANGE_TYPE(o,type) \
316 o->op_type = (OPCODE)type; \
317 o->op_ppaddr = PL_ppaddr[type]; \
321 S_gv_ename(pTHX_ GV *gv)
323 SV* const tmpsv = sv_newmortal();
325 PERL_ARGS_ASSERT_GV_ENAME;
327 gv_efullname3(tmpsv, gv, NULL);
328 return SvPV_nolen_const(tmpsv);
332 S_no_fh_allowed(pTHX_ OP *o)
334 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
336 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
342 S_too_few_arguments(pTHX_ OP *o, const char *name)
344 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
346 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
351 S_too_many_arguments(pTHX_ OP *o, const char *name)
353 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
355 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
360 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
362 PERL_ARGS_ASSERT_BAD_TYPE;
364 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
365 (int)n, name, t, OP_DESC(kid)));
369 S_no_bareword_allowed(pTHX_ OP *o)
371 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
374 return; /* various ok barewords are hidden in extra OP_NULL */
375 qerror(Perl_mess(aTHX_
376 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
378 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
381 /* "register" allocation */
384 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
388 const bool is_our = (PL_parser->in_my == KEY_our);
390 PERL_ARGS_ASSERT_ALLOCMY;
392 if (flags & ~SVf_UTF8)
393 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
396 /* Until we're using the length for real, cross check that we're being
398 assert(strlen(name) == len);
400 /* complain about "my $<special_var>" etc etc */
404 ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) ||
405 (name[1] == '_' && (*name == '$' || len > 2))))
407 /* name[2] is true if strlen(name) > 2 */
408 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
409 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
410 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
411 PL_parser->in_my == KEY_state ? "state" : "my"));
413 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
414 PL_parser->in_my == KEY_state ? "state" : "my"));
418 /* allocate a spare slot and store the name in that slot */
420 off = pad_add_name_pvn(name, len,
421 (is_our ? padadd_OUR :
422 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
423 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
424 PL_parser->in_my_stash,
426 /* $_ is always in main::, even with our */
427 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
431 /* anon sub prototypes contains state vars should always be cloned,
432 * otherwise the state var would be shared between anon subs */
434 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
435 CvCLONE_on(PL_compcv);
440 /* free the body of an op without examining its contents.
441 * Always use this rather than FreeOp directly */
444 S_op_destroy(pTHX_ OP *o)
446 if (o->op_latefree) {
454 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
456 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
462 Perl_op_free(pTHX_ OP *o)
469 if (o->op_latefreed) {
476 if (o->op_private & OPpREFCOUNTED) {
487 refcnt = OpREFCNT_dec(o);
490 /* Need to find and remove any pattern match ops from the list
491 we maintain for reset(). */
492 find_and_forget_pmops(o);
502 /* Call the op_free hook if it has been set. Do it now so that it's called
503 * at the right time for refcounted ops, but still before all of the kids
507 if (o->op_flags & OPf_KIDS) {
508 register OP *kid, *nextkid;
509 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
510 nextkid = kid->op_sibling; /* Get before next freeing kid */
515 #ifdef PERL_DEBUG_READONLY_OPS
519 /* COP* is not cleared by op_clear() so that we may track line
520 * numbers etc even after null() */
521 if (type == OP_NEXTSTATE || type == OP_DBSTATE
522 || (type == OP_NULL /* the COP might have been null'ed */
523 && ((OPCODE)o->op_targ == OP_NEXTSTATE
524 || (OPCODE)o->op_targ == OP_DBSTATE))) {
529 type = (OPCODE)o->op_targ;
532 if (o->op_latefree) {
538 #ifdef DEBUG_LEAKING_SCALARS
545 Perl_op_clear(pTHX_ OP *o)
550 PERL_ARGS_ASSERT_OP_CLEAR;
553 mad_free(o->op_madprop);
558 switch (o->op_type) {
559 case OP_NULL: /* Was holding old type, if any. */
560 if (PL_madskills && o->op_targ != OP_NULL) {
561 o->op_type = (Optype)o->op_targ;
566 case OP_ENTEREVAL: /* Was holding hints. */
570 if (!(o->op_flags & OPf_REF)
571 || (PL_check[o->op_type] != Perl_ck_ftst))
578 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
583 /* It's possible during global destruction that the GV is freed
584 before the optree. Whilst the SvREFCNT_inc is happy to bump from
585 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
586 will trigger an assertion failure, because the entry to sv_clear
587 checks that the scalar is not already freed. A check of for
588 !SvIS_FREED(gv) turns out to be invalid, because during global
589 destruction the reference count can be forced down to zero
590 (with SVf_BREAK set). In which case raising to 1 and then
591 dropping to 0 triggers cleanup before it should happen. I
592 *think* that this might actually be a general, systematic,
593 weakness of the whole idea of SVf_BREAK, in that code *is*
594 allowed to raise and lower references during global destruction,
595 so any *valid* code that happens to do this during global
596 destruction might well trigger premature cleanup. */
597 bool still_valid = gv && SvREFCNT(gv);
600 SvREFCNT_inc_simple_void(gv);
602 if (cPADOPo->op_padix > 0) {
603 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
604 * may still exist on the pad */
605 pad_swipe(cPADOPo->op_padix, TRUE);
606 cPADOPo->op_padix = 0;
609 SvREFCNT_dec(cSVOPo->op_sv);
610 cSVOPo->op_sv = NULL;
613 int try_downgrade = SvREFCNT(gv) == 2;
616 gv_try_downgrade(gv);
620 case OP_METHOD_NAMED:
623 SvREFCNT_dec(cSVOPo->op_sv);
624 cSVOPo->op_sv = NULL;
627 Even if op_clear does a pad_free for the target of the op,
628 pad_free doesn't actually remove the sv that exists in the pad;
629 instead it lives on. This results in that it could be reused as
630 a target later on when the pad was reallocated.
633 pad_swipe(o->op_targ,1);
642 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
647 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
649 if (cPADOPo->op_padix > 0) {
650 pad_swipe(cPADOPo->op_padix, TRUE);
651 cPADOPo->op_padix = 0;
654 SvREFCNT_dec(cSVOPo->op_sv);
655 cSVOPo->op_sv = NULL;
659 PerlMemShared_free(cPVOPo->op_pv);
660 cPVOPo->op_pv = NULL;
664 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
668 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
669 /* No GvIN_PAD_off here, because other references may still
670 * exist on the pad */
671 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
674 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
680 forget_pmop(cPMOPo, 1);
681 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
682 /* we use the same protection as the "SAFE" version of the PM_ macros
683 * here since sv_clean_all might release some PMOPs
684 * after PL_regex_padav has been cleared
685 * and the clearing of PL_regex_padav needs to
686 * happen before sv_clean_all
689 if(PL_regex_pad) { /* We could be in destruction */
690 const IV offset = (cPMOPo)->op_pmoffset;
691 ReREFCNT_dec(PM_GETRE(cPMOPo));
692 PL_regex_pad[offset] = &PL_sv_undef;
693 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
697 ReREFCNT_dec(PM_GETRE(cPMOPo));
698 PM_SETRE(cPMOPo, NULL);
704 if (o->op_targ > 0) {
705 pad_free(o->op_targ);
711 S_cop_free(pTHX_ COP* cop)
713 PERL_ARGS_ASSERT_COP_FREE;
717 if (! specialWARN(cop->cop_warnings))
718 PerlMemShared_free(cop->cop_warnings);
719 cophh_free(CopHINTHASH_get(cop));
723 S_forget_pmop(pTHX_ PMOP *const o
729 HV * const pmstash = PmopSTASH(o);
731 PERL_ARGS_ASSERT_FORGET_PMOP;
733 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
734 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
736 PMOP **const array = (PMOP**) mg->mg_ptr;
737 U32 count = mg->mg_len / sizeof(PMOP**);
742 /* Found it. Move the entry at the end to overwrite it. */
743 array[i] = array[--count];
744 mg->mg_len = count * sizeof(PMOP**);
745 /* Could realloc smaller at this point always, but probably
746 not worth it. Probably worth free()ing if we're the
749 Safefree(mg->mg_ptr);
766 S_find_and_forget_pmops(pTHX_ OP *o)
768 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
770 if (o->op_flags & OPf_KIDS) {
771 OP *kid = cUNOPo->op_first;
773 switch (kid->op_type) {
778 forget_pmop((PMOP*)kid, 0);
780 find_and_forget_pmops(kid);
781 kid = kid->op_sibling;
787 Perl_op_null(pTHX_ OP *o)
791 PERL_ARGS_ASSERT_OP_NULL;
793 if (o->op_type == OP_NULL)
797 o->op_targ = o->op_type;
798 o->op_type = OP_NULL;
799 o->op_ppaddr = PL_ppaddr[OP_NULL];
803 Perl_op_refcnt_lock(pTHX)
811 Perl_op_refcnt_unlock(pTHX)
818 /* Contextualizers */
821 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
823 Applies a syntactic context to an op tree representing an expression.
824 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
825 or C<G_VOID> to specify the context to apply. The modified op tree
832 Perl_op_contextualize(pTHX_ OP *o, I32 context)
834 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
836 case G_SCALAR: return scalar(o);
837 case G_ARRAY: return list(o);
838 case G_VOID: return scalarvoid(o);
840 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
847 =head1 Optree Manipulation Functions
849 =for apidoc Am|OP*|op_linklist|OP *o
850 This function is the implementation of the L</LINKLIST> macro. It should
851 not be called directly.
857 Perl_op_linklist(pTHX_ OP *o)
861 PERL_ARGS_ASSERT_OP_LINKLIST;
866 /* establish postfix order */
867 first = cUNOPo->op_first;
870 o->op_next = LINKLIST(first);
873 if (kid->op_sibling) {
874 kid->op_next = LINKLIST(kid->op_sibling);
875 kid = kid->op_sibling;
889 S_scalarkids(pTHX_ OP *o)
891 if (o && o->op_flags & OPf_KIDS) {
893 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
900 S_scalarboolean(pTHX_ OP *o)
904 PERL_ARGS_ASSERT_SCALARBOOLEAN;
906 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
907 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
908 if (ckWARN(WARN_SYNTAX)) {
909 const line_t oldline = CopLINE(PL_curcop);
911 if (PL_parser && PL_parser->copline != NOLINE)
912 CopLINE_set(PL_curcop, PL_parser->copline);
913 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
914 CopLINE_set(PL_curcop, oldline);
921 Perl_scalar(pTHX_ OP *o)
926 /* assumes no premature commitment */
927 if (!o || (PL_parser && PL_parser->error_count)
928 || (o->op_flags & OPf_WANT)
929 || o->op_type == OP_RETURN)
934 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
936 switch (o->op_type) {
938 scalar(cBINOPo->op_first);
943 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
953 if (o->op_flags & OPf_KIDS) {
954 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
960 kid = cLISTOPo->op_first;
962 kid = kid->op_sibling;
965 OP *sib = kid->op_sibling;
966 if (sib && kid->op_type != OP_LEAVEWHEN)
972 PL_curcop = &PL_compiling;
977 kid = cLISTOPo->op_first;
980 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
987 Perl_scalarvoid(pTHX_ OP *o)
991 const char* useless = NULL;
992 U32 useless_is_utf8 = 0;
996 PERL_ARGS_ASSERT_SCALARVOID;
998 /* trailing mad null ops don't count as "there" for void processing */
1000 o->op_type != OP_NULL &&
1002 o->op_sibling->op_type == OP_NULL)
1005 for (sib = o->op_sibling;
1006 sib && sib->op_type == OP_NULL;
1007 sib = sib->op_sibling) ;
1013 if (o->op_type == OP_NEXTSTATE
1014 || o->op_type == OP_DBSTATE
1015 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1016 || o->op_targ == OP_DBSTATE)))
1017 PL_curcop = (COP*)o; /* for warning below */
1019 /* assumes no premature commitment */
1020 want = o->op_flags & OPf_WANT;
1021 if ((want && want != OPf_WANT_SCALAR)
1022 || (PL_parser && PL_parser->error_count)
1023 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1028 if ((o->op_private & OPpTARGET_MY)
1029 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1031 return scalar(o); /* As if inside SASSIGN */
1034 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1036 switch (o->op_type) {
1038 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1042 if (o->op_flags & OPf_STACKED)
1046 if (o->op_private == 4)
1071 case OP_AELEMFAST_LEX:
1090 case OP_GETSOCKNAME:
1091 case OP_GETPEERNAME:
1096 case OP_GETPRIORITY:
1121 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1122 /* Otherwise it's "Useless use of grep iterator" */
1123 useless = OP_DESC(o);
1127 kid = cLISTOPo->op_first;
1128 if (kid && kid->op_type == OP_PUSHRE
1130 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1132 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1134 useless = OP_DESC(o);
1138 kid = cUNOPo->op_first;
1139 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1140 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1143 useless = "negative pattern binding (!~)";
1147 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1148 useless = "non-destructive substitution (s///r)";
1152 useless = "non-destructive transliteration (tr///r)";
1159 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1160 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1161 useless = "a variable";
1166 if (cSVOPo->op_private & OPpCONST_STRICT)
1167 no_bareword_allowed(o);
1169 if (ckWARN(WARN_VOID)) {
1170 /* don't warn on optimised away booleans, eg
1171 * use constant Foo, 5; Foo || print; */
1172 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1174 /* the constants 0 and 1 are permitted as they are
1175 conventionally used as dummies in constructs like
1176 1 while some_condition_with_side_effects; */
1177 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1179 else if (SvPOK(sv)) {
1180 /* perl4's way of mixing documentation and code
1181 (before the invention of POD) was based on a
1182 trick to mix nroff and perl code. The trick was
1183 built upon these three nroff macros being used in
1184 void context. The pink camel has the details in
1185 the script wrapman near page 319. */
1186 const char * const maybe_macro = SvPVX_const(sv);
1187 if (strnEQ(maybe_macro, "di", 2) ||
1188 strnEQ(maybe_macro, "ds", 2) ||
1189 strnEQ(maybe_macro, "ig", 2))
1192 SV * const dsv = newSVpvs("");
1193 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1195 pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
1196 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
1198 useless = SvPV_nolen(msv);
1199 useless_is_utf8 = SvUTF8(msv);
1202 else if (SvOK(sv)) {
1203 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1204 "a constant (%"SVf")", sv));
1205 useless = SvPV_nolen(msv);
1208 useless = "a constant (undef)";
1211 op_null(o); /* don't execute or even remember it */
1215 o->op_type = OP_PREINC; /* pre-increment is faster */
1216 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1220 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1221 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1225 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1226 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1230 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1231 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1236 UNOP *refgen, *rv2cv;
1239 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1242 rv2gv = ((BINOP *)o)->op_last;
1243 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1246 refgen = (UNOP *)((BINOP *)o)->op_first;
1248 if (!refgen || refgen->op_type != OP_REFGEN)
1251 exlist = (LISTOP *)refgen->op_first;
1252 if (!exlist || exlist->op_type != OP_NULL
1253 || exlist->op_targ != OP_LIST)
1256 if (exlist->op_first->op_type != OP_PUSHMARK)
1259 rv2cv = (UNOP*)exlist->op_last;
1261 if (rv2cv->op_type != OP_RV2CV)
1264 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1265 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1266 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1268 o->op_private |= OPpASSIGN_CV_TO_GV;
1269 rv2gv->op_private |= OPpDONT_INIT_GV;
1270 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1282 kid = cLOGOPo->op_first;
1283 if (kid->op_type == OP_NOT
1284 && (kid->op_flags & OPf_KIDS)
1286 if (o->op_type == OP_AND) {
1288 o->op_ppaddr = PL_ppaddr[OP_OR];
1290 o->op_type = OP_AND;
1291 o->op_ppaddr = PL_ppaddr[OP_AND];
1300 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1305 if (o->op_flags & OPf_STACKED)
1312 if (!(o->op_flags & OPf_KIDS))
1323 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1333 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1334 newSVpvn_flags(useless, strlen(useless),
1335 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1340 S_listkids(pTHX_ OP *o)
1342 if (o && o->op_flags & OPf_KIDS) {
1344 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1351 Perl_list(pTHX_ OP *o)
1356 /* assumes no premature commitment */
1357 if (!o || (o->op_flags & OPf_WANT)
1358 || (PL_parser && PL_parser->error_count)
1359 || o->op_type == OP_RETURN)
1364 if ((o->op_private & OPpTARGET_MY)
1365 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1367 return o; /* As if inside SASSIGN */
1370 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1372 switch (o->op_type) {
1375 list(cBINOPo->op_first);
1380 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1388 if (!(o->op_flags & OPf_KIDS))
1390 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1391 list(cBINOPo->op_first);
1392 return gen_constant_list(o);
1399 kid = cLISTOPo->op_first;
1401 kid = kid->op_sibling;
1404 OP *sib = kid->op_sibling;
1405 if (sib && kid->op_type != OP_LEAVEWHEN)
1411 PL_curcop = &PL_compiling;
1415 kid = cLISTOPo->op_first;
1422 S_scalarseq(pTHX_ OP *o)
1426 const OPCODE type = o->op_type;
1428 if (type == OP_LINESEQ || type == OP_SCOPE ||
1429 type == OP_LEAVE || type == OP_LEAVETRY)
1432 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1433 if (kid->op_sibling) {
1437 PL_curcop = &PL_compiling;
1439 o->op_flags &= ~OPf_PARENS;
1440 if (PL_hints & HINT_BLOCK_SCOPE)
1441 o->op_flags |= OPf_PARENS;
1444 o = newOP(OP_STUB, 0);
1449 S_modkids(pTHX_ OP *o, I32 type)
1451 if (o && o->op_flags & OPf_KIDS) {
1453 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1454 op_lvalue(kid, type);
1460 =for apidoc finalize_optree
1462 This function finalizes the optree. Should be called directly after
1463 the complete optree is built. It does some additional
1464 checking which can't be done in the normal ck_xxx functions and makes
1465 the tree thread-safe.
1470 Perl_finalize_optree(pTHX_ OP* o)
1472 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1475 SAVEVPTR(PL_curcop);
1483 S_finalize_op(pTHX_ OP* o)
1485 PERL_ARGS_ASSERT_FINALIZE_OP;
1487 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1489 /* Make sure mad ops are also thread-safe */
1490 MADPROP *mp = o->op_madprop;
1492 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1493 OP *prop_op = (OP *) mp->mad_val;
1494 /* We only need "Relocate sv to the pad for thread safety.", but this
1495 easiest way to make sure it traverses everything */
1496 if (prop_op->op_type == OP_CONST)
1497 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1498 finalize_op(prop_op);
1505 switch (o->op_type) {
1508 PL_curcop = ((COP*)o); /* for warnings */
1512 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1513 && ckWARN(WARN_SYNTAX))
1515 if (o->op_sibling->op_sibling) {
1516 const OPCODE type = o->op_sibling->op_sibling->op_type;
1517 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1518 const line_t oldline = CopLINE(PL_curcop);
1519 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1520 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1521 "Statement unlikely to be reached");
1522 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1523 "\t(Maybe you meant system() when you said exec()?)\n");
1524 CopLINE_set(PL_curcop, oldline);
1531 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1532 GV * const gv = cGVOPo_gv;
1533 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1534 /* XXX could check prototype here instead of just carping */
1535 SV * const sv = sv_newmortal();
1536 gv_efullname3(sv, gv, NULL);
1537 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1538 "%"SVf"() called too early to check prototype",
1545 if (cSVOPo->op_private & OPpCONST_STRICT)
1546 no_bareword_allowed(o);
1550 case OP_METHOD_NAMED:
1551 /* Relocate sv to the pad for thread safety.
1552 * Despite being a "constant", the SV is written to,
1553 * for reference counts, sv_upgrade() etc. */
1554 if (cSVOPo->op_sv) {
1555 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1556 if (o->op_type != OP_METHOD_NAMED &&
1557 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1559 /* If op_sv is already a PADTMP/MY then it is being used by
1560 * some pad, so make a copy. */
1561 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1562 SvREADONLY_on(PAD_SVl(ix));
1563 SvREFCNT_dec(cSVOPo->op_sv);
1565 else if (o->op_type != OP_METHOD_NAMED
1566 && cSVOPo->op_sv == &PL_sv_undef) {
1567 /* PL_sv_undef is hack - it's unsafe to store it in the
1568 AV that is the pad, because av_fetch treats values of
1569 PL_sv_undef as a "free" AV entry and will merrily
1570 replace them with a new SV, causing pad_alloc to think
1571 that this pad slot is free. (When, clearly, it is not)
1573 SvOK_off(PAD_SVl(ix));
1574 SvPADTMP_on(PAD_SVl(ix));
1575 SvREADONLY_on(PAD_SVl(ix));
1578 SvREFCNT_dec(PAD_SVl(ix));
1579 SvPADTMP_on(cSVOPo->op_sv);
1580 PAD_SETSV(ix, cSVOPo->op_sv);
1581 /* XXX I don't know how this isn't readonly already. */
1582 SvREADONLY_on(PAD_SVl(ix));
1584 cSVOPo->op_sv = NULL;
1595 const char *key = NULL;
1598 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1601 /* Make the CONST have a shared SV */
1602 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1603 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1604 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1605 key = SvPV_const(sv, keylen);
1606 lexname = newSVpvn_share(key,
1607 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1613 if ((o->op_private & (OPpLVAL_INTRO)))
1616 rop = (UNOP*)((BINOP*)o)->op_first;
1617 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1619 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1620 if (!SvPAD_TYPED(lexname))
1622 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1623 if (!fields || !GvHV(*fields))
1625 key = SvPV_const(*svp, keylen);
1626 if (!hv_fetch(GvHV(*fields), key,
1627 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1628 Perl_croak(aTHX_ "No such class field \"%s\" "
1629 "in variable %s of type %s",
1630 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
1642 SVOP *first_key_op, *key_op;
1644 if ((o->op_private & (OPpLVAL_INTRO))
1645 /* I bet there's always a pushmark... */
1646 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1647 /* hmmm, no optimization if list contains only one key. */
1649 rop = (UNOP*)((LISTOP*)o)->op_last;
1650 if (rop->op_type != OP_RV2HV)
1652 if (rop->op_first->op_type == OP_PADSV)
1653 /* @$hash{qw(keys here)} */
1654 rop = (UNOP*)rop->op_first;
1656 /* @{$hash}{qw(keys here)} */
1657 if (rop->op_first->op_type == OP_SCOPE
1658 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1660 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1666 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1667 if (!SvPAD_TYPED(lexname))
1669 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1670 if (!fields || !GvHV(*fields))
1672 /* Again guessing that the pushmark can be jumped over.... */
1673 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1674 ->op_first->op_sibling;
1675 for (key_op = first_key_op; key_op;
1676 key_op = (SVOP*)key_op->op_sibling) {
1677 if (key_op->op_type != OP_CONST)
1679 svp = cSVOPx_svp(key_op);
1680 key = SvPV_const(*svp, keylen);
1681 if (!hv_fetch(GvHV(*fields), key,
1682 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1683 Perl_croak(aTHX_ "No such class field \"%s\" "
1684 "in variable %s of type %s",
1685 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
1691 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1692 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1699 if (o->op_flags & OPf_KIDS) {
1701 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1707 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1709 Propagate lvalue ("modifiable") context to an op and its children.
1710 I<type> represents the context type, roughly based on the type of op that
1711 would do the modifying, although C<local()> is represented by OP_NULL,
1712 because it has no op type of its own (it is signalled by a flag on
1715 This function detects things that can't be modified, such as C<$x+1>, and
1716 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1717 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1719 It also flags things that need to behave specially in an lvalue context,
1720 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1726 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1730 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1733 if (!o || (PL_parser && PL_parser->error_count))
1736 if ((o->op_private & OPpTARGET_MY)
1737 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1742 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1744 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1746 switch (o->op_type) {
1752 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1756 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1757 !(o->op_flags & OPf_STACKED)) {
1758 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1759 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1760 poses, so we need it clear. */
1761 o->op_private &= ~1;
1762 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1763 assert(cUNOPo->op_first->op_type == OP_NULL);
1764 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1767 else { /* lvalue subroutine call */
1768 o->op_private |= OPpLVAL_INTRO
1769 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1770 PL_modcount = RETURN_UNLIMITED_NUMBER;
1771 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1772 /* Potential lvalue context: */
1773 o->op_private |= OPpENTERSUB_INARGS;
1776 else { /* Compile-time error message: */
1777 OP *kid = cUNOPo->op_first;
1780 if (kid->op_type != OP_PUSHMARK) {
1781 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1783 "panic: unexpected lvalue entersub "
1784 "args: type/targ %ld:%"UVuf,
1785 (long)kid->op_type, (UV)kid->op_targ);
1786 kid = kLISTOP->op_first;
1788 while (kid->op_sibling)
1789 kid = kid->op_sibling;
1790 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1791 break; /* Postpone until runtime */
1794 kid = kUNOP->op_first;
1795 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1796 kid = kUNOP->op_first;
1797 if (kid->op_type == OP_NULL)
1799 "Unexpected constant lvalue entersub "
1800 "entry via type/targ %ld:%"UVuf,
1801 (long)kid->op_type, (UV)kid->op_targ);
1802 if (kid->op_type != OP_GV) {
1806 cv = GvCV(kGVOP_gv);
1816 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1817 /* grep, foreach, subcalls, refgen */
1818 if (type == OP_GREPSTART || type == OP_ENTERSUB
1819 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1821 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1822 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1824 : (o->op_type == OP_ENTERSUB
1825 ? "non-lvalue subroutine call"
1827 type ? PL_op_desc[type] : "local"));
1841 case OP_RIGHT_SHIFT:
1850 if (!(o->op_flags & OPf_STACKED))
1857 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1858 op_lvalue(kid, type);
1863 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1864 PL_modcount = RETURN_UNLIMITED_NUMBER;
1865 return o; /* Treat \(@foo) like ordinary list. */
1869 if (scalar_mod_type(o, type))
1871 ref(cUNOPo->op_first, o->op_type);
1875 if (type == OP_LEAVESUBLV)
1876 o->op_private |= OPpMAYBE_LVSUB;
1882 PL_modcount = RETURN_UNLIMITED_NUMBER;
1885 PL_hints |= HINT_BLOCK_SCOPE;
1886 if (type == OP_LEAVESUBLV)
1887 o->op_private |= OPpMAYBE_LVSUB;
1891 ref(cUNOPo->op_first, o->op_type);
1895 PL_hints |= HINT_BLOCK_SCOPE;
1904 case OP_AELEMFAST_LEX:
1911 PL_modcount = RETURN_UNLIMITED_NUMBER;
1912 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1913 return o; /* Treat \(@foo) like ordinary list. */
1914 if (scalar_mod_type(o, type))
1916 if (type == OP_LEAVESUBLV)
1917 o->op_private |= OPpMAYBE_LVSUB;
1921 if (!type) /* local() */
1922 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1923 PAD_COMPNAME_SV(o->op_targ));
1932 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1936 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1942 if (type == OP_LEAVESUBLV)
1943 o->op_private |= OPpMAYBE_LVSUB;
1944 pad_free(o->op_targ);
1945 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1946 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1947 if (o->op_flags & OPf_KIDS)
1948 op_lvalue(cBINOPo->op_first->op_sibling, type);
1953 ref(cBINOPo->op_first, o->op_type);
1954 if (type == OP_ENTERSUB &&
1955 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1956 o->op_private |= OPpLVAL_DEFER;
1957 if (type == OP_LEAVESUBLV)
1958 o->op_private |= OPpMAYBE_LVSUB;
1968 if (o->op_flags & OPf_KIDS)
1969 op_lvalue(cLISTOPo->op_last, type);
1974 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1976 else if (!(o->op_flags & OPf_KIDS))
1978 if (o->op_targ != OP_LIST) {
1979 op_lvalue(cBINOPo->op_first, type);
1985 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1986 /* elements might be in void context because the list is
1987 in scalar context or because they are attribute sub calls */
1988 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
1989 op_lvalue(kid, type);
1993 if (type != OP_LEAVESUBLV)
1995 break; /* op_lvalue()ing was handled by ck_return() */
1998 /* [20011101.069] File test operators interpret OPf_REF to mean that
1999 their argument is a filehandle; thus \stat(".") should not set
2001 if (type == OP_REFGEN &&
2002 PL_check[o->op_type] == Perl_ck_ftst)
2005 if (type != OP_LEAVESUBLV)
2006 o->op_flags |= OPf_MOD;
2008 if (type == OP_AASSIGN || type == OP_SASSIGN)
2009 o->op_flags |= OPf_SPECIAL|OPf_REF;
2010 else if (!type) { /* local() */
2013 o->op_private |= OPpLVAL_INTRO;
2014 o->op_flags &= ~OPf_SPECIAL;
2015 PL_hints |= HINT_BLOCK_SCOPE;
2020 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2021 "Useless localization of %s", OP_DESC(o));
2024 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2025 && type != OP_LEAVESUBLV)
2026 o->op_flags |= OPf_REF;
2031 S_scalar_mod_type(const OP *o, I32 type)
2033 assert(o || type != OP_SASSIGN);
2037 if (o->op_type == OP_RV2GV)
2061 case OP_RIGHT_SHIFT:
2082 S_is_handle_constructor(const OP *o, I32 numargs)
2084 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2086 switch (o->op_type) {
2094 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2107 S_refkids(pTHX_ OP *o, I32 type)
2109 if (o && o->op_flags & OPf_KIDS) {
2111 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2118 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2123 PERL_ARGS_ASSERT_DOREF;
2125 if (!o || (PL_parser && PL_parser->error_count))
2128 switch (o->op_type) {
2130 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2131 !(o->op_flags & OPf_STACKED)) {
2132 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2133 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2134 assert(cUNOPo->op_first->op_type == OP_NULL);
2135 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2136 o->op_flags |= OPf_SPECIAL;
2137 o->op_private &= ~1;
2139 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2140 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2141 : type == OP_RV2HV ? OPpDEREF_HV
2143 o->op_flags |= OPf_MOD;
2149 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2150 doref(kid, type, set_op_ref);
2153 if (type == OP_DEFINED)
2154 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2155 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2158 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2159 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2160 : type == OP_RV2HV ? OPpDEREF_HV
2162 o->op_flags |= OPf_MOD;
2169 o->op_flags |= OPf_REF;
2172 if (type == OP_DEFINED)
2173 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2174 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2180 o->op_flags |= OPf_REF;
2185 if (!(o->op_flags & OPf_KIDS))
2187 doref(cBINOPo->op_first, type, set_op_ref);
2191 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2192 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2193 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2194 : type == OP_RV2HV ? OPpDEREF_HV
2196 o->op_flags |= OPf_MOD;
2206 if (!(o->op_flags & OPf_KIDS))
2208 doref(cLISTOPo->op_last, type, set_op_ref);
2218 S_dup_attrlist(pTHX_ OP *o)
2223 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2225 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2226 * where the first kid is OP_PUSHMARK and the remaining ones
2227 * are OP_CONST. We need to push the OP_CONST values.
2229 if (o->op_type == OP_CONST)
2230 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2232 else if (o->op_type == OP_NULL)
2236 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2238 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2239 if (o->op_type == OP_CONST)
2240 rop = op_append_elem(OP_LIST, rop,
2241 newSVOP(OP_CONST, o->op_flags,
2242 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2249 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2254 PERL_ARGS_ASSERT_APPLY_ATTRS;
2256 /* fake up C<use attributes $pkg,$rv,@attrs> */
2257 ENTER; /* need to protect against side-effects of 'use' */
2258 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2260 #define ATTRSMODULE "attributes"
2261 #define ATTRSMODULE_PM "attributes.pm"
2264 /* Don't force the C<use> if we don't need it. */
2265 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2266 if (svp && *svp != &PL_sv_undef)
2267 NOOP; /* already in %INC */
2269 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2270 newSVpvs(ATTRSMODULE), NULL);
2273 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2274 newSVpvs(ATTRSMODULE),
2276 op_prepend_elem(OP_LIST,
2277 newSVOP(OP_CONST, 0, stashsv),
2278 op_prepend_elem(OP_LIST,
2279 newSVOP(OP_CONST, 0,
2281 dup_attrlist(attrs))));
2287 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2290 OP *pack, *imop, *arg;
2293 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2298 assert(target->op_type == OP_PADSV ||
2299 target->op_type == OP_PADHV ||
2300 target->op_type == OP_PADAV);
2302 /* Ensure that attributes.pm is loaded. */
2303 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2305 /* Need package name for method call. */
2306 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2308 /* Build up the real arg-list. */
2309 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2311 arg = newOP(OP_PADSV, 0);
2312 arg->op_targ = target->op_targ;
2313 arg = op_prepend_elem(OP_LIST,
2314 newSVOP(OP_CONST, 0, stashsv),
2315 op_prepend_elem(OP_LIST,
2316 newUNOP(OP_REFGEN, 0,
2317 op_lvalue(arg, OP_REFGEN)),
2318 dup_attrlist(attrs)));
2320 /* Fake up a method call to import */
2321 meth = newSVpvs_share("import");
2322 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2323 op_append_elem(OP_LIST,
2324 op_prepend_elem(OP_LIST, pack, list(arg)),
2325 newSVOP(OP_METHOD_NAMED, 0, meth)));
2327 /* Combine the ops. */
2328 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2332 =notfor apidoc apply_attrs_string
2334 Attempts to apply a list of attributes specified by the C<attrstr> and
2335 C<len> arguments to the subroutine identified by the C<cv> argument which
2336 is expected to be associated with the package identified by the C<stashpv>
2337 argument (see L<attributes>). It gets this wrong, though, in that it
2338 does not correctly identify the boundaries of the individual attribute
2339 specifications within C<attrstr>. This is not really intended for the
2340 public API, but has to be listed here for systems such as AIX which
2341 need an explicit export list for symbols. (It's called from XS code
2342 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2343 to respect attribute syntax properly would be welcome.
2349 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2350 const char *attrstr, STRLEN len)
2354 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2357 len = strlen(attrstr);
2361 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2363 const char * const sstr = attrstr;
2364 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2365 attrs = op_append_elem(OP_LIST, attrs,
2366 newSVOP(OP_CONST, 0,
2367 newSVpvn(sstr, attrstr-sstr)));
2371 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2372 newSVpvs(ATTRSMODULE),
2373 NULL, op_prepend_elem(OP_LIST,
2374 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2375 op_prepend_elem(OP_LIST,
2376 newSVOP(OP_CONST, 0,
2377 newRV(MUTABLE_SV(cv))),
2382 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2386 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2388 PERL_ARGS_ASSERT_MY_KID;
2390 if (!o || (PL_parser && PL_parser->error_count))
2394 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2395 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2399 if (type == OP_LIST) {
2401 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2402 my_kid(kid, attrs, imopsp);
2404 } else if (type == OP_UNDEF
2410 } else if (type == OP_RV2SV || /* "our" declaration */
2412 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2413 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2414 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2416 PL_parser->in_my == KEY_our
2418 : PL_parser->in_my == KEY_state ? "state" : "my"));
2420 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2421 PL_parser->in_my = FALSE;
2422 PL_parser->in_my_stash = NULL;
2423 apply_attrs(GvSTASH(gv),
2424 (type == OP_RV2SV ? GvSV(gv) :
2425 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2426 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2429 o->op_private |= OPpOUR_INTRO;
2432 else if (type != OP_PADSV &&
2435 type != OP_PUSHMARK)
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"));
2444 else if (attrs && type != OP_PUSHMARK) {
2447 PL_parser->in_my = FALSE;
2448 PL_parser->in_my_stash = NULL;
2450 /* check for C<my Dog $spot> when deciding package */
2451 stash = PAD_COMPNAME_TYPE(o->op_targ);
2453 stash = PL_curstash;
2454 apply_attrs_my(stash, o, attrs, imopsp);
2456 o->op_flags |= OPf_MOD;
2457 o->op_private |= OPpLVAL_INTRO;
2459 o->op_private |= OPpPAD_STATE;
2464 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2468 int maybe_scalar = 0;
2470 PERL_ARGS_ASSERT_MY_ATTRS;
2472 /* [perl #17376]: this appears to be premature, and results in code such as
2473 C< our(%x); > executing in list mode rather than void mode */
2475 if (o->op_flags & OPf_PARENS)
2485 o = my_kid(o, attrs, &rops);
2487 if (maybe_scalar && o->op_type == OP_PADSV) {
2488 o = scalar(op_append_list(OP_LIST, rops, o));
2489 o->op_private |= OPpLVAL_INTRO;
2492 /* The listop in rops might have a pushmark at the beginning,
2493 which will mess up list assignment. */
2494 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2495 if (rops->op_type == OP_LIST &&
2496 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2498 OP * const pushmark = lrops->op_first;
2499 lrops->op_first = pushmark->op_sibling;
2502 o = op_append_list(OP_LIST, o, rops);
2505 PL_parser->in_my = FALSE;
2506 PL_parser->in_my_stash = NULL;
2511 Perl_sawparens(pTHX_ OP *o)
2513 PERL_UNUSED_CONTEXT;
2515 o->op_flags |= OPf_PARENS;
2520 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2524 const OPCODE ltype = left->op_type;
2525 const OPCODE rtype = right->op_type;
2527 PERL_ARGS_ASSERT_BIND_MATCH;
2529 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2530 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2532 const char * const desc
2534 rtype == OP_SUBST || rtype == OP_TRANS
2535 || rtype == OP_TRANSR
2537 ? (int)rtype : OP_MATCH];
2538 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2541 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2542 ? cUNOPx(left)->op_first->op_type == OP_GV
2543 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2544 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2547 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2550 Perl_warner(aTHX_ packWARN(WARN_MISC),
2551 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2554 const char * const sample = (isary
2555 ? "@array" : "%hash");
2556 Perl_warner(aTHX_ packWARN(WARN_MISC),
2557 "Applying %s to %s will act on scalar(%s)",
2558 desc, sample, sample);
2562 if (rtype == OP_CONST &&
2563 cSVOPx(right)->op_private & OPpCONST_BARE &&
2564 cSVOPx(right)->op_private & OPpCONST_STRICT)
2566 no_bareword_allowed(right);
2569 /* !~ doesn't make sense with /r, so error on it for now */
2570 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2572 yyerror("Using !~ with s///r doesn't make sense");
2573 if (rtype == OP_TRANSR && type == OP_NOT)
2574 yyerror("Using !~ with tr///r doesn't make sense");
2576 ismatchop = (rtype == OP_MATCH ||
2577 rtype == OP_SUBST ||
2578 rtype == OP_TRANS || rtype == OP_TRANSR)
2579 && !(right->op_flags & OPf_SPECIAL);
2580 if (ismatchop && right->op_private & OPpTARGET_MY) {
2582 right->op_private &= ~OPpTARGET_MY;
2584 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2587 right->op_flags |= OPf_STACKED;
2588 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2589 ! (rtype == OP_TRANS &&
2590 right->op_private & OPpTRANS_IDENTICAL) &&
2591 ! (rtype == OP_SUBST &&
2592 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2593 newleft = op_lvalue(left, rtype);
2596 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2597 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2599 o = op_prepend_elem(rtype, scalar(newleft), right);
2601 return newUNOP(OP_NOT, 0, scalar(o));
2605 return bind_match(type, left,
2606 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2610 Perl_invert(pTHX_ OP *o)
2614 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2618 =for apidoc Amx|OP *|op_scope|OP *o
2620 Wraps up an op tree with some additional ops so that at runtime a dynamic
2621 scope will be created. The original ops run in the new dynamic scope,
2622 and then, provided that they exit normally, the scope will be unwound.
2623 The additional ops used to create and unwind the dynamic scope will
2624 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2625 instead if the ops are simple enough to not need the full dynamic scope
2632 Perl_op_scope(pTHX_ OP *o)
2636 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2637 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2638 o->op_type = OP_LEAVE;
2639 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2641 else if (o->op_type == OP_LINESEQ) {
2643 o->op_type = OP_SCOPE;
2644 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2645 kid = ((LISTOP*)o)->op_first;
2646 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2649 /* The following deals with things like 'do {1 for 1}' */
2650 kid = kid->op_sibling;
2652 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2657 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2663 Perl_block_start(pTHX_ int full)
2666 const int retval = PL_savestack_ix;
2668 pad_block_start(full);
2670 PL_hints &= ~HINT_BLOCK_SCOPE;
2671 SAVECOMPILEWARNINGS();
2672 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2674 CALL_BLOCK_HOOKS(bhk_start, full);
2680 Perl_block_end(pTHX_ I32 floor, OP *seq)
2683 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2684 OP* retval = scalarseq(seq);
2686 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2689 CopHINTS_set(&PL_compiling, PL_hints);
2691 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2694 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2700 =head1 Compile-time scope hooks
2702 =for apidoc Aox||blockhook_register
2704 Register a set of hooks to be called when the Perl lexical scope changes
2705 at compile time. See L<perlguts/"Compile-time scope hooks">.
2711 Perl_blockhook_register(pTHX_ BHK *hk)
2713 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2715 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2722 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2723 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2724 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2727 OP * const o = newOP(OP_PADSV, 0);
2728 o->op_targ = offset;
2734 Perl_newPROG(pTHX_ OP *o)
2738 PERL_ARGS_ASSERT_NEWPROG;
2744 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2745 ((PL_in_eval & EVAL_KEEPERR)
2746 ? OPf_SPECIAL : 0), o);
2748 cx = &cxstack[cxstack_ix];
2749 assert(CxTYPE(cx) == CXt_EVAL);
2751 if ((cx->blk_gimme & G_WANT) == G_VOID)
2752 scalarvoid(PL_eval_root);
2753 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2756 scalar(PL_eval_root);
2758 /* don't use LINKLIST, since PL_eval_root might indirect through
2759 * a rather expensive function call and LINKLIST evaluates its
2760 * argument more than once */
2761 PL_eval_start = op_linklist(PL_eval_root);
2762 PL_eval_root->op_private |= OPpREFCOUNTED;
2763 OpREFCNT_set(PL_eval_root, 1);
2764 PL_eval_root->op_next = 0;
2765 CALL_PEEP(PL_eval_start);
2766 finalize_optree(PL_eval_root);
2770 if (o->op_type == OP_STUB) {
2771 PL_comppad_name = 0;
2773 S_op_destroy(aTHX_ o);
2776 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2777 PL_curcop = &PL_compiling;
2778 PL_main_start = LINKLIST(PL_main_root);
2779 PL_main_root->op_private |= OPpREFCOUNTED;
2780 OpREFCNT_set(PL_main_root, 1);
2781 PL_main_root->op_next = 0;
2782 CALL_PEEP(PL_main_start);
2783 finalize_optree(PL_main_root);
2786 /* Register with debugger */
2788 CV * const cv = get_cvs("DB::postponed", 0);
2792 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2794 call_sv(MUTABLE_SV(cv), G_DISCARD);
2801 Perl_localize(pTHX_ OP *o, I32 lex)
2805 PERL_ARGS_ASSERT_LOCALIZE;
2807 if (o->op_flags & OPf_PARENS)
2808 /* [perl #17376]: this appears to be premature, and results in code such as
2809 C< our(%x); > executing in list mode rather than void mode */
2816 if ( PL_parser->bufptr > PL_parser->oldbufptr
2817 && PL_parser->bufptr[-1] == ','
2818 && ckWARN(WARN_PARENTHESIS))
2820 char *s = PL_parser->bufptr;
2823 /* some heuristics to detect a potential error */
2824 while (*s && (strchr(", \t\n", *s)))
2828 if (*s && strchr("@$%*", *s) && *++s
2829 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2832 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2834 while (*s && (strchr(", \t\n", *s)))
2840 if (sigil && (*s == ';' || *s == '=')) {
2841 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2842 "Parentheses missing around \"%s\" list",
2844 ? (PL_parser->in_my == KEY_our
2846 : PL_parser->in_my == KEY_state
2856 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2857 PL_parser->in_my = FALSE;
2858 PL_parser->in_my_stash = NULL;
2863 Perl_jmaybe(pTHX_ OP *o)
2865 PERL_ARGS_ASSERT_JMAYBE;
2867 if (o->op_type == OP_LIST) {
2869 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2870 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2875 PERL_STATIC_INLINE OP *
2876 S_op_std_init(pTHX_ OP *o)
2878 I32 type = o->op_type;
2880 PERL_ARGS_ASSERT_OP_STD_INIT;
2882 if (PL_opargs[type] & OA_RETSCALAR)
2884 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2885 o->op_targ = pad_alloc(type, SVs_PADTMP);
2890 PERL_STATIC_INLINE OP *
2891 S_op_integerize(pTHX_ OP *o)
2893 I32 type = o->op_type;
2895 PERL_ARGS_ASSERT_OP_INTEGERIZE;
2897 /* integerize op, unless it happens to be C<-foo>.
2898 * XXX should pp_i_negate() do magic string negation instead? */
2899 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2900 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2901 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2904 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2907 if (type == OP_NEGATE)
2908 /* XXX might want a ck_negate() for this */
2909 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2915 S_fold_constants(pTHX_ register OP *o)
2918 register OP * VOL curop;
2920 VOL I32 type = o->op_type;
2925 SV * const oldwarnhook = PL_warnhook;
2926 SV * const olddiehook = PL_diehook;
2930 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2932 if (!(PL_opargs[type] & OA_FOLDCONST))
2946 /* XXX what about the numeric ops? */
2947 if (IN_LOCALE_COMPILETIME)
2952 if (PL_parser && PL_parser->error_count)
2953 goto nope; /* Don't try to run w/ errors */
2955 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2956 const OPCODE type = curop->op_type;
2957 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2959 type != OP_SCALAR &&
2961 type != OP_PUSHMARK)
2967 curop = LINKLIST(o);
2968 old_next = o->op_next;
2972 oldscope = PL_scopestack_ix;
2973 create_eval_scope(G_FAKINGEVAL);
2975 /* Verify that we don't need to save it: */
2976 assert(PL_curcop == &PL_compiling);
2977 StructCopy(&PL_compiling, ¬_compiling, COP);
2978 PL_curcop = ¬_compiling;
2979 /* The above ensures that we run with all the correct hints of the
2980 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2981 assert(IN_PERL_RUNTIME);
2982 PL_warnhook = PERL_WARNHOOK_FATAL;
2989 sv = *(PL_stack_sp--);
2990 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2992 /* Can't simply swipe the SV from the pad, because that relies on
2993 the op being freed "real soon now". Under MAD, this doesn't
2994 happen (see the #ifdef below). */
2997 pad_swipe(o->op_targ, FALSE);
3000 else if (SvTEMP(sv)) { /* grab mortal temp? */
3001 SvREFCNT_inc_simple_void(sv);
3006 /* Something tried to die. Abandon constant folding. */
3007 /* Pretend the error never happened. */
3009 o->op_next = old_next;
3013 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3014 PL_warnhook = oldwarnhook;
3015 PL_diehook = olddiehook;
3016 /* XXX note that this croak may fail as we've already blown away
3017 * the stack - eg any nested evals */
3018 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3021 PL_warnhook = oldwarnhook;
3022 PL_diehook = olddiehook;
3023 PL_curcop = &PL_compiling;
3025 if (PL_scopestack_ix > oldscope)
3026 delete_eval_scope();
3035 if (type == OP_RV2GV)
3036 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3038 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3039 op_getmad(o,newop,'f');
3047 S_gen_constant_list(pTHX_ register OP *o)
3051 const I32 oldtmps_floor = PL_tmps_floor;
3054 if (PL_parser && PL_parser->error_count)
3055 return o; /* Don't attempt to run with errors */
3057 PL_op = curop = LINKLIST(o);
3060 Perl_pp_pushmark(aTHX);
3063 assert (!(curop->op_flags & OPf_SPECIAL));
3064 assert(curop->op_type == OP_RANGE);
3065 Perl_pp_anonlist(aTHX);
3066 PL_tmps_floor = oldtmps_floor;
3068 o->op_type = OP_RV2AV;
3069 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3070 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3071 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3072 o->op_opt = 0; /* needs to be revisited in rpeep() */
3073 curop = ((UNOP*)o)->op_first;
3074 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3076 op_getmad(curop,o,'O');
3085 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3088 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3089 if (!o || o->op_type != OP_LIST)
3090 o = newLISTOP(OP_LIST, 0, o, NULL);
3092 o->op_flags &= ~OPf_WANT;
3094 if (!(PL_opargs[type] & OA_MARK))
3095 op_null(cLISTOPo->op_first);
3097 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3098 if (kid2 && kid2->op_type == OP_COREARGS) {
3099 op_null(cLISTOPo->op_first);
3100 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3104 o->op_type = (OPCODE)type;
3105 o->op_ppaddr = PL_ppaddr[type];
3106 o->op_flags |= flags;
3108 o = CHECKOP(type, o);
3109 if (o->op_type != (unsigned)type)
3112 return fold_constants(op_integerize(op_std_init(o)));
3116 =head1 Optree Manipulation Functions
3119 /* List constructors */
3122 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3124 Append an item to the list of ops contained directly within a list-type
3125 op, returning the lengthened list. I<first> is the list-type op,
3126 and I<last> is the op to append to the list. I<optype> specifies the
3127 intended opcode for the list. If I<first> is not already a list of the
3128 right type, it will be upgraded into one. If either I<first> or I<last>
3129 is null, the other is returned unchanged.
3135 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3143 if (first->op_type != (unsigned)type
3144 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3146 return newLISTOP(type, 0, first, last);
3149 if (first->op_flags & OPf_KIDS)
3150 ((LISTOP*)first)->op_last->op_sibling = last;
3152 first->op_flags |= OPf_KIDS;
3153 ((LISTOP*)first)->op_first = last;
3155 ((LISTOP*)first)->op_last = last;
3160 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3162 Concatenate the lists of ops contained directly within two list-type ops,
3163 returning the combined list. I<first> and I<last> are the list-type ops
3164 to concatenate. I<optype> specifies the intended opcode for the list.
3165 If either I<first> or I<last> is not already a list of the right type,
3166 it will be upgraded into one. If either I<first> or I<last> is null,
3167 the other is returned unchanged.
3173 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3181 if (first->op_type != (unsigned)type)
3182 return op_prepend_elem(type, first, last);
3184 if (last->op_type != (unsigned)type)
3185 return op_append_elem(type, first, last);
3187 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3188 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3189 first->op_flags |= (last->op_flags & OPf_KIDS);
3192 if (((LISTOP*)last)->op_first && first->op_madprop) {
3193 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3195 while (mp->mad_next)
3197 mp->mad_next = first->op_madprop;
3200 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3203 first->op_madprop = last->op_madprop;
3204 last->op_madprop = 0;
3207 S_op_destroy(aTHX_ last);
3213 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3215 Prepend an item to the list of ops contained directly within a list-type
3216 op, returning the lengthened list. I<first> is the op to prepend to the
3217 list, and I<last> is the list-type op. I<optype> specifies the intended
3218 opcode for the list. If I<last> is not already a list of the right type,
3219 it will be upgraded into one. If either I<first> or I<last> is null,
3220 the other is returned unchanged.
3226 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3234 if (last->op_type == (unsigned)type) {
3235 if (type == OP_LIST) { /* already a PUSHMARK there */
3236 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3237 ((LISTOP*)last)->op_first->op_sibling = first;
3238 if (!(first->op_flags & OPf_PARENS))
3239 last->op_flags &= ~OPf_PARENS;
3242 if (!(last->op_flags & OPf_KIDS)) {
3243 ((LISTOP*)last)->op_last = first;
3244 last->op_flags |= OPf_KIDS;
3246 first->op_sibling = ((LISTOP*)last)->op_first;
3247 ((LISTOP*)last)->op_first = first;
3249 last->op_flags |= OPf_KIDS;
3253 return newLISTOP(type, 0, first, last);
3261 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3264 Newxz(tk, 1, TOKEN);
3265 tk->tk_type = (OPCODE)optype;
3266 tk->tk_type = 12345;
3268 tk->tk_mad = madprop;
3273 Perl_token_free(pTHX_ TOKEN* tk)
3275 PERL_ARGS_ASSERT_TOKEN_FREE;
3277 if (tk->tk_type != 12345)
3279 mad_free(tk->tk_mad);
3284 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3289 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3291 if (tk->tk_type != 12345) {
3292 Perl_warner(aTHX_ packWARN(WARN_MISC),
3293 "Invalid TOKEN object ignored");
3300 /* faked up qw list? */
3302 tm->mad_type == MAD_SV &&
3303 SvPVX((SV *)tm->mad_val)[0] == 'q')
3310 /* pretend constant fold didn't happen? */
3311 if (mp->mad_key == 'f' &&
3312 (o->op_type == OP_CONST ||
3313 o->op_type == OP_GV) )
3315 token_getmad(tk,(OP*)mp->mad_val,slot);
3329 if (mp->mad_key == 'X')
3330 mp->mad_key = slot; /* just change the first one */
3340 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3349 /* pretend constant fold didn't happen? */
3350 if (mp->mad_key == 'f' &&
3351 (o->op_type == OP_CONST ||
3352 o->op_type == OP_GV) )
3354 op_getmad(from,(OP*)mp->mad_val,slot);
3361 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3364 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3370 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3379 /* pretend constant fold didn't happen? */
3380 if (mp->mad_key == 'f' &&
3381 (o->op_type == OP_CONST ||
3382 o->op_type == OP_GV) )
3384 op_getmad(from,(OP*)mp->mad_val,slot);
3391 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3394 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3398 PerlIO_printf(PerlIO_stderr(),
3399 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3405 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3423 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3427 addmad(tm, &(o->op_madprop), slot);
3431 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3452 Perl_newMADsv(pTHX_ char key, SV* sv)
3454 PERL_ARGS_ASSERT_NEWMADSV;
3456 return newMADPROP(key, MAD_SV, sv, 0);
3460 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3462 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3465 mp->mad_vlen = vlen;
3466 mp->mad_type = type;
3468 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3473 Perl_mad_free(pTHX_ MADPROP* mp)
3475 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3479 mad_free(mp->mad_next);
3480 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3481 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3482 switch (mp->mad_type) {
3486 Safefree((char*)mp->mad_val);
3489 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3490 op_free((OP*)mp->mad_val);
3493 sv_free(MUTABLE_SV(mp->mad_val));
3496 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3499 PerlMemShared_free(mp);
3505 =head1 Optree construction
3507 =for apidoc Am|OP *|newNULLLIST
3509 Constructs, checks, and returns a new C<stub> op, which represents an
3510 empty list expression.
3516 Perl_newNULLLIST(pTHX)
3518 return newOP(OP_STUB, 0);
3522 S_force_list(pTHX_ OP *o)
3524 if (!o || o->op_type != OP_LIST)
3525 o = newLISTOP(OP_LIST, 0, o, NULL);
3531 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3533 Constructs, checks, and returns an op of any list type. I<type> is
3534 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3535 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3536 supply up to two ops to be direct children of the list op; they are
3537 consumed by this function and become part of the constructed op tree.
3543 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3548 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3550 NewOp(1101, listop, 1, LISTOP);
3552 listop->op_type = (OPCODE)type;
3553 listop->op_ppaddr = PL_ppaddr[type];
3556 listop->op_flags = (U8)flags;
3560 else if (!first && last)
3563 first->op_sibling = last;
3564 listop->op_first = first;
3565 listop->op_last = last;
3566 if (type == OP_LIST) {
3567 OP* const pushop = newOP(OP_PUSHMARK, 0);
3568 pushop->op_sibling = first;
3569 listop->op_first = pushop;
3570 listop->op_flags |= OPf_KIDS;
3572 listop->op_last = pushop;
3575 return CHECKOP(type, listop);
3579 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3581 Constructs, checks, and returns an op of any base type (any type that
3582 has no extra fields). I<type> is the opcode. I<flags> gives the
3583 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3590 Perl_newOP(pTHX_ I32 type, I32 flags)
3595 if (type == -OP_ENTEREVAL) {
3596 type = OP_ENTEREVAL;
3597 flags |= OPpEVAL_BYTES<<8;
3600 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3601 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3602 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3603 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3605 NewOp(1101, o, 1, OP);
3606 o->op_type = (OPCODE)type;
3607 o->op_ppaddr = PL_ppaddr[type];
3608 o->op_flags = (U8)flags;
3610 o->op_latefreed = 0;
3614 o->op_private = (U8)(0 | (flags >> 8));
3615 if (PL_opargs[type] & OA_RETSCALAR)
3617 if (PL_opargs[type] & OA_TARGET)
3618 o->op_targ = pad_alloc(type, SVs_PADTMP);
3619 return CHECKOP(type, o);
3623 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3625 Constructs, checks, and returns an op of any unary type. I<type> is
3626 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3627 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3628 bits, the eight bits of C<op_private>, except that the bit with value 1
3629 is automatically set. I<first> supplies an optional op to be the direct
3630 child of the unary op; it is consumed by this function and become part
3631 of the constructed op tree.
3637 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3642 if (type == -OP_ENTEREVAL) {
3643 type = OP_ENTEREVAL;
3644 flags |= OPpEVAL_BYTES<<8;
3647 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3648 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3649 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3650 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3651 || type == OP_SASSIGN
3652 || type == OP_ENTERTRY
3653 || type == OP_NULL );
3656 first = newOP(OP_STUB, 0);
3657 if (PL_opargs[type] & OA_MARK)
3658 first = force_list(first);
3660 NewOp(1101, unop, 1, UNOP);
3661 unop->op_type = (OPCODE)type;
3662 unop->op_ppaddr = PL_ppaddr[type];
3663 unop->op_first = first;
3664 unop->op_flags = (U8)(flags | OPf_KIDS);
3665 unop->op_private = (U8)(1 | (flags >> 8));
3666 unop = (UNOP*) CHECKOP(type, unop);
3670 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3674 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3676 Constructs, checks, and returns an op of any binary type. I<type>
3677 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3678 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3679 the eight bits of C<op_private>, except that the bit with value 1 or
3680 2 is automatically set as required. I<first> and I<last> supply up to
3681 two ops to be the direct children of the binary op; they are consumed
3682 by this function and become part of the constructed op tree.
3688 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3693 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3694 || type == OP_SASSIGN || type == OP_NULL );
3696 NewOp(1101, binop, 1, BINOP);
3699 first = newOP(OP_NULL, 0);
3701 binop->op_type = (OPCODE)type;
3702 binop->op_ppaddr = PL_ppaddr[type];
3703 binop->op_first = first;
3704 binop->op_flags = (U8)(flags | OPf_KIDS);
3707 binop->op_private = (U8)(1 | (flags >> 8));
3710 binop->op_private = (U8)(2 | (flags >> 8));
3711 first->op_sibling = last;
3714 binop = (BINOP*)CHECKOP(type, binop);
3715 if (binop->op_next || binop->op_type != (OPCODE)type)
3718 binop->op_last = binop->op_first->op_sibling;
3720 return fold_constants(op_integerize(op_std_init((OP *)binop)));
3723 static int uvcompare(const void *a, const void *b)
3724 __attribute__nonnull__(1)
3725 __attribute__nonnull__(2)
3726 __attribute__pure__;
3727 static int uvcompare(const void *a, const void *b)
3729 if (*((const UV *)a) < (*(const UV *)b))
3731 if (*((const UV *)a) > (*(const UV *)b))
3733 if (*((const UV *)a+1) < (*(const UV *)b+1))
3735 if (*((const UV *)a+1) > (*(const UV *)b+1))
3741 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3744 SV * const tstr = ((SVOP*)expr)->op_sv;
3747 (repl->op_type == OP_NULL)
3748 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3750 ((SVOP*)repl)->op_sv;
3753 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3754 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3758 register short *tbl;
3760 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3761 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3762 I32 del = o->op_private & OPpTRANS_DELETE;
3765 PERL_ARGS_ASSERT_PMTRANS;
3767 PL_hints |= HINT_BLOCK_SCOPE;
3770 o->op_private |= OPpTRANS_FROM_UTF;
3773 o->op_private |= OPpTRANS_TO_UTF;
3775 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3776 SV* const listsv = newSVpvs("# comment\n");
3778 const U8* tend = t + tlen;
3779 const U8* rend = r + rlen;
3793 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3794 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3797 const U32 flags = UTF8_ALLOW_DEFAULT;
3801 t = tsave = bytes_to_utf8(t, &len);
3804 if (!to_utf && rlen) {
3806 r = rsave = bytes_to_utf8(r, &len);
3810 /* There are several snags with this code on EBCDIC:
3811 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3812 2. scan_const() in toke.c has encoded chars in native encoding which makes
3813 ranges at least in EBCDIC 0..255 range the bottom odd.
3817 U8 tmpbuf[UTF8_MAXBYTES+1];
3820 Newx(cp, 2*tlen, UV);
3822 transv = newSVpvs("");
3824 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3826 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3828 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3832 cp[2*i+1] = cp[2*i];
3836 qsort(cp, i, 2*sizeof(UV), uvcompare);
3837 for (j = 0; j < i; j++) {
3839 diff = val - nextmin;
3841 t = uvuni_to_utf8(tmpbuf,nextmin);
3842 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3844 U8 range_mark = UTF_TO_NATIVE(0xff);
3845 t = uvuni_to_utf8(tmpbuf, val - 1);
3846 sv_catpvn(transv, (char *)&range_mark, 1);
3847 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3854 t = uvuni_to_utf8(tmpbuf,nextmin);
3855 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3857 U8 range_mark = UTF_TO_NATIVE(0xff);
3858 sv_catpvn(transv, (char *)&range_mark, 1);
3860 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3861 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3862 t = (const U8*)SvPVX_const(transv);
3863 tlen = SvCUR(transv);
3867 else if (!rlen && !del) {
3868 r = t; rlen = tlen; rend = tend;
3871 if ((!rlen && !del) || t == r ||
3872 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3874 o->op_private |= OPpTRANS_IDENTICAL;
3878 while (t < tend || tfirst <= tlast) {
3879 /* see if we need more "t" chars */
3880 if (tfirst > tlast) {
3881 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3883 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3885 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3892 /* now see if we need more "r" chars */
3893 if (rfirst > rlast) {
3895 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3897 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3899 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3908 rfirst = rlast = 0xffffffff;
3912 /* now see which range will peter our first, if either. */
3913 tdiff = tlast - tfirst;
3914 rdiff = rlast - rfirst;
3921 if (rfirst == 0xffffffff) {
3922 diff = tdiff; /* oops, pretend rdiff is infinite */
3924 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3925 (long)tfirst, (long)tlast);
3927 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3931 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3932 (long)tfirst, (long)(tfirst + diff),
3935 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3936 (long)tfirst, (long)rfirst);
3938 if (rfirst + diff > max)
3939 max = rfirst + diff;
3941 grows = (tfirst < rfirst &&
3942 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3954 else if (max > 0xff)
3959 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3961 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3962 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3963 PAD_SETSV(cPADOPo->op_padix, swash);
3965 SvREADONLY_on(swash);
3967 cSVOPo->op_sv = swash;
3969 SvREFCNT_dec(listsv);
3970 SvREFCNT_dec(transv);
3972 if (!del && havefinal && rlen)
3973 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3974 newSVuv((UV)final), 0);
3977 o->op_private |= OPpTRANS_GROWS;
3983 op_getmad(expr,o,'e');
3984 op_getmad(repl,o,'r');
3992 tbl = (short*)PerlMemShared_calloc(
3993 (o->op_private & OPpTRANS_COMPLEMENT) &&
3994 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
3996 cPVOPo->op_pv = (char*)tbl;
3998 for (i = 0; i < (I32)tlen; i++)
4000 for (i = 0, j = 0; i < 256; i++) {
4002 if (j >= (I32)rlen) {
4011 if (i < 128 && r[j] >= 128)
4021 o->op_private |= OPpTRANS_IDENTICAL;
4023 else if (j >= (I32)rlen)
4028 PerlMemShared_realloc(tbl,
4029 (0x101+rlen-j) * sizeof(short));
4030 cPVOPo->op_pv = (char*)tbl;
4032 tbl[0x100] = (short)(rlen - j);
4033 for (i=0; i < (I32)rlen - j; i++)
4034 tbl[0x101+i] = r[j+i];
4038 if (!rlen && !del) {
4041 o->op_private |= OPpTRANS_IDENTICAL;
4043 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4044 o->op_private |= OPpTRANS_IDENTICAL;
4046 for (i = 0; i < 256; i++)
4048 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4049 if (j >= (I32)rlen) {
4051 if (tbl[t[i]] == -1)
4057 if (tbl[t[i]] == -1) {
4058 if (t[i] < 128 && r[j] >= 128)
4065 if(del && rlen == tlen) {
4066 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4067 } else if(rlen > tlen) {
4068 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4072 o->op_private |= OPpTRANS_GROWS;
4074 op_getmad(expr,o,'e');
4075 op_getmad(repl,o,'r');
4085 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4087 Constructs, checks, and returns an op of any pattern matching type.
4088 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4089 and, shifted up eight bits, the eight bits of C<op_private>.
4095 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4100 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4102 NewOp(1101, pmop, 1, PMOP);
4103 pmop->op_type = (OPCODE)type;
4104 pmop->op_ppaddr = PL_ppaddr[type];
4105 pmop->op_flags = (U8)flags;
4106 pmop->op_private = (U8)(0 | (flags >> 8));
4108 if (PL_hints & HINT_RE_TAINT)
4109 pmop->op_pmflags |= PMf_RETAINT;
4110 if (IN_LOCALE_COMPILETIME) {
4111 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4113 else if ((! (PL_hints & HINT_BYTES))
4114 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4115 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4117 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4119 if (PL_hints & HINT_RE_FLAGS) {
4120 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4121 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4123 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4124 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4125 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4127 if (reflags && SvOK(reflags)) {
4128 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4134 assert(SvPOK(PL_regex_pad[0]));
4135 if (SvCUR(PL_regex_pad[0])) {
4136 /* Pop off the "packed" IV from the end. */
4137 SV *const repointer_list = PL_regex_pad[0];
4138 const char *p = SvEND(repointer_list) - sizeof(IV);
4139 const IV offset = *((IV*)p);
4141 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4143 SvEND_set(repointer_list, p);
4145 pmop->op_pmoffset = offset;
4146 /* This slot should be free, so assert this: */
4147 assert(PL_regex_pad[offset] == &PL_sv_undef);
4149 SV * const repointer = &PL_sv_undef;
4150 av_push(PL_regex_padav, repointer);
4151 pmop->op_pmoffset = av_len(PL_regex_padav);
4152 PL_regex_pad = AvARRAY(PL_regex_padav);
4156 return CHECKOP(type, pmop);
4159 /* Given some sort of match op o, and an expression expr containing a
4160 * pattern, either compile expr into a regex and attach it to o (if it's
4161 * constant), or convert expr into a runtime regcomp op sequence (if it's
4164 * isreg indicates that the pattern is part of a regex construct, eg
4165 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4166 * split "pattern", which aren't. In the former case, expr will be a list
4167 * if the pattern contains more than one term (eg /a$b/) or if it contains
4168 * a replacement, ie s/// or tr///.
4172 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4177 I32 repl_has_vars = 0;
4181 PERL_ARGS_ASSERT_PMRUNTIME;
4184 o->op_type == OP_SUBST
4185 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4187 /* last element in list is the replacement; pop it */
4189 repl = cLISTOPx(expr)->op_last;
4190 kid = cLISTOPx(expr)->op_first;
4191 while (kid->op_sibling != repl)
4192 kid = kid->op_sibling;
4193 kid->op_sibling = NULL;
4194 cLISTOPx(expr)->op_last = kid;
4197 if (isreg && expr->op_type == OP_LIST &&
4198 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4200 /* convert single element list to element */
4201 OP* const oe = expr;
4202 expr = cLISTOPx(oe)->op_first->op_sibling;
4203 cLISTOPx(oe)->op_first->op_sibling = NULL;
4204 cLISTOPx(oe)->op_last = NULL;
4208 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4209 return pmtrans(o, expr, repl);
4212 reglist = isreg && expr->op_type == OP_LIST;
4216 PL_hints |= HINT_BLOCK_SCOPE;
4219 if (expr->op_type == OP_CONST) {
4220 SV *pat = ((SVOP*)expr)->op_sv;
4221 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4223 if (o->op_flags & OPf_SPECIAL)
4224 pm_flags |= RXf_SPLIT;
4227 assert (SvUTF8(pat));
4228 } else if (SvUTF8(pat)) {
4229 /* Not doing UTF-8, despite what the SV says. Is this only if we're
4230 trapped in use 'bytes'? */
4231 /* Make a copy of the octet sequence, but without the flag on, as
4232 the compiler now honours the SvUTF8 flag on pat. */
4234 const char *const p = SvPV(pat, len);
4235 pat = newSVpvn_flags(p, len, SVs_TEMP);
4238 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4241 op_getmad(expr,(OP*)pm,'e');
4247 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4248 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4250 : OP_REGCMAYBE),0,expr);
4252 NewOp(1101, rcop, 1, LOGOP);
4253 rcop->op_type = OP_REGCOMP;
4254 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4255 rcop->op_first = scalar(expr);
4256 rcop->op_flags |= OPf_KIDS
4257 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4258 | (reglist ? OPf_STACKED : 0);
4259 rcop->op_private = 1;
4262 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4264 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4265 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4267 /* establish postfix order */
4268 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4270 rcop->op_next = expr;
4271 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4274 rcop->op_next = LINKLIST(expr);
4275 expr->op_next = (OP*)rcop;
4278 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4283 if (pm->op_pmflags & PMf_EVAL) {
4285 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4286 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4288 else if (repl->op_type == OP_CONST)
4292 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4293 if (curop->op_type == OP_SCOPE
4294 || curop->op_type == OP_LEAVE
4295 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4296 if (curop->op_type == OP_GV) {
4297 GV * const gv = cGVOPx_gv(curop);
4299 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4302 else if (curop->op_type == OP_RV2CV)
4304 else if (curop->op_type == OP_RV2SV ||
4305 curop->op_type == OP_RV2AV ||
4306 curop->op_type == OP_RV2HV ||
4307 curop->op_type == OP_RV2GV) {
4308 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4311 else if (curop->op_type == OP_PADSV ||
4312 curop->op_type == OP_PADAV ||
4313 curop->op_type == OP_PADHV ||
4314 curop->op_type == OP_PADANY)
4318 else if (curop->op_type == OP_PUSHRE)
4319 NOOP; /* Okay here, dangerous in newASSIGNOP */
4329 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4331 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4332 op_prepend_elem(o->op_type, scalar(repl), o);
4335 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4336 pm->op_pmflags |= PMf_MAYBE_CONST;
4338 NewOp(1101, rcop, 1, LOGOP);
4339 rcop->op_type = OP_SUBSTCONT;
4340 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4341 rcop->op_first = scalar(repl);
4342 rcop->op_flags |= OPf_KIDS;
4343 rcop->op_private = 1;
4346 /* establish postfix order */
4347 rcop->op_next = LINKLIST(repl);
4348 repl->op_next = (OP*)rcop;
4350 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4351 assert(!(pm->op_pmflags & PMf_ONCE));
4352 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4361 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4363 Constructs, checks, and returns an op of any type that involves an
4364 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4365 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4366 takes ownership of one reference to it.
4372 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4377 PERL_ARGS_ASSERT_NEWSVOP;
4379 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4380 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4381 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4383 NewOp(1101, svop, 1, SVOP);
4384 svop->op_type = (OPCODE)type;
4385 svop->op_ppaddr = PL_ppaddr[type];
4387 svop->op_next = (OP*)svop;
4388 svop->op_flags = (U8)flags;
4389 if (PL_opargs[type] & OA_RETSCALAR)
4391 if (PL_opargs[type] & OA_TARGET)
4392 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4393 return CHECKOP(type, svop);
4399 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4401 Constructs, checks, and returns an op of any type that involves a
4402 reference to a pad element. I<type> is the opcode. I<flags> gives the
4403 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4404 is populated with I<sv>; this function takes ownership of one reference
4407 This function only exists if Perl has been compiled to use ithreads.
4413 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4418 PERL_ARGS_ASSERT_NEWPADOP;
4420 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4421 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4422 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4424 NewOp(1101, padop, 1, PADOP);
4425 padop->op_type = (OPCODE)type;
4426 padop->op_ppaddr = PL_ppaddr[type];
4427 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4428 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4429 PAD_SETSV(padop->op_padix, sv);
4432 padop->op_next = (OP*)padop;
4433 padop->op_flags = (U8)flags;
4434 if (PL_opargs[type] & OA_RETSCALAR)
4436 if (PL_opargs[type] & OA_TARGET)
4437 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4438 return CHECKOP(type, padop);
4441 #endif /* !USE_ITHREADS */
4444 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4446 Constructs, checks, and returns an op of any type that involves an
4447 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4448 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4449 reference; calling this function does not transfer ownership of any
4456 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4460 PERL_ARGS_ASSERT_NEWGVOP;
4464 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4466 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4471 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4473 Constructs, checks, and returns an op of any type that involves an
4474 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4475 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4476 must have been allocated using L</PerlMemShared_malloc>; the memory will
4477 be freed when the op is destroyed.
4483 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4488 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4490 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4492 NewOp(1101, pvop, 1, PVOP);
4493 pvop->op_type = (OPCODE)type;
4494 pvop->op_ppaddr = PL_ppaddr[type];
4496 pvop->op_next = (OP*)pvop;
4497 pvop->op_flags = (U8)flags;
4498 if (PL_opargs[type] & OA_RETSCALAR)
4500 if (PL_opargs[type] & OA_TARGET)
4501 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4502 return CHECKOP(type, pvop);
4510 Perl_package(pTHX_ OP *o)
4513 SV *const sv = cSVOPo->op_sv;
4518 PERL_ARGS_ASSERT_PACKAGE;
4520 SAVEGENERICSV(PL_curstash);
4521 save_item(PL_curstname);
4523 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4525 sv_setsv(PL_curstname, sv);
4527 PL_hints |= HINT_BLOCK_SCOPE;
4528 PL_parser->copline = NOLINE;
4529 PL_parser->expect = XSTATE;
4534 if (!PL_madskills) {
4539 pegop = newOP(OP_NULL,0);
4540 op_getmad(o,pegop,'P');
4546 Perl_package_version( pTHX_ OP *v )
4549 U32 savehints = PL_hints;
4550 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4551 PL_hints &= ~HINT_STRICT_VARS;
4552 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4553 PL_hints = savehints;
4562 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4569 OP *pegop = newOP(OP_NULL,0);
4571 SV *use_version = NULL;
4573 PERL_ARGS_ASSERT_UTILIZE;
4575 if (idop->op_type != OP_CONST)
4576 Perl_croak(aTHX_ "Module name must be constant");
4579 op_getmad(idop,pegop,'U');
4584 SV * const vesv = ((SVOP*)version)->op_sv;
4587 op_getmad(version,pegop,'V');
4588 if (!arg && !SvNIOKp(vesv)) {
4595 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4596 Perl_croak(aTHX_ "Version number must be a constant number");
4598 /* Make copy of idop so we don't free it twice */
4599 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4601 /* Fake up a method call to VERSION */
4602 meth = newSVpvs_share("VERSION");
4603 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4604 op_append_elem(OP_LIST,
4605 op_prepend_elem(OP_LIST, pack, list(version)),
4606 newSVOP(OP_METHOD_NAMED, 0, meth)));
4610 /* Fake up an import/unimport */
4611 if (arg && arg->op_type == OP_STUB) {
4613 op_getmad(arg,pegop,'S');
4614 imop = arg; /* no import on explicit () */
4616 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4617 imop = NULL; /* use 5.0; */
4619 use_version = ((SVOP*)idop)->op_sv;
4621 idop->op_private |= OPpCONST_NOVER;
4627 op_getmad(arg,pegop,'A');
4629 /* Make copy of idop so we don't free it twice */
4630 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4632 /* Fake up a method call to import/unimport */
4634 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4635 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4636 op_append_elem(OP_LIST,
4637 op_prepend_elem(OP_LIST, pack, list(arg)),
4638 newSVOP(OP_METHOD_NAMED, 0, meth)));
4641 /* Fake up the BEGIN {}, which does its thing immediately. */
4643 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4646 op_append_elem(OP_LINESEQ,
4647 op_append_elem(OP_LINESEQ,
4648 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4649 newSTATEOP(0, NULL, veop)),
4650 newSTATEOP(0, NULL, imop) ));
4653 HV * const hinthv = GvHV(PL_hintgv);
4654 const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH);
4657 * feature bundle that corresponds to the required version. */
4658 use_version = sv_2mortal(new_version(use_version));
4659 S_enable_feature_bundle(aTHX_ use_version);
4661 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4662 if (vcmp(use_version,
4663 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4664 if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
4665 PL_hints |= HINT_STRICT_REFS;
4666 if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
4667 PL_hints |= HINT_STRICT_SUBS;
4668 if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
4669 PL_hints |= HINT_STRICT_VARS;
4671 /* otherwise they are off */
4673 if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
4674 PL_hints &= ~HINT_STRICT_REFS;
4675 if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
4676 PL_hints &= ~HINT_STRICT_SUBS;
4677 if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
4678 PL_hints &= ~HINT_STRICT_VARS;
4682 /* The "did you use incorrect case?" warning used to be here.
4683 * The problem is that on case-insensitive filesystems one
4684 * might get false positives for "use" (and "require"):
4685 * "use Strict" or "require CARP" will work. This causes
4686 * portability problems for the script: in case-strict
4687 * filesystems the script will stop working.
4689 * The "incorrect case" warning checked whether "use Foo"
4690 * imported "Foo" to your namespace, but that is wrong, too:
4691 * there is no requirement nor promise in the language that
4692 * a Foo.pm should or would contain anything in package "Foo".
4694 * There is very little Configure-wise that can be done, either:
4695 * the case-sensitivity of the build filesystem of Perl does not
4696 * help in guessing the case-sensitivity of the runtime environment.
4699 PL_hints |= HINT_BLOCK_SCOPE;
4700 PL_parser->copline = NOLINE;
4701 PL_parser->expect = XSTATE;
4702 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4703 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4707 if (!PL_madskills) {
4708 /* FIXME - don't allocate pegop if !PL_madskills */
4717 =head1 Embedding Functions
4719 =for apidoc load_module
4721 Loads the module whose name is pointed to by the string part of name.
4722 Note that the actual module name, not its filename, should be given.
4723 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4724 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4725 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
4726 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4727 arguments can be used to specify arguments to the module's import()
4728 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4729 terminated with a final NULL pointer. Note that this list can only
4730 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4731 Otherwise at least a single NULL pointer to designate the default
4732 import list is required.
4734 The reference count for each specified C<SV*> parameter is decremented.
4739 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4743 PERL_ARGS_ASSERT_LOAD_MODULE;
4745 va_start(args, ver);
4746 vload_module(flags, name, ver, &args);
4750 #ifdef PERL_IMPLICIT_CONTEXT
4752 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4756 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4757 va_start(args, ver);
4758 vload_module(flags, name, ver, &args);
4764 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4768 OP * const modname = newSVOP(OP_CONST, 0, name);
4770 PERL_ARGS_ASSERT_VLOAD_MODULE;
4772 modname->op_private |= OPpCONST_BARE;
4774 veop = newSVOP(OP_CONST, 0, ver);
4778 if (flags & PERL_LOADMOD_NOIMPORT) {
4779 imop = sawparens(newNULLLIST());
4781 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4782 imop = va_arg(*args, OP*);
4787 sv = va_arg(*args, SV*);
4789 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4790 sv = va_arg(*args, SV*);
4794 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4795 * that it has a PL_parser to play with while doing that, and also
4796 * that it doesn't mess with any existing parser, by creating a tmp
4797 * new parser with lex_start(). This won't actually be used for much,
4798 * since pp_require() will create another parser for the real work. */
4801 SAVEVPTR(PL_curcop);
4802 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4803 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4804 veop, modname, imop);
4809 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4815 PERL_ARGS_ASSERT_DOFILE;
4817 if (!force_builtin) {
4818 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4819 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4820 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4821 gv = gvp ? *gvp : NULL;
4825 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4826 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4827 op_append_elem(OP_LIST, term,
4828 scalar(newUNOP(OP_RV2CV, 0,
4829 newGVOP(OP_GV, 0, gv))))));
4832 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4838 =head1 Optree construction
4840 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4842 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4843 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4844 be set automatically, and, shifted up eight bits, the eight bits of
4845 C<op_private>, except that the bit with value 1 or 2 is automatically
4846 set as required. I<listval> and I<subscript> supply the parameters of
4847 the slice; they are consumed by this function and become part of the
4848 constructed op tree.
4854 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4856 return newBINOP(OP_LSLICE, flags,
4857 list(force_list(subscript)),
4858 list(force_list(listval)) );
4862 S_is_list_assignment(pTHX_ register const OP *o)
4870 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4871 o = cUNOPo->op_first;
4873 flags = o->op_flags;
4875 if (type == OP_COND_EXPR) {
4876 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4877 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4882 yyerror("Assignment to both a list and a scalar");
4886 if (type == OP_LIST &&
4887 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4888 o->op_private & OPpLVAL_INTRO)
4891 if (type == OP_LIST || flags & OPf_PARENS ||
4892 type == OP_RV2AV || type == OP_RV2HV ||
4893 type == OP_ASLICE || type == OP_HSLICE)
4896 if (type == OP_PADAV || type == OP_PADHV)
4899 if (type == OP_RV2SV)
4906 Helper function for newASSIGNOP to detection commonality between the
4907 lhs and the rhs. Marks all variables with PL_generation. If it
4908 returns TRUE the assignment must be able to handle common variables.
4910 PERL_STATIC_INLINE bool
4911 S_aassign_common_vars(pTHX_ OP* o)
4914 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
4915 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4916 if (curop->op_type == OP_GV) {
4917 GV *gv = cGVOPx_gv(curop);
4919 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4921 GvASSIGN_GENERATION_set(gv, PL_generation);
4923 else if (curop->op_type == OP_PADSV ||
4924 curop->op_type == OP_PADAV ||
4925 curop->op_type == OP_PADHV ||
4926 curop->op_type == OP_PADANY)
4928 if (PAD_COMPNAME_GEN(curop->op_targ)
4929 == (STRLEN)PL_generation)
4931 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4934 else if (curop->op_type == OP_RV2CV)
4936 else if (curop->op_type == OP_RV2SV ||
4937 curop->op_type == OP_RV2AV ||
4938 curop->op_type == OP_RV2HV ||
4939 curop->op_type == OP_RV2GV) {
4940 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
4943 else if (curop->op_type == OP_PUSHRE) {
4945 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4946 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4948 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4950 GvASSIGN_GENERATION_set(gv, PL_generation);
4954 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4957 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4959 GvASSIGN_GENERATION_set(gv, PL_generation);
4967 if (curop->op_flags & OPf_KIDS) {
4968 if (aassign_common_vars(curop))
4976 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4978 Constructs, checks, and returns an assignment op. I<left> and I<right>
4979 supply the parameters of the assignment; they are consumed by this
4980 function and become part of the constructed op tree.
4982 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4983 a suitable conditional optree is constructed. If I<optype> is the opcode
4984 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4985 performs the binary operation and assigns the result to the left argument.
4986 Either way, if I<optype> is non-zero then I<flags> has no effect.
4988 If I<optype> is zero, then a plain scalar or list assignment is
4989 constructed. Which type of assignment it is is automatically determined.
4990 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4991 will be set automatically, and, shifted up eight bits, the eight bits
4992 of C<op_private>, except that the bit with value 1 or 2 is automatically
4999 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5005 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5006 return newLOGOP(optype, 0,
5007 op_lvalue(scalar(left), optype),
5008 newUNOP(OP_SASSIGN, 0, scalar(right)));
5011 return newBINOP(optype, OPf_STACKED,
5012 op_lvalue(scalar(left), optype), scalar(right));
5016 if (is_list_assignment(left)) {
5017 static const char no_list_state[] = "Initialization of state variables"
5018 " in list context currently forbidden";
5020 bool maybe_common_vars = TRUE;
5023 left = op_lvalue(left, OP_AASSIGN);
5024 curop = list(force_list(left));
5025 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5026 o->op_private = (U8)(0 | (flags >> 8));
5028 if ((left->op_type == OP_LIST
5029 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5031 OP* lop = ((LISTOP*)left)->op_first;
5032 maybe_common_vars = FALSE;
5034 if (lop->op_type == OP_PADSV ||
5035 lop->op_type == OP_PADAV ||
5036 lop->op_type == OP_PADHV ||
5037 lop->op_type == OP_PADANY) {
5038 if (!(lop->op_private & OPpLVAL_INTRO))
5039 maybe_common_vars = TRUE;
5041 if (lop->op_private & OPpPAD_STATE) {
5042 if (left->op_private & OPpLVAL_INTRO) {
5043 /* Each variable in state($a, $b, $c) = ... */
5046 /* Each state variable in
5047 (state $a, my $b, our $c, $d, undef) = ... */
5049 yyerror(no_list_state);
5051 /* Each my variable in
5052 (state $a, my $b, our $c, $d, undef) = ... */
5054 } else if (lop->op_type == OP_UNDEF ||
5055 lop->op_type == OP_PUSHMARK) {
5056 /* undef may be interesting in
5057 (state $a, undef, state $c) */
5059 /* Other ops in the list. */
5060 maybe_common_vars = TRUE;
5062 lop = lop->op_sibling;
5065 else if ((left->op_private & OPpLVAL_INTRO)
5066 && ( left->op_type == OP_PADSV
5067 || left->op_type == OP_PADAV
5068 || left->op_type == OP_PADHV
5069 || left->op_type == OP_PADANY))
5071 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5072 if (left->op_private & OPpPAD_STATE) {
5073 /* All single variable list context state assignments, hence
5083 yyerror(no_list_state);
5087 /* PL_generation sorcery:
5088 * an assignment like ($a,$b) = ($c,$d) is easier than
5089 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5090 * To detect whether there are common vars, the global var
5091 * PL_generation is incremented for each assign op we compile.
5092 * Then, while compiling the assign op, we run through all the
5093 * variables on both sides of the assignment, setting a spare slot
5094 * in each of them to PL_generation. If any of them already have
5095 * that value, we know we've got commonality. We could use a
5096 * single bit marker, but then we'd have to make 2 passes, first
5097 * to clear the flag, then to test and set it. To find somewhere
5098 * to store these values, evil chicanery is done with SvUVX().
5101 if (maybe_common_vars) {
5103 if (aassign_common_vars(o))
5104 o->op_private |= OPpASSIGN_COMMON;
5108 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5109 OP* tmpop = ((LISTOP*)right)->op_first;
5110 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5111 PMOP * const pm = (PMOP*)tmpop;
5112 if (left->op_type == OP_RV2AV &&
5113 !(left->op_private & OPpLVAL_INTRO) &&
5114 !(o->op_private & OPpASSIGN_COMMON) )
5116 tmpop = ((UNOP*)left)->op_first;
5117 if (tmpop->op_type == OP_GV
5119 && !pm->op_pmreplrootu.op_pmtargetoff
5121 && !pm->op_pmreplrootu.op_pmtargetgv
5125 pm->op_pmreplrootu.op_pmtargetoff
5126 = cPADOPx(tmpop)->op_padix;
5127 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5129 pm->op_pmreplrootu.op_pmtargetgv
5130 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5131 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5133 pm->op_pmflags |= PMf_ONCE;
5134 tmpop = cUNOPo->op_first; /* to list (nulled) */
5135 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5136 tmpop->op_sibling = NULL; /* don't free split */
5137 right->op_next = tmpop->op_next; /* fix starting loc */
5138 op_free(o); /* blow off assign */
5139 right->op_flags &= ~OPf_WANT;
5140 /* "I don't know and I don't care." */
5145 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5146 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5148 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5149 if (SvIOK(sv) && SvIVX(sv) == 0)
5150 sv_setiv(sv, PL_modcount+1);
5158 right = newOP(OP_UNDEF, 0);
5159 if (right->op_type == OP_READLINE) {
5160 right->op_flags |= OPf_STACKED;
5161 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5165 o = newBINOP(OP_SASSIGN, flags,
5166 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5172 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5174 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5175 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5176 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5177 If I<label> is non-null, it supplies the name of a label to attach to
5178 the state op; this function takes ownership of the memory pointed at by
5179 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5182 If I<o> is null, the state op is returned. Otherwise the state op is
5183 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5184 is consumed by this function and becomes part of the returned op tree.
5190 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5193 const U32 seq = intro_my();
5196 NewOp(1101, cop, 1, COP);
5197 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5198 cop->op_type = OP_DBSTATE;
5199 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5202 cop->op_type = OP_NEXTSTATE;
5203 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5205 cop->op_flags = (U8)flags;
5206 CopHINTS_set(cop, PL_hints);
5208 cop->op_private |= NATIVE_HINTS;
5210 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5211 cop->op_next = (OP*)cop;
5214 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5215 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5217 Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
5219 PL_hints |= HINT_BLOCK_SCOPE;
5220 /* It seems that we need to defer freeing this pointer, as other parts
5221 of the grammar end up wanting to copy it after this op has been
5226 if (PL_parser && PL_parser->copline == NOLINE)
5227 CopLINE_set(cop, CopLINE(PL_curcop));
5229 CopLINE_set(cop, PL_parser->copline);
5231 PL_parser->copline = NOLINE;
5234 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5236 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5238 CopSTASH_set(cop, PL_curstash);
5240 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5241 /* this line can have a breakpoint - store the cop in IV */
5242 AV *av = CopFILEAVx(PL_curcop);
5244 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5245 if (svp && *svp != &PL_sv_undef ) {
5246 (void)SvIOK_on(*svp);
5247 SvIV_set(*svp, PTR2IV(cop));
5252 if (flags & OPf_SPECIAL)
5254 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5258 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5260 Constructs, checks, and returns a logical (flow control) op. I<type>
5261 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5262 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5263 the eight bits of C<op_private>, except that the bit with value 1 is
5264 automatically set. I<first> supplies the expression controlling the
5265 flow, and I<other> supplies the side (alternate) chain of ops; they are
5266 consumed by this function and become part of the constructed op tree.
5272 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5276 PERL_ARGS_ASSERT_NEWLOGOP;
5278 return new_logop(type, flags, &first, &other);
5282 S_search_const(pTHX_ OP *o)
5284 PERL_ARGS_ASSERT_SEARCH_CONST;
5286 switch (o->op_type) {
5290 if (o->op_flags & OPf_KIDS)
5291 return search_const(cUNOPo->op_first);
5298 if (!(o->op_flags & OPf_KIDS))
5300 kid = cLISTOPo->op_first;
5302 switch (kid->op_type) {
5306 kid = kid->op_sibling;
5309 if (kid != cLISTOPo->op_last)
5315 kid = cLISTOPo->op_last;
5317 return search_const(kid);
5325 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5333 int prepend_not = 0;
5335 PERL_ARGS_ASSERT_NEW_LOGOP;
5340 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5341 return newBINOP(type, flags, scalar(first), scalar(other));
5343 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5345 scalarboolean(first);
5346 /* optimize AND and OR ops that have NOTs as children */
5347 if (first->op_type == OP_NOT
5348 && (first->op_flags & OPf_KIDS)
5349 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5350 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5352 if (type == OP_AND || type == OP_OR) {
5358 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5360 prepend_not = 1; /* prepend a NOT op later */
5364 /* search for a constant op that could let us fold the test */
5365 if ((cstop = search_const(first))) {
5366 if (cstop->op_private & OPpCONST_STRICT)
5367 no_bareword_allowed(cstop);
5368 else if ((cstop->op_private & OPpCONST_BARE))
5369 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5370 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5371 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5372 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5374 if (other->op_type == OP_CONST)
5375 other->op_private |= OPpCONST_SHORTCIRCUIT;
5377 OP *newop = newUNOP(OP_NULL, 0, other);
5378 op_getmad(first, newop, '1');
5379 newop->op_targ = type; /* set "was" field */
5383 if (other->op_type == OP_LEAVE)
5384 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5385 else if (other->op_type == OP_MATCH
5386 || other->op_type == OP_SUBST
5387 || other->op_type == OP_TRANSR
5388 || other->op_type == OP_TRANS)
5389 /* Mark the op as being unbindable with =~ */
5390 other->op_flags |= OPf_SPECIAL;
5394 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5395 const OP *o2 = other;
5396 if ( ! (o2->op_type == OP_LIST
5397 && (( o2 = cUNOPx(o2)->op_first))
5398 && o2->op_type == OP_PUSHMARK
5399 && (( o2 = o2->op_sibling)) )
5402 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5403 || o2->op_type == OP_PADHV)
5404 && o2->op_private & OPpLVAL_INTRO
5405 && !(o2->op_private & OPpPAD_STATE))
5407 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5408 "Deprecated use of my() in false conditional");
5412 if (first->op_type == OP_CONST)
5413 first->op_private |= OPpCONST_SHORTCIRCUIT;
5415 first = newUNOP(OP_NULL, 0, first);
5416 op_getmad(other, first, '2');
5417 first->op_targ = type; /* set "was" field */
5424 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5425 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5427 const OP * const k1 = ((UNOP*)first)->op_first;
5428 const OP * const k2 = k1->op_sibling;
5430 switch (first->op_type)
5433 if (k2 && k2->op_type == OP_READLINE
5434 && (k2->op_flags & OPf_STACKED)
5435 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5437 warnop = k2->op_type;
5442 if (k1->op_type == OP_READDIR
5443 || k1->op_type == OP_GLOB
5444 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5445 || k1->op_type == OP_EACH
5446 || k1->op_type == OP_AEACH)
5448 warnop = ((k1->op_type == OP_NULL)
5449 ? (OPCODE)k1->op_targ : k1->op_type);
5454 const line_t oldline = CopLINE(PL_curcop);
5455 CopLINE_set(PL_curcop, PL_parser->copline);
5456 Perl_warner(aTHX_ packWARN(WARN_MISC),
5457 "Value of %s%s can be \"0\"; test with defined()",
5459 ((warnop == OP_READLINE || warnop == OP_GLOB)
5460 ? " construct" : "() operator"));
5461 CopLINE_set(PL_curcop, oldline);
5468 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5469 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5471 NewOp(1101, logop, 1, LOGOP);
5473 logop->op_type = (OPCODE)type;
5474 logop->op_ppaddr = PL_ppaddr[type];
5475 logop->op_first = first;
5476 logop->op_flags = (U8)(flags | OPf_KIDS);
5477 logop->op_other = LINKLIST(other);
5478 logop->op_private = (U8)(1 | (flags >> 8));
5480 /* establish postfix order */
5481 logop->op_next = LINKLIST(first);
5482 first->op_next = (OP*)logop;
5483 first->op_sibling = other;
5485 CHECKOP(type,logop);
5487 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5494 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5496 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5497 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5498 will be set automatically, and, shifted up eight bits, the eight bits of
5499 C<op_private>, except that the bit with value 1 is automatically set.
5500 I<first> supplies the expression selecting between the two branches,
5501 and I<trueop> and I<falseop> supply the branches; they are consumed by
5502 this function and become part of the constructed op tree.
5508 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5516 PERL_ARGS_ASSERT_NEWCONDOP;
5519 return newLOGOP(OP_AND, 0, first, trueop);
5521 return newLOGOP(OP_OR, 0, first, falseop);
5523 scalarboolean(first);
5524 if ((cstop = search_const(first))) {
5525 /* Left or right arm of the conditional? */
5526 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5527 OP *live = left ? trueop : falseop;
5528 OP *const dead = left ? falseop : trueop;
5529 if (cstop->op_private & OPpCONST_BARE &&
5530 cstop->op_private & OPpCONST_STRICT) {
5531 no_bareword_allowed(cstop);
5534 /* This is all dead code when PERL_MAD is not defined. */
5535 live = newUNOP(OP_NULL, 0, live);
5536 op_getmad(first, live, 'C');
5537 op_getmad(dead, live, left ? 'e' : 't');
5542 if (live->op_type == OP_LEAVE)
5543 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5544 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5545 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5546 /* Mark the op as being unbindable with =~ */
5547 live->op_flags |= OPf_SPECIAL;
5550 NewOp(1101, logop, 1, LOGOP);
5551 logop->op_type = OP_COND_EXPR;
5552 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5553 logop->op_first = first;
5554 logop->op_flags = (U8)(flags | OPf_KIDS);
5555 logop->op_private = (U8)(1 | (flags >> 8));
5556 logop->op_other = LINKLIST(trueop);
5557 logop->op_next = LINKLIST(falseop);
5559 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5562 /* establish postfix order */
5563 start = LINKLIST(first);
5564 first->op_next = (OP*)logop;
5566 first->op_sibling = trueop;
5567 trueop->op_sibling = falseop;
5568 o = newUNOP(OP_NULL, 0, (OP*)logop);
5570 trueop->op_next = falseop->op_next = o;
5577 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5579 Constructs and returns a C<range> op, with subordinate C<flip> and
5580 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5581 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5582 for both the C<flip> and C<range> ops, except that the bit with value
5583 1 is automatically set. I<left> and I<right> supply the expressions
5584 controlling the endpoints of the range; they are consumed by this function
5585 and become part of the constructed op tree.
5591 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5600 PERL_ARGS_ASSERT_NEWRANGE;
5602 NewOp(1101, range, 1, LOGOP);
5604 range->op_type = OP_RANGE;
5605 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5606 range->op_first = left;
5607 range->op_flags = OPf_KIDS;
5608 leftstart = LINKLIST(left);
5609 range->op_other = LINKLIST(right);
5610 range->op_private = (U8)(1 | (flags >> 8));
5612 left->op_sibling = right;
5614 range->op_next = (OP*)range;
5615 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5616 flop = newUNOP(OP_FLOP, 0, flip);
5617 o = newUNOP(OP_NULL, 0, flop);
5619 range->op_next = leftstart;
5621 left->op_next = flip;
5622 right->op_next = flop;
5624 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5625 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5626 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5627 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5629 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5630 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5632 /* check barewords before they might be optimized aways */
5633 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5634 no_bareword_allowed(left);
5635 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5636 no_bareword_allowed(right);
5639 if (!flip->op_private || !flop->op_private)
5640 LINKLIST(o); /* blow off optimizer unless constant */
5646 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5648 Constructs, checks, and returns an op tree expressing a loop. This is
5649 only a loop in the control flow through the op tree; it does not have
5650 the heavyweight loop structure that allows exiting the loop by C<last>
5651 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5652 top-level op, except that some bits will be set automatically as required.
5653 I<expr> supplies the expression controlling loop iteration, and I<block>
5654 supplies the body of the loop; they are consumed by this function and
5655 become part of the constructed op tree. I<debuggable> is currently
5656 unused and should always be 1.
5662 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5667 const bool once = block && block->op_flags & OPf_SPECIAL &&
5668 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5670 PERL_UNUSED_ARG(debuggable);
5673 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5674 return block; /* do {} while 0 does once */
5675 if (expr->op_type == OP_READLINE
5676 || expr->op_type == OP_READDIR
5677 || expr->op_type == OP_GLOB
5678 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5679 expr = newUNOP(OP_DEFINED, 0,
5680 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5681 } else if (expr->op_flags & OPf_KIDS) {
5682 const OP * const k1 = ((UNOP*)expr)->op_first;
5683 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5684 switch (expr->op_type) {
5686 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5687 && (k2->op_flags & OPf_STACKED)
5688 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5689 expr = newUNOP(OP_DEFINED, 0, expr);
5693 if (k1 && (k1->op_type == OP_READDIR
5694 || k1->op_type == OP_GLOB
5695 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5696 || k1->op_type == OP_EACH
5697 || k1->op_type == OP_AEACH))
5698 expr = newUNOP(OP_DEFINED, 0, expr);
5704 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5705 * op, in listop. This is wrong. [perl #27024] */
5707 block = newOP(OP_NULL, 0);
5708 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5709 o = new_logop(OP_AND, 0, &expr, &listop);
5712 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5714 if (once && o != listop)
5715 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5718 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5720 o->op_flags |= flags;
5722 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5727 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5729 Constructs, checks, and returns an op tree expressing a C<while> loop.
5730 This is a heavyweight loop, with structure that allows exiting the loop
5731 by C<last> and suchlike.
5733 I<loop> is an optional preconstructed C<enterloop> op to use in the
5734 loop; if it is null then a suitable op will be constructed automatically.
5735 I<expr> supplies the loop's controlling expression. I<block> supplies the
5736 main body of the loop, and I<cont> optionally supplies a C<continue> block
5737 that operates as a second half of the body. All of these optree inputs
5738 are consumed by this function and become part of the constructed op tree.
5740 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5741 op and, shifted up eight bits, the eight bits of C<op_private> for
5742 the C<leaveloop> op, except that (in both cases) some bits will be set
5743 automatically. I<debuggable> is currently unused and should always be 1.
5744 I<has_my> can be supplied as true to force the
5745 loop body to be enclosed in its own scope.
5751 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5752 OP *expr, OP *block, OP *cont, I32 has_my)
5761 PERL_UNUSED_ARG(debuggable);
5764 if (expr->op_type == OP_READLINE
5765 || expr->op_type == OP_READDIR
5766 || expr->op_type == OP_GLOB
5767 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5768 expr = newUNOP(OP_DEFINED, 0,
5769 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5770 } else if (expr->op_flags & OPf_KIDS) {
5771 const OP * const k1 = ((UNOP*)expr)->op_first;
5772 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5773 switch (expr->op_type) {
5775 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5776 && (k2->op_flags & OPf_STACKED)
5777 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5778 expr = newUNOP(OP_DEFINED, 0, expr);
5782 if (k1 && (k1->op_type == OP_READDIR
5783 || k1->op_type == OP_GLOB
5784 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5785 || k1->op_type == OP_EACH
5786 || k1->op_type == OP_AEACH))
5787 expr = newUNOP(OP_DEFINED, 0, expr);
5794 block = newOP(OP_NULL, 0);
5795 else if (cont || has_my) {
5796 block = op_scope(block);
5800 next = LINKLIST(cont);
5803 OP * const unstack = newOP(OP_UNSTACK, 0);
5806 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5810 listop = op_append_list(OP_LINESEQ, block, cont);
5812 redo = LINKLIST(listop);
5816 o = new_logop(OP_AND, 0, &expr, &listop);
5817 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5818 op_free(expr); /* oops, it's a while (0) */
5820 return NULL; /* listop already freed by new_logop */
5823 ((LISTOP*)listop)->op_last->op_next =
5824 (o == listop ? redo : LINKLIST(o));
5830 NewOp(1101,loop,1,LOOP);
5831 loop->op_type = OP_ENTERLOOP;
5832 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5833 loop->op_private = 0;
5834 loop->op_next = (OP*)loop;
5837 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5839 loop->op_redoop = redo;
5840 loop->op_lastop = o;
5841 o->op_private |= loopflags;
5844 loop->op_nextop = next;
5846 loop->op_nextop = o;
5848 o->op_flags |= flags;
5849 o->op_private |= (flags >> 8);
5854 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5856 Constructs, checks, and returns an op tree expressing a C<foreach>
5857 loop (iteration through a list of values). This is a heavyweight loop,
5858 with structure that allows exiting the loop by C<last> and suchlike.
5860 I<sv> optionally supplies the variable that will be aliased to each
5861 item in turn; if null, it defaults to C<$_> (either lexical or global).
5862 I<expr> supplies the list of values to iterate over. I<block> supplies
5863 the main body of the loop, and I<cont> optionally supplies a C<continue>
5864 block that operates as a second half of the body. All of these optree
5865 inputs are consumed by this function and become part of the constructed
5868 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5869 op and, shifted up eight bits, the eight bits of C<op_private> for
5870 the C<leaveloop> op, except that (in both cases) some bits will be set
5877 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5882 PADOFFSET padoff = 0;
5887 PERL_ARGS_ASSERT_NEWFOROP;
5890 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5891 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5892 sv->op_type = OP_RV2GV;
5893 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5895 /* The op_type check is needed to prevent a possible segfault
5896 * if the loop variable is undeclared and 'strict vars' is in
5897 * effect. This is illegal but is nonetheless parsed, so we
5898 * may reach this point with an OP_CONST where we're expecting
5901 if (cUNOPx(sv)->op_first->op_type == OP_GV
5902 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5903 iterpflags |= OPpITER_DEF;
5905 else if (sv->op_type == OP_PADSV) { /* private variable */
5906 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5907 padoff = sv->op_targ;
5917 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5919 SV *const namesv = PAD_COMPNAME_SV(padoff);
5921 const char *const name = SvPV_const(namesv, len);
5923 if (len == 2 && name[0] == '$' && name[1] == '_')
5924 iterpflags |= OPpITER_DEF;
5928 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5929 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5930 sv = newGVOP(OP_GV, 0, PL_defgv);
5935 iterpflags |= OPpITER_DEF;
5937 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5938 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5939 iterflags |= OPf_STACKED;
5941 else if (expr->op_type == OP_NULL &&
5942 (expr->op_flags & OPf_KIDS) &&
5943 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5945 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5946 * set the STACKED flag to indicate that these values are to be
5947 * treated as min/max values by 'pp_iterinit'.
5949 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5950 LOGOP* const range = (LOGOP*) flip->op_first;
5951 OP* const left = range->op_first;
5952 OP* const right = left->op_sibling;
5955 range->op_flags &= ~OPf_KIDS;
5956 range->op_first = NULL;
5958 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5959 listop->op_first->op_next = range->op_next;
5960 left->op_next = range->op_other;
5961 right->op_next = (OP*)listop;
5962 listop->op_next = listop->op_first;
5965 op_getmad(expr,(OP*)listop,'O');
5969 expr = (OP*)(listop);
5971 iterflags |= OPf_STACKED;
5974 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5977 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5978 op_append_elem(OP_LIST, expr, scalar(sv))));
5979 assert(!loop->op_next);
5980 /* for my $x () sets OPpLVAL_INTRO;
5981 * for our $x () sets OPpOUR_INTRO */
5982 loop->op_private = (U8)iterpflags;
5983 #ifdef PL_OP_SLAB_ALLOC
5986 NewOp(1234,tmp,1,LOOP);
5987 Copy(loop,tmp,1,LISTOP);
5988 S_op_destroy(aTHX_ (OP*)loop);
5992 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5994 loop->op_targ = padoff;
5995 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5997 op_getmad(madsv, (OP*)loop, 'v');
6002 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6004 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6005 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6006 determining the target of the op; it is consumed by this function and
6007 become part of the constructed op tree.
6013 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6018 PERL_ARGS_ASSERT_NEWLOOPEX;
6020 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6022 if (type != OP_GOTO || label->op_type == OP_CONST) {
6023 /* "last()" means "last" */
6024 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6025 o = newOP(type, OPf_SPECIAL);
6027 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
6028 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6032 op_getmad(label,o,'L');
6038 /* Check whether it's going to be a goto &function */
6039 if (label->op_type == OP_ENTERSUB
6040 && !(label->op_flags & OPf_STACKED))
6041 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6042 o = newUNOP(type, OPf_STACKED, label);
6044 PL_hints |= HINT_BLOCK_SCOPE;
6048 /* if the condition is a literal array or hash
6049 (or @{ ... } etc), make a reference to it.
6052 S_ref_array_or_hash(pTHX_ OP *cond)
6055 && (cond->op_type == OP_RV2AV
6056 || cond->op_type == OP_PADAV
6057 || cond->op_type == OP_RV2HV
6058 || cond->op_type == OP_PADHV))
6060 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6063 && (cond->op_type == OP_ASLICE
6064 || cond->op_type == OP_HSLICE)) {
6066 /* anonlist now needs a list from this op, was previously used in
6068 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6069 cond->op_flags |= OPf_WANT_LIST;
6071 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6078 /* These construct the optree fragments representing given()
6081 entergiven and enterwhen are LOGOPs; the op_other pointer
6082 points up to the associated leave op. We need this so we
6083 can put it in the context and make break/continue work.
6084 (Also, of course, pp_enterwhen will jump straight to
6085 op_other if the match fails.)
6089 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6090 I32 enter_opcode, I32 leave_opcode,
6091 PADOFFSET entertarg)
6097 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6099 NewOp(1101, enterop, 1, LOGOP);
6100 enterop->op_type = (Optype)enter_opcode;
6101 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6102 enterop->op_flags = (U8) OPf_KIDS;
6103 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6104 enterop->op_private = 0;
6106 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6109 enterop->op_first = scalar(cond);
6110 cond->op_sibling = block;
6112 o->op_next = LINKLIST(cond);
6113 cond->op_next = (OP *) enterop;
6116 /* This is a default {} block */
6117 enterop->op_first = block;
6118 enterop->op_flags |= OPf_SPECIAL;
6119 o ->op_flags |= OPf_SPECIAL;
6121 o->op_next = (OP *) enterop;
6124 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6125 entergiven and enterwhen both
6128 enterop->op_next = LINKLIST(block);
6129 block->op_next = enterop->op_other = o;
6134 /* Does this look like a boolean operation? For these purposes
6135 a boolean operation is:
6136 - a subroutine call [*]
6137 - a logical connective
6138 - a comparison operator
6139 - a filetest operator, with the exception of -s -M -A -C
6140 - defined(), exists() or eof()
6141 - /$re/ or $foo =~ /$re/
6143 [*] possibly surprising
6146 S_looks_like_bool(pTHX_ const OP *o)
6150 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6152 switch(o->op_type) {
6155 return looks_like_bool(cLOGOPo->op_first);
6159 looks_like_bool(cLOGOPo->op_first)
6160 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6165 o->op_flags & OPf_KIDS
6166 && looks_like_bool(cUNOPo->op_first));
6170 case OP_NOT: case OP_XOR:
6172 case OP_EQ: case OP_NE: case OP_LT:
6173 case OP_GT: case OP_LE: case OP_GE:
6175 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6176 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6178 case OP_SEQ: case OP_SNE: case OP_SLT:
6179 case OP_SGT: case OP_SLE: case OP_SGE:
6183 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6184 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6185 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6186 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6187 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6188 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6189 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6190 case OP_FTTEXT: case OP_FTBINARY:
6192 case OP_DEFINED: case OP_EXISTS:
6193 case OP_MATCH: case OP_EOF:
6200 /* Detect comparisons that have been optimized away */
6201 if (cSVOPo->op_sv == &PL_sv_yes
6202 || cSVOPo->op_sv == &PL_sv_no)
6215 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6217 Constructs, checks, and returns an op tree expressing a C<given> block.
6218 I<cond> supplies the expression that will be locally assigned to a lexical
6219 variable, and I<block> supplies the body of the C<given> construct; they
6220 are consumed by this function and become part of the constructed op tree.
6221 I<defsv_off> is the pad offset of the scalar lexical variable that will
6228 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6231 PERL_ARGS_ASSERT_NEWGIVENOP;
6232 return newGIVWHENOP(
6233 ref_array_or_hash(cond),
6235 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6240 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6242 Constructs, checks, and returns an op tree expressing a C<when> block.
6243 I<cond> supplies the test expression, and I<block> supplies the block
6244 that will be executed if the test evaluates to true; they are consumed
6245 by this function and become part of the constructed op tree. I<cond>
6246 will be interpreted DWIMically, often as a comparison against C<$_>,
6247 and may be null to generate a C<default> block.
6253 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6255 const bool cond_llb = (!cond || looks_like_bool(cond));
6258 PERL_ARGS_ASSERT_NEWWHENOP;
6263 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6265 scalar(ref_array_or_hash(cond)));
6268 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6272 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6273 const STRLEN len, const U32 flags)
6275 const char * const cvp = CvPROTO(cv);
6276 const STRLEN clen = CvPROTOLEN(cv);
6278 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6280 if (((!p != !cvp) /* One has prototype, one has not. */
6282 (flags & SVf_UTF8) == SvUTF8(cv)
6283 ? len != clen || memNE(cvp, p, len)
6285 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6287 : bytes_cmp_utf8((const U8 *)p, len,
6288 (const U8 *)cvp, clen)
6292 && ckWARN_d(WARN_PROTOTYPE)) {
6293 SV* const msg = sv_newmortal();
6297 gv_efullname3(name = sv_newmortal(), gv, NULL);
6298 sv_setpvs(msg, "Prototype mismatch:");
6300 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6302 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6303 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6306 sv_catpvs(msg, ": none");
6307 sv_catpvs(msg, " vs ");
6309 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6311 sv_catpvs(msg, "none");
6312 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6316 static void const_sv_xsub(pTHX_ CV* cv);
6320 =head1 Optree Manipulation Functions
6322 =for apidoc cv_const_sv
6324 If C<cv> is a constant sub eligible for inlining. returns the constant
6325 value returned by the sub. Otherwise, returns NULL.
6327 Constant subs can be created with C<newCONSTSUB> or as described in
6328 L<perlsub/"Constant Functions">.
6333 Perl_cv_const_sv(pTHX_ const CV *const cv)
6335 PERL_UNUSED_CONTEXT;
6338 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6340 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6343 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6344 * Can be called in 3 ways:
6347 * look for a single OP_CONST with attached value: return the value
6349 * cv && CvCLONE(cv) && !CvCONST(cv)
6351 * examine the clone prototype, and if contains only a single
6352 * OP_CONST referencing a pad const, or a single PADSV referencing
6353 * an outer lexical, return a non-zero value to indicate the CV is
6354 * a candidate for "constizing" at clone time
6358 * We have just cloned an anon prototype that was marked as a const
6359 * candidate. Try to grab the current value, and in the case of
6360 * PADSV, ignore it if it has multiple references. Return the value.
6364 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6375 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6376 o = cLISTOPo->op_first->op_sibling;
6378 for (; o; o = o->op_next) {
6379 const OPCODE type = o->op_type;
6381 if (sv && o->op_next == o)
6383 if (o->op_next != o) {
6384 if (type == OP_NEXTSTATE
6385 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6386 || type == OP_PUSHMARK)
6388 if (type == OP_DBSTATE)
6391 if (type == OP_LEAVESUB || type == OP_RETURN)
6395 if (type == OP_CONST && cSVOPo->op_sv)
6397 else if (cv && type == OP_CONST) {
6398 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6402 else if (cv && type == OP_PADSV) {
6403 if (CvCONST(cv)) { /* newly cloned anon */
6404 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6405 /* the candidate should have 1 ref from this pad and 1 ref
6406 * from the parent */
6407 if (!sv || SvREFCNT(sv) != 2)
6414 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6415 sv = &PL_sv_undef; /* an arbitrary non-null value */
6430 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6433 /* This would be the return value, but the return cannot be reached. */
6434 OP* pegop = newOP(OP_NULL, 0);
6437 PERL_UNUSED_ARG(floor);
6447 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6449 NORETURN_FUNCTION_END;
6454 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6456 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
6460 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
6461 OP *block, U32 flags)
6466 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6468 register CV *cv = NULL;
6470 /* If the subroutine has no body, no attributes, and no builtin attributes
6471 then it's just a sub declaration, and we may be able to get away with
6472 storing with a placeholder scalar in the symbol table, rather than a
6473 full GV and CV. If anything is present then it will take a full CV to
6475 const I32 gv_fetch_flags
6476 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6478 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6480 const bool o_is_gv = flags & 1;
6481 const char * const name =
6482 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
6484 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
6487 assert(proto->op_type == OP_CONST);
6488 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6489 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6499 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6501 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6502 SV * const sv = sv_newmortal();
6503 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6504 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6505 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6506 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6508 } else if (PL_curstash) {
6509 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6512 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6516 if (!PL_madskills) {
6525 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6526 maximum a prototype before. */
6527 if (SvTYPE(gv) > SVt_NULL) {
6528 if (!SvPOK((const SV *)gv)
6529 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6531 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6533 cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
6536 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6537 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
6540 sv_setiv(MUTABLE_SV(gv), -1);
6542 SvREFCNT_dec(PL_compcv);
6543 cv = PL_compcv = NULL;
6547 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6549 if (!block || !ps || *ps || attrs
6550 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6552 || block->op_type == OP_NULL
6557 const_sv = op_const_sv(block, NULL);
6560 const bool exists = CvROOT(cv) || CvXSUB(cv);
6562 /* if the subroutine doesn't exist and wasn't pre-declared
6563 * with a prototype, assume it will be AUTOLOADed,
6564 * skipping the prototype check
6566 if (exists || SvPOK(cv))
6567 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
6568 /* already defined (or promised)? */
6569 if (exists || GvASSUMECV(gv)) {
6572 || block->op_type == OP_NULL
6575 if (CvFLAGS(PL_compcv)) {
6576 /* might have had built-in attrs applied */
6577 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6578 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6579 && ckWARN(WARN_MISC))
6580 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6582 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6583 & ~(CVf_LVALUE * pureperl));
6585 if (attrs) goto attrs;
6586 /* just a "sub foo;" when &foo is already defined */
6587 SAVEFREESV(PL_compcv);
6592 && block->op_type != OP_NULL
6595 const line_t oldline = CopLINE(PL_curcop);
6596 if (PL_parser && PL_parser->copline != NOLINE)
6597 CopLINE_set(PL_curcop, PL_parser->copline);
6598 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
6599 CopLINE_set(PL_curcop, oldline);
6601 if (!PL_minus_c) /* keep old one around for madskills */
6604 /* (PL_madskills unset in used file.) */
6613 SvREFCNT_inc_simple_void_NN(const_sv);
6615 assert(!CvROOT(cv) && !CvCONST(cv));
6616 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6617 CvXSUBANY(cv).any_ptr = const_sv;
6618 CvXSUB(cv) = const_sv_xsub;
6624 cv = newCONSTSUB_flags(
6625 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
6630 (CvGV(cv) && GvSTASH(CvGV(cv)))
6635 if (HvENAME_HEK(stash))
6636 mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
6640 SvREFCNT_dec(PL_compcv);
6644 if (cv) { /* must reuse cv if autoloaded */
6645 /* transfer PL_compcv to cv */
6648 && block->op_type != OP_NULL
6651 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6652 AV *const temp_av = CvPADLIST(cv);
6653 CV *const temp_cv = CvOUTSIDE(cv);
6655 assert(!CvWEAKOUTSIDE(cv));
6656 assert(!CvCVGV_RC(cv));
6657 assert(CvGV(cv) == gv);
6660 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6661 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6662 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6663 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6664 CvOUTSIDE(PL_compcv) = temp_cv;
6665 CvPADLIST(PL_compcv) = temp_av;
6667 if (CvFILE(cv) && CvDYNFILE(cv)) {
6668 Safefree(CvFILE(cv));
6670 CvFILE_set_from_cop(cv, PL_curcop);
6671 CvSTASH_set(cv, PL_curstash);
6673 /* inner references to PL_compcv must be fixed up ... */
6674 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6675 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6676 ++PL_sub_generation;
6679 /* Might have had built-in attributes applied -- propagate them. */
6680 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6682 /* ... before we throw it away */
6683 SvREFCNT_dec(PL_compcv);
6691 if (strEQ(name, "import")) {
6692 PL_formfeed = MUTABLE_SV(cv);
6693 /* diag_listed_as: SKIPME */
6694 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6698 if (HvENAME_HEK(GvSTASH(gv)))
6699 /* sub Foo::bar { (shift)+1 } */
6700 mro_method_changed_in(GvSTASH(gv));
6705 CvFILE_set_from_cop(cv, PL_curcop);
6706 CvSTASH_set(cv, PL_curstash);
6710 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6711 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
6714 if (PL_parser && PL_parser->error_count) {
6718 const char *s = strrchr(name, ':');
6720 if (strEQ(s, "BEGIN")) {
6721 const char not_safe[] =
6722 "BEGIN not safe after errors--compilation aborted";
6723 if (PL_in_eval & EVAL_KEEPERR)
6724 Perl_croak(aTHX_ not_safe);
6726 /* force display of errors found but not reported */
6727 sv_catpv(ERRSV, not_safe);
6728 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6737 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6738 the debugger could be able to set a breakpoint in, so signal to
6739 pp_entereval that it should not throw away any saved lines at scope
6742 PL_breakable_sub_gen++;
6743 /* This makes sub {}; work as expected. */
6744 if (block->op_type == OP_STUB) {
6745 OP* const newblock = newSTATEOP(0, NULL, 0);
6747 op_getmad(block,newblock,'B');
6753 else block->op_attached = 1;
6754 CvROOT(cv) = CvLVALUE(cv)
6755 ? newUNOP(OP_LEAVESUBLV, 0,
6756 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6757 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6758 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6759 OpREFCNT_set(CvROOT(cv), 1);
6760 CvSTART(cv) = LINKLIST(CvROOT(cv));
6761 CvROOT(cv)->op_next = 0;
6762 CALL_PEEP(CvSTART(cv));
6763 finalize_optree(CvROOT(cv));
6765 /* now that optimizer has done its work, adjust pad values */
6767 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6770 assert(!CvCONST(cv));
6771 if (ps && !*ps && op_const_sv(block, cv))
6777 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6778 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6779 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6782 if (block && has_name) {
6783 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6784 SV * const tmpstr = sv_newmortal();
6785 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6786 GV_ADDMULTI, SVt_PVHV);
6788 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6791 (long)CopLINE(PL_curcop));
6792 gv_efullname3(tmpstr, gv, NULL);
6793 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6794 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
6795 hv = GvHVn(db_postponed);
6796 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
6797 CV * const pcv = GvCV(db_postponed);
6803 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6808 if (name && ! (PL_parser && PL_parser->error_count))
6809 process_special_blocks(name, gv, cv);
6814 PL_parser->copline = NOLINE;
6820 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6823 const char *const colon = strrchr(fullname,':');
6824 const char *const name = colon ? colon + 1 : fullname;
6826 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6829 if (strEQ(name, "BEGIN")) {
6830 const I32 oldscope = PL_scopestack_ix;
6832 SAVECOPFILE(&PL_compiling);
6833 SAVECOPLINE(&PL_compiling);
6834 SAVEVPTR(PL_curcop);
6836 DEBUG_x( dump_sub(gv) );
6837 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6838 GvCV_set(gv,0); /* cv has been hijacked */
6839 call_list(oldscope, PL_beginav);
6841 CopHINTS_set(&PL_compiling, PL_hints);
6848 if strEQ(name, "END") {
6849 DEBUG_x( dump_sub(gv) );
6850 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6853 } else if (*name == 'U') {
6854 if (strEQ(name, "UNITCHECK")) {
6855 /* It's never too late to run a unitcheck block */
6856 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6860 } else if (*name == 'C') {
6861 if (strEQ(name, "CHECK")) {
6863 /* diag_listed_as: Too late to run %s block */
6864 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6865 "Too late to run CHECK block");
6866 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6870 } else if (*name == 'I') {
6871 if (strEQ(name, "INIT")) {
6873 /* diag_listed_as: Too late to run %s block */
6874 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6875 "Too late to run INIT block");
6876 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6882 DEBUG_x( dump_sub(gv) );
6883 GvCV_set(gv,0); /* cv has been hijacked */
6888 =for apidoc newCONSTSUB
6890 See L</newCONSTSUB_flags>.
6896 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6898 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
6902 =for apidoc newCONSTSUB_flags
6904 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6905 eligible for inlining at compile-time.
6907 Currently, the only useful value for C<flags> is SVf_UTF8.
6909 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6910 which won't be called if used as a destructor, but will suppress the overhead
6911 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6918 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
6924 const char *const file = CopFILE(PL_curcop);
6926 SV *const temp_sv = CopFILESV(PL_curcop);
6927 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6932 if (IN_PERL_RUNTIME) {
6933 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6934 * an op shared between threads. Use a non-shared COP for our
6936 SAVEVPTR(PL_curcop);
6937 SAVECOMPILEWARNINGS();
6938 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6939 PL_curcop = &PL_compiling;
6941 SAVECOPLINE(PL_curcop);
6942 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6945 PL_hints &= ~HINT_BLOCK_SCOPE;
6948 SAVEGENERICSV(PL_curstash);
6949 SAVECOPSTASH(PL_curcop);
6950 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
6951 CopSTASH_set(PL_curcop,stash);
6954 /* file becomes the CvFILE. For an XS, it's usually static storage,
6955 and so doesn't get free()d. (It's expected to be from the C pre-
6956 processor __FILE__ directive). But we need a dynamically allocated one,
6957 and we need it to get freed. */
6958 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
6959 &sv, XS_DYNAMIC_FILENAME | flags);
6960 CvXSUBANY(cv).any_ptr = sv;
6965 CopSTASH_free(PL_curcop);
6973 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6974 const char *const filename, const char *const proto,
6977 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6978 return newXS_len_flags(
6979 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
6984 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
6985 XSUBADDR_t subaddr, const char *const filename,
6986 const char *const proto, SV **const_svp,
6991 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
6994 GV * const gv = name
6996 name,len,GV_ADDMULTI|flags,SVt_PVCV
6999 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
7000 GV_ADDMULTI | flags, SVt_PVCV);
7003 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7005 if ((cv = (name ? GvCV(gv) : NULL))) {
7007 /* just a cached method */
7011 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7012 /* already defined (or promised) */
7013 /* Redundant check that allows us to avoid creating an SV
7014 most of the time: */
7015 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7016 const line_t oldline = CopLINE(PL_curcop);
7017 if (PL_parser && PL_parser->copline != NOLINE)
7018 CopLINE_set(PL_curcop, PL_parser->copline);
7019 report_redefined_cv(newSVpvn_flags(
7020 name,len,(flags&SVf_UTF8)|SVs_TEMP
7023 CopLINE_set(PL_curcop, oldline);
7030 if (cv) /* must reuse cv if autoloaded */
7033 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7037 if (HvENAME_HEK(GvSTASH(gv)))
7038 mro_method_changed_in(GvSTASH(gv)); /* newXS */
7044 (void)gv_fetchfile(filename);
7045 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7046 an external constant string */
7047 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7049 CvXSUB(cv) = subaddr;
7052 process_special_blocks(name, gv, cv);
7055 if (flags & XS_DYNAMIC_FILENAME) {
7056 CvFILE(cv) = savepv(filename);
7059 sv_setpv(MUTABLE_SV(cv), proto);
7064 =for apidoc U||newXS
7066 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7067 static storage, as it is used directly as CvFILE(), without a copy being made.
7073 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7075 PERL_ARGS_ASSERT_NEWXS;
7076 return newXS_flags(name, subaddr, filename, NULL, 0);
7084 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7089 OP* pegop = newOP(OP_NULL, 0);
7093 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7094 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7097 if ((cv = GvFORM(gv))) {
7098 if (ckWARN(WARN_REDEFINE)) {
7099 const line_t oldline = CopLINE(PL_curcop);
7100 if (PL_parser && PL_parser->copline != NOLINE)
7101 CopLINE_set(PL_curcop, PL_parser->copline);
7103 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7104 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7106 /* diag_listed_as: Format %s redefined */
7107 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7108 "Format STDOUT redefined");
7110 CopLINE_set(PL_curcop, oldline);
7117 CvFILE_set_from_cop(cv, PL_curcop);
7120 pad_tidy(padtidy_FORMAT);
7121 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7122 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7123 OpREFCNT_set(CvROOT(cv), 1);
7124 CvSTART(cv) = LINKLIST(CvROOT(cv));
7125 CvROOT(cv)->op_next = 0;
7126 CALL_PEEP(CvSTART(cv));
7127 finalize_optree(CvROOT(cv));
7129 op_getmad(o,pegop,'n');
7130 op_getmad_weak(block, pegop, 'b');
7135 PL_parser->copline = NOLINE;
7143 Perl_newANONLIST(pTHX_ OP *o)
7145 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7149 Perl_newANONHASH(pTHX_ OP *o)
7151 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7155 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7157 return newANONATTRSUB(floor, proto, NULL, block);
7161 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7163 return newUNOP(OP_REFGEN, 0,
7164 newSVOP(OP_ANONCODE, 0,
7165 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7169 Perl_oopsAV(pTHX_ OP *o)
7173 PERL_ARGS_ASSERT_OOPSAV;
7175 switch (o->op_type) {
7177 o->op_type = OP_PADAV;
7178 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7179 return ref(o, OP_RV2AV);
7182 o->op_type = OP_RV2AV;
7183 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7188 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7195 Perl_oopsHV(pTHX_ OP *o)
7199 PERL_ARGS_ASSERT_OOPSHV;
7201 switch (o->op_type) {
7204 o->op_type = OP_PADHV;
7205 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7206 return ref(o, OP_RV2HV);
7210 o->op_type = OP_RV2HV;
7211 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7216 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7223 Perl_newAVREF(pTHX_ OP *o)
7227 PERL_ARGS_ASSERT_NEWAVREF;
7229 if (o->op_type == OP_PADANY) {
7230 o->op_type = OP_PADAV;
7231 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7234 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7235 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7236 "Using an array as a reference is deprecated");
7238 return newUNOP(OP_RV2AV, 0, scalar(o));
7242 Perl_newGVREF(pTHX_ I32 type, OP *o)
7244 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7245 return newUNOP(OP_NULL, 0, o);
7246 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7250 Perl_newHVREF(pTHX_ OP *o)
7254 PERL_ARGS_ASSERT_NEWHVREF;
7256 if (o->op_type == OP_PADANY) {
7257 o->op_type = OP_PADHV;
7258 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7261 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7262 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7263 "Using a hash as a reference is deprecated");
7265 return newUNOP(OP_RV2HV, 0, scalar(o));
7269 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7271 return newUNOP(OP_RV2CV, flags, scalar(o));
7275 Perl_newSVREF(pTHX_ OP *o)
7279 PERL_ARGS_ASSERT_NEWSVREF;
7281 if (o->op_type == OP_PADANY) {
7282 o->op_type = OP_PADSV;
7283 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7286 return newUNOP(OP_RV2SV, 0, scalar(o));
7289 /* Check routines. See the comments at the top of this file for details
7290 * on when these are called */
7293 Perl_ck_anoncode(pTHX_ OP *o)
7295 PERL_ARGS_ASSERT_CK_ANONCODE;
7297 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7299 cSVOPo->op_sv = NULL;
7304 Perl_ck_bitop(pTHX_ OP *o)
7308 PERL_ARGS_ASSERT_CK_BITOP;
7310 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7311 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7312 && (o->op_type == OP_BIT_OR
7313 || o->op_type == OP_BIT_AND
7314 || o->op_type == OP_BIT_XOR))
7316 const OP * const left = cBINOPo->op_first;
7317 const OP * const right = left->op_sibling;
7318 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7319 (left->op_flags & OPf_PARENS) == 0) ||
7320 (OP_IS_NUMCOMPARE(right->op_type) &&
7321 (right->op_flags & OPf_PARENS) == 0))
7322 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7323 "Possible precedence problem on bitwise %c operator",
7324 o->op_type == OP_BIT_OR ? '|'
7325 : o->op_type == OP_BIT_AND ? '&' : '^'
7331 PERL_STATIC_INLINE bool
7332 is_dollar_bracket(pTHX_ const OP * const o)
7335 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
7336 && (kid = cUNOPx(o)->op_first)
7337 && kid->op_type == OP_GV
7338 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
7342 Perl_ck_cmp(pTHX_ OP *o)
7344 PERL_ARGS_ASSERT_CK_CMP;
7345 if (ckWARN(WARN_SYNTAX)) {
7346 const OP *kid = cUNOPo->op_first;
7349 is_dollar_bracket(aTHX_ kid)
7350 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
7352 || ( kid->op_type == OP_CONST
7353 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
7355 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7356 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
7362 Perl_ck_concat(pTHX_ OP *o)
7364 const OP * const kid = cUNOPo->op_first;
7366 PERL_ARGS_ASSERT_CK_CONCAT;
7367 PERL_UNUSED_CONTEXT;
7369 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7370 !(kUNOP->op_first->op_flags & OPf_MOD))
7371 o->op_flags |= OPf_STACKED;
7376 Perl_ck_spair(pTHX_ OP *o)
7380 PERL_ARGS_ASSERT_CK_SPAIR;
7382 if (o->op_flags & OPf_KIDS) {
7385 const OPCODE type = o->op_type;
7386 o = modkids(ck_fun(o), type);
7387 kid = cUNOPo->op_first;
7388 newop = kUNOP->op_first->op_sibling;
7390 const OPCODE type = newop->op_type;
7391 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7392 type == OP_PADAV || type == OP_PADHV ||
7393 type == OP_RV2AV || type == OP_RV2HV)
7397 op_getmad(kUNOP->op_first,newop,'K');
7399 op_free(kUNOP->op_first);
7401 kUNOP->op_first = newop;
7403 o->op_ppaddr = PL_ppaddr[++o->op_type];
7408 Perl_ck_delete(pTHX_ OP *o)
7410 PERL_ARGS_ASSERT_CK_DELETE;
7414 if (o->op_flags & OPf_KIDS) {
7415 OP * const kid = cUNOPo->op_first;
7416 switch (kid->op_type) {
7418 o->op_flags |= OPf_SPECIAL;
7421 o->op_private |= OPpSLICE;
7424 o->op_flags |= OPf_SPECIAL;
7429 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7432 if (kid->op_private & OPpLVAL_INTRO)
7433 o->op_private |= OPpLVAL_INTRO;
7440 Perl_ck_die(pTHX_ OP *o)
7442 PERL_ARGS_ASSERT_CK_DIE;
7445 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7451 Perl_ck_eof(pTHX_ OP *o)
7455 PERL_ARGS_ASSERT_CK_EOF;
7457 if (o->op_flags & OPf_KIDS) {
7459 if (cLISTOPo->op_first->op_type == OP_STUB) {
7461 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7463 op_getmad(o,newop,'O');
7470 kid = cLISTOPo->op_first;
7471 if (kid->op_type == OP_RV2GV)
7472 kid->op_private |= OPpALLOW_FAKE;
7478 Perl_ck_eval(pTHX_ OP *o)
7482 PERL_ARGS_ASSERT_CK_EVAL;
7484 PL_hints |= HINT_BLOCK_SCOPE;
7485 if (o->op_flags & OPf_KIDS) {
7486 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7489 o->op_flags &= ~OPf_KIDS;
7492 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7498 cUNOPo->op_first = 0;
7503 NewOp(1101, enter, 1, LOGOP);
7504 enter->op_type = OP_ENTERTRY;
7505 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7506 enter->op_private = 0;
7508 /* establish postfix order */
7509 enter->op_next = (OP*)enter;
7511 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7512 o->op_type = OP_LEAVETRY;
7513 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7514 enter->op_other = o;
7515 op_getmad(oldo,o,'O');
7524 const U8 priv = o->op_private;
7530 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
7531 op_getmad(oldo,o,'O');
7533 o->op_targ = (PADOFFSET)PL_hints;
7534 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7535 if ((PL_hints & HINT_LOCALIZE_HH) != 0
7536 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
7537 /* Store a copy of %^H that pp_entereval can pick up. */
7538 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7539 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7540 cUNOPo->op_first->op_sibling = hhop;
7541 o->op_private |= OPpEVAL_HAS_HH;
7543 if (!(o->op_private & OPpEVAL_BYTES)
7544 && FEATURE_UNIEVAL_IS_ENABLED)
7545 o->op_private |= OPpEVAL_UNICODE;
7551 Perl_ck_exit(pTHX_ OP *o)
7553 PERL_ARGS_ASSERT_CK_EXIT;
7556 HV * const table = GvHV(PL_hintgv);
7558 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7559 if (svp && *svp && SvTRUE(*svp))
7560 o->op_private |= OPpEXIT_VMSISH;
7562 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7568 Perl_ck_exec(pTHX_ OP *o)
7570 PERL_ARGS_ASSERT_CK_EXEC;
7572 if (o->op_flags & OPf_STACKED) {
7575 kid = cUNOPo->op_first->op_sibling;
7576 if (kid->op_type == OP_RV2GV)
7585 Perl_ck_exists(pTHX_ OP *o)
7589 PERL_ARGS_ASSERT_CK_EXISTS;
7592 if (o->op_flags & OPf_KIDS) {
7593 OP * const kid = cUNOPo->op_first;
7594 if (kid->op_type == OP_ENTERSUB) {
7595 (void) ref(kid, o->op_type);
7596 if (kid->op_type != OP_RV2CV
7597 && !(PL_parser && PL_parser->error_count))
7598 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7600 o->op_private |= OPpEXISTS_SUB;
7602 else if (kid->op_type == OP_AELEM)
7603 o->op_flags |= OPf_SPECIAL;
7604 else if (kid->op_type != OP_HELEM)
7605 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7613 Perl_ck_rvconst(pTHX_ register OP *o)
7616 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7618 PERL_ARGS_ASSERT_CK_RVCONST;
7620 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7621 if (o->op_type == OP_RV2CV)
7622 o->op_private &= ~1;
7624 if (kid->op_type == OP_CONST) {
7627 SV * const kidsv = kid->op_sv;
7629 /* Is it a constant from cv_const_sv()? */
7630 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7631 SV * const rsv = SvRV(kidsv);
7632 const svtype type = SvTYPE(rsv);
7633 const char *badtype = NULL;
7635 switch (o->op_type) {
7637 if (type > SVt_PVMG)
7638 badtype = "a SCALAR";
7641 if (type != SVt_PVAV)
7642 badtype = "an ARRAY";
7645 if (type != SVt_PVHV)
7649 if (type != SVt_PVCV)
7654 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7657 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7658 const char *badthing;
7659 switch (o->op_type) {
7661 badthing = "a SCALAR";
7664 badthing = "an ARRAY";
7667 badthing = "a HASH";
7675 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7676 SVfARG(kidsv), badthing);
7679 * This is a little tricky. We only want to add the symbol if we
7680 * didn't add it in the lexer. Otherwise we get duplicate strict
7681 * warnings. But if we didn't add it in the lexer, we must at
7682 * least pretend like we wanted to add it even if it existed before,
7683 * or we get possible typo warnings. OPpCONST_ENTERED says
7684 * whether the lexer already added THIS instance of this symbol.
7686 iscv = (o->op_type == OP_RV2CV) * 2;
7688 gv = gv_fetchsv(kidsv,
7689 iscv | !(kid->op_private & OPpCONST_ENTERED),
7692 : o->op_type == OP_RV2SV
7694 : o->op_type == OP_RV2AV
7696 : o->op_type == OP_RV2HV
7699 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7701 kid->op_type = OP_GV;
7702 SvREFCNT_dec(kid->op_sv);
7704 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7705 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7706 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7708 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7710 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7712 kid->op_private = 0;
7713 kid->op_ppaddr = PL_ppaddr[OP_GV];
7714 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7722 Perl_ck_ftst(pTHX_ OP *o)
7725 const I32 type = o->op_type;
7727 PERL_ARGS_ASSERT_CK_FTST;
7729 if (o->op_flags & OPf_REF) {
7732 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7733 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7734 const OPCODE kidtype = kid->op_type;
7736 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7737 OP * const newop = newGVOP(type, OPf_REF,
7738 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7740 op_getmad(o,newop,'O');
7746 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7747 o->op_private |= OPpFT_ACCESS;
7748 if (PL_check[kidtype] == Perl_ck_ftst
7749 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7750 o->op_private |= OPpFT_STACKED;
7751 kid->op_private |= OPpFT_STACKING;
7752 if (kidtype == OP_FTTTY && (
7753 !(kid->op_private & OPpFT_STACKED)
7754 || kid->op_private & OPpFT_AFTER_t
7756 o->op_private |= OPpFT_AFTER_t;
7765 if (type == OP_FTTTY)
7766 o = newGVOP(type, OPf_REF, PL_stdingv);
7768 o = newUNOP(type, 0, newDEFSVOP());
7769 op_getmad(oldo,o,'O');
7775 Perl_ck_fun(pTHX_ OP *o)
7778 const int type = o->op_type;
7779 register I32 oa = PL_opargs[type] >> OASHIFT;
7781 PERL_ARGS_ASSERT_CK_FUN;
7783 if (o->op_flags & OPf_STACKED) {
7784 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7787 return no_fh_allowed(o);
7790 if (o->op_flags & OPf_KIDS) {
7791 OP **tokid = &cLISTOPo->op_first;
7792 register OP *kid = cLISTOPo->op_first;
7795 bool seen_optional = FALSE;
7797 if (kid->op_type == OP_PUSHMARK ||
7798 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7800 tokid = &kid->op_sibling;
7801 kid = kid->op_sibling;
7803 if (kid && kid->op_type == OP_COREARGS) {
7804 bool optional = FALSE;
7807 if (oa & OA_OPTIONAL) optional = TRUE;
7810 if (optional) o->op_private |= numargs;
7815 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
7816 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
7817 *tokid = kid = newDEFSVOP();
7818 seen_optional = TRUE;
7823 sibl = kid->op_sibling;
7825 if (!sibl && kid->op_type == OP_STUB) {
7832 /* list seen where single (scalar) arg expected? */
7833 if (numargs == 1 && !(oa >> 4)
7834 && kid->op_type == OP_LIST && type != OP_SCALAR)
7836 return too_many_arguments(o,PL_op_desc[type]);
7849 if ((type == OP_PUSH || type == OP_UNSHIFT)
7850 && !kid->op_sibling)
7851 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7852 "Useless use of %s with no values",
7855 if (kid->op_type == OP_CONST &&
7856 (kid->op_private & OPpCONST_BARE))
7858 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7859 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7860 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7861 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7862 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7864 op_getmad(kid,newop,'K');
7869 kid->op_sibling = sibl;
7872 else if (kid->op_type == OP_CONST
7873 && ( !SvROK(cSVOPx_sv(kid))
7874 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7876 bad_type(numargs, "array", PL_op_desc[type], kid);
7877 /* Defer checks to run-time if we have a scalar arg */
7878 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7879 op_lvalue(kid, type);
7883 if (kid->op_type == OP_CONST &&
7884 (kid->op_private & OPpCONST_BARE))
7886 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7887 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7888 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7889 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7890 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7892 op_getmad(kid,newop,'K');
7897 kid->op_sibling = sibl;
7900 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7901 bad_type(numargs, "hash", PL_op_desc[type], kid);
7902 op_lvalue(kid, type);
7906 OP * const newop = newUNOP(OP_NULL, 0, kid);
7907 kid->op_sibling = 0;
7909 newop->op_next = newop;
7911 kid->op_sibling = sibl;
7916 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7917 if (kid->op_type == OP_CONST &&
7918 (kid->op_private & OPpCONST_BARE))
7920 OP * const newop = newGVOP(OP_GV, 0,
7921 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7922 if (!(o->op_private & 1) && /* if not unop */
7923 kid == cLISTOPo->op_last)
7924 cLISTOPo->op_last = newop;
7926 op_getmad(kid,newop,'K');
7932 else if (kid->op_type == OP_READLINE) {
7933 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7934 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7937 I32 flags = OPf_SPECIAL;
7941 /* is this op a FH constructor? */
7942 if (is_handle_constructor(o,numargs)) {
7943 const char *name = NULL;
7946 bool want_dollar = TRUE;
7949 /* Set a flag to tell rv2gv to vivify
7950 * need to "prove" flag does not mean something
7951 * else already - NI-S 1999/05/07
7954 if (kid->op_type == OP_PADSV) {
7956 = PAD_COMPNAME_SV(kid->op_targ);
7957 name = SvPV_const(namesv, len);
7958 name_utf8 = SvUTF8(namesv);
7960 else if (kid->op_type == OP_RV2SV
7961 && kUNOP->op_first->op_type == OP_GV)
7963 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7965 len = GvNAMELEN(gv);
7966 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
7968 else if (kid->op_type == OP_AELEM
7969 || kid->op_type == OP_HELEM)
7972 OP *op = ((BINOP*)kid)->op_first;
7976 const char * const a =
7977 kid->op_type == OP_AELEM ?
7979 if (((op->op_type == OP_RV2AV) ||
7980 (op->op_type == OP_RV2HV)) &&
7981 (firstop = ((UNOP*)op)->op_first) &&
7982 (firstop->op_type == OP_GV)) {
7983 /* packagevar $a[] or $h{} */
7984 GV * const gv = cGVOPx_gv(firstop);
7992 else if (op->op_type == OP_PADAV
7993 || op->op_type == OP_PADHV) {
7994 /* lexicalvar $a[] or $h{} */
7995 const char * const padname =
7996 PAD_COMPNAME_PV(op->op_targ);
8005 name = SvPV_const(tmpstr, len);
8006 name_utf8 = SvUTF8(tmpstr);
8011 name = "__ANONIO__";
8013 want_dollar = FALSE;
8015 op_lvalue(kid, type);
8019 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
8020 namesv = PAD_SVl(targ);
8021 SvUPGRADE(namesv, SVt_PV);
8022 if (want_dollar && *name != '$')
8023 sv_setpvs(namesv, "$");
8024 sv_catpvn(namesv, name, len);
8025 if ( name_utf8 ) SvUTF8_on(namesv);
8028 kid->op_sibling = 0;
8029 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8030 kid->op_targ = targ;
8031 kid->op_private |= priv;
8033 kid->op_sibling = sibl;
8039 op_lvalue(scalar(kid), type);
8043 tokid = &kid->op_sibling;
8044 kid = kid->op_sibling;
8047 if (kid && kid->op_type != OP_STUB)
8048 return too_many_arguments(o,OP_DESC(o));
8049 o->op_private |= numargs;
8051 /* FIXME - should the numargs move as for the PERL_MAD case? */
8052 o->op_private |= numargs;
8054 return too_many_arguments(o,OP_DESC(o));
8058 else if (PL_opargs[type] & OA_DEFGV) {
8060 OP *newop = newUNOP(type, 0, newDEFSVOP());
8061 op_getmad(o,newop,'O');
8064 /* Ordering of these two is important to keep f_map.t passing. */
8066 return newUNOP(type, 0, newDEFSVOP());
8071 while (oa & OA_OPTIONAL)
8073 if (oa && oa != OA_LIST)
8074 return too_few_arguments(o,OP_DESC(o));
8080 Perl_ck_glob(pTHX_ OP *o)
8084 const bool core = o->op_flags & OPf_SPECIAL;
8086 PERL_ARGS_ASSERT_CK_GLOB;
8089 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8090 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8092 if (core) gv = NULL;
8093 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
8094 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8096 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
8099 #if !defined(PERL_EXTERNAL_GLOB)
8100 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8102 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8103 newSVpvs("File::Glob"), NULL, NULL, NULL);
8106 #endif /* !PERL_EXTERNAL_GLOB */
8108 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8111 * \ null - const(wildcard)
8116 * \ mark - glob - rv2cv
8117 * | \ gv(CORE::GLOBAL::glob)
8119 * \ null - const(wildcard) - const(ix)
8121 o->op_flags |= OPf_SPECIAL;
8122 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8123 op_append_elem(OP_GLOB, o,
8124 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
8125 o = newLISTOP(OP_LIST, 0, o, NULL);
8126 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
8127 op_append_elem(OP_LIST, o,
8128 scalar(newUNOP(OP_RV2CV, 0,
8129 newGVOP(OP_GV, 0, gv)))));
8130 o = newUNOP(OP_NULL, 0, ck_subr(o));
8131 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8134 else o->op_flags &= ~OPf_SPECIAL;
8135 gv = newGVgen("main");
8137 #ifndef PERL_EXTERNAL_GLOB
8138 sv_setiv(GvSVn(gv),PL_glob_index++);
8140 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8146 Perl_ck_grep(pTHX_ OP *o)
8151 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8154 PERL_ARGS_ASSERT_CK_GREP;
8156 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8157 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8159 if (o->op_flags & OPf_STACKED) {
8162 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8163 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8164 return no_fh_allowed(o);
8165 for (k = kid; k; k = k->op_next) {
8168 NewOp(1101, gwop, 1, LOGOP);
8169 kid->op_next = (OP*)gwop;
8170 o->op_flags &= ~OPf_STACKED;
8172 kid = cLISTOPo->op_first->op_sibling;
8173 if (type == OP_MAPWHILE)
8178 if (PL_parser && PL_parser->error_count)
8180 kid = cLISTOPo->op_first->op_sibling;
8181 if (kid->op_type != OP_NULL)
8182 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
8183 kid = kUNOP->op_first;
8186 NewOp(1101, gwop, 1, LOGOP);
8187 gwop->op_type = type;
8188 gwop->op_ppaddr = PL_ppaddr[type];
8189 gwop->op_first = listkids(o);
8190 gwop->op_flags |= OPf_KIDS;
8191 gwop->op_other = LINKLIST(kid);
8192 kid->op_next = (OP*)gwop;
8193 offset = pad_findmy_pvs("$_", 0);
8194 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8195 o->op_private = gwop->op_private = 0;
8196 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8199 o->op_private = gwop->op_private = OPpGREP_LEX;
8200 gwop->op_targ = o->op_targ = offset;
8203 kid = cLISTOPo->op_first->op_sibling;
8204 if (!kid || !kid->op_sibling)
8205 return too_few_arguments(o,OP_DESC(o));
8206 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8207 op_lvalue(kid, OP_GREPSTART);
8213 Perl_ck_index(pTHX_ OP *o)
8215 PERL_ARGS_ASSERT_CK_INDEX;
8217 if (o->op_flags & OPf_KIDS) {
8218 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8220 kid = kid->op_sibling; /* get past "big" */
8221 if (kid && kid->op_type == OP_CONST) {
8222 const bool save_taint = PL_tainted;
8223 fbm_compile(((SVOP*)kid)->op_sv, 0);
8224 PL_tainted = save_taint;
8231 Perl_ck_lfun(pTHX_ OP *o)
8233 const OPCODE type = o->op_type;
8235 PERL_ARGS_ASSERT_CK_LFUN;
8237 return modkids(ck_fun(o), type);
8241 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8243 PERL_ARGS_ASSERT_CK_DEFINED;
8245 if ((o->op_flags & OPf_KIDS)) {
8246 switch (cUNOPo->op_first->op_type) {
8249 case OP_AASSIGN: /* Is this a good idea? */
8250 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8251 "defined(@array) is deprecated");
8252 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8253 "\t(Maybe you should just omit the defined()?)\n");
8257 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8258 "defined(%%hash) is deprecated");
8259 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8260 "\t(Maybe you should just omit the defined()?)\n");
8271 Perl_ck_readline(pTHX_ OP *o)
8273 PERL_ARGS_ASSERT_CK_READLINE;
8275 if (o->op_flags & OPf_KIDS) {
8276 OP *kid = cLISTOPo->op_first;
8277 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
8281 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8283 op_getmad(o,newop,'O');
8293 Perl_ck_rfun(pTHX_ OP *o)
8295 const OPCODE type = o->op_type;
8297 PERL_ARGS_ASSERT_CK_RFUN;
8299 return refkids(ck_fun(o), type);
8303 Perl_ck_listiob(pTHX_ OP *o)
8307 PERL_ARGS_ASSERT_CK_LISTIOB;
8309 kid = cLISTOPo->op_first;
8312 kid = cLISTOPo->op_first;
8314 if (kid->op_type == OP_PUSHMARK)
8315 kid = kid->op_sibling;
8316 if (kid && o->op_flags & OPf_STACKED)
8317 kid = kid->op_sibling;
8318 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8319 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8320 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8321 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8322 cLISTOPo->op_first->op_sibling = kid;
8323 cLISTOPo->op_last = kid;
8324 kid = kid->op_sibling;
8329 op_append_elem(o->op_type, o, newDEFSVOP());
8331 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
8336 Perl_ck_smartmatch(pTHX_ OP *o)
8339 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8340 if (0 == (o->op_flags & OPf_SPECIAL)) {
8341 OP *first = cBINOPo->op_first;
8342 OP *second = first->op_sibling;
8344 /* Implicitly take a reference to an array or hash */
8345 first->op_sibling = NULL;
8346 first = cBINOPo->op_first = ref_array_or_hash(first);
8347 second = first->op_sibling = ref_array_or_hash(second);
8349 /* Implicitly take a reference to a regular expression */
8350 if (first->op_type == OP_MATCH) {
8351 first->op_type = OP_QR;
8352 first->op_ppaddr = PL_ppaddr[OP_QR];
8354 if (second->op_type == OP_MATCH) {
8355 second->op_type = OP_QR;
8356 second->op_ppaddr = PL_ppaddr[OP_QR];
8365 Perl_ck_sassign(pTHX_ OP *o)
8368 OP * const kid = cLISTOPo->op_first;
8370 PERL_ARGS_ASSERT_CK_SASSIGN;
8372 /* has a disposable target? */
8373 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8374 && !(kid->op_flags & OPf_STACKED)
8375 /* Cannot steal the second time! */
8376 && !(kid->op_private & OPpTARGET_MY)
8377 /* Keep the full thing for madskills */
8381 OP * const kkid = kid->op_sibling;
8383 /* Can just relocate the target. */
8384 if (kkid && kkid->op_type == OP_PADSV
8385 && !(kkid->op_private & OPpLVAL_INTRO))
8387 kid->op_targ = kkid->op_targ;
8389 /* Now we do not need PADSV and SASSIGN. */
8390 kid->op_sibling = o->op_sibling; /* NULL */
8391 cLISTOPo->op_first = NULL;
8394 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8398 if (kid->op_sibling) {
8399 OP *kkid = kid->op_sibling;
8400 /* For state variable assignment, kkid is a list op whose op_last
8402 if ((kkid->op_type == OP_PADSV ||
8403 (kkid->op_type == OP_LIST &&
8404 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8407 && (kkid->op_private & OPpLVAL_INTRO)
8408 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8409 const PADOFFSET target = kkid->op_targ;
8410 OP *const other = newOP(OP_PADSV,
8412 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8413 OP *const first = newOP(OP_NULL, 0);
8414 OP *const nullop = newCONDOP(0, first, o, other);
8415 OP *const condop = first->op_next;
8416 /* hijacking PADSTALE for uninitialized state variables */
8417 SvPADSTALE_on(PAD_SVl(target));
8419 condop->op_type = OP_ONCE;
8420 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8421 condop->op_targ = target;
8422 other->op_targ = target;
8424 /* Because we change the type of the op here, we will skip the
8425 assignment binop->op_last = binop->op_first->op_sibling; at the
8426 end of Perl_newBINOP(). So need to do it here. */
8427 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8436 Perl_ck_match(pTHX_ OP *o)
8440 PERL_ARGS_ASSERT_CK_MATCH;
8442 if (o->op_type != OP_QR && PL_compcv) {
8443 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8444 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8445 o->op_targ = offset;
8446 o->op_private |= OPpTARGET_MY;
8449 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8450 o->op_private |= OPpRUNTIME;
8455 Perl_ck_method(pTHX_ OP *o)
8457 OP * const kid = cUNOPo->op_first;
8459 PERL_ARGS_ASSERT_CK_METHOD;
8461 if (kid->op_type == OP_CONST) {
8462 SV* sv = kSVOP->op_sv;
8463 const char * const method = SvPVX_const(sv);
8464 if (!(strchr(method, ':') || strchr(method, '\''))) {
8466 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8467 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
8470 kSVOP->op_sv = NULL;
8472 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8474 op_getmad(o,cmop,'O');
8485 Perl_ck_null(pTHX_ OP *o)
8487 PERL_ARGS_ASSERT_CK_NULL;
8488 PERL_UNUSED_CONTEXT;
8493 Perl_ck_open(pTHX_ OP *o)
8496 HV * const table = GvHV(PL_hintgv);
8498 PERL_ARGS_ASSERT_CK_OPEN;
8501 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8504 const char *d = SvPV_const(*svp, len);
8505 const I32 mode = mode_from_discipline(d, len);
8506 if (mode & O_BINARY)
8507 o->op_private |= OPpOPEN_IN_RAW;
8508 else if (mode & O_TEXT)
8509 o->op_private |= OPpOPEN_IN_CRLF;
8512 svp = hv_fetchs(table, "open_OUT", FALSE);
8515 const char *d = SvPV_const(*svp, len);
8516 const I32 mode = mode_from_discipline(d, len);
8517 if (mode & O_BINARY)
8518 o->op_private |= OPpOPEN_OUT_RAW;
8519 else if (mode & O_TEXT)
8520 o->op_private |= OPpOPEN_OUT_CRLF;
8523 if (o->op_type == OP_BACKTICK) {
8524 if (!(o->op_flags & OPf_KIDS)) {
8525 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8527 op_getmad(o,newop,'O');
8536 /* In case of three-arg dup open remove strictness
8537 * from the last arg if it is a bareword. */
8538 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8539 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8543 if ((last->op_type == OP_CONST) && /* The bareword. */
8544 (last->op_private & OPpCONST_BARE) &&
8545 (last->op_private & OPpCONST_STRICT) &&
8546 (oa = first->op_sibling) && /* The fh. */
8547 (oa = oa->op_sibling) && /* The mode. */
8548 (oa->op_type == OP_CONST) &&
8549 SvPOK(((SVOP*)oa)->op_sv) &&
8550 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8551 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8552 (last == oa->op_sibling)) /* The bareword. */
8553 last->op_private &= ~OPpCONST_STRICT;
8559 Perl_ck_repeat(pTHX_ OP *o)
8561 PERL_ARGS_ASSERT_CK_REPEAT;
8563 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8564 o->op_private |= OPpREPEAT_DOLIST;
8565 cBINOPo->op_first = force_list(cBINOPo->op_first);
8573 Perl_ck_require(pTHX_ OP *o)
8578 PERL_ARGS_ASSERT_CK_REQUIRE;
8580 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8581 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8583 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8584 SV * const sv = kid->op_sv;
8585 U32 was_readonly = SvREADONLY(sv);
8592 sv_force_normal_flags(sv, 0);
8593 assert(!SvREADONLY(sv));
8603 for (; s < end; s++) {
8604 if (*s == ':' && s[1] == ':') {
8606 Move(s+2, s+1, end - s - 1, char);
8611 sv_catpvs(sv, ".pm");
8612 SvFLAGS(sv) |= was_readonly;
8616 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8617 /* handle override, if any */
8618 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8619 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8620 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8621 gv = gvp ? *gvp : NULL;
8625 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8627 if (o->op_flags & OPf_KIDS) {
8628 kid = cUNOPo->op_first;
8629 cUNOPo->op_first = NULL;
8637 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8638 op_append_elem(OP_LIST, kid,
8639 scalar(newUNOP(OP_RV2CV, 0,
8642 op_getmad(o,newop,'O');
8646 return scalar(ck_fun(o));
8650 Perl_ck_return(pTHX_ OP *o)
8655 PERL_ARGS_ASSERT_CK_RETURN;
8657 kid = cLISTOPo->op_first->op_sibling;
8658 if (CvLVALUE(PL_compcv)) {
8659 for (; kid; kid = kid->op_sibling)
8660 op_lvalue(kid, OP_LEAVESUBLV);
8667 Perl_ck_select(pTHX_ OP *o)
8672 PERL_ARGS_ASSERT_CK_SELECT;
8674 if (o->op_flags & OPf_KIDS) {
8675 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8676 if (kid && kid->op_sibling) {
8677 o->op_type = OP_SSELECT;
8678 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8680 return fold_constants(op_integerize(op_std_init(o)));
8684 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8685 if (kid && kid->op_type == OP_RV2GV)
8686 kid->op_private &= ~HINT_STRICT_REFS;
8691 Perl_ck_shift(pTHX_ OP *o)
8694 const I32 type = o->op_type;
8696 PERL_ARGS_ASSERT_CK_SHIFT;
8698 if (!(o->op_flags & OPf_KIDS)) {
8701 if (!CvUNIQUE(PL_compcv)) {
8702 o->op_flags |= OPf_SPECIAL;
8706 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8709 OP * const oldo = o;
8710 o = newUNOP(type, 0, scalar(argop));
8711 op_getmad(oldo,o,'O');
8716 return newUNOP(type, 0, scalar(argop));
8719 return scalar(ck_fun(o));
8723 Perl_ck_sort(pTHX_ OP *o)
8728 PERL_ARGS_ASSERT_CK_SORT;
8730 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8731 HV * const hinthv = GvHV(PL_hintgv);
8733 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8735 const I32 sorthints = (I32)SvIV(*svp);
8736 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8737 o->op_private |= OPpSORT_QSORT;
8738 if ((sorthints & HINT_SORT_STABLE) != 0)
8739 o->op_private |= OPpSORT_STABLE;
8744 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8746 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8747 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8749 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8751 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8753 if (kid->op_type == OP_SCOPE) {
8757 else if (kid->op_type == OP_LEAVE) {
8758 if (o->op_type == OP_SORT) {
8759 op_null(kid); /* wipe out leave */
8762 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8763 if (k->op_next == kid)
8765 /* don't descend into loops */
8766 else if (k->op_type == OP_ENTERLOOP
8767 || k->op_type == OP_ENTERITER)
8769 k = cLOOPx(k)->op_lastop;
8774 kid->op_next = 0; /* just disconnect the leave */
8775 k = kLISTOP->op_first;
8780 if (o->op_type == OP_SORT) {
8781 /* provide scalar context for comparison function/block */
8787 o->op_flags |= OPf_SPECIAL;
8790 firstkid = firstkid->op_sibling;
8793 /* provide list context for arguments */
8794 if (o->op_type == OP_SORT)
8801 S_simplify_sort(pTHX_ OP *o)
8804 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8810 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8812 if (!(o->op_flags & OPf_STACKED))
8814 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8815 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8816 kid = kUNOP->op_first; /* get past null */
8817 if (kid->op_type != OP_SCOPE)
8819 kid = kLISTOP->op_last; /* get past scope */
8820 switch(kid->op_type) {
8828 k = kid; /* remember this node*/
8829 if (kBINOP->op_first->op_type != OP_RV2SV)
8831 kid = kBINOP->op_first; /* get past cmp */
8832 if (kUNOP->op_first->op_type != OP_GV)
8834 kid = kUNOP->op_first; /* get past rv2sv */
8836 if (GvSTASH(gv) != PL_curstash)
8838 gvname = GvNAME(gv);
8839 if (*gvname == 'a' && gvname[1] == '\0')
8841 else if (*gvname == 'b' && gvname[1] == '\0')
8846 kid = k; /* back to cmp */
8847 if (kBINOP->op_last->op_type != OP_RV2SV)
8849 kid = kBINOP->op_last; /* down to 2nd arg */
8850 if (kUNOP->op_first->op_type != OP_GV)
8852 kid = kUNOP->op_first; /* get past rv2sv */
8854 if (GvSTASH(gv) != PL_curstash)
8856 gvname = GvNAME(gv);
8858 ? !(*gvname == 'a' && gvname[1] == '\0')
8859 : !(*gvname == 'b' && gvname[1] == '\0'))
8861 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8863 o->op_private |= OPpSORT_DESCEND;
8864 if (k->op_type == OP_NCMP)
8865 o->op_private |= OPpSORT_NUMERIC;
8866 if (k->op_type == OP_I_NCMP)
8867 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8868 kid = cLISTOPo->op_first->op_sibling;
8869 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8871 op_getmad(kid,o,'S'); /* then delete it */
8873 op_free(kid); /* then delete it */
8878 Perl_ck_split(pTHX_ OP *o)
8883 PERL_ARGS_ASSERT_CK_SPLIT;
8885 if (o->op_flags & OPf_STACKED)
8886 return no_fh_allowed(o);
8888 kid = cLISTOPo->op_first;
8889 if (kid->op_type != OP_NULL)
8890 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
8891 kid = kid->op_sibling;
8892 op_free(cLISTOPo->op_first);
8894 cLISTOPo->op_first = kid;
8896 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8897 cLISTOPo->op_last = kid; /* There was only one element previously */
8900 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8901 OP * const sibl = kid->op_sibling;
8902 kid->op_sibling = 0;
8903 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8904 if (cLISTOPo->op_first == cLISTOPo->op_last)
8905 cLISTOPo->op_last = kid;
8906 cLISTOPo->op_first = kid;
8907 kid->op_sibling = sibl;
8910 kid->op_type = OP_PUSHRE;
8911 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8913 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8914 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8915 "Use of /g modifier is meaningless in split");
8918 if (!kid->op_sibling)
8919 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8921 kid = kid->op_sibling;
8924 if (!kid->op_sibling)
8925 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8926 assert(kid->op_sibling);
8928 kid = kid->op_sibling;
8931 if (kid->op_sibling)
8932 return too_many_arguments(o,OP_DESC(o));
8938 Perl_ck_join(pTHX_ OP *o)
8940 const OP * const kid = cLISTOPo->op_first->op_sibling;
8942 PERL_ARGS_ASSERT_CK_JOIN;
8944 if (kid && kid->op_type == OP_MATCH) {
8945 if (ckWARN(WARN_SYNTAX)) {
8946 const REGEXP *re = PM_GETRE(kPMOP);
8947 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8948 const STRLEN len = re ? RX_PRELEN(re) : 6;
8949 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8950 "/%.*s/ should probably be written as \"%.*s\"",
8951 (int)len, pmstr, (int)len, pmstr);
8958 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8960 Examines an op, which is expected to identify a subroutine at runtime,
8961 and attempts to determine at compile time which subroutine it identifies.
8962 This is normally used during Perl compilation to determine whether
8963 a prototype can be applied to a function call. I<cvop> is the op
8964 being considered, normally an C<rv2cv> op. A pointer to the identified
8965 subroutine is returned, if it could be determined statically, and a null
8966 pointer is returned if it was not possible to determine statically.
8968 Currently, the subroutine can be identified statically if the RV that the
8969 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8970 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8971 suitable if the constant value must be an RV pointing to a CV. Details of
8972 this process may change in future versions of Perl. If the C<rv2cv> op
8973 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8974 the subroutine statically: this flag is used to suppress compile-time
8975 magic on a subroutine call, forcing it to use default runtime behaviour.
8977 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8978 of a GV reference is modified. If a GV was examined and its CV slot was
8979 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8980 If the op is not optimised away, and the CV slot is later populated with
8981 a subroutine having a prototype, that flag eventually triggers the warning
8982 "called too early to check prototype".
8984 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8985 of returning a pointer to the subroutine it returns a pointer to the
8986 GV giving the most appropriate name for the subroutine in this context.
8987 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8988 (C<CvANON>) subroutine that is referenced through a GV it will be the
8989 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8990 A null pointer is returned as usual if there is no statically-determinable
8997 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9002 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9003 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9004 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9005 if (cvop->op_type != OP_RV2CV)
9007 if (cvop->op_private & OPpENTERSUB_AMPER)
9009 if (!(cvop->op_flags & OPf_KIDS))
9011 rvop = cUNOPx(cvop)->op_first;
9012 switch (rvop->op_type) {
9014 gv = cGVOPx_gv(rvop);
9017 if (flags & RV2CVOPCV_MARK_EARLY)
9018 rvop->op_private |= OPpEARLY_CV;
9023 SV *rv = cSVOPx_sv(rvop);
9033 if (SvTYPE((SV*)cv) != SVt_PVCV)
9035 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9036 if (!CvANON(cv) || !gv)
9045 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9047 Performs the default fixup of the arguments part of an C<entersub>
9048 op tree. This consists of applying list context to each of the
9049 argument ops. This is the standard treatment used on a call marked
9050 with C<&>, or a method call, or a call through a subroutine reference,
9051 or any other call where the callee can't be identified at compile time,
9052 or a call where the callee has no prototype.
9058 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9061 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9062 aop = cUNOPx(entersubop)->op_first;
9063 if (!aop->op_sibling)
9064 aop = cUNOPx(aop)->op_first;
9065 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9066 if (!(PL_madskills && aop->op_type == OP_STUB)) {
9068 op_lvalue(aop, OP_ENTERSUB);
9075 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9077 Performs the fixup of the arguments part of an C<entersub> op tree
9078 based on a subroutine prototype. This makes various modifications to
9079 the argument ops, from applying context up to inserting C<refgen> ops,
9080 and checking the number and syntactic types of arguments, as directed by
9081 the prototype. This is the standard treatment used on a subroutine call,
9082 not marked with C<&>, where the callee can be identified at compile time
9083 and has a prototype.
9085 I<protosv> supplies the subroutine prototype to be applied to the call.
9086 It may be a normal defined scalar, of which the string value will be used.
9087 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9088 that has been cast to C<SV*>) which has a prototype. The prototype
9089 supplied, in whichever form, does not need to match the actual callee
9090 referenced by the op tree.
9092 If the argument ops disagree with the prototype, for example by having
9093 an unacceptable number of arguments, a valid op tree is returned anyway.
9094 The error is reflected in the parser state, normally resulting in a single
9095 exception at the top level of parsing which covers all the compilation
9096 errors that occurred. In the error message, the callee is referred to
9097 by the name defined by the I<namegv> parameter.
9103 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9106 const char *proto, *proto_end;
9107 OP *aop, *prev, *cvop;
9110 I32 contextclass = 0;
9111 const char *e = NULL;
9112 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9113 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9114 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
9115 "flags=%lx", (unsigned long) SvFLAGS(protosv));
9116 if (SvTYPE(protosv) == SVt_PVCV)
9117 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9118 else proto = SvPV(protosv, proto_len);
9119 proto_end = proto + proto_len;
9120 aop = cUNOPx(entersubop)->op_first;
9121 if (!aop->op_sibling)
9122 aop = cUNOPx(aop)->op_first;
9124 aop = aop->op_sibling;
9125 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9126 while (aop != cvop) {
9128 if (PL_madskills && aop->op_type == OP_STUB) {
9129 aop = aop->op_sibling;
9132 if (PL_madskills && aop->op_type == OP_NULL)
9133 o3 = ((UNOP*)aop)->op_first;
9137 if (proto >= proto_end)
9138 return too_many_arguments(entersubop, gv_ename(namegv));
9146 /* _ must be at the end */
9147 if (proto[1] && !strchr(";@%", proto[1]))
9162 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9164 arg == 1 ? "block or sub {}" : "sub {}",
9165 gv_ename(namegv), o3);
9168 /* '*' allows any scalar type, including bareword */
9171 if (o3->op_type == OP_RV2GV)
9172 goto wrapref; /* autoconvert GLOB -> GLOBref */
9173 else if (o3->op_type == OP_CONST)
9174 o3->op_private &= ~OPpCONST_STRICT;
9175 else if (o3->op_type == OP_ENTERSUB) {
9176 /* accidental subroutine, revert to bareword */
9177 OP *gvop = ((UNOP*)o3)->op_first;
9178 if (gvop && gvop->op_type == OP_NULL) {
9179 gvop = ((UNOP*)gvop)->op_first;
9181 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9184 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9185 (gvop = ((UNOP*)gvop)->op_first) &&
9186 gvop->op_type == OP_GV)
9188 GV * const gv = cGVOPx_gv(gvop);
9189 OP * const sibling = aop->op_sibling;
9190 SV * const n = newSVpvs("");
9192 OP * const oldaop = aop;
9196 gv_fullname4(n, gv, "", FALSE);
9197 aop = newSVOP(OP_CONST, 0, n);
9198 op_getmad(oldaop,aop,'O');
9199 prev->op_sibling = aop;
9200 aop->op_sibling = sibling;
9210 if (o3->op_type == OP_RV2AV ||
9211 o3->op_type == OP_PADAV ||
9212 o3->op_type == OP_RV2HV ||
9213 o3->op_type == OP_PADHV
9228 if (contextclass++ == 0) {
9229 e = strchr(proto, ']');
9230 if (!e || e == proto)
9239 const char *p = proto;
9240 const char *const end = proto;
9243 /* \[$] accepts any scalar lvalue */
9245 && Perl_op_lvalue_flags(aTHX_
9247 OP_READ, /* not entersub */
9250 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
9252 gv_ename(namegv), o3);
9257 if (o3->op_type == OP_RV2GV)
9260 bad_type(arg, "symbol", gv_ename(namegv), o3);
9263 if (o3->op_type == OP_ENTERSUB)
9266 bad_type(arg, "subroutine entry", gv_ename(namegv),
9270 if (o3->op_type == OP_RV2SV ||
9271 o3->op_type == OP_PADSV ||
9272 o3->op_type == OP_HELEM ||
9273 o3->op_type == OP_AELEM)
9275 if (!contextclass) {
9276 /* \$ accepts any scalar lvalue */
9277 if (Perl_op_lvalue_flags(aTHX_
9279 OP_READ, /* not entersub */
9282 bad_type(arg, "scalar", gv_ename(namegv), o3);
9286 if (o3->op_type == OP_RV2AV ||
9287 o3->op_type == OP_PADAV)
9290 bad_type(arg, "array", gv_ename(namegv), o3);
9293 if (o3->op_type == OP_RV2HV ||
9294 o3->op_type == OP_PADHV)
9297 bad_type(arg, "hash", gv_ename(namegv), o3);
9301 OP* const kid = aop;
9302 OP* const sib = kid->op_sibling;
9303 kid->op_sibling = 0;
9304 aop = newUNOP(OP_REFGEN, 0, kid);
9305 aop->op_sibling = sib;
9306 prev->op_sibling = aop;
9308 if (contextclass && e) {
9323 SV* const tmpsv = sv_newmortal();
9324 gv_efullname3(tmpsv, namegv, NULL);
9325 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9326 SVfARG(tmpsv), SVfARG(protosv));
9330 op_lvalue(aop, OP_ENTERSUB);
9332 aop = aop->op_sibling;
9334 if (aop == cvop && *proto == '_') {
9335 /* generate an access to $_ */
9337 aop->op_sibling = prev->op_sibling;
9338 prev->op_sibling = aop; /* instead of cvop */
9340 if (!optional && proto_end > proto &&
9341 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9342 return too_few_arguments(entersubop, gv_ename(namegv));
9347 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9349 Performs the fixup of the arguments part of an C<entersub> op tree either
9350 based on a subroutine prototype or using default list-context processing.
9351 This is the standard treatment used on a subroutine call, not marked
9352 with C<&>, where the callee can be identified at compile time.
9354 I<protosv> supplies the subroutine prototype to be applied to the call,
9355 or indicates that there is no prototype. It may be a normal scalar,
9356 in which case if it is defined then the string value will be used
9357 as a prototype, and if it is undefined then there is no prototype.
9358 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9359 that has been cast to C<SV*>), of which the prototype will be used if it
9360 has one. The prototype (or lack thereof) supplied, in whichever form,
9361 does not need to match the actual callee referenced by the op tree.
9363 If the argument ops disagree with the prototype, for example by having
9364 an unacceptable number of arguments, a valid op tree is returned anyway.
9365 The error is reflected in the parser state, normally resulting in a single
9366 exception at the top level of parsing which covers all the compilation
9367 errors that occurred. In the error message, the callee is referred to
9368 by the name defined by the I<namegv> parameter.
9374 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9375 GV *namegv, SV *protosv)
9377 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9378 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9379 return ck_entersub_args_proto(entersubop, namegv, protosv);
9381 return ck_entersub_args_list(entersubop);
9385 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9387 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9388 OP *aop = cUNOPx(entersubop)->op_first;
9390 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9394 if (!aop->op_sibling)
9395 aop = cUNOPx(aop)->op_first;
9396 aop = aop->op_sibling;
9397 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9398 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9399 aop = aop->op_sibling;
9402 (void)too_many_arguments(entersubop, GvNAME(namegv));
9404 op_free(entersubop);
9405 switch(GvNAME(namegv)[2]) {
9406 case 'F': return newSVOP(OP_CONST, 0,
9407 newSVpv(CopFILE(PL_curcop),0));
9408 case 'L': return newSVOP(
9411 "%"IVdf, (IV)CopLINE(PL_curcop)
9414 case 'P': return newSVOP(OP_CONST, 0,
9416 ? newSVhek(HvNAME_HEK(PL_curstash))
9427 bool seenarg = FALSE;
9429 if (!aop->op_sibling)
9430 aop = cUNOPx(aop)->op_first;
9433 aop = aop->op_sibling;
9434 prev->op_sibling = NULL;
9437 prev=cvop, cvop = cvop->op_sibling)
9439 if (PL_madskills && cvop->op_sibling
9440 && cvop->op_type != OP_STUB) seenarg = TRUE
9443 prev->op_sibling = NULL;
9444 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9446 if (aop == cvop) aop = NULL;
9447 op_free(entersubop);
9449 if (opnum == OP_ENTEREVAL
9450 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
9451 flags |= OPpEVAL_BYTES <<8;
9453 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9455 case OA_BASEOP_OR_UNOP:
9457 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
9461 if (!PL_madskills || seenarg)
9463 (void)too_many_arguments(aop, GvNAME(namegv));
9466 return opnum == OP_RUNCV
9467 ? newPVOP(OP_RUNCV,0,NULL)
9470 return convert(opnum,0,aop);
9478 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9480 Retrieves the function that will be used to fix up a call to I<cv>.
9481 Specifically, the function is applied to an C<entersub> op tree for a
9482 subroutine call, not marked with C<&>, where the callee can be identified
9483 at compile time as I<cv>.
9485 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9486 argument for it is returned in I<*ckobj_p>. The function is intended
9487 to be called in this manner:
9489 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9491 In this call, I<entersubop> is a pointer to the C<entersub> op,
9492 which may be replaced by the check function, and I<namegv> is a GV
9493 supplying the name that should be used by the check function to refer
9494 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9495 It is permitted to apply the check function in non-standard situations,
9496 such as to a call to a different subroutine or to a method call.
9498 By default, the function is
9499 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9500 and the SV parameter is I<cv> itself. This implements standard
9501 prototype processing. It can be changed, for a particular subroutine,
9502 by L</cv_set_call_checker>.
9508 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9511 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9512 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9514 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9515 *ckobj_p = callmg->mg_obj;
9517 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9523 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9525 Sets the function that will be used to fix up a call to I<cv>.
9526 Specifically, the function is applied to an C<entersub> op tree for a
9527 subroutine call, not marked with C<&>, where the callee can be identified
9528 at compile time as I<cv>.
9530 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9531 for it is supplied in I<ckobj>. The function is intended to be called
9534 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9536 In this call, I<entersubop> is a pointer to the C<entersub> op,
9537 which may be replaced by the check function, and I<namegv> is a GV
9538 supplying the name that should be used by the check function to refer
9539 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9540 It is permitted to apply the check function in non-standard situations,
9541 such as to a call to a different subroutine or to a method call.
9543 The current setting for a particular CV can be retrieved by
9544 L</cv_get_call_checker>.
9550 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9552 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9553 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9554 if (SvMAGICAL((SV*)cv))
9555 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9558 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9559 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9560 if (callmg->mg_flags & MGf_REFCOUNTED) {
9561 SvREFCNT_dec(callmg->mg_obj);
9562 callmg->mg_flags &= ~MGf_REFCOUNTED;
9564 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9565 callmg->mg_obj = ckobj;
9566 if (ckobj != (SV*)cv) {
9567 SvREFCNT_inc_simple_void_NN(ckobj);
9568 callmg->mg_flags |= MGf_REFCOUNTED;
9574 Perl_ck_subr(pTHX_ OP *o)
9580 PERL_ARGS_ASSERT_CK_SUBR;
9582 aop = cUNOPx(o)->op_first;
9583 if (!aop->op_sibling)
9584 aop = cUNOPx(aop)->op_first;
9585 aop = aop->op_sibling;
9586 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9587 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9588 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9590 o->op_private &= ~1;
9591 o->op_private |= OPpENTERSUB_HASTARG;
9592 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9593 if (PERLDB_SUB && PL_curstash != PL_debstash)
9594 o->op_private |= OPpENTERSUB_DB;
9595 if (cvop->op_type == OP_RV2CV) {
9596 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9598 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9599 if (aop->op_type == OP_CONST)
9600 aop->op_private &= ~OPpCONST_STRICT;
9601 else if (aop->op_type == OP_LIST) {
9602 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9603 if (sib && sib->op_type == OP_CONST)
9604 sib->op_private &= ~OPpCONST_STRICT;
9609 return ck_entersub_args_list(o);
9611 Perl_call_checker ckfun;
9613 cv_get_call_checker(cv, &ckfun, &ckobj);
9614 return ckfun(aTHX_ o, namegv, ckobj);
9619 Perl_ck_svconst(pTHX_ OP *o)
9621 PERL_ARGS_ASSERT_CK_SVCONST;
9622 PERL_UNUSED_CONTEXT;
9623 SvREADONLY_on(cSVOPo->op_sv);
9628 Perl_ck_chdir(pTHX_ OP *o)
9630 PERL_ARGS_ASSERT_CK_CHDIR;
9631 if (o->op_flags & OPf_KIDS) {
9632 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9634 if (kid && kid->op_type == OP_CONST &&
9635 (kid->op_private & OPpCONST_BARE))
9637 o->op_flags |= OPf_SPECIAL;
9638 kid->op_private &= ~OPpCONST_STRICT;
9645 Perl_ck_trunc(pTHX_ OP *o)
9647 PERL_ARGS_ASSERT_CK_TRUNC;
9649 if (o->op_flags & OPf_KIDS) {
9650 SVOP *kid = (SVOP*)cUNOPo->op_first;
9652 if (kid->op_type == OP_NULL)
9653 kid = (SVOP*)kid->op_sibling;
9654 if (kid && kid->op_type == OP_CONST &&
9655 (kid->op_private & OPpCONST_BARE))
9657 o->op_flags |= OPf_SPECIAL;
9658 kid->op_private &= ~OPpCONST_STRICT;
9665 Perl_ck_substr(pTHX_ OP *o)
9667 PERL_ARGS_ASSERT_CK_SUBSTR;
9670 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9671 OP *kid = cLISTOPo->op_first;
9673 if (kid->op_type == OP_NULL)
9674 kid = kid->op_sibling;
9676 kid->op_flags |= OPf_MOD;
9683 Perl_ck_tell(pTHX_ OP *o)
9685 PERL_ARGS_ASSERT_CK_TELL;
9687 if (o->op_flags & OPf_KIDS) {
9688 OP *kid = cLISTOPo->op_first;
9689 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
9690 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9696 Perl_ck_each(pTHX_ OP *o)
9699 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9700 const unsigned orig_type = o->op_type;
9701 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9702 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9703 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9704 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9706 PERL_ARGS_ASSERT_CK_EACH;
9709 switch (kid->op_type) {
9715 CHANGE_TYPE(o, array_type);
9718 if (kid->op_private == OPpCONST_BARE
9719 || !SvROK(cSVOPx_sv(kid))
9720 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9721 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9723 /* we let ck_fun handle it */
9726 CHANGE_TYPE(o, ref_type);
9730 /* if treating as a reference, defer additional checks to runtime */
9731 return o->op_type == ref_type ? o : ck_fun(o);
9735 Perl_ck_length(pTHX_ OP *o)
9737 PERL_ARGS_ASSERT_CK_LENGTH;
9741 if (ckWARN(WARN_SYNTAX)) {
9742 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9746 const bool hash = kid->op_type == OP_PADHV
9747 || kid->op_type == OP_RV2HV;
9748 switch (kid->op_type) {
9752 (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
9758 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
9760 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
9762 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
9769 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9770 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
9772 name, hash ? "keys " : "", name
9775 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9776 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
9778 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9779 "length() used on @array (did you mean \"scalar(@array)\"?)");
9786 /* caller is supposed to assign the return to the
9787 container of the rep_op var */
9789 S_opt_scalarhv(pTHX_ OP *rep_op) {
9793 PERL_ARGS_ASSERT_OPT_SCALARHV;
9795 NewOp(1101, unop, 1, UNOP);
9796 unop->op_type = (OPCODE)OP_BOOLKEYS;
9797 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9798 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9799 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9800 unop->op_first = rep_op;
9801 unop->op_next = rep_op->op_next;
9802 rep_op->op_next = (OP*)unop;
9803 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9804 unop->op_sibling = rep_op->op_sibling;
9805 rep_op->op_sibling = NULL;
9806 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9807 if (rep_op->op_type == OP_PADHV) {
9808 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9809 rep_op->op_flags |= OPf_WANT_LIST;
9814 /* Check for in place reverse and sort assignments like "@a = reverse @a"
9815 and modify the optree to make them work inplace */
9818 S_inplace_aassign(pTHX_ OP *o) {
9820 OP *modop, *modop_pushmark;
9822 OP *oleft, *oleft_pushmark;
9824 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
9826 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
9828 assert(cUNOPo->op_first->op_type == OP_NULL);
9829 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
9830 assert(modop_pushmark->op_type == OP_PUSHMARK);
9831 modop = modop_pushmark->op_sibling;
9833 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
9836 /* no other operation except sort/reverse */
9837 if (modop->op_sibling)
9840 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
9841 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
9843 if (modop->op_flags & OPf_STACKED) {
9844 /* skip sort subroutine/block */
9845 assert(oright->op_type == OP_NULL);
9846 oright = oright->op_sibling;
9849 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
9850 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
9851 assert(oleft_pushmark->op_type == OP_PUSHMARK);
9852 oleft = oleft_pushmark->op_sibling;
9854 /* Check the lhs is an array */
9856 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
9857 || oleft->op_sibling
9858 || (oleft->op_private & OPpLVAL_INTRO)
9862 /* Only one thing on the rhs */
9863 if (oright->op_sibling)
9866 /* check the array is the same on both sides */
9867 if (oleft->op_type == OP_RV2AV) {
9868 if (oright->op_type != OP_RV2AV
9869 || !cUNOPx(oright)->op_first
9870 || cUNOPx(oright)->op_first->op_type != OP_GV
9871 || cUNOPx(oleft )->op_first->op_type != OP_GV
9872 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9873 cGVOPx_gv(cUNOPx(oright)->op_first)
9877 else if (oright->op_type != OP_PADAV
9878 || oright->op_targ != oleft->op_targ
9882 /* This actually is an inplace assignment */
9884 modop->op_private |= OPpSORT_INPLACE;
9886 /* transfer MODishness etc from LHS arg to RHS arg */
9887 oright->op_flags = oleft->op_flags;
9889 /* remove the aassign op and the lhs */
9891 op_null(oleft_pushmark);
9892 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
9893 op_null(cUNOPx(oleft)->op_first);
9897 #define MAX_DEFERRED 4
9900 if (defer_ix == (MAX_DEFERRED-1)) { \
9901 CALL_RPEEP(defer_queue[defer_base]); \
9902 defer_base = (defer_base + 1) % MAX_DEFERRED; \
9905 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
9907 /* A peephole optimizer. We visit the ops in the order they're to execute.
9908 * See the comments at the top of this file for more details about when
9909 * peep() is called */
9912 Perl_rpeep(pTHX_ register OP *o)
9915 register OP* oldop = NULL;
9916 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
9920 if (!o || o->op_opt)
9924 SAVEVPTR(PL_curcop);
9925 for (;; o = o->op_next) {
9929 while (defer_ix >= 0)
9930 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
9934 /* By default, this op has now been optimised. A couple of cases below
9935 clear this again. */
9938 switch (o->op_type) {
9940 PL_curcop = ((COP*)o); /* for warnings */
9943 PL_curcop = ((COP*)o); /* for warnings */
9945 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9946 to carry two labels. For now, take the easier option, and skip
9947 this optimisation if the first NEXTSTATE has a label. */
9948 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9949 OP *nextop = o->op_next;
9950 while (nextop && nextop->op_type == OP_NULL)
9951 nextop = nextop->op_next;
9953 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9954 COP *firstcop = (COP *)o;
9955 COP *secondcop = (COP *)nextop;
9956 /* We want the COP pointed to by o (and anything else) to
9957 become the next COP down the line. */
9960 firstcop->op_next = secondcop->op_next;
9962 /* Now steal all its pointers, and duplicate the other
9964 firstcop->cop_line = secondcop->cop_line;
9966 firstcop->cop_stashpv = secondcop->cop_stashpv;
9967 firstcop->cop_file = secondcop->cop_file;
9969 firstcop->cop_stash = secondcop->cop_stash;
9970 firstcop->cop_filegv = secondcop->cop_filegv;
9972 firstcop->cop_hints = secondcop->cop_hints;
9973 firstcop->cop_seq = secondcop->cop_seq;
9974 firstcop->cop_warnings = secondcop->cop_warnings;
9975 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9978 secondcop->cop_stashpv = NULL;
9979 secondcop->cop_file = NULL;
9981 secondcop->cop_stash = NULL;
9982 secondcop->cop_filegv = NULL;
9984 secondcop->cop_warnings = NULL;
9985 secondcop->cop_hints_hash = NULL;
9987 /* If we use op_null(), and hence leave an ex-COP, some
9988 warnings are misreported. For example, the compile-time
9989 error in 'use strict; no strict refs;' */
9990 secondcop->op_type = OP_NULL;
9991 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9997 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9998 if (o->op_next->op_private & OPpTARGET_MY) {
9999 if (o->op_flags & OPf_STACKED) /* chained concats */
10000 break; /* ignore_optimization */
10002 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10003 o->op_targ = o->op_next->op_targ;
10004 o->op_next->op_targ = 0;
10005 o->op_private |= OPpTARGET_MY;
10008 op_null(o->op_next);
10012 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10013 break; /* Scalar stub must produce undef. List stub is noop */
10017 if (o->op_targ == OP_NEXTSTATE
10018 || o->op_targ == OP_DBSTATE)
10020 PL_curcop = ((COP*)o);
10022 /* XXX: We avoid setting op_seq here to prevent later calls
10023 to rpeep() from mistakenly concluding that optimisation
10024 has already occurred. This doesn't fix the real problem,
10025 though (See 20010220.007). AMS 20010719 */
10026 /* op_seq functionality is now replaced by op_opt */
10033 if (oldop && o->op_next) {
10034 oldop->op_next = o->op_next;
10042 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
10043 OP* const pop = (o->op_type == OP_PADAV) ?
10044 o->op_next : o->op_next->op_next;
10046 if (pop && pop->op_type == OP_CONST &&
10047 ((PL_op = pop->op_next)) &&
10048 pop->op_next->op_type == OP_AELEM &&
10049 !(pop->op_next->op_private &
10050 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
10051 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
10054 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
10055 no_bareword_allowed(pop);
10056 if (o->op_type == OP_GV)
10057 op_null(o->op_next);
10058 op_null(pop->op_next);
10060 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
10061 o->op_next = pop->op_next->op_next;
10062 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
10063 o->op_private = (U8)i;
10064 if (o->op_type == OP_GV) {
10067 o->op_type = OP_AELEMFAST;
10070 o->op_type = OP_AELEMFAST_LEX;
10075 if (o->op_next->op_type == OP_RV2SV) {
10076 if (!(o->op_next->op_private & OPpDEREF)) {
10077 op_null(o->op_next);
10078 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
10080 o->op_next = o->op_next->op_next;
10081 o->op_type = OP_GVSV;
10082 o->op_ppaddr = PL_ppaddr[OP_GVSV];
10085 else if (o->op_next->op_type == OP_READLINE
10086 && o->op_next->op_next->op_type == OP_CONCAT
10087 && (o->op_next->op_next->op_flags & OPf_STACKED))
10089 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
10090 o->op_type = OP_RCATLINE;
10091 o->op_flags |= OPf_STACKED;
10092 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
10093 op_null(o->op_next->op_next);
10094 op_null(o->op_next);
10104 fop = cUNOP->op_first;
10112 fop = cLOGOP->op_first;
10113 sop = fop->op_sibling;
10114 while (cLOGOP->op_other->op_type == OP_NULL)
10115 cLOGOP->op_other = cLOGOP->op_other->op_next;
10116 while (o->op_next && ( o->op_type == o->op_next->op_type
10117 || o->op_next->op_type == OP_NULL))
10118 o->op_next = o->op_next->op_next;
10119 DEFER(cLOGOP->op_other);
10123 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10125 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
10130 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
10131 while (nop && nop->op_next) {
10132 switch (nop->op_next->op_type) {
10137 lop = nop = nop->op_next;
10140 nop = nop->op_next;
10148 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
10149 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10150 cLOGOP->op_first = opt_scalarhv(fop);
10151 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
10152 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
10168 while (cLOGOP->op_other->op_type == OP_NULL)
10169 cLOGOP->op_other = cLOGOP->op_other->op_next;
10170 DEFER(cLOGOP->op_other);
10175 while (cLOOP->op_redoop->op_type == OP_NULL)
10176 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
10177 while (cLOOP->op_nextop->op_type == OP_NULL)
10178 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
10179 while (cLOOP->op_lastop->op_type == OP_NULL)
10180 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
10181 /* a while(1) loop doesn't have an op_next that escapes the
10182 * loop, so we have to explicitly follow the op_lastop to
10183 * process the rest of the code */
10184 DEFER(cLOOP->op_lastop);
10188 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10189 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10190 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10191 cPMOP->op_pmstashstartu.op_pmreplstart
10192 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
10193 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
10197 /* check that RHS of sort is a single plain array */
10198 OP *oright = cUNOPo->op_first;
10199 if (!oright || oright->op_type != OP_PUSHMARK)
10202 if (o->op_private & OPpSORT_INPLACE)
10205 /* reverse sort ... can be optimised. */
10206 if (!cUNOPo->op_sibling) {
10207 /* Nothing follows us on the list. */
10208 OP * const reverse = o->op_next;
10210 if (reverse->op_type == OP_REVERSE &&
10211 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10212 OP * const pushmark = cUNOPx(reverse)->op_first;
10213 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10214 && (cUNOPx(pushmark)->op_sibling == o)) {
10215 /* reverse -> pushmark -> sort */
10216 o->op_private |= OPpSORT_REVERSE;
10218 pushmark->op_next = oright->op_next;
10228 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10230 LISTOP *enter, *exlist;
10232 if (o->op_private & OPpSORT_INPLACE)
10235 enter = (LISTOP *) o->op_next;
10238 if (enter->op_type == OP_NULL) {
10239 enter = (LISTOP *) enter->op_next;
10243 /* for $a (...) will have OP_GV then OP_RV2GV here.
10244 for (...) just has an OP_GV. */
10245 if (enter->op_type == OP_GV) {
10246 gvop = (OP *) enter;
10247 enter = (LISTOP *) enter->op_next;
10250 if (enter->op_type == OP_RV2GV) {
10251 enter = (LISTOP *) enter->op_next;
10257 if (enter->op_type != OP_ENTERITER)
10260 iter = enter->op_next;
10261 if (!iter || iter->op_type != OP_ITER)
10264 expushmark = enter->op_first;
10265 if (!expushmark || expushmark->op_type != OP_NULL
10266 || expushmark->op_targ != OP_PUSHMARK)
10269 exlist = (LISTOP *) expushmark->op_sibling;
10270 if (!exlist || exlist->op_type != OP_NULL
10271 || exlist->op_targ != OP_LIST)
10274 if (exlist->op_last != o) {
10275 /* Mmm. Was expecting to point back to this op. */
10278 theirmark = exlist->op_first;
10279 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10282 if (theirmark->op_sibling != o) {
10283 /* There's something between the mark and the reverse, eg
10284 for (1, reverse (...))
10289 ourmark = ((LISTOP *)o)->op_first;
10290 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10293 ourlast = ((LISTOP *)o)->op_last;
10294 if (!ourlast || ourlast->op_next != o)
10297 rv2av = ourmark->op_sibling;
10298 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10299 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10300 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10301 /* We're just reversing a single array. */
10302 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10303 enter->op_flags |= OPf_STACKED;
10306 /* We don't have control over who points to theirmark, so sacrifice
10308 theirmark->op_next = ourmark->op_next;
10309 theirmark->op_flags = ourmark->op_flags;
10310 ourlast->op_next = gvop ? gvop : (OP *) enter;
10313 enter->op_private |= OPpITER_REVERSED;
10314 iter->op_private |= OPpITER_REVERSED;
10321 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10322 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10327 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
10329 if (CvUNIQUE(PL_compcv)) sv = &PL_sv_undef;
10331 sv = newRV((SV *)PL_compcv);
10335 o->op_type = OP_CONST;
10336 o->op_ppaddr = PL_ppaddr[OP_CONST];
10337 o->op_flags |= OPf_SPECIAL;
10338 cSVOPo->op_sv = sv;
10343 if (OP_GIMME(o,0) == G_VOID) {
10344 OP *right = cBINOP->op_first;
10346 OP *left = right->op_sibling;
10347 if (left->op_type == OP_SUBSTR
10348 && (left->op_private & 7) < 4) {
10350 cBINOP->op_first = left;
10351 right->op_sibling =
10352 cBINOPx(left)->op_first->op_sibling;
10353 cBINOPx(left)->op_first->op_sibling = right;
10354 left->op_private |= OPpSUBSTR_REPL_FIRST;
10356 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10363 Perl_cpeep_t cpeep =
10364 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10366 cpeep(aTHX_ o, oldop);
10377 Perl_peep(pTHX_ register OP *o)
10383 =head1 Custom Operators
10385 =for apidoc Ao||custom_op_xop
10386 Return the XOP structure for a given custom op. This function should be
10387 considered internal to OP_NAME and the other access macros: use them instead.
10393 Perl_custom_op_xop(pTHX_ const OP *o)
10399 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10401 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10402 assert(o->op_type == OP_CUSTOM);
10404 /* This is wrong. It assumes a function pointer can be cast to IV,
10405 * which isn't guaranteed, but this is what the old custom OP code
10406 * did. In principle it should be safer to Copy the bytes of the
10407 * pointer into a PV: since the new interface is hidden behind
10408 * functions, this can be changed later if necessary. */
10409 /* Change custom_op_xop if this ever happens */
10410 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10413 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10415 /* assume noone will have just registered a desc */
10416 if (!he && PL_custom_op_names &&
10417 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10422 /* XXX does all this need to be shared mem? */
10423 Newxz(xop, 1, XOP);
10424 pv = SvPV(HeVAL(he), l);
10425 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10426 if (PL_custom_op_descs &&
10427 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10429 pv = SvPV(HeVAL(he), l);
10430 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10432 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10436 if (!he) return &xop_null;
10438 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10443 =for apidoc Ao||custom_op_register
10444 Register a custom op. See L<perlguts/"Custom Operators">.
10450 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10454 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10456 /* see the comment in custom_op_xop */
10457 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10459 if (!PL_custom_ops)
10460 PL_custom_ops = newHV();
10462 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10463 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10467 =head1 Functions in file op.c
10469 =for apidoc core_prototype
10470 This function assigns the prototype of the named core function to C<sv>, or
10471 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10472 NULL if the core function has no prototype. C<code> is a code as returned
10473 by C<keyword()>. It must be negative and unequal to -KEY_CORE.
10479 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10482 int i = 0, n = 0, seen_question = 0, defgv = 0;
10484 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10485 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10486 bool nullret = FALSE;
10488 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10490 assert (code < 0 && code != -KEY_CORE);
10492 if (!sv) sv = sv_newmortal();
10494 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10497 case KEY_and : case KEY_chop: case KEY_chomp:
10498 case KEY_cmp : case KEY_exec: case KEY_eq :
10499 case KEY_ge : case KEY_gt : case KEY_le :
10500 case KEY_lt : case KEY_ne : case KEY_or :
10501 case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
10502 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10503 case KEY_keys: retsetpvs("+", OP_KEYS);
10504 case KEY_values: retsetpvs("+", OP_VALUES);
10505 case KEY_each: retsetpvs("+", OP_EACH);
10506 case KEY_push: retsetpvs("+@", OP_PUSH);
10507 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10508 case KEY_pop: retsetpvs(";+", OP_POP);
10509 case KEY_shift: retsetpvs(";+", OP_SHIFT);
10511 retsetpvs("+;$$@", OP_SPLICE);
10512 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10514 case KEY_evalbytes:
10515 name = "entereval"; break;
10523 while (i < MAXO) { /* The slow way. */
10524 if (strEQ(name, PL_op_name[i])
10525 || strEQ(name, PL_op_desc[i]))
10527 if (nullret) { assert(opnum); *opnum = i; return NULL; }
10532 assert(0); return NULL; /* Should not happen... */
10534 defgv = PL_opargs[i] & OA_DEFGV;
10535 oa = PL_opargs[i] >> OASHIFT;
10537 if (oa & OA_OPTIONAL && !seen_question && (
10538 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
10543 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10544 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10545 /* But globs are already references (kinda) */
10546 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10550 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10551 && !scalar_mod_type(NULL, i)) {
10556 if (i == OP_LOCK) str[n++] = '&';
10560 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10561 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10562 str[n-1] = '_'; defgv = 0;
10566 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
10568 sv_setpvn(sv, str, n - 1);
10569 if (opnum) *opnum = i;
10574 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
10577 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
10580 PERL_ARGS_ASSERT_CORESUB_OP;
10584 return op_append_elem(OP_LINESEQ,
10587 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
10591 case OP_SELECT: /* which represents OP_SSELECT as well */
10596 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
10597 newSVOP(OP_CONST, 0, newSVuv(1))
10599 coresub_op(newSVuv((UV)OP_SSELECT), 0,
10601 coresub_op(coreargssv, 0, OP_SELECT)
10605 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10607 return op_append_elem(
10610 opnum == OP_WANTARRAY || opnum == OP_RUNCV
10611 ? OPpOFFBYONE << 8 : 0)
10613 case OA_BASEOP_OR_UNOP:
10614 if (opnum == OP_ENTEREVAL) {
10615 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
10616 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
10618 else o = newUNOP(opnum,0,argop);
10619 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
10622 if (is_handle_constructor(o, 1))
10623 argop->op_private |= OPpCOREARGS_DEREF1;
10627 o = convert(opnum,0,argop);
10628 if (is_handle_constructor(o, 2))
10629 argop->op_private |= OPpCOREARGS_DEREF2;
10630 if (scalar_mod_type(NULL, opnum))
10631 argop->op_private |= OPpCOREARGS_SCALARMOD;
10632 if (opnum == OP_SUBSTR) {
10633 o->op_private |= OPpMAYBE_LVSUB;
10642 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
10643 SV * const *new_const_svp)
10645 const char *hvname;
10646 bool is_const = !!CvCONST(old_cv);
10647 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
10649 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
10651 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
10653 /* They are 2 constant subroutines generated from
10654 the same constant. This probably means that
10655 they are really the "same" proxy subroutine
10656 instantiated in 2 places. Most likely this is
10657 when a constant is exported twice. Don't warn.
10660 (ckWARN(WARN_REDEFINE)
10662 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
10663 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
10664 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
10665 strEQ(hvname, "autouse"))
10669 && ckWARN_d(WARN_REDEFINE)
10670 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
10673 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10675 ? "Constant subroutine %"SVf" redefined"
10676 : "Subroutine %"SVf" redefined",
10681 =head1 Hook manipulation
10683 These functions provide convenient and thread-safe means of manipulating
10690 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
10692 Puts a C function into the chain of check functions for a specified op
10693 type. This is the preferred way to manipulate the L</PL_check> array.
10694 I<opcode> specifies which type of op is to be affected. I<new_checker>
10695 is a pointer to the C function that is to be added to that opcode's
10696 check chain, and I<old_checker_p> points to the storage location where a
10697 pointer to the next function in the chain will be stored. The value of
10698 I<new_pointer> is written into the L</PL_check> array, while the value
10699 previously stored there is written to I<*old_checker_p>.
10701 L</PL_check> is global to an entire process, and a module wishing to
10702 hook op checking may find itself invoked more than once per process,
10703 typically in different threads. To handle that situation, this function
10704 is idempotent. The location I<*old_checker_p> must initially (once
10705 per process) contain a null pointer. A C variable of static duration
10706 (declared at file scope, typically also marked C<static> to give
10707 it internal linkage) will be implicitly initialised appropriately,
10708 if it does not have an explicit initialiser. This function will only
10709 actually modify the check chain if it finds I<*old_checker_p> to be null.
10710 This function is also thread safe on the small scale. It uses appropriate
10711 locking to avoid race conditions in accessing L</PL_check>.
10713 When this function is called, the function referenced by I<new_checker>
10714 must be ready to be called, except for I<*old_checker_p> being unfilled.
10715 In a threading situation, I<new_checker> may be called immediately,
10716 even before this function has returned. I<*old_checker_p> will always
10717 be appropriately set before I<new_checker> is called. If I<new_checker>
10718 decides not to do anything special with an op that it is given (which
10719 is the usual case for most uses of op check hooking), it must chain the
10720 check function referenced by I<*old_checker_p>.
10722 If you want to influence compilation of calls to a specific subroutine,
10723 then use L</cv_set_call_checker> rather than hooking checking of all
10730 Perl_wrap_op_checker(pTHX_ Optype opcode,
10731 Perl_check_t new_checker, Perl_check_t *old_checker_p)
10735 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
10736 if (*old_checker_p) return;
10737 OP_CHECK_MUTEX_LOCK;
10738 if (!*old_checker_p) {
10739 *old_checker_p = PL_check[opcode];
10740 PL_check[opcode] = new_checker;
10742 OP_CHECK_MUTEX_UNLOCK;
10747 /* Efficient sub that returns a constant scalar value. */
10749 const_sv_xsub(pTHX_ CV* cv)
10753 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10757 /* diag_listed_as: SKIPME */
10758 Perl_croak(aTHX_ "usage: %s::%s()",
10759 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10772 * c-indentation-style: bsd
10773 * c-basic-offset: 4
10774 * indent-tabs-mode: t
10777 * ex: set ts=8 sts=4 sw=4 noet: