4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
106 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
107 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
108 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
110 #if defined(PL_OP_SLAB_ALLOC)
112 #ifdef PERL_DEBUG_READONLY_OPS
113 # define PERL_SLAB_SIZE 4096
114 # include <sys/mman.h>
117 #ifndef PERL_SLAB_SIZE
118 #define PERL_SLAB_SIZE 2048
122 Perl_Slab_Alloc(pTHX_ size_t sz)
126 * To make incrementing use count easy PL_OpSlab is an I32 *
127 * To make inserting the link to slab PL_OpPtr is I32 **
128 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
129 * Add an overhead for pointer to slab and round up as a number of pointers
131 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
132 if ((PL_OpSpace -= sz) < 0) {
133 #ifdef PERL_DEBUG_READONLY_OPS
134 /* We need to allocate chunk by chunk so that we can control the VM
136 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
139 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
140 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
142 if(PL_OpPtr == MAP_FAILED) {
143 perror("mmap failed");
148 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
153 /* We reserve the 0'th I32 sized chunk as a use count */
154 PL_OpSlab = (I32 *) PL_OpPtr;
155 /* Reduce size by the use count word, and by the size we need.
156 * Latter is to mimic the '-=' in the if() above
158 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
159 /* Allocation pointer starts at the top.
160 Theory: because we build leaves before trunk allocating at end
161 means that at run time access is cache friendly upward
163 PL_OpPtr += PERL_SLAB_SIZE;
165 #ifdef PERL_DEBUG_READONLY_OPS
166 /* We remember this slab. */
167 /* This implementation isn't efficient, but it is simple. */
168 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
169 PL_slabs[PL_slab_count++] = PL_OpSlab;
170 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
173 assert( PL_OpSpace >= 0 );
174 /* Move the allocation pointer down */
176 assert( PL_OpPtr > (I32 **) PL_OpSlab );
177 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
178 (*PL_OpSlab)++; /* Increment use count of slab */
179 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
180 assert( *PL_OpSlab > 0 );
181 return (void *)(PL_OpPtr + 1);
184 #ifdef PERL_DEBUG_READONLY_OPS
186 Perl_pending_Slabs_to_ro(pTHX) {
187 /* Turn all the allocated op slabs read only. */
188 U32 count = PL_slab_count;
189 I32 **const slabs = PL_slabs;
191 /* Reset the array of pending OP slabs, as we're about to turn this lot
192 read only. Also, do it ahead of the loop in case the warn triggers,
193 and a warn handler has an eval */
198 /* Force a new slab for any further allocation. */
202 void *const start = slabs[count];
203 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
204 if(mprotect(start, size, PROT_READ)) {
205 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
206 start, (unsigned long) size, errno);
214 S_Slab_to_rw(pTHX_ void *op)
216 I32 * const * const ptr = (I32 **) op;
217 I32 * const slab = ptr[-1];
219 PERL_ARGS_ASSERT_SLAB_TO_RW;
221 assert( ptr-1 > (I32 **) slab );
222 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
224 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
225 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
226 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
231 Perl_op_refcnt_inc(pTHX_ OP *o)
242 Perl_op_refcnt_dec(pTHX_ OP *o)
244 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
249 # define Slab_to_rw(op)
253 Perl_Slab_Free(pTHX_ void *op)
255 I32 * const * const ptr = (I32 **) op;
256 I32 * const slab = ptr[-1];
257 PERL_ARGS_ASSERT_SLAB_FREE;
258 assert( ptr-1 > (I32 **) slab );
259 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
262 if (--(*slab) == 0) {
264 # define PerlMemShared PerlMem
267 #ifdef PERL_DEBUG_READONLY_OPS
268 U32 count = PL_slab_count;
269 /* Need to remove this slab from our list of slabs */
272 if (PL_slabs[count] == slab) {
274 /* Found it. Move the entry at the end to overwrite it. */
275 DEBUG_m(PerlIO_printf(Perl_debug_log,
276 "Deallocate %p by moving %p from %lu to %lu\n",
278 PL_slabs[PL_slab_count - 1],
279 PL_slab_count, count));
280 PL_slabs[count] = PL_slabs[--PL_slab_count];
281 /* Could realloc smaller at this point, but probably not
283 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
284 perror("munmap failed");
292 PerlMemShared_free(slab);
294 if (slab == PL_OpSlab) {
301 * In the following definition, the ", (OP*)0" is just to make the compiler
302 * think the expression is of the right type: croak actually does a Siglongjmp.
304 #define CHECKOP(type,o) \
305 ((PL_op_mask && PL_op_mask[type]) \
306 ? ( op_free((OP*)o), \
307 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
309 : PL_check[type](aTHX_ (OP*)o))
311 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
313 #define CHANGE_TYPE(o,type) \
315 o->op_type = (OPCODE)type; \
316 o->op_ppaddr = PL_ppaddr[type]; \
320 S_gv_ename(pTHX_ GV *gv)
322 SV* const tmpsv = sv_newmortal();
324 PERL_ARGS_ASSERT_GV_ENAME;
326 gv_efullname3(tmpsv, gv, NULL);
327 return SvPV_nolen_const(tmpsv);
331 S_no_fh_allowed(pTHX_ OP *o)
333 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
335 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
341 S_too_few_arguments(pTHX_ OP *o, const char *name)
343 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
345 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
350 S_too_many_arguments(pTHX_ OP *o, const char *name)
352 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
354 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
359 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
361 PERL_ARGS_ASSERT_BAD_TYPE;
363 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
364 (int)n, name, t, OP_DESC(kid)));
368 S_no_bareword_allowed(pTHX_ OP *o)
370 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
373 return; /* various ok barewords are hidden in extra OP_NULL */
374 qerror(Perl_mess(aTHX_
375 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
377 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
380 /* "register" allocation */
383 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
387 const bool is_our = (PL_parser->in_my == KEY_our);
389 PERL_ARGS_ASSERT_ALLOCMY;
391 if (flags & ~SVf_UTF8)
392 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
395 /* Until we're using the length for real, cross check that we're being
397 assert(strlen(name) == len);
399 /* complain about "my $<special_var>" etc etc */
403 ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) ||
404 (name[1] == '_' && (*name == '$' || len > 2))))
406 /* name[2] is true if strlen(name) > 2 */
407 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
408 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
409 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
410 PL_parser->in_my == KEY_state ? "state" : "my"));
412 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
413 PL_parser->in_my == KEY_state ? "state" : "my"));
417 /* allocate a spare slot and store the name in that slot */
419 off = pad_add_name_pvn(name, len,
420 (is_our ? padadd_OUR :
421 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
422 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
423 PL_parser->in_my_stash,
425 /* $_ is always in main::, even with our */
426 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
430 /* anon sub prototypes contains state vars should always be cloned,
431 * otherwise the state var would be shared between anon subs */
433 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
434 CvCLONE_on(PL_compcv);
439 /* free the body of an op without examining its contents.
440 * Always use this rather than FreeOp directly */
443 S_op_destroy(pTHX_ OP *o)
445 if (o->op_latefree) {
453 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
455 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
461 Perl_op_free(pTHX_ OP *o)
468 if (o->op_latefreed) {
475 if (o->op_private & OPpREFCOUNTED) {
486 refcnt = OpREFCNT_dec(o);
489 /* Need to find and remove any pattern match ops from the list
490 we maintain for reset(). */
491 find_and_forget_pmops(o);
501 /* Call the op_free hook if it has been set. Do it now so that it's called
502 * at the right time for refcounted ops, but still before all of the kids
506 if (o->op_flags & OPf_KIDS) {
507 register OP *kid, *nextkid;
508 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
509 nextkid = kid->op_sibling; /* Get before next freeing kid */
514 #ifdef PERL_DEBUG_READONLY_OPS
518 /* COP* is not cleared by op_clear() so that we may track line
519 * numbers etc even after null() */
520 if (type == OP_NEXTSTATE || type == OP_DBSTATE
521 || (type == OP_NULL /* the COP might have been null'ed */
522 && ((OPCODE)o->op_targ == OP_NEXTSTATE
523 || (OPCODE)o->op_targ == OP_DBSTATE))) {
528 type = (OPCODE)o->op_targ;
531 if (o->op_latefree) {
537 #ifdef DEBUG_LEAKING_SCALARS
544 Perl_op_clear(pTHX_ OP *o)
549 PERL_ARGS_ASSERT_OP_CLEAR;
552 mad_free(o->op_madprop);
557 switch (o->op_type) {
558 case OP_NULL: /* Was holding old type, if any. */
559 if (PL_madskills && o->op_targ != OP_NULL) {
560 o->op_type = (Optype)o->op_targ;
565 case OP_ENTEREVAL: /* Was holding hints. */
569 if (!(o->op_flags & OPf_REF)
570 || (PL_check[o->op_type] != Perl_ck_ftst))
577 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
582 /* It's possible during global destruction that the GV is freed
583 before the optree. Whilst the SvREFCNT_inc is happy to bump from
584 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
585 will trigger an assertion failure, because the entry to sv_clear
586 checks that the scalar is not already freed. A check of for
587 !SvIS_FREED(gv) turns out to be invalid, because during global
588 destruction the reference count can be forced down to zero
589 (with SVf_BREAK set). In which case raising to 1 and then
590 dropping to 0 triggers cleanup before it should happen. I
591 *think* that this might actually be a general, systematic,
592 weakness of the whole idea of SVf_BREAK, in that code *is*
593 allowed to raise and lower references during global destruction,
594 so any *valid* code that happens to do this during global
595 destruction might well trigger premature cleanup. */
596 bool still_valid = gv && SvREFCNT(gv);
599 SvREFCNT_inc_simple_void(gv);
601 if (cPADOPo->op_padix > 0) {
602 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
603 * may still exist on the pad */
604 pad_swipe(cPADOPo->op_padix, TRUE);
605 cPADOPo->op_padix = 0;
608 SvREFCNT_dec(cSVOPo->op_sv);
609 cSVOPo->op_sv = NULL;
612 int try_downgrade = SvREFCNT(gv) == 2;
615 gv_try_downgrade(gv);
619 case OP_METHOD_NAMED:
622 SvREFCNT_dec(cSVOPo->op_sv);
623 cSVOPo->op_sv = NULL;
626 Even if op_clear does a pad_free for the target of the op,
627 pad_free doesn't actually remove the sv that exists in the pad;
628 instead it lives on. This results in that it could be reused as
629 a target later on when the pad was reallocated.
632 pad_swipe(o->op_targ,1);
641 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
646 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
648 if (cPADOPo->op_padix > 0) {
649 pad_swipe(cPADOPo->op_padix, TRUE);
650 cPADOPo->op_padix = 0;
653 SvREFCNT_dec(cSVOPo->op_sv);
654 cSVOPo->op_sv = NULL;
658 PerlMemShared_free(cPVOPo->op_pv);
659 cPVOPo->op_pv = NULL;
663 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
667 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
668 /* No GvIN_PAD_off here, because other references may still
669 * exist on the pad */
670 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
673 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
679 forget_pmop(cPMOPo, 1);
680 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
681 /* we use the same protection as the "SAFE" version of the PM_ macros
682 * here since sv_clean_all might release some PMOPs
683 * after PL_regex_padav has been cleared
684 * and the clearing of PL_regex_padav needs to
685 * happen before sv_clean_all
688 if(PL_regex_pad) { /* We could be in destruction */
689 const IV offset = (cPMOPo)->op_pmoffset;
690 ReREFCNT_dec(PM_GETRE(cPMOPo));
691 PL_regex_pad[offset] = &PL_sv_undef;
692 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
696 ReREFCNT_dec(PM_GETRE(cPMOPo));
697 PM_SETRE(cPMOPo, NULL);
703 if (o->op_targ > 0) {
704 pad_free(o->op_targ);
710 S_cop_free(pTHX_ COP* cop)
712 PERL_ARGS_ASSERT_COP_FREE;
716 if (! specialWARN(cop->cop_warnings))
717 PerlMemShared_free(cop->cop_warnings);
718 cophh_free(CopHINTHASH_get(cop));
722 S_forget_pmop(pTHX_ PMOP *const o
728 HV * const pmstash = PmopSTASH(o);
730 PERL_ARGS_ASSERT_FORGET_PMOP;
732 if (pmstash && !SvIS_FREED(pmstash)) {
733 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
735 PMOP **const array = (PMOP**) mg->mg_ptr;
736 U32 count = mg->mg_len / sizeof(PMOP**);
741 /* Found it. Move the entry at the end to overwrite it. */
742 array[i] = array[--count];
743 mg->mg_len = count * sizeof(PMOP**);
744 /* Could realloc smaller at this point always, but probably
745 not worth it. Probably worth free()ing if we're the
748 Safefree(mg->mg_ptr);
765 S_find_and_forget_pmops(pTHX_ OP *o)
767 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
769 if (o->op_flags & OPf_KIDS) {
770 OP *kid = cUNOPo->op_first;
772 switch (kid->op_type) {
777 forget_pmop((PMOP*)kid, 0);
779 find_and_forget_pmops(kid);
780 kid = kid->op_sibling;
786 Perl_op_null(pTHX_ OP *o)
790 PERL_ARGS_ASSERT_OP_NULL;
792 if (o->op_type == OP_NULL)
796 o->op_targ = o->op_type;
797 o->op_type = OP_NULL;
798 o->op_ppaddr = PL_ppaddr[OP_NULL];
802 Perl_op_refcnt_lock(pTHX)
810 Perl_op_refcnt_unlock(pTHX)
817 /* Contextualizers */
820 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
822 Applies a syntactic context to an op tree representing an expression.
823 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
824 or C<G_VOID> to specify the context to apply. The modified op tree
831 Perl_op_contextualize(pTHX_ OP *o, I32 context)
833 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
835 case G_SCALAR: return scalar(o);
836 case G_ARRAY: return list(o);
837 case G_VOID: return scalarvoid(o);
839 Perl_croak(aTHX_ "panic: op_contextualize bad context");
845 =head1 Optree Manipulation Functions
847 =for apidoc Am|OP*|op_linklist|OP *o
848 This function is the implementation of the L</LINKLIST> macro. It should
849 not be called directly.
855 Perl_op_linklist(pTHX_ OP *o)
859 PERL_ARGS_ASSERT_OP_LINKLIST;
864 /* establish postfix order */
865 first = cUNOPo->op_first;
868 o->op_next = LINKLIST(first);
871 if (kid->op_sibling) {
872 kid->op_next = LINKLIST(kid->op_sibling);
873 kid = kid->op_sibling;
887 S_scalarkids(pTHX_ OP *o)
889 if (o && o->op_flags & OPf_KIDS) {
891 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
898 S_scalarboolean(pTHX_ OP *o)
902 PERL_ARGS_ASSERT_SCALARBOOLEAN;
904 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
905 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
906 if (ckWARN(WARN_SYNTAX)) {
907 const line_t oldline = CopLINE(PL_curcop);
909 if (PL_parser && PL_parser->copline != NOLINE)
910 CopLINE_set(PL_curcop, PL_parser->copline);
911 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
912 CopLINE_set(PL_curcop, oldline);
919 Perl_scalar(pTHX_ OP *o)
924 /* assumes no premature commitment */
925 if (!o || (PL_parser && PL_parser->error_count)
926 || (o->op_flags & OPf_WANT)
927 || o->op_type == OP_RETURN)
932 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
934 switch (o->op_type) {
936 scalar(cBINOPo->op_first);
941 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
951 if (o->op_flags & OPf_KIDS) {
952 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
958 kid = cLISTOPo->op_first;
960 kid = kid->op_sibling;
963 OP *sib = kid->op_sibling;
964 if (sib && kid->op_type != OP_LEAVEWHEN)
970 PL_curcop = &PL_compiling;
975 kid = cLISTOPo->op_first;
978 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
985 Perl_scalarvoid(pTHX_ OP *o)
989 const char* useless = NULL;
990 U32 useless_is_utf8 = 0;
994 PERL_ARGS_ASSERT_SCALARVOID;
996 /* trailing mad null ops don't count as "there" for void processing */
998 o->op_type != OP_NULL &&
1000 o->op_sibling->op_type == OP_NULL)
1003 for (sib = o->op_sibling;
1004 sib && sib->op_type == OP_NULL;
1005 sib = sib->op_sibling) ;
1011 if (o->op_type == OP_NEXTSTATE
1012 || o->op_type == OP_DBSTATE
1013 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1014 || o->op_targ == OP_DBSTATE)))
1015 PL_curcop = (COP*)o; /* for warning below */
1017 /* assumes no premature commitment */
1018 want = o->op_flags & OPf_WANT;
1019 if ((want && want != OPf_WANT_SCALAR)
1020 || (PL_parser && PL_parser->error_count)
1021 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1026 if ((o->op_private & OPpTARGET_MY)
1027 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1029 return scalar(o); /* As if inside SASSIGN */
1032 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1034 switch (o->op_type) {
1036 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1040 if (o->op_flags & OPf_STACKED)
1044 if (o->op_private == 4)
1069 case OP_AELEMFAST_LEX:
1088 case OP_GETSOCKNAME:
1089 case OP_GETPEERNAME:
1094 case OP_GETPRIORITY:
1118 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1119 /* Otherwise it's "Useless use of grep iterator" */
1120 useless = OP_DESC(o);
1124 kid = cLISTOPo->op_first;
1125 if (kid && kid->op_type == OP_PUSHRE
1127 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1129 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1131 useless = OP_DESC(o);
1135 kid = cUNOPo->op_first;
1136 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1137 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1140 useless = "negative pattern binding (!~)";
1144 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1145 useless = "non-destructive substitution (s///r)";
1149 useless = "non-destructive transliteration (tr///r)";
1156 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1157 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1158 useless = "a variable";
1163 if (cSVOPo->op_private & OPpCONST_STRICT)
1164 no_bareword_allowed(o);
1166 if (ckWARN(WARN_VOID)) {
1168 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1169 "a constant (%"SVf")", sv));
1170 useless = SvPV_nolen(msv);
1171 useless_is_utf8 = SvUTF8(msv);
1174 useless = "a constant (undef)";
1175 /* don't warn on optimised away booleans, eg
1176 * use constant Foo, 5; Foo || print; */
1177 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1179 /* the constants 0 and 1 are permitted as they are
1180 conventionally used as dummies in constructs like
1181 1 while some_condition_with_side_effects; */
1182 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1184 else if (SvPOK(sv)) {
1185 /* perl4's way of mixing documentation and code
1186 (before the invention of POD) was based on a
1187 trick to mix nroff and perl code. The trick was
1188 built upon these three nroff macros being used in
1189 void context. The pink camel has the details in
1190 the script wrapman near page 319. */
1191 const char * const maybe_macro = SvPVX_const(sv);
1192 if (strnEQ(maybe_macro, "di", 2) ||
1193 strnEQ(maybe_macro, "ds", 2) ||
1194 strnEQ(maybe_macro, "ig", 2))
1199 op_null(o); /* don't execute or even remember it */
1203 o->op_type = OP_PREINC; /* pre-increment is faster */
1204 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1208 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1209 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1213 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1214 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1218 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1219 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1224 UNOP *refgen, *rv2cv;
1227 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1230 rv2gv = ((BINOP *)o)->op_last;
1231 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1234 refgen = (UNOP *)((BINOP *)o)->op_first;
1236 if (!refgen || refgen->op_type != OP_REFGEN)
1239 exlist = (LISTOP *)refgen->op_first;
1240 if (!exlist || exlist->op_type != OP_NULL
1241 || exlist->op_targ != OP_LIST)
1244 if (exlist->op_first->op_type != OP_PUSHMARK)
1247 rv2cv = (UNOP*)exlist->op_last;
1249 if (rv2cv->op_type != OP_RV2CV)
1252 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1253 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1254 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1256 o->op_private |= OPpASSIGN_CV_TO_GV;
1257 rv2gv->op_private |= OPpDONT_INIT_GV;
1258 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1270 kid = cLOGOPo->op_first;
1271 if (kid->op_type == OP_NOT
1272 && (kid->op_flags & OPf_KIDS)
1274 if (o->op_type == OP_AND) {
1276 o->op_ppaddr = PL_ppaddr[OP_OR];
1278 o->op_type = OP_AND;
1279 o->op_ppaddr = PL_ppaddr[OP_AND];
1288 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1293 if (o->op_flags & OPf_STACKED)
1300 if (!(o->op_flags & OPf_KIDS))
1311 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1321 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1322 newSVpvn_flags(useless, strlen(useless),
1323 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1328 S_listkids(pTHX_ OP *o)
1330 if (o && o->op_flags & OPf_KIDS) {
1332 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1339 Perl_list(pTHX_ OP *o)
1344 /* assumes no premature commitment */
1345 if (!o || (o->op_flags & OPf_WANT)
1346 || (PL_parser && PL_parser->error_count)
1347 || o->op_type == OP_RETURN)
1352 if ((o->op_private & OPpTARGET_MY)
1353 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1355 return o; /* As if inside SASSIGN */
1358 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1360 switch (o->op_type) {
1363 list(cBINOPo->op_first);
1368 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1376 if (!(o->op_flags & OPf_KIDS))
1378 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1379 list(cBINOPo->op_first);
1380 return gen_constant_list(o);
1387 kid = cLISTOPo->op_first;
1389 kid = kid->op_sibling;
1392 OP *sib = kid->op_sibling;
1393 if (sib && kid->op_type != OP_LEAVEWHEN)
1399 PL_curcop = &PL_compiling;
1403 kid = cLISTOPo->op_first;
1410 S_scalarseq(pTHX_ OP *o)
1414 const OPCODE type = o->op_type;
1416 if (type == OP_LINESEQ || type == OP_SCOPE ||
1417 type == OP_LEAVE || type == OP_LEAVETRY)
1420 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1421 if (kid->op_sibling) {
1425 PL_curcop = &PL_compiling;
1427 o->op_flags &= ~OPf_PARENS;
1428 if (PL_hints & HINT_BLOCK_SCOPE)
1429 o->op_flags |= OPf_PARENS;
1432 o = newOP(OP_STUB, 0);
1437 S_modkids(pTHX_ OP *o, I32 type)
1439 if (o && o->op_flags & OPf_KIDS) {
1441 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1442 op_lvalue(kid, type);
1448 =for apidoc finalize_optree
1450 This function finalizes the optree. Should be called directly after
1451 the complete optree is built. It does some additional
1452 checking which can't be done in the normal ck_xxx functions and makes
1453 the tree thread-safe.
1458 Perl_finalize_optree(pTHX_ OP* o)
1460 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1463 SAVEVPTR(PL_curcop);
1471 S_finalize_op(pTHX_ OP* o)
1473 PERL_ARGS_ASSERT_FINALIZE_OP;
1475 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1477 /* Make sure mad ops are also thread-safe */
1478 MADPROP *mp = o->op_madprop;
1480 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1481 OP *prop_op = (OP *) mp->mad_val;
1482 /* We only need "Relocate sv to the pad for thread safety.", but this
1483 easiest way to make sure it traverses everything */
1484 if (prop_op->op_type == OP_CONST)
1485 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1486 finalize_op(prop_op);
1493 switch (o->op_type) {
1496 PL_curcop = ((COP*)o); /* for warnings */
1500 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1501 && ckWARN(WARN_SYNTAX))
1503 if (o->op_sibling->op_sibling) {
1504 const OPCODE type = o->op_sibling->op_sibling->op_type;
1505 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1506 const line_t oldline = CopLINE(PL_curcop);
1507 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1508 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1509 "Statement unlikely to be reached");
1510 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1511 "\t(Maybe you meant system() when you said exec()?)\n");
1512 CopLINE_set(PL_curcop, oldline);
1519 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1520 GV * const gv = cGVOPo_gv;
1521 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1522 /* XXX could check prototype here instead of just carping */
1523 SV * const sv = sv_newmortal();
1524 gv_efullname3(sv, gv, NULL);
1525 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1526 "%"SVf"() called too early to check prototype",
1533 if (cSVOPo->op_private & OPpCONST_STRICT)
1534 no_bareword_allowed(o);
1538 case OP_METHOD_NAMED:
1539 /* Relocate sv to the pad for thread safety.
1540 * Despite being a "constant", the SV is written to,
1541 * for reference counts, sv_upgrade() etc. */
1542 if (cSVOPo->op_sv) {
1543 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1544 if (o->op_type != OP_METHOD_NAMED &&
1545 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1547 /* If op_sv is already a PADTMP/MY then it is being used by
1548 * some pad, so make a copy. */
1549 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1550 SvREADONLY_on(PAD_SVl(ix));
1551 SvREFCNT_dec(cSVOPo->op_sv);
1553 else if (o->op_type != OP_METHOD_NAMED
1554 && cSVOPo->op_sv == &PL_sv_undef) {
1555 /* PL_sv_undef is hack - it's unsafe to store it in the
1556 AV that is the pad, because av_fetch treats values of
1557 PL_sv_undef as a "free" AV entry and will merrily
1558 replace them with a new SV, causing pad_alloc to think
1559 that this pad slot is free. (When, clearly, it is not)
1561 SvOK_off(PAD_SVl(ix));
1562 SvPADTMP_on(PAD_SVl(ix));
1563 SvREADONLY_on(PAD_SVl(ix));
1566 SvREFCNT_dec(PAD_SVl(ix));
1567 SvPADTMP_on(cSVOPo->op_sv);
1568 PAD_SETSV(ix, cSVOPo->op_sv);
1569 /* XXX I don't know how this isn't readonly already. */
1570 SvREADONLY_on(PAD_SVl(ix));
1572 cSVOPo->op_sv = NULL;
1583 const char *key = NULL;
1586 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1589 /* Make the CONST have a shared SV */
1590 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1591 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1592 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1593 key = SvPV_const(sv, keylen);
1594 lexname = newSVpvn_share(key,
1595 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1601 if ((o->op_private & (OPpLVAL_INTRO)))
1604 rop = (UNOP*)((BINOP*)o)->op_first;
1605 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1607 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1608 if (!SvPAD_TYPED(lexname))
1610 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1611 if (!fields || !GvHV(*fields))
1613 key = SvPV_const(*svp, keylen);
1614 if (!hv_fetch(GvHV(*fields), key,
1615 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1616 Perl_croak(aTHX_ "No such class field \"%s\" "
1617 "in variable %s of type %s",
1618 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
1630 SVOP *first_key_op, *key_op;
1632 if ((o->op_private & (OPpLVAL_INTRO))
1633 /* I bet there's always a pushmark... */
1634 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1635 /* hmmm, no optimization if list contains only one key. */
1637 rop = (UNOP*)((LISTOP*)o)->op_last;
1638 if (rop->op_type != OP_RV2HV)
1640 if (rop->op_first->op_type == OP_PADSV)
1641 /* @$hash{qw(keys here)} */
1642 rop = (UNOP*)rop->op_first;
1644 /* @{$hash}{qw(keys here)} */
1645 if (rop->op_first->op_type == OP_SCOPE
1646 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1648 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1654 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1655 if (!SvPAD_TYPED(lexname))
1657 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1658 if (!fields || !GvHV(*fields))
1660 /* Again guessing that the pushmark can be jumped over.... */
1661 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1662 ->op_first->op_sibling;
1663 for (key_op = first_key_op; key_op;
1664 key_op = (SVOP*)key_op->op_sibling) {
1665 if (key_op->op_type != OP_CONST)
1667 svp = cSVOPx_svp(key_op);
1668 key = SvPV_const(*svp, keylen);
1669 if (!hv_fetch(GvHV(*fields), key,
1670 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1671 Perl_croak(aTHX_ "No such class field \"%s\" "
1672 "in variable %s of type %s",
1673 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
1679 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1680 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1687 if (o->op_flags & OPf_KIDS) {
1689 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1695 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1697 Propagate lvalue ("modifiable") context to an op and its children.
1698 I<type> represents the context type, roughly based on the type of op that
1699 would do the modifying, although C<local()> is represented by OP_NULL,
1700 because it has no op type of its own (it is signalled by a flag on
1703 This function detects things that can't be modified, such as C<$x+1>, and
1704 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1705 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1707 It also flags things that need to behave specially in an lvalue context,
1708 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1714 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1718 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1721 if (!o || (PL_parser && PL_parser->error_count))
1724 if ((o->op_private & OPpTARGET_MY)
1725 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1730 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1732 switch (o->op_type) {
1738 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1742 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1743 !(o->op_flags & OPf_STACKED)) {
1744 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1745 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1746 poses, so we need it clear. */
1747 o->op_private &= ~1;
1748 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1749 assert(cUNOPo->op_first->op_type == OP_NULL);
1750 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1753 else { /* lvalue subroutine call */
1754 o->op_private |= OPpLVAL_INTRO
1755 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1756 PL_modcount = RETURN_UNLIMITED_NUMBER;
1757 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1758 /* Backward compatibility mode: */
1759 o->op_private |= OPpENTERSUB_INARGS;
1762 else { /* Compile-time error message: */
1763 OP *kid = cUNOPo->op_first;
1767 if (kid->op_type != OP_PUSHMARK) {
1768 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1770 "panic: unexpected lvalue entersub "
1771 "args: type/targ %ld:%"UVuf,
1772 (long)kid->op_type, (UV)kid->op_targ);
1773 kid = kLISTOP->op_first;
1775 while (kid->op_sibling)
1776 kid = kid->op_sibling;
1777 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1779 if (kid->op_type == OP_METHOD_NAMED
1780 || kid->op_type == OP_METHOD)
1784 NewOp(1101, newop, 1, UNOP);
1785 newop->op_type = OP_RV2CV;
1786 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1787 newop->op_first = NULL;
1788 newop->op_next = (OP*)newop;
1789 kid->op_sibling = (OP*)newop;
1790 newop->op_private |= OPpLVAL_INTRO;
1791 newop->op_private &= ~1;
1795 if (kid->op_type != OP_RV2CV)
1797 "panic: unexpected lvalue entersub "
1798 "entry via type/targ %ld:%"UVuf,
1799 (long)kid->op_type, (UV)kid->op_targ);
1800 kid->op_private |= OPpLVAL_INTRO;
1801 break; /* Postpone until runtime */
1805 kid = kUNOP->op_first;
1806 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1807 kid = kUNOP->op_first;
1808 if (kid->op_type == OP_NULL)
1810 "Unexpected constant lvalue entersub "
1811 "entry via type/targ %ld:%"UVuf,
1812 (long)kid->op_type, (UV)kid->op_targ);
1813 if (kid->op_type != OP_GV) {
1814 /* Restore RV2CV to check lvalueness */
1816 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1817 okid->op_next = kid->op_next;
1818 kid->op_next = okid;
1821 okid->op_next = NULL;
1822 okid->op_type = OP_RV2CV;
1824 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1825 okid->op_private |= OPpLVAL_INTRO;
1826 okid->op_private &= ~1;
1830 cv = GvCV(kGVOP_gv);
1840 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1841 /* grep, foreach, subcalls, refgen */
1842 if (type == OP_GREPSTART || type == OP_ENTERSUB
1843 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1845 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1846 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1848 : (o->op_type == OP_ENTERSUB
1849 ? "non-lvalue subroutine call"
1851 type ? PL_op_desc[type] : "local"));
1865 case OP_RIGHT_SHIFT:
1874 if (!(o->op_flags & OPf_STACKED))
1881 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1882 op_lvalue(kid, type);
1887 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1888 PL_modcount = RETURN_UNLIMITED_NUMBER;
1889 return o; /* Treat \(@foo) like ordinary list. */
1893 if (scalar_mod_type(o, type))
1895 ref(cUNOPo->op_first, o->op_type);
1899 if (type == OP_LEAVESUBLV)
1900 o->op_private |= OPpMAYBE_LVSUB;
1906 PL_modcount = RETURN_UNLIMITED_NUMBER;
1909 PL_hints |= HINT_BLOCK_SCOPE;
1910 if (type == OP_LEAVESUBLV)
1911 o->op_private |= OPpMAYBE_LVSUB;
1915 ref(cUNOPo->op_first, o->op_type);
1919 PL_hints |= HINT_BLOCK_SCOPE;
1928 case OP_AELEMFAST_LEX:
1935 PL_modcount = RETURN_UNLIMITED_NUMBER;
1936 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1937 return o; /* Treat \(@foo) like ordinary list. */
1938 if (scalar_mod_type(o, type))
1940 if (type == OP_LEAVESUBLV)
1941 o->op_private |= OPpMAYBE_LVSUB;
1945 if (!type) /* local() */
1946 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1947 PAD_COMPNAME_SV(o->op_targ));
1956 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1960 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1966 if (type == OP_LEAVESUBLV)
1967 o->op_private |= OPpMAYBE_LVSUB;
1968 pad_free(o->op_targ);
1969 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1970 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1971 if (o->op_flags & OPf_KIDS)
1972 op_lvalue(cBINOPo->op_first->op_sibling, type);
1977 ref(cBINOPo->op_first, o->op_type);
1978 if (type == OP_ENTERSUB &&
1979 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1980 o->op_private |= OPpLVAL_DEFER;
1981 if (type == OP_LEAVESUBLV)
1982 o->op_private |= OPpMAYBE_LVSUB;
1992 if (o->op_flags & OPf_KIDS)
1993 op_lvalue(cLISTOPo->op_last, type);
1998 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2000 else if (!(o->op_flags & OPf_KIDS))
2002 if (o->op_targ != OP_LIST) {
2003 op_lvalue(cBINOPo->op_first, type);
2009 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2010 /* elements might be in void context because the list is
2011 in scalar context or because they are attribute sub calls */
2012 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2013 op_lvalue(kid, type);
2017 if (type != OP_LEAVESUBLV)
2019 break; /* op_lvalue()ing was handled by ck_return() */
2022 /* [20011101.069] File test operators interpret OPf_REF to mean that
2023 their argument is a filehandle; thus \stat(".") should not set
2025 if (type == OP_REFGEN &&
2026 PL_check[o->op_type] == Perl_ck_ftst)
2029 if (type != OP_LEAVESUBLV)
2030 o->op_flags |= OPf_MOD;
2032 if (type == OP_AASSIGN || type == OP_SASSIGN)
2033 o->op_flags |= OPf_SPECIAL|OPf_REF;
2034 else if (!type) { /* local() */
2037 o->op_private |= OPpLVAL_INTRO;
2038 o->op_flags &= ~OPf_SPECIAL;
2039 PL_hints |= HINT_BLOCK_SCOPE;
2044 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2045 "Useless localization of %s", OP_DESC(o));
2048 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2049 && type != OP_LEAVESUBLV)
2050 o->op_flags |= OPf_REF;
2055 S_scalar_mod_type(const OP *o, I32 type)
2057 assert(o || type != OP_SASSIGN);
2061 if (o->op_type == OP_RV2GV)
2085 case OP_RIGHT_SHIFT:
2106 S_is_handle_constructor(const OP *o, I32 numargs)
2108 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2110 switch (o->op_type) {
2118 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2131 S_refkids(pTHX_ OP *o, I32 type)
2133 if (o && o->op_flags & OPf_KIDS) {
2135 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2142 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2147 PERL_ARGS_ASSERT_DOREF;
2149 if (!o || (PL_parser && PL_parser->error_count))
2152 switch (o->op_type) {
2154 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2155 !(o->op_flags & OPf_STACKED)) {
2156 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2157 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2158 assert(cUNOPo->op_first->op_type == OP_NULL);
2159 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2160 o->op_flags |= OPf_SPECIAL;
2161 o->op_private &= ~1;
2163 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2164 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2165 : type == OP_RV2HV ? OPpDEREF_HV
2167 o->op_flags |= OPf_MOD;
2173 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2174 doref(kid, type, set_op_ref);
2177 if (type == OP_DEFINED)
2178 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2179 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2182 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2183 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2184 : type == OP_RV2HV ? OPpDEREF_HV
2186 o->op_flags |= OPf_MOD;
2193 o->op_flags |= OPf_REF;
2196 if (type == OP_DEFINED)
2197 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2198 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2204 o->op_flags |= OPf_REF;
2209 if (!(o->op_flags & OPf_KIDS))
2211 doref(cBINOPo->op_first, type, set_op_ref);
2215 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2216 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2217 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2218 : type == OP_RV2HV ? OPpDEREF_HV
2220 o->op_flags |= OPf_MOD;
2230 if (!(o->op_flags & OPf_KIDS))
2232 doref(cLISTOPo->op_last, type, set_op_ref);
2242 S_dup_attrlist(pTHX_ OP *o)
2247 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2249 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2250 * where the first kid is OP_PUSHMARK and the remaining ones
2251 * are OP_CONST. We need to push the OP_CONST values.
2253 if (o->op_type == OP_CONST)
2254 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2256 else if (o->op_type == OP_NULL)
2260 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2262 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2263 if (o->op_type == OP_CONST)
2264 rop = op_append_elem(OP_LIST, rop,
2265 newSVOP(OP_CONST, o->op_flags,
2266 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2273 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2278 PERL_ARGS_ASSERT_APPLY_ATTRS;
2280 /* fake up C<use attributes $pkg,$rv,@attrs> */
2281 ENTER; /* need to protect against side-effects of 'use' */
2282 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2284 #define ATTRSMODULE "attributes"
2285 #define ATTRSMODULE_PM "attributes.pm"
2288 /* Don't force the C<use> if we don't need it. */
2289 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2290 if (svp && *svp != &PL_sv_undef)
2291 NOOP; /* already in %INC */
2293 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2294 newSVpvs(ATTRSMODULE), NULL);
2297 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2298 newSVpvs(ATTRSMODULE),
2300 op_prepend_elem(OP_LIST,
2301 newSVOP(OP_CONST, 0, stashsv),
2302 op_prepend_elem(OP_LIST,
2303 newSVOP(OP_CONST, 0,
2305 dup_attrlist(attrs))));
2311 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2314 OP *pack, *imop, *arg;
2317 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2322 assert(target->op_type == OP_PADSV ||
2323 target->op_type == OP_PADHV ||
2324 target->op_type == OP_PADAV);
2326 /* Ensure that attributes.pm is loaded. */
2327 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2329 /* Need package name for method call. */
2330 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2332 /* Build up the real arg-list. */
2333 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2335 arg = newOP(OP_PADSV, 0);
2336 arg->op_targ = target->op_targ;
2337 arg = op_prepend_elem(OP_LIST,
2338 newSVOP(OP_CONST, 0, stashsv),
2339 op_prepend_elem(OP_LIST,
2340 newUNOP(OP_REFGEN, 0,
2341 op_lvalue(arg, OP_REFGEN)),
2342 dup_attrlist(attrs)));
2344 /* Fake up a method call to import */
2345 meth = newSVpvs_share("import");
2346 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2347 op_append_elem(OP_LIST,
2348 op_prepend_elem(OP_LIST, pack, list(arg)),
2349 newSVOP(OP_METHOD_NAMED, 0, meth)));
2351 /* Combine the ops. */
2352 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2356 =notfor apidoc apply_attrs_string
2358 Attempts to apply a list of attributes specified by the C<attrstr> and
2359 C<len> arguments to the subroutine identified by the C<cv> argument which
2360 is expected to be associated with the package identified by the C<stashpv>
2361 argument (see L<attributes>). It gets this wrong, though, in that it
2362 does not correctly identify the boundaries of the individual attribute
2363 specifications within C<attrstr>. This is not really intended for the
2364 public API, but has to be listed here for systems such as AIX which
2365 need an explicit export list for symbols. (It's called from XS code
2366 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2367 to respect attribute syntax properly would be welcome.
2373 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2374 const char *attrstr, STRLEN len)
2378 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2381 len = strlen(attrstr);
2385 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2387 const char * const sstr = attrstr;
2388 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2389 attrs = op_append_elem(OP_LIST, attrs,
2390 newSVOP(OP_CONST, 0,
2391 newSVpvn(sstr, attrstr-sstr)));
2395 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2396 newSVpvs(ATTRSMODULE),
2397 NULL, op_prepend_elem(OP_LIST,
2398 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2399 op_prepend_elem(OP_LIST,
2400 newSVOP(OP_CONST, 0,
2401 newRV(MUTABLE_SV(cv))),
2406 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2410 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2412 PERL_ARGS_ASSERT_MY_KID;
2414 if (!o || (PL_parser && PL_parser->error_count))
2418 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2419 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2423 if (type == OP_LIST) {
2425 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2426 my_kid(kid, attrs, imopsp);
2427 } else if (type == OP_UNDEF
2433 } else if (type == OP_RV2SV || /* "our" declaration */
2435 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2436 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2437 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2439 PL_parser->in_my == KEY_our
2441 : PL_parser->in_my == KEY_state ? "state" : "my"));
2443 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2444 PL_parser->in_my = FALSE;
2445 PL_parser->in_my_stash = NULL;
2446 apply_attrs(GvSTASH(gv),
2447 (type == OP_RV2SV ? GvSV(gv) :
2448 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2449 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2452 o->op_private |= OPpOUR_INTRO;
2455 else if (type != OP_PADSV &&
2458 type != OP_PUSHMARK)
2460 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2462 PL_parser->in_my == KEY_our
2464 : PL_parser->in_my == KEY_state ? "state" : "my"));
2467 else if (attrs && type != OP_PUSHMARK) {
2470 PL_parser->in_my = FALSE;
2471 PL_parser->in_my_stash = NULL;
2473 /* check for C<my Dog $spot> when deciding package */
2474 stash = PAD_COMPNAME_TYPE(o->op_targ);
2476 stash = PL_curstash;
2477 apply_attrs_my(stash, o, attrs, imopsp);
2479 o->op_flags |= OPf_MOD;
2480 o->op_private |= OPpLVAL_INTRO;
2482 o->op_private |= OPpPAD_STATE;
2487 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2491 int maybe_scalar = 0;
2493 PERL_ARGS_ASSERT_MY_ATTRS;
2495 /* [perl #17376]: this appears to be premature, and results in code such as
2496 C< our(%x); > executing in list mode rather than void mode */
2498 if (o->op_flags & OPf_PARENS)
2508 o = my_kid(o, attrs, &rops);
2510 if (maybe_scalar && o->op_type == OP_PADSV) {
2511 o = scalar(op_append_list(OP_LIST, rops, o));
2512 o->op_private |= OPpLVAL_INTRO;
2515 /* The listop in rops might have a pushmark at the beginning,
2516 which will mess up list assignment. */
2517 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2518 if (rops->op_type == OP_LIST &&
2519 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2521 OP * const pushmark = lrops->op_first;
2522 lrops->op_first = pushmark->op_sibling;
2525 o = op_append_list(OP_LIST, o, rops);
2528 PL_parser->in_my = FALSE;
2529 PL_parser->in_my_stash = NULL;
2534 Perl_sawparens(pTHX_ OP *o)
2536 PERL_UNUSED_CONTEXT;
2538 o->op_flags |= OPf_PARENS;
2543 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2547 const OPCODE ltype = left->op_type;
2548 const OPCODE rtype = right->op_type;
2550 PERL_ARGS_ASSERT_BIND_MATCH;
2552 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2553 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2555 const char * const desc
2557 rtype == OP_SUBST || rtype == OP_TRANS
2558 || rtype == OP_TRANSR
2560 ? (int)rtype : OP_MATCH];
2561 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2562 ? "@array" : "%hash");
2563 Perl_warner(aTHX_ packWARN(WARN_MISC),
2564 "Applying %s to %s will act on scalar(%s)",
2565 desc, sample, sample);
2568 if (rtype == OP_CONST &&
2569 cSVOPx(right)->op_private & OPpCONST_BARE &&
2570 cSVOPx(right)->op_private & OPpCONST_STRICT)
2572 no_bareword_allowed(right);
2575 /* !~ doesn't make sense with /r, so error on it for now */
2576 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2578 yyerror("Using !~ with s///r doesn't make sense");
2579 if (rtype == OP_TRANSR && type == OP_NOT)
2580 yyerror("Using !~ with tr///r doesn't make sense");
2582 ismatchop = (rtype == OP_MATCH ||
2583 rtype == OP_SUBST ||
2584 rtype == OP_TRANS || rtype == OP_TRANSR)
2585 && !(right->op_flags & OPf_SPECIAL);
2586 if (ismatchop && right->op_private & OPpTARGET_MY) {
2588 right->op_private &= ~OPpTARGET_MY;
2590 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2593 right->op_flags |= OPf_STACKED;
2594 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2595 ! (rtype == OP_TRANS &&
2596 right->op_private & OPpTRANS_IDENTICAL) &&
2597 ! (rtype == OP_SUBST &&
2598 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2599 newleft = op_lvalue(left, rtype);
2602 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2603 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2605 o = op_prepend_elem(rtype, scalar(newleft), right);
2607 return newUNOP(OP_NOT, 0, scalar(o));
2611 return bind_match(type, left,
2612 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2616 Perl_invert(pTHX_ OP *o)
2620 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2624 =for apidoc Amx|OP *|op_scope|OP *o
2626 Wraps up an op tree with some additional ops so that at runtime a dynamic
2627 scope will be created. The original ops run in the new dynamic scope,
2628 and then, provided that they exit normally, the scope will be unwound.
2629 The additional ops used to create and unwind the dynamic scope will
2630 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2631 instead if the ops are simple enough to not need the full dynamic scope
2638 Perl_op_scope(pTHX_ OP *o)
2642 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2643 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2644 o->op_type = OP_LEAVE;
2645 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2647 else if (o->op_type == OP_LINESEQ) {
2649 o->op_type = OP_SCOPE;
2650 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2651 kid = ((LISTOP*)o)->op_first;
2652 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2655 /* The following deals with things like 'do {1 for 1}' */
2656 kid = kid->op_sibling;
2658 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2663 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2669 Perl_block_start(pTHX_ int full)
2672 const int retval = PL_savestack_ix;
2674 pad_block_start(full);
2676 PL_hints &= ~HINT_BLOCK_SCOPE;
2677 SAVECOMPILEWARNINGS();
2678 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2680 CALL_BLOCK_HOOKS(bhk_start, full);
2686 Perl_block_end(pTHX_ I32 floor, OP *seq)
2689 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2690 OP* retval = scalarseq(seq);
2692 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2695 CopHINTS_set(&PL_compiling, PL_hints);
2697 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2700 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2706 =head1 Compile-time scope hooks
2708 =for apidoc Aox||blockhook_register
2710 Register a set of hooks to be called when the Perl lexical scope changes
2711 at compile time. See L<perlguts/"Compile-time scope hooks">.
2717 Perl_blockhook_register(pTHX_ BHK *hk)
2719 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2721 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2728 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2729 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2730 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2733 OP * const o = newOP(OP_PADSV, 0);
2734 o->op_targ = offset;
2740 Perl_newPROG(pTHX_ OP *o)
2744 PERL_ARGS_ASSERT_NEWPROG;
2750 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2751 ((PL_in_eval & EVAL_KEEPERR)
2752 ? OPf_SPECIAL : 0), o);
2754 cx = &cxstack[cxstack_ix];
2755 assert(CxTYPE(cx) == CXt_EVAL);
2757 if ((cx->blk_gimme & G_WANT) == G_VOID)
2758 scalarvoid(PL_eval_root);
2759 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2762 scalar(PL_eval_root);
2764 /* don't use LINKLIST, since PL_eval_root might indirect through
2765 * a rather expensive function call and LINKLIST evaluates its
2766 * argument more than once */
2767 PL_eval_start = op_linklist(PL_eval_root);
2768 PL_eval_root->op_private |= OPpREFCOUNTED;
2769 OpREFCNT_set(PL_eval_root, 1);
2770 PL_eval_root->op_next = 0;
2771 CALL_PEEP(PL_eval_start);
2772 finalize_optree(PL_eval_root);
2776 if (o->op_type == OP_STUB) {
2777 PL_comppad_name = 0;
2779 S_op_destroy(aTHX_ o);
2782 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2783 PL_curcop = &PL_compiling;
2784 PL_main_start = LINKLIST(PL_main_root);
2785 PL_main_root->op_private |= OPpREFCOUNTED;
2786 OpREFCNT_set(PL_main_root, 1);
2787 PL_main_root->op_next = 0;
2788 CALL_PEEP(PL_main_start);
2789 finalize_optree(PL_main_root);
2792 /* Register with debugger */
2794 CV * const cv = get_cvs("DB::postponed", 0);
2798 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2800 call_sv(MUTABLE_SV(cv), G_DISCARD);
2807 Perl_localize(pTHX_ OP *o, I32 lex)
2811 PERL_ARGS_ASSERT_LOCALIZE;
2813 if (o->op_flags & OPf_PARENS)
2814 /* [perl #17376]: this appears to be premature, and results in code such as
2815 C< our(%x); > executing in list mode rather than void mode */
2822 if ( PL_parser->bufptr > PL_parser->oldbufptr
2823 && PL_parser->bufptr[-1] == ','
2824 && ckWARN(WARN_PARENTHESIS))
2826 char *s = PL_parser->bufptr;
2829 /* some heuristics to detect a potential error */
2830 while (*s && (strchr(", \t\n", *s)))
2834 if (*s && strchr("@$%*", *s) && *++s
2835 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2838 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2840 while (*s && (strchr(", \t\n", *s)))
2846 if (sigil && (*s == ';' || *s == '=')) {
2847 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2848 "Parentheses missing around \"%s\" list",
2850 ? (PL_parser->in_my == KEY_our
2852 : PL_parser->in_my == KEY_state
2862 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2863 PL_parser->in_my = FALSE;
2864 PL_parser->in_my_stash = NULL;
2869 Perl_jmaybe(pTHX_ OP *o)
2871 PERL_ARGS_ASSERT_JMAYBE;
2873 if (o->op_type == OP_LIST) {
2875 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2876 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2881 PERL_STATIC_INLINE OP *
2882 S_op_std_init(pTHX_ OP *o)
2884 I32 type = o->op_type;
2886 PERL_ARGS_ASSERT_OP_STD_INIT;
2888 if (PL_opargs[type] & OA_RETSCALAR)
2890 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2891 o->op_targ = pad_alloc(type, SVs_PADTMP);
2896 PERL_STATIC_INLINE OP *
2897 S_op_integerize(pTHX_ OP *o)
2899 I32 type = o->op_type;
2901 PERL_ARGS_ASSERT_OP_INTEGERIZE;
2903 /* integerize op, unless it happens to be C<-foo>.
2904 * XXX should pp_i_negate() do magic string negation instead? */
2905 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2906 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2907 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2910 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2913 if (type == OP_NEGATE)
2914 /* XXX might want a ck_negate() for this */
2915 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2921 S_fold_constants(pTHX_ register OP *o)
2924 register OP * VOL curop;
2926 VOL I32 type = o->op_type;
2931 SV * const oldwarnhook = PL_warnhook;
2932 SV * const olddiehook = PL_diehook;
2936 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2938 if (!(PL_opargs[type] & OA_FOLDCONST))
2952 /* XXX what about the numeric ops? */
2953 if (PL_hints & HINT_LOCALE)
2958 if (PL_parser && PL_parser->error_count)
2959 goto nope; /* Don't try to run w/ errors */
2961 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2962 const OPCODE type = curop->op_type;
2963 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2965 type != OP_SCALAR &&
2967 type != OP_PUSHMARK)
2973 curop = LINKLIST(o);
2974 old_next = o->op_next;
2978 oldscope = PL_scopestack_ix;
2979 create_eval_scope(G_FAKINGEVAL);
2981 /* Verify that we don't need to save it: */
2982 assert(PL_curcop == &PL_compiling);
2983 StructCopy(&PL_compiling, ¬_compiling, COP);
2984 PL_curcop = ¬_compiling;
2985 /* The above ensures that we run with all the correct hints of the
2986 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2987 assert(IN_PERL_RUNTIME);
2988 PL_warnhook = PERL_WARNHOOK_FATAL;
2995 sv = *(PL_stack_sp--);
2996 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2998 /* Can't simply swipe the SV from the pad, because that relies on
2999 the op being freed "real soon now". Under MAD, this doesn't
3000 happen (see the #ifdef below). */
3003 pad_swipe(o->op_targ, FALSE);
3006 else if (SvTEMP(sv)) { /* grab mortal temp? */
3007 SvREFCNT_inc_simple_void(sv);
3012 /* Something tried to die. Abandon constant folding. */
3013 /* Pretend the error never happened. */
3015 o->op_next = old_next;
3019 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3020 PL_warnhook = oldwarnhook;
3021 PL_diehook = olddiehook;
3022 /* XXX note that this croak may fail as we've already blown away
3023 * the stack - eg any nested evals */
3024 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3027 PL_warnhook = oldwarnhook;
3028 PL_diehook = olddiehook;
3029 PL_curcop = &PL_compiling;
3031 if (PL_scopestack_ix > oldscope)
3032 delete_eval_scope();
3041 if (type == OP_RV2GV)
3042 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3044 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3045 op_getmad(o,newop,'f');
3053 S_gen_constant_list(pTHX_ register OP *o)
3057 const I32 oldtmps_floor = PL_tmps_floor;
3060 if (PL_parser && PL_parser->error_count)
3061 return o; /* Don't attempt to run with errors */
3063 PL_op = curop = LINKLIST(o);
3066 Perl_pp_pushmark(aTHX);
3069 assert (!(curop->op_flags & OPf_SPECIAL));
3070 assert(curop->op_type == OP_RANGE);
3071 Perl_pp_anonlist(aTHX);
3072 PL_tmps_floor = oldtmps_floor;
3074 o->op_type = OP_RV2AV;
3075 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3076 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3077 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3078 o->op_opt = 0; /* needs to be revisited in rpeep() */
3079 curop = ((UNOP*)o)->op_first;
3080 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3082 op_getmad(curop,o,'O');
3091 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3094 if (!o || o->op_type != OP_LIST)
3095 o = newLISTOP(OP_LIST, 0, o, NULL);
3097 o->op_flags &= ~OPf_WANT;
3099 if (!(PL_opargs[type] & OA_MARK))
3100 op_null(cLISTOPo->op_first);
3102 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3103 if (kid2 && kid2->op_type == OP_COREARGS) {
3104 op_null(cLISTOPo->op_first);
3105 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3109 o->op_type = (OPCODE)type;
3110 o->op_ppaddr = PL_ppaddr[type];
3111 o->op_flags |= flags;
3113 o = CHECKOP(type, o);
3114 if (o->op_type != (unsigned)type)
3117 return fold_constants(op_integerize(op_std_init(o)));
3121 =head1 Optree Manipulation Functions
3124 /* List constructors */
3127 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3129 Append an item to the list of ops contained directly within a list-type
3130 op, returning the lengthened list. I<first> is the list-type op,
3131 and I<last> is the op to append to the list. I<optype> specifies the
3132 intended opcode for the list. If I<first> is not already a list of the
3133 right type, it will be upgraded into one. If either I<first> or I<last>
3134 is null, the other is returned unchanged.
3140 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3148 if (first->op_type != (unsigned)type
3149 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3151 return newLISTOP(type, 0, first, last);
3154 if (first->op_flags & OPf_KIDS)
3155 ((LISTOP*)first)->op_last->op_sibling = last;
3157 first->op_flags |= OPf_KIDS;
3158 ((LISTOP*)first)->op_first = last;
3160 ((LISTOP*)first)->op_last = last;
3165 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3167 Concatenate the lists of ops contained directly within two list-type ops,
3168 returning the combined list. I<first> and I<last> are the list-type ops
3169 to concatenate. I<optype> specifies the intended opcode for the list.
3170 If either I<first> or I<last> is not already a list of the right type,
3171 it will be upgraded into one. If either I<first> or I<last> is null,
3172 the other is returned unchanged.
3178 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3186 if (first->op_type != (unsigned)type)
3187 return op_prepend_elem(type, first, last);
3189 if (last->op_type != (unsigned)type)
3190 return op_append_elem(type, first, last);
3192 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3193 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3194 first->op_flags |= (last->op_flags & OPf_KIDS);
3197 if (((LISTOP*)last)->op_first && first->op_madprop) {
3198 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3200 while (mp->mad_next)
3202 mp->mad_next = first->op_madprop;
3205 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3208 first->op_madprop = last->op_madprop;
3209 last->op_madprop = 0;
3212 S_op_destroy(aTHX_ last);
3218 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3220 Prepend an item to the list of ops contained directly within a list-type
3221 op, returning the lengthened list. I<first> is the op to prepend to the
3222 list, and I<last> is the list-type op. I<optype> specifies the intended
3223 opcode for the list. If I<last> is not already a list of the right type,
3224 it will be upgraded into one. If either I<first> or I<last> is null,
3225 the other is returned unchanged.
3231 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3239 if (last->op_type == (unsigned)type) {
3240 if (type == OP_LIST) { /* already a PUSHMARK there */
3241 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3242 ((LISTOP*)last)->op_first->op_sibling = first;
3243 if (!(first->op_flags & OPf_PARENS))
3244 last->op_flags &= ~OPf_PARENS;
3247 if (!(last->op_flags & OPf_KIDS)) {
3248 ((LISTOP*)last)->op_last = first;
3249 last->op_flags |= OPf_KIDS;
3251 first->op_sibling = ((LISTOP*)last)->op_first;
3252 ((LISTOP*)last)->op_first = first;
3254 last->op_flags |= OPf_KIDS;
3258 return newLISTOP(type, 0, first, last);
3266 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3269 Newxz(tk, 1, TOKEN);
3270 tk->tk_type = (OPCODE)optype;
3271 tk->tk_type = 12345;
3273 tk->tk_mad = madprop;
3278 Perl_token_free(pTHX_ TOKEN* tk)
3280 PERL_ARGS_ASSERT_TOKEN_FREE;
3282 if (tk->tk_type != 12345)
3284 mad_free(tk->tk_mad);
3289 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3294 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3296 if (tk->tk_type != 12345) {
3297 Perl_warner(aTHX_ packWARN(WARN_MISC),
3298 "Invalid TOKEN object ignored");
3305 /* faked up qw list? */
3307 tm->mad_type == MAD_SV &&
3308 SvPVX((SV *)tm->mad_val)[0] == 'q')
3315 /* pretend constant fold didn't happen? */
3316 if (mp->mad_key == 'f' &&
3317 (o->op_type == OP_CONST ||
3318 o->op_type == OP_GV) )
3320 token_getmad(tk,(OP*)mp->mad_val,slot);
3334 if (mp->mad_key == 'X')
3335 mp->mad_key = slot; /* just change the first one */
3345 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3354 /* pretend constant fold didn't happen? */
3355 if (mp->mad_key == 'f' &&
3356 (o->op_type == OP_CONST ||
3357 o->op_type == OP_GV) )
3359 op_getmad(from,(OP*)mp->mad_val,slot);
3366 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3369 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3375 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3384 /* pretend constant fold didn't happen? */
3385 if (mp->mad_key == 'f' &&
3386 (o->op_type == OP_CONST ||
3387 o->op_type == OP_GV) )
3389 op_getmad(from,(OP*)mp->mad_val,slot);
3396 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3399 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3403 PerlIO_printf(PerlIO_stderr(),
3404 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3410 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3428 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3432 addmad(tm, &(o->op_madprop), slot);
3436 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3457 Perl_newMADsv(pTHX_ char key, SV* sv)
3459 PERL_ARGS_ASSERT_NEWMADSV;
3461 return newMADPROP(key, MAD_SV, sv, 0);
3465 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3467 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3470 mp->mad_vlen = vlen;
3471 mp->mad_type = type;
3473 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3478 Perl_mad_free(pTHX_ MADPROP* mp)
3480 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3484 mad_free(mp->mad_next);
3485 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3486 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3487 switch (mp->mad_type) {
3491 Safefree((char*)mp->mad_val);
3494 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3495 op_free((OP*)mp->mad_val);
3498 sv_free(MUTABLE_SV(mp->mad_val));
3501 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3504 PerlMemShared_free(mp);
3510 =head1 Optree construction
3512 =for apidoc Am|OP *|newNULLLIST
3514 Constructs, checks, and returns a new C<stub> op, which represents an
3515 empty list expression.
3521 Perl_newNULLLIST(pTHX)
3523 return newOP(OP_STUB, 0);
3527 S_force_list(pTHX_ OP *o)
3529 if (!o || o->op_type != OP_LIST)
3530 o = newLISTOP(OP_LIST, 0, o, NULL);
3536 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3538 Constructs, checks, and returns an op of any list type. I<type> is
3539 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3540 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3541 supply up to two ops to be direct children of the list op; they are
3542 consumed by this function and become part of the constructed op tree.
3548 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3553 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3555 NewOp(1101, listop, 1, LISTOP);
3557 listop->op_type = (OPCODE)type;
3558 listop->op_ppaddr = PL_ppaddr[type];
3561 listop->op_flags = (U8)flags;
3565 else if (!first && last)
3568 first->op_sibling = last;
3569 listop->op_first = first;
3570 listop->op_last = last;
3571 if (type == OP_LIST) {
3572 OP* const pushop = newOP(OP_PUSHMARK, 0);
3573 pushop->op_sibling = first;
3574 listop->op_first = pushop;
3575 listop->op_flags |= OPf_KIDS;
3577 listop->op_last = pushop;
3580 return CHECKOP(type, listop);
3584 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3586 Constructs, checks, and returns an op of any base type (any type that
3587 has no extra fields). I<type> is the opcode. I<flags> gives the
3588 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3595 Perl_newOP(pTHX_ I32 type, I32 flags)
3600 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3601 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3602 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3603 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3605 NewOp(1101, o, 1, OP);
3606 o->op_type = (OPCODE)type;
3607 o->op_ppaddr = PL_ppaddr[type];
3608 o->op_flags = (U8)flags;
3610 o->op_latefreed = 0;
3614 o->op_private = (U8)(0 | (flags >> 8));
3615 if (PL_opargs[type] & OA_RETSCALAR)
3617 if (PL_opargs[type] & OA_TARGET)
3618 o->op_targ = pad_alloc(type, SVs_PADTMP);
3619 return CHECKOP(type, o);
3623 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3625 Constructs, checks, and returns an op of any unary type. I<type> is
3626 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3627 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3628 bits, the eight bits of C<op_private>, except that the bit with value 1
3629 is automatically set. I<first> supplies an optional op to be the direct
3630 child of the unary op; it is consumed by this function and become part
3631 of the constructed op tree.
3637 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3642 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3643 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3644 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3645 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3646 || type == OP_SASSIGN
3647 || type == OP_ENTERTRY
3648 || type == OP_NULL );
3651 first = newOP(OP_STUB, 0);
3652 if (PL_opargs[type] & OA_MARK)
3653 first = force_list(first);
3655 NewOp(1101, unop, 1, UNOP);
3656 unop->op_type = (OPCODE)type;
3657 unop->op_ppaddr = PL_ppaddr[type];
3658 unop->op_first = first;
3659 unop->op_flags = (U8)(flags | OPf_KIDS);
3660 unop->op_private = (U8)(1 | (flags >> 8));
3661 unop = (UNOP*) CHECKOP(type, unop);
3665 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3669 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3671 Constructs, checks, and returns an op of any binary type. I<type>
3672 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3673 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3674 the eight bits of C<op_private>, except that the bit with value 1 or
3675 2 is automatically set as required. I<first> and I<last> supply up to
3676 two ops to be the direct children of the binary op; they are consumed
3677 by this function and become part of the constructed op tree.
3683 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3688 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3689 || type == OP_SASSIGN || type == OP_NULL );
3691 NewOp(1101, binop, 1, BINOP);
3694 first = newOP(OP_NULL, 0);
3696 binop->op_type = (OPCODE)type;
3697 binop->op_ppaddr = PL_ppaddr[type];
3698 binop->op_first = first;
3699 binop->op_flags = (U8)(flags | OPf_KIDS);
3702 binop->op_private = (U8)(1 | (flags >> 8));
3705 binop->op_private = (U8)(2 | (flags >> 8));
3706 first->op_sibling = last;
3709 binop = (BINOP*)CHECKOP(type, binop);
3710 if (binop->op_next || binop->op_type != (OPCODE)type)
3713 binop->op_last = binop->op_first->op_sibling;
3715 return fold_constants(op_integerize(op_std_init((OP *)binop)));
3718 static int uvcompare(const void *a, const void *b)
3719 __attribute__nonnull__(1)
3720 __attribute__nonnull__(2)
3721 __attribute__pure__;
3722 static int uvcompare(const void *a, const void *b)
3724 if (*((const UV *)a) < (*(const UV *)b))
3726 if (*((const UV *)a) > (*(const UV *)b))
3728 if (*((const UV *)a+1) < (*(const UV *)b+1))
3730 if (*((const UV *)a+1) > (*(const UV *)b+1))
3736 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3739 SV * const tstr = ((SVOP*)expr)->op_sv;
3742 (repl->op_type == OP_NULL)
3743 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3745 ((SVOP*)repl)->op_sv;
3748 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3749 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3753 register short *tbl;
3755 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3756 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3757 I32 del = o->op_private & OPpTRANS_DELETE;
3760 PERL_ARGS_ASSERT_PMTRANS;
3762 PL_hints |= HINT_BLOCK_SCOPE;
3765 o->op_private |= OPpTRANS_FROM_UTF;
3768 o->op_private |= OPpTRANS_TO_UTF;
3770 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3771 SV* const listsv = newSVpvs("# comment\n");
3773 const U8* tend = t + tlen;
3774 const U8* rend = r + rlen;
3788 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3789 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3792 const U32 flags = UTF8_ALLOW_DEFAULT;
3796 t = tsave = bytes_to_utf8(t, &len);
3799 if (!to_utf && rlen) {
3801 r = rsave = bytes_to_utf8(r, &len);
3805 /* There are several snags with this code on EBCDIC:
3806 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3807 2. scan_const() in toke.c has encoded chars in native encoding which makes
3808 ranges at least in EBCDIC 0..255 range the bottom odd.
3812 U8 tmpbuf[UTF8_MAXBYTES+1];
3815 Newx(cp, 2*tlen, UV);
3817 transv = newSVpvs("");
3819 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3821 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3823 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3827 cp[2*i+1] = cp[2*i];
3831 qsort(cp, i, 2*sizeof(UV), uvcompare);
3832 for (j = 0; j < i; j++) {
3834 diff = val - nextmin;
3836 t = uvuni_to_utf8(tmpbuf,nextmin);
3837 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3839 U8 range_mark = UTF_TO_NATIVE(0xff);
3840 t = uvuni_to_utf8(tmpbuf, val - 1);
3841 sv_catpvn(transv, (char *)&range_mark, 1);
3842 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3849 t = uvuni_to_utf8(tmpbuf,nextmin);
3850 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3852 U8 range_mark = UTF_TO_NATIVE(0xff);
3853 sv_catpvn(transv, (char *)&range_mark, 1);
3855 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3856 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3857 t = (const U8*)SvPVX_const(transv);
3858 tlen = SvCUR(transv);
3862 else if (!rlen && !del) {
3863 r = t; rlen = tlen; rend = tend;
3866 if ((!rlen && !del) || t == r ||
3867 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3869 o->op_private |= OPpTRANS_IDENTICAL;
3873 while (t < tend || tfirst <= tlast) {
3874 /* see if we need more "t" chars */
3875 if (tfirst > tlast) {
3876 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3878 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3880 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3887 /* now see if we need more "r" chars */
3888 if (rfirst > rlast) {
3890 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3892 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3894 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3903 rfirst = rlast = 0xffffffff;
3907 /* now see which range will peter our first, if either. */
3908 tdiff = tlast - tfirst;
3909 rdiff = rlast - rfirst;
3916 if (rfirst == 0xffffffff) {
3917 diff = tdiff; /* oops, pretend rdiff is infinite */
3919 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3920 (long)tfirst, (long)tlast);
3922 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3926 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3927 (long)tfirst, (long)(tfirst + diff),
3930 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3931 (long)tfirst, (long)rfirst);
3933 if (rfirst + diff > max)
3934 max = rfirst + diff;
3936 grows = (tfirst < rfirst &&
3937 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3949 else if (max > 0xff)
3954 PerlMemShared_free(cPVOPo->op_pv);
3955 cPVOPo->op_pv = NULL;
3957 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3959 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3960 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3961 PAD_SETSV(cPADOPo->op_padix, swash);
3963 SvREADONLY_on(swash);
3965 cSVOPo->op_sv = swash;
3967 SvREFCNT_dec(listsv);
3968 SvREFCNT_dec(transv);
3970 if (!del && havefinal && rlen)
3971 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3972 newSVuv((UV)final), 0);
3975 o->op_private |= OPpTRANS_GROWS;
3981 op_getmad(expr,o,'e');
3982 op_getmad(repl,o,'r');
3990 tbl = (short*)cPVOPo->op_pv;
3992 Zero(tbl, 256, short);
3993 for (i = 0; i < (I32)tlen; i++)
3995 for (i = 0, j = 0; i < 256; i++) {
3997 if (j >= (I32)rlen) {
4006 if (i < 128 && r[j] >= 128)
4016 o->op_private |= OPpTRANS_IDENTICAL;
4018 else if (j >= (I32)rlen)
4023 PerlMemShared_realloc(tbl,
4024 (0x101+rlen-j) * sizeof(short));
4025 cPVOPo->op_pv = (char*)tbl;
4027 tbl[0x100] = (short)(rlen - j);
4028 for (i=0; i < (I32)rlen - j; i++)
4029 tbl[0x101+i] = r[j+i];
4033 if (!rlen && !del) {
4036 o->op_private |= OPpTRANS_IDENTICAL;
4038 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4039 o->op_private |= OPpTRANS_IDENTICAL;
4041 for (i = 0; i < 256; i++)
4043 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4044 if (j >= (I32)rlen) {
4046 if (tbl[t[i]] == -1)
4052 if (tbl[t[i]] == -1) {
4053 if (t[i] < 128 && r[j] >= 128)
4060 if(del && rlen == tlen) {
4061 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4062 } else if(rlen > tlen) {
4063 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4067 o->op_private |= OPpTRANS_GROWS;
4069 op_getmad(expr,o,'e');
4070 op_getmad(repl,o,'r');
4080 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4082 Constructs, checks, and returns an op of any pattern matching type.
4083 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4084 and, shifted up eight bits, the eight bits of C<op_private>.
4090 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4095 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4097 NewOp(1101, pmop, 1, PMOP);
4098 pmop->op_type = (OPCODE)type;
4099 pmop->op_ppaddr = PL_ppaddr[type];
4100 pmop->op_flags = (U8)flags;
4101 pmop->op_private = (U8)(0 | (flags >> 8));
4103 if (PL_hints & HINT_RE_TAINT)
4104 pmop->op_pmflags |= PMf_RETAINT;
4105 if (PL_hints & HINT_LOCALE) {
4106 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4108 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
4109 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4111 if (PL_hints & HINT_RE_FLAGS) {
4112 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4113 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4115 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4116 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4117 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4119 if (reflags && SvOK(reflags)) {
4120 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4126 assert(SvPOK(PL_regex_pad[0]));
4127 if (SvCUR(PL_regex_pad[0])) {
4128 /* Pop off the "packed" IV from the end. */
4129 SV *const repointer_list = PL_regex_pad[0];
4130 const char *p = SvEND(repointer_list) - sizeof(IV);
4131 const IV offset = *((IV*)p);
4133 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4135 SvEND_set(repointer_list, p);
4137 pmop->op_pmoffset = offset;
4138 /* This slot should be free, so assert this: */
4139 assert(PL_regex_pad[offset] == &PL_sv_undef);
4141 SV * const repointer = &PL_sv_undef;
4142 av_push(PL_regex_padav, repointer);
4143 pmop->op_pmoffset = av_len(PL_regex_padav);
4144 PL_regex_pad = AvARRAY(PL_regex_padav);
4148 return CHECKOP(type, pmop);
4151 /* Given some sort of match op o, and an expression expr containing a
4152 * pattern, either compile expr into a regex and attach it to o (if it's
4153 * constant), or convert expr into a runtime regcomp op sequence (if it's
4156 * isreg indicates that the pattern is part of a regex construct, eg
4157 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4158 * split "pattern", which aren't. In the former case, expr will be a list
4159 * if the pattern contains more than one term (eg /a$b/) or if it contains
4160 * a replacement, ie s/// or tr///.
4164 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4169 I32 repl_has_vars = 0;
4173 PERL_ARGS_ASSERT_PMRUNTIME;
4176 o->op_type == OP_SUBST
4177 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4179 /* last element in list is the replacement; pop it */
4181 repl = cLISTOPx(expr)->op_last;
4182 kid = cLISTOPx(expr)->op_first;
4183 while (kid->op_sibling != repl)
4184 kid = kid->op_sibling;
4185 kid->op_sibling = NULL;
4186 cLISTOPx(expr)->op_last = kid;
4189 if (isreg && expr->op_type == OP_LIST &&
4190 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4192 /* convert single element list to element */
4193 OP* const oe = expr;
4194 expr = cLISTOPx(oe)->op_first->op_sibling;
4195 cLISTOPx(oe)->op_first->op_sibling = NULL;
4196 cLISTOPx(oe)->op_last = NULL;
4200 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4201 return pmtrans(o, expr, repl);
4204 reglist = isreg && expr->op_type == OP_LIST;
4208 PL_hints |= HINT_BLOCK_SCOPE;
4211 if (expr->op_type == OP_CONST) {
4212 SV *pat = ((SVOP*)expr)->op_sv;
4213 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4215 if (o->op_flags & OPf_SPECIAL)
4216 pm_flags |= RXf_SPLIT;
4219 assert (SvUTF8(pat));
4220 } else if (SvUTF8(pat)) {
4221 /* Not doing UTF-8, despite what the SV says. Is this only if we're
4222 trapped in use 'bytes'? */
4223 /* Make a copy of the octet sequence, but without the flag on, as
4224 the compiler now honours the SvUTF8 flag on pat. */
4226 const char *const p = SvPV(pat, len);
4227 pat = newSVpvn_flags(p, len, SVs_TEMP);
4230 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4233 op_getmad(expr,(OP*)pm,'e');
4239 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4240 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4242 : OP_REGCMAYBE),0,expr);
4244 NewOp(1101, rcop, 1, LOGOP);
4245 rcop->op_type = OP_REGCOMP;
4246 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4247 rcop->op_first = scalar(expr);
4248 rcop->op_flags |= OPf_KIDS
4249 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4250 | (reglist ? OPf_STACKED : 0);
4251 rcop->op_private = 1;
4254 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4256 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4257 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4259 /* establish postfix order */
4260 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4262 rcop->op_next = expr;
4263 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4266 rcop->op_next = LINKLIST(expr);
4267 expr->op_next = (OP*)rcop;
4270 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4275 if (pm->op_pmflags & PMf_EVAL) {
4277 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4278 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4280 else if (repl->op_type == OP_CONST)
4284 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4285 if (curop->op_type == OP_SCOPE
4286 || curop->op_type == OP_LEAVE
4287 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4288 if (curop->op_type == OP_GV) {
4289 GV * const gv = cGVOPx_gv(curop);
4291 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4294 else if (curop->op_type == OP_RV2CV)
4296 else if (curop->op_type == OP_RV2SV ||
4297 curop->op_type == OP_RV2AV ||
4298 curop->op_type == OP_RV2HV ||
4299 curop->op_type == OP_RV2GV) {
4300 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4303 else if (curop->op_type == OP_PADSV ||
4304 curop->op_type == OP_PADAV ||
4305 curop->op_type == OP_PADHV ||
4306 curop->op_type == OP_PADANY)
4310 else if (curop->op_type == OP_PUSHRE)
4311 NOOP; /* Okay here, dangerous in newASSIGNOP */
4321 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4323 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4324 op_prepend_elem(o->op_type, scalar(repl), o);
4327 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4328 pm->op_pmflags |= PMf_MAYBE_CONST;
4330 NewOp(1101, rcop, 1, LOGOP);
4331 rcop->op_type = OP_SUBSTCONT;
4332 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4333 rcop->op_first = scalar(repl);
4334 rcop->op_flags |= OPf_KIDS;
4335 rcop->op_private = 1;
4338 /* establish postfix order */
4339 rcop->op_next = LINKLIST(repl);
4340 repl->op_next = (OP*)rcop;
4342 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4343 assert(!(pm->op_pmflags & PMf_ONCE));
4344 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4353 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4355 Constructs, checks, and returns an op of any type that involves an
4356 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4357 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4358 takes ownership of one reference to it.
4364 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4369 PERL_ARGS_ASSERT_NEWSVOP;
4371 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4372 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4373 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4375 NewOp(1101, svop, 1, SVOP);
4376 svop->op_type = (OPCODE)type;
4377 svop->op_ppaddr = PL_ppaddr[type];
4379 svop->op_next = (OP*)svop;
4380 svop->op_flags = (U8)flags;
4381 if (PL_opargs[type] & OA_RETSCALAR)
4383 if (PL_opargs[type] & OA_TARGET)
4384 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4385 return CHECKOP(type, svop);
4391 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4393 Constructs, checks, and returns an op of any type that involves a
4394 reference to a pad element. I<type> is the opcode. I<flags> gives the
4395 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4396 is populated with I<sv>; this function takes ownership of one reference
4399 This function only exists if Perl has been compiled to use ithreads.
4405 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4410 PERL_ARGS_ASSERT_NEWPADOP;
4412 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4413 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4414 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4416 NewOp(1101, padop, 1, PADOP);
4417 padop->op_type = (OPCODE)type;
4418 padop->op_ppaddr = PL_ppaddr[type];
4419 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4420 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4421 PAD_SETSV(padop->op_padix, sv);
4424 padop->op_next = (OP*)padop;
4425 padop->op_flags = (U8)flags;
4426 if (PL_opargs[type] & OA_RETSCALAR)
4428 if (PL_opargs[type] & OA_TARGET)
4429 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4430 return CHECKOP(type, padop);
4433 #endif /* !USE_ITHREADS */
4436 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4438 Constructs, checks, and returns an op of any type that involves an
4439 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4440 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4441 reference; calling this function does not transfer ownership of any
4448 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4452 PERL_ARGS_ASSERT_NEWGVOP;
4456 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4458 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4463 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4465 Constructs, checks, and returns an op of any type that involves an
4466 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4467 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4468 must have been allocated using L</PerlMemShared_malloc>; the memory will
4469 be freed when the op is destroyed.
4475 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4480 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4481 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4483 NewOp(1101, pvop, 1, PVOP);
4484 pvop->op_type = (OPCODE)type;
4485 pvop->op_ppaddr = PL_ppaddr[type];
4487 pvop->op_next = (OP*)pvop;
4488 pvop->op_flags = (U8)flags;
4489 if (PL_opargs[type] & OA_RETSCALAR)
4491 if (PL_opargs[type] & OA_TARGET)
4492 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4493 return CHECKOP(type, pvop);
4501 Perl_package(pTHX_ OP *o)
4504 SV *const sv = cSVOPo->op_sv;
4509 PERL_ARGS_ASSERT_PACKAGE;
4511 save_hptr(&PL_curstash);
4512 save_item(PL_curstname);
4514 PL_curstash = gv_stashsv(sv, GV_ADD);
4516 sv_setsv(PL_curstname, sv);
4518 PL_hints |= HINT_BLOCK_SCOPE;
4519 PL_parser->copline = NOLINE;
4520 PL_parser->expect = XSTATE;
4525 if (!PL_madskills) {
4530 pegop = newOP(OP_NULL,0);
4531 op_getmad(o,pegop,'P');
4537 Perl_package_version( pTHX_ OP *v )
4540 U32 savehints = PL_hints;
4541 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4542 PL_hints &= ~HINT_STRICT_VARS;
4543 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4544 PL_hints = savehints;
4553 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4560 OP *pegop = newOP(OP_NULL,0);
4562 SV *use_version = NULL;
4564 PERL_ARGS_ASSERT_UTILIZE;
4566 if (idop->op_type != OP_CONST)
4567 Perl_croak(aTHX_ "Module name must be constant");
4570 op_getmad(idop,pegop,'U');
4575 SV * const vesv = ((SVOP*)version)->op_sv;
4578 op_getmad(version,pegop,'V');
4579 if (!arg && !SvNIOKp(vesv)) {
4586 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4587 Perl_croak(aTHX_ "Version number must be a constant number");
4589 /* Make copy of idop so we don't free it twice */
4590 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4592 /* Fake up a method call to VERSION */
4593 meth = newSVpvs_share("VERSION");
4594 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4595 op_append_elem(OP_LIST,
4596 op_prepend_elem(OP_LIST, pack, list(version)),
4597 newSVOP(OP_METHOD_NAMED, 0, meth)));
4601 /* Fake up an import/unimport */
4602 if (arg && arg->op_type == OP_STUB) {
4604 op_getmad(arg,pegop,'S');
4605 imop = arg; /* no import on explicit () */
4607 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4608 imop = NULL; /* use 5.0; */
4610 use_version = ((SVOP*)idop)->op_sv;
4612 idop->op_private |= OPpCONST_NOVER;
4618 op_getmad(arg,pegop,'A');
4620 /* Make copy of idop so we don't free it twice */
4621 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4623 /* Fake up a method call to import/unimport */
4625 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4626 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4627 op_append_elem(OP_LIST,
4628 op_prepend_elem(OP_LIST, pack, list(arg)),
4629 newSVOP(OP_METHOD_NAMED, 0, meth)));
4632 /* Fake up the BEGIN {}, which does its thing immediately. */
4634 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4637 op_append_elem(OP_LINESEQ,
4638 op_append_elem(OP_LINESEQ,
4639 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4640 newSTATEOP(0, NULL, veop)),
4641 newSTATEOP(0, NULL, imop) ));
4644 /* If we request a version >= 5.9.5, load feature.pm with the
4645 * feature bundle that corresponds to the required version. */
4646 use_version = sv_2mortal(new_version(use_version));
4648 if (vcmp(use_version,
4649 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4650 SV *const importsv = vnormal(use_version);
4651 *SvPVX_mutable(importsv) = ':';
4652 ENTER_with_name("load_feature");
4653 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4654 LEAVE_with_name("load_feature");
4656 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4657 if (vcmp(use_version,
4658 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4659 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4663 /* The "did you use incorrect case?" warning used to be here.
4664 * The problem is that on case-insensitive filesystems one
4665 * might get false positives for "use" (and "require"):
4666 * "use Strict" or "require CARP" will work. This causes
4667 * portability problems for the script: in case-strict
4668 * filesystems the script will stop working.
4670 * The "incorrect case" warning checked whether "use Foo"
4671 * imported "Foo" to your namespace, but that is wrong, too:
4672 * there is no requirement nor promise in the language that
4673 * a Foo.pm should or would contain anything in package "Foo".
4675 * There is very little Configure-wise that can be done, either:
4676 * the case-sensitivity of the build filesystem of Perl does not
4677 * help in guessing the case-sensitivity of the runtime environment.
4680 PL_hints |= HINT_BLOCK_SCOPE;
4681 PL_parser->copline = NOLINE;
4682 PL_parser->expect = XSTATE;
4683 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4684 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4688 if (!PL_madskills) {
4689 /* FIXME - don't allocate pegop if !PL_madskills */
4698 =head1 Embedding Functions
4700 =for apidoc load_module
4702 Loads the module whose name is pointed to by the string part of name.
4703 Note that the actual module name, not its filename, should be given.
4704 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4705 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4706 (or 0 for no flags). ver, if specified, provides version semantics
4707 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4708 arguments can be used to specify arguments to the module's import()
4709 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4710 terminated with a final NULL pointer. Note that this list can only
4711 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4712 Otherwise at least a single NULL pointer to designate the default
4713 import list is required.
4718 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4722 PERL_ARGS_ASSERT_LOAD_MODULE;
4724 va_start(args, ver);
4725 vload_module(flags, name, ver, &args);
4729 #ifdef PERL_IMPLICIT_CONTEXT
4731 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4735 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4736 va_start(args, ver);
4737 vload_module(flags, name, ver, &args);
4743 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4747 OP * const modname = newSVOP(OP_CONST, 0, name);
4749 PERL_ARGS_ASSERT_VLOAD_MODULE;
4751 modname->op_private |= OPpCONST_BARE;
4753 veop = newSVOP(OP_CONST, 0, ver);
4757 if (flags & PERL_LOADMOD_NOIMPORT) {
4758 imop = sawparens(newNULLLIST());
4760 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4761 imop = va_arg(*args, OP*);
4766 sv = va_arg(*args, SV*);
4768 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4769 sv = va_arg(*args, SV*);
4773 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4774 * that it has a PL_parser to play with while doing that, and also
4775 * that it doesn't mess with any existing parser, by creating a tmp
4776 * new parser with lex_start(). This won't actually be used for much,
4777 * since pp_require() will create another parser for the real work. */
4780 SAVEVPTR(PL_curcop);
4781 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4782 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4783 veop, modname, imop);
4788 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4794 PERL_ARGS_ASSERT_DOFILE;
4796 if (!force_builtin) {
4797 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4798 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4799 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4800 gv = gvp ? *gvp : NULL;
4804 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4805 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4806 op_append_elem(OP_LIST, term,
4807 scalar(newUNOP(OP_RV2CV, 0,
4808 newGVOP(OP_GV, 0, gv))))));
4811 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4817 =head1 Optree construction
4819 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4821 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4822 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4823 be set automatically, and, shifted up eight bits, the eight bits of
4824 C<op_private>, except that the bit with value 1 or 2 is automatically
4825 set as required. I<listval> and I<subscript> supply the parameters of
4826 the slice; they are consumed by this function and become part of the
4827 constructed op tree.
4833 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4835 return newBINOP(OP_LSLICE, flags,
4836 list(force_list(subscript)),
4837 list(force_list(listval)) );
4841 S_is_list_assignment(pTHX_ register const OP *o)
4849 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4850 o = cUNOPo->op_first;
4852 flags = o->op_flags;
4854 if (type == OP_COND_EXPR) {
4855 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4856 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4861 yyerror("Assignment to both a list and a scalar");
4865 if (type == OP_LIST &&
4866 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4867 o->op_private & OPpLVAL_INTRO)
4870 if (type == OP_LIST || flags & OPf_PARENS ||
4871 type == OP_RV2AV || type == OP_RV2HV ||
4872 type == OP_ASLICE || type == OP_HSLICE)
4875 if (type == OP_PADAV || type == OP_PADHV)
4878 if (type == OP_RV2SV)
4885 Helper function for newASSIGNOP to detection commonality between the
4886 lhs and the rhs. Marks all variables with PL_generation. If it
4887 returns TRUE the assignment must be able to handle common variables.
4889 PERL_STATIC_INLINE bool
4890 S_aassign_common_vars(pTHX_ OP* o)
4893 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
4894 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4895 if (curop->op_type == OP_GV) {
4896 GV *gv = cGVOPx_gv(curop);
4898 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4900 GvASSIGN_GENERATION_set(gv, PL_generation);
4902 else if (curop->op_type == OP_PADSV ||
4903 curop->op_type == OP_PADAV ||
4904 curop->op_type == OP_PADHV ||
4905 curop->op_type == OP_PADANY)
4907 if (PAD_COMPNAME_GEN(curop->op_targ)
4908 == (STRLEN)PL_generation)
4910 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4913 else if (curop->op_type == OP_RV2CV)
4915 else if (curop->op_type == OP_RV2SV ||
4916 curop->op_type == OP_RV2AV ||
4917 curop->op_type == OP_RV2HV ||
4918 curop->op_type == OP_RV2GV) {
4919 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
4922 else if (curop->op_type == OP_PUSHRE) {
4924 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4925 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4927 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4929 GvASSIGN_GENERATION_set(gv, PL_generation);
4933 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4936 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4938 GvASSIGN_GENERATION_set(gv, PL_generation);
4946 if (curop->op_flags & OPf_KIDS) {
4947 if (aassign_common_vars(curop))
4955 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4957 Constructs, checks, and returns an assignment op. I<left> and I<right>
4958 supply the parameters of the assignment; they are consumed by this
4959 function and become part of the constructed op tree.
4961 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4962 a suitable conditional optree is constructed. If I<optype> is the opcode
4963 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4964 performs the binary operation and assigns the result to the left argument.
4965 Either way, if I<optype> is non-zero then I<flags> has no effect.
4967 If I<optype> is zero, then a plain scalar or list assignment is
4968 constructed. Which type of assignment it is is automatically determined.
4969 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4970 will be set automatically, and, shifted up eight bits, the eight bits
4971 of C<op_private>, except that the bit with value 1 or 2 is automatically
4978 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4984 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4985 return newLOGOP(optype, 0,
4986 op_lvalue(scalar(left), optype),
4987 newUNOP(OP_SASSIGN, 0, scalar(right)));
4990 return newBINOP(optype, OPf_STACKED,
4991 op_lvalue(scalar(left), optype), scalar(right));
4995 if (is_list_assignment(left)) {
4996 static const char no_list_state[] = "Initialization of state variables"
4997 " in list context currently forbidden";
4999 bool maybe_common_vars = TRUE;
5002 left = op_lvalue(left, OP_AASSIGN);
5003 curop = list(force_list(left));
5004 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5005 o->op_private = (U8)(0 | (flags >> 8));
5007 if ((left->op_type == OP_LIST
5008 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5010 OP* lop = ((LISTOP*)left)->op_first;
5011 maybe_common_vars = FALSE;
5013 if (lop->op_type == OP_PADSV ||
5014 lop->op_type == OP_PADAV ||
5015 lop->op_type == OP_PADHV ||
5016 lop->op_type == OP_PADANY) {
5017 if (!(lop->op_private & OPpLVAL_INTRO))
5018 maybe_common_vars = TRUE;
5020 if (lop->op_private & OPpPAD_STATE) {
5021 if (left->op_private & OPpLVAL_INTRO) {
5022 /* Each variable in state($a, $b, $c) = ... */
5025 /* Each state variable in
5026 (state $a, my $b, our $c, $d, undef) = ... */
5028 yyerror(no_list_state);
5030 /* Each my variable in
5031 (state $a, my $b, our $c, $d, undef) = ... */
5033 } else if (lop->op_type == OP_UNDEF ||
5034 lop->op_type == OP_PUSHMARK) {
5035 /* undef may be interesting in
5036 (state $a, undef, state $c) */
5038 /* Other ops in the list. */
5039 maybe_common_vars = TRUE;
5041 lop = lop->op_sibling;
5044 else if ((left->op_private & OPpLVAL_INTRO)
5045 && ( left->op_type == OP_PADSV
5046 || left->op_type == OP_PADAV
5047 || left->op_type == OP_PADHV
5048 || left->op_type == OP_PADANY))
5050 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5051 if (left->op_private & OPpPAD_STATE) {
5052 /* All single variable list context state assignments, hence
5062 yyerror(no_list_state);
5066 /* PL_generation sorcery:
5067 * an assignment like ($a,$b) = ($c,$d) is easier than
5068 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5069 * To detect whether there are common vars, the global var
5070 * PL_generation is incremented for each assign op we compile.
5071 * Then, while compiling the assign op, we run through all the
5072 * variables on both sides of the assignment, setting a spare slot
5073 * in each of them to PL_generation. If any of them already have
5074 * that value, we know we've got commonality. We could use a
5075 * single bit marker, but then we'd have to make 2 passes, first
5076 * to clear the flag, then to test and set it. To find somewhere
5077 * to store these values, evil chicanery is done with SvUVX().
5080 if (maybe_common_vars) {
5082 if (aassign_common_vars(o))
5083 o->op_private |= OPpASSIGN_COMMON;
5087 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5088 OP* tmpop = ((LISTOP*)right)->op_first;
5089 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5090 PMOP * const pm = (PMOP*)tmpop;
5091 if (left->op_type == OP_RV2AV &&
5092 !(left->op_private & OPpLVAL_INTRO) &&
5093 !(o->op_private & OPpASSIGN_COMMON) )
5095 tmpop = ((UNOP*)left)->op_first;
5096 if (tmpop->op_type == OP_GV
5098 && !pm->op_pmreplrootu.op_pmtargetoff
5100 && !pm->op_pmreplrootu.op_pmtargetgv
5104 pm->op_pmreplrootu.op_pmtargetoff
5105 = cPADOPx(tmpop)->op_padix;
5106 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5108 pm->op_pmreplrootu.op_pmtargetgv
5109 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5110 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5112 pm->op_pmflags |= PMf_ONCE;
5113 tmpop = cUNOPo->op_first; /* to list (nulled) */
5114 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5115 tmpop->op_sibling = NULL; /* don't free split */
5116 right->op_next = tmpop->op_next; /* fix starting loc */
5117 op_free(o); /* blow off assign */
5118 right->op_flags &= ~OPf_WANT;
5119 /* "I don't know and I don't care." */
5124 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5125 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5127 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5128 if (SvIOK(sv) && SvIVX(sv) == 0)
5129 sv_setiv(sv, PL_modcount+1);
5137 right = newOP(OP_UNDEF, 0);
5138 if (right->op_type == OP_READLINE) {
5139 right->op_flags |= OPf_STACKED;
5140 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5144 o = newBINOP(OP_SASSIGN, flags,
5145 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5151 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5153 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5154 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5155 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5156 If I<label> is non-null, it supplies the name of a label to attach to
5157 the state op; this function takes ownership of the memory pointed at by
5158 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5161 If I<o> is null, the state op is returned. Otherwise the state op is
5162 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5163 is consumed by this function and becomes part of the returned op tree.
5169 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5172 const U32 seq = intro_my();
5175 NewOp(1101, cop, 1, COP);
5176 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5177 cop->op_type = OP_DBSTATE;
5178 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5181 cop->op_type = OP_NEXTSTATE;
5182 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5184 cop->op_flags = (U8)flags;
5185 CopHINTS_set(cop, PL_hints);
5187 cop->op_private |= NATIVE_HINTS;
5189 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5190 cop->op_next = (OP*)cop;
5193 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5194 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5196 Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
5198 PL_hints |= HINT_BLOCK_SCOPE;
5199 /* It seems that we need to defer freeing this pointer, as other parts
5200 of the grammar end up wanting to copy it after this op has been
5205 if (PL_parser && PL_parser->copline == NOLINE)
5206 CopLINE_set(cop, CopLINE(PL_curcop));
5208 CopLINE_set(cop, PL_parser->copline);
5210 PL_parser->copline = NOLINE;
5213 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5215 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5217 CopSTASH_set(cop, PL_curstash);
5219 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5220 /* this line can have a breakpoint - store the cop in IV */
5221 AV *av = CopFILEAVx(PL_curcop);
5223 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5224 if (svp && *svp != &PL_sv_undef ) {
5225 (void)SvIOK_on(*svp);
5226 SvIV_set(*svp, PTR2IV(cop));
5231 if (flags & OPf_SPECIAL)
5233 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5237 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5239 Constructs, checks, and returns a logical (flow control) op. I<type>
5240 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5241 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5242 the eight bits of C<op_private>, except that the bit with value 1 is
5243 automatically set. I<first> supplies the expression controlling the
5244 flow, and I<other> supplies the side (alternate) chain of ops; they are
5245 consumed by this function and become part of the constructed op tree.
5251 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5255 PERL_ARGS_ASSERT_NEWLOGOP;
5257 return new_logop(type, flags, &first, &other);
5261 S_search_const(pTHX_ OP *o)
5263 PERL_ARGS_ASSERT_SEARCH_CONST;
5265 switch (o->op_type) {
5269 if (o->op_flags & OPf_KIDS)
5270 return search_const(cUNOPo->op_first);
5277 if (!(o->op_flags & OPf_KIDS))
5279 kid = cLISTOPo->op_first;
5281 switch (kid->op_type) {
5285 kid = kid->op_sibling;
5288 if (kid != cLISTOPo->op_last)
5294 kid = cLISTOPo->op_last;
5296 return search_const(kid);
5304 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5312 int prepend_not = 0;
5314 PERL_ARGS_ASSERT_NEW_LOGOP;
5319 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5320 return newBINOP(type, flags, scalar(first), scalar(other));
5322 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5324 scalarboolean(first);
5325 /* optimize AND and OR ops that have NOTs as children */
5326 if (first->op_type == OP_NOT
5327 && (first->op_flags & OPf_KIDS)
5328 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5329 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5331 if (type == OP_AND || type == OP_OR) {
5337 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5339 prepend_not = 1; /* prepend a NOT op later */
5343 /* search for a constant op that could let us fold the test */
5344 if ((cstop = search_const(first))) {
5345 if (cstop->op_private & OPpCONST_STRICT)
5346 no_bareword_allowed(cstop);
5347 else if ((cstop->op_private & OPpCONST_BARE))
5348 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5349 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5350 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5351 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5353 if (other->op_type == OP_CONST)
5354 other->op_private |= OPpCONST_SHORTCIRCUIT;
5356 OP *newop = newUNOP(OP_NULL, 0, other);
5357 op_getmad(first, newop, '1');
5358 newop->op_targ = type; /* set "was" field */
5362 if (other->op_type == OP_LEAVE)
5363 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5364 else if (other->op_type == OP_MATCH
5365 || other->op_type == OP_SUBST
5366 || other->op_type == OP_TRANSR
5367 || other->op_type == OP_TRANS)
5368 /* Mark the op as being unbindable with =~ */
5369 other->op_flags |= OPf_SPECIAL;
5373 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5374 const OP *o2 = other;
5375 if ( ! (o2->op_type == OP_LIST
5376 && (( o2 = cUNOPx(o2)->op_first))
5377 && o2->op_type == OP_PUSHMARK
5378 && (( o2 = o2->op_sibling)) )
5381 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5382 || o2->op_type == OP_PADHV)
5383 && o2->op_private & OPpLVAL_INTRO
5384 && !(o2->op_private & OPpPAD_STATE))
5386 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5387 "Deprecated use of my() in false conditional");
5391 if (first->op_type == OP_CONST)
5392 first->op_private |= OPpCONST_SHORTCIRCUIT;
5394 first = newUNOP(OP_NULL, 0, first);
5395 op_getmad(other, first, '2');
5396 first->op_targ = type; /* set "was" field */
5403 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5404 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5406 const OP * const k1 = ((UNOP*)first)->op_first;
5407 const OP * const k2 = k1->op_sibling;
5409 switch (first->op_type)
5412 if (k2 && k2->op_type == OP_READLINE
5413 && (k2->op_flags & OPf_STACKED)
5414 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5416 warnop = k2->op_type;
5421 if (k1->op_type == OP_READDIR
5422 || k1->op_type == OP_GLOB
5423 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5424 || k1->op_type == OP_EACH
5425 || k1->op_type == OP_AEACH)
5427 warnop = ((k1->op_type == OP_NULL)
5428 ? (OPCODE)k1->op_targ : k1->op_type);
5433 const line_t oldline = CopLINE(PL_curcop);
5434 CopLINE_set(PL_curcop, PL_parser->copline);
5435 Perl_warner(aTHX_ packWARN(WARN_MISC),
5436 "Value of %s%s can be \"0\"; test with defined()",
5438 ((warnop == OP_READLINE || warnop == OP_GLOB)
5439 ? " construct" : "() operator"));
5440 CopLINE_set(PL_curcop, oldline);
5447 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5448 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5450 NewOp(1101, logop, 1, LOGOP);
5452 logop->op_type = (OPCODE)type;
5453 logop->op_ppaddr = PL_ppaddr[type];
5454 logop->op_first = first;
5455 logop->op_flags = (U8)(flags | OPf_KIDS);
5456 logop->op_other = LINKLIST(other);
5457 logop->op_private = (U8)(1 | (flags >> 8));
5459 /* establish postfix order */
5460 logop->op_next = LINKLIST(first);
5461 first->op_next = (OP*)logop;
5462 first->op_sibling = other;
5464 CHECKOP(type,logop);
5466 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5473 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5475 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5476 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5477 will be set automatically, and, shifted up eight bits, the eight bits of
5478 C<op_private>, except that the bit with value 1 is automatically set.
5479 I<first> supplies the expression selecting between the two branches,
5480 and I<trueop> and I<falseop> supply the branches; they are consumed by
5481 this function and become part of the constructed op tree.
5487 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5495 PERL_ARGS_ASSERT_NEWCONDOP;
5498 return newLOGOP(OP_AND, 0, first, trueop);
5500 return newLOGOP(OP_OR, 0, first, falseop);
5502 scalarboolean(first);
5503 if ((cstop = search_const(first))) {
5504 /* Left or right arm of the conditional? */
5505 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5506 OP *live = left ? trueop : falseop;
5507 OP *const dead = left ? falseop : trueop;
5508 if (cstop->op_private & OPpCONST_BARE &&
5509 cstop->op_private & OPpCONST_STRICT) {
5510 no_bareword_allowed(cstop);
5513 /* This is all dead code when PERL_MAD is not defined. */
5514 live = newUNOP(OP_NULL, 0, live);
5515 op_getmad(first, live, 'C');
5516 op_getmad(dead, live, left ? 'e' : 't');
5521 if (live->op_type == OP_LEAVE)
5522 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5523 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5524 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5525 /* Mark the op as being unbindable with =~ */
5526 live->op_flags |= OPf_SPECIAL;
5529 NewOp(1101, logop, 1, LOGOP);
5530 logop->op_type = OP_COND_EXPR;
5531 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5532 logop->op_first = first;
5533 logop->op_flags = (U8)(flags | OPf_KIDS);
5534 logop->op_private = (U8)(1 | (flags >> 8));
5535 logop->op_other = LINKLIST(trueop);
5536 logop->op_next = LINKLIST(falseop);
5538 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5541 /* establish postfix order */
5542 start = LINKLIST(first);
5543 first->op_next = (OP*)logop;
5545 first->op_sibling = trueop;
5546 trueop->op_sibling = falseop;
5547 o = newUNOP(OP_NULL, 0, (OP*)logop);
5549 trueop->op_next = falseop->op_next = o;
5556 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5558 Constructs and returns a C<range> op, with subordinate C<flip> and
5559 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5560 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5561 for both the C<flip> and C<range> ops, except that the bit with value
5562 1 is automatically set. I<left> and I<right> supply the expressions
5563 controlling the endpoints of the range; they are consumed by this function
5564 and become part of the constructed op tree.
5570 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5579 PERL_ARGS_ASSERT_NEWRANGE;
5581 NewOp(1101, range, 1, LOGOP);
5583 range->op_type = OP_RANGE;
5584 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5585 range->op_first = left;
5586 range->op_flags = OPf_KIDS;
5587 leftstart = LINKLIST(left);
5588 range->op_other = LINKLIST(right);
5589 range->op_private = (U8)(1 | (flags >> 8));
5591 left->op_sibling = right;
5593 range->op_next = (OP*)range;
5594 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5595 flop = newUNOP(OP_FLOP, 0, flip);
5596 o = newUNOP(OP_NULL, 0, flop);
5598 range->op_next = leftstart;
5600 left->op_next = flip;
5601 right->op_next = flop;
5603 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5604 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5605 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5606 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5608 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5609 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5611 /* check barewords before they might be optimized aways */
5612 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5613 no_bareword_allowed(left);
5614 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5615 no_bareword_allowed(right);
5618 if (!flip->op_private || !flop->op_private)
5619 LINKLIST(o); /* blow off optimizer unless constant */
5625 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5627 Constructs, checks, and returns an op tree expressing a loop. This is
5628 only a loop in the control flow through the op tree; it does not have
5629 the heavyweight loop structure that allows exiting the loop by C<last>
5630 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5631 top-level op, except that some bits will be set automatically as required.
5632 I<expr> supplies the expression controlling loop iteration, and I<block>
5633 supplies the body of the loop; they are consumed by this function and
5634 become part of the constructed op tree. I<debuggable> is currently
5635 unused and should always be 1.
5641 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5646 const bool once = block && block->op_flags & OPf_SPECIAL &&
5647 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5649 PERL_UNUSED_ARG(debuggable);
5652 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5653 return block; /* do {} while 0 does once */
5654 if (expr->op_type == OP_READLINE
5655 || expr->op_type == OP_READDIR
5656 || expr->op_type == OP_GLOB
5657 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5658 expr = newUNOP(OP_DEFINED, 0,
5659 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5660 } else if (expr->op_flags & OPf_KIDS) {
5661 const OP * const k1 = ((UNOP*)expr)->op_first;
5662 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5663 switch (expr->op_type) {
5665 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5666 && (k2->op_flags & OPf_STACKED)
5667 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5668 expr = newUNOP(OP_DEFINED, 0, expr);
5672 if (k1 && (k1->op_type == OP_READDIR
5673 || k1->op_type == OP_GLOB
5674 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5675 || k1->op_type == OP_EACH
5676 || k1->op_type == OP_AEACH))
5677 expr = newUNOP(OP_DEFINED, 0, expr);
5683 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5684 * op, in listop. This is wrong. [perl #27024] */
5686 block = newOP(OP_NULL, 0);
5687 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5688 o = new_logop(OP_AND, 0, &expr, &listop);
5691 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5693 if (once && o != listop)
5694 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5697 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5699 o->op_flags |= flags;
5701 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5706 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5708 Constructs, checks, and returns an op tree expressing a C<while> loop.
5709 This is a heavyweight loop, with structure that allows exiting the loop
5710 by C<last> and suchlike.
5712 I<loop> is an optional preconstructed C<enterloop> op to use in the
5713 loop; if it is null then a suitable op will be constructed automatically.
5714 I<expr> supplies the loop's controlling expression. I<block> supplies the
5715 main body of the loop, and I<cont> optionally supplies a C<continue> block
5716 that operates as a second half of the body. All of these optree inputs
5717 are consumed by this function and become part of the constructed op tree.
5719 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5720 op and, shifted up eight bits, the eight bits of C<op_private> for
5721 the C<leaveloop> op, except that (in both cases) some bits will be set
5722 automatically. I<debuggable> is currently unused and should always be 1.
5723 I<has_my> can be supplied as true to force the
5724 loop body to be enclosed in its own scope.
5730 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5731 OP *expr, OP *block, OP *cont, I32 has_my)
5740 PERL_UNUSED_ARG(debuggable);
5743 if (expr->op_type == OP_READLINE
5744 || expr->op_type == OP_READDIR
5745 || expr->op_type == OP_GLOB
5746 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5747 expr = newUNOP(OP_DEFINED, 0,
5748 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5749 } else if (expr->op_flags & OPf_KIDS) {
5750 const OP * const k1 = ((UNOP*)expr)->op_first;
5751 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5752 switch (expr->op_type) {
5754 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5755 && (k2->op_flags & OPf_STACKED)
5756 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5757 expr = newUNOP(OP_DEFINED, 0, expr);
5761 if (k1 && (k1->op_type == OP_READDIR
5762 || k1->op_type == OP_GLOB
5763 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5764 || k1->op_type == OP_EACH
5765 || k1->op_type == OP_AEACH))
5766 expr = newUNOP(OP_DEFINED, 0, expr);
5773 block = newOP(OP_NULL, 0);
5774 else if (cont || has_my) {
5775 block = op_scope(block);
5779 next = LINKLIST(cont);
5782 OP * const unstack = newOP(OP_UNSTACK, 0);
5785 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5789 listop = op_append_list(OP_LINESEQ, block, cont);
5791 redo = LINKLIST(listop);
5795 o = new_logop(OP_AND, 0, &expr, &listop);
5796 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5797 op_free(expr); /* oops, it's a while (0) */
5799 return NULL; /* listop already freed by new_logop */
5802 ((LISTOP*)listop)->op_last->op_next =
5803 (o == listop ? redo : LINKLIST(o));
5809 NewOp(1101,loop,1,LOOP);
5810 loop->op_type = OP_ENTERLOOP;
5811 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5812 loop->op_private = 0;
5813 loop->op_next = (OP*)loop;
5816 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5818 loop->op_redoop = redo;
5819 loop->op_lastop = o;
5820 o->op_private |= loopflags;
5823 loop->op_nextop = next;
5825 loop->op_nextop = o;
5827 o->op_flags |= flags;
5828 o->op_private |= (flags >> 8);
5833 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5835 Constructs, checks, and returns an op tree expressing a C<foreach>
5836 loop (iteration through a list of values). This is a heavyweight loop,
5837 with structure that allows exiting the loop by C<last> and suchlike.
5839 I<sv> optionally supplies the variable that will be aliased to each
5840 item in turn; if null, it defaults to C<$_> (either lexical or global).
5841 I<expr> supplies the list of values to iterate over. I<block> supplies
5842 the main body of the loop, and I<cont> optionally supplies a C<continue>
5843 block that operates as a second half of the body. All of these optree
5844 inputs are consumed by this function and become part of the constructed
5847 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5848 op and, shifted up eight bits, the eight bits of C<op_private> for
5849 the C<leaveloop> op, except that (in both cases) some bits will be set
5856 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5861 PADOFFSET padoff = 0;
5866 PERL_ARGS_ASSERT_NEWFOROP;
5869 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5870 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5871 sv->op_type = OP_RV2GV;
5872 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5874 /* The op_type check is needed to prevent a possible segfault
5875 * if the loop variable is undeclared and 'strict vars' is in
5876 * effect. This is illegal but is nonetheless parsed, so we
5877 * may reach this point with an OP_CONST where we're expecting
5880 if (cUNOPx(sv)->op_first->op_type == OP_GV
5881 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5882 iterpflags |= OPpITER_DEF;
5884 else if (sv->op_type == OP_PADSV) { /* private variable */
5885 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5886 padoff = sv->op_targ;
5896 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5898 SV *const namesv = PAD_COMPNAME_SV(padoff);
5900 const char *const name = SvPV_const(namesv, len);
5902 if (len == 2 && name[0] == '$' && name[1] == '_')
5903 iterpflags |= OPpITER_DEF;
5907 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5908 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5909 sv = newGVOP(OP_GV, 0, PL_defgv);
5914 iterpflags |= OPpITER_DEF;
5916 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5917 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5918 iterflags |= OPf_STACKED;
5920 else if (expr->op_type == OP_NULL &&
5921 (expr->op_flags & OPf_KIDS) &&
5922 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5924 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5925 * set the STACKED flag to indicate that these values are to be
5926 * treated as min/max values by 'pp_iterinit'.
5928 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5929 LOGOP* const range = (LOGOP*) flip->op_first;
5930 OP* const left = range->op_first;
5931 OP* const right = left->op_sibling;
5934 range->op_flags &= ~OPf_KIDS;
5935 range->op_first = NULL;
5937 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5938 listop->op_first->op_next = range->op_next;
5939 left->op_next = range->op_other;
5940 right->op_next = (OP*)listop;
5941 listop->op_next = listop->op_first;
5944 op_getmad(expr,(OP*)listop,'O');
5948 expr = (OP*)(listop);
5950 iterflags |= OPf_STACKED;
5953 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5956 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5957 op_append_elem(OP_LIST, expr, scalar(sv))));
5958 assert(!loop->op_next);
5959 /* for my $x () sets OPpLVAL_INTRO;
5960 * for our $x () sets OPpOUR_INTRO */
5961 loop->op_private = (U8)iterpflags;
5962 #ifdef PL_OP_SLAB_ALLOC
5965 NewOp(1234,tmp,1,LOOP);
5966 Copy(loop,tmp,1,LISTOP);
5967 S_op_destroy(aTHX_ (OP*)loop);
5971 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5973 loop->op_targ = padoff;
5974 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5976 op_getmad(madsv, (OP*)loop, 'v');
5981 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5983 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5984 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5985 determining the target of the op; it is consumed by this function and
5986 become part of the constructed op tree.
5992 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5997 PERL_ARGS_ASSERT_NEWLOOPEX;
5999 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6001 if (type != OP_GOTO || label->op_type == OP_CONST) {
6002 /* "last()" means "last" */
6003 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6004 o = newOP(type, OPf_SPECIAL);
6006 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
6007 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6011 op_getmad(label,o,'L');
6017 /* Check whether it's going to be a goto &function */
6018 if (label->op_type == OP_ENTERSUB
6019 && !(label->op_flags & OPf_STACKED))
6020 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6021 o = newUNOP(type, OPf_STACKED, label);
6023 PL_hints |= HINT_BLOCK_SCOPE;
6027 /* if the condition is a literal array or hash
6028 (or @{ ... } etc), make a reference to it.
6031 S_ref_array_or_hash(pTHX_ OP *cond)
6034 && (cond->op_type == OP_RV2AV
6035 || cond->op_type == OP_PADAV
6036 || cond->op_type == OP_RV2HV
6037 || cond->op_type == OP_PADHV))
6039 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6042 && (cond->op_type == OP_ASLICE
6043 || cond->op_type == OP_HSLICE)) {
6045 /* anonlist now needs a list from this op, was previously used in
6047 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6048 cond->op_flags |= OPf_WANT_LIST;
6050 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6057 /* These construct the optree fragments representing given()
6060 entergiven and enterwhen are LOGOPs; the op_other pointer
6061 points up to the associated leave op. We need this so we
6062 can put it in the context and make break/continue work.
6063 (Also, of course, pp_enterwhen will jump straight to
6064 op_other if the match fails.)
6068 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6069 I32 enter_opcode, I32 leave_opcode,
6070 PADOFFSET entertarg)
6076 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6078 NewOp(1101, enterop, 1, LOGOP);
6079 enterop->op_type = (Optype)enter_opcode;
6080 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6081 enterop->op_flags = (U8) OPf_KIDS;
6082 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6083 enterop->op_private = 0;
6085 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6088 enterop->op_first = scalar(cond);
6089 cond->op_sibling = block;
6091 o->op_next = LINKLIST(cond);
6092 cond->op_next = (OP *) enterop;
6095 /* This is a default {} block */
6096 enterop->op_first = block;
6097 enterop->op_flags |= OPf_SPECIAL;
6099 o->op_next = (OP *) enterop;
6102 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6103 entergiven and enterwhen both
6106 enterop->op_next = LINKLIST(block);
6107 block->op_next = enterop->op_other = o;
6112 /* Does this look like a boolean operation? For these purposes
6113 a boolean operation is:
6114 - a subroutine call [*]
6115 - a logical connective
6116 - a comparison operator
6117 - a filetest operator, with the exception of -s -M -A -C
6118 - defined(), exists() or eof()
6119 - /$re/ or $foo =~ /$re/
6121 [*] possibly surprising
6124 S_looks_like_bool(pTHX_ const OP *o)
6128 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6130 switch(o->op_type) {
6133 return looks_like_bool(cLOGOPo->op_first);
6137 looks_like_bool(cLOGOPo->op_first)
6138 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6143 o->op_flags & OPf_KIDS
6144 && looks_like_bool(cUNOPo->op_first));
6148 case OP_NOT: case OP_XOR:
6150 case OP_EQ: case OP_NE: case OP_LT:
6151 case OP_GT: case OP_LE: case OP_GE:
6153 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6154 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6156 case OP_SEQ: case OP_SNE: case OP_SLT:
6157 case OP_SGT: case OP_SLE: case OP_SGE:
6161 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6162 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6163 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6164 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6165 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6166 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6167 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6168 case OP_FTTEXT: case OP_FTBINARY:
6170 case OP_DEFINED: case OP_EXISTS:
6171 case OP_MATCH: case OP_EOF:
6178 /* Detect comparisons that have been optimized away */
6179 if (cSVOPo->op_sv == &PL_sv_yes
6180 || cSVOPo->op_sv == &PL_sv_no)
6193 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6195 Constructs, checks, and returns an op tree expressing a C<given> block.
6196 I<cond> supplies the expression that will be locally assigned to a lexical
6197 variable, and I<block> supplies the body of the C<given> construct; they
6198 are consumed by this function and become part of the constructed op tree.
6199 I<defsv_off> is the pad offset of the scalar lexical variable that will
6206 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6209 PERL_ARGS_ASSERT_NEWGIVENOP;
6210 return newGIVWHENOP(
6211 ref_array_or_hash(cond),
6213 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6218 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6220 Constructs, checks, and returns an op tree expressing a C<when> block.
6221 I<cond> supplies the test expression, and I<block> supplies the block
6222 that will be executed if the test evaluates to true; they are consumed
6223 by this function and become part of the constructed op tree. I<cond>
6224 will be interpreted DWIMically, often as a comparison against C<$_>,
6225 and may be null to generate a C<default> block.
6231 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6233 const bool cond_llb = (!cond || looks_like_bool(cond));
6236 PERL_ARGS_ASSERT_NEWWHENOP;
6241 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6243 scalar(ref_array_or_hash(cond)));
6246 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6250 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6251 const STRLEN len, const U32 flags)
6253 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6254 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
6255 || (p && !sv_eq((SV*)cv, newSVpvn_flags(p, len, flags | SVs_TEMP))))
6256 && ckWARN_d(WARN_PROTOTYPE)) {
6257 SV* const msg = sv_newmortal();
6261 gv_efullname3(name = sv_newmortal(), gv, NULL);
6262 sv_setpvs(msg, "Prototype mismatch:");
6264 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6266 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
6268 sv_catpvs(msg, ": none");
6269 sv_catpvs(msg, " vs ");
6271 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6273 sv_catpvs(msg, "none");
6274 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6278 static void const_sv_xsub(pTHX_ CV* cv);
6282 =head1 Optree Manipulation Functions
6284 =for apidoc cv_const_sv
6286 If C<cv> is a constant sub eligible for inlining. returns the constant
6287 value returned by the sub. Otherwise, returns NULL.
6289 Constant subs can be created with C<newCONSTSUB> or as described in
6290 L<perlsub/"Constant Functions">.
6295 Perl_cv_const_sv(pTHX_ const CV *const cv)
6297 PERL_UNUSED_CONTEXT;
6300 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6302 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6305 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6306 * Can be called in 3 ways:
6309 * look for a single OP_CONST with attached value: return the value
6311 * cv && CvCLONE(cv) && !CvCONST(cv)
6313 * examine the clone prototype, and if contains only a single
6314 * OP_CONST referencing a pad const, or a single PADSV referencing
6315 * an outer lexical, return a non-zero value to indicate the CV is
6316 * a candidate for "constizing" at clone time
6320 * We have just cloned an anon prototype that was marked as a const
6321 * candidate. Try to grab the current value, and in the case of
6322 * PADSV, ignore it if it has multiple references. Return the value.
6326 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6337 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6338 o = cLISTOPo->op_first->op_sibling;
6340 for (; o; o = o->op_next) {
6341 const OPCODE type = o->op_type;
6343 if (sv && o->op_next == o)
6345 if (o->op_next != o) {
6346 if (type == OP_NEXTSTATE
6347 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6348 || type == OP_PUSHMARK)
6350 if (type == OP_DBSTATE)
6353 if (type == OP_LEAVESUB || type == OP_RETURN)
6357 if (type == OP_CONST && cSVOPo->op_sv)
6359 else if (cv && type == OP_CONST) {
6360 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6364 else if (cv && type == OP_PADSV) {
6365 if (CvCONST(cv)) { /* newly cloned anon */
6366 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6367 /* the candidate should have 1 ref from this pad and 1 ref
6368 * from the parent */
6369 if (!sv || SvREFCNT(sv) != 2)
6376 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6377 sv = &PL_sv_undef; /* an arbitrary non-null value */
6392 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6395 /* This would be the return value, but the return cannot be reached. */
6396 OP* pegop = newOP(OP_NULL, 0);
6399 PERL_UNUSED_ARG(floor);
6409 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6411 NORETURN_FUNCTION_END;
6416 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6421 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6423 register CV *cv = NULL;
6425 /* If the subroutine has no body, no attributes, and no builtin attributes
6426 then it's just a sub declaration, and we may be able to get away with
6427 storing with a placeholder scalar in the symbol table, rather than a
6428 full GV and CV. If anything is present then it will take a full CV to
6430 const I32 gv_fetch_flags
6431 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6433 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6434 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6436 bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
6439 assert(proto->op_type == OP_CONST);
6440 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6441 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6447 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6449 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6450 SV * const sv = sv_newmortal();
6451 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6452 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6453 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6454 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6456 } else if (PL_curstash) {
6457 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6460 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6464 if (!PL_madskills) {
6473 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6474 maximum a prototype before. */
6475 if (SvTYPE(gv) > SVt_NULL) {
6476 if (!SvPOK((const SV *)gv)
6477 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6479 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6481 cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
6484 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6485 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
6488 sv_setiv(MUTABLE_SV(gv), -1);
6490 SvREFCNT_dec(PL_compcv);
6491 cv = PL_compcv = NULL;
6495 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6497 if (!block || !ps || *ps || attrs
6498 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6500 || block->op_type == OP_NULL
6505 const_sv = op_const_sv(block, NULL);
6508 const bool exists = CvROOT(cv) || CvXSUB(cv);
6510 /* if the subroutine doesn't exist and wasn't pre-declared
6511 * with a prototype, assume it will be AUTOLOADed,
6512 * skipping the prototype check
6514 if (exists || SvPOK(cv))
6515 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
6516 /* already defined (or promised)? */
6517 if (exists || GvASSUMECV(gv)) {
6520 || block->op_type == OP_NULL
6523 if (CvFLAGS(PL_compcv)) {
6524 /* might have had built-in attrs applied */
6525 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6526 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6527 && ckWARN(WARN_MISC))
6528 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6530 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6531 & ~(CVf_LVALUE * pureperl));
6533 if (attrs) goto attrs;
6534 /* just a "sub foo;" when &foo is already defined */
6535 SAVEFREESV(PL_compcv);
6540 && block->op_type != OP_NULL
6543 if (ckWARN(WARN_REDEFINE)
6545 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6547 const line_t oldline = CopLINE(PL_curcop);
6548 if (PL_parser && PL_parser->copline != NOLINE)
6549 CopLINE_set(PL_curcop, PL_parser->copline);
6550 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6551 CvCONST(cv) ? "Constant subroutine %"SVf" redefined"
6552 : "Subroutine %"SVf" redefined",
6553 SVfARG(cSVOPo->op_sv));
6554 CopLINE_set(PL_curcop, oldline);
6557 if (!PL_minus_c) /* keep old one around for madskills */
6560 /* (PL_madskills unset in used file.) */
6568 SvREFCNT_inc_simple_void_NN(const_sv);
6570 assert(!CvROOT(cv) && !CvCONST(cv));
6571 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6572 CvXSUBANY(cv).any_ptr = const_sv;
6573 CvXSUB(cv) = const_sv_xsub;
6579 cv = newCONSTSUB_flags(NULL, name, name_is_utf8 ? SVf_UTF8 : 0, const_sv);
6581 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6582 (CvGV(cv) && GvSTASH(CvGV(cv)))
6591 SvREFCNT_dec(PL_compcv);
6595 if (cv) { /* must reuse cv if autoloaded */
6596 /* transfer PL_compcv to cv */
6599 && block->op_type != OP_NULL
6602 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6603 AV *const temp_av = CvPADLIST(cv);
6604 CV *const temp_cv = CvOUTSIDE(cv);
6606 assert(!CvWEAKOUTSIDE(cv));
6607 assert(!CvCVGV_RC(cv));
6608 assert(CvGV(cv) == gv);
6611 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6612 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6613 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6614 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6615 CvOUTSIDE(PL_compcv) = temp_cv;
6616 CvPADLIST(PL_compcv) = temp_av;
6618 if (CvFILE(cv) && CvDYNFILE(cv)) {
6619 Safefree(CvFILE(cv));
6621 CvFILE_set_from_cop(cv, PL_curcop);
6622 CvSTASH_set(cv, PL_curstash);
6624 /* inner references to PL_compcv must be fixed up ... */
6625 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6626 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6627 ++PL_sub_generation;
6630 /* Might have had built-in attributes applied -- propagate them. */
6631 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6633 /* ... before we throw it away */
6634 SvREFCNT_dec(PL_compcv);
6642 if (strEQ(name, "import")) {
6643 PL_formfeed = MUTABLE_SV(cv);
6644 /* diag_listed_as: SKIPME */
6645 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6649 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6654 CvFILE_set_from_cop(cv, PL_curcop);
6655 CvSTASH_set(cv, PL_curstash);
6659 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6660 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6661 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6665 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6666 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
6669 if (PL_parser && PL_parser->error_count) {
6673 const char *s = strrchr(name, ':');
6675 if (strEQ(s, "BEGIN")) {
6676 const char not_safe[] =
6677 "BEGIN not safe after errors--compilation aborted";
6678 if (PL_in_eval & EVAL_KEEPERR)
6679 Perl_croak(aTHX_ not_safe);
6681 /* force display of errors found but not reported */
6682 sv_catpv(ERRSV, not_safe);
6683 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6692 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6693 the debugger could be able to set a breakpoint in, so signal to
6694 pp_entereval that it should not throw away any saved lines at scope
6697 PL_breakable_sub_gen++;
6698 /* This makes sub {}; work as expected. */
6699 if (block->op_type == OP_STUB) {
6700 OP* const newblock = newSTATEOP(0, NULL, 0);
6702 op_getmad(block,newblock,'B');
6708 else block->op_attached = 1;
6709 CvROOT(cv) = CvLVALUE(cv)
6710 ? newUNOP(OP_LEAVESUBLV, 0,
6711 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6712 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6713 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6714 OpREFCNT_set(CvROOT(cv), 1);
6715 CvSTART(cv) = LINKLIST(CvROOT(cv));
6716 CvROOT(cv)->op_next = 0;
6717 CALL_PEEP(CvSTART(cv));
6718 finalize_optree(CvROOT(cv));
6720 /* now that optimizer has done its work, adjust pad values */
6722 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6725 assert(!CvCONST(cv));
6726 if (ps && !*ps && op_const_sv(block, cv))
6731 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6732 SV * const tmpstr = sv_newmortal();
6733 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6734 GV_ADDMULTI, SVt_PVHV);
6736 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6739 (long)CopLINE(PL_curcop));
6740 gv_efullname3(tmpstr, gv, NULL);
6741 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6742 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
6743 hv = GvHVn(db_postponed);
6744 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
6745 CV * const pcv = GvCV(db_postponed);
6751 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6756 if (name && ! (PL_parser && PL_parser->error_count))
6757 process_special_blocks(name, gv, cv);
6762 PL_parser->copline = NOLINE;
6768 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6771 const char *const colon = strrchr(fullname,':');
6772 const char *const name = colon ? colon + 1 : fullname;
6774 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6777 if (strEQ(name, "BEGIN")) {
6778 const I32 oldscope = PL_scopestack_ix;
6780 SAVECOPFILE(&PL_compiling);
6781 SAVECOPLINE(&PL_compiling);
6783 DEBUG_x( dump_sub(gv) );
6784 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6785 GvCV_set(gv,0); /* cv has been hijacked */
6786 call_list(oldscope, PL_beginav);
6788 PL_curcop = &PL_compiling;
6789 CopHINTS_set(&PL_compiling, PL_hints);
6796 if strEQ(name, "END") {
6797 DEBUG_x( dump_sub(gv) );
6798 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6801 } else if (*name == 'U') {
6802 if (strEQ(name, "UNITCHECK")) {
6803 /* It's never too late to run a unitcheck block */
6804 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6808 } else if (*name == 'C') {
6809 if (strEQ(name, "CHECK")) {
6811 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6812 "Too late to run CHECK block");
6813 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6817 } else if (*name == 'I') {
6818 if (strEQ(name, "INIT")) {
6820 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6821 "Too late to run INIT block");
6822 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6828 DEBUG_x( dump_sub(gv) );
6829 GvCV_set(gv,0); /* cv has been hijacked */
6834 =for apidoc newCONSTSUB
6836 See L</newCONSTSUB_flags>.
6842 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6844 return newCONSTSUB_flags(stash, name, 0, sv);
6848 =for apidoc newCONSTSUB_flags
6850 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6851 eligible for inlining at compile-time.
6853 Currently, the only useful value for C<flags> is SVf_UTF8.
6855 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6856 which won't be called if used as a destructor, but will suppress the overhead
6857 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6864 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, U32 flags, SV *sv)
6869 const char *const file = CopFILE(PL_curcop);
6871 SV *const temp_sv = CopFILESV(PL_curcop);
6872 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6877 if (IN_PERL_RUNTIME) {
6878 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6879 * an op shared between threads. Use a non-shared COP for our
6881 SAVEVPTR(PL_curcop);
6882 PL_curcop = &PL_compiling;
6884 SAVECOPLINE(PL_curcop);
6885 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6888 PL_hints &= ~HINT_BLOCK_SCOPE;
6891 SAVESPTR(PL_curstash);
6892 SAVECOPSTASH(PL_curcop);
6893 PL_curstash = stash;
6894 CopSTASH_set(PL_curcop,stash);
6897 /* file becomes the CvFILE. For an XS, it's usually static storage,
6898 and so doesn't get free()d. (It's expected to be from the C pre-
6899 processor __FILE__ directive). But we need a dynamically allocated one,
6900 and we need it to get freed. */
6901 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6902 XS_DYNAMIC_FILENAME | flags);
6903 CvXSUBANY(cv).any_ptr = sv;
6908 CopSTASH_free(PL_curcop);
6916 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6917 const char *const filename, const char *const proto,
6922 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6925 GV * const gv = gv_fetchpv(name ? name :
6926 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6927 GV_ADDMULTI | flags, SVt_PVCV);
6930 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6932 if ((cv = (name ? GvCV(gv) : NULL))) {
6934 /* just a cached method */
6938 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6939 /* already defined (or promised) */
6940 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6941 if (ckWARN(WARN_REDEFINE)) {
6942 GV * const gvcv = CvGV(cv);
6944 HV * const stash = GvSTASH(gvcv);
6946 const char *redefined_name = HvNAME_get(stash);
6947 if ( strEQ(redefined_name,"autouse") ) {
6948 const line_t oldline = CopLINE(PL_curcop);
6949 if (PL_parser && PL_parser->copline != NOLINE)
6950 CopLINE_set(PL_curcop, PL_parser->copline);
6951 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6952 CvCONST(cv) ? "Constant subroutine %s redefined"
6953 : "Subroutine %s redefined"
6955 CopLINE_set(PL_curcop, oldline);
6965 if (cv) /* must reuse cv if autoloaded */
6968 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6972 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6978 (void)gv_fetchfile(filename);
6979 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6980 an external constant string */
6981 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
6983 CvXSUB(cv) = subaddr;
6986 process_special_blocks(name, gv, cv);
6989 if (flags & XS_DYNAMIC_FILENAME) {
6990 CvFILE(cv) = savepv(filename);
6993 sv_setpv(MUTABLE_SV(cv), proto);
6998 =for apidoc U||newXS
7000 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7001 static storage, as it is used directly as CvFILE(), without a copy being made.
7007 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7009 PERL_ARGS_ASSERT_NEWXS;
7010 return newXS_flags(name, subaddr, filename, NULL, 0);
7018 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7023 OP* pegop = newOP(OP_NULL, 0);
7027 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7028 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7031 if ((cv = GvFORM(gv))) {
7032 if (ckWARN(WARN_REDEFINE)) {
7033 const line_t oldline = CopLINE(PL_curcop);
7034 if (PL_parser && PL_parser->copline != NOLINE)
7035 CopLINE_set(PL_curcop, PL_parser->copline);
7037 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7038 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7040 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7041 "Format STDOUT redefined");
7043 CopLINE_set(PL_curcop, oldline);
7050 CvFILE_set_from_cop(cv, PL_curcop);
7053 pad_tidy(padtidy_FORMAT);
7054 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7055 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7056 OpREFCNT_set(CvROOT(cv), 1);
7057 CvSTART(cv) = LINKLIST(CvROOT(cv));
7058 CvROOT(cv)->op_next = 0;
7059 CALL_PEEP(CvSTART(cv));
7060 finalize_optree(CvROOT(cv));
7062 op_getmad(o,pegop,'n');
7063 op_getmad_weak(block, pegop, 'b');
7068 PL_parser->copline = NOLINE;
7076 Perl_newANONLIST(pTHX_ OP *o)
7078 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7082 Perl_newANONHASH(pTHX_ OP *o)
7084 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7088 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7090 return newANONATTRSUB(floor, proto, NULL, block);
7094 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7096 return newUNOP(OP_REFGEN, 0,
7097 newSVOP(OP_ANONCODE, 0,
7098 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7102 Perl_oopsAV(pTHX_ OP *o)
7106 PERL_ARGS_ASSERT_OOPSAV;
7108 switch (o->op_type) {
7110 o->op_type = OP_PADAV;
7111 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7112 return ref(o, OP_RV2AV);
7115 o->op_type = OP_RV2AV;
7116 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7121 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7128 Perl_oopsHV(pTHX_ OP *o)
7132 PERL_ARGS_ASSERT_OOPSHV;
7134 switch (o->op_type) {
7137 o->op_type = OP_PADHV;
7138 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7139 return ref(o, OP_RV2HV);
7143 o->op_type = OP_RV2HV;
7144 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7149 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7156 Perl_newAVREF(pTHX_ OP *o)
7160 PERL_ARGS_ASSERT_NEWAVREF;
7162 if (o->op_type == OP_PADANY) {
7163 o->op_type = OP_PADAV;
7164 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7167 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7168 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7169 "Using an array as a reference is deprecated");
7171 return newUNOP(OP_RV2AV, 0, scalar(o));
7175 Perl_newGVREF(pTHX_ I32 type, OP *o)
7177 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7178 return newUNOP(OP_NULL, 0, o);
7179 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7183 Perl_newHVREF(pTHX_ OP *o)
7187 PERL_ARGS_ASSERT_NEWHVREF;
7189 if (o->op_type == OP_PADANY) {
7190 o->op_type = OP_PADHV;
7191 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7194 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7195 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7196 "Using a hash as a reference is deprecated");
7198 return newUNOP(OP_RV2HV, 0, scalar(o));
7202 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7204 return newUNOP(OP_RV2CV, flags, scalar(o));
7208 Perl_newSVREF(pTHX_ OP *o)
7212 PERL_ARGS_ASSERT_NEWSVREF;
7214 if (o->op_type == OP_PADANY) {
7215 o->op_type = OP_PADSV;
7216 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7219 return newUNOP(OP_RV2SV, 0, scalar(o));
7222 /* Check routines. See the comments at the top of this file for details
7223 * on when these are called */
7226 Perl_ck_anoncode(pTHX_ OP *o)
7228 PERL_ARGS_ASSERT_CK_ANONCODE;
7230 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7232 cSVOPo->op_sv = NULL;
7237 Perl_ck_bitop(pTHX_ OP *o)
7241 PERL_ARGS_ASSERT_CK_BITOP;
7243 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7244 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7245 && (o->op_type == OP_BIT_OR
7246 || o->op_type == OP_BIT_AND
7247 || o->op_type == OP_BIT_XOR))
7249 const OP * const left = cBINOPo->op_first;
7250 const OP * const right = left->op_sibling;
7251 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7252 (left->op_flags & OPf_PARENS) == 0) ||
7253 (OP_IS_NUMCOMPARE(right->op_type) &&
7254 (right->op_flags & OPf_PARENS) == 0))
7255 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7256 "Possible precedence problem on bitwise %c operator",
7257 o->op_type == OP_BIT_OR ? '|'
7258 : o->op_type == OP_BIT_AND ? '&' : '^'
7265 Perl_ck_concat(pTHX_ OP *o)
7267 const OP * const kid = cUNOPo->op_first;
7269 PERL_ARGS_ASSERT_CK_CONCAT;
7270 PERL_UNUSED_CONTEXT;
7272 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7273 !(kUNOP->op_first->op_flags & OPf_MOD))
7274 o->op_flags |= OPf_STACKED;
7279 Perl_ck_spair(pTHX_ OP *o)
7283 PERL_ARGS_ASSERT_CK_SPAIR;
7285 if (o->op_flags & OPf_KIDS) {
7288 const OPCODE type = o->op_type;
7289 o = modkids(ck_fun(o), type);
7290 kid = cUNOPo->op_first;
7291 newop = kUNOP->op_first->op_sibling;
7293 const OPCODE type = newop->op_type;
7294 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7295 type == OP_PADAV || type == OP_PADHV ||
7296 type == OP_RV2AV || type == OP_RV2HV)
7300 op_getmad(kUNOP->op_first,newop,'K');
7302 op_free(kUNOP->op_first);
7304 kUNOP->op_first = newop;
7306 o->op_ppaddr = PL_ppaddr[++o->op_type];
7311 Perl_ck_delete(pTHX_ OP *o)
7313 PERL_ARGS_ASSERT_CK_DELETE;
7317 if (o->op_flags & OPf_KIDS) {
7318 OP * const kid = cUNOPo->op_first;
7319 switch (kid->op_type) {
7321 o->op_flags |= OPf_SPECIAL;
7324 o->op_private |= OPpSLICE;
7327 o->op_flags |= OPf_SPECIAL;
7332 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7335 if (kid->op_private & OPpLVAL_INTRO)
7336 o->op_private |= OPpLVAL_INTRO;
7343 Perl_ck_die(pTHX_ OP *o)
7345 PERL_ARGS_ASSERT_CK_DIE;
7348 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7354 Perl_ck_eof(pTHX_ OP *o)
7358 PERL_ARGS_ASSERT_CK_EOF;
7360 if (o->op_flags & OPf_KIDS) {
7361 if (cLISTOPo->op_first->op_type == OP_STUB) {
7363 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7365 op_getmad(o,newop,'O');
7377 Perl_ck_eval(pTHX_ OP *o)
7381 PERL_ARGS_ASSERT_CK_EVAL;
7383 PL_hints |= HINT_BLOCK_SCOPE;
7384 if (o->op_flags & OPf_KIDS) {
7385 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7388 o->op_flags &= ~OPf_KIDS;
7391 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7397 cUNOPo->op_first = 0;
7402 NewOp(1101, enter, 1, LOGOP);
7403 enter->op_type = OP_ENTERTRY;
7404 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7405 enter->op_private = 0;
7407 /* establish postfix order */
7408 enter->op_next = (OP*)enter;
7410 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7411 o->op_type = OP_LEAVETRY;
7412 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7413 enter->op_other = o;
7414 op_getmad(oldo,o,'O');
7428 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7429 op_getmad(oldo,o,'O');
7431 o->op_targ = (PADOFFSET)PL_hints;
7432 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7433 /* Store a copy of %^H that pp_entereval can pick up. */
7434 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7435 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7436 cUNOPo->op_first->op_sibling = hhop;
7437 o->op_private |= OPpEVAL_HAS_HH;
7443 Perl_ck_exit(pTHX_ OP *o)
7445 PERL_ARGS_ASSERT_CK_EXIT;
7448 HV * const table = GvHV(PL_hintgv);
7450 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7451 if (svp && *svp && SvTRUE(*svp))
7452 o->op_private |= OPpEXIT_VMSISH;
7454 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7460 Perl_ck_exec(pTHX_ OP *o)
7462 PERL_ARGS_ASSERT_CK_EXEC;
7464 if (o->op_flags & OPf_STACKED) {
7467 kid = cUNOPo->op_first->op_sibling;
7468 if (kid->op_type == OP_RV2GV)
7477 Perl_ck_exists(pTHX_ OP *o)
7481 PERL_ARGS_ASSERT_CK_EXISTS;
7484 if (o->op_flags & OPf_KIDS) {
7485 OP * const kid = cUNOPo->op_first;
7486 if (kid->op_type == OP_ENTERSUB) {
7487 (void) ref(kid, o->op_type);
7488 if (kid->op_type != OP_RV2CV
7489 && !(PL_parser && PL_parser->error_count))
7490 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7492 o->op_private |= OPpEXISTS_SUB;
7494 else if (kid->op_type == OP_AELEM)
7495 o->op_flags |= OPf_SPECIAL;
7496 else if (kid->op_type != OP_HELEM)
7497 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7505 Perl_ck_rvconst(pTHX_ register OP *o)
7508 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7510 PERL_ARGS_ASSERT_CK_RVCONST;
7512 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7513 if (o->op_type == OP_RV2CV)
7514 o->op_private &= ~1;
7516 if (kid->op_type == OP_CONST) {
7519 SV * const kidsv = kid->op_sv;
7521 /* Is it a constant from cv_const_sv()? */
7522 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7523 SV * const rsv = SvRV(kidsv);
7524 const svtype type = SvTYPE(rsv);
7525 const char *badtype = NULL;
7527 switch (o->op_type) {
7529 if (type > SVt_PVMG)
7530 badtype = "a SCALAR";
7533 if (type != SVt_PVAV)
7534 badtype = "an ARRAY";
7537 if (type != SVt_PVHV)
7541 if (type != SVt_PVCV)
7546 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7549 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7550 const char *badthing;
7551 switch (o->op_type) {
7553 badthing = "a SCALAR";
7556 badthing = "an ARRAY";
7559 badthing = "a HASH";
7567 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7568 SVfARG(kidsv), badthing);
7571 * This is a little tricky. We only want to add the symbol if we
7572 * didn't add it in the lexer. Otherwise we get duplicate strict
7573 * warnings. But if we didn't add it in the lexer, we must at
7574 * least pretend like we wanted to add it even if it existed before,
7575 * or we get possible typo warnings. OPpCONST_ENTERED says
7576 * whether the lexer already added THIS instance of this symbol.
7578 iscv = (o->op_type == OP_RV2CV) * 2;
7580 gv = gv_fetchsv(kidsv,
7581 iscv | !(kid->op_private & OPpCONST_ENTERED),
7584 : o->op_type == OP_RV2SV
7586 : o->op_type == OP_RV2AV
7588 : o->op_type == OP_RV2HV
7591 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7593 kid->op_type = OP_GV;
7594 SvREFCNT_dec(kid->op_sv);
7596 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7597 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7598 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7600 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7602 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7604 kid->op_private = 0;
7605 kid->op_ppaddr = PL_ppaddr[OP_GV];
7606 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7614 Perl_ck_ftst(pTHX_ OP *o)
7617 const I32 type = o->op_type;
7619 PERL_ARGS_ASSERT_CK_FTST;
7621 if (o->op_flags & OPf_REF) {
7624 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7625 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7626 const OPCODE kidtype = kid->op_type;
7628 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7629 OP * const newop = newGVOP(type, OPf_REF,
7630 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7632 op_getmad(o,newop,'O');
7638 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7639 o->op_private |= OPpFT_ACCESS;
7640 if (PL_check[kidtype] == Perl_ck_ftst
7641 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7642 o->op_private |= OPpFT_STACKED;
7643 kid->op_private |= OPpFT_STACKING;
7652 if (type == OP_FTTTY)
7653 o = newGVOP(type, OPf_REF, PL_stdingv);
7655 o = newUNOP(type, 0, newDEFSVOP());
7656 op_getmad(oldo,o,'O');
7662 Perl_ck_fun(pTHX_ OP *o)
7665 const int type = o->op_type;
7666 register I32 oa = PL_opargs[type] >> OASHIFT;
7668 PERL_ARGS_ASSERT_CK_FUN;
7670 if (o->op_flags & OPf_STACKED) {
7671 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7674 return no_fh_allowed(o);
7677 if (o->op_flags & OPf_KIDS) {
7678 OP **tokid = &cLISTOPo->op_first;
7679 register OP *kid = cLISTOPo->op_first;
7682 bool seen_optional = FALSE;
7684 if (kid->op_type == OP_PUSHMARK ||
7685 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7687 tokid = &kid->op_sibling;
7688 kid = kid->op_sibling;
7690 if (kid && kid->op_type == OP_COREARGS) {
7691 bool optional = FALSE;
7694 if (oa & OA_OPTIONAL) optional = TRUE;
7697 if (optional) o->op_private |= numargs;
7702 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
7703 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
7704 *tokid = kid = newDEFSVOP();
7705 seen_optional = TRUE;
7710 sibl = kid->op_sibling;
7712 if (!sibl && kid->op_type == OP_STUB) {
7719 /* list seen where single (scalar) arg expected? */
7720 if (numargs == 1 && !(oa >> 4)
7721 && kid->op_type == OP_LIST && type != OP_SCALAR)
7723 return too_many_arguments(o,PL_op_desc[type]);
7736 if ((type == OP_PUSH || type == OP_UNSHIFT)
7737 && !kid->op_sibling)
7738 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7739 "Useless use of %s with no values",
7742 if (kid->op_type == OP_CONST &&
7743 (kid->op_private & OPpCONST_BARE))
7745 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7746 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7747 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7748 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7749 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7751 op_getmad(kid,newop,'K');
7756 kid->op_sibling = sibl;
7759 else if (kid->op_type == OP_CONST
7760 && ( !SvROK(cSVOPx_sv(kid))
7761 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7763 bad_type(numargs, "array", PL_op_desc[type], kid);
7764 /* Defer checks to run-time if we have a scalar arg */
7765 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7766 op_lvalue(kid, type);
7770 if (kid->op_type == OP_CONST &&
7771 (kid->op_private & OPpCONST_BARE))
7773 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7774 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7775 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7776 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7777 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7779 op_getmad(kid,newop,'K');
7784 kid->op_sibling = sibl;
7787 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7788 bad_type(numargs, "hash", PL_op_desc[type], kid);
7789 op_lvalue(kid, type);
7793 OP * const newop = newUNOP(OP_NULL, 0, kid);
7794 kid->op_sibling = 0;
7796 newop->op_next = newop;
7798 kid->op_sibling = sibl;
7803 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7804 if (kid->op_type == OP_CONST &&
7805 (kid->op_private & OPpCONST_BARE))
7807 OP * const newop = newGVOP(OP_GV, 0,
7808 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7809 if (!(o->op_private & 1) && /* if not unop */
7810 kid == cLISTOPo->op_last)
7811 cLISTOPo->op_last = newop;
7813 op_getmad(kid,newop,'K');
7819 else if (kid->op_type == OP_READLINE) {
7820 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7821 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7824 I32 flags = OPf_SPECIAL;
7828 /* is this op a FH constructor? */
7829 if (is_handle_constructor(o,numargs)) {
7830 const char *name = NULL;
7835 /* Set a flag to tell rv2gv to vivify
7836 * need to "prove" flag does not mean something
7837 * else already - NI-S 1999/05/07
7840 if (kid->op_type == OP_PADSV) {
7842 = PAD_COMPNAME_SV(kid->op_targ);
7843 name = SvPV_const(namesv, len);
7844 name_utf8 = SvUTF8(namesv);
7846 else if (kid->op_type == OP_RV2SV
7847 && kUNOP->op_first->op_type == OP_GV)
7849 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7851 len = GvNAMELEN(gv);
7852 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
7854 else if (kid->op_type == OP_AELEM
7855 || kid->op_type == OP_HELEM)
7858 OP *op = ((BINOP*)kid)->op_first;
7862 const char * const a =
7863 kid->op_type == OP_AELEM ?
7865 if (((op->op_type == OP_RV2AV) ||
7866 (op->op_type == OP_RV2HV)) &&
7867 (firstop = ((UNOP*)op)->op_first) &&
7868 (firstop->op_type == OP_GV)) {
7869 /* packagevar $a[] or $h{} */
7870 GV * const gv = cGVOPx_gv(firstop);
7878 else if (op->op_type == OP_PADAV
7879 || op->op_type == OP_PADHV) {
7880 /* lexicalvar $a[] or $h{} */
7881 const char * const padname =
7882 PAD_COMPNAME_PV(op->op_targ);
7891 name = SvPV_const(tmpstr, len);
7892 name_utf8 = SvUTF8(tmpstr);
7897 name = "__ANONIO__";
7900 op_lvalue(kid, type);
7904 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7905 namesv = PAD_SVl(targ);
7906 SvUPGRADE(namesv, SVt_PV);
7908 sv_setpvs(namesv, "$");
7909 sv_catpvn(namesv, name, len);
7910 if ( name_utf8 ) SvUTF8_on(namesv);
7913 kid->op_sibling = 0;
7914 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7915 kid->op_targ = targ;
7916 kid->op_private |= priv;
7918 kid->op_sibling = sibl;
7924 op_lvalue(scalar(kid), type);
7928 tokid = &kid->op_sibling;
7929 kid = kid->op_sibling;
7932 if (kid && kid->op_type != OP_STUB)
7933 return too_many_arguments(o,OP_DESC(o));
7934 o->op_private |= numargs;
7936 /* FIXME - should the numargs move as for the PERL_MAD case? */
7937 o->op_private |= numargs;
7939 return too_many_arguments(o,OP_DESC(o));
7943 else if (PL_opargs[type] & OA_DEFGV) {
7945 OP *newop = newUNOP(type, 0, newDEFSVOP());
7946 op_getmad(o,newop,'O');
7949 /* Ordering of these two is important to keep f_map.t passing. */
7951 return newUNOP(type, 0, newDEFSVOP());
7956 while (oa & OA_OPTIONAL)
7958 if (oa && oa != OA_LIST)
7959 return too_few_arguments(o,OP_DESC(o));
7965 Perl_ck_glob(pTHX_ OP *o)
7970 PERL_ARGS_ASSERT_CK_GLOB;
7973 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7974 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
7976 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7977 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7979 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7982 #if !defined(PERL_EXTERNAL_GLOB)
7983 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7986 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7987 newSVpvs("File::Glob"), NULL, NULL, NULL);
7988 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7989 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7990 GvCV_set(gv, GvCV(glob_gv));
7991 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7992 GvIMPORTED_CV_on(gv);
7996 #endif /* PERL_EXTERNAL_GLOB */
7998 assert(!(o->op_flags & OPf_SPECIAL));
7999 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8002 * \ null - const(wildcard)
8007 * \ mark - glob - rv2cv
8008 * | \ gv(CORE::GLOBAL::glob)
8010 * \ null - const(wildcard) - const(ix)
8012 o->op_flags |= OPf_SPECIAL;
8013 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8014 op_append_elem(OP_GLOB, o,
8015 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
8016 o = newLISTOP(OP_LIST, 0, o, NULL);
8017 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
8018 op_append_elem(OP_LIST, o,
8019 scalar(newUNOP(OP_RV2CV, 0,
8020 newGVOP(OP_GV, 0, gv)))));
8021 o = newUNOP(OP_NULL, 0, ck_subr(o));
8022 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8025 gv = newGVgen("main");
8027 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8033 Perl_ck_grep(pTHX_ OP *o)
8038 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8041 PERL_ARGS_ASSERT_CK_GREP;
8043 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8044 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8046 if (o->op_flags & OPf_STACKED) {
8049 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8050 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8051 return no_fh_allowed(o);
8052 for (k = kid; k; k = k->op_next) {
8055 NewOp(1101, gwop, 1, LOGOP);
8056 kid->op_next = (OP*)gwop;
8057 o->op_flags &= ~OPf_STACKED;
8059 kid = cLISTOPo->op_first->op_sibling;
8060 if (type == OP_MAPWHILE)
8065 if (PL_parser && PL_parser->error_count)
8067 kid = cLISTOPo->op_first->op_sibling;
8068 if (kid->op_type != OP_NULL)
8069 Perl_croak(aTHX_ "panic: ck_grep");
8070 kid = kUNOP->op_first;
8073 NewOp(1101, gwop, 1, LOGOP);
8074 gwop->op_type = type;
8075 gwop->op_ppaddr = PL_ppaddr[type];
8076 gwop->op_first = listkids(o);
8077 gwop->op_flags |= OPf_KIDS;
8078 gwop->op_other = LINKLIST(kid);
8079 kid->op_next = (OP*)gwop;
8080 offset = pad_findmy_pvs("$_", 0);
8081 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8082 o->op_private = gwop->op_private = 0;
8083 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8086 o->op_private = gwop->op_private = OPpGREP_LEX;
8087 gwop->op_targ = o->op_targ = offset;
8090 kid = cLISTOPo->op_first->op_sibling;
8091 if (!kid || !kid->op_sibling)
8092 return too_few_arguments(o,OP_DESC(o));
8093 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8094 op_lvalue(kid, OP_GREPSTART);
8100 Perl_ck_index(pTHX_ OP *o)
8102 PERL_ARGS_ASSERT_CK_INDEX;
8104 if (o->op_flags & OPf_KIDS) {
8105 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8107 kid = kid->op_sibling; /* get past "big" */
8108 if (kid && kid->op_type == OP_CONST) {
8109 const bool save_taint = PL_tainted;
8110 fbm_compile(((SVOP*)kid)->op_sv, 0);
8111 PL_tainted = save_taint;
8118 Perl_ck_lfun(pTHX_ OP *o)
8120 const OPCODE type = o->op_type;
8122 PERL_ARGS_ASSERT_CK_LFUN;
8124 return modkids(ck_fun(o), type);
8128 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8130 PERL_ARGS_ASSERT_CK_DEFINED;
8132 if ((o->op_flags & OPf_KIDS)) {
8133 switch (cUNOPo->op_first->op_type) {
8135 /* This is needed for
8136 if (defined %stash::)
8137 to work. Do not break Tk.
8139 break; /* Globals via GV can be undef */
8141 case OP_AASSIGN: /* Is this a good idea? */
8142 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8143 "defined(@array) is deprecated");
8144 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8145 "\t(Maybe you should just omit the defined()?)\n");
8149 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8150 "defined(%%hash) is deprecated");
8151 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8152 "\t(Maybe you should just omit the defined()?)\n");
8163 Perl_ck_readline(pTHX_ OP *o)
8165 PERL_ARGS_ASSERT_CK_READLINE;
8167 if (!(o->op_flags & OPf_KIDS)) {
8169 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8171 op_getmad(o,newop,'O');
8181 Perl_ck_rfun(pTHX_ OP *o)
8183 const OPCODE type = o->op_type;
8185 PERL_ARGS_ASSERT_CK_RFUN;
8187 return refkids(ck_fun(o), type);
8191 Perl_ck_listiob(pTHX_ OP *o)
8195 PERL_ARGS_ASSERT_CK_LISTIOB;
8197 kid = cLISTOPo->op_first;
8200 kid = cLISTOPo->op_first;
8202 if (kid->op_type == OP_PUSHMARK)
8203 kid = kid->op_sibling;
8204 if (kid && o->op_flags & OPf_STACKED)
8205 kid = kid->op_sibling;
8206 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8207 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8208 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8209 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8210 cLISTOPo->op_first->op_sibling = kid;
8211 cLISTOPo->op_last = kid;
8212 kid = kid->op_sibling;
8217 op_append_elem(o->op_type, o, newDEFSVOP());
8223 Perl_ck_smartmatch(pTHX_ OP *o)
8226 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8227 if (0 == (o->op_flags & OPf_SPECIAL)) {
8228 OP *first = cBINOPo->op_first;
8229 OP *second = first->op_sibling;
8231 /* Implicitly take a reference to an array or hash */
8232 first->op_sibling = NULL;
8233 first = cBINOPo->op_first = ref_array_or_hash(first);
8234 second = first->op_sibling = ref_array_or_hash(second);
8236 /* Implicitly take a reference to a regular expression */
8237 if (first->op_type == OP_MATCH) {
8238 first->op_type = OP_QR;
8239 first->op_ppaddr = PL_ppaddr[OP_QR];
8241 if (second->op_type == OP_MATCH) {
8242 second->op_type = OP_QR;
8243 second->op_ppaddr = PL_ppaddr[OP_QR];
8252 Perl_ck_sassign(pTHX_ OP *o)
8255 OP * const kid = cLISTOPo->op_first;
8257 PERL_ARGS_ASSERT_CK_SASSIGN;
8259 /* has a disposable target? */
8260 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8261 && !(kid->op_flags & OPf_STACKED)
8262 /* Cannot steal the second time! */
8263 && !(kid->op_private & OPpTARGET_MY)
8264 /* Keep the full thing for madskills */
8268 OP * const kkid = kid->op_sibling;
8270 /* Can just relocate the target. */
8271 if (kkid && kkid->op_type == OP_PADSV
8272 && !(kkid->op_private & OPpLVAL_INTRO))
8274 kid->op_targ = kkid->op_targ;
8276 /* Now we do not need PADSV and SASSIGN. */
8277 kid->op_sibling = o->op_sibling; /* NULL */
8278 cLISTOPo->op_first = NULL;
8281 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8285 if (kid->op_sibling) {
8286 OP *kkid = kid->op_sibling;
8287 /* For state variable assignment, kkid is a list op whose op_last
8289 if ((kkid->op_type == OP_PADSV ||
8290 (kkid->op_type == OP_LIST &&
8291 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8294 && (kkid->op_private & OPpLVAL_INTRO)
8295 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8296 const PADOFFSET target = kkid->op_targ;
8297 OP *const other = newOP(OP_PADSV,
8299 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8300 OP *const first = newOP(OP_NULL, 0);
8301 OP *const nullop = newCONDOP(0, first, o, other);
8302 OP *const condop = first->op_next;
8303 /* hijacking PADSTALE for uninitialized state variables */
8304 SvPADSTALE_on(PAD_SVl(target));
8306 condop->op_type = OP_ONCE;
8307 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8308 condop->op_targ = target;
8309 other->op_targ = target;
8311 /* Because we change the type of the op here, we will skip the
8312 assignment binop->op_last = binop->op_first->op_sibling; at the
8313 end of Perl_newBINOP(). So need to do it here. */
8314 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8323 Perl_ck_match(pTHX_ OP *o)
8327 PERL_ARGS_ASSERT_CK_MATCH;
8329 if (o->op_type != OP_QR && PL_compcv) {
8330 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8331 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8332 o->op_targ = offset;
8333 o->op_private |= OPpTARGET_MY;
8336 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8337 o->op_private |= OPpRUNTIME;
8342 Perl_ck_method(pTHX_ OP *o)
8344 OP * const kid = cUNOPo->op_first;
8346 PERL_ARGS_ASSERT_CK_METHOD;
8348 if (kid->op_type == OP_CONST) {
8349 SV* sv = kSVOP->op_sv;
8350 const char * const method = SvPVX_const(sv);
8351 if (!(strchr(method, ':') || strchr(method, '\''))) {
8353 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8354 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
8357 kSVOP->op_sv = NULL;
8359 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8361 op_getmad(o,cmop,'O');
8372 Perl_ck_null(pTHX_ OP *o)
8374 PERL_ARGS_ASSERT_CK_NULL;
8375 PERL_UNUSED_CONTEXT;
8380 Perl_ck_open(pTHX_ OP *o)
8383 HV * const table = GvHV(PL_hintgv);
8385 PERL_ARGS_ASSERT_CK_OPEN;
8388 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8391 const char *d = SvPV_const(*svp, len);
8392 const I32 mode = mode_from_discipline(d, len);
8393 if (mode & O_BINARY)
8394 o->op_private |= OPpOPEN_IN_RAW;
8395 else if (mode & O_TEXT)
8396 o->op_private |= OPpOPEN_IN_CRLF;
8399 svp = hv_fetchs(table, "open_OUT", FALSE);
8402 const char *d = SvPV_const(*svp, len);
8403 const I32 mode = mode_from_discipline(d, len);
8404 if (mode & O_BINARY)
8405 o->op_private |= OPpOPEN_OUT_RAW;
8406 else if (mode & O_TEXT)
8407 o->op_private |= OPpOPEN_OUT_CRLF;
8410 if (o->op_type == OP_BACKTICK) {
8411 if (!(o->op_flags & OPf_KIDS)) {
8412 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8414 op_getmad(o,newop,'O');
8423 /* In case of three-arg dup open remove strictness
8424 * from the last arg if it is a bareword. */
8425 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8426 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8430 if ((last->op_type == OP_CONST) && /* The bareword. */
8431 (last->op_private & OPpCONST_BARE) &&
8432 (last->op_private & OPpCONST_STRICT) &&
8433 (oa = first->op_sibling) && /* The fh. */
8434 (oa = oa->op_sibling) && /* The mode. */
8435 (oa->op_type == OP_CONST) &&
8436 SvPOK(((SVOP*)oa)->op_sv) &&
8437 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8438 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8439 (last == oa->op_sibling)) /* The bareword. */
8440 last->op_private &= ~OPpCONST_STRICT;
8446 Perl_ck_repeat(pTHX_ OP *o)
8448 PERL_ARGS_ASSERT_CK_REPEAT;
8450 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8451 o->op_private |= OPpREPEAT_DOLIST;
8452 cBINOPo->op_first = force_list(cBINOPo->op_first);
8460 Perl_ck_require(pTHX_ OP *o)
8465 PERL_ARGS_ASSERT_CK_REQUIRE;
8467 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8468 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8470 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8471 SV * const sv = kid->op_sv;
8472 U32 was_readonly = SvREADONLY(sv);
8479 sv_force_normal_flags(sv, 0);
8480 assert(!SvREADONLY(sv));
8490 for (; s < end; s++) {
8491 if (*s == ':' && s[1] == ':') {
8493 Move(s+2, s+1, end - s - 1, char);
8498 sv_catpvs(sv, ".pm");
8499 SvFLAGS(sv) |= was_readonly;
8503 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8504 /* handle override, if any */
8505 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8506 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8507 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8508 gv = gvp ? *gvp : NULL;
8512 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8513 OP * const kid = cUNOPo->op_first;
8516 cUNOPo->op_first = 0;
8520 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8521 op_append_elem(OP_LIST, kid,
8522 scalar(newUNOP(OP_RV2CV, 0,
8525 op_getmad(o,newop,'O');
8529 return scalar(ck_fun(o));
8533 Perl_ck_return(pTHX_ OP *o)
8538 PERL_ARGS_ASSERT_CK_RETURN;
8540 kid = cLISTOPo->op_first->op_sibling;
8541 if (CvLVALUE(PL_compcv)) {
8542 for (; kid; kid = kid->op_sibling)
8543 op_lvalue(kid, OP_LEAVESUBLV);
8550 Perl_ck_select(pTHX_ OP *o)
8555 PERL_ARGS_ASSERT_CK_SELECT;
8557 if (o->op_flags & OPf_KIDS) {
8558 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8559 if (kid && kid->op_sibling) {
8560 o->op_type = OP_SSELECT;
8561 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8563 return fold_constants(op_integerize(op_std_init(o)));
8567 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8568 if (kid && kid->op_type == OP_RV2GV)
8569 kid->op_private &= ~HINT_STRICT_REFS;
8574 Perl_ck_shift(pTHX_ OP *o)
8577 const I32 type = o->op_type;
8579 PERL_ARGS_ASSERT_CK_SHIFT;
8581 if (!(o->op_flags & OPf_KIDS)) {
8584 if (!CvUNIQUE(PL_compcv)) {
8585 o->op_flags |= OPf_SPECIAL;
8589 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8592 OP * const oldo = o;
8593 o = newUNOP(type, 0, scalar(argop));
8594 op_getmad(oldo,o,'O');
8599 return newUNOP(type, 0, scalar(argop));
8602 return scalar(ck_fun(o));
8606 Perl_ck_sort(pTHX_ OP *o)
8611 PERL_ARGS_ASSERT_CK_SORT;
8613 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8614 HV * const hinthv = GvHV(PL_hintgv);
8616 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8618 const I32 sorthints = (I32)SvIV(*svp);
8619 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8620 o->op_private |= OPpSORT_QSORT;
8621 if ((sorthints & HINT_SORT_STABLE) != 0)
8622 o->op_private |= OPpSORT_STABLE;
8627 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8629 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8630 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8632 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8634 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8636 if (kid->op_type == OP_SCOPE) {
8640 else if (kid->op_type == OP_LEAVE) {
8641 if (o->op_type == OP_SORT) {
8642 op_null(kid); /* wipe out leave */
8645 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8646 if (k->op_next == kid)
8648 /* don't descend into loops */
8649 else if (k->op_type == OP_ENTERLOOP
8650 || k->op_type == OP_ENTERITER)
8652 k = cLOOPx(k)->op_lastop;
8657 kid->op_next = 0; /* just disconnect the leave */
8658 k = kLISTOP->op_first;
8663 if (o->op_type == OP_SORT) {
8664 /* provide scalar context for comparison function/block */
8670 o->op_flags |= OPf_SPECIAL;
8672 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8675 firstkid = firstkid->op_sibling;
8678 /* provide list context for arguments */
8679 if (o->op_type == OP_SORT)
8686 S_simplify_sort(pTHX_ OP *o)
8689 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8695 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8697 if (!(o->op_flags & OPf_STACKED))
8699 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8700 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8701 kid = kUNOP->op_first; /* get past null */
8702 if (kid->op_type != OP_SCOPE)
8704 kid = kLISTOP->op_last; /* get past scope */
8705 switch(kid->op_type) {
8713 k = kid; /* remember this node*/
8714 if (kBINOP->op_first->op_type != OP_RV2SV)
8716 kid = kBINOP->op_first; /* get past cmp */
8717 if (kUNOP->op_first->op_type != OP_GV)
8719 kid = kUNOP->op_first; /* get past rv2sv */
8721 if (GvSTASH(gv) != PL_curstash)
8723 gvname = GvNAME(gv);
8724 if (*gvname == 'a' && gvname[1] == '\0')
8726 else if (*gvname == 'b' && gvname[1] == '\0')
8731 kid = k; /* back to cmp */
8732 if (kBINOP->op_last->op_type != OP_RV2SV)
8734 kid = kBINOP->op_last; /* down to 2nd arg */
8735 if (kUNOP->op_first->op_type != OP_GV)
8737 kid = kUNOP->op_first; /* get past rv2sv */
8739 if (GvSTASH(gv) != PL_curstash)
8741 gvname = GvNAME(gv);
8743 ? !(*gvname == 'a' && gvname[1] == '\0')
8744 : !(*gvname == 'b' && gvname[1] == '\0'))
8746 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8748 o->op_private |= OPpSORT_DESCEND;
8749 if (k->op_type == OP_NCMP)
8750 o->op_private |= OPpSORT_NUMERIC;
8751 if (k->op_type == OP_I_NCMP)
8752 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8753 kid = cLISTOPo->op_first->op_sibling;
8754 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8756 op_getmad(kid,o,'S'); /* then delete it */
8758 op_free(kid); /* then delete it */
8763 Perl_ck_split(pTHX_ OP *o)
8768 PERL_ARGS_ASSERT_CK_SPLIT;
8770 if (o->op_flags & OPf_STACKED)
8771 return no_fh_allowed(o);
8773 kid = cLISTOPo->op_first;
8774 if (kid->op_type != OP_NULL)
8775 Perl_croak(aTHX_ "panic: ck_split");
8776 kid = kid->op_sibling;
8777 op_free(cLISTOPo->op_first);
8779 cLISTOPo->op_first = kid;
8781 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8782 cLISTOPo->op_last = kid; /* There was only one element previously */
8785 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8786 OP * const sibl = kid->op_sibling;
8787 kid->op_sibling = 0;
8788 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8789 if (cLISTOPo->op_first == cLISTOPo->op_last)
8790 cLISTOPo->op_last = kid;
8791 cLISTOPo->op_first = kid;
8792 kid->op_sibling = sibl;
8795 kid->op_type = OP_PUSHRE;
8796 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8798 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8799 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8800 "Use of /g modifier is meaningless in split");
8803 if (!kid->op_sibling)
8804 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8806 kid = kid->op_sibling;
8809 if (!kid->op_sibling)
8810 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8811 assert(kid->op_sibling);
8813 kid = kid->op_sibling;
8816 if (kid->op_sibling)
8817 return too_many_arguments(o,OP_DESC(o));
8823 Perl_ck_join(pTHX_ OP *o)
8825 const OP * const kid = cLISTOPo->op_first->op_sibling;
8827 PERL_ARGS_ASSERT_CK_JOIN;
8829 if (kid && kid->op_type == OP_MATCH) {
8830 if (ckWARN(WARN_SYNTAX)) {
8831 const REGEXP *re = PM_GETRE(kPMOP);
8832 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8833 const STRLEN len = re ? RX_PRELEN(re) : 6;
8834 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8835 "/%.*s/ should probably be written as \"%.*s\"",
8836 (int)len, pmstr, (int)len, pmstr);
8843 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8845 Examines an op, which is expected to identify a subroutine at runtime,
8846 and attempts to determine at compile time which subroutine it identifies.
8847 This is normally used during Perl compilation to determine whether
8848 a prototype can be applied to a function call. I<cvop> is the op
8849 being considered, normally an C<rv2cv> op. A pointer to the identified
8850 subroutine is returned, if it could be determined statically, and a null
8851 pointer is returned if it was not possible to determine statically.
8853 Currently, the subroutine can be identified statically if the RV that the
8854 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8855 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8856 suitable if the constant value must be an RV pointing to a CV. Details of
8857 this process may change in future versions of Perl. If the C<rv2cv> op
8858 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8859 the subroutine statically: this flag is used to suppress compile-time
8860 magic on a subroutine call, forcing it to use default runtime behaviour.
8862 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8863 of a GV reference is modified. If a GV was examined and its CV slot was
8864 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8865 If the op is not optimised away, and the CV slot is later populated with
8866 a subroutine having a prototype, that flag eventually triggers the warning
8867 "called too early to check prototype".
8869 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8870 of returning a pointer to the subroutine it returns a pointer to the
8871 GV giving the most appropriate name for the subroutine in this context.
8872 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8873 (C<CvANON>) subroutine that is referenced through a GV it will be the
8874 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8875 A null pointer is returned as usual if there is no statically-determinable
8882 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8887 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8888 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8889 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8890 if (cvop->op_type != OP_RV2CV)
8892 if (cvop->op_private & OPpENTERSUB_AMPER)
8894 if (!(cvop->op_flags & OPf_KIDS))
8896 rvop = cUNOPx(cvop)->op_first;
8897 switch (rvop->op_type) {
8899 gv = cGVOPx_gv(rvop);
8902 if (flags & RV2CVOPCV_MARK_EARLY)
8903 rvop->op_private |= OPpEARLY_CV;
8908 SV *rv = cSVOPx_sv(rvop);
8918 if (SvTYPE((SV*)cv) != SVt_PVCV)
8920 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8921 if (!CvANON(cv) || !gv)
8930 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8932 Performs the default fixup of the arguments part of an C<entersub>
8933 op tree. This consists of applying list context to each of the
8934 argument ops. This is the standard treatment used on a call marked
8935 with C<&>, or a method call, or a call through a subroutine reference,
8936 or any other call where the callee can't be identified at compile time,
8937 or a call where the callee has no prototype.
8943 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8946 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8947 aop = cUNOPx(entersubop)->op_first;
8948 if (!aop->op_sibling)
8949 aop = cUNOPx(aop)->op_first;
8950 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8951 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8953 op_lvalue(aop, OP_ENTERSUB);
8960 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8962 Performs the fixup of the arguments part of an C<entersub> op tree
8963 based on a subroutine prototype. This makes various modifications to
8964 the argument ops, from applying context up to inserting C<refgen> ops,
8965 and checking the number and syntactic types of arguments, as directed by
8966 the prototype. This is the standard treatment used on a subroutine call,
8967 not marked with C<&>, where the callee can be identified at compile time
8968 and has a prototype.
8970 I<protosv> supplies the subroutine prototype to be applied to the call.
8971 It may be a normal defined scalar, of which the string value will be used.
8972 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8973 that has been cast to C<SV*>) which has a prototype. The prototype
8974 supplied, in whichever form, does not need to match the actual callee
8975 referenced by the op tree.
8977 If the argument ops disagree with the prototype, for example by having
8978 an unacceptable number of arguments, a valid op tree is returned anyway.
8979 The error is reflected in the parser state, normally resulting in a single
8980 exception at the top level of parsing which covers all the compilation
8981 errors that occurred. In the error message, the callee is referred to
8982 by the name defined by the I<namegv> parameter.
8988 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8991 const char *proto, *proto_end;
8992 OP *aop, *prev, *cvop;
8995 I32 contextclass = 0;
8996 const char *e = NULL;
8997 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8998 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8999 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
9000 proto = SvPV(protosv, proto_len);
9001 proto_end = proto + proto_len;
9002 aop = cUNOPx(entersubop)->op_first;
9003 if (!aop->op_sibling)
9004 aop = cUNOPx(aop)->op_first;
9006 aop = aop->op_sibling;
9007 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9008 while (aop != cvop) {
9010 if (PL_madskills && aop->op_type == OP_STUB) {
9011 aop = aop->op_sibling;
9014 if (PL_madskills && aop->op_type == OP_NULL)
9015 o3 = ((UNOP*)aop)->op_first;
9019 if (proto >= proto_end)
9020 return too_many_arguments(entersubop, gv_ename(namegv));
9028 /* _ must be at the end */
9029 if (proto[1] && proto[1] != ';')
9044 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9046 arg == 1 ? "block or sub {}" : "sub {}",
9047 gv_ename(namegv), o3);
9050 /* '*' allows any scalar type, including bareword */
9053 if (o3->op_type == OP_RV2GV)
9054 goto wrapref; /* autoconvert GLOB -> GLOBref */
9055 else if (o3->op_type == OP_CONST)
9056 o3->op_private &= ~OPpCONST_STRICT;
9057 else if (o3->op_type == OP_ENTERSUB) {
9058 /* accidental subroutine, revert to bareword */
9059 OP *gvop = ((UNOP*)o3)->op_first;
9060 if (gvop && gvop->op_type == OP_NULL) {
9061 gvop = ((UNOP*)gvop)->op_first;
9063 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9066 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9067 (gvop = ((UNOP*)gvop)->op_first) &&
9068 gvop->op_type == OP_GV)
9070 GV * const gv = cGVOPx_gv(gvop);
9071 OP * const sibling = aop->op_sibling;
9072 SV * const n = newSVpvs("");
9074 OP * const oldaop = aop;
9078 gv_fullname4(n, gv, "", FALSE);
9079 aop = newSVOP(OP_CONST, 0, n);
9080 op_getmad(oldaop,aop,'O');
9081 prev->op_sibling = aop;
9082 aop->op_sibling = sibling;
9092 if (o3->op_type == OP_RV2AV ||
9093 o3->op_type == OP_PADAV ||
9094 o3->op_type == OP_RV2HV ||
9095 o3->op_type == OP_PADHV
9110 if (contextclass++ == 0) {
9111 e = strchr(proto, ']');
9112 if (!e || e == proto)
9121 const char *p = proto;
9122 const char *const end = proto;
9125 /* \[$] accepts any scalar lvalue */
9127 && Perl_op_lvalue_flags(aTHX_
9129 OP_READ, /* not entersub */
9132 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
9134 gv_ename(namegv), o3);
9139 if (o3->op_type == OP_RV2GV)
9142 bad_type(arg, "symbol", gv_ename(namegv), o3);
9145 if (o3->op_type == OP_ENTERSUB)
9148 bad_type(arg, "subroutine entry", gv_ename(namegv),
9152 if (o3->op_type == OP_RV2SV ||
9153 o3->op_type == OP_PADSV ||
9154 o3->op_type == OP_HELEM ||
9155 o3->op_type == OP_AELEM)
9157 if (!contextclass) {
9158 /* \$ accepts any scalar lvalue */
9159 if (Perl_op_lvalue_flags(aTHX_
9161 OP_READ, /* not entersub */
9164 bad_type(arg, "scalar", gv_ename(namegv), o3);
9168 if (o3->op_type == OP_RV2AV ||
9169 o3->op_type == OP_PADAV)
9172 bad_type(arg, "array", gv_ename(namegv), o3);
9175 if (o3->op_type == OP_RV2HV ||
9176 o3->op_type == OP_PADHV)
9179 bad_type(arg, "hash", gv_ename(namegv), o3);
9183 OP* const kid = aop;
9184 OP* const sib = kid->op_sibling;
9185 kid->op_sibling = 0;
9186 aop = newUNOP(OP_REFGEN, 0, kid);
9187 aop->op_sibling = sib;
9188 prev->op_sibling = aop;
9190 if (contextclass && e) {
9205 SV* const tmpsv = sv_newmortal();
9206 gv_efullname3(tmpsv, namegv, NULL);
9207 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9208 SVfARG(tmpsv), SVfARG(protosv));
9212 op_lvalue(aop, OP_ENTERSUB);
9214 aop = aop->op_sibling;
9216 if (aop == cvop && *proto == '_') {
9217 /* generate an access to $_ */
9219 aop->op_sibling = prev->op_sibling;
9220 prev->op_sibling = aop; /* instead of cvop */
9222 if (!optional && proto_end > proto &&
9223 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9224 return too_few_arguments(entersubop, gv_ename(namegv));
9229 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9231 Performs the fixup of the arguments part of an C<entersub> op tree either
9232 based on a subroutine prototype or using default list-context processing.
9233 This is the standard treatment used on a subroutine call, not marked
9234 with C<&>, where the callee can be identified at compile time.
9236 I<protosv> supplies the subroutine prototype to be applied to the call,
9237 or indicates that there is no prototype. It may be a normal scalar,
9238 in which case if it is defined then the string value will be used
9239 as a prototype, and if it is undefined then there is no prototype.
9240 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9241 that has been cast to C<SV*>), of which the prototype will be used if it
9242 has one. The prototype (or lack thereof) supplied, in whichever form,
9243 does not need to match the actual callee referenced by the op tree.
9245 If the argument ops disagree with the prototype, for example by having
9246 an unacceptable number of arguments, a valid op tree is returned anyway.
9247 The error is reflected in the parser state, normally resulting in a single
9248 exception at the top level of parsing which covers all the compilation
9249 errors that occurred. In the error message, the callee is referred to
9250 by the name defined by the I<namegv> parameter.
9256 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9257 GV *namegv, SV *protosv)
9259 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9260 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9261 return ck_entersub_args_proto(entersubop, namegv, protosv);
9263 return ck_entersub_args_list(entersubop);
9267 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9269 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9270 OP *aop = cUNOPx(entersubop)->op_first;
9272 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9276 if (!aop->op_sibling)
9277 aop = cUNOPx(aop)->op_first;
9278 aop = aop->op_sibling;
9279 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9280 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9281 aop = aop->op_sibling;
9285 (void)too_many_arguments(entersubop, GvNAME(namegv));
9287 op_free(entersubop);
9288 switch(GvNAME(namegv)[2]) {
9289 case 'F': return newSVOP(OP_CONST, 0,
9290 newSVpv(CopFILE(PL_curcop),0));
9291 case 'L': return newSVOP(
9294 "%"IVdf, (IV)CopLINE(PL_curcop)
9297 case 'P': return newSVOP(OP_CONST, 0,
9299 ? newSVhek(HvNAME_HEK(PL_curstash))
9310 bool seenarg = FALSE;
9312 if (!aop->op_sibling)
9313 aop = cUNOPx(aop)->op_first;
9316 aop = aop->op_sibling;
9317 prev->op_sibling = NULL;
9320 prev=cvop, cvop = cvop->op_sibling)
9322 if (PL_madskills && cvop->op_sibling
9323 && cvop->op_type != OP_STUB) seenarg = TRUE
9326 prev->op_sibling = NULL;
9327 paren = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9329 if (aop == cvop) aop = NULL;
9330 op_free(entersubop);
9332 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9334 case OA_BASEOP_OR_UNOP:
9336 return aop ? newUNOP(opnum,paren,aop) : newOP(opnum,paren);
9340 if (!PL_madskills || seenarg)
9342 (void)too_many_arguments(aop, GvNAME(namegv));
9345 return newOP(opnum,0);
9347 return convert(opnum,0,aop);
9355 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9357 Retrieves the function that will be used to fix up a call to I<cv>.
9358 Specifically, the function is applied to an C<entersub> op tree for a
9359 subroutine call, not marked with C<&>, where the callee can be identified
9360 at compile time as I<cv>.
9362 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9363 argument for it is returned in I<*ckobj_p>. The function is intended
9364 to be called in this manner:
9366 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9368 In this call, I<entersubop> is a pointer to the C<entersub> op,
9369 which may be replaced by the check function, and I<namegv> is a GV
9370 supplying the name that should be used by the check function to refer
9371 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9372 It is permitted to apply the check function in non-standard situations,
9373 such as to a call to a different subroutine or to a method call.
9375 By default, the function is
9376 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9377 and the SV parameter is I<cv> itself. This implements standard
9378 prototype processing. It can be changed, for a particular subroutine,
9379 by L</cv_set_call_checker>.
9385 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9388 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9389 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9391 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9392 *ckobj_p = callmg->mg_obj;
9394 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9400 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9402 Sets the function that will be used to fix up a call to I<cv>.
9403 Specifically, the function is applied to an C<entersub> op tree for a
9404 subroutine call, not marked with C<&>, where the callee can be identified
9405 at compile time as I<cv>.
9407 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9408 for it is supplied in I<ckobj>. The function is intended to be called
9411 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9413 In this call, I<entersubop> is a pointer to the C<entersub> op,
9414 which may be replaced by the check function, and I<namegv> is a GV
9415 supplying the name that should be used by the check function to refer
9416 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9417 It is permitted to apply the check function in non-standard situations,
9418 such as to a call to a different subroutine or to a method call.
9420 The current setting for a particular CV can be retrieved by
9421 L</cv_get_call_checker>.
9427 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9429 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9430 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9431 if (SvMAGICAL((SV*)cv))
9432 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9435 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9436 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9437 if (callmg->mg_flags & MGf_REFCOUNTED) {
9438 SvREFCNT_dec(callmg->mg_obj);
9439 callmg->mg_flags &= ~MGf_REFCOUNTED;
9441 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9442 callmg->mg_obj = ckobj;
9443 if (ckobj != (SV*)cv) {
9444 SvREFCNT_inc_simple_void_NN(ckobj);
9445 callmg->mg_flags |= MGf_REFCOUNTED;
9451 Perl_ck_subr(pTHX_ OP *o)
9457 PERL_ARGS_ASSERT_CK_SUBR;
9459 aop = cUNOPx(o)->op_first;
9460 if (!aop->op_sibling)
9461 aop = cUNOPx(aop)->op_first;
9462 aop = aop->op_sibling;
9463 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9464 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9465 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9467 o->op_private &= ~1;
9468 o->op_private |= OPpENTERSUB_HASTARG;
9469 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9470 if (PERLDB_SUB && PL_curstash != PL_debstash)
9471 o->op_private |= OPpENTERSUB_DB;
9472 if (cvop->op_type == OP_RV2CV) {
9473 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9475 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9476 if (aop->op_type == OP_CONST)
9477 aop->op_private &= ~OPpCONST_STRICT;
9478 else if (aop->op_type == OP_LIST) {
9479 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9480 if (sib && sib->op_type == OP_CONST)
9481 sib->op_private &= ~OPpCONST_STRICT;
9486 return ck_entersub_args_list(o);
9488 Perl_call_checker ckfun;
9490 cv_get_call_checker(cv, &ckfun, &ckobj);
9491 return ckfun(aTHX_ o, namegv, ckobj);
9496 Perl_ck_svconst(pTHX_ OP *o)
9498 PERL_ARGS_ASSERT_CK_SVCONST;
9499 PERL_UNUSED_CONTEXT;
9500 SvREADONLY_on(cSVOPo->op_sv);
9505 Perl_ck_chdir(pTHX_ OP *o)
9507 PERL_ARGS_ASSERT_CK_CHDIR;
9508 if (o->op_flags & OPf_KIDS) {
9509 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9511 if (kid && kid->op_type == OP_CONST &&
9512 (kid->op_private & OPpCONST_BARE))
9514 o->op_flags |= OPf_SPECIAL;
9515 kid->op_private &= ~OPpCONST_STRICT;
9522 Perl_ck_trunc(pTHX_ OP *o)
9524 PERL_ARGS_ASSERT_CK_TRUNC;
9526 if (o->op_flags & OPf_KIDS) {
9527 SVOP *kid = (SVOP*)cUNOPo->op_first;
9529 if (kid->op_type == OP_NULL)
9530 kid = (SVOP*)kid->op_sibling;
9531 if (kid && kid->op_type == OP_CONST &&
9532 (kid->op_private & OPpCONST_BARE))
9534 o->op_flags |= OPf_SPECIAL;
9535 kid->op_private &= ~OPpCONST_STRICT;
9542 Perl_ck_substr(pTHX_ OP *o)
9544 PERL_ARGS_ASSERT_CK_SUBSTR;
9547 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9548 OP *kid = cLISTOPo->op_first;
9550 if (kid->op_type == OP_NULL)
9551 kid = kid->op_sibling;
9553 kid->op_flags |= OPf_MOD;
9560 Perl_ck_each(pTHX_ OP *o)
9563 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9564 const unsigned orig_type = o->op_type;
9565 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9566 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9567 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9568 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9570 PERL_ARGS_ASSERT_CK_EACH;
9573 switch (kid->op_type) {
9579 CHANGE_TYPE(o, array_type);
9582 if (kid->op_private == OPpCONST_BARE
9583 || !SvROK(cSVOPx_sv(kid))
9584 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9585 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9587 /* we let ck_fun handle it */
9590 CHANGE_TYPE(o, ref_type);
9594 /* if treating as a reference, defer additional checks to runtime */
9595 return o->op_type == ref_type ? o : ck_fun(o);
9598 /* caller is supposed to assign the return to the
9599 container of the rep_op var */
9601 S_opt_scalarhv(pTHX_ OP *rep_op) {
9605 PERL_ARGS_ASSERT_OPT_SCALARHV;
9607 NewOp(1101, unop, 1, UNOP);
9608 unop->op_type = (OPCODE)OP_BOOLKEYS;
9609 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9610 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9611 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9612 unop->op_first = rep_op;
9613 unop->op_next = rep_op->op_next;
9614 rep_op->op_next = (OP*)unop;
9615 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9616 unop->op_sibling = rep_op->op_sibling;
9617 rep_op->op_sibling = NULL;
9618 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9619 if (rep_op->op_type == OP_PADHV) {
9620 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9621 rep_op->op_flags |= OPf_WANT_LIST;
9626 /* Check for in place reverse and sort assignments like "@a = reverse @a"
9627 and modify the optree to make them work inplace */
9630 S_inplace_aassign(pTHX_ OP *o) {
9632 OP *modop, *modop_pushmark;
9634 OP *oleft, *oleft_pushmark;
9636 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
9638 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
9640 assert(cUNOPo->op_first->op_type == OP_NULL);
9641 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
9642 assert(modop_pushmark->op_type == OP_PUSHMARK);
9643 modop = modop_pushmark->op_sibling;
9645 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
9648 /* no other operation except sort/reverse */
9649 if (modop->op_sibling)
9652 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
9653 oright = cUNOPx(modop)->op_first->op_sibling;
9655 if (modop->op_flags & OPf_STACKED) {
9656 /* skip sort subroutine/block */
9657 assert(oright->op_type == OP_NULL);
9658 oright = oright->op_sibling;
9661 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
9662 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
9663 assert(oleft_pushmark->op_type == OP_PUSHMARK);
9664 oleft = oleft_pushmark->op_sibling;
9666 /* Check the lhs is an array */
9668 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
9669 || oleft->op_sibling
9670 || (oleft->op_private & OPpLVAL_INTRO)
9674 /* Only one thing on the rhs */
9675 if (oright->op_sibling)
9678 /* check the array is the same on both sides */
9679 if (oleft->op_type == OP_RV2AV) {
9680 if (oright->op_type != OP_RV2AV
9681 || !cUNOPx(oright)->op_first
9682 || cUNOPx(oright)->op_first->op_type != OP_GV
9683 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9684 cGVOPx_gv(cUNOPx(oright)->op_first)
9688 else if (oright->op_type != OP_PADAV
9689 || oright->op_targ != oleft->op_targ
9693 /* This actually is an inplace assignment */
9695 modop->op_private |= OPpSORT_INPLACE;
9697 /* transfer MODishness etc from LHS arg to RHS arg */
9698 oright->op_flags = oleft->op_flags;
9700 /* remove the aassign op and the lhs */
9702 op_null(oleft_pushmark);
9703 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
9704 op_null(cUNOPx(oleft)->op_first);
9708 #define MAX_DEFERRED 4
9711 if (defer_ix == (MAX_DEFERRED-1)) { \
9712 CALL_RPEEP(defer_queue[defer_base]); \
9713 defer_base = (defer_base + 1) % MAX_DEFERRED; \
9716 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
9718 /* A peephole optimizer. We visit the ops in the order they're to execute.
9719 * See the comments at the top of this file for more details about when
9720 * peep() is called */
9723 Perl_rpeep(pTHX_ register OP *o)
9726 register OP* oldop = NULL;
9727 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
9731 if (!o || o->op_opt)
9735 SAVEVPTR(PL_curcop);
9736 for (;; o = o->op_next) {
9740 while (defer_ix >= 0)
9741 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
9745 /* By default, this op has now been optimised. A couple of cases below
9746 clear this again. */
9749 switch (o->op_type) {
9751 PL_curcop = ((COP*)o); /* for warnings */
9754 PL_curcop = ((COP*)o); /* for warnings */
9756 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9757 to carry two labels. For now, take the easier option, and skip
9758 this optimisation if the first NEXTSTATE has a label. */
9759 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9760 OP *nextop = o->op_next;
9761 while (nextop && nextop->op_type == OP_NULL)
9762 nextop = nextop->op_next;
9764 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9765 COP *firstcop = (COP *)o;
9766 COP *secondcop = (COP *)nextop;
9767 /* We want the COP pointed to by o (and anything else) to
9768 become the next COP down the line. */
9771 firstcop->op_next = secondcop->op_next;
9773 /* Now steal all its pointers, and duplicate the other
9775 firstcop->cop_line = secondcop->cop_line;
9777 firstcop->cop_stashpv = secondcop->cop_stashpv;
9778 firstcop->cop_file = secondcop->cop_file;
9780 firstcop->cop_stash = secondcop->cop_stash;
9781 firstcop->cop_filegv = secondcop->cop_filegv;
9783 firstcop->cop_hints = secondcop->cop_hints;
9784 firstcop->cop_seq = secondcop->cop_seq;
9785 firstcop->cop_warnings = secondcop->cop_warnings;
9786 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9789 secondcop->cop_stashpv = NULL;
9790 secondcop->cop_file = NULL;
9792 secondcop->cop_stash = NULL;
9793 secondcop->cop_filegv = NULL;
9795 secondcop->cop_warnings = NULL;
9796 secondcop->cop_hints_hash = NULL;
9798 /* If we use op_null(), and hence leave an ex-COP, some
9799 warnings are misreported. For example, the compile-time
9800 error in 'use strict; no strict refs;' */
9801 secondcop->op_type = OP_NULL;
9802 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9808 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9809 if (o->op_next->op_private & OPpTARGET_MY) {
9810 if (o->op_flags & OPf_STACKED) /* chained concats */
9811 break; /* ignore_optimization */
9813 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9814 o->op_targ = o->op_next->op_targ;
9815 o->op_next->op_targ = 0;
9816 o->op_private |= OPpTARGET_MY;
9819 op_null(o->op_next);
9823 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9824 break; /* Scalar stub must produce undef. List stub is noop */
9828 if (o->op_targ == OP_NEXTSTATE
9829 || o->op_targ == OP_DBSTATE)
9831 PL_curcop = ((COP*)o);
9833 /* XXX: We avoid setting op_seq here to prevent later calls
9834 to rpeep() from mistakenly concluding that optimisation
9835 has already occurred. This doesn't fix the real problem,
9836 though (See 20010220.007). AMS 20010719 */
9837 /* op_seq functionality is now replaced by op_opt */
9844 if (oldop && o->op_next) {
9845 oldop->op_next = o->op_next;
9853 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9854 OP* const pop = (o->op_type == OP_PADAV) ?
9855 o->op_next : o->op_next->op_next;
9857 if (pop && pop->op_type == OP_CONST &&
9858 ((PL_op = pop->op_next)) &&
9859 pop->op_next->op_type == OP_AELEM &&
9860 !(pop->op_next->op_private &
9861 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9862 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
9865 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9866 no_bareword_allowed(pop);
9867 if (o->op_type == OP_GV)
9868 op_null(o->op_next);
9869 op_null(pop->op_next);
9871 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9872 o->op_next = pop->op_next->op_next;
9873 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9874 o->op_private = (U8)i;
9875 if (o->op_type == OP_GV) {
9878 o->op_type = OP_AELEMFAST;
9881 o->op_type = OP_AELEMFAST_LEX;
9886 if (o->op_next->op_type == OP_RV2SV) {
9887 if (!(o->op_next->op_private & OPpDEREF)) {
9888 op_null(o->op_next);
9889 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9891 o->op_next = o->op_next->op_next;
9892 o->op_type = OP_GVSV;
9893 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9896 else if (o->op_next->op_type == OP_READLINE
9897 && o->op_next->op_next->op_type == OP_CONCAT
9898 && (o->op_next->op_next->op_flags & OPf_STACKED))
9900 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9901 o->op_type = OP_RCATLINE;
9902 o->op_flags |= OPf_STACKED;
9903 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9904 op_null(o->op_next->op_next);
9905 op_null(o->op_next);
9915 fop = cUNOP->op_first;
9923 fop = cLOGOP->op_first;
9924 sop = fop->op_sibling;
9925 while (cLOGOP->op_other->op_type == OP_NULL)
9926 cLOGOP->op_other = cLOGOP->op_other->op_next;
9927 while (o->op_next && ( o->op_type == o->op_next->op_type
9928 || o->op_next->op_type == OP_NULL))
9929 o->op_next = o->op_next->op_next;
9930 DEFER(cLOGOP->op_other);
9934 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9936 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9941 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9942 while (nop && nop->op_next) {
9943 switch (nop->op_next->op_type) {
9948 lop = nop = nop->op_next;
9959 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9960 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9961 cLOGOP->op_first = opt_scalarhv(fop);
9962 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9963 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9979 while (cLOGOP->op_other->op_type == OP_NULL)
9980 cLOGOP->op_other = cLOGOP->op_other->op_next;
9981 DEFER(cLOGOP->op_other);
9986 while (cLOOP->op_redoop->op_type == OP_NULL)
9987 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9988 while (cLOOP->op_nextop->op_type == OP_NULL)
9989 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9990 while (cLOOP->op_lastop->op_type == OP_NULL)
9991 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9992 /* a while(1) loop doesn't have an op_next that escapes the
9993 * loop, so we have to explicitly follow the op_lastop to
9994 * process the rest of the code */
9995 DEFER(cLOOP->op_lastop);
9999 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10000 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10001 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10002 cPMOP->op_pmstashstartu.op_pmreplstart
10003 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
10004 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
10008 /* check that RHS of sort is a single plain array */
10009 OP *oright = cUNOPo->op_first;
10010 if (!oright || oright->op_type != OP_PUSHMARK)
10013 if (o->op_private & OPpSORT_INPLACE)
10016 /* reverse sort ... can be optimised. */
10017 if (!cUNOPo->op_sibling) {
10018 /* Nothing follows us on the list. */
10019 OP * const reverse = o->op_next;
10021 if (reverse->op_type == OP_REVERSE &&
10022 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10023 OP * const pushmark = cUNOPx(reverse)->op_first;
10024 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10025 && (cUNOPx(pushmark)->op_sibling == o)) {
10026 /* reverse -> pushmark -> sort */
10027 o->op_private |= OPpSORT_REVERSE;
10029 pushmark->op_next = oright->op_next;
10039 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10041 LISTOP *enter, *exlist;
10043 if (o->op_private & OPpSORT_INPLACE)
10046 enter = (LISTOP *) o->op_next;
10049 if (enter->op_type == OP_NULL) {
10050 enter = (LISTOP *) enter->op_next;
10054 /* for $a (...) will have OP_GV then OP_RV2GV here.
10055 for (...) just has an OP_GV. */
10056 if (enter->op_type == OP_GV) {
10057 gvop = (OP *) enter;
10058 enter = (LISTOP *) enter->op_next;
10061 if (enter->op_type == OP_RV2GV) {
10062 enter = (LISTOP *) enter->op_next;
10068 if (enter->op_type != OP_ENTERITER)
10071 iter = enter->op_next;
10072 if (!iter || iter->op_type != OP_ITER)
10075 expushmark = enter->op_first;
10076 if (!expushmark || expushmark->op_type != OP_NULL
10077 || expushmark->op_targ != OP_PUSHMARK)
10080 exlist = (LISTOP *) expushmark->op_sibling;
10081 if (!exlist || exlist->op_type != OP_NULL
10082 || exlist->op_targ != OP_LIST)
10085 if (exlist->op_last != o) {
10086 /* Mmm. Was expecting to point back to this op. */
10089 theirmark = exlist->op_first;
10090 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10093 if (theirmark->op_sibling != o) {
10094 /* There's something between the mark and the reverse, eg
10095 for (1, reverse (...))
10100 ourmark = ((LISTOP *)o)->op_first;
10101 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10104 ourlast = ((LISTOP *)o)->op_last;
10105 if (!ourlast || ourlast->op_next != o)
10108 rv2av = ourmark->op_sibling;
10109 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10110 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10111 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10112 /* We're just reversing a single array. */
10113 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10114 enter->op_flags |= OPf_STACKED;
10117 /* We don't have control over who points to theirmark, so sacrifice
10119 theirmark->op_next = ourmark->op_next;
10120 theirmark->op_flags = ourmark->op_flags;
10121 ourlast->op_next = gvop ? gvop : (OP *) enter;
10124 enter->op_private |= OPpITER_REVERSED;
10125 iter->op_private |= OPpITER_REVERSED;
10132 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10133 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10138 Perl_cpeep_t cpeep =
10139 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10141 cpeep(aTHX_ o, oldop);
10152 Perl_peep(pTHX_ register OP *o)
10158 =head1 Custom Operators
10160 =for apidoc Ao||custom_op_xop
10161 Return the XOP structure for a given custom op. This function should be
10162 considered internal to OP_NAME and the other access macros: use them instead.
10168 Perl_custom_op_xop(pTHX_ const OP *o)
10174 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10176 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10177 assert(o->op_type == OP_CUSTOM);
10179 /* This is wrong. It assumes a function pointer can be cast to IV,
10180 * which isn't guaranteed, but this is what the old custom OP code
10181 * did. In principle it should be safer to Copy the bytes of the
10182 * pointer into a PV: since the new interface is hidden behind
10183 * functions, this can be changed later if necessary. */
10184 /* Change custom_op_xop if this ever happens */
10185 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10188 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10190 /* assume noone will have just registered a desc */
10191 if (!he && PL_custom_op_names &&
10192 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10197 /* XXX does all this need to be shared mem? */
10198 Newxz(xop, 1, XOP);
10199 pv = SvPV(HeVAL(he), l);
10200 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10201 if (PL_custom_op_descs &&
10202 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10204 pv = SvPV(HeVAL(he), l);
10205 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10207 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10211 if (!he) return &xop_null;
10213 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10218 =for apidoc Ao||custom_op_register
10219 Register a custom op. See L<perlguts/"Custom Operators">.
10225 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10229 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10231 /* see the comment in custom_op_xop */
10232 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10234 if (!PL_custom_ops)
10235 PL_custom_ops = newHV();
10237 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10238 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10242 =head1 Functions in file op.c
10244 =for apidoc core_prototype
10245 This function assigns the prototype of the named core function to C<sv>, or
10246 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10247 NULL if the core function has no prototype. C<code> is a code as returned
10248 by C<keyword()>. It must be negative and unequal to -KEY_CORE.
10254 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10257 int i = 0, n = 0, seen_question = 0, defgv = 0;
10259 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10260 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10261 bool nullret = FALSE;
10263 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10265 assert (code < 0 && code != -KEY_CORE);
10267 if (!sv) sv = sv_newmortal();
10269 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10272 case KEY_and : case KEY_chop: case KEY_chomp:
10273 case KEY_cmp : case KEY_exec: case KEY_eq :
10274 case KEY_ge : case KEY_gt : case KEY_le :
10275 case KEY_lt : case KEY_ne : case KEY_or :
10276 case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
10277 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10278 case KEY_keys: retsetpvs("+", OP_KEYS);
10279 case KEY_values: retsetpvs("+", OP_VALUES);
10280 case KEY_each: retsetpvs("+", OP_EACH);
10281 case KEY_push: retsetpvs("+@", OP_PUSH);
10282 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10283 case KEY_pop: retsetpvs(";+", OP_POP);
10284 case KEY_shift: retsetpvs(";+", OP_SHIFT);
10286 retsetpvs("+;$$@", OP_SPLICE);
10287 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10296 while (i < MAXO) { /* The slow way. */
10297 if (strEQ(name, PL_op_name[i])
10298 || strEQ(name, PL_op_desc[i]))
10300 if (nullret) { assert(opnum); *opnum = i; return NULL; }
10305 assert(0); return NULL; /* Should not happen... */
10307 defgv = PL_opargs[i] & OA_DEFGV;
10308 oa = PL_opargs[i] >> OASHIFT;
10310 if (oa & OA_OPTIONAL && !seen_question && (
10311 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
10316 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10317 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10318 /* But globs are already references (kinda) */
10319 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10323 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10324 && !scalar_mod_type(NULL, i)) {
10329 if (i == OP_LOCK) str[n++] = '&';
10333 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10334 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10335 str[n-1] = '_'; defgv = 0;
10339 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
10341 sv_setpvn(sv, str, n - 1);
10342 if (opnum) *opnum = i;
10347 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
10350 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
10353 PERL_ARGS_ASSERT_CORESUB_OP;
10357 return op_append_elem(OP_LINESEQ,
10360 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
10364 case OP_SELECT: /* which represents OP_SSELECT as well */
10369 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
10370 newSVOP(OP_CONST, 0, newSVuv(1))
10372 coresub_op(newSVuv((UV)OP_SSELECT), 0,
10374 coresub_op(coreargssv, 0, OP_SELECT)
10378 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10380 return op_append_elem(
10383 opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0)
10385 case OA_BASEOP_OR_UNOP:
10386 o = newUNOP(opnum,0,argop);
10387 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
10390 if (is_handle_constructor(o, 1))
10391 argop->op_private |= OPpCOREARGS_DEREF1;
10395 o = convert(opnum,0,argop);
10396 if (is_handle_constructor(o, 2))
10397 argop->op_private |= OPpCOREARGS_DEREF2;
10398 if (scalar_mod_type(NULL, opnum))
10399 argop->op_private |= OPpCOREARGS_SCALARMOD;
10400 if (opnum == OP_SUBSTR) {
10401 o->op_private |= OPpMAYBE_LVSUB;
10411 /* Efficient sub that returns a constant scalar value. */
10413 const_sv_xsub(pTHX_ CV* cv)
10417 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10421 /* diag_listed_as: SKIPME */
10422 Perl_croak(aTHX_ "usage: %s::%s()",
10423 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10436 * c-indentation-style: bsd
10437 * c-basic-offset: 4
10438 * indent-tabs-mode: t
10441 * ex: set ts=8 sts=4 sw=4 noet: