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)) {
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)) {
1171 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1172 "a constant (%"SVf")", sv));
1173 useless = SvPV_nolen(msv);
1174 useless_is_utf8 = SvUTF8(msv);
1177 useless = "a constant (undef)";
1178 /* don't warn on optimised away booleans, eg
1179 * use constant Foo, 5; Foo || print; */
1180 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1182 /* the constants 0 and 1 are permitted as they are
1183 conventionally used as dummies in constructs like
1184 1 while some_condition_with_side_effects; */
1185 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1187 else if (SvPOK(sv)) {
1188 /* perl4's way of mixing documentation and code
1189 (before the invention of POD) was based on a
1190 trick to mix nroff and perl code. The trick was
1191 built upon these three nroff macros being used in
1192 void context. The pink camel has the details in
1193 the script wrapman near page 319. */
1194 const char * const maybe_macro = SvPVX_const(sv);
1195 if (strnEQ(maybe_macro, "di", 2) ||
1196 strnEQ(maybe_macro, "ds", 2) ||
1197 strnEQ(maybe_macro, "ig", 2))
1202 op_null(o); /* don't execute or even remember it */
1206 o->op_type = OP_PREINC; /* pre-increment is faster */
1207 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1211 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1212 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1216 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1217 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1221 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1222 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1227 UNOP *refgen, *rv2cv;
1230 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1233 rv2gv = ((BINOP *)o)->op_last;
1234 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1237 refgen = (UNOP *)((BINOP *)o)->op_first;
1239 if (!refgen || refgen->op_type != OP_REFGEN)
1242 exlist = (LISTOP *)refgen->op_first;
1243 if (!exlist || exlist->op_type != OP_NULL
1244 || exlist->op_targ != OP_LIST)
1247 if (exlist->op_first->op_type != OP_PUSHMARK)
1250 rv2cv = (UNOP*)exlist->op_last;
1252 if (rv2cv->op_type != OP_RV2CV)
1255 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1256 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1257 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1259 o->op_private |= OPpASSIGN_CV_TO_GV;
1260 rv2gv->op_private |= OPpDONT_INIT_GV;
1261 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1273 kid = cLOGOPo->op_first;
1274 if (kid->op_type == OP_NOT
1275 && (kid->op_flags & OPf_KIDS)
1277 if (o->op_type == OP_AND) {
1279 o->op_ppaddr = PL_ppaddr[OP_OR];
1281 o->op_type = OP_AND;
1282 o->op_ppaddr = PL_ppaddr[OP_AND];
1291 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1296 if (o->op_flags & OPf_STACKED)
1303 if (!(o->op_flags & OPf_KIDS))
1314 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1324 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1325 newSVpvn_flags(useless, strlen(useless),
1326 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1331 S_listkids(pTHX_ OP *o)
1333 if (o && o->op_flags & OPf_KIDS) {
1335 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1342 Perl_list(pTHX_ OP *o)
1347 /* assumes no premature commitment */
1348 if (!o || (o->op_flags & OPf_WANT)
1349 || (PL_parser && PL_parser->error_count)
1350 || o->op_type == OP_RETURN)
1355 if ((o->op_private & OPpTARGET_MY)
1356 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1358 return o; /* As if inside SASSIGN */
1361 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1363 switch (o->op_type) {
1366 list(cBINOPo->op_first);
1371 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1379 if (!(o->op_flags & OPf_KIDS))
1381 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1382 list(cBINOPo->op_first);
1383 return gen_constant_list(o);
1390 kid = cLISTOPo->op_first;
1392 kid = kid->op_sibling;
1395 OP *sib = kid->op_sibling;
1396 if (sib && kid->op_type != OP_LEAVEWHEN)
1402 PL_curcop = &PL_compiling;
1406 kid = cLISTOPo->op_first;
1413 S_scalarseq(pTHX_ OP *o)
1417 const OPCODE type = o->op_type;
1419 if (type == OP_LINESEQ || type == OP_SCOPE ||
1420 type == OP_LEAVE || type == OP_LEAVETRY)
1423 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1424 if (kid->op_sibling) {
1428 PL_curcop = &PL_compiling;
1430 o->op_flags &= ~OPf_PARENS;
1431 if (PL_hints & HINT_BLOCK_SCOPE)
1432 o->op_flags |= OPf_PARENS;
1435 o = newOP(OP_STUB, 0);
1440 S_modkids(pTHX_ OP *o, I32 type)
1442 if (o && o->op_flags & OPf_KIDS) {
1444 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1445 op_lvalue(kid, type);
1451 =for apidoc finalize_optree
1453 This function finalizes the optree. Should be called directly after
1454 the complete optree is built. It does some additional
1455 checking which can't be done in the normal ck_xxx functions and makes
1456 the tree thread-safe.
1461 Perl_finalize_optree(pTHX_ OP* o)
1463 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1466 SAVEVPTR(PL_curcop);
1474 S_finalize_op(pTHX_ OP* o)
1476 PERL_ARGS_ASSERT_FINALIZE_OP;
1478 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1480 /* Make sure mad ops are also thread-safe */
1481 MADPROP *mp = o->op_madprop;
1483 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1484 OP *prop_op = (OP *) mp->mad_val;
1485 /* We only need "Relocate sv to the pad for thread safety.", but this
1486 easiest way to make sure it traverses everything */
1487 if (prop_op->op_type == OP_CONST)
1488 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1489 finalize_op(prop_op);
1496 switch (o->op_type) {
1499 PL_curcop = ((COP*)o); /* for warnings */
1503 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1504 && ckWARN(WARN_SYNTAX))
1506 if (o->op_sibling->op_sibling) {
1507 const OPCODE type = o->op_sibling->op_sibling->op_type;
1508 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1509 const line_t oldline = CopLINE(PL_curcop);
1510 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1511 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1512 "Statement unlikely to be reached");
1513 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1514 "\t(Maybe you meant system() when you said exec()?)\n");
1515 CopLINE_set(PL_curcop, oldline);
1522 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1523 GV * const gv = cGVOPo_gv;
1524 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1525 /* XXX could check prototype here instead of just carping */
1526 SV * const sv = sv_newmortal();
1527 gv_efullname3(sv, gv, NULL);
1528 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1529 "%"SVf"() called too early to check prototype",
1536 if (cSVOPo->op_private & OPpCONST_STRICT)
1537 no_bareword_allowed(o);
1541 case OP_METHOD_NAMED:
1542 /* Relocate sv to the pad for thread safety.
1543 * Despite being a "constant", the SV is written to,
1544 * for reference counts, sv_upgrade() etc. */
1545 if (cSVOPo->op_sv) {
1546 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1547 if (o->op_type != OP_METHOD_NAMED &&
1548 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1550 /* If op_sv is already a PADTMP/MY then it is being used by
1551 * some pad, so make a copy. */
1552 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1553 SvREADONLY_on(PAD_SVl(ix));
1554 SvREFCNT_dec(cSVOPo->op_sv);
1556 else if (o->op_type != OP_METHOD_NAMED
1557 && cSVOPo->op_sv == &PL_sv_undef) {
1558 /* PL_sv_undef is hack - it's unsafe to store it in the
1559 AV that is the pad, because av_fetch treats values of
1560 PL_sv_undef as a "free" AV entry and will merrily
1561 replace them with a new SV, causing pad_alloc to think
1562 that this pad slot is free. (When, clearly, it is not)
1564 SvOK_off(PAD_SVl(ix));
1565 SvPADTMP_on(PAD_SVl(ix));
1566 SvREADONLY_on(PAD_SVl(ix));
1569 SvREFCNT_dec(PAD_SVl(ix));
1570 SvPADTMP_on(cSVOPo->op_sv);
1571 PAD_SETSV(ix, cSVOPo->op_sv);
1572 /* XXX I don't know how this isn't readonly already. */
1573 SvREADONLY_on(PAD_SVl(ix));
1575 cSVOPo->op_sv = NULL;
1586 const char *key = NULL;
1589 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1592 /* Make the CONST have a shared SV */
1593 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1594 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1595 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1596 key = SvPV_const(sv, keylen);
1597 lexname = newSVpvn_share(key,
1598 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1604 if ((o->op_private & (OPpLVAL_INTRO)))
1607 rop = (UNOP*)((BINOP*)o)->op_first;
1608 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1610 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1611 if (!SvPAD_TYPED(lexname))
1613 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1614 if (!fields || !GvHV(*fields))
1616 key = SvPV_const(*svp, keylen);
1617 if (!hv_fetch(GvHV(*fields), key,
1618 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1619 Perl_croak(aTHX_ "No such class field \"%s\" "
1620 "in variable %s of type %s",
1621 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
1633 SVOP *first_key_op, *key_op;
1635 if ((o->op_private & (OPpLVAL_INTRO))
1636 /* I bet there's always a pushmark... */
1637 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1638 /* hmmm, no optimization if list contains only one key. */
1640 rop = (UNOP*)((LISTOP*)o)->op_last;
1641 if (rop->op_type != OP_RV2HV)
1643 if (rop->op_first->op_type == OP_PADSV)
1644 /* @$hash{qw(keys here)} */
1645 rop = (UNOP*)rop->op_first;
1647 /* @{$hash}{qw(keys here)} */
1648 if (rop->op_first->op_type == OP_SCOPE
1649 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1651 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1657 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1658 if (!SvPAD_TYPED(lexname))
1660 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1661 if (!fields || !GvHV(*fields))
1663 /* Again guessing that the pushmark can be jumped over.... */
1664 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1665 ->op_first->op_sibling;
1666 for (key_op = first_key_op; key_op;
1667 key_op = (SVOP*)key_op->op_sibling) {
1668 if (key_op->op_type != OP_CONST)
1670 svp = cSVOPx_svp(key_op);
1671 key = SvPV_const(*svp, keylen);
1672 if (!hv_fetch(GvHV(*fields), key,
1673 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1674 Perl_croak(aTHX_ "No such class field \"%s\" "
1675 "in variable %s of type %s",
1676 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
1682 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1683 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1690 if (o->op_flags & OPf_KIDS) {
1692 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1698 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1700 Propagate lvalue ("modifiable") context to an op and its children.
1701 I<type> represents the context type, roughly based on the type of op that
1702 would do the modifying, although C<local()> is represented by OP_NULL,
1703 because it has no op type of its own (it is signalled by a flag on
1706 This function detects things that can't be modified, such as C<$x+1>, and
1707 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1708 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1710 It also flags things that need to behave specially in an lvalue context,
1711 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1717 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1721 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1724 if (!o || (PL_parser && PL_parser->error_count))
1727 if ((o->op_private & OPpTARGET_MY)
1728 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1733 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1735 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1737 switch (o->op_type) {
1743 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1747 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1748 !(o->op_flags & OPf_STACKED)) {
1749 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1750 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1751 poses, so we need it clear. */
1752 o->op_private &= ~1;
1753 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1754 assert(cUNOPo->op_first->op_type == OP_NULL);
1755 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1758 else { /* lvalue subroutine call */
1759 o->op_private |= OPpLVAL_INTRO
1760 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1761 PL_modcount = RETURN_UNLIMITED_NUMBER;
1762 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1763 /* Potential lvalue context: */
1764 o->op_private |= OPpENTERSUB_INARGS;
1767 else { /* Compile-time error message: */
1768 OP *kid = cUNOPo->op_first;
1772 if (kid->op_type != OP_PUSHMARK) {
1773 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1775 "panic: unexpected lvalue entersub "
1776 "args: type/targ %ld:%"UVuf,
1777 (long)kid->op_type, (UV)kid->op_targ);
1778 kid = kLISTOP->op_first;
1780 while (kid->op_sibling)
1781 kid = kid->op_sibling;
1782 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1783 break; /* Postpone until runtime */
1787 kid = kUNOP->op_first;
1788 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1789 kid = kUNOP->op_first;
1790 if (kid->op_type == OP_NULL)
1792 "Unexpected constant lvalue entersub "
1793 "entry via type/targ %ld:%"UVuf,
1794 (long)kid->op_type, (UV)kid->op_targ);
1795 if (kid->op_type != OP_GV) {
1799 cv = GvCV(kGVOP_gv);
1809 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1810 /* grep, foreach, subcalls, refgen */
1811 if (type == OP_GREPSTART || type == OP_ENTERSUB
1812 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1814 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1815 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1817 : (o->op_type == OP_ENTERSUB
1818 ? "non-lvalue subroutine call"
1820 type ? PL_op_desc[type] : "local"));
1834 case OP_RIGHT_SHIFT:
1843 if (!(o->op_flags & OPf_STACKED))
1850 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1851 op_lvalue(kid, type);
1856 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1857 PL_modcount = RETURN_UNLIMITED_NUMBER;
1858 return o; /* Treat \(@foo) like ordinary list. */
1862 if (scalar_mod_type(o, type))
1864 ref(cUNOPo->op_first, o->op_type);
1868 if (type == OP_LEAVESUBLV)
1869 o->op_private |= OPpMAYBE_LVSUB;
1875 PL_modcount = RETURN_UNLIMITED_NUMBER;
1878 PL_hints |= HINT_BLOCK_SCOPE;
1879 if (type == OP_LEAVESUBLV)
1880 o->op_private |= OPpMAYBE_LVSUB;
1884 ref(cUNOPo->op_first, o->op_type);
1888 PL_hints |= HINT_BLOCK_SCOPE;
1897 case OP_AELEMFAST_LEX:
1904 PL_modcount = RETURN_UNLIMITED_NUMBER;
1905 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1906 return o; /* Treat \(@foo) like ordinary list. */
1907 if (scalar_mod_type(o, type))
1909 if (type == OP_LEAVESUBLV)
1910 o->op_private |= OPpMAYBE_LVSUB;
1914 if (!type) /* local() */
1915 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1916 PAD_COMPNAME_SV(o->op_targ));
1925 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1929 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1935 if (type == OP_LEAVESUBLV)
1936 o->op_private |= OPpMAYBE_LVSUB;
1937 pad_free(o->op_targ);
1938 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1939 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1940 if (o->op_flags & OPf_KIDS)
1941 op_lvalue(cBINOPo->op_first->op_sibling, type);
1946 ref(cBINOPo->op_first, o->op_type);
1947 if (type == OP_ENTERSUB &&
1948 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1949 o->op_private |= OPpLVAL_DEFER;
1950 if (type == OP_LEAVESUBLV)
1951 o->op_private |= OPpMAYBE_LVSUB;
1961 if (o->op_flags & OPf_KIDS)
1962 op_lvalue(cLISTOPo->op_last, type);
1967 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1969 else if (!(o->op_flags & OPf_KIDS))
1971 if (o->op_targ != OP_LIST) {
1972 op_lvalue(cBINOPo->op_first, type);
1978 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1979 /* elements might be in void context because the list is
1980 in scalar context or because they are attribute sub calls */
1981 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
1982 op_lvalue(kid, type);
1986 if (type != OP_LEAVESUBLV)
1988 break; /* op_lvalue()ing was handled by ck_return() */
1991 /* [20011101.069] File test operators interpret OPf_REF to mean that
1992 their argument is a filehandle; thus \stat(".") should not set
1994 if (type == OP_REFGEN &&
1995 PL_check[o->op_type] == Perl_ck_ftst)
1998 if (type != OP_LEAVESUBLV)
1999 o->op_flags |= OPf_MOD;
2001 if (type == OP_AASSIGN || type == OP_SASSIGN)
2002 o->op_flags |= OPf_SPECIAL|OPf_REF;
2003 else if (!type) { /* local() */
2006 o->op_private |= OPpLVAL_INTRO;
2007 o->op_flags &= ~OPf_SPECIAL;
2008 PL_hints |= HINT_BLOCK_SCOPE;
2013 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2014 "Useless localization of %s", OP_DESC(o));
2017 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2018 && type != OP_LEAVESUBLV)
2019 o->op_flags |= OPf_REF;
2024 S_scalar_mod_type(const OP *o, I32 type)
2026 assert(o || type != OP_SASSIGN);
2030 if (o->op_type == OP_RV2GV)
2054 case OP_RIGHT_SHIFT:
2075 S_is_handle_constructor(const OP *o, I32 numargs)
2077 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2079 switch (o->op_type) {
2087 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2100 S_refkids(pTHX_ OP *o, I32 type)
2102 if (o && o->op_flags & OPf_KIDS) {
2104 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2111 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2116 PERL_ARGS_ASSERT_DOREF;
2118 if (!o || (PL_parser && PL_parser->error_count))
2121 switch (o->op_type) {
2123 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2124 !(o->op_flags & OPf_STACKED)) {
2125 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2126 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2127 assert(cUNOPo->op_first->op_type == OP_NULL);
2128 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2129 o->op_flags |= OPf_SPECIAL;
2130 o->op_private &= ~1;
2132 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2133 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2134 : type == OP_RV2HV ? OPpDEREF_HV
2136 o->op_flags |= OPf_MOD;
2142 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2143 doref(kid, type, set_op_ref);
2146 if (type == OP_DEFINED)
2147 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2148 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2151 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2152 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2153 : type == OP_RV2HV ? OPpDEREF_HV
2155 o->op_flags |= OPf_MOD;
2162 o->op_flags |= OPf_REF;
2165 if (type == OP_DEFINED)
2166 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2167 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2173 o->op_flags |= OPf_REF;
2178 if (!(o->op_flags & OPf_KIDS))
2180 doref(cBINOPo->op_first, type, set_op_ref);
2184 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2185 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2186 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2187 : type == OP_RV2HV ? OPpDEREF_HV
2189 o->op_flags |= OPf_MOD;
2199 if (!(o->op_flags & OPf_KIDS))
2201 doref(cLISTOPo->op_last, type, set_op_ref);
2211 S_dup_attrlist(pTHX_ OP *o)
2216 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2218 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2219 * where the first kid is OP_PUSHMARK and the remaining ones
2220 * are OP_CONST. We need to push the OP_CONST values.
2222 if (o->op_type == OP_CONST)
2223 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2225 else if (o->op_type == OP_NULL)
2229 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2231 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2232 if (o->op_type == OP_CONST)
2233 rop = op_append_elem(OP_LIST, rop,
2234 newSVOP(OP_CONST, o->op_flags,
2235 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2242 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2247 PERL_ARGS_ASSERT_APPLY_ATTRS;
2249 /* fake up C<use attributes $pkg,$rv,@attrs> */
2250 ENTER; /* need to protect against side-effects of 'use' */
2251 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2253 #define ATTRSMODULE "attributes"
2254 #define ATTRSMODULE_PM "attributes.pm"
2257 /* Don't force the C<use> if we don't need it. */
2258 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2259 if (svp && *svp != &PL_sv_undef)
2260 NOOP; /* already in %INC */
2262 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2263 newSVpvs(ATTRSMODULE), NULL);
2266 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2267 newSVpvs(ATTRSMODULE),
2269 op_prepend_elem(OP_LIST,
2270 newSVOP(OP_CONST, 0, stashsv),
2271 op_prepend_elem(OP_LIST,
2272 newSVOP(OP_CONST, 0,
2274 dup_attrlist(attrs))));
2280 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2283 OP *pack, *imop, *arg;
2286 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2291 assert(target->op_type == OP_PADSV ||
2292 target->op_type == OP_PADHV ||
2293 target->op_type == OP_PADAV);
2295 /* Ensure that attributes.pm is loaded. */
2296 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2298 /* Need package name for method call. */
2299 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2301 /* Build up the real arg-list. */
2302 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2304 arg = newOP(OP_PADSV, 0);
2305 arg->op_targ = target->op_targ;
2306 arg = op_prepend_elem(OP_LIST,
2307 newSVOP(OP_CONST, 0, stashsv),
2308 op_prepend_elem(OP_LIST,
2309 newUNOP(OP_REFGEN, 0,
2310 op_lvalue(arg, OP_REFGEN)),
2311 dup_attrlist(attrs)));
2313 /* Fake up a method call to import */
2314 meth = newSVpvs_share("import");
2315 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2316 op_append_elem(OP_LIST,
2317 op_prepend_elem(OP_LIST, pack, list(arg)),
2318 newSVOP(OP_METHOD_NAMED, 0, meth)));
2320 /* Combine the ops. */
2321 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2325 =notfor apidoc apply_attrs_string
2327 Attempts to apply a list of attributes specified by the C<attrstr> and
2328 C<len> arguments to the subroutine identified by the C<cv> argument which
2329 is expected to be associated with the package identified by the C<stashpv>
2330 argument (see L<attributes>). It gets this wrong, though, in that it
2331 does not correctly identify the boundaries of the individual attribute
2332 specifications within C<attrstr>. This is not really intended for the
2333 public API, but has to be listed here for systems such as AIX which
2334 need an explicit export list for symbols. (It's called from XS code
2335 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2336 to respect attribute syntax properly would be welcome.
2342 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2343 const char *attrstr, STRLEN len)
2347 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2350 len = strlen(attrstr);
2354 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2356 const char * const sstr = attrstr;
2357 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2358 attrs = op_append_elem(OP_LIST, attrs,
2359 newSVOP(OP_CONST, 0,
2360 newSVpvn(sstr, attrstr-sstr)));
2364 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2365 newSVpvs(ATTRSMODULE),
2366 NULL, op_prepend_elem(OP_LIST,
2367 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2368 op_prepend_elem(OP_LIST,
2369 newSVOP(OP_CONST, 0,
2370 newRV(MUTABLE_SV(cv))),
2375 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2379 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2381 PERL_ARGS_ASSERT_MY_KID;
2383 if (!o || (PL_parser && PL_parser->error_count))
2387 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2388 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2392 if (type == OP_LIST) {
2394 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2395 my_kid(kid, attrs, imopsp);
2396 } else if (type == OP_UNDEF
2402 } else if (type == OP_RV2SV || /* "our" declaration */
2404 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2405 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2406 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2408 PL_parser->in_my == KEY_our
2410 : PL_parser->in_my == KEY_state ? "state" : "my"));
2412 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2413 PL_parser->in_my = FALSE;
2414 PL_parser->in_my_stash = NULL;
2415 apply_attrs(GvSTASH(gv),
2416 (type == OP_RV2SV ? GvSV(gv) :
2417 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2418 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2421 o->op_private |= OPpOUR_INTRO;
2424 else if (type != OP_PADSV &&
2427 type != OP_PUSHMARK)
2429 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2431 PL_parser->in_my == KEY_our
2433 : PL_parser->in_my == KEY_state ? "state" : "my"));
2436 else if (attrs && type != OP_PUSHMARK) {
2439 PL_parser->in_my = FALSE;
2440 PL_parser->in_my_stash = NULL;
2442 /* check for C<my Dog $spot> when deciding package */
2443 stash = PAD_COMPNAME_TYPE(o->op_targ);
2445 stash = PL_curstash;
2446 apply_attrs_my(stash, o, attrs, imopsp);
2448 o->op_flags |= OPf_MOD;
2449 o->op_private |= OPpLVAL_INTRO;
2451 o->op_private |= OPpPAD_STATE;
2456 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2460 int maybe_scalar = 0;
2462 PERL_ARGS_ASSERT_MY_ATTRS;
2464 /* [perl #17376]: this appears to be premature, and results in code such as
2465 C< our(%x); > executing in list mode rather than void mode */
2467 if (o->op_flags & OPf_PARENS)
2477 o = my_kid(o, attrs, &rops);
2479 if (maybe_scalar && o->op_type == OP_PADSV) {
2480 o = scalar(op_append_list(OP_LIST, rops, o));
2481 o->op_private |= OPpLVAL_INTRO;
2484 /* The listop in rops might have a pushmark at the beginning,
2485 which will mess up list assignment. */
2486 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2487 if (rops->op_type == OP_LIST &&
2488 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2490 OP * const pushmark = lrops->op_first;
2491 lrops->op_first = pushmark->op_sibling;
2494 o = op_append_list(OP_LIST, o, rops);
2497 PL_parser->in_my = FALSE;
2498 PL_parser->in_my_stash = NULL;
2503 Perl_sawparens(pTHX_ OP *o)
2505 PERL_UNUSED_CONTEXT;
2507 o->op_flags |= OPf_PARENS;
2512 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2516 const OPCODE ltype = left->op_type;
2517 const OPCODE rtype = right->op_type;
2519 PERL_ARGS_ASSERT_BIND_MATCH;
2521 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2522 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2524 const char * const desc
2526 rtype == OP_SUBST || rtype == OP_TRANS
2527 || rtype == OP_TRANSR
2529 ? (int)rtype : OP_MATCH];
2530 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2533 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2534 ? cUNOPx(left)->op_first->op_type == OP_GV
2535 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2536 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2539 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2542 Perl_warner(aTHX_ packWARN(WARN_MISC),
2543 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2546 const char * const sample = (isary
2547 ? "@array" : "%hash");
2548 Perl_warner(aTHX_ packWARN(WARN_MISC),
2549 "Applying %s to %s will act on scalar(%s)",
2550 desc, sample, sample);
2554 if (rtype == OP_CONST &&
2555 cSVOPx(right)->op_private & OPpCONST_BARE &&
2556 cSVOPx(right)->op_private & OPpCONST_STRICT)
2558 no_bareword_allowed(right);
2561 /* !~ doesn't make sense with /r, so error on it for now */
2562 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2564 yyerror("Using !~ with s///r doesn't make sense");
2565 if (rtype == OP_TRANSR && type == OP_NOT)
2566 yyerror("Using !~ with tr///r doesn't make sense");
2568 ismatchop = (rtype == OP_MATCH ||
2569 rtype == OP_SUBST ||
2570 rtype == OP_TRANS || rtype == OP_TRANSR)
2571 && !(right->op_flags & OPf_SPECIAL);
2572 if (ismatchop && right->op_private & OPpTARGET_MY) {
2574 right->op_private &= ~OPpTARGET_MY;
2576 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2579 right->op_flags |= OPf_STACKED;
2580 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2581 ! (rtype == OP_TRANS &&
2582 right->op_private & OPpTRANS_IDENTICAL) &&
2583 ! (rtype == OP_SUBST &&
2584 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2585 newleft = op_lvalue(left, rtype);
2588 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2589 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2591 o = op_prepend_elem(rtype, scalar(newleft), right);
2593 return newUNOP(OP_NOT, 0, scalar(o));
2597 return bind_match(type, left,
2598 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2602 Perl_invert(pTHX_ OP *o)
2606 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2610 =for apidoc Amx|OP *|op_scope|OP *o
2612 Wraps up an op tree with some additional ops so that at runtime a dynamic
2613 scope will be created. The original ops run in the new dynamic scope,
2614 and then, provided that they exit normally, the scope will be unwound.
2615 The additional ops used to create and unwind the dynamic scope will
2616 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2617 instead if the ops are simple enough to not need the full dynamic scope
2624 Perl_op_scope(pTHX_ OP *o)
2628 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2629 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2630 o->op_type = OP_LEAVE;
2631 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2633 else if (o->op_type == OP_LINESEQ) {
2635 o->op_type = OP_SCOPE;
2636 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2637 kid = ((LISTOP*)o)->op_first;
2638 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2641 /* The following deals with things like 'do {1 for 1}' */
2642 kid = kid->op_sibling;
2644 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2649 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2655 Perl_block_start(pTHX_ int full)
2658 const int retval = PL_savestack_ix;
2660 pad_block_start(full);
2662 PL_hints &= ~HINT_BLOCK_SCOPE;
2663 SAVECOMPILEWARNINGS();
2664 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2666 CALL_BLOCK_HOOKS(bhk_start, full);
2672 Perl_block_end(pTHX_ I32 floor, OP *seq)
2675 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2676 OP* retval = scalarseq(seq);
2678 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2681 CopHINTS_set(&PL_compiling, PL_hints);
2683 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2686 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2692 =head1 Compile-time scope hooks
2694 =for apidoc Aox||blockhook_register
2696 Register a set of hooks to be called when the Perl lexical scope changes
2697 at compile time. See L<perlguts/"Compile-time scope hooks">.
2703 Perl_blockhook_register(pTHX_ BHK *hk)
2705 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2707 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2714 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2715 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2716 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2719 OP * const o = newOP(OP_PADSV, 0);
2720 o->op_targ = offset;
2726 Perl_newPROG(pTHX_ OP *o)
2730 PERL_ARGS_ASSERT_NEWPROG;
2736 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2737 ((PL_in_eval & EVAL_KEEPERR)
2738 ? OPf_SPECIAL : 0), o);
2740 cx = &cxstack[cxstack_ix];
2741 assert(CxTYPE(cx) == CXt_EVAL);
2743 if ((cx->blk_gimme & G_WANT) == G_VOID)
2744 scalarvoid(PL_eval_root);
2745 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2748 scalar(PL_eval_root);
2750 /* don't use LINKLIST, since PL_eval_root might indirect through
2751 * a rather expensive function call and LINKLIST evaluates its
2752 * argument more than once */
2753 PL_eval_start = op_linklist(PL_eval_root);
2754 PL_eval_root->op_private |= OPpREFCOUNTED;
2755 OpREFCNT_set(PL_eval_root, 1);
2756 PL_eval_root->op_next = 0;
2757 CALL_PEEP(PL_eval_start);
2758 finalize_optree(PL_eval_root);
2762 if (o->op_type == OP_STUB) {
2763 PL_comppad_name = 0;
2765 S_op_destroy(aTHX_ o);
2768 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2769 PL_curcop = &PL_compiling;
2770 PL_main_start = LINKLIST(PL_main_root);
2771 PL_main_root->op_private |= OPpREFCOUNTED;
2772 OpREFCNT_set(PL_main_root, 1);
2773 PL_main_root->op_next = 0;
2774 CALL_PEEP(PL_main_start);
2775 finalize_optree(PL_main_root);
2778 /* Register with debugger */
2780 CV * const cv = get_cvs("DB::postponed", 0);
2784 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2786 call_sv(MUTABLE_SV(cv), G_DISCARD);
2793 Perl_localize(pTHX_ OP *o, I32 lex)
2797 PERL_ARGS_ASSERT_LOCALIZE;
2799 if (o->op_flags & OPf_PARENS)
2800 /* [perl #17376]: this appears to be premature, and results in code such as
2801 C< our(%x); > executing in list mode rather than void mode */
2808 if ( PL_parser->bufptr > PL_parser->oldbufptr
2809 && PL_parser->bufptr[-1] == ','
2810 && ckWARN(WARN_PARENTHESIS))
2812 char *s = PL_parser->bufptr;
2815 /* some heuristics to detect a potential error */
2816 while (*s && (strchr(", \t\n", *s)))
2820 if (*s && strchr("@$%*", *s) && *++s
2821 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2824 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2826 while (*s && (strchr(", \t\n", *s)))
2832 if (sigil && (*s == ';' || *s == '=')) {
2833 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2834 "Parentheses missing around \"%s\" list",
2836 ? (PL_parser->in_my == KEY_our
2838 : PL_parser->in_my == KEY_state
2848 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2849 PL_parser->in_my = FALSE;
2850 PL_parser->in_my_stash = NULL;
2855 Perl_jmaybe(pTHX_ OP *o)
2857 PERL_ARGS_ASSERT_JMAYBE;
2859 if (o->op_type == OP_LIST) {
2861 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2862 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2867 PERL_STATIC_INLINE OP *
2868 S_op_std_init(pTHX_ OP *o)
2870 I32 type = o->op_type;
2872 PERL_ARGS_ASSERT_OP_STD_INIT;
2874 if (PL_opargs[type] & OA_RETSCALAR)
2876 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2877 o->op_targ = pad_alloc(type, SVs_PADTMP);
2882 PERL_STATIC_INLINE OP *
2883 S_op_integerize(pTHX_ OP *o)
2885 I32 type = o->op_type;
2887 PERL_ARGS_ASSERT_OP_INTEGERIZE;
2889 /* integerize op, unless it happens to be C<-foo>.
2890 * XXX should pp_i_negate() do magic string negation instead? */
2891 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2892 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2893 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2896 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2899 if (type == OP_NEGATE)
2900 /* XXX might want a ck_negate() for this */
2901 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2907 S_fold_constants(pTHX_ register OP *o)
2910 register OP * VOL curop;
2912 VOL I32 type = o->op_type;
2917 SV * const oldwarnhook = PL_warnhook;
2918 SV * const olddiehook = PL_diehook;
2922 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2924 if (!(PL_opargs[type] & OA_FOLDCONST))
2938 /* XXX what about the numeric ops? */
2939 if (PL_hints & HINT_LOCALE)
2944 if (PL_parser && PL_parser->error_count)
2945 goto nope; /* Don't try to run w/ errors */
2947 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2948 const OPCODE type = curop->op_type;
2949 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2951 type != OP_SCALAR &&
2953 type != OP_PUSHMARK)
2959 curop = LINKLIST(o);
2960 old_next = o->op_next;
2964 oldscope = PL_scopestack_ix;
2965 create_eval_scope(G_FAKINGEVAL);
2967 /* Verify that we don't need to save it: */
2968 assert(PL_curcop == &PL_compiling);
2969 StructCopy(&PL_compiling, ¬_compiling, COP);
2970 PL_curcop = ¬_compiling;
2971 /* The above ensures that we run with all the correct hints of the
2972 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2973 assert(IN_PERL_RUNTIME);
2974 PL_warnhook = PERL_WARNHOOK_FATAL;
2981 sv = *(PL_stack_sp--);
2982 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2984 /* Can't simply swipe the SV from the pad, because that relies on
2985 the op being freed "real soon now". Under MAD, this doesn't
2986 happen (see the #ifdef below). */
2989 pad_swipe(o->op_targ, FALSE);
2992 else if (SvTEMP(sv)) { /* grab mortal temp? */
2993 SvREFCNT_inc_simple_void(sv);
2998 /* Something tried to die. Abandon constant folding. */
2999 /* Pretend the error never happened. */
3001 o->op_next = old_next;
3005 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3006 PL_warnhook = oldwarnhook;
3007 PL_diehook = olddiehook;
3008 /* XXX note that this croak may fail as we've already blown away
3009 * the stack - eg any nested evals */
3010 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3013 PL_warnhook = oldwarnhook;
3014 PL_diehook = olddiehook;
3015 PL_curcop = &PL_compiling;
3017 if (PL_scopestack_ix > oldscope)
3018 delete_eval_scope();
3027 if (type == OP_RV2GV)
3028 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3030 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3031 op_getmad(o,newop,'f');
3039 S_gen_constant_list(pTHX_ register OP *o)
3043 const I32 oldtmps_floor = PL_tmps_floor;
3046 if (PL_parser && PL_parser->error_count)
3047 return o; /* Don't attempt to run with errors */
3049 PL_op = curop = LINKLIST(o);
3052 Perl_pp_pushmark(aTHX);
3055 assert (!(curop->op_flags & OPf_SPECIAL));
3056 assert(curop->op_type == OP_RANGE);
3057 Perl_pp_anonlist(aTHX);
3058 PL_tmps_floor = oldtmps_floor;
3060 o->op_type = OP_RV2AV;
3061 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3062 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3063 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3064 o->op_opt = 0; /* needs to be revisited in rpeep() */
3065 curop = ((UNOP*)o)->op_first;
3066 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3068 op_getmad(curop,o,'O');
3077 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3080 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3081 if (!o || o->op_type != OP_LIST)
3082 o = newLISTOP(OP_LIST, 0, o, NULL);
3084 o->op_flags &= ~OPf_WANT;
3086 if (!(PL_opargs[type] & OA_MARK))
3087 op_null(cLISTOPo->op_first);
3089 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3090 if (kid2 && kid2->op_type == OP_COREARGS) {
3091 op_null(cLISTOPo->op_first);
3092 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3096 o->op_type = (OPCODE)type;
3097 o->op_ppaddr = PL_ppaddr[type];
3098 o->op_flags |= flags;
3100 o = CHECKOP(type, o);
3101 if (o->op_type != (unsigned)type)
3104 return fold_constants(op_integerize(op_std_init(o)));
3108 =head1 Optree Manipulation Functions
3111 /* List constructors */
3114 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3116 Append an item to the list of ops contained directly within a list-type
3117 op, returning the lengthened list. I<first> is the list-type op,
3118 and I<last> is the op to append to the list. I<optype> specifies the
3119 intended opcode for the list. If I<first> is not already a list of the
3120 right type, it will be upgraded into one. If either I<first> or I<last>
3121 is null, the other is returned unchanged.
3127 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3135 if (first->op_type != (unsigned)type
3136 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3138 return newLISTOP(type, 0, first, last);
3141 if (first->op_flags & OPf_KIDS)
3142 ((LISTOP*)first)->op_last->op_sibling = last;
3144 first->op_flags |= OPf_KIDS;
3145 ((LISTOP*)first)->op_first = last;
3147 ((LISTOP*)first)->op_last = last;
3152 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3154 Concatenate the lists of ops contained directly within two list-type ops,
3155 returning the combined list. I<first> and I<last> are the list-type ops
3156 to concatenate. I<optype> specifies the intended opcode for the list.
3157 If either I<first> or I<last> is not already a list of the right type,
3158 it will be upgraded into one. If either I<first> or I<last> is null,
3159 the other is returned unchanged.
3165 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3173 if (first->op_type != (unsigned)type)
3174 return op_prepend_elem(type, first, last);
3176 if (last->op_type != (unsigned)type)
3177 return op_append_elem(type, first, last);
3179 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3180 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3181 first->op_flags |= (last->op_flags & OPf_KIDS);
3184 if (((LISTOP*)last)->op_first && first->op_madprop) {
3185 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3187 while (mp->mad_next)
3189 mp->mad_next = first->op_madprop;
3192 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3195 first->op_madprop = last->op_madprop;
3196 last->op_madprop = 0;
3199 S_op_destroy(aTHX_ last);
3205 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3207 Prepend an item to the list of ops contained directly within a list-type
3208 op, returning the lengthened list. I<first> is the op to prepend to the
3209 list, and I<last> is the list-type op. I<optype> specifies the intended
3210 opcode for the list. If I<last> is not already a list of the right type,
3211 it will be upgraded into one. If either I<first> or I<last> is null,
3212 the other is returned unchanged.
3218 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3226 if (last->op_type == (unsigned)type) {
3227 if (type == OP_LIST) { /* already a PUSHMARK there */
3228 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3229 ((LISTOP*)last)->op_first->op_sibling = first;
3230 if (!(first->op_flags & OPf_PARENS))
3231 last->op_flags &= ~OPf_PARENS;
3234 if (!(last->op_flags & OPf_KIDS)) {
3235 ((LISTOP*)last)->op_last = first;
3236 last->op_flags |= OPf_KIDS;
3238 first->op_sibling = ((LISTOP*)last)->op_first;
3239 ((LISTOP*)last)->op_first = first;
3241 last->op_flags |= OPf_KIDS;
3245 return newLISTOP(type, 0, first, last);
3253 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3256 Newxz(tk, 1, TOKEN);
3257 tk->tk_type = (OPCODE)optype;
3258 tk->tk_type = 12345;
3260 tk->tk_mad = madprop;
3265 Perl_token_free(pTHX_ TOKEN* tk)
3267 PERL_ARGS_ASSERT_TOKEN_FREE;
3269 if (tk->tk_type != 12345)
3271 mad_free(tk->tk_mad);
3276 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3281 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3283 if (tk->tk_type != 12345) {
3284 Perl_warner(aTHX_ packWARN(WARN_MISC),
3285 "Invalid TOKEN object ignored");
3292 /* faked up qw list? */
3294 tm->mad_type == MAD_SV &&
3295 SvPVX((SV *)tm->mad_val)[0] == 'q')
3302 /* pretend constant fold didn't happen? */
3303 if (mp->mad_key == 'f' &&
3304 (o->op_type == OP_CONST ||
3305 o->op_type == OP_GV) )
3307 token_getmad(tk,(OP*)mp->mad_val,slot);
3321 if (mp->mad_key == 'X')
3322 mp->mad_key = slot; /* just change the first one */
3332 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3341 /* pretend constant fold didn't happen? */
3342 if (mp->mad_key == 'f' &&
3343 (o->op_type == OP_CONST ||
3344 o->op_type == OP_GV) )
3346 op_getmad(from,(OP*)mp->mad_val,slot);
3353 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3356 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3362 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3371 /* pretend constant fold didn't happen? */
3372 if (mp->mad_key == 'f' &&
3373 (o->op_type == OP_CONST ||
3374 o->op_type == OP_GV) )
3376 op_getmad(from,(OP*)mp->mad_val,slot);
3383 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3386 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3390 PerlIO_printf(PerlIO_stderr(),
3391 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3397 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3415 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3419 addmad(tm, &(o->op_madprop), slot);
3423 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3444 Perl_newMADsv(pTHX_ char key, SV* sv)
3446 PERL_ARGS_ASSERT_NEWMADSV;
3448 return newMADPROP(key, MAD_SV, sv, 0);
3452 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3454 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3457 mp->mad_vlen = vlen;
3458 mp->mad_type = type;
3460 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3465 Perl_mad_free(pTHX_ MADPROP* mp)
3467 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3471 mad_free(mp->mad_next);
3472 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3473 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3474 switch (mp->mad_type) {
3478 Safefree((char*)mp->mad_val);
3481 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3482 op_free((OP*)mp->mad_val);
3485 sv_free(MUTABLE_SV(mp->mad_val));
3488 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3491 PerlMemShared_free(mp);
3497 =head1 Optree construction
3499 =for apidoc Am|OP *|newNULLLIST
3501 Constructs, checks, and returns a new C<stub> op, which represents an
3502 empty list expression.
3508 Perl_newNULLLIST(pTHX)
3510 return newOP(OP_STUB, 0);
3514 S_force_list(pTHX_ OP *o)
3516 if (!o || o->op_type != OP_LIST)
3517 o = newLISTOP(OP_LIST, 0, o, NULL);
3523 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3525 Constructs, checks, and returns an op of any list type. I<type> is
3526 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3527 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3528 supply up to two ops to be direct children of the list op; they are
3529 consumed by this function and become part of the constructed op tree.
3535 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3540 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3542 NewOp(1101, listop, 1, LISTOP);
3544 listop->op_type = (OPCODE)type;
3545 listop->op_ppaddr = PL_ppaddr[type];
3548 listop->op_flags = (U8)flags;
3552 else if (!first && last)
3555 first->op_sibling = last;
3556 listop->op_first = first;
3557 listop->op_last = last;
3558 if (type == OP_LIST) {
3559 OP* const pushop = newOP(OP_PUSHMARK, 0);
3560 pushop->op_sibling = first;
3561 listop->op_first = pushop;
3562 listop->op_flags |= OPf_KIDS;
3564 listop->op_last = pushop;
3567 return CHECKOP(type, listop);
3571 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3573 Constructs, checks, and returns an op of any base type (any type that
3574 has no extra fields). I<type> is the opcode. I<flags> gives the
3575 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3582 Perl_newOP(pTHX_ I32 type, I32 flags)
3587 if (type == -OP_ENTEREVAL) {
3588 type = OP_ENTEREVAL;
3589 flags |= OPpEVAL_BYTES<<8;
3592 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3593 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3594 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3595 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3597 NewOp(1101, o, 1, OP);
3598 o->op_type = (OPCODE)type;
3599 o->op_ppaddr = PL_ppaddr[type];
3600 o->op_flags = (U8)flags;
3602 o->op_latefreed = 0;
3606 o->op_private = (U8)(0 | (flags >> 8));
3607 if (PL_opargs[type] & OA_RETSCALAR)
3609 if (PL_opargs[type] & OA_TARGET)
3610 o->op_targ = pad_alloc(type, SVs_PADTMP);
3611 return CHECKOP(type, o);
3615 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3617 Constructs, checks, and returns an op of any unary type. I<type> is
3618 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3619 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3620 bits, the eight bits of C<op_private>, except that the bit with value 1
3621 is automatically set. I<first> supplies an optional op to be the direct
3622 child of the unary op; it is consumed by this function and become part
3623 of the constructed op tree.
3629 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3634 if (type == -OP_ENTEREVAL) {
3635 type = OP_ENTEREVAL;
3636 flags |= OPpEVAL_BYTES<<8;
3639 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3640 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3641 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3642 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3643 || type == OP_SASSIGN
3644 || type == OP_ENTERTRY
3645 || type == OP_NULL );
3648 first = newOP(OP_STUB, 0);
3649 if (PL_opargs[type] & OA_MARK)
3650 first = force_list(first);
3652 NewOp(1101, unop, 1, UNOP);
3653 unop->op_type = (OPCODE)type;
3654 unop->op_ppaddr = PL_ppaddr[type];
3655 unop->op_first = first;
3656 unop->op_flags = (U8)(flags | OPf_KIDS);
3657 unop->op_private = (U8)(1 | (flags >> 8));
3658 unop = (UNOP*) CHECKOP(type, unop);
3662 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3666 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3668 Constructs, checks, and returns an op of any binary type. I<type>
3669 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3670 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3671 the eight bits of C<op_private>, except that the bit with value 1 or
3672 2 is automatically set as required. I<first> and I<last> supply up to
3673 two ops to be the direct children of the binary op; they are consumed
3674 by this function and become part of the constructed op tree.
3680 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3685 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3686 || type == OP_SASSIGN || type == OP_NULL );
3688 NewOp(1101, binop, 1, BINOP);
3691 first = newOP(OP_NULL, 0);
3693 binop->op_type = (OPCODE)type;
3694 binop->op_ppaddr = PL_ppaddr[type];
3695 binop->op_first = first;
3696 binop->op_flags = (U8)(flags | OPf_KIDS);
3699 binop->op_private = (U8)(1 | (flags >> 8));
3702 binop->op_private = (U8)(2 | (flags >> 8));
3703 first->op_sibling = last;
3706 binop = (BINOP*)CHECKOP(type, binop);
3707 if (binop->op_next || binop->op_type != (OPCODE)type)
3710 binop->op_last = binop->op_first->op_sibling;
3712 return fold_constants(op_integerize(op_std_init((OP *)binop)));
3715 static int uvcompare(const void *a, const void *b)
3716 __attribute__nonnull__(1)
3717 __attribute__nonnull__(2)
3718 __attribute__pure__;
3719 static int uvcompare(const void *a, const void *b)
3721 if (*((const UV *)a) < (*(const UV *)b))
3723 if (*((const UV *)a) > (*(const UV *)b))
3725 if (*((const UV *)a+1) < (*(const UV *)b+1))
3727 if (*((const UV *)a+1) > (*(const UV *)b+1))
3733 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3736 SV * const tstr = ((SVOP*)expr)->op_sv;
3739 (repl->op_type == OP_NULL)
3740 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3742 ((SVOP*)repl)->op_sv;
3745 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3746 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3750 register short *tbl;
3752 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3753 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3754 I32 del = o->op_private & OPpTRANS_DELETE;
3757 PERL_ARGS_ASSERT_PMTRANS;
3759 PL_hints |= HINT_BLOCK_SCOPE;
3762 o->op_private |= OPpTRANS_FROM_UTF;
3765 o->op_private |= OPpTRANS_TO_UTF;
3767 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3768 SV* const listsv = newSVpvs("# comment\n");
3770 const U8* tend = t + tlen;
3771 const U8* rend = r + rlen;
3785 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3786 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3789 const U32 flags = UTF8_ALLOW_DEFAULT;
3793 t = tsave = bytes_to_utf8(t, &len);
3796 if (!to_utf && rlen) {
3798 r = rsave = bytes_to_utf8(r, &len);
3802 /* There are several snags with this code on EBCDIC:
3803 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3804 2. scan_const() in toke.c has encoded chars in native encoding which makes
3805 ranges at least in EBCDIC 0..255 range the bottom odd.
3809 U8 tmpbuf[UTF8_MAXBYTES+1];
3812 Newx(cp, 2*tlen, UV);
3814 transv = newSVpvs("");
3816 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3818 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3820 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3824 cp[2*i+1] = cp[2*i];
3828 qsort(cp, i, 2*sizeof(UV), uvcompare);
3829 for (j = 0; j < i; j++) {
3831 diff = val - nextmin;
3833 t = uvuni_to_utf8(tmpbuf,nextmin);
3834 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3836 U8 range_mark = UTF_TO_NATIVE(0xff);
3837 t = uvuni_to_utf8(tmpbuf, val - 1);
3838 sv_catpvn(transv, (char *)&range_mark, 1);
3839 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3846 t = uvuni_to_utf8(tmpbuf,nextmin);
3847 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3849 U8 range_mark = UTF_TO_NATIVE(0xff);
3850 sv_catpvn(transv, (char *)&range_mark, 1);
3852 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3853 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3854 t = (const U8*)SvPVX_const(transv);
3855 tlen = SvCUR(transv);
3859 else if (!rlen && !del) {
3860 r = t; rlen = tlen; rend = tend;
3863 if ((!rlen && !del) || t == r ||
3864 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3866 o->op_private |= OPpTRANS_IDENTICAL;
3870 while (t < tend || tfirst <= tlast) {
3871 /* see if we need more "t" chars */
3872 if (tfirst > tlast) {
3873 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3875 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3877 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3884 /* now see if we need more "r" chars */
3885 if (rfirst > rlast) {
3887 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3889 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3891 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3900 rfirst = rlast = 0xffffffff;
3904 /* now see which range will peter our first, if either. */
3905 tdiff = tlast - tfirst;
3906 rdiff = rlast - rfirst;
3913 if (rfirst == 0xffffffff) {
3914 diff = tdiff; /* oops, pretend rdiff is infinite */
3916 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3917 (long)tfirst, (long)tlast);
3919 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3923 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3924 (long)tfirst, (long)(tfirst + diff),
3927 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3928 (long)tfirst, (long)rfirst);
3930 if (rfirst + diff > max)
3931 max = rfirst + diff;
3933 grows = (tfirst < rfirst &&
3934 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3946 else if (max > 0xff)
3951 PerlMemShared_free(cPVOPo->op_pv);
3952 cPVOPo->op_pv = NULL;
3954 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3956 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3957 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3958 PAD_SETSV(cPADOPo->op_padix, swash);
3960 SvREADONLY_on(swash);
3962 cSVOPo->op_sv = swash;
3964 SvREFCNT_dec(listsv);
3965 SvREFCNT_dec(transv);
3967 if (!del && havefinal && rlen)
3968 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3969 newSVuv((UV)final), 0);
3972 o->op_private |= OPpTRANS_GROWS;
3978 op_getmad(expr,o,'e');
3979 op_getmad(repl,o,'r');
3987 tbl = (short*)cPVOPo->op_pv;
3989 Zero(tbl, 256, short);
3990 for (i = 0; i < (I32)tlen; i++)
3992 for (i = 0, j = 0; i < 256; i++) {
3994 if (j >= (I32)rlen) {
4003 if (i < 128 && r[j] >= 128)
4013 o->op_private |= OPpTRANS_IDENTICAL;
4015 else if (j >= (I32)rlen)
4020 PerlMemShared_realloc(tbl,
4021 (0x101+rlen-j) * sizeof(short));
4022 cPVOPo->op_pv = (char*)tbl;
4024 tbl[0x100] = (short)(rlen - j);
4025 for (i=0; i < (I32)rlen - j; i++)
4026 tbl[0x101+i] = r[j+i];
4030 if (!rlen && !del) {
4033 o->op_private |= OPpTRANS_IDENTICAL;
4035 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4036 o->op_private |= OPpTRANS_IDENTICAL;
4038 for (i = 0; i < 256; i++)
4040 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4041 if (j >= (I32)rlen) {
4043 if (tbl[t[i]] == -1)
4049 if (tbl[t[i]] == -1) {
4050 if (t[i] < 128 && r[j] >= 128)
4057 if(del && rlen == tlen) {
4058 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4059 } else if(rlen > tlen) {
4060 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4064 o->op_private |= OPpTRANS_GROWS;
4066 op_getmad(expr,o,'e');
4067 op_getmad(repl,o,'r');
4077 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4079 Constructs, checks, and returns an op of any pattern matching type.
4080 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4081 and, shifted up eight bits, the eight bits of C<op_private>.
4087 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4092 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4094 NewOp(1101, pmop, 1, PMOP);
4095 pmop->op_type = (OPCODE)type;
4096 pmop->op_ppaddr = PL_ppaddr[type];
4097 pmop->op_flags = (U8)flags;
4098 pmop->op_private = (U8)(0 | (flags >> 8));
4100 if (PL_hints & HINT_RE_TAINT)
4101 pmop->op_pmflags |= PMf_RETAINT;
4102 if (PL_hints & HINT_LOCALE) {
4103 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4105 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
4106 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4108 if (PL_hints & HINT_RE_FLAGS) {
4109 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4110 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4112 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4113 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4114 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4116 if (reflags && SvOK(reflags)) {
4117 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4123 assert(SvPOK(PL_regex_pad[0]));
4124 if (SvCUR(PL_regex_pad[0])) {
4125 /* Pop off the "packed" IV from the end. */
4126 SV *const repointer_list = PL_regex_pad[0];
4127 const char *p = SvEND(repointer_list) - sizeof(IV);
4128 const IV offset = *((IV*)p);
4130 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4132 SvEND_set(repointer_list, p);
4134 pmop->op_pmoffset = offset;
4135 /* This slot should be free, so assert this: */
4136 assert(PL_regex_pad[offset] == &PL_sv_undef);
4138 SV * const repointer = &PL_sv_undef;
4139 av_push(PL_regex_padav, repointer);
4140 pmop->op_pmoffset = av_len(PL_regex_padav);
4141 PL_regex_pad = AvARRAY(PL_regex_padav);
4145 return CHECKOP(type, pmop);
4148 /* Given some sort of match op o, and an expression expr containing a
4149 * pattern, either compile expr into a regex and attach it to o (if it's
4150 * constant), or convert expr into a runtime regcomp op sequence (if it's
4153 * isreg indicates that the pattern is part of a regex construct, eg
4154 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4155 * split "pattern", which aren't. In the former case, expr will be a list
4156 * if the pattern contains more than one term (eg /a$b/) or if it contains
4157 * a replacement, ie s/// or tr///.
4161 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4166 I32 repl_has_vars = 0;
4170 PERL_ARGS_ASSERT_PMRUNTIME;
4173 o->op_type == OP_SUBST
4174 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4176 /* last element in list is the replacement; pop it */
4178 repl = cLISTOPx(expr)->op_last;
4179 kid = cLISTOPx(expr)->op_first;
4180 while (kid->op_sibling != repl)
4181 kid = kid->op_sibling;
4182 kid->op_sibling = NULL;
4183 cLISTOPx(expr)->op_last = kid;
4186 if (isreg && expr->op_type == OP_LIST &&
4187 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4189 /* convert single element list to element */
4190 OP* const oe = expr;
4191 expr = cLISTOPx(oe)->op_first->op_sibling;
4192 cLISTOPx(oe)->op_first->op_sibling = NULL;
4193 cLISTOPx(oe)->op_last = NULL;
4197 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4198 return pmtrans(o, expr, repl);
4201 reglist = isreg && expr->op_type == OP_LIST;
4205 PL_hints |= HINT_BLOCK_SCOPE;
4208 if (expr->op_type == OP_CONST) {
4209 SV *pat = ((SVOP*)expr)->op_sv;
4210 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4212 if (o->op_flags & OPf_SPECIAL)
4213 pm_flags |= RXf_SPLIT;
4216 assert (SvUTF8(pat));
4217 } else if (SvUTF8(pat)) {
4218 /* Not doing UTF-8, despite what the SV says. Is this only if we're
4219 trapped in use 'bytes'? */
4220 /* Make a copy of the octet sequence, but without the flag on, as
4221 the compiler now honours the SvUTF8 flag on pat. */
4223 const char *const p = SvPV(pat, len);
4224 pat = newSVpvn_flags(p, len, SVs_TEMP);
4227 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4230 op_getmad(expr,(OP*)pm,'e');
4236 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4237 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4239 : OP_REGCMAYBE),0,expr);
4241 NewOp(1101, rcop, 1, LOGOP);
4242 rcop->op_type = OP_REGCOMP;
4243 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4244 rcop->op_first = scalar(expr);
4245 rcop->op_flags |= OPf_KIDS
4246 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4247 | (reglist ? OPf_STACKED : 0);
4248 rcop->op_private = 1;
4251 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4253 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4254 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4256 /* establish postfix order */
4257 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4259 rcop->op_next = expr;
4260 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4263 rcop->op_next = LINKLIST(expr);
4264 expr->op_next = (OP*)rcop;
4267 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4272 if (pm->op_pmflags & PMf_EVAL) {
4274 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4275 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4277 else if (repl->op_type == OP_CONST)
4281 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4282 if (curop->op_type == OP_SCOPE
4283 || curop->op_type == OP_LEAVE
4284 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4285 if (curop->op_type == OP_GV) {
4286 GV * const gv = cGVOPx_gv(curop);
4288 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4291 else if (curop->op_type == OP_RV2CV)
4293 else if (curop->op_type == OP_RV2SV ||
4294 curop->op_type == OP_RV2AV ||
4295 curop->op_type == OP_RV2HV ||
4296 curop->op_type == OP_RV2GV) {
4297 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4300 else if (curop->op_type == OP_PADSV ||
4301 curop->op_type == OP_PADAV ||
4302 curop->op_type == OP_PADHV ||
4303 curop->op_type == OP_PADANY)
4307 else if (curop->op_type == OP_PUSHRE)
4308 NOOP; /* Okay here, dangerous in newASSIGNOP */
4318 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4320 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4321 op_prepend_elem(o->op_type, scalar(repl), o);
4324 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4325 pm->op_pmflags |= PMf_MAYBE_CONST;
4327 NewOp(1101, rcop, 1, LOGOP);
4328 rcop->op_type = OP_SUBSTCONT;
4329 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4330 rcop->op_first = scalar(repl);
4331 rcop->op_flags |= OPf_KIDS;
4332 rcop->op_private = 1;
4335 /* establish postfix order */
4336 rcop->op_next = LINKLIST(repl);
4337 repl->op_next = (OP*)rcop;
4339 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4340 assert(!(pm->op_pmflags & PMf_ONCE));
4341 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4350 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4352 Constructs, checks, and returns an op of any type that involves an
4353 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4354 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4355 takes ownership of one reference to it.
4361 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4366 PERL_ARGS_ASSERT_NEWSVOP;
4368 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4369 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4370 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4372 NewOp(1101, svop, 1, SVOP);
4373 svop->op_type = (OPCODE)type;
4374 svop->op_ppaddr = PL_ppaddr[type];
4376 svop->op_next = (OP*)svop;
4377 svop->op_flags = (U8)flags;
4378 if (PL_opargs[type] & OA_RETSCALAR)
4380 if (PL_opargs[type] & OA_TARGET)
4381 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4382 return CHECKOP(type, svop);
4388 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4390 Constructs, checks, and returns an op of any type that involves a
4391 reference to a pad element. I<type> is the opcode. I<flags> gives the
4392 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4393 is populated with I<sv>; this function takes ownership of one reference
4396 This function only exists if Perl has been compiled to use ithreads.
4402 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4407 PERL_ARGS_ASSERT_NEWPADOP;
4409 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4410 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4411 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4413 NewOp(1101, padop, 1, PADOP);
4414 padop->op_type = (OPCODE)type;
4415 padop->op_ppaddr = PL_ppaddr[type];
4416 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4417 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4418 PAD_SETSV(padop->op_padix, sv);
4421 padop->op_next = (OP*)padop;
4422 padop->op_flags = (U8)flags;
4423 if (PL_opargs[type] & OA_RETSCALAR)
4425 if (PL_opargs[type] & OA_TARGET)
4426 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4427 return CHECKOP(type, padop);
4430 #endif /* !USE_ITHREADS */
4433 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4435 Constructs, checks, and returns an op of any type that involves an
4436 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4437 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4438 reference; calling this function does not transfer ownership of any
4445 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4449 PERL_ARGS_ASSERT_NEWGVOP;
4453 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4455 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4460 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4462 Constructs, checks, and returns an op of any type that involves an
4463 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4464 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4465 must have been allocated using L</PerlMemShared_malloc>; the memory will
4466 be freed when the op is destroyed.
4472 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4477 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4479 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4481 NewOp(1101, pvop, 1, PVOP);
4482 pvop->op_type = (OPCODE)type;
4483 pvop->op_ppaddr = PL_ppaddr[type];
4485 pvop->op_next = (OP*)pvop;
4486 pvop->op_flags = (U8)flags;
4487 if (PL_opargs[type] & OA_RETSCALAR)
4489 if (PL_opargs[type] & OA_TARGET)
4490 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4491 return CHECKOP(type, pvop);
4499 Perl_package(pTHX_ OP *o)
4502 SV *const sv = cSVOPo->op_sv;
4507 PERL_ARGS_ASSERT_PACKAGE;
4509 SAVEGENERICSV(PL_curstash);
4510 save_item(PL_curstname);
4512 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4514 sv_setsv(PL_curstname, sv);
4516 PL_hints |= HINT_BLOCK_SCOPE;
4517 PL_parser->copline = NOLINE;
4518 PL_parser->expect = XSTATE;
4523 if (!PL_madskills) {
4528 pegop = newOP(OP_NULL,0);
4529 op_getmad(o,pegop,'P');
4535 Perl_package_version( pTHX_ OP *v )
4538 U32 savehints = PL_hints;
4539 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4540 PL_hints &= ~HINT_STRICT_VARS;
4541 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4542 PL_hints = savehints;
4551 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4558 OP *pegop = newOP(OP_NULL,0);
4560 SV *use_version = NULL;
4562 PERL_ARGS_ASSERT_UTILIZE;
4564 if (idop->op_type != OP_CONST)
4565 Perl_croak(aTHX_ "Module name must be constant");
4568 op_getmad(idop,pegop,'U');
4573 SV * const vesv = ((SVOP*)version)->op_sv;
4576 op_getmad(version,pegop,'V');
4577 if (!arg && !SvNIOKp(vesv)) {
4584 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4585 Perl_croak(aTHX_ "Version number must be a constant number");
4587 /* Make copy of idop so we don't free it twice */
4588 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4590 /* Fake up a method call to VERSION */
4591 meth = newSVpvs_share("VERSION");
4592 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4593 op_append_elem(OP_LIST,
4594 op_prepend_elem(OP_LIST, pack, list(version)),
4595 newSVOP(OP_METHOD_NAMED, 0, meth)));
4599 /* Fake up an import/unimport */
4600 if (arg && arg->op_type == OP_STUB) {
4602 op_getmad(arg,pegop,'S');
4603 imop = arg; /* no import on explicit () */
4605 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4606 imop = NULL; /* use 5.0; */
4608 use_version = ((SVOP*)idop)->op_sv;
4610 idop->op_private |= OPpCONST_NOVER;
4616 op_getmad(arg,pegop,'A');
4618 /* Make copy of idop so we don't free it twice */
4619 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4621 /* Fake up a method call to import/unimport */
4623 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4624 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4625 op_append_elem(OP_LIST,
4626 op_prepend_elem(OP_LIST, pack, list(arg)),
4627 newSVOP(OP_METHOD_NAMED, 0, meth)));
4630 /* Fake up the BEGIN {}, which does its thing immediately. */
4632 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4635 op_append_elem(OP_LINESEQ,
4636 op_append_elem(OP_LINESEQ,
4637 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4638 newSTATEOP(0, NULL, veop)),
4639 newSTATEOP(0, NULL, imop) ));
4642 HV * const hinthv = GvHV(PL_hintgv);
4643 const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH);
4646 * feature bundle that corresponds to the required version. */
4647 use_version = sv_2mortal(new_version(use_version));
4648 S_enable_feature_bundle(aTHX_ use_version);
4650 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4651 if (vcmp(use_version,
4652 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4653 if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
4654 PL_hints |= HINT_STRICT_REFS;
4655 if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
4656 PL_hints |= HINT_STRICT_SUBS;
4657 if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
4658 PL_hints |= HINT_STRICT_VARS;
4660 /* otherwise they are off */
4662 if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
4663 PL_hints &= ~HINT_STRICT_REFS;
4664 if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
4665 PL_hints &= ~HINT_STRICT_SUBS;
4666 if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
4667 PL_hints &= ~HINT_STRICT_VARS;
4671 /* The "did you use incorrect case?" warning used to be here.
4672 * The problem is that on case-insensitive filesystems one
4673 * might get false positives for "use" (and "require"):
4674 * "use Strict" or "require CARP" will work. This causes
4675 * portability problems for the script: in case-strict
4676 * filesystems the script will stop working.
4678 * The "incorrect case" warning checked whether "use Foo"
4679 * imported "Foo" to your namespace, but that is wrong, too:
4680 * there is no requirement nor promise in the language that
4681 * a Foo.pm should or would contain anything in package "Foo".
4683 * There is very little Configure-wise that can be done, either:
4684 * the case-sensitivity of the build filesystem of Perl does not
4685 * help in guessing the case-sensitivity of the runtime environment.
4688 PL_hints |= HINT_BLOCK_SCOPE;
4689 PL_parser->copline = NOLINE;
4690 PL_parser->expect = XSTATE;
4691 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4692 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4696 if (!PL_madskills) {
4697 /* FIXME - don't allocate pegop if !PL_madskills */
4706 =head1 Embedding Functions
4708 =for apidoc load_module
4710 Loads the module whose name is pointed to by the string part of name.
4711 Note that the actual module name, not its filename, should be given.
4712 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4713 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4714 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
4715 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4716 arguments can be used to specify arguments to the module's import()
4717 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4718 terminated with a final NULL pointer. Note that this list can only
4719 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4720 Otherwise at least a single NULL pointer to designate the default
4721 import list is required.
4723 The reference count for each specified C<SV*> parameter is decremented.
4728 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4732 PERL_ARGS_ASSERT_LOAD_MODULE;
4734 va_start(args, ver);
4735 vload_module(flags, name, ver, &args);
4739 #ifdef PERL_IMPLICIT_CONTEXT
4741 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4745 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4746 va_start(args, ver);
4747 vload_module(flags, name, ver, &args);
4753 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4757 OP * const modname = newSVOP(OP_CONST, 0, name);
4759 PERL_ARGS_ASSERT_VLOAD_MODULE;
4761 modname->op_private |= OPpCONST_BARE;
4763 veop = newSVOP(OP_CONST, 0, ver);
4767 if (flags & PERL_LOADMOD_NOIMPORT) {
4768 imop = sawparens(newNULLLIST());
4770 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4771 imop = va_arg(*args, OP*);
4776 sv = va_arg(*args, SV*);
4778 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4779 sv = va_arg(*args, SV*);
4783 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4784 * that it has a PL_parser to play with while doing that, and also
4785 * that it doesn't mess with any existing parser, by creating a tmp
4786 * new parser with lex_start(). This won't actually be used for much,
4787 * since pp_require() will create another parser for the real work. */
4790 SAVEVPTR(PL_curcop);
4791 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4792 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4793 veop, modname, imop);
4798 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4804 PERL_ARGS_ASSERT_DOFILE;
4806 if (!force_builtin) {
4807 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4808 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4809 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4810 gv = gvp ? *gvp : NULL;
4814 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4815 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4816 op_append_elem(OP_LIST, term,
4817 scalar(newUNOP(OP_RV2CV, 0,
4818 newGVOP(OP_GV, 0, gv))))));
4821 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4827 =head1 Optree construction
4829 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4831 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4832 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4833 be set automatically, and, shifted up eight bits, the eight bits of
4834 C<op_private>, except that the bit with value 1 or 2 is automatically
4835 set as required. I<listval> and I<subscript> supply the parameters of
4836 the slice; they are consumed by this function and become part of the
4837 constructed op tree.
4843 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4845 return newBINOP(OP_LSLICE, flags,
4846 list(force_list(subscript)),
4847 list(force_list(listval)) );
4851 S_is_list_assignment(pTHX_ register const OP *o)
4859 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4860 o = cUNOPo->op_first;
4862 flags = o->op_flags;
4864 if (type == OP_COND_EXPR) {
4865 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4866 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4871 yyerror("Assignment to both a list and a scalar");
4875 if (type == OP_LIST &&
4876 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4877 o->op_private & OPpLVAL_INTRO)
4880 if (type == OP_LIST || flags & OPf_PARENS ||
4881 type == OP_RV2AV || type == OP_RV2HV ||
4882 type == OP_ASLICE || type == OP_HSLICE)
4885 if (type == OP_PADAV || type == OP_PADHV)
4888 if (type == OP_RV2SV)
4895 Helper function for newASSIGNOP to detection commonality between the
4896 lhs and the rhs. Marks all variables with PL_generation. If it
4897 returns TRUE the assignment must be able to handle common variables.
4899 PERL_STATIC_INLINE bool
4900 S_aassign_common_vars(pTHX_ OP* o)
4903 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
4904 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4905 if (curop->op_type == OP_GV) {
4906 GV *gv = cGVOPx_gv(curop);
4908 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4910 GvASSIGN_GENERATION_set(gv, PL_generation);
4912 else if (curop->op_type == OP_PADSV ||
4913 curop->op_type == OP_PADAV ||
4914 curop->op_type == OP_PADHV ||
4915 curop->op_type == OP_PADANY)
4917 if (PAD_COMPNAME_GEN(curop->op_targ)
4918 == (STRLEN)PL_generation)
4920 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4923 else if (curop->op_type == OP_RV2CV)
4925 else if (curop->op_type == OP_RV2SV ||
4926 curop->op_type == OP_RV2AV ||
4927 curop->op_type == OP_RV2HV ||
4928 curop->op_type == OP_RV2GV) {
4929 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
4932 else if (curop->op_type == OP_PUSHRE) {
4934 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4935 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4937 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4939 GvASSIGN_GENERATION_set(gv, PL_generation);
4943 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4946 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4948 GvASSIGN_GENERATION_set(gv, PL_generation);
4956 if (curop->op_flags & OPf_KIDS) {
4957 if (aassign_common_vars(curop))
4965 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4967 Constructs, checks, and returns an assignment op. I<left> and I<right>
4968 supply the parameters of the assignment; they are consumed by this
4969 function and become part of the constructed op tree.
4971 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4972 a suitable conditional optree is constructed. If I<optype> is the opcode
4973 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4974 performs the binary operation and assigns the result to the left argument.
4975 Either way, if I<optype> is non-zero then I<flags> has no effect.
4977 If I<optype> is zero, then a plain scalar or list assignment is
4978 constructed. Which type of assignment it is is automatically determined.
4979 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4980 will be set automatically, and, shifted up eight bits, the eight bits
4981 of C<op_private>, except that the bit with value 1 or 2 is automatically
4988 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4994 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4995 return newLOGOP(optype, 0,
4996 op_lvalue(scalar(left), optype),
4997 newUNOP(OP_SASSIGN, 0, scalar(right)));
5000 return newBINOP(optype, OPf_STACKED,
5001 op_lvalue(scalar(left), optype), scalar(right));
5005 if (is_list_assignment(left)) {
5006 static const char no_list_state[] = "Initialization of state variables"
5007 " in list context currently forbidden";
5009 bool maybe_common_vars = TRUE;
5012 left = op_lvalue(left, OP_AASSIGN);
5013 curop = list(force_list(left));
5014 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5015 o->op_private = (U8)(0 | (flags >> 8));
5017 if ((left->op_type == OP_LIST
5018 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5020 OP* lop = ((LISTOP*)left)->op_first;
5021 maybe_common_vars = FALSE;
5023 if (lop->op_type == OP_PADSV ||
5024 lop->op_type == OP_PADAV ||
5025 lop->op_type == OP_PADHV ||
5026 lop->op_type == OP_PADANY) {
5027 if (!(lop->op_private & OPpLVAL_INTRO))
5028 maybe_common_vars = TRUE;
5030 if (lop->op_private & OPpPAD_STATE) {
5031 if (left->op_private & OPpLVAL_INTRO) {
5032 /* Each variable in state($a, $b, $c) = ... */
5035 /* Each state variable in
5036 (state $a, my $b, our $c, $d, undef) = ... */
5038 yyerror(no_list_state);
5040 /* Each my variable in
5041 (state $a, my $b, our $c, $d, undef) = ... */
5043 } else if (lop->op_type == OP_UNDEF ||
5044 lop->op_type == OP_PUSHMARK) {
5045 /* undef may be interesting in
5046 (state $a, undef, state $c) */
5048 /* Other ops in the list. */
5049 maybe_common_vars = TRUE;
5051 lop = lop->op_sibling;
5054 else if ((left->op_private & OPpLVAL_INTRO)
5055 && ( left->op_type == OP_PADSV
5056 || left->op_type == OP_PADAV
5057 || left->op_type == OP_PADHV
5058 || left->op_type == OP_PADANY))
5060 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5061 if (left->op_private & OPpPAD_STATE) {
5062 /* All single variable list context state assignments, hence
5072 yyerror(no_list_state);
5076 /* PL_generation sorcery:
5077 * an assignment like ($a,$b) = ($c,$d) is easier than
5078 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5079 * To detect whether there are common vars, the global var
5080 * PL_generation is incremented for each assign op we compile.
5081 * Then, while compiling the assign op, we run through all the
5082 * variables on both sides of the assignment, setting a spare slot
5083 * in each of them to PL_generation. If any of them already have
5084 * that value, we know we've got commonality. We could use a
5085 * single bit marker, but then we'd have to make 2 passes, first
5086 * to clear the flag, then to test and set it. To find somewhere
5087 * to store these values, evil chicanery is done with SvUVX().
5090 if (maybe_common_vars) {
5092 if (aassign_common_vars(o))
5093 o->op_private |= OPpASSIGN_COMMON;
5097 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5098 OP* tmpop = ((LISTOP*)right)->op_first;
5099 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5100 PMOP * const pm = (PMOP*)tmpop;
5101 if (left->op_type == OP_RV2AV &&
5102 !(left->op_private & OPpLVAL_INTRO) &&
5103 !(o->op_private & OPpASSIGN_COMMON) )
5105 tmpop = ((UNOP*)left)->op_first;
5106 if (tmpop->op_type == OP_GV
5108 && !pm->op_pmreplrootu.op_pmtargetoff
5110 && !pm->op_pmreplrootu.op_pmtargetgv
5114 pm->op_pmreplrootu.op_pmtargetoff
5115 = cPADOPx(tmpop)->op_padix;
5116 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5118 pm->op_pmreplrootu.op_pmtargetgv
5119 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5120 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5122 pm->op_pmflags |= PMf_ONCE;
5123 tmpop = cUNOPo->op_first; /* to list (nulled) */
5124 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5125 tmpop->op_sibling = NULL; /* don't free split */
5126 right->op_next = tmpop->op_next; /* fix starting loc */
5127 op_free(o); /* blow off assign */
5128 right->op_flags &= ~OPf_WANT;
5129 /* "I don't know and I don't care." */
5134 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5135 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5137 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5138 if (SvIOK(sv) && SvIVX(sv) == 0)
5139 sv_setiv(sv, PL_modcount+1);
5147 right = newOP(OP_UNDEF, 0);
5148 if (right->op_type == OP_READLINE) {
5149 right->op_flags |= OPf_STACKED;
5150 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5154 o = newBINOP(OP_SASSIGN, flags,
5155 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5161 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5163 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5164 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5165 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5166 If I<label> is non-null, it supplies the name of a label to attach to
5167 the state op; this function takes ownership of the memory pointed at by
5168 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5171 If I<o> is null, the state op is returned. Otherwise the state op is
5172 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5173 is consumed by this function and becomes part of the returned op tree.
5179 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5182 const U32 seq = intro_my();
5185 NewOp(1101, cop, 1, COP);
5186 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5187 cop->op_type = OP_DBSTATE;
5188 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5191 cop->op_type = OP_NEXTSTATE;
5192 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5194 cop->op_flags = (U8)flags;
5195 CopHINTS_set(cop, PL_hints);
5197 cop->op_private |= NATIVE_HINTS;
5199 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5200 cop->op_next = (OP*)cop;
5203 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5204 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5206 Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
5208 PL_hints |= HINT_BLOCK_SCOPE;
5209 /* It seems that we need to defer freeing this pointer, as other parts
5210 of the grammar end up wanting to copy it after this op has been
5215 if (PL_parser && PL_parser->copline == NOLINE)
5216 CopLINE_set(cop, CopLINE(PL_curcop));
5218 CopLINE_set(cop, PL_parser->copline);
5220 PL_parser->copline = NOLINE;
5223 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5225 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5227 CopSTASH_set(cop, PL_curstash);
5229 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5230 /* this line can have a breakpoint - store the cop in IV */
5231 AV *av = CopFILEAVx(PL_curcop);
5233 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5234 if (svp && *svp != &PL_sv_undef ) {
5235 (void)SvIOK_on(*svp);
5236 SvIV_set(*svp, PTR2IV(cop));
5241 if (flags & OPf_SPECIAL)
5243 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5247 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5249 Constructs, checks, and returns a logical (flow control) op. I<type>
5250 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5251 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5252 the eight bits of C<op_private>, except that the bit with value 1 is
5253 automatically set. I<first> supplies the expression controlling the
5254 flow, and I<other> supplies the side (alternate) chain of ops; they are
5255 consumed by this function and become part of the constructed op tree.
5261 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5265 PERL_ARGS_ASSERT_NEWLOGOP;
5267 return new_logop(type, flags, &first, &other);
5271 S_search_const(pTHX_ OP *o)
5273 PERL_ARGS_ASSERT_SEARCH_CONST;
5275 switch (o->op_type) {
5279 if (o->op_flags & OPf_KIDS)
5280 return search_const(cUNOPo->op_first);
5287 if (!(o->op_flags & OPf_KIDS))
5289 kid = cLISTOPo->op_first;
5291 switch (kid->op_type) {
5295 kid = kid->op_sibling;
5298 if (kid != cLISTOPo->op_last)
5304 kid = cLISTOPo->op_last;
5306 return search_const(kid);
5314 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5322 int prepend_not = 0;
5324 PERL_ARGS_ASSERT_NEW_LOGOP;
5329 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5330 return newBINOP(type, flags, scalar(first), scalar(other));
5332 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5334 scalarboolean(first);
5335 /* optimize AND and OR ops that have NOTs as children */
5336 if (first->op_type == OP_NOT
5337 && (first->op_flags & OPf_KIDS)
5338 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5339 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5341 if (type == OP_AND || type == OP_OR) {
5347 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5349 prepend_not = 1; /* prepend a NOT op later */
5353 /* search for a constant op that could let us fold the test */
5354 if ((cstop = search_const(first))) {
5355 if (cstop->op_private & OPpCONST_STRICT)
5356 no_bareword_allowed(cstop);
5357 else if ((cstop->op_private & OPpCONST_BARE))
5358 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5359 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5360 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5361 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5363 if (other->op_type == OP_CONST)
5364 other->op_private |= OPpCONST_SHORTCIRCUIT;
5366 OP *newop = newUNOP(OP_NULL, 0, other);
5367 op_getmad(first, newop, '1');
5368 newop->op_targ = type; /* set "was" field */
5372 if (other->op_type == OP_LEAVE)
5373 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5374 else if (other->op_type == OP_MATCH
5375 || other->op_type == OP_SUBST
5376 || other->op_type == OP_TRANSR
5377 || other->op_type == OP_TRANS)
5378 /* Mark the op as being unbindable with =~ */
5379 other->op_flags |= OPf_SPECIAL;
5383 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5384 const OP *o2 = other;
5385 if ( ! (o2->op_type == OP_LIST
5386 && (( o2 = cUNOPx(o2)->op_first))
5387 && o2->op_type == OP_PUSHMARK
5388 && (( o2 = o2->op_sibling)) )
5391 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5392 || o2->op_type == OP_PADHV)
5393 && o2->op_private & OPpLVAL_INTRO
5394 && !(o2->op_private & OPpPAD_STATE))
5396 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5397 "Deprecated use of my() in false conditional");
5401 if (first->op_type == OP_CONST)
5402 first->op_private |= OPpCONST_SHORTCIRCUIT;
5404 first = newUNOP(OP_NULL, 0, first);
5405 op_getmad(other, first, '2');
5406 first->op_targ = type; /* set "was" field */
5413 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5414 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5416 const OP * const k1 = ((UNOP*)first)->op_first;
5417 const OP * const k2 = k1->op_sibling;
5419 switch (first->op_type)
5422 if (k2 && k2->op_type == OP_READLINE
5423 && (k2->op_flags & OPf_STACKED)
5424 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5426 warnop = k2->op_type;
5431 if (k1->op_type == OP_READDIR
5432 || k1->op_type == OP_GLOB
5433 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5434 || k1->op_type == OP_EACH
5435 || k1->op_type == OP_AEACH)
5437 warnop = ((k1->op_type == OP_NULL)
5438 ? (OPCODE)k1->op_targ : k1->op_type);
5443 const line_t oldline = CopLINE(PL_curcop);
5444 CopLINE_set(PL_curcop, PL_parser->copline);
5445 Perl_warner(aTHX_ packWARN(WARN_MISC),
5446 "Value of %s%s can be \"0\"; test with defined()",
5448 ((warnop == OP_READLINE || warnop == OP_GLOB)
5449 ? " construct" : "() operator"));
5450 CopLINE_set(PL_curcop, oldline);
5457 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5458 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5460 NewOp(1101, logop, 1, LOGOP);
5462 logop->op_type = (OPCODE)type;
5463 logop->op_ppaddr = PL_ppaddr[type];
5464 logop->op_first = first;
5465 logop->op_flags = (U8)(flags | OPf_KIDS);
5466 logop->op_other = LINKLIST(other);
5467 logop->op_private = (U8)(1 | (flags >> 8));
5469 /* establish postfix order */
5470 logop->op_next = LINKLIST(first);
5471 first->op_next = (OP*)logop;
5472 first->op_sibling = other;
5474 CHECKOP(type,logop);
5476 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5483 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5485 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5486 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5487 will be set automatically, and, shifted up eight bits, the eight bits of
5488 C<op_private>, except that the bit with value 1 is automatically set.
5489 I<first> supplies the expression selecting between the two branches,
5490 and I<trueop> and I<falseop> supply the branches; they are consumed by
5491 this function and become part of the constructed op tree.
5497 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5505 PERL_ARGS_ASSERT_NEWCONDOP;
5508 return newLOGOP(OP_AND, 0, first, trueop);
5510 return newLOGOP(OP_OR, 0, first, falseop);
5512 scalarboolean(first);
5513 if ((cstop = search_const(first))) {
5514 /* Left or right arm of the conditional? */
5515 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5516 OP *live = left ? trueop : falseop;
5517 OP *const dead = left ? falseop : trueop;
5518 if (cstop->op_private & OPpCONST_BARE &&
5519 cstop->op_private & OPpCONST_STRICT) {
5520 no_bareword_allowed(cstop);
5523 /* This is all dead code when PERL_MAD is not defined. */
5524 live = newUNOP(OP_NULL, 0, live);
5525 op_getmad(first, live, 'C');
5526 op_getmad(dead, live, left ? 'e' : 't');
5531 if (live->op_type == OP_LEAVE)
5532 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5533 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5534 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5535 /* Mark the op as being unbindable with =~ */
5536 live->op_flags |= OPf_SPECIAL;
5539 NewOp(1101, logop, 1, LOGOP);
5540 logop->op_type = OP_COND_EXPR;
5541 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5542 logop->op_first = first;
5543 logop->op_flags = (U8)(flags | OPf_KIDS);
5544 logop->op_private = (U8)(1 | (flags >> 8));
5545 logop->op_other = LINKLIST(trueop);
5546 logop->op_next = LINKLIST(falseop);
5548 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5551 /* establish postfix order */
5552 start = LINKLIST(first);
5553 first->op_next = (OP*)logop;
5555 first->op_sibling = trueop;
5556 trueop->op_sibling = falseop;
5557 o = newUNOP(OP_NULL, 0, (OP*)logop);
5559 trueop->op_next = falseop->op_next = o;
5566 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5568 Constructs and returns a C<range> op, with subordinate C<flip> and
5569 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5570 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5571 for both the C<flip> and C<range> ops, except that the bit with value
5572 1 is automatically set. I<left> and I<right> supply the expressions
5573 controlling the endpoints of the range; they are consumed by this function
5574 and become part of the constructed op tree.
5580 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5589 PERL_ARGS_ASSERT_NEWRANGE;
5591 NewOp(1101, range, 1, LOGOP);
5593 range->op_type = OP_RANGE;
5594 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5595 range->op_first = left;
5596 range->op_flags = OPf_KIDS;
5597 leftstart = LINKLIST(left);
5598 range->op_other = LINKLIST(right);
5599 range->op_private = (U8)(1 | (flags >> 8));
5601 left->op_sibling = right;
5603 range->op_next = (OP*)range;
5604 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5605 flop = newUNOP(OP_FLOP, 0, flip);
5606 o = newUNOP(OP_NULL, 0, flop);
5608 range->op_next = leftstart;
5610 left->op_next = flip;
5611 right->op_next = flop;
5613 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5614 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5615 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5616 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5618 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5619 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5621 /* check barewords before they might be optimized aways */
5622 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5623 no_bareword_allowed(left);
5624 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5625 no_bareword_allowed(right);
5628 if (!flip->op_private || !flop->op_private)
5629 LINKLIST(o); /* blow off optimizer unless constant */
5635 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5637 Constructs, checks, and returns an op tree expressing a loop. This is
5638 only a loop in the control flow through the op tree; it does not have
5639 the heavyweight loop structure that allows exiting the loop by C<last>
5640 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5641 top-level op, except that some bits will be set automatically as required.
5642 I<expr> supplies the expression controlling loop iteration, and I<block>
5643 supplies the body of the loop; they are consumed by this function and
5644 become part of the constructed op tree. I<debuggable> is currently
5645 unused and should always be 1.
5651 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5656 const bool once = block && block->op_flags & OPf_SPECIAL &&
5657 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5659 PERL_UNUSED_ARG(debuggable);
5662 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5663 return block; /* do {} while 0 does once */
5664 if (expr->op_type == OP_READLINE
5665 || expr->op_type == OP_READDIR
5666 || expr->op_type == OP_GLOB
5667 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5668 expr = newUNOP(OP_DEFINED, 0,
5669 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5670 } else if (expr->op_flags & OPf_KIDS) {
5671 const OP * const k1 = ((UNOP*)expr)->op_first;
5672 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5673 switch (expr->op_type) {
5675 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5676 && (k2->op_flags & OPf_STACKED)
5677 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5678 expr = newUNOP(OP_DEFINED, 0, expr);
5682 if (k1 && (k1->op_type == OP_READDIR
5683 || k1->op_type == OP_GLOB
5684 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5685 || k1->op_type == OP_EACH
5686 || k1->op_type == OP_AEACH))
5687 expr = newUNOP(OP_DEFINED, 0, expr);
5693 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5694 * op, in listop. This is wrong. [perl #27024] */
5696 block = newOP(OP_NULL, 0);
5697 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5698 o = new_logop(OP_AND, 0, &expr, &listop);
5701 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5703 if (once && o != listop)
5704 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5707 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5709 o->op_flags |= flags;
5711 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5716 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5718 Constructs, checks, and returns an op tree expressing a C<while> loop.
5719 This is a heavyweight loop, with structure that allows exiting the loop
5720 by C<last> and suchlike.
5722 I<loop> is an optional preconstructed C<enterloop> op to use in the
5723 loop; if it is null then a suitable op will be constructed automatically.
5724 I<expr> supplies the loop's controlling expression. I<block> supplies the
5725 main body of the loop, and I<cont> optionally supplies a C<continue> block
5726 that operates as a second half of the body. All of these optree inputs
5727 are consumed by this function and become part of the constructed op tree.
5729 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5730 op and, shifted up eight bits, the eight bits of C<op_private> for
5731 the C<leaveloop> op, except that (in both cases) some bits will be set
5732 automatically. I<debuggable> is currently unused and should always be 1.
5733 I<has_my> can be supplied as true to force the
5734 loop body to be enclosed in its own scope.
5740 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5741 OP *expr, OP *block, OP *cont, I32 has_my)
5750 PERL_UNUSED_ARG(debuggable);
5753 if (expr->op_type == OP_READLINE
5754 || expr->op_type == OP_READDIR
5755 || expr->op_type == OP_GLOB
5756 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5757 expr = newUNOP(OP_DEFINED, 0,
5758 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5759 } else if (expr->op_flags & OPf_KIDS) {
5760 const OP * const k1 = ((UNOP*)expr)->op_first;
5761 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5762 switch (expr->op_type) {
5764 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5765 && (k2->op_flags & OPf_STACKED)
5766 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5767 expr = newUNOP(OP_DEFINED, 0, expr);
5771 if (k1 && (k1->op_type == OP_READDIR
5772 || k1->op_type == OP_GLOB
5773 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5774 || k1->op_type == OP_EACH
5775 || k1->op_type == OP_AEACH))
5776 expr = newUNOP(OP_DEFINED, 0, expr);
5783 block = newOP(OP_NULL, 0);
5784 else if (cont || has_my) {
5785 block = op_scope(block);
5789 next = LINKLIST(cont);
5792 OP * const unstack = newOP(OP_UNSTACK, 0);
5795 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5799 listop = op_append_list(OP_LINESEQ, block, cont);
5801 redo = LINKLIST(listop);
5805 o = new_logop(OP_AND, 0, &expr, &listop);
5806 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5807 op_free(expr); /* oops, it's a while (0) */
5809 return NULL; /* listop already freed by new_logop */
5812 ((LISTOP*)listop)->op_last->op_next =
5813 (o == listop ? redo : LINKLIST(o));
5819 NewOp(1101,loop,1,LOOP);
5820 loop->op_type = OP_ENTERLOOP;
5821 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5822 loop->op_private = 0;
5823 loop->op_next = (OP*)loop;
5826 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5828 loop->op_redoop = redo;
5829 loop->op_lastop = o;
5830 o->op_private |= loopflags;
5833 loop->op_nextop = next;
5835 loop->op_nextop = o;
5837 o->op_flags |= flags;
5838 o->op_private |= (flags >> 8);
5843 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5845 Constructs, checks, and returns an op tree expressing a C<foreach>
5846 loop (iteration through a list of values). This is a heavyweight loop,
5847 with structure that allows exiting the loop by C<last> and suchlike.
5849 I<sv> optionally supplies the variable that will be aliased to each
5850 item in turn; if null, it defaults to C<$_> (either lexical or global).
5851 I<expr> supplies the list of values to iterate over. I<block> supplies
5852 the main body of the loop, and I<cont> optionally supplies a C<continue>
5853 block that operates as a second half of the body. All of these optree
5854 inputs are consumed by this function and become part of the constructed
5857 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5858 op and, shifted up eight bits, the eight bits of C<op_private> for
5859 the C<leaveloop> op, except that (in both cases) some bits will be set
5866 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5871 PADOFFSET padoff = 0;
5876 PERL_ARGS_ASSERT_NEWFOROP;
5879 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5880 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5881 sv->op_type = OP_RV2GV;
5882 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5884 /* The op_type check is needed to prevent a possible segfault
5885 * if the loop variable is undeclared and 'strict vars' is in
5886 * effect. This is illegal but is nonetheless parsed, so we
5887 * may reach this point with an OP_CONST where we're expecting
5890 if (cUNOPx(sv)->op_first->op_type == OP_GV
5891 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5892 iterpflags |= OPpITER_DEF;
5894 else if (sv->op_type == OP_PADSV) { /* private variable */
5895 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5896 padoff = sv->op_targ;
5906 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5908 SV *const namesv = PAD_COMPNAME_SV(padoff);
5910 const char *const name = SvPV_const(namesv, len);
5912 if (len == 2 && name[0] == '$' && name[1] == '_')
5913 iterpflags |= OPpITER_DEF;
5917 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5918 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5919 sv = newGVOP(OP_GV, 0, PL_defgv);
5924 iterpflags |= OPpITER_DEF;
5926 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5927 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5928 iterflags |= OPf_STACKED;
5930 else if (expr->op_type == OP_NULL &&
5931 (expr->op_flags & OPf_KIDS) &&
5932 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5934 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5935 * set the STACKED flag to indicate that these values are to be
5936 * treated as min/max values by 'pp_iterinit'.
5938 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5939 LOGOP* const range = (LOGOP*) flip->op_first;
5940 OP* const left = range->op_first;
5941 OP* const right = left->op_sibling;
5944 range->op_flags &= ~OPf_KIDS;
5945 range->op_first = NULL;
5947 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5948 listop->op_first->op_next = range->op_next;
5949 left->op_next = range->op_other;
5950 right->op_next = (OP*)listop;
5951 listop->op_next = listop->op_first;
5954 op_getmad(expr,(OP*)listop,'O');
5958 expr = (OP*)(listop);
5960 iterflags |= OPf_STACKED;
5963 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5966 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5967 op_append_elem(OP_LIST, expr, scalar(sv))));
5968 assert(!loop->op_next);
5969 /* for my $x () sets OPpLVAL_INTRO;
5970 * for our $x () sets OPpOUR_INTRO */
5971 loop->op_private = (U8)iterpflags;
5972 #ifdef PL_OP_SLAB_ALLOC
5975 NewOp(1234,tmp,1,LOOP);
5976 Copy(loop,tmp,1,LISTOP);
5977 S_op_destroy(aTHX_ (OP*)loop);
5981 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5983 loop->op_targ = padoff;
5984 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5986 op_getmad(madsv, (OP*)loop, 'v');
5991 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5993 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5994 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5995 determining the target of the op; it is consumed by this function and
5996 become part of the constructed op tree.
6002 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6007 PERL_ARGS_ASSERT_NEWLOOPEX;
6009 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6011 if (type != OP_GOTO || label->op_type == OP_CONST) {
6012 /* "last()" means "last" */
6013 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6014 o = newOP(type, OPf_SPECIAL);
6016 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
6017 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6021 op_getmad(label,o,'L');
6027 /* Check whether it's going to be a goto &function */
6028 if (label->op_type == OP_ENTERSUB
6029 && !(label->op_flags & OPf_STACKED))
6030 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6031 o = newUNOP(type, OPf_STACKED, label);
6033 PL_hints |= HINT_BLOCK_SCOPE;
6037 /* if the condition is a literal array or hash
6038 (or @{ ... } etc), make a reference to it.
6041 S_ref_array_or_hash(pTHX_ OP *cond)
6044 && (cond->op_type == OP_RV2AV
6045 || cond->op_type == OP_PADAV
6046 || cond->op_type == OP_RV2HV
6047 || cond->op_type == OP_PADHV))
6049 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6052 && (cond->op_type == OP_ASLICE
6053 || cond->op_type == OP_HSLICE)) {
6055 /* anonlist now needs a list from this op, was previously used in
6057 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6058 cond->op_flags |= OPf_WANT_LIST;
6060 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6067 /* These construct the optree fragments representing given()
6070 entergiven and enterwhen are LOGOPs; the op_other pointer
6071 points up to the associated leave op. We need this so we
6072 can put it in the context and make break/continue work.
6073 (Also, of course, pp_enterwhen will jump straight to
6074 op_other if the match fails.)
6078 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6079 I32 enter_opcode, I32 leave_opcode,
6080 PADOFFSET entertarg)
6086 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6088 NewOp(1101, enterop, 1, LOGOP);
6089 enterop->op_type = (Optype)enter_opcode;
6090 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6091 enterop->op_flags = (U8) OPf_KIDS;
6092 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6093 enterop->op_private = 0;
6095 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6098 enterop->op_first = scalar(cond);
6099 cond->op_sibling = block;
6101 o->op_next = LINKLIST(cond);
6102 cond->op_next = (OP *) enterop;
6105 /* This is a default {} block */
6106 enterop->op_first = block;
6107 enterop->op_flags |= OPf_SPECIAL;
6108 o ->op_flags |= OPf_SPECIAL;
6110 o->op_next = (OP *) enterop;
6113 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6114 entergiven and enterwhen both
6117 enterop->op_next = LINKLIST(block);
6118 block->op_next = enterop->op_other = o;
6123 /* Does this look like a boolean operation? For these purposes
6124 a boolean operation is:
6125 - a subroutine call [*]
6126 - a logical connective
6127 - a comparison operator
6128 - a filetest operator, with the exception of -s -M -A -C
6129 - defined(), exists() or eof()
6130 - /$re/ or $foo =~ /$re/
6132 [*] possibly surprising
6135 S_looks_like_bool(pTHX_ const OP *o)
6139 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6141 switch(o->op_type) {
6144 return looks_like_bool(cLOGOPo->op_first);
6148 looks_like_bool(cLOGOPo->op_first)
6149 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6154 o->op_flags & OPf_KIDS
6155 && looks_like_bool(cUNOPo->op_first));
6159 case OP_NOT: case OP_XOR:
6161 case OP_EQ: case OP_NE: case OP_LT:
6162 case OP_GT: case OP_LE: case OP_GE:
6164 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6165 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6167 case OP_SEQ: case OP_SNE: case OP_SLT:
6168 case OP_SGT: case OP_SLE: case OP_SGE:
6172 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6173 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6174 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6175 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6176 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6177 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6178 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6179 case OP_FTTEXT: case OP_FTBINARY:
6181 case OP_DEFINED: case OP_EXISTS:
6182 case OP_MATCH: case OP_EOF:
6189 /* Detect comparisons that have been optimized away */
6190 if (cSVOPo->op_sv == &PL_sv_yes
6191 || cSVOPo->op_sv == &PL_sv_no)
6204 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6206 Constructs, checks, and returns an op tree expressing a C<given> block.
6207 I<cond> supplies the expression that will be locally assigned to a lexical
6208 variable, and I<block> supplies the body of the C<given> construct; they
6209 are consumed by this function and become part of the constructed op tree.
6210 I<defsv_off> is the pad offset of the scalar lexical variable that will
6217 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6220 PERL_ARGS_ASSERT_NEWGIVENOP;
6221 return newGIVWHENOP(
6222 ref_array_or_hash(cond),
6224 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6229 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6231 Constructs, checks, and returns an op tree expressing a C<when> block.
6232 I<cond> supplies the test expression, and I<block> supplies the block
6233 that will be executed if the test evaluates to true; they are consumed
6234 by this function and become part of the constructed op tree. I<cond>
6235 will be interpreted DWIMically, often as a comparison against C<$_>,
6236 and may be null to generate a C<default> block.
6242 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6244 const bool cond_llb = (!cond || looks_like_bool(cond));
6247 PERL_ARGS_ASSERT_NEWWHENOP;
6252 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6254 scalar(ref_array_or_hash(cond)));
6257 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6261 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6262 const STRLEN len, const U32 flags)
6264 const char * const cvp = CvPROTO(cv);
6265 const STRLEN clen = CvPROTOLEN(cv);
6267 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6269 if (((!p != !cvp) /* One has prototype, one has not. */
6271 (flags & SVf_UTF8) == SvUTF8(cv)
6272 ? len != clen || memNE(cvp, p, len)
6274 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6276 : bytes_cmp_utf8((const U8 *)p, len,
6277 (const U8 *)cvp, clen)
6281 && ckWARN_d(WARN_PROTOTYPE)) {
6282 SV* const msg = sv_newmortal();
6286 gv_efullname3(name = sv_newmortal(), gv, NULL);
6287 sv_setpvs(msg, "Prototype mismatch:");
6289 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6291 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6292 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6295 sv_catpvs(msg, ": none");
6296 sv_catpvs(msg, " vs ");
6298 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6300 sv_catpvs(msg, "none");
6301 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6305 static void const_sv_xsub(pTHX_ CV* cv);
6309 =head1 Optree Manipulation Functions
6311 =for apidoc cv_const_sv
6313 If C<cv> is a constant sub eligible for inlining. returns the constant
6314 value returned by the sub. Otherwise, returns NULL.
6316 Constant subs can be created with C<newCONSTSUB> or as described in
6317 L<perlsub/"Constant Functions">.
6322 Perl_cv_const_sv(pTHX_ const CV *const cv)
6324 PERL_UNUSED_CONTEXT;
6327 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6329 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6332 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6333 * Can be called in 3 ways:
6336 * look for a single OP_CONST with attached value: return the value
6338 * cv && CvCLONE(cv) && !CvCONST(cv)
6340 * examine the clone prototype, and if contains only a single
6341 * OP_CONST referencing a pad const, or a single PADSV referencing
6342 * an outer lexical, return a non-zero value to indicate the CV is
6343 * a candidate for "constizing" at clone time
6347 * We have just cloned an anon prototype that was marked as a const
6348 * candidate. Try to grab the current value, and in the case of
6349 * PADSV, ignore it if it has multiple references. Return the value.
6353 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6364 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6365 o = cLISTOPo->op_first->op_sibling;
6367 for (; o; o = o->op_next) {
6368 const OPCODE type = o->op_type;
6370 if (sv && o->op_next == o)
6372 if (o->op_next != o) {
6373 if (type == OP_NEXTSTATE
6374 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6375 || type == OP_PUSHMARK)
6377 if (type == OP_DBSTATE)
6380 if (type == OP_LEAVESUB || type == OP_RETURN)
6384 if (type == OP_CONST && cSVOPo->op_sv)
6386 else if (cv && type == OP_CONST) {
6387 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6391 else if (cv && type == OP_PADSV) {
6392 if (CvCONST(cv)) { /* newly cloned anon */
6393 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6394 /* the candidate should have 1 ref from this pad and 1 ref
6395 * from the parent */
6396 if (!sv || SvREFCNT(sv) != 2)
6403 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6404 sv = &PL_sv_undef; /* an arbitrary non-null value */
6419 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6422 /* This would be the return value, but the return cannot be reached. */
6423 OP* pegop = newOP(OP_NULL, 0);
6426 PERL_UNUSED_ARG(floor);
6436 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6438 NORETURN_FUNCTION_END;
6443 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6448 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6450 register CV *cv = NULL;
6452 /* If the subroutine has no body, no attributes, and no builtin attributes
6453 then it's just a sub declaration, and we may be able to get away with
6454 storing with a placeholder scalar in the symbol table, rather than a
6455 full GV and CV. If anything is present then it will take a full CV to
6457 const I32 gv_fetch_flags
6458 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6460 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6462 const char * const name = o ? SvPV_const(cSVOPo->op_sv, namlen) : NULL;
6464 bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
6467 assert(proto->op_type == OP_CONST);
6468 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6469 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6475 gv = isGV(cSVOPo->op_sv)
6476 ? (GV *)cSVOPo->op_sv
6477 : gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6479 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6480 SV * const sv = sv_newmortal();
6481 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6482 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6483 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6484 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6486 } else if (PL_curstash) {
6487 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6490 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6494 if (!PL_madskills) {
6503 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6504 maximum a prototype before. */
6505 if (SvTYPE(gv) > SVt_NULL) {
6506 if (!SvPOK((const SV *)gv)
6507 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6509 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6511 cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
6514 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6515 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
6518 sv_setiv(MUTABLE_SV(gv), -1);
6520 SvREFCNT_dec(PL_compcv);
6521 cv = PL_compcv = NULL;
6525 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6527 if (!block || !ps || *ps || attrs
6528 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6530 || block->op_type == OP_NULL
6535 const_sv = op_const_sv(block, NULL);
6538 const bool exists = CvROOT(cv) || CvXSUB(cv);
6540 /* if the subroutine doesn't exist and wasn't pre-declared
6541 * with a prototype, assume it will be AUTOLOADed,
6542 * skipping the prototype check
6544 if (exists || SvPOK(cv))
6545 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
6546 /* already defined (or promised)? */
6547 if (exists || GvASSUMECV(gv)) {
6550 || block->op_type == OP_NULL
6553 if (CvFLAGS(PL_compcv)) {
6554 /* might have had built-in attrs applied */
6555 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6556 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6557 && ckWARN(WARN_MISC))
6558 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6560 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6561 & ~(CVf_LVALUE * pureperl));
6563 if (attrs) goto attrs;
6564 /* just a "sub foo;" when &foo is already defined */
6565 SAVEFREESV(PL_compcv);
6570 && block->op_type != OP_NULL
6573 const line_t oldline = CopLINE(PL_curcop);
6574 if (PL_parser && PL_parser->copline != NOLINE)
6575 CopLINE_set(PL_curcop, PL_parser->copline);
6576 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
6577 CopLINE_set(PL_curcop, oldline);
6579 if (!PL_minus_c) /* keep old one around for madskills */
6582 /* (PL_madskills unset in used file.) */
6591 SvREFCNT_inc_simple_void_NN(const_sv);
6593 assert(!CvROOT(cv) && !CvCONST(cv));
6594 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6595 CvXSUBANY(cv).any_ptr = const_sv;
6596 CvXSUB(cv) = const_sv_xsub;
6602 cv = newCONSTSUB_flags(
6603 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
6608 (CvGV(cv) && GvSTASH(CvGV(cv)))
6613 if (HvENAME_HEK(stash))
6614 mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
6618 SvREFCNT_dec(PL_compcv);
6622 if (cv) { /* must reuse cv if autoloaded */
6623 /* transfer PL_compcv to cv */
6626 && block->op_type != OP_NULL
6629 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6630 AV *const temp_av = CvPADLIST(cv);
6631 CV *const temp_cv = CvOUTSIDE(cv);
6633 assert(!CvWEAKOUTSIDE(cv));
6634 assert(!CvCVGV_RC(cv));
6635 assert(CvGV(cv) == gv);
6638 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6639 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6640 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6641 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6642 CvOUTSIDE(PL_compcv) = temp_cv;
6643 CvPADLIST(PL_compcv) = temp_av;
6645 if (CvFILE(cv) && CvDYNFILE(cv)) {
6646 Safefree(CvFILE(cv));
6648 CvFILE_set_from_cop(cv, PL_curcop);
6649 CvSTASH_set(cv, PL_curstash);
6651 /* inner references to PL_compcv must be fixed up ... */
6652 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6653 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6654 ++PL_sub_generation;
6657 /* Might have had built-in attributes applied -- propagate them. */
6658 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6660 /* ... before we throw it away */
6661 SvREFCNT_dec(PL_compcv);
6669 if (strEQ(name, "import")) {
6670 PL_formfeed = MUTABLE_SV(cv);
6671 /* diag_listed_as: SKIPME */
6672 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6676 if (HvENAME_HEK(GvSTASH(gv)))
6677 /* sub Foo::bar { (shift)+1 } */
6678 mro_method_changed_in(GvSTASH(gv));
6683 CvFILE_set_from_cop(cv, PL_curcop);
6684 CvSTASH_set(cv, PL_curstash);
6688 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6689 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
6692 if (PL_parser && PL_parser->error_count) {
6696 const char *s = strrchr(name, ':');
6698 if (strEQ(s, "BEGIN")) {
6699 const char not_safe[] =
6700 "BEGIN not safe after errors--compilation aborted";
6701 if (PL_in_eval & EVAL_KEEPERR)
6702 Perl_croak(aTHX_ not_safe);
6704 /* force display of errors found but not reported */
6705 sv_catpv(ERRSV, not_safe);
6706 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6715 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6716 the debugger could be able to set a breakpoint in, so signal to
6717 pp_entereval that it should not throw away any saved lines at scope
6720 PL_breakable_sub_gen++;
6721 /* This makes sub {}; work as expected. */
6722 if (block->op_type == OP_STUB) {
6723 OP* const newblock = newSTATEOP(0, NULL, 0);
6725 op_getmad(block,newblock,'B');
6731 else block->op_attached = 1;
6732 CvROOT(cv) = CvLVALUE(cv)
6733 ? newUNOP(OP_LEAVESUBLV, 0,
6734 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6735 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6736 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6737 OpREFCNT_set(CvROOT(cv), 1);
6738 CvSTART(cv) = LINKLIST(CvROOT(cv));
6739 CvROOT(cv)->op_next = 0;
6740 CALL_PEEP(CvSTART(cv));
6741 finalize_optree(CvROOT(cv));
6743 /* now that optimizer has done its work, adjust pad values */
6745 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6748 assert(!CvCONST(cv));
6749 if (ps && !*ps && op_const_sv(block, cv))
6755 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6756 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6757 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6760 if (block && has_name) {
6761 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6762 SV * const tmpstr = sv_newmortal();
6763 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6764 GV_ADDMULTI, SVt_PVHV);
6766 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6769 (long)CopLINE(PL_curcop));
6770 gv_efullname3(tmpstr, gv, NULL);
6771 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6772 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
6773 hv = GvHVn(db_postponed);
6774 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
6775 CV * const pcv = GvCV(db_postponed);
6781 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6786 if (name && ! (PL_parser && PL_parser->error_count))
6787 process_special_blocks(name, gv, cv);
6792 PL_parser->copline = NOLINE;
6798 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6801 const char *const colon = strrchr(fullname,':');
6802 const char *const name = colon ? colon + 1 : fullname;
6804 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6807 if (strEQ(name, "BEGIN")) {
6808 const I32 oldscope = PL_scopestack_ix;
6810 SAVECOPFILE(&PL_compiling);
6811 SAVECOPLINE(&PL_compiling);
6812 SAVEVPTR(PL_curcop);
6814 DEBUG_x( dump_sub(gv) );
6815 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6816 GvCV_set(gv,0); /* cv has been hijacked */
6817 call_list(oldscope, PL_beginav);
6819 CopHINTS_set(&PL_compiling, PL_hints);
6826 if strEQ(name, "END") {
6827 DEBUG_x( dump_sub(gv) );
6828 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6831 } else if (*name == 'U') {
6832 if (strEQ(name, "UNITCHECK")) {
6833 /* It's never too late to run a unitcheck block */
6834 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6838 } else if (*name == 'C') {
6839 if (strEQ(name, "CHECK")) {
6841 /* diag_listed_as: Too late to run %s block */
6842 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6843 "Too late to run CHECK block");
6844 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6848 } else if (*name == 'I') {
6849 if (strEQ(name, "INIT")) {
6851 /* diag_listed_as: Too late to run %s block */
6852 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6853 "Too late to run INIT block");
6854 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6860 DEBUG_x( dump_sub(gv) );
6861 GvCV_set(gv,0); /* cv has been hijacked */
6866 =for apidoc newCONSTSUB
6868 See L</newCONSTSUB_flags>.
6874 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6876 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
6880 =for apidoc newCONSTSUB_flags
6882 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6883 eligible for inlining at compile-time.
6885 Currently, the only useful value for C<flags> is SVf_UTF8.
6887 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6888 which won't be called if used as a destructor, but will suppress the overhead
6889 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6896 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
6902 const char *const file = CopFILE(PL_curcop);
6904 SV *const temp_sv = CopFILESV(PL_curcop);
6905 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6910 if (IN_PERL_RUNTIME) {
6911 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6912 * an op shared between threads. Use a non-shared COP for our
6914 SAVEVPTR(PL_curcop);
6915 SAVECOMPILEWARNINGS();
6916 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6917 PL_curcop = &PL_compiling;
6919 SAVECOPLINE(PL_curcop);
6920 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6923 PL_hints &= ~HINT_BLOCK_SCOPE;
6926 SAVEGENERICSV(PL_curstash);
6927 SAVECOPSTASH(PL_curcop);
6928 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
6929 CopSTASH_set(PL_curcop,stash);
6932 /* file becomes the CvFILE. For an XS, it's usually static storage,
6933 and so doesn't get free()d. (It's expected to be from the C pre-
6934 processor __FILE__ directive). But we need a dynamically allocated one,
6935 and we need it to get freed. */
6936 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
6937 &sv, XS_DYNAMIC_FILENAME | flags);
6938 CvXSUBANY(cv).any_ptr = sv;
6943 CopSTASH_free(PL_curcop);
6951 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6952 const char *const filename, const char *const proto,
6955 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6956 return newXS_len_flags(
6957 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
6962 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
6963 XSUBADDR_t subaddr, const char *const filename,
6964 const char *const proto, SV **const_svp,
6969 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
6972 GV * const gv = name
6974 name,len,GV_ADDMULTI|flags,SVt_PVCV
6977 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6978 GV_ADDMULTI | flags, SVt_PVCV);
6981 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6983 if ((cv = (name ? GvCV(gv) : NULL))) {
6985 /* just a cached method */
6989 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6990 /* already defined (or promised) */
6991 /* Redundant check that allows us to avoid creating an SV
6992 most of the time: */
6993 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
6994 const line_t oldline = CopLINE(PL_curcop);
6995 if (PL_parser && PL_parser->copline != NOLINE)
6996 CopLINE_set(PL_curcop, PL_parser->copline);
6997 report_redefined_cv(newSVpvn_flags(
6998 name,len,(flags&SVf_UTF8)|SVs_TEMP
7001 CopLINE_set(PL_curcop, oldline);
7008 if (cv) /* must reuse cv if autoloaded */
7011 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7015 if (HvENAME_HEK(GvSTASH(gv)))
7016 mro_method_changed_in(GvSTASH(gv)); /* newXS */
7022 (void)gv_fetchfile(filename);
7023 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7024 an external constant string */
7025 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7027 CvXSUB(cv) = subaddr;
7030 process_special_blocks(name, gv, cv);
7033 if (flags & XS_DYNAMIC_FILENAME) {
7034 CvFILE(cv) = savepv(filename);
7037 sv_setpv(MUTABLE_SV(cv), proto);
7042 =for apidoc U||newXS
7044 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7045 static storage, as it is used directly as CvFILE(), without a copy being made.
7051 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7053 PERL_ARGS_ASSERT_NEWXS;
7054 return newXS_flags(name, subaddr, filename, NULL, 0);
7062 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7067 OP* pegop = newOP(OP_NULL, 0);
7071 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7072 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7075 if ((cv = GvFORM(gv))) {
7076 if (ckWARN(WARN_REDEFINE)) {
7077 const line_t oldline = CopLINE(PL_curcop);
7078 if (PL_parser && PL_parser->copline != NOLINE)
7079 CopLINE_set(PL_curcop, PL_parser->copline);
7081 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7082 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7084 /* diag_listed_as: Format %s redefined */
7085 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7086 "Format STDOUT redefined");
7088 CopLINE_set(PL_curcop, oldline);
7095 CvFILE_set_from_cop(cv, PL_curcop);
7098 pad_tidy(padtidy_FORMAT);
7099 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7100 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7101 OpREFCNT_set(CvROOT(cv), 1);
7102 CvSTART(cv) = LINKLIST(CvROOT(cv));
7103 CvROOT(cv)->op_next = 0;
7104 CALL_PEEP(CvSTART(cv));
7105 finalize_optree(CvROOT(cv));
7107 op_getmad(o,pegop,'n');
7108 op_getmad_weak(block, pegop, 'b');
7113 PL_parser->copline = NOLINE;
7121 Perl_newANONLIST(pTHX_ OP *o)
7123 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7127 Perl_newANONHASH(pTHX_ OP *o)
7129 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7133 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7135 return newANONATTRSUB(floor, proto, NULL, block);
7139 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7141 return newUNOP(OP_REFGEN, 0,
7142 newSVOP(OP_ANONCODE, 0,
7143 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7147 Perl_oopsAV(pTHX_ OP *o)
7151 PERL_ARGS_ASSERT_OOPSAV;
7153 switch (o->op_type) {
7155 o->op_type = OP_PADAV;
7156 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7157 return ref(o, OP_RV2AV);
7160 o->op_type = OP_RV2AV;
7161 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7166 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7173 Perl_oopsHV(pTHX_ OP *o)
7177 PERL_ARGS_ASSERT_OOPSHV;
7179 switch (o->op_type) {
7182 o->op_type = OP_PADHV;
7183 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7184 return ref(o, OP_RV2HV);
7188 o->op_type = OP_RV2HV;
7189 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7194 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7201 Perl_newAVREF(pTHX_ OP *o)
7205 PERL_ARGS_ASSERT_NEWAVREF;
7207 if (o->op_type == OP_PADANY) {
7208 o->op_type = OP_PADAV;
7209 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7212 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7213 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7214 "Using an array as a reference is deprecated");
7216 return newUNOP(OP_RV2AV, 0, scalar(o));
7220 Perl_newGVREF(pTHX_ I32 type, OP *o)
7222 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7223 return newUNOP(OP_NULL, 0, o);
7224 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7228 Perl_newHVREF(pTHX_ OP *o)
7232 PERL_ARGS_ASSERT_NEWHVREF;
7234 if (o->op_type == OP_PADANY) {
7235 o->op_type = OP_PADHV;
7236 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7239 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7240 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7241 "Using a hash as a reference is deprecated");
7243 return newUNOP(OP_RV2HV, 0, scalar(o));
7247 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7249 return newUNOP(OP_RV2CV, flags, scalar(o));
7253 Perl_newSVREF(pTHX_ OP *o)
7257 PERL_ARGS_ASSERT_NEWSVREF;
7259 if (o->op_type == OP_PADANY) {
7260 o->op_type = OP_PADSV;
7261 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7264 return newUNOP(OP_RV2SV, 0, scalar(o));
7267 /* Check routines. See the comments at the top of this file for details
7268 * on when these are called */
7271 Perl_ck_anoncode(pTHX_ OP *o)
7273 PERL_ARGS_ASSERT_CK_ANONCODE;
7275 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7277 cSVOPo->op_sv = NULL;
7282 Perl_ck_bitop(pTHX_ OP *o)
7286 PERL_ARGS_ASSERT_CK_BITOP;
7288 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7289 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7290 && (o->op_type == OP_BIT_OR
7291 || o->op_type == OP_BIT_AND
7292 || o->op_type == OP_BIT_XOR))
7294 const OP * const left = cBINOPo->op_first;
7295 const OP * const right = left->op_sibling;
7296 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7297 (left->op_flags & OPf_PARENS) == 0) ||
7298 (OP_IS_NUMCOMPARE(right->op_type) &&
7299 (right->op_flags & OPf_PARENS) == 0))
7300 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7301 "Possible precedence problem on bitwise %c operator",
7302 o->op_type == OP_BIT_OR ? '|'
7303 : o->op_type == OP_BIT_AND ? '&' : '^'
7309 PERL_STATIC_INLINE bool
7310 is_dollar_bracket(pTHX_ const OP * const o)
7313 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
7314 && (kid = cUNOPx(o)->op_first)
7315 && kid->op_type == OP_GV
7316 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
7320 Perl_ck_cmp(pTHX_ OP *o)
7322 PERL_ARGS_ASSERT_CK_CMP;
7323 if (ckWARN(WARN_SYNTAX)) {
7324 const OP *kid = cUNOPo->op_first;
7327 is_dollar_bracket(aTHX_ kid)
7328 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
7330 || ( kid->op_type == OP_CONST
7331 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
7333 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7334 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
7340 Perl_ck_concat(pTHX_ OP *o)
7342 const OP * const kid = cUNOPo->op_first;
7344 PERL_ARGS_ASSERT_CK_CONCAT;
7345 PERL_UNUSED_CONTEXT;
7347 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7348 !(kUNOP->op_first->op_flags & OPf_MOD))
7349 o->op_flags |= OPf_STACKED;
7354 Perl_ck_spair(pTHX_ OP *o)
7358 PERL_ARGS_ASSERT_CK_SPAIR;
7360 if (o->op_flags & OPf_KIDS) {
7363 const OPCODE type = o->op_type;
7364 o = modkids(ck_fun(o), type);
7365 kid = cUNOPo->op_first;
7366 newop = kUNOP->op_first->op_sibling;
7368 const OPCODE type = newop->op_type;
7369 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7370 type == OP_PADAV || type == OP_PADHV ||
7371 type == OP_RV2AV || type == OP_RV2HV)
7375 op_getmad(kUNOP->op_first,newop,'K');
7377 op_free(kUNOP->op_first);
7379 kUNOP->op_first = newop;
7381 o->op_ppaddr = PL_ppaddr[++o->op_type];
7386 Perl_ck_delete(pTHX_ OP *o)
7388 PERL_ARGS_ASSERT_CK_DELETE;
7392 if (o->op_flags & OPf_KIDS) {
7393 OP * const kid = cUNOPo->op_first;
7394 switch (kid->op_type) {
7396 o->op_flags |= OPf_SPECIAL;
7399 o->op_private |= OPpSLICE;
7402 o->op_flags |= OPf_SPECIAL;
7407 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7410 if (kid->op_private & OPpLVAL_INTRO)
7411 o->op_private |= OPpLVAL_INTRO;
7418 Perl_ck_die(pTHX_ OP *o)
7420 PERL_ARGS_ASSERT_CK_DIE;
7423 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7429 Perl_ck_eof(pTHX_ OP *o)
7433 PERL_ARGS_ASSERT_CK_EOF;
7435 if (o->op_flags & OPf_KIDS) {
7437 if (cLISTOPo->op_first->op_type == OP_STUB) {
7439 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7441 op_getmad(o,newop,'O');
7448 kid = cLISTOPo->op_first;
7449 if (kid->op_type == OP_RV2GV)
7450 kid->op_private |= OPpALLOW_FAKE;
7456 Perl_ck_eval(pTHX_ OP *o)
7460 PERL_ARGS_ASSERT_CK_EVAL;
7462 PL_hints |= HINT_BLOCK_SCOPE;
7463 if (o->op_flags & OPf_KIDS) {
7464 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7467 o->op_flags &= ~OPf_KIDS;
7470 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7476 cUNOPo->op_first = 0;
7481 NewOp(1101, enter, 1, LOGOP);
7482 enter->op_type = OP_ENTERTRY;
7483 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7484 enter->op_private = 0;
7486 /* establish postfix order */
7487 enter->op_next = (OP*)enter;
7489 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7490 o->op_type = OP_LEAVETRY;
7491 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7492 enter->op_other = o;
7493 op_getmad(oldo,o,'O');
7502 const U8 priv = o->op_private;
7508 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
7509 op_getmad(oldo,o,'O');
7511 o->op_targ = (PADOFFSET)PL_hints;
7512 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7513 if ((PL_hints & HINT_LOCALIZE_HH) != 0
7514 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
7515 /* Store a copy of %^H that pp_entereval can pick up. */
7516 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7517 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7518 cUNOPo->op_first->op_sibling = hhop;
7519 o->op_private |= OPpEVAL_HAS_HH;
7521 if (!(o->op_private & OPpEVAL_BYTES)
7522 && FEATURE_UNIEVAL_IS_ENABLED)
7523 o->op_private |= OPpEVAL_UNICODE;
7529 Perl_ck_exit(pTHX_ OP *o)
7531 PERL_ARGS_ASSERT_CK_EXIT;
7534 HV * const table = GvHV(PL_hintgv);
7536 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7537 if (svp && *svp && SvTRUE(*svp))
7538 o->op_private |= OPpEXIT_VMSISH;
7540 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7546 Perl_ck_exec(pTHX_ OP *o)
7548 PERL_ARGS_ASSERT_CK_EXEC;
7550 if (o->op_flags & OPf_STACKED) {
7553 kid = cUNOPo->op_first->op_sibling;
7554 if (kid->op_type == OP_RV2GV)
7563 Perl_ck_exists(pTHX_ OP *o)
7567 PERL_ARGS_ASSERT_CK_EXISTS;
7570 if (o->op_flags & OPf_KIDS) {
7571 OP * const kid = cUNOPo->op_first;
7572 if (kid->op_type == OP_ENTERSUB) {
7573 (void) ref(kid, o->op_type);
7574 if (kid->op_type != OP_RV2CV
7575 && !(PL_parser && PL_parser->error_count))
7576 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7578 o->op_private |= OPpEXISTS_SUB;
7580 else if (kid->op_type == OP_AELEM)
7581 o->op_flags |= OPf_SPECIAL;
7582 else if (kid->op_type != OP_HELEM)
7583 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7591 Perl_ck_rvconst(pTHX_ register OP *o)
7594 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7596 PERL_ARGS_ASSERT_CK_RVCONST;
7598 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7599 if (o->op_type == OP_RV2CV)
7600 o->op_private &= ~1;
7602 if (kid->op_type == OP_CONST) {
7605 SV * const kidsv = kid->op_sv;
7607 /* Is it a constant from cv_const_sv()? */
7608 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7609 SV * const rsv = SvRV(kidsv);
7610 const svtype type = SvTYPE(rsv);
7611 const char *badtype = NULL;
7613 switch (o->op_type) {
7615 if (type > SVt_PVMG)
7616 badtype = "a SCALAR";
7619 if (type != SVt_PVAV)
7620 badtype = "an ARRAY";
7623 if (type != SVt_PVHV)
7627 if (type != SVt_PVCV)
7632 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7635 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7636 const char *badthing;
7637 switch (o->op_type) {
7639 badthing = "a SCALAR";
7642 badthing = "an ARRAY";
7645 badthing = "a HASH";
7653 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7654 SVfARG(kidsv), badthing);
7657 * This is a little tricky. We only want to add the symbol if we
7658 * didn't add it in the lexer. Otherwise we get duplicate strict
7659 * warnings. But if we didn't add it in the lexer, we must at
7660 * least pretend like we wanted to add it even if it existed before,
7661 * or we get possible typo warnings. OPpCONST_ENTERED says
7662 * whether the lexer already added THIS instance of this symbol.
7664 iscv = (o->op_type == OP_RV2CV) * 2;
7666 gv = gv_fetchsv(kidsv,
7667 iscv | !(kid->op_private & OPpCONST_ENTERED),
7670 : o->op_type == OP_RV2SV
7672 : o->op_type == OP_RV2AV
7674 : o->op_type == OP_RV2HV
7677 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7679 kid->op_type = OP_GV;
7680 SvREFCNT_dec(kid->op_sv);
7682 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7683 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7684 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7686 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7688 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7690 kid->op_private = 0;
7691 kid->op_ppaddr = PL_ppaddr[OP_GV];
7692 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7700 Perl_ck_ftst(pTHX_ OP *o)
7703 const I32 type = o->op_type;
7705 PERL_ARGS_ASSERT_CK_FTST;
7707 if (o->op_flags & OPf_REF) {
7710 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7711 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7712 const OPCODE kidtype = kid->op_type;
7714 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7715 OP * const newop = newGVOP(type, OPf_REF,
7716 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7718 op_getmad(o,newop,'O');
7724 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7725 o->op_private |= OPpFT_ACCESS;
7726 if (PL_check[kidtype] == Perl_ck_ftst
7727 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7728 o->op_private |= OPpFT_STACKED;
7729 kid->op_private |= OPpFT_STACKING;
7738 if (type == OP_FTTTY)
7739 o = newGVOP(type, OPf_REF, PL_stdingv);
7741 o = newUNOP(type, 0, newDEFSVOP());
7742 op_getmad(oldo,o,'O');
7748 Perl_ck_fun(pTHX_ OP *o)
7751 const int type = o->op_type;
7752 register I32 oa = PL_opargs[type] >> OASHIFT;
7754 PERL_ARGS_ASSERT_CK_FUN;
7756 if (o->op_flags & OPf_STACKED) {
7757 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7760 return no_fh_allowed(o);
7763 if (o->op_flags & OPf_KIDS) {
7764 OP **tokid = &cLISTOPo->op_first;
7765 register OP *kid = cLISTOPo->op_first;
7768 bool seen_optional = FALSE;
7770 if (kid->op_type == OP_PUSHMARK ||
7771 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7773 tokid = &kid->op_sibling;
7774 kid = kid->op_sibling;
7776 if (kid && kid->op_type == OP_COREARGS) {
7777 bool optional = FALSE;
7780 if (oa & OA_OPTIONAL) optional = TRUE;
7783 if (optional) o->op_private |= numargs;
7788 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
7789 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
7790 *tokid = kid = newDEFSVOP();
7791 seen_optional = TRUE;
7796 sibl = kid->op_sibling;
7798 if (!sibl && kid->op_type == OP_STUB) {
7805 /* list seen where single (scalar) arg expected? */
7806 if (numargs == 1 && !(oa >> 4)
7807 && kid->op_type == OP_LIST && type != OP_SCALAR)
7809 return too_many_arguments(o,PL_op_desc[type]);
7822 if ((type == OP_PUSH || type == OP_UNSHIFT)
7823 && !kid->op_sibling)
7824 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7825 "Useless use of %s with no values",
7828 if (kid->op_type == OP_CONST &&
7829 (kid->op_private & OPpCONST_BARE))
7831 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7832 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7833 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7834 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7835 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7837 op_getmad(kid,newop,'K');
7842 kid->op_sibling = sibl;
7845 else if (kid->op_type == OP_CONST
7846 && ( !SvROK(cSVOPx_sv(kid))
7847 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7849 bad_type(numargs, "array", PL_op_desc[type], kid);
7850 /* Defer checks to run-time if we have a scalar arg */
7851 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7852 op_lvalue(kid, type);
7856 if (kid->op_type == OP_CONST &&
7857 (kid->op_private & OPpCONST_BARE))
7859 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7860 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7861 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7862 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7863 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7865 op_getmad(kid,newop,'K');
7870 kid->op_sibling = sibl;
7873 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7874 bad_type(numargs, "hash", PL_op_desc[type], kid);
7875 op_lvalue(kid, type);
7879 OP * const newop = newUNOP(OP_NULL, 0, kid);
7880 kid->op_sibling = 0;
7882 newop->op_next = newop;
7884 kid->op_sibling = sibl;
7889 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7890 if (kid->op_type == OP_CONST &&
7891 (kid->op_private & OPpCONST_BARE))
7893 OP * const newop = newGVOP(OP_GV, 0,
7894 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7895 if (!(o->op_private & 1) && /* if not unop */
7896 kid == cLISTOPo->op_last)
7897 cLISTOPo->op_last = newop;
7899 op_getmad(kid,newop,'K');
7905 else if (kid->op_type == OP_READLINE) {
7906 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7907 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7910 I32 flags = OPf_SPECIAL;
7914 /* is this op a FH constructor? */
7915 if (is_handle_constructor(o,numargs)) {
7916 const char *name = NULL;
7919 bool want_dollar = TRUE;
7922 /* Set a flag to tell rv2gv to vivify
7923 * need to "prove" flag does not mean something
7924 * else already - NI-S 1999/05/07
7927 if (kid->op_type == OP_PADSV) {
7929 = PAD_COMPNAME_SV(kid->op_targ);
7930 name = SvPV_const(namesv, len);
7931 name_utf8 = SvUTF8(namesv);
7933 else if (kid->op_type == OP_RV2SV
7934 && kUNOP->op_first->op_type == OP_GV)
7936 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7938 len = GvNAMELEN(gv);
7939 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
7941 else if (kid->op_type == OP_AELEM
7942 || kid->op_type == OP_HELEM)
7945 OP *op = ((BINOP*)kid)->op_first;
7949 const char * const a =
7950 kid->op_type == OP_AELEM ?
7952 if (((op->op_type == OP_RV2AV) ||
7953 (op->op_type == OP_RV2HV)) &&
7954 (firstop = ((UNOP*)op)->op_first) &&
7955 (firstop->op_type == OP_GV)) {
7956 /* packagevar $a[] or $h{} */
7957 GV * const gv = cGVOPx_gv(firstop);
7965 else if (op->op_type == OP_PADAV
7966 || op->op_type == OP_PADHV) {
7967 /* lexicalvar $a[] or $h{} */
7968 const char * const padname =
7969 PAD_COMPNAME_PV(op->op_targ);
7978 name = SvPV_const(tmpstr, len);
7979 name_utf8 = SvUTF8(tmpstr);
7984 name = "__ANONIO__";
7986 want_dollar = FALSE;
7988 op_lvalue(kid, type);
7992 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7993 namesv = PAD_SVl(targ);
7994 SvUPGRADE(namesv, SVt_PV);
7995 if (want_dollar && *name != '$')
7996 sv_setpvs(namesv, "$");
7997 sv_catpvn(namesv, name, len);
7998 if ( name_utf8 ) SvUTF8_on(namesv);
8001 kid->op_sibling = 0;
8002 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8003 kid->op_targ = targ;
8004 kid->op_private |= priv;
8006 kid->op_sibling = sibl;
8012 op_lvalue(scalar(kid), type);
8016 tokid = &kid->op_sibling;
8017 kid = kid->op_sibling;
8020 if (kid && kid->op_type != OP_STUB)
8021 return too_many_arguments(o,OP_DESC(o));
8022 o->op_private |= numargs;
8024 /* FIXME - should the numargs move as for the PERL_MAD case? */
8025 o->op_private |= numargs;
8027 return too_many_arguments(o,OP_DESC(o));
8031 else if (PL_opargs[type] & OA_DEFGV) {
8033 OP *newop = newUNOP(type, 0, newDEFSVOP());
8034 op_getmad(o,newop,'O');
8037 /* Ordering of these two is important to keep f_map.t passing. */
8039 return newUNOP(type, 0, newDEFSVOP());
8044 while (oa & OA_OPTIONAL)
8046 if (oa && oa != OA_LIST)
8047 return too_few_arguments(o,OP_DESC(o));
8053 Perl_ck_glob(pTHX_ OP *o)
8057 const bool core = o->op_flags & OPf_SPECIAL;
8059 PERL_ARGS_ASSERT_CK_GLOB;
8062 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8063 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8065 if (core) gv = NULL;
8066 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
8067 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8069 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
8072 #if !defined(PERL_EXTERNAL_GLOB)
8073 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8075 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8076 newSVpvs("File::Glob"), NULL, NULL, NULL);
8079 #endif /* !PERL_EXTERNAL_GLOB */
8081 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8084 * \ null - const(wildcard)
8089 * \ mark - glob - rv2cv
8090 * | \ gv(CORE::GLOBAL::glob)
8092 * \ null - const(wildcard) - const(ix)
8094 o->op_flags |= OPf_SPECIAL;
8095 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8096 op_append_elem(OP_GLOB, o,
8097 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
8098 o = newLISTOP(OP_LIST, 0, o, NULL);
8099 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
8100 op_append_elem(OP_LIST, o,
8101 scalar(newUNOP(OP_RV2CV, 0,
8102 newGVOP(OP_GV, 0, gv)))));
8103 o = newUNOP(OP_NULL, 0, ck_subr(o));
8104 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8107 else o->op_flags &= ~OPf_SPECIAL;
8108 gv = newGVgen("main");
8110 #ifndef PERL_EXTERNAL_GLOB
8111 sv_setiv(GvSVn(gv),PL_glob_index++);
8113 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8119 Perl_ck_grep(pTHX_ OP *o)
8124 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8127 PERL_ARGS_ASSERT_CK_GREP;
8129 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8130 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8132 if (o->op_flags & OPf_STACKED) {
8135 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8136 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8137 return no_fh_allowed(o);
8138 for (k = kid; k; k = k->op_next) {
8141 NewOp(1101, gwop, 1, LOGOP);
8142 kid->op_next = (OP*)gwop;
8143 o->op_flags &= ~OPf_STACKED;
8145 kid = cLISTOPo->op_first->op_sibling;
8146 if (type == OP_MAPWHILE)
8151 if (PL_parser && PL_parser->error_count)
8153 kid = cLISTOPo->op_first->op_sibling;
8154 if (kid->op_type != OP_NULL)
8155 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
8156 kid = kUNOP->op_first;
8159 NewOp(1101, gwop, 1, LOGOP);
8160 gwop->op_type = type;
8161 gwop->op_ppaddr = PL_ppaddr[type];
8162 gwop->op_first = listkids(o);
8163 gwop->op_flags |= OPf_KIDS;
8164 gwop->op_other = LINKLIST(kid);
8165 kid->op_next = (OP*)gwop;
8166 offset = pad_findmy_pvs("$_", 0);
8167 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8168 o->op_private = gwop->op_private = 0;
8169 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8172 o->op_private = gwop->op_private = OPpGREP_LEX;
8173 gwop->op_targ = o->op_targ = offset;
8176 kid = cLISTOPo->op_first->op_sibling;
8177 if (!kid || !kid->op_sibling)
8178 return too_few_arguments(o,OP_DESC(o));
8179 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8180 op_lvalue(kid, OP_GREPSTART);
8186 Perl_ck_index(pTHX_ OP *o)
8188 PERL_ARGS_ASSERT_CK_INDEX;
8190 if (o->op_flags & OPf_KIDS) {
8191 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8193 kid = kid->op_sibling; /* get past "big" */
8194 if (kid && kid->op_type == OP_CONST) {
8195 const bool save_taint = PL_tainted;
8196 fbm_compile(((SVOP*)kid)->op_sv, 0);
8197 PL_tainted = save_taint;
8204 Perl_ck_lfun(pTHX_ OP *o)
8206 const OPCODE type = o->op_type;
8208 PERL_ARGS_ASSERT_CK_LFUN;
8210 return modkids(ck_fun(o), type);
8214 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8216 PERL_ARGS_ASSERT_CK_DEFINED;
8218 if ((o->op_flags & OPf_KIDS)) {
8219 switch (cUNOPo->op_first->op_type) {
8222 case OP_AASSIGN: /* Is this a good idea? */
8223 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8224 "defined(@array) is deprecated");
8225 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8226 "\t(Maybe you should just omit the defined()?)\n");
8230 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8231 "defined(%%hash) is deprecated");
8232 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8233 "\t(Maybe you should just omit the defined()?)\n");
8244 Perl_ck_readline(pTHX_ OP *o)
8246 PERL_ARGS_ASSERT_CK_READLINE;
8248 if (o->op_flags & OPf_KIDS) {
8249 OP *kid = cLISTOPo->op_first;
8250 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
8254 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8256 op_getmad(o,newop,'O');
8266 Perl_ck_rfun(pTHX_ OP *o)
8268 const OPCODE type = o->op_type;
8270 PERL_ARGS_ASSERT_CK_RFUN;
8272 return refkids(ck_fun(o), type);
8276 Perl_ck_listiob(pTHX_ OP *o)
8280 PERL_ARGS_ASSERT_CK_LISTIOB;
8282 kid = cLISTOPo->op_first;
8285 kid = cLISTOPo->op_first;
8287 if (kid->op_type == OP_PUSHMARK)
8288 kid = kid->op_sibling;
8289 if (kid && o->op_flags & OPf_STACKED)
8290 kid = kid->op_sibling;
8291 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8292 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8293 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8294 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8295 cLISTOPo->op_first->op_sibling = kid;
8296 cLISTOPo->op_last = kid;
8297 kid = kid->op_sibling;
8302 op_append_elem(o->op_type, o, newDEFSVOP());
8304 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
8309 Perl_ck_smartmatch(pTHX_ OP *o)
8312 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8313 if (0 == (o->op_flags & OPf_SPECIAL)) {
8314 OP *first = cBINOPo->op_first;
8315 OP *second = first->op_sibling;
8317 /* Implicitly take a reference to an array or hash */
8318 first->op_sibling = NULL;
8319 first = cBINOPo->op_first = ref_array_or_hash(first);
8320 second = first->op_sibling = ref_array_or_hash(second);
8322 /* Implicitly take a reference to a regular expression */
8323 if (first->op_type == OP_MATCH) {
8324 first->op_type = OP_QR;
8325 first->op_ppaddr = PL_ppaddr[OP_QR];
8327 if (second->op_type == OP_MATCH) {
8328 second->op_type = OP_QR;
8329 second->op_ppaddr = PL_ppaddr[OP_QR];
8338 Perl_ck_sassign(pTHX_ OP *o)
8341 OP * const kid = cLISTOPo->op_first;
8343 PERL_ARGS_ASSERT_CK_SASSIGN;
8345 /* has a disposable target? */
8346 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8347 && !(kid->op_flags & OPf_STACKED)
8348 /* Cannot steal the second time! */
8349 && !(kid->op_private & OPpTARGET_MY)
8350 /* Keep the full thing for madskills */
8354 OP * const kkid = kid->op_sibling;
8356 /* Can just relocate the target. */
8357 if (kkid && kkid->op_type == OP_PADSV
8358 && !(kkid->op_private & OPpLVAL_INTRO))
8360 kid->op_targ = kkid->op_targ;
8362 /* Now we do not need PADSV and SASSIGN. */
8363 kid->op_sibling = o->op_sibling; /* NULL */
8364 cLISTOPo->op_first = NULL;
8367 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8371 if (kid->op_sibling) {
8372 OP *kkid = kid->op_sibling;
8373 /* For state variable assignment, kkid is a list op whose op_last
8375 if ((kkid->op_type == OP_PADSV ||
8376 (kkid->op_type == OP_LIST &&
8377 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8380 && (kkid->op_private & OPpLVAL_INTRO)
8381 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8382 const PADOFFSET target = kkid->op_targ;
8383 OP *const other = newOP(OP_PADSV,
8385 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8386 OP *const first = newOP(OP_NULL, 0);
8387 OP *const nullop = newCONDOP(0, first, o, other);
8388 OP *const condop = first->op_next;
8389 /* hijacking PADSTALE for uninitialized state variables */
8390 SvPADSTALE_on(PAD_SVl(target));
8392 condop->op_type = OP_ONCE;
8393 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8394 condop->op_targ = target;
8395 other->op_targ = target;
8397 /* Because we change the type of the op here, we will skip the
8398 assignment binop->op_last = binop->op_first->op_sibling; at the
8399 end of Perl_newBINOP(). So need to do it here. */
8400 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8409 Perl_ck_match(pTHX_ OP *o)
8413 PERL_ARGS_ASSERT_CK_MATCH;
8415 if (o->op_type != OP_QR && PL_compcv) {
8416 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8417 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8418 o->op_targ = offset;
8419 o->op_private |= OPpTARGET_MY;
8422 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8423 o->op_private |= OPpRUNTIME;
8428 Perl_ck_method(pTHX_ OP *o)
8430 OP * const kid = cUNOPo->op_first;
8432 PERL_ARGS_ASSERT_CK_METHOD;
8434 if (kid->op_type == OP_CONST) {
8435 SV* sv = kSVOP->op_sv;
8436 const char * const method = SvPVX_const(sv);
8437 if (!(strchr(method, ':') || strchr(method, '\''))) {
8439 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8440 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
8443 kSVOP->op_sv = NULL;
8445 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8447 op_getmad(o,cmop,'O');
8458 Perl_ck_null(pTHX_ OP *o)
8460 PERL_ARGS_ASSERT_CK_NULL;
8461 PERL_UNUSED_CONTEXT;
8466 Perl_ck_open(pTHX_ OP *o)
8469 HV * const table = GvHV(PL_hintgv);
8471 PERL_ARGS_ASSERT_CK_OPEN;
8474 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8477 const char *d = SvPV_const(*svp, len);
8478 const I32 mode = mode_from_discipline(d, len);
8479 if (mode & O_BINARY)
8480 o->op_private |= OPpOPEN_IN_RAW;
8481 else if (mode & O_TEXT)
8482 o->op_private |= OPpOPEN_IN_CRLF;
8485 svp = hv_fetchs(table, "open_OUT", FALSE);
8488 const char *d = SvPV_const(*svp, len);
8489 const I32 mode = mode_from_discipline(d, len);
8490 if (mode & O_BINARY)
8491 o->op_private |= OPpOPEN_OUT_RAW;
8492 else if (mode & O_TEXT)
8493 o->op_private |= OPpOPEN_OUT_CRLF;
8496 if (o->op_type == OP_BACKTICK) {
8497 if (!(o->op_flags & OPf_KIDS)) {
8498 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8500 op_getmad(o,newop,'O');
8509 /* In case of three-arg dup open remove strictness
8510 * from the last arg if it is a bareword. */
8511 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8512 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8516 if ((last->op_type == OP_CONST) && /* The bareword. */
8517 (last->op_private & OPpCONST_BARE) &&
8518 (last->op_private & OPpCONST_STRICT) &&
8519 (oa = first->op_sibling) && /* The fh. */
8520 (oa = oa->op_sibling) && /* The mode. */
8521 (oa->op_type == OP_CONST) &&
8522 SvPOK(((SVOP*)oa)->op_sv) &&
8523 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8524 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8525 (last == oa->op_sibling)) /* The bareword. */
8526 last->op_private &= ~OPpCONST_STRICT;
8532 Perl_ck_repeat(pTHX_ OP *o)
8534 PERL_ARGS_ASSERT_CK_REPEAT;
8536 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8537 o->op_private |= OPpREPEAT_DOLIST;
8538 cBINOPo->op_first = force_list(cBINOPo->op_first);
8546 Perl_ck_require(pTHX_ OP *o)
8551 PERL_ARGS_ASSERT_CK_REQUIRE;
8553 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8554 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8556 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8557 SV * const sv = kid->op_sv;
8558 U32 was_readonly = SvREADONLY(sv);
8565 sv_force_normal_flags(sv, 0);
8566 assert(!SvREADONLY(sv));
8576 for (; s < end; s++) {
8577 if (*s == ':' && s[1] == ':') {
8579 Move(s+2, s+1, end - s - 1, char);
8584 sv_catpvs(sv, ".pm");
8585 SvFLAGS(sv) |= was_readonly;
8589 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8590 /* handle override, if any */
8591 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8592 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8593 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8594 gv = gvp ? *gvp : NULL;
8598 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8600 if (o->op_flags & OPf_KIDS) {
8601 kid = cUNOPo->op_first;
8602 cUNOPo->op_first = NULL;
8610 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8611 op_append_elem(OP_LIST, kid,
8612 scalar(newUNOP(OP_RV2CV, 0,
8615 op_getmad(o,newop,'O');
8619 return scalar(ck_fun(o));
8623 Perl_ck_return(pTHX_ OP *o)
8628 PERL_ARGS_ASSERT_CK_RETURN;
8630 kid = cLISTOPo->op_first->op_sibling;
8631 if (CvLVALUE(PL_compcv)) {
8632 for (; kid; kid = kid->op_sibling)
8633 op_lvalue(kid, OP_LEAVESUBLV);
8640 Perl_ck_select(pTHX_ OP *o)
8645 PERL_ARGS_ASSERT_CK_SELECT;
8647 if (o->op_flags & OPf_KIDS) {
8648 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8649 if (kid && kid->op_sibling) {
8650 o->op_type = OP_SSELECT;
8651 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8653 return fold_constants(op_integerize(op_std_init(o)));
8657 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8658 if (kid && kid->op_type == OP_RV2GV)
8659 kid->op_private &= ~HINT_STRICT_REFS;
8664 Perl_ck_shift(pTHX_ OP *o)
8667 const I32 type = o->op_type;
8669 PERL_ARGS_ASSERT_CK_SHIFT;
8671 if (!(o->op_flags & OPf_KIDS)) {
8674 if (!CvUNIQUE(PL_compcv)) {
8675 o->op_flags |= OPf_SPECIAL;
8679 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8682 OP * const oldo = o;
8683 o = newUNOP(type, 0, scalar(argop));
8684 op_getmad(oldo,o,'O');
8689 return newUNOP(type, 0, scalar(argop));
8692 return scalar(ck_fun(o));
8696 Perl_ck_sort(pTHX_ OP *o)
8701 PERL_ARGS_ASSERT_CK_SORT;
8703 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8704 HV * const hinthv = GvHV(PL_hintgv);
8706 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8708 const I32 sorthints = (I32)SvIV(*svp);
8709 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8710 o->op_private |= OPpSORT_QSORT;
8711 if ((sorthints & HINT_SORT_STABLE) != 0)
8712 o->op_private |= OPpSORT_STABLE;
8717 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8719 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8720 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8722 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8724 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8726 if (kid->op_type == OP_SCOPE) {
8730 else if (kid->op_type == OP_LEAVE) {
8731 if (o->op_type == OP_SORT) {
8732 op_null(kid); /* wipe out leave */
8735 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8736 if (k->op_next == kid)
8738 /* don't descend into loops */
8739 else if (k->op_type == OP_ENTERLOOP
8740 || k->op_type == OP_ENTERITER)
8742 k = cLOOPx(k)->op_lastop;
8747 kid->op_next = 0; /* just disconnect the leave */
8748 k = kLISTOP->op_first;
8753 if (o->op_type == OP_SORT) {
8754 /* provide scalar context for comparison function/block */
8760 o->op_flags |= OPf_SPECIAL;
8763 firstkid = firstkid->op_sibling;
8766 /* provide list context for arguments */
8767 if (o->op_type == OP_SORT)
8774 S_simplify_sort(pTHX_ OP *o)
8777 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8783 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8785 if (!(o->op_flags & OPf_STACKED))
8787 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8788 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8789 kid = kUNOP->op_first; /* get past null */
8790 if (kid->op_type != OP_SCOPE)
8792 kid = kLISTOP->op_last; /* get past scope */
8793 switch(kid->op_type) {
8801 k = kid; /* remember this node*/
8802 if (kBINOP->op_first->op_type != OP_RV2SV)
8804 kid = kBINOP->op_first; /* get past cmp */
8805 if (kUNOP->op_first->op_type != OP_GV)
8807 kid = kUNOP->op_first; /* get past rv2sv */
8809 if (GvSTASH(gv) != PL_curstash)
8811 gvname = GvNAME(gv);
8812 if (*gvname == 'a' && gvname[1] == '\0')
8814 else if (*gvname == 'b' && gvname[1] == '\0')
8819 kid = k; /* back to cmp */
8820 if (kBINOP->op_last->op_type != OP_RV2SV)
8822 kid = kBINOP->op_last; /* down to 2nd arg */
8823 if (kUNOP->op_first->op_type != OP_GV)
8825 kid = kUNOP->op_first; /* get past rv2sv */
8827 if (GvSTASH(gv) != PL_curstash)
8829 gvname = GvNAME(gv);
8831 ? !(*gvname == 'a' && gvname[1] == '\0')
8832 : !(*gvname == 'b' && gvname[1] == '\0'))
8834 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8836 o->op_private |= OPpSORT_DESCEND;
8837 if (k->op_type == OP_NCMP)
8838 o->op_private |= OPpSORT_NUMERIC;
8839 if (k->op_type == OP_I_NCMP)
8840 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8841 kid = cLISTOPo->op_first->op_sibling;
8842 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8844 op_getmad(kid,o,'S'); /* then delete it */
8846 op_free(kid); /* then delete it */
8851 Perl_ck_split(pTHX_ OP *o)
8856 PERL_ARGS_ASSERT_CK_SPLIT;
8858 if (o->op_flags & OPf_STACKED)
8859 return no_fh_allowed(o);
8861 kid = cLISTOPo->op_first;
8862 if (kid->op_type != OP_NULL)
8863 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
8864 kid = kid->op_sibling;
8865 op_free(cLISTOPo->op_first);
8867 cLISTOPo->op_first = kid;
8869 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8870 cLISTOPo->op_last = kid; /* There was only one element previously */
8873 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8874 OP * const sibl = kid->op_sibling;
8875 kid->op_sibling = 0;
8876 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8877 if (cLISTOPo->op_first == cLISTOPo->op_last)
8878 cLISTOPo->op_last = kid;
8879 cLISTOPo->op_first = kid;
8880 kid->op_sibling = sibl;
8883 kid->op_type = OP_PUSHRE;
8884 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8886 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8887 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8888 "Use of /g modifier is meaningless in split");
8891 if (!kid->op_sibling)
8892 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8894 kid = kid->op_sibling;
8897 if (!kid->op_sibling)
8898 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8899 assert(kid->op_sibling);
8901 kid = kid->op_sibling;
8904 if (kid->op_sibling)
8905 return too_many_arguments(o,OP_DESC(o));
8911 Perl_ck_join(pTHX_ OP *o)
8913 const OP * const kid = cLISTOPo->op_first->op_sibling;
8915 PERL_ARGS_ASSERT_CK_JOIN;
8917 if (kid && kid->op_type == OP_MATCH) {
8918 if (ckWARN(WARN_SYNTAX)) {
8919 const REGEXP *re = PM_GETRE(kPMOP);
8920 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8921 const STRLEN len = re ? RX_PRELEN(re) : 6;
8922 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8923 "/%.*s/ should probably be written as \"%.*s\"",
8924 (int)len, pmstr, (int)len, pmstr);
8931 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8933 Examines an op, which is expected to identify a subroutine at runtime,
8934 and attempts to determine at compile time which subroutine it identifies.
8935 This is normally used during Perl compilation to determine whether
8936 a prototype can be applied to a function call. I<cvop> is the op
8937 being considered, normally an C<rv2cv> op. A pointer to the identified
8938 subroutine is returned, if it could be determined statically, and a null
8939 pointer is returned if it was not possible to determine statically.
8941 Currently, the subroutine can be identified statically if the RV that the
8942 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8943 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8944 suitable if the constant value must be an RV pointing to a CV. Details of
8945 this process may change in future versions of Perl. If the C<rv2cv> op
8946 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8947 the subroutine statically: this flag is used to suppress compile-time
8948 magic on a subroutine call, forcing it to use default runtime behaviour.
8950 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8951 of a GV reference is modified. If a GV was examined and its CV slot was
8952 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8953 If the op is not optimised away, and the CV slot is later populated with
8954 a subroutine having a prototype, that flag eventually triggers the warning
8955 "called too early to check prototype".
8957 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8958 of returning a pointer to the subroutine it returns a pointer to the
8959 GV giving the most appropriate name for the subroutine in this context.
8960 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8961 (C<CvANON>) subroutine that is referenced through a GV it will be the
8962 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8963 A null pointer is returned as usual if there is no statically-determinable
8970 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8975 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8976 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8977 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8978 if (cvop->op_type != OP_RV2CV)
8980 if (cvop->op_private & OPpENTERSUB_AMPER)
8982 if (!(cvop->op_flags & OPf_KIDS))
8984 rvop = cUNOPx(cvop)->op_first;
8985 switch (rvop->op_type) {
8987 gv = cGVOPx_gv(rvop);
8990 if (flags & RV2CVOPCV_MARK_EARLY)
8991 rvop->op_private |= OPpEARLY_CV;
8996 SV *rv = cSVOPx_sv(rvop);
9006 if (SvTYPE((SV*)cv) != SVt_PVCV)
9008 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9009 if (!CvANON(cv) || !gv)
9018 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9020 Performs the default fixup of the arguments part of an C<entersub>
9021 op tree. This consists of applying list context to each of the
9022 argument ops. This is the standard treatment used on a call marked
9023 with C<&>, or a method call, or a call through a subroutine reference,
9024 or any other call where the callee can't be identified at compile time,
9025 or a call where the callee has no prototype.
9031 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9034 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9035 aop = cUNOPx(entersubop)->op_first;
9036 if (!aop->op_sibling)
9037 aop = cUNOPx(aop)->op_first;
9038 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9039 if (!(PL_madskills && aop->op_type == OP_STUB)) {
9041 op_lvalue(aop, OP_ENTERSUB);
9048 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9050 Performs the fixup of the arguments part of an C<entersub> op tree
9051 based on a subroutine prototype. This makes various modifications to
9052 the argument ops, from applying context up to inserting C<refgen> ops,
9053 and checking the number and syntactic types of arguments, as directed by
9054 the prototype. This is the standard treatment used on a subroutine call,
9055 not marked with C<&>, where the callee can be identified at compile time
9056 and has a prototype.
9058 I<protosv> supplies the subroutine prototype to be applied to the call.
9059 It may be a normal defined scalar, of which the string value will be used.
9060 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9061 that has been cast to C<SV*>) which has a prototype. The prototype
9062 supplied, in whichever form, does not need to match the actual callee
9063 referenced by the op tree.
9065 If the argument ops disagree with the prototype, for example by having
9066 an unacceptable number of arguments, a valid op tree is returned anyway.
9067 The error is reflected in the parser state, normally resulting in a single
9068 exception at the top level of parsing which covers all the compilation
9069 errors that occurred. In the error message, the callee is referred to
9070 by the name defined by the I<namegv> parameter.
9076 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9079 const char *proto, *proto_end;
9080 OP *aop, *prev, *cvop;
9083 I32 contextclass = 0;
9084 const char *e = NULL;
9085 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9086 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9087 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto,"
9088 "flags=%lx", (unsigned long) SvFLAGS(protosv));
9089 if (SvTYPE(protosv) == SVt_PVCV)
9090 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9091 else proto = SvPV(protosv, proto_len);
9092 proto_end = proto + proto_len;
9093 aop = cUNOPx(entersubop)->op_first;
9094 if (!aop->op_sibling)
9095 aop = cUNOPx(aop)->op_first;
9097 aop = aop->op_sibling;
9098 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9099 while (aop != cvop) {
9101 if (PL_madskills && aop->op_type == OP_STUB) {
9102 aop = aop->op_sibling;
9105 if (PL_madskills && aop->op_type == OP_NULL)
9106 o3 = ((UNOP*)aop)->op_first;
9110 if (proto >= proto_end)
9111 return too_many_arguments(entersubop, gv_ename(namegv));
9119 /* _ must be at the end */
9120 if (proto[1] && proto[1] != ';')
9135 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9137 arg == 1 ? "block or sub {}" : "sub {}",
9138 gv_ename(namegv), o3);
9141 /* '*' allows any scalar type, including bareword */
9144 if (o3->op_type == OP_RV2GV)
9145 goto wrapref; /* autoconvert GLOB -> GLOBref */
9146 else if (o3->op_type == OP_CONST)
9147 o3->op_private &= ~OPpCONST_STRICT;
9148 else if (o3->op_type == OP_ENTERSUB) {
9149 /* accidental subroutine, revert to bareword */
9150 OP *gvop = ((UNOP*)o3)->op_first;
9151 if (gvop && gvop->op_type == OP_NULL) {
9152 gvop = ((UNOP*)gvop)->op_first;
9154 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9157 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9158 (gvop = ((UNOP*)gvop)->op_first) &&
9159 gvop->op_type == OP_GV)
9161 GV * const gv = cGVOPx_gv(gvop);
9162 OP * const sibling = aop->op_sibling;
9163 SV * const n = newSVpvs("");
9165 OP * const oldaop = aop;
9169 gv_fullname4(n, gv, "", FALSE);
9170 aop = newSVOP(OP_CONST, 0, n);
9171 op_getmad(oldaop,aop,'O');
9172 prev->op_sibling = aop;
9173 aop->op_sibling = sibling;
9183 if (o3->op_type == OP_RV2AV ||
9184 o3->op_type == OP_PADAV ||
9185 o3->op_type == OP_RV2HV ||
9186 o3->op_type == OP_PADHV
9201 if (contextclass++ == 0) {
9202 e = strchr(proto, ']');
9203 if (!e || e == proto)
9212 const char *p = proto;
9213 const char *const end = proto;
9216 /* \[$] accepts any scalar lvalue */
9218 && Perl_op_lvalue_flags(aTHX_
9220 OP_READ, /* not entersub */
9223 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
9225 gv_ename(namegv), o3);
9230 if (o3->op_type == OP_RV2GV)
9233 bad_type(arg, "symbol", gv_ename(namegv), o3);
9236 if (o3->op_type == OP_ENTERSUB)
9239 bad_type(arg, "subroutine entry", gv_ename(namegv),
9243 if (o3->op_type == OP_RV2SV ||
9244 o3->op_type == OP_PADSV ||
9245 o3->op_type == OP_HELEM ||
9246 o3->op_type == OP_AELEM)
9248 if (!contextclass) {
9249 /* \$ accepts any scalar lvalue */
9250 if (Perl_op_lvalue_flags(aTHX_
9252 OP_READ, /* not entersub */
9255 bad_type(arg, "scalar", gv_ename(namegv), o3);
9259 if (o3->op_type == OP_RV2AV ||
9260 o3->op_type == OP_PADAV)
9263 bad_type(arg, "array", gv_ename(namegv), o3);
9266 if (o3->op_type == OP_RV2HV ||
9267 o3->op_type == OP_PADHV)
9270 bad_type(arg, "hash", gv_ename(namegv), o3);
9274 OP* const kid = aop;
9275 OP* const sib = kid->op_sibling;
9276 kid->op_sibling = 0;
9277 aop = newUNOP(OP_REFGEN, 0, kid);
9278 aop->op_sibling = sib;
9279 prev->op_sibling = aop;
9281 if (contextclass && e) {
9296 SV* const tmpsv = sv_newmortal();
9297 gv_efullname3(tmpsv, namegv, NULL);
9298 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9299 SVfARG(tmpsv), SVfARG(protosv));
9303 op_lvalue(aop, OP_ENTERSUB);
9305 aop = aop->op_sibling;
9307 if (aop == cvop && *proto == '_') {
9308 /* generate an access to $_ */
9310 aop->op_sibling = prev->op_sibling;
9311 prev->op_sibling = aop; /* instead of cvop */
9313 if (!optional && proto_end > proto &&
9314 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9315 return too_few_arguments(entersubop, gv_ename(namegv));
9320 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9322 Performs the fixup of the arguments part of an C<entersub> op tree either
9323 based on a subroutine prototype or using default list-context processing.
9324 This is the standard treatment used on a subroutine call, not marked
9325 with C<&>, where the callee can be identified at compile time.
9327 I<protosv> supplies the subroutine prototype to be applied to the call,
9328 or indicates that there is no prototype. It may be a normal scalar,
9329 in which case if it is defined then the string value will be used
9330 as a prototype, and if it is undefined then there is no prototype.
9331 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9332 that has been cast to C<SV*>), of which the prototype will be used if it
9333 has one. The prototype (or lack thereof) supplied, in whichever form,
9334 does not need to match the actual callee referenced by the op tree.
9336 If the argument ops disagree with the prototype, for example by having
9337 an unacceptable number of arguments, a valid op tree is returned anyway.
9338 The error is reflected in the parser state, normally resulting in a single
9339 exception at the top level of parsing which covers all the compilation
9340 errors that occurred. In the error message, the callee is referred to
9341 by the name defined by the I<namegv> parameter.
9347 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9348 GV *namegv, SV *protosv)
9350 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9351 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9352 return ck_entersub_args_proto(entersubop, namegv, protosv);
9354 return ck_entersub_args_list(entersubop);
9358 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9360 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9361 OP *aop = cUNOPx(entersubop)->op_first;
9363 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9367 if (!aop->op_sibling)
9368 aop = cUNOPx(aop)->op_first;
9369 aop = aop->op_sibling;
9370 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9371 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9372 aop = aop->op_sibling;
9375 (void)too_many_arguments(entersubop, GvNAME(namegv));
9377 op_free(entersubop);
9378 switch(GvNAME(namegv)[2]) {
9379 case 'F': return newSVOP(OP_CONST, 0,
9380 newSVpv(CopFILE(PL_curcop),0));
9381 case 'L': return newSVOP(
9384 "%"IVdf, (IV)CopLINE(PL_curcop)
9387 case 'P': return newSVOP(OP_CONST, 0,
9389 ? newSVhek(HvNAME_HEK(PL_curstash))
9400 bool seenarg = FALSE;
9402 if (!aop->op_sibling)
9403 aop = cUNOPx(aop)->op_first;
9406 aop = aop->op_sibling;
9407 prev->op_sibling = NULL;
9410 prev=cvop, cvop = cvop->op_sibling)
9412 if (PL_madskills && cvop->op_sibling
9413 && cvop->op_type != OP_STUB) seenarg = TRUE
9416 prev->op_sibling = NULL;
9417 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9419 if (aop == cvop) aop = NULL;
9420 op_free(entersubop);
9422 if (opnum == OP_ENTEREVAL
9423 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
9424 flags |= OPpEVAL_BYTES <<8;
9426 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9428 case OA_BASEOP_OR_UNOP:
9430 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
9434 if (!PL_madskills || seenarg)
9436 (void)too_many_arguments(aop, GvNAME(namegv));
9439 return opnum == OP_RUNCV
9440 ? newPVOP(OP_RUNCV,0,NULL)
9443 return convert(opnum,0,aop);
9451 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9453 Retrieves the function that will be used to fix up a call to I<cv>.
9454 Specifically, the function is applied to an C<entersub> op tree for a
9455 subroutine call, not marked with C<&>, where the callee can be identified
9456 at compile time as I<cv>.
9458 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9459 argument for it is returned in I<*ckobj_p>. The function is intended
9460 to be called in this manner:
9462 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9464 In this call, I<entersubop> is a pointer to the C<entersub> op,
9465 which may be replaced by the check function, and I<namegv> is a GV
9466 supplying the name that should be used by the check function to refer
9467 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9468 It is permitted to apply the check function in non-standard situations,
9469 such as to a call to a different subroutine or to a method call.
9471 By default, the function is
9472 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9473 and the SV parameter is I<cv> itself. This implements standard
9474 prototype processing. It can be changed, for a particular subroutine,
9475 by L</cv_set_call_checker>.
9481 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9484 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9485 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9487 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9488 *ckobj_p = callmg->mg_obj;
9490 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9496 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9498 Sets the function that will be used to fix up a call to I<cv>.
9499 Specifically, the function is applied to an C<entersub> op tree for a
9500 subroutine call, not marked with C<&>, where the callee can be identified
9501 at compile time as I<cv>.
9503 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9504 for it is supplied in I<ckobj>. The function is intended to be called
9507 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9509 In this call, I<entersubop> is a pointer to the C<entersub> op,
9510 which may be replaced by the check function, and I<namegv> is a GV
9511 supplying the name that should be used by the check function to refer
9512 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9513 It is permitted to apply the check function in non-standard situations,
9514 such as to a call to a different subroutine or to a method call.
9516 The current setting for a particular CV can be retrieved by
9517 L</cv_get_call_checker>.
9523 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9525 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9526 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9527 if (SvMAGICAL((SV*)cv))
9528 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9531 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9532 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9533 if (callmg->mg_flags & MGf_REFCOUNTED) {
9534 SvREFCNT_dec(callmg->mg_obj);
9535 callmg->mg_flags &= ~MGf_REFCOUNTED;
9537 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9538 callmg->mg_obj = ckobj;
9539 if (ckobj != (SV*)cv) {
9540 SvREFCNT_inc_simple_void_NN(ckobj);
9541 callmg->mg_flags |= MGf_REFCOUNTED;
9547 Perl_ck_subr(pTHX_ OP *o)
9553 PERL_ARGS_ASSERT_CK_SUBR;
9555 aop = cUNOPx(o)->op_first;
9556 if (!aop->op_sibling)
9557 aop = cUNOPx(aop)->op_first;
9558 aop = aop->op_sibling;
9559 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9560 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9561 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9563 o->op_private &= ~1;
9564 o->op_private |= OPpENTERSUB_HASTARG;
9565 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9566 if (PERLDB_SUB && PL_curstash != PL_debstash)
9567 o->op_private |= OPpENTERSUB_DB;
9568 if (cvop->op_type == OP_RV2CV) {
9569 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9571 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9572 if (aop->op_type == OP_CONST)
9573 aop->op_private &= ~OPpCONST_STRICT;
9574 else if (aop->op_type == OP_LIST) {
9575 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9576 if (sib && sib->op_type == OP_CONST)
9577 sib->op_private &= ~OPpCONST_STRICT;
9582 return ck_entersub_args_list(o);
9584 Perl_call_checker ckfun;
9586 cv_get_call_checker(cv, &ckfun, &ckobj);
9587 return ckfun(aTHX_ o, namegv, ckobj);
9592 Perl_ck_svconst(pTHX_ OP *o)
9594 PERL_ARGS_ASSERT_CK_SVCONST;
9595 PERL_UNUSED_CONTEXT;
9596 SvREADONLY_on(cSVOPo->op_sv);
9601 Perl_ck_chdir(pTHX_ OP *o)
9603 PERL_ARGS_ASSERT_CK_CHDIR;
9604 if (o->op_flags & OPf_KIDS) {
9605 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9607 if (kid && kid->op_type == OP_CONST &&
9608 (kid->op_private & OPpCONST_BARE))
9610 o->op_flags |= OPf_SPECIAL;
9611 kid->op_private &= ~OPpCONST_STRICT;
9618 Perl_ck_trunc(pTHX_ OP *o)
9620 PERL_ARGS_ASSERT_CK_TRUNC;
9622 if (o->op_flags & OPf_KIDS) {
9623 SVOP *kid = (SVOP*)cUNOPo->op_first;
9625 if (kid->op_type == OP_NULL)
9626 kid = (SVOP*)kid->op_sibling;
9627 if (kid && kid->op_type == OP_CONST &&
9628 (kid->op_private & OPpCONST_BARE))
9630 o->op_flags |= OPf_SPECIAL;
9631 kid->op_private &= ~OPpCONST_STRICT;
9638 Perl_ck_substr(pTHX_ OP *o)
9640 PERL_ARGS_ASSERT_CK_SUBSTR;
9643 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9644 OP *kid = cLISTOPo->op_first;
9646 if (kid->op_type == OP_NULL)
9647 kid = kid->op_sibling;
9649 kid->op_flags |= OPf_MOD;
9656 Perl_ck_tell(pTHX_ OP *o)
9658 PERL_ARGS_ASSERT_CK_TELL;
9660 if (o->op_flags & OPf_KIDS) {
9661 OP *kid = cLISTOPo->op_first;
9662 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
9663 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9669 Perl_ck_each(pTHX_ OP *o)
9672 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9673 const unsigned orig_type = o->op_type;
9674 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9675 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9676 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9677 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9679 PERL_ARGS_ASSERT_CK_EACH;
9682 switch (kid->op_type) {
9688 CHANGE_TYPE(o, array_type);
9691 if (kid->op_private == OPpCONST_BARE
9692 || !SvROK(cSVOPx_sv(kid))
9693 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9694 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9696 /* we let ck_fun handle it */
9699 CHANGE_TYPE(o, ref_type);
9703 /* if treating as a reference, defer additional checks to runtime */
9704 return o->op_type == ref_type ? o : ck_fun(o);
9708 Perl_ck_length(pTHX_ OP *o)
9710 PERL_ARGS_ASSERT_CK_LENGTH;
9714 if (ckWARN(WARN_SYNTAX)) {
9715 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9719 const bool hash = kid->op_type == OP_PADHV
9720 || kid->op_type == OP_RV2HV;
9721 switch (kid->op_type) {
9725 (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
9731 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
9733 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
9735 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
9742 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9743 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
9745 name, hash ? "keys " : "", name
9748 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9749 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
9751 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9752 "length() used on @array (did you mean \"scalar(@array)\"?)");
9759 /* caller is supposed to assign the return to the
9760 container of the rep_op var */
9762 S_opt_scalarhv(pTHX_ OP *rep_op) {
9766 PERL_ARGS_ASSERT_OPT_SCALARHV;
9768 NewOp(1101, unop, 1, UNOP);
9769 unop->op_type = (OPCODE)OP_BOOLKEYS;
9770 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9771 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9772 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9773 unop->op_first = rep_op;
9774 unop->op_next = rep_op->op_next;
9775 rep_op->op_next = (OP*)unop;
9776 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9777 unop->op_sibling = rep_op->op_sibling;
9778 rep_op->op_sibling = NULL;
9779 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9780 if (rep_op->op_type == OP_PADHV) {
9781 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9782 rep_op->op_flags |= OPf_WANT_LIST;
9787 /* Check for in place reverse and sort assignments like "@a = reverse @a"
9788 and modify the optree to make them work inplace */
9791 S_inplace_aassign(pTHX_ OP *o) {
9793 OP *modop, *modop_pushmark;
9795 OP *oleft, *oleft_pushmark;
9797 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
9799 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
9801 assert(cUNOPo->op_first->op_type == OP_NULL);
9802 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
9803 assert(modop_pushmark->op_type == OP_PUSHMARK);
9804 modop = modop_pushmark->op_sibling;
9806 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
9809 /* no other operation except sort/reverse */
9810 if (modop->op_sibling)
9813 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
9814 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
9816 if (modop->op_flags & OPf_STACKED) {
9817 /* skip sort subroutine/block */
9818 assert(oright->op_type == OP_NULL);
9819 oright = oright->op_sibling;
9822 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
9823 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
9824 assert(oleft_pushmark->op_type == OP_PUSHMARK);
9825 oleft = oleft_pushmark->op_sibling;
9827 /* Check the lhs is an array */
9829 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
9830 || oleft->op_sibling
9831 || (oleft->op_private & OPpLVAL_INTRO)
9835 /* Only one thing on the rhs */
9836 if (oright->op_sibling)
9839 /* check the array is the same on both sides */
9840 if (oleft->op_type == OP_RV2AV) {
9841 if (oright->op_type != OP_RV2AV
9842 || !cUNOPx(oright)->op_first
9843 || cUNOPx(oright)->op_first->op_type != OP_GV
9844 || cUNOPx(oleft )->op_first->op_type != OP_GV
9845 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9846 cGVOPx_gv(cUNOPx(oright)->op_first)
9850 else if (oright->op_type != OP_PADAV
9851 || oright->op_targ != oleft->op_targ
9855 /* This actually is an inplace assignment */
9857 modop->op_private |= OPpSORT_INPLACE;
9859 /* transfer MODishness etc from LHS arg to RHS arg */
9860 oright->op_flags = oleft->op_flags;
9862 /* remove the aassign op and the lhs */
9864 op_null(oleft_pushmark);
9865 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
9866 op_null(cUNOPx(oleft)->op_first);
9870 #define MAX_DEFERRED 4
9873 if (defer_ix == (MAX_DEFERRED-1)) { \
9874 CALL_RPEEP(defer_queue[defer_base]); \
9875 defer_base = (defer_base + 1) % MAX_DEFERRED; \
9878 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
9880 /* A peephole optimizer. We visit the ops in the order they're to execute.
9881 * See the comments at the top of this file for more details about when
9882 * peep() is called */
9885 Perl_rpeep(pTHX_ register OP *o)
9888 register OP* oldop = NULL;
9889 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
9893 if (!o || o->op_opt)
9897 SAVEVPTR(PL_curcop);
9898 for (;; o = o->op_next) {
9902 while (defer_ix >= 0)
9903 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
9907 /* By default, this op has now been optimised. A couple of cases below
9908 clear this again. */
9911 switch (o->op_type) {
9913 PL_curcop = ((COP*)o); /* for warnings */
9916 PL_curcop = ((COP*)o); /* for warnings */
9918 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9919 to carry two labels. For now, take the easier option, and skip
9920 this optimisation if the first NEXTSTATE has a label. */
9921 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9922 OP *nextop = o->op_next;
9923 while (nextop && nextop->op_type == OP_NULL)
9924 nextop = nextop->op_next;
9926 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9927 COP *firstcop = (COP *)o;
9928 COP *secondcop = (COP *)nextop;
9929 /* We want the COP pointed to by o (and anything else) to
9930 become the next COP down the line. */
9933 firstcop->op_next = secondcop->op_next;
9935 /* Now steal all its pointers, and duplicate the other
9937 firstcop->cop_line = secondcop->cop_line;
9939 firstcop->cop_stashpv = secondcop->cop_stashpv;
9940 firstcop->cop_file = secondcop->cop_file;
9942 firstcop->cop_stash = secondcop->cop_stash;
9943 firstcop->cop_filegv = secondcop->cop_filegv;
9945 firstcop->cop_hints = secondcop->cop_hints;
9946 firstcop->cop_seq = secondcop->cop_seq;
9947 firstcop->cop_warnings = secondcop->cop_warnings;
9948 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9951 secondcop->cop_stashpv = NULL;
9952 secondcop->cop_file = NULL;
9954 secondcop->cop_stash = NULL;
9955 secondcop->cop_filegv = NULL;
9957 secondcop->cop_warnings = NULL;
9958 secondcop->cop_hints_hash = NULL;
9960 /* If we use op_null(), and hence leave an ex-COP, some
9961 warnings are misreported. For example, the compile-time
9962 error in 'use strict; no strict refs;' */
9963 secondcop->op_type = OP_NULL;
9964 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9970 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9971 if (o->op_next->op_private & OPpTARGET_MY) {
9972 if (o->op_flags & OPf_STACKED) /* chained concats */
9973 break; /* ignore_optimization */
9975 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9976 o->op_targ = o->op_next->op_targ;
9977 o->op_next->op_targ = 0;
9978 o->op_private |= OPpTARGET_MY;
9981 op_null(o->op_next);
9985 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9986 break; /* Scalar stub must produce undef. List stub is noop */
9990 if (o->op_targ == OP_NEXTSTATE
9991 || o->op_targ == OP_DBSTATE)
9993 PL_curcop = ((COP*)o);
9995 /* XXX: We avoid setting op_seq here to prevent later calls
9996 to rpeep() from mistakenly concluding that optimisation
9997 has already occurred. This doesn't fix the real problem,
9998 though (See 20010220.007). AMS 20010719 */
9999 /* op_seq functionality is now replaced by op_opt */
10006 if (oldop && o->op_next) {
10007 oldop->op_next = o->op_next;
10015 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
10016 OP* const pop = (o->op_type == OP_PADAV) ?
10017 o->op_next : o->op_next->op_next;
10019 if (pop && pop->op_type == OP_CONST &&
10020 ((PL_op = pop->op_next)) &&
10021 pop->op_next->op_type == OP_AELEM &&
10022 !(pop->op_next->op_private &
10023 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
10024 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
10027 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
10028 no_bareword_allowed(pop);
10029 if (o->op_type == OP_GV)
10030 op_null(o->op_next);
10031 op_null(pop->op_next);
10033 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
10034 o->op_next = pop->op_next->op_next;
10035 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
10036 o->op_private = (U8)i;
10037 if (o->op_type == OP_GV) {
10040 o->op_type = OP_AELEMFAST;
10043 o->op_type = OP_AELEMFAST_LEX;
10048 if (o->op_next->op_type == OP_RV2SV) {
10049 if (!(o->op_next->op_private & OPpDEREF)) {
10050 op_null(o->op_next);
10051 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
10053 o->op_next = o->op_next->op_next;
10054 o->op_type = OP_GVSV;
10055 o->op_ppaddr = PL_ppaddr[OP_GVSV];
10058 else if (o->op_next->op_type == OP_READLINE
10059 && o->op_next->op_next->op_type == OP_CONCAT
10060 && (o->op_next->op_next->op_flags & OPf_STACKED))
10062 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
10063 o->op_type = OP_RCATLINE;
10064 o->op_flags |= OPf_STACKED;
10065 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
10066 op_null(o->op_next->op_next);
10067 op_null(o->op_next);
10077 fop = cUNOP->op_first;
10085 fop = cLOGOP->op_first;
10086 sop = fop->op_sibling;
10087 while (cLOGOP->op_other->op_type == OP_NULL)
10088 cLOGOP->op_other = cLOGOP->op_other->op_next;
10089 while (o->op_next && ( o->op_type == o->op_next->op_type
10090 || o->op_next->op_type == OP_NULL))
10091 o->op_next = o->op_next->op_next;
10092 DEFER(cLOGOP->op_other);
10096 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10098 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
10103 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
10104 while (nop && nop->op_next) {
10105 switch (nop->op_next->op_type) {
10110 lop = nop = nop->op_next;
10113 nop = nop->op_next;
10121 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
10122 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10123 cLOGOP->op_first = opt_scalarhv(fop);
10124 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
10125 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
10141 while (cLOGOP->op_other->op_type == OP_NULL)
10142 cLOGOP->op_other = cLOGOP->op_other->op_next;
10143 DEFER(cLOGOP->op_other);
10148 while (cLOOP->op_redoop->op_type == OP_NULL)
10149 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
10150 while (cLOOP->op_nextop->op_type == OP_NULL)
10151 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
10152 while (cLOOP->op_lastop->op_type == OP_NULL)
10153 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
10154 /* a while(1) loop doesn't have an op_next that escapes the
10155 * loop, so we have to explicitly follow the op_lastop to
10156 * process the rest of the code */
10157 DEFER(cLOOP->op_lastop);
10161 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10162 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10163 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10164 cPMOP->op_pmstashstartu.op_pmreplstart
10165 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
10166 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
10170 /* check that RHS of sort is a single plain array */
10171 OP *oright = cUNOPo->op_first;
10172 if (!oright || oright->op_type != OP_PUSHMARK)
10175 if (o->op_private & OPpSORT_INPLACE)
10178 /* reverse sort ... can be optimised. */
10179 if (!cUNOPo->op_sibling) {
10180 /* Nothing follows us on the list. */
10181 OP * const reverse = o->op_next;
10183 if (reverse->op_type == OP_REVERSE &&
10184 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10185 OP * const pushmark = cUNOPx(reverse)->op_first;
10186 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10187 && (cUNOPx(pushmark)->op_sibling == o)) {
10188 /* reverse -> pushmark -> sort */
10189 o->op_private |= OPpSORT_REVERSE;
10191 pushmark->op_next = oright->op_next;
10201 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10203 LISTOP *enter, *exlist;
10205 if (o->op_private & OPpSORT_INPLACE)
10208 enter = (LISTOP *) o->op_next;
10211 if (enter->op_type == OP_NULL) {
10212 enter = (LISTOP *) enter->op_next;
10216 /* for $a (...) will have OP_GV then OP_RV2GV here.
10217 for (...) just has an OP_GV. */
10218 if (enter->op_type == OP_GV) {
10219 gvop = (OP *) enter;
10220 enter = (LISTOP *) enter->op_next;
10223 if (enter->op_type == OP_RV2GV) {
10224 enter = (LISTOP *) enter->op_next;
10230 if (enter->op_type != OP_ENTERITER)
10233 iter = enter->op_next;
10234 if (!iter || iter->op_type != OP_ITER)
10237 expushmark = enter->op_first;
10238 if (!expushmark || expushmark->op_type != OP_NULL
10239 || expushmark->op_targ != OP_PUSHMARK)
10242 exlist = (LISTOP *) expushmark->op_sibling;
10243 if (!exlist || exlist->op_type != OP_NULL
10244 || exlist->op_targ != OP_LIST)
10247 if (exlist->op_last != o) {
10248 /* Mmm. Was expecting to point back to this op. */
10251 theirmark = exlist->op_first;
10252 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10255 if (theirmark->op_sibling != o) {
10256 /* There's something between the mark and the reverse, eg
10257 for (1, reverse (...))
10262 ourmark = ((LISTOP *)o)->op_first;
10263 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10266 ourlast = ((LISTOP *)o)->op_last;
10267 if (!ourlast || ourlast->op_next != o)
10270 rv2av = ourmark->op_sibling;
10271 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10272 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10273 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10274 /* We're just reversing a single array. */
10275 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10276 enter->op_flags |= OPf_STACKED;
10279 /* We don't have control over who points to theirmark, so sacrifice
10281 theirmark->op_next = ourmark->op_next;
10282 theirmark->op_flags = ourmark->op_flags;
10283 ourlast->op_next = gvop ? gvop : (OP *) enter;
10286 enter->op_private |= OPpITER_REVERSED;
10287 iter->op_private |= OPpITER_REVERSED;
10294 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10295 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10300 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
10302 if (CvUNIQUE(PL_compcv)) sv = &PL_sv_undef;
10304 sv = newRV((SV *)PL_compcv);
10308 o->op_type = OP_CONST;
10309 o->op_ppaddr = PL_ppaddr[OP_CONST];
10310 o->op_flags |= OPf_SPECIAL;
10311 cSVOPo->op_sv = sv;
10316 if (OP_GIMME(o,0) == G_VOID) {
10317 OP *right = cBINOP->op_first;
10319 OP *left = right->op_sibling;
10320 if (left->op_type == OP_SUBSTR
10321 && (left->op_private & 7) < 4) {
10323 cBINOP->op_first = left;
10324 right->op_sibling =
10325 cBINOPx(left)->op_first->op_sibling;
10326 cBINOPx(left)->op_first->op_sibling = right;
10327 left->op_private |= OPpSUBSTR_REPL_FIRST;
10329 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10336 Perl_cpeep_t cpeep =
10337 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10339 cpeep(aTHX_ o, oldop);
10350 Perl_peep(pTHX_ register OP *o)
10356 =head1 Custom Operators
10358 =for apidoc Ao||custom_op_xop
10359 Return the XOP structure for a given custom op. This function should be
10360 considered internal to OP_NAME and the other access macros: use them instead.
10366 Perl_custom_op_xop(pTHX_ const OP *o)
10372 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10374 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10375 assert(o->op_type == OP_CUSTOM);
10377 /* This is wrong. It assumes a function pointer can be cast to IV,
10378 * which isn't guaranteed, but this is what the old custom OP code
10379 * did. In principle it should be safer to Copy the bytes of the
10380 * pointer into a PV: since the new interface is hidden behind
10381 * functions, this can be changed later if necessary. */
10382 /* Change custom_op_xop if this ever happens */
10383 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10386 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10388 /* assume noone will have just registered a desc */
10389 if (!he && PL_custom_op_names &&
10390 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10395 /* XXX does all this need to be shared mem? */
10396 Newxz(xop, 1, XOP);
10397 pv = SvPV(HeVAL(he), l);
10398 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10399 if (PL_custom_op_descs &&
10400 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10402 pv = SvPV(HeVAL(he), l);
10403 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10405 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10409 if (!he) return &xop_null;
10411 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10416 =for apidoc Ao||custom_op_register
10417 Register a custom op. See L<perlguts/"Custom Operators">.
10423 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10427 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10429 /* see the comment in custom_op_xop */
10430 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10432 if (!PL_custom_ops)
10433 PL_custom_ops = newHV();
10435 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10436 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10440 =head1 Functions in file op.c
10442 =for apidoc core_prototype
10443 This function assigns the prototype of the named core function to C<sv>, or
10444 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10445 NULL if the core function has no prototype. C<code> is a code as returned
10446 by C<keyword()>. It must be negative and unequal to -KEY_CORE.
10452 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10455 int i = 0, n = 0, seen_question = 0, defgv = 0;
10457 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10458 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10459 bool nullret = FALSE;
10461 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10463 assert (code < 0 && code != -KEY_CORE);
10465 if (!sv) sv = sv_newmortal();
10467 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10470 case KEY_and : case KEY_chop: case KEY_chomp:
10471 case KEY_cmp : case KEY_exec: case KEY_eq :
10472 case KEY_ge : case KEY_gt : case KEY_le :
10473 case KEY_lt : case KEY_ne : case KEY_or :
10474 case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
10475 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10476 case KEY_keys: retsetpvs("+", OP_KEYS);
10477 case KEY_values: retsetpvs("+", OP_VALUES);
10478 case KEY_each: retsetpvs("+", OP_EACH);
10479 case KEY_push: retsetpvs("+@", OP_PUSH);
10480 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10481 case KEY_pop: retsetpvs(";+", OP_POP);
10482 case KEY_shift: retsetpvs(";+", OP_SHIFT);
10484 retsetpvs("+;$$@", OP_SPLICE);
10485 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10487 case KEY_evalbytes:
10488 name = "entereval"; break;
10496 while (i < MAXO) { /* The slow way. */
10497 if (strEQ(name, PL_op_name[i])
10498 || strEQ(name, PL_op_desc[i]))
10500 if (nullret) { assert(opnum); *opnum = i; return NULL; }
10505 assert(0); return NULL; /* Should not happen... */
10507 defgv = PL_opargs[i] & OA_DEFGV;
10508 oa = PL_opargs[i] >> OASHIFT;
10510 if (oa & OA_OPTIONAL && !seen_question && (
10511 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
10516 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10517 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10518 /* But globs are already references (kinda) */
10519 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10523 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10524 && !scalar_mod_type(NULL, i)) {
10529 if (i == OP_LOCK) str[n++] = '&';
10533 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10534 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10535 str[n-1] = '_'; defgv = 0;
10539 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
10541 sv_setpvn(sv, str, n - 1);
10542 if (opnum) *opnum = i;
10547 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
10550 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
10553 PERL_ARGS_ASSERT_CORESUB_OP;
10557 return op_append_elem(OP_LINESEQ,
10560 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
10564 case OP_SELECT: /* which represents OP_SSELECT as well */
10569 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
10570 newSVOP(OP_CONST, 0, newSVuv(1))
10572 coresub_op(newSVuv((UV)OP_SSELECT), 0,
10574 coresub_op(coreargssv, 0, OP_SELECT)
10578 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10580 return op_append_elem(
10583 opnum == OP_WANTARRAY || opnum == OP_RUNCV
10584 ? OPpOFFBYONE << 8 : 0)
10586 case OA_BASEOP_OR_UNOP:
10587 if (opnum == OP_ENTEREVAL) {
10588 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
10589 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
10591 else o = newUNOP(opnum,0,argop);
10592 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
10595 if (is_handle_constructor(o, 1))
10596 argop->op_private |= OPpCOREARGS_DEREF1;
10600 o = convert(opnum,0,argop);
10601 if (is_handle_constructor(o, 2))
10602 argop->op_private |= OPpCOREARGS_DEREF2;
10603 if (scalar_mod_type(NULL, opnum))
10604 argop->op_private |= OPpCOREARGS_SCALARMOD;
10605 if (opnum == OP_SUBSTR) {
10606 o->op_private |= OPpMAYBE_LVSUB;
10615 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
10616 SV * const *new_const_svp)
10618 const char *hvname;
10619 bool is_const = !!CvCONST(old_cv);
10620 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
10622 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
10624 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
10626 /* They are 2 constant subroutines generated from
10627 the same constant. This probably means that
10628 they are really the "same" proxy subroutine
10629 instantiated in 2 places. Most likely this is
10630 when a constant is exported twice. Don't warn.
10633 (ckWARN(WARN_REDEFINE)
10635 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
10636 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
10637 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
10638 strEQ(hvname, "autouse"))
10642 && ckWARN_d(WARN_REDEFINE)
10643 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
10646 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10648 ? "Constant subroutine %"SVf" redefined"
10649 : "Subroutine %"SVf" redefined",
10655 /* Efficient sub that returns a constant scalar value. */
10657 const_sv_xsub(pTHX_ CV* cv)
10661 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10665 /* diag_listed_as: SKIPME */
10666 Perl_croak(aTHX_ "usage: %s::%s()",
10667 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10680 * c-indentation-style: bsd
10681 * c-basic-offset: 4
10682 * indent-tabs-mode: t
10685 * ex: set ts=8 sts=4 sw=4 noet: