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;
993 PERL_ARGS_ASSERT_SCALARVOID;
995 /* trailing mad null ops don't count as "there" for void processing */
997 o->op_type != OP_NULL &&
999 o->op_sibling->op_type == OP_NULL)
1002 for (sib = o->op_sibling;
1003 sib && sib->op_type == OP_NULL;
1004 sib = sib->op_sibling) ;
1010 if (o->op_type == OP_NEXTSTATE
1011 || o->op_type == OP_DBSTATE
1012 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1013 || o->op_targ == OP_DBSTATE)))
1014 PL_curcop = (COP*)o; /* for warning below */
1016 /* assumes no premature commitment */
1017 want = o->op_flags & OPf_WANT;
1018 if ((want && want != OPf_WANT_SCALAR)
1019 || (PL_parser && PL_parser->error_count)
1020 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1025 if ((o->op_private & OPpTARGET_MY)
1026 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1028 return scalar(o); /* As if inside SASSIGN */
1031 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1033 switch (o->op_type) {
1035 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1039 if (o->op_flags & OPf_STACKED)
1043 if (o->op_private == 4)
1068 case OP_AELEMFAST_LEX:
1087 case OP_GETSOCKNAME:
1088 case OP_GETPEERNAME:
1093 case OP_GETPRIORITY:
1117 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1118 /* Otherwise it's "Useless use of grep iterator" */
1119 useless = OP_DESC(o);
1123 kid = cLISTOPo->op_first;
1124 if (kid && kid->op_type == OP_PUSHRE
1126 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1128 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1130 useless = OP_DESC(o);
1134 kid = cUNOPo->op_first;
1135 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1136 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1139 useless = "negative pattern binding (!~)";
1143 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1144 useless = "non-destructive substitution (s///r)";
1148 useless = "non-destructive transliteration (tr///r)";
1155 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1156 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1157 useless = "a variable";
1162 if (cSVOPo->op_private & OPpCONST_STRICT)
1163 no_bareword_allowed(o);
1165 if (ckWARN(WARN_VOID)) {
1167 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1168 "a constant (%"SVf")", sv));
1169 useless = SvPV_nolen(msv);
1172 useless = "a constant (undef)";
1173 if (o->op_private & OPpCONST_ARYBASE)
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;
1265 kid = cLOGOPo->op_first;
1266 if (kid->op_type == OP_NOT
1267 && (kid->op_flags & OPf_KIDS)
1269 if (o->op_type == OP_AND) {
1271 o->op_ppaddr = PL_ppaddr[OP_OR];
1273 o->op_type = OP_AND;
1274 o->op_ppaddr = PL_ppaddr[OP_AND];
1283 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1288 if (o->op_flags & OPf_STACKED)
1295 if (!(o->op_flags & OPf_KIDS))
1306 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1316 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1321 S_listkids(pTHX_ OP *o)
1323 if (o && o->op_flags & OPf_KIDS) {
1325 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1332 Perl_list(pTHX_ OP *o)
1337 /* assumes no premature commitment */
1338 if (!o || (o->op_flags & OPf_WANT)
1339 || (PL_parser && PL_parser->error_count)
1340 || o->op_type == OP_RETURN)
1345 if ((o->op_private & OPpTARGET_MY)
1346 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1348 return o; /* As if inside SASSIGN */
1351 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1353 switch (o->op_type) {
1356 list(cBINOPo->op_first);
1361 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1369 if (!(o->op_flags & OPf_KIDS))
1371 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1372 list(cBINOPo->op_first);
1373 return gen_constant_list(o);
1380 kid = cLISTOPo->op_first;
1382 kid = kid->op_sibling;
1385 OP *sib = kid->op_sibling;
1386 if (sib && kid->op_type != OP_LEAVEWHEN)
1392 PL_curcop = &PL_compiling;
1396 kid = cLISTOPo->op_first;
1403 S_scalarseq(pTHX_ OP *o)
1407 const OPCODE type = o->op_type;
1409 if (type == OP_LINESEQ || type == OP_SCOPE ||
1410 type == OP_LEAVE || type == OP_LEAVETRY)
1413 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1414 if (kid->op_sibling) {
1418 PL_curcop = &PL_compiling;
1420 o->op_flags &= ~OPf_PARENS;
1421 if (PL_hints & HINT_BLOCK_SCOPE)
1422 o->op_flags |= OPf_PARENS;
1425 o = newOP(OP_STUB, 0);
1430 S_modkids(pTHX_ OP *o, I32 type)
1432 if (o && o->op_flags & OPf_KIDS) {
1434 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1435 op_lvalue(kid, type);
1441 =for apidoc finalize_optree
1443 This function finalizes the optree. Should be called directly after
1444 the complete optree is built. It does some additional
1445 checking which can't be done in the normal ck_xxx functions and makes
1446 the tree thread-safe.
1451 Perl_finalize_optree(pTHX_ OP* o)
1453 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1456 SAVEVPTR(PL_curcop);
1464 S_finalize_op(pTHX_ OP* o)
1466 PERL_ARGS_ASSERT_FINALIZE_OP;
1468 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1470 /* Make sure mad ops are also thread-safe */
1471 MADPROP *mp = o->op_madprop;
1473 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1474 OP *prop_op = (OP *) mp->mad_val;
1475 /* We only need "Relocate sv to the pad for thread safety.", but this
1476 easiest way to make sure it traverses everything */
1477 if (prop_op->op_type == OP_CONST)
1478 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1479 finalize_op(prop_op);
1486 switch (o->op_type) {
1489 PL_curcop = ((COP*)o); /* for warnings */
1493 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1494 && ckWARN(WARN_SYNTAX))
1496 if (o->op_sibling->op_sibling) {
1497 const OPCODE type = o->op_sibling->op_sibling->op_type;
1498 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1499 const line_t oldline = CopLINE(PL_curcop);
1500 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1501 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1502 "Statement unlikely to be reached");
1503 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1504 "\t(Maybe you meant system() when you said exec()?)\n");
1505 CopLINE_set(PL_curcop, oldline);
1512 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1513 GV * const gv = cGVOPo_gv;
1514 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1515 /* XXX could check prototype here instead of just carping */
1516 SV * const sv = sv_newmortal();
1517 gv_efullname3(sv, gv, NULL);
1518 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1519 "%"SVf"() called too early to check prototype",
1526 if (cSVOPo->op_private & OPpCONST_STRICT)
1527 no_bareword_allowed(o);
1531 case OP_METHOD_NAMED:
1532 /* Relocate sv to the pad for thread safety.
1533 * Despite being a "constant", the SV is written to,
1534 * for reference counts, sv_upgrade() etc. */
1535 if (cSVOPo->op_sv) {
1536 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1537 if (o->op_type != OP_METHOD_NAMED &&
1538 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1540 /* If op_sv is already a PADTMP/MY then it is being used by
1541 * some pad, so make a copy. */
1542 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1543 SvREADONLY_on(PAD_SVl(ix));
1544 SvREFCNT_dec(cSVOPo->op_sv);
1546 else if (o->op_type != OP_METHOD_NAMED
1547 && cSVOPo->op_sv == &PL_sv_undef) {
1548 /* PL_sv_undef is hack - it's unsafe to store it in the
1549 AV that is the pad, because av_fetch treats values of
1550 PL_sv_undef as a "free" AV entry and will merrily
1551 replace them with a new SV, causing pad_alloc to think
1552 that this pad slot is free. (When, clearly, it is not)
1554 SvOK_off(PAD_SVl(ix));
1555 SvPADTMP_on(PAD_SVl(ix));
1556 SvREADONLY_on(PAD_SVl(ix));
1559 SvREFCNT_dec(PAD_SVl(ix));
1560 SvPADTMP_on(cSVOPo->op_sv);
1561 PAD_SETSV(ix, cSVOPo->op_sv);
1562 /* XXX I don't know how this isn't readonly already. */
1563 SvREADONLY_on(PAD_SVl(ix));
1565 cSVOPo->op_sv = NULL;
1576 const char *key = NULL;
1579 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1582 /* Make the CONST have a shared SV */
1583 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1584 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1585 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1586 key = SvPV_const(sv, keylen);
1587 lexname = newSVpvn_share(key,
1588 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1594 if ((o->op_private & (OPpLVAL_INTRO)))
1597 rop = (UNOP*)((BINOP*)o)->op_first;
1598 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1600 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1601 if (!SvPAD_TYPED(lexname))
1603 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1604 if (!fields || !GvHV(*fields))
1606 key = SvPV_const(*svp, keylen);
1607 if (!hv_fetch(GvHV(*fields), key,
1608 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1609 Perl_croak(aTHX_ "No such class field \"%s\" "
1610 "in variable %s of type %s",
1611 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
1623 SVOP *first_key_op, *key_op;
1625 if ((o->op_private & (OPpLVAL_INTRO))
1626 /* I bet there's always a pushmark... */
1627 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1628 /* hmmm, no optimization if list contains only one key. */
1630 rop = (UNOP*)((LISTOP*)o)->op_last;
1631 if (rop->op_type != OP_RV2HV)
1633 if (rop->op_first->op_type == OP_PADSV)
1634 /* @$hash{qw(keys here)} */
1635 rop = (UNOP*)rop->op_first;
1637 /* @{$hash}{qw(keys here)} */
1638 if (rop->op_first->op_type == OP_SCOPE
1639 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1641 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1647 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1648 if (!SvPAD_TYPED(lexname))
1650 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1651 if (!fields || !GvHV(*fields))
1653 /* Again guessing that the pushmark can be jumped over.... */
1654 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1655 ->op_first->op_sibling;
1656 for (key_op = first_key_op; key_op;
1657 key_op = (SVOP*)key_op->op_sibling) {
1658 if (key_op->op_type != OP_CONST)
1660 svp = cSVOPx_svp(key_op);
1661 key = SvPV_const(*svp, keylen);
1662 if (!hv_fetch(GvHV(*fields), key,
1663 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1664 Perl_croak(aTHX_ "No such class field \"%s\" "
1665 "in variable %s of type %s",
1666 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
1672 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1673 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1680 if (o->op_flags & OPf_KIDS) {
1682 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1688 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1690 Propagate lvalue ("modifiable") context to an op and its children.
1691 I<type> represents the context type, roughly based on the type of op that
1692 would do the modifying, although C<local()> is represented by OP_NULL,
1693 because it has no op type of its own (it is signalled by a flag on
1696 This function detects things that can't be modified, such as C<$x+1>, and
1697 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1698 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1700 It also flags things that need to behave specially in an lvalue context,
1701 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1707 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1711 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1714 if (!o || (PL_parser && PL_parser->error_count))
1717 if ((o->op_private & OPpTARGET_MY)
1718 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1723 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1725 switch (o->op_type) {
1731 if (!(o->op_private & OPpCONST_ARYBASE))
1734 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1735 CopARYBASE_set(&PL_compiling,
1736 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1740 SAVECOPARYBASE(&PL_compiling);
1741 CopARYBASE_set(&PL_compiling, 0);
1743 else if (type == OP_REFGEN)
1746 Perl_croak(aTHX_ "That use of $[ is unsupported");
1749 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1753 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1754 !(o->op_flags & OPf_STACKED)) {
1755 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1756 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1757 poses, so we need it clear. */
1758 o->op_private &= ~1;
1759 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1760 assert(cUNOPo->op_first->op_type == OP_NULL);
1761 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1764 else { /* lvalue subroutine call */
1765 o->op_private |= OPpLVAL_INTRO
1766 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1767 PL_modcount = RETURN_UNLIMITED_NUMBER;
1768 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1769 /* Backward compatibility mode: */
1770 o->op_private |= OPpENTERSUB_INARGS;
1773 else { /* Compile-time error message: */
1774 OP *kid = cUNOPo->op_first;
1778 if (kid->op_type != OP_PUSHMARK) {
1779 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1781 "panic: unexpected lvalue entersub "
1782 "args: type/targ %ld:%"UVuf,
1783 (long)kid->op_type, (UV)kid->op_targ);
1784 kid = kLISTOP->op_first;
1786 while (kid->op_sibling)
1787 kid = kid->op_sibling;
1788 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1790 if (kid->op_type == OP_METHOD_NAMED
1791 || kid->op_type == OP_METHOD)
1795 NewOp(1101, newop, 1, UNOP);
1796 newop->op_type = OP_RV2CV;
1797 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1798 newop->op_first = NULL;
1799 newop->op_next = (OP*)newop;
1800 kid->op_sibling = (OP*)newop;
1801 newop->op_private |= OPpLVAL_INTRO;
1802 newop->op_private &= ~1;
1806 if (kid->op_type != OP_RV2CV)
1808 "panic: unexpected lvalue entersub "
1809 "entry via type/targ %ld:%"UVuf,
1810 (long)kid->op_type, (UV)kid->op_targ);
1811 kid->op_private |= OPpLVAL_INTRO;
1812 break; /* Postpone until runtime */
1816 kid = kUNOP->op_first;
1817 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1818 kid = kUNOP->op_first;
1819 if (kid->op_type == OP_NULL)
1821 "Unexpected constant lvalue entersub "
1822 "entry via type/targ %ld:%"UVuf,
1823 (long)kid->op_type, (UV)kid->op_targ);
1824 if (kid->op_type != OP_GV) {
1825 /* Restore RV2CV to check lvalueness */
1827 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1828 okid->op_next = kid->op_next;
1829 kid->op_next = okid;
1832 okid->op_next = NULL;
1833 okid->op_type = OP_RV2CV;
1835 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1836 okid->op_private |= OPpLVAL_INTRO;
1837 okid->op_private &= ~1;
1841 cv = GvCV(kGVOP_gv);
1851 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1852 /* grep, foreach, subcalls, refgen */
1853 if (type == OP_GREPSTART || type == OP_ENTERSUB
1854 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1856 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1857 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1859 : (o->op_type == OP_ENTERSUB
1860 ? "non-lvalue subroutine call"
1862 type ? PL_op_desc[type] : "local"));
1876 case OP_RIGHT_SHIFT:
1885 if (!(o->op_flags & OPf_STACKED))
1892 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1893 op_lvalue(kid, type);
1898 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1899 PL_modcount = RETURN_UNLIMITED_NUMBER;
1900 return o; /* Treat \(@foo) like ordinary list. */
1904 if (scalar_mod_type(o, type))
1906 ref(cUNOPo->op_first, o->op_type);
1910 if (type == OP_LEAVESUBLV)
1911 o->op_private |= OPpMAYBE_LVSUB;
1917 PL_modcount = RETURN_UNLIMITED_NUMBER;
1920 PL_hints |= HINT_BLOCK_SCOPE;
1921 if (type == OP_LEAVESUBLV)
1922 o->op_private |= OPpMAYBE_LVSUB;
1926 ref(cUNOPo->op_first, o->op_type);
1930 PL_hints |= HINT_BLOCK_SCOPE;
1939 case OP_AELEMFAST_LEX:
1946 PL_modcount = RETURN_UNLIMITED_NUMBER;
1947 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1948 return o; /* Treat \(@foo) like ordinary list. */
1949 if (scalar_mod_type(o, type))
1951 if (type == OP_LEAVESUBLV)
1952 o->op_private |= OPpMAYBE_LVSUB;
1956 if (!type) /* local() */
1957 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1958 PAD_COMPNAME_SV(o->op_targ));
1967 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1971 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1977 if (type == OP_LEAVESUBLV)
1978 o->op_private |= OPpMAYBE_LVSUB;
1979 pad_free(o->op_targ);
1980 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1981 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1982 if (o->op_flags & OPf_KIDS)
1983 op_lvalue(cBINOPo->op_first->op_sibling, type);
1988 ref(cBINOPo->op_first, o->op_type);
1989 if (type == OP_ENTERSUB &&
1990 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1991 o->op_private |= OPpLVAL_DEFER;
1992 if (type == OP_LEAVESUBLV)
1993 o->op_private |= OPpMAYBE_LVSUB;
2003 if (o->op_flags & OPf_KIDS)
2004 op_lvalue(cLISTOPo->op_last, type);
2009 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2011 else if (!(o->op_flags & OPf_KIDS))
2013 if (o->op_targ != OP_LIST) {
2014 op_lvalue(cBINOPo->op_first, type);
2020 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2021 /* elements might be in void context because the list is
2022 in scalar context or because they are attribute sub calls */
2023 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2024 op_lvalue(kid, type);
2028 if (type != OP_LEAVESUBLV)
2030 break; /* op_lvalue()ing was handled by ck_return() */
2033 /* [20011101.069] File test operators interpret OPf_REF to mean that
2034 their argument is a filehandle; thus \stat(".") should not set
2036 if (type == OP_REFGEN &&
2037 PL_check[o->op_type] == Perl_ck_ftst)
2040 if (type != OP_LEAVESUBLV)
2041 o->op_flags |= OPf_MOD;
2043 if (type == OP_AASSIGN || type == OP_SASSIGN)
2044 o->op_flags |= OPf_SPECIAL|OPf_REF;
2045 else if (!type) { /* local() */
2048 o->op_private |= OPpLVAL_INTRO;
2049 o->op_flags &= ~OPf_SPECIAL;
2050 PL_hints |= HINT_BLOCK_SCOPE;
2055 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2056 "Useless localization of %s", OP_DESC(o));
2059 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2060 && type != OP_LEAVESUBLV)
2061 o->op_flags |= OPf_REF;
2066 S_scalar_mod_type(const OP *o, I32 type)
2068 assert(o || type != OP_SASSIGN);
2072 if (o->op_type == OP_RV2GV)
2096 case OP_RIGHT_SHIFT:
2117 S_is_handle_constructor(const OP *o, I32 numargs)
2119 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2121 switch (o->op_type) {
2129 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2142 S_refkids(pTHX_ OP *o, I32 type)
2144 if (o && o->op_flags & OPf_KIDS) {
2146 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2153 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2158 PERL_ARGS_ASSERT_DOREF;
2160 if (!o || (PL_parser && PL_parser->error_count))
2163 switch (o->op_type) {
2165 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2166 !(o->op_flags & OPf_STACKED)) {
2167 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2168 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2169 assert(cUNOPo->op_first->op_type == OP_NULL);
2170 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2171 o->op_flags |= OPf_SPECIAL;
2172 o->op_private &= ~1;
2174 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2175 o->op_private |= OPpENTERSUB_DEREF;
2176 o->op_flags |= OPf_MOD;
2182 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2183 doref(kid, type, set_op_ref);
2186 if (type == OP_DEFINED)
2187 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2188 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2191 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2192 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2193 : type == OP_RV2HV ? OPpDEREF_HV
2195 o->op_flags |= OPf_MOD;
2202 o->op_flags |= OPf_REF;
2205 if (type == OP_DEFINED)
2206 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2207 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2213 o->op_flags |= OPf_REF;
2218 if (!(o->op_flags & OPf_KIDS))
2220 doref(cBINOPo->op_first, type, set_op_ref);
2224 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2225 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2226 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2227 : type == OP_RV2HV ? OPpDEREF_HV
2229 o->op_flags |= OPf_MOD;
2239 if (!(o->op_flags & OPf_KIDS))
2241 doref(cLISTOPo->op_last, type, set_op_ref);
2251 S_dup_attrlist(pTHX_ OP *o)
2256 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2258 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2259 * where the first kid is OP_PUSHMARK and the remaining ones
2260 * are OP_CONST. We need to push the OP_CONST values.
2262 if (o->op_type == OP_CONST)
2263 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2265 else if (o->op_type == OP_NULL)
2269 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2271 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2272 if (o->op_type == OP_CONST)
2273 rop = op_append_elem(OP_LIST, rop,
2274 newSVOP(OP_CONST, o->op_flags,
2275 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2282 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2287 PERL_ARGS_ASSERT_APPLY_ATTRS;
2289 /* fake up C<use attributes $pkg,$rv,@attrs> */
2290 ENTER; /* need to protect against side-effects of 'use' */
2291 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2293 #define ATTRSMODULE "attributes"
2294 #define ATTRSMODULE_PM "attributes.pm"
2297 /* Don't force the C<use> if we don't need it. */
2298 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2299 if (svp && *svp != &PL_sv_undef)
2300 NOOP; /* already in %INC */
2302 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2303 newSVpvs(ATTRSMODULE), NULL);
2306 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2307 newSVpvs(ATTRSMODULE),
2309 op_prepend_elem(OP_LIST,
2310 newSVOP(OP_CONST, 0, stashsv),
2311 op_prepend_elem(OP_LIST,
2312 newSVOP(OP_CONST, 0,
2314 dup_attrlist(attrs))));
2320 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2323 OP *pack, *imop, *arg;
2326 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2331 assert(target->op_type == OP_PADSV ||
2332 target->op_type == OP_PADHV ||
2333 target->op_type == OP_PADAV);
2335 /* Ensure that attributes.pm is loaded. */
2336 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2338 /* Need package name for method call. */
2339 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2341 /* Build up the real arg-list. */
2342 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2344 arg = newOP(OP_PADSV, 0);
2345 arg->op_targ = target->op_targ;
2346 arg = op_prepend_elem(OP_LIST,
2347 newSVOP(OP_CONST, 0, stashsv),
2348 op_prepend_elem(OP_LIST,
2349 newUNOP(OP_REFGEN, 0,
2350 op_lvalue(arg, OP_REFGEN)),
2351 dup_attrlist(attrs)));
2353 /* Fake up a method call to import */
2354 meth = newSVpvs_share("import");
2355 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2356 op_append_elem(OP_LIST,
2357 op_prepend_elem(OP_LIST, pack, list(arg)),
2358 newSVOP(OP_METHOD_NAMED, 0, meth)));
2360 /* Combine the ops. */
2361 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2365 =notfor apidoc apply_attrs_string
2367 Attempts to apply a list of attributes specified by the C<attrstr> and
2368 C<len> arguments to the subroutine identified by the C<cv> argument which
2369 is expected to be associated with the package identified by the C<stashpv>
2370 argument (see L<attributes>). It gets this wrong, though, in that it
2371 does not correctly identify the boundaries of the individual attribute
2372 specifications within C<attrstr>. This is not really intended for the
2373 public API, but has to be listed here for systems such as AIX which
2374 need an explicit export list for symbols. (It's called from XS code
2375 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2376 to respect attribute syntax properly would be welcome.
2382 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2383 const char *attrstr, STRLEN len)
2387 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2390 len = strlen(attrstr);
2394 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2396 const char * const sstr = attrstr;
2397 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2398 attrs = op_append_elem(OP_LIST, attrs,
2399 newSVOP(OP_CONST, 0,
2400 newSVpvn(sstr, attrstr-sstr)));
2404 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2405 newSVpvs(ATTRSMODULE),
2406 NULL, op_prepend_elem(OP_LIST,
2407 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2408 op_prepend_elem(OP_LIST,
2409 newSVOP(OP_CONST, 0,
2410 newRV(MUTABLE_SV(cv))),
2415 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2419 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2421 PERL_ARGS_ASSERT_MY_KID;
2423 if (!o || (PL_parser && PL_parser->error_count))
2427 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2428 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2432 if (type == OP_LIST) {
2434 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2435 my_kid(kid, attrs, imopsp);
2436 } else if (type == OP_UNDEF
2442 } else if (type == OP_RV2SV || /* "our" declaration */
2444 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2445 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2446 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2448 PL_parser->in_my == KEY_our
2450 : PL_parser->in_my == KEY_state ? "state" : "my"));
2452 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2453 PL_parser->in_my = FALSE;
2454 PL_parser->in_my_stash = NULL;
2455 apply_attrs(GvSTASH(gv),
2456 (type == OP_RV2SV ? GvSV(gv) :
2457 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2458 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2461 o->op_private |= OPpOUR_INTRO;
2464 else if (type != OP_PADSV &&
2467 type != OP_PUSHMARK)
2469 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2471 PL_parser->in_my == KEY_our
2473 : PL_parser->in_my == KEY_state ? "state" : "my"));
2476 else if (attrs && type != OP_PUSHMARK) {
2479 PL_parser->in_my = FALSE;
2480 PL_parser->in_my_stash = NULL;
2482 /* check for C<my Dog $spot> when deciding package */
2483 stash = PAD_COMPNAME_TYPE(o->op_targ);
2485 stash = PL_curstash;
2486 apply_attrs_my(stash, o, attrs, imopsp);
2488 o->op_flags |= OPf_MOD;
2489 o->op_private |= OPpLVAL_INTRO;
2491 o->op_private |= OPpPAD_STATE;
2496 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2500 int maybe_scalar = 0;
2502 PERL_ARGS_ASSERT_MY_ATTRS;
2504 /* [perl #17376]: this appears to be premature, and results in code such as
2505 C< our(%x); > executing in list mode rather than void mode */
2507 if (o->op_flags & OPf_PARENS)
2517 o = my_kid(o, attrs, &rops);
2519 if (maybe_scalar && o->op_type == OP_PADSV) {
2520 o = scalar(op_append_list(OP_LIST, rops, o));
2521 o->op_private |= OPpLVAL_INTRO;
2524 /* The listop in rops might have a pushmark at the beginning,
2525 which will mess up list assignment. */
2526 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2527 if (rops->op_type == OP_LIST &&
2528 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2530 OP * const pushmark = lrops->op_first;
2531 lrops->op_first = pushmark->op_sibling;
2534 o = op_append_list(OP_LIST, o, rops);
2537 PL_parser->in_my = FALSE;
2538 PL_parser->in_my_stash = NULL;
2543 Perl_sawparens(pTHX_ OP *o)
2545 PERL_UNUSED_CONTEXT;
2547 o->op_flags |= OPf_PARENS;
2552 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2556 const OPCODE ltype = left->op_type;
2557 const OPCODE rtype = right->op_type;
2559 PERL_ARGS_ASSERT_BIND_MATCH;
2561 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2562 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2564 const char * const desc
2566 rtype == OP_SUBST || rtype == OP_TRANS
2567 || rtype == OP_TRANSR
2569 ? (int)rtype : OP_MATCH];
2570 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2571 ? "@array" : "%hash");
2572 Perl_warner(aTHX_ packWARN(WARN_MISC),
2573 "Applying %s to %s will act on scalar(%s)",
2574 desc, sample, sample);
2577 if (rtype == OP_CONST &&
2578 cSVOPx(right)->op_private & OPpCONST_BARE &&
2579 cSVOPx(right)->op_private & OPpCONST_STRICT)
2581 no_bareword_allowed(right);
2584 /* !~ doesn't make sense with /r, so error on it for now */
2585 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2587 yyerror("Using !~ with s///r doesn't make sense");
2588 if (rtype == OP_TRANSR && type == OP_NOT)
2589 yyerror("Using !~ with tr///r doesn't make sense");
2591 ismatchop = (rtype == OP_MATCH ||
2592 rtype == OP_SUBST ||
2593 rtype == OP_TRANS || rtype == OP_TRANSR)
2594 && !(right->op_flags & OPf_SPECIAL);
2595 if (ismatchop && right->op_private & OPpTARGET_MY) {
2597 right->op_private &= ~OPpTARGET_MY;
2599 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2602 right->op_flags |= OPf_STACKED;
2603 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2604 ! (rtype == OP_TRANS &&
2605 right->op_private & OPpTRANS_IDENTICAL) &&
2606 ! (rtype == OP_SUBST &&
2607 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2608 newleft = op_lvalue(left, rtype);
2611 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2612 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2614 o = op_prepend_elem(rtype, scalar(newleft), right);
2616 return newUNOP(OP_NOT, 0, scalar(o));
2620 return bind_match(type, left,
2621 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2625 Perl_invert(pTHX_ OP *o)
2629 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2633 =for apidoc Amx|OP *|op_scope|OP *o
2635 Wraps up an op tree with some additional ops so that at runtime a dynamic
2636 scope will be created. The original ops run in the new dynamic scope,
2637 and then, provided that they exit normally, the scope will be unwound.
2638 The additional ops used to create and unwind the dynamic scope will
2639 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2640 instead if the ops are simple enough to not need the full dynamic scope
2647 Perl_op_scope(pTHX_ OP *o)
2651 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2652 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2653 o->op_type = OP_LEAVE;
2654 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2656 else if (o->op_type == OP_LINESEQ) {
2658 o->op_type = OP_SCOPE;
2659 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2660 kid = ((LISTOP*)o)->op_first;
2661 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2664 /* The following deals with things like 'do {1 for 1}' */
2665 kid = kid->op_sibling;
2667 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2672 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2678 Perl_block_start(pTHX_ int full)
2681 const int retval = PL_savestack_ix;
2683 pad_block_start(full);
2685 PL_hints &= ~HINT_BLOCK_SCOPE;
2686 SAVECOMPILEWARNINGS();
2687 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2689 CALL_BLOCK_HOOKS(bhk_start, full);
2695 Perl_block_end(pTHX_ I32 floor, OP *seq)
2698 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2699 OP* retval = scalarseq(seq);
2701 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2704 CopHINTS_set(&PL_compiling, PL_hints);
2706 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2709 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2715 =head1 Compile-time scope hooks
2717 =for apidoc Aox||blockhook_register
2719 Register a set of hooks to be called when the Perl lexical scope changes
2720 at compile time. See L<perlguts/"Compile-time scope hooks">.
2726 Perl_blockhook_register(pTHX_ BHK *hk)
2728 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2730 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2737 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2738 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2739 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2742 OP * const o = newOP(OP_PADSV, 0);
2743 o->op_targ = offset;
2749 Perl_newPROG(pTHX_ OP *o)
2753 PERL_ARGS_ASSERT_NEWPROG;
2759 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2760 ((PL_in_eval & EVAL_KEEPERR)
2761 ? OPf_SPECIAL : 0), o);
2763 cx = &cxstack[cxstack_ix];
2764 assert(CxTYPE(cx) == CXt_EVAL);
2766 if ((cx->blk_gimme & G_WANT) == G_VOID)
2767 scalarvoid(PL_eval_root);
2768 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2771 scalar(PL_eval_root);
2773 /* don't use LINKLIST, since PL_eval_root might indirect through
2774 * a rather expensive function call and LINKLIST evaluates its
2775 * argument more than once */
2776 PL_eval_start = op_linklist(PL_eval_root);
2777 PL_eval_root->op_private |= OPpREFCOUNTED;
2778 OpREFCNT_set(PL_eval_root, 1);
2779 PL_eval_root->op_next = 0;
2780 CALL_PEEP(PL_eval_start);
2781 finalize_optree(PL_eval_root);
2785 if (o->op_type == OP_STUB) {
2786 PL_comppad_name = 0;
2788 S_op_destroy(aTHX_ o);
2791 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2792 PL_curcop = &PL_compiling;
2793 PL_main_start = LINKLIST(PL_main_root);
2794 PL_main_root->op_private |= OPpREFCOUNTED;
2795 OpREFCNT_set(PL_main_root, 1);
2796 PL_main_root->op_next = 0;
2797 CALL_PEEP(PL_main_start);
2798 finalize_optree(PL_main_root);
2801 /* Register with debugger */
2803 CV * const cv = get_cvs("DB::postponed", 0);
2807 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2809 call_sv(MUTABLE_SV(cv), G_DISCARD);
2816 Perl_localize(pTHX_ OP *o, I32 lex)
2820 PERL_ARGS_ASSERT_LOCALIZE;
2822 if (o->op_flags & OPf_PARENS)
2823 /* [perl #17376]: this appears to be premature, and results in code such as
2824 C< our(%x); > executing in list mode rather than void mode */
2831 if ( PL_parser->bufptr > PL_parser->oldbufptr
2832 && PL_parser->bufptr[-1] == ','
2833 && ckWARN(WARN_PARENTHESIS))
2835 char *s = PL_parser->bufptr;
2838 /* some heuristics to detect a potential error */
2839 while (*s && (strchr(", \t\n", *s)))
2843 if (*s && strchr("@$%*", *s) && *++s
2844 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2847 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2849 while (*s && (strchr(", \t\n", *s)))
2855 if (sigil && (*s == ';' || *s == '=')) {
2856 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2857 "Parentheses missing around \"%s\" list",
2859 ? (PL_parser->in_my == KEY_our
2861 : PL_parser->in_my == KEY_state
2871 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2872 PL_parser->in_my = FALSE;
2873 PL_parser->in_my_stash = NULL;
2878 Perl_jmaybe(pTHX_ OP *o)
2880 PERL_ARGS_ASSERT_JMAYBE;
2882 if (o->op_type == OP_LIST) {
2884 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2885 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2891 S_fold_constants(pTHX_ register OP *o)
2894 register OP * VOL curop;
2896 VOL I32 type = o->op_type;
2901 SV * const oldwarnhook = PL_warnhook;
2902 SV * const olddiehook = PL_diehook;
2906 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2908 if (PL_opargs[type] & OA_RETSCALAR)
2910 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2911 o->op_targ = pad_alloc(type, SVs_PADTMP);
2913 /* integerize op, unless it happens to be C<-foo>.
2914 * XXX should pp_i_negate() do magic string negation instead? */
2915 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2916 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2917 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2919 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2922 if (!(PL_opargs[type] & OA_FOLDCONST))
2927 /* XXX might want a ck_negate() for this */
2928 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2940 /* XXX what about the numeric ops? */
2941 if (PL_hints & HINT_LOCALE)
2946 if (PL_parser && PL_parser->error_count)
2947 goto nope; /* Don't try to run w/ errors */
2949 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2950 const OPCODE type = curop->op_type;
2951 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2953 type != OP_SCALAR &&
2955 type != OP_PUSHMARK)
2961 curop = LINKLIST(o);
2962 old_next = o->op_next;
2966 oldscope = PL_scopestack_ix;
2967 create_eval_scope(G_FAKINGEVAL);
2969 /* Verify that we don't need to save it: */
2970 assert(PL_curcop == &PL_compiling);
2971 StructCopy(&PL_compiling, ¬_compiling, COP);
2972 PL_curcop = ¬_compiling;
2973 /* The above ensures that we run with all the correct hints of the
2974 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2975 assert(IN_PERL_RUNTIME);
2976 PL_warnhook = PERL_WARNHOOK_FATAL;
2983 sv = *(PL_stack_sp--);
2984 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2986 /* Can't simply swipe the SV from the pad, because that relies on
2987 the op being freed "real soon now". Under MAD, this doesn't
2988 happen (see the #ifdef below). */
2991 pad_swipe(o->op_targ, FALSE);
2994 else if (SvTEMP(sv)) { /* grab mortal temp? */
2995 SvREFCNT_inc_simple_void(sv);
3000 /* Something tried to die. Abandon constant folding. */
3001 /* Pretend the error never happened. */
3003 o->op_next = old_next;
3007 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3008 PL_warnhook = oldwarnhook;
3009 PL_diehook = olddiehook;
3010 /* XXX note that this croak may fail as we've already blown away
3011 * the stack - eg any nested evals */
3012 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3015 PL_warnhook = oldwarnhook;
3016 PL_diehook = olddiehook;
3017 PL_curcop = &PL_compiling;
3019 if (PL_scopestack_ix > oldscope)
3020 delete_eval_scope();
3029 if (type == OP_RV2GV)
3030 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3032 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3033 op_getmad(o,newop,'f');
3041 S_gen_constant_list(pTHX_ register OP *o)
3045 const I32 oldtmps_floor = PL_tmps_floor;
3048 if (PL_parser && PL_parser->error_count)
3049 return o; /* Don't attempt to run with errors */
3051 PL_op = curop = LINKLIST(o);
3054 Perl_pp_pushmark(aTHX);
3057 assert (!(curop->op_flags & OPf_SPECIAL));
3058 assert(curop->op_type == OP_RANGE);
3059 Perl_pp_anonlist(aTHX);
3060 PL_tmps_floor = oldtmps_floor;
3062 o->op_type = OP_RV2AV;
3063 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3064 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3065 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3066 o->op_opt = 0; /* needs to be revisited in rpeep() */
3067 curop = ((UNOP*)o)->op_first;
3068 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3070 op_getmad(curop,o,'O');
3079 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3082 if (!o || o->op_type != OP_LIST)
3083 o = newLISTOP(OP_LIST, 0, o, NULL);
3085 o->op_flags &= ~OPf_WANT;
3087 if (!(PL_opargs[type] & OA_MARK))
3088 op_null(cLISTOPo->op_first);
3090 o->op_type = (OPCODE)type;
3091 o->op_ppaddr = PL_ppaddr[type];
3092 o->op_flags |= flags;
3094 o = CHECKOP(type, o);
3095 if (o->op_type != (unsigned)type)
3098 return fold_constants(o);
3102 =head1 Optree Manipulation Functions
3105 /* List constructors */
3108 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3110 Append an item to the list of ops contained directly within a list-type
3111 op, returning the lengthened list. I<first> is the list-type op,
3112 and I<last> is the op to append to the list. I<optype> specifies the
3113 intended opcode for the list. If I<first> is not already a list of the
3114 right type, it will be upgraded into one. If either I<first> or I<last>
3115 is null, the other is returned unchanged.
3121 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3129 if (first->op_type != (unsigned)type
3130 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3132 return newLISTOP(type, 0, first, last);
3135 if (first->op_flags & OPf_KIDS)
3136 ((LISTOP*)first)->op_last->op_sibling = last;
3138 first->op_flags |= OPf_KIDS;
3139 ((LISTOP*)first)->op_first = last;
3141 ((LISTOP*)first)->op_last = last;
3146 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3148 Concatenate the lists of ops contained directly within two list-type ops,
3149 returning the combined list. I<first> and I<last> are the list-type ops
3150 to concatenate. I<optype> specifies the intended opcode for the list.
3151 If either I<first> or I<last> is not already a list of the right type,
3152 it will be upgraded into one. If either I<first> or I<last> is null,
3153 the other is returned unchanged.
3159 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3167 if (first->op_type != (unsigned)type)
3168 return op_prepend_elem(type, first, last);
3170 if (last->op_type != (unsigned)type)
3171 return op_append_elem(type, first, last);
3173 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3174 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3175 first->op_flags |= (last->op_flags & OPf_KIDS);
3178 if (((LISTOP*)last)->op_first && first->op_madprop) {
3179 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3181 while (mp->mad_next)
3183 mp->mad_next = first->op_madprop;
3186 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3189 first->op_madprop = last->op_madprop;
3190 last->op_madprop = 0;
3193 S_op_destroy(aTHX_ last);
3199 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3201 Prepend an item to the list of ops contained directly within a list-type
3202 op, returning the lengthened list. I<first> is the op to prepend to the
3203 list, and I<last> is the list-type op. I<optype> specifies the intended
3204 opcode for the list. If I<last> is not already a list of the right type,
3205 it will be upgraded into one. If either I<first> or I<last> is null,
3206 the other is returned unchanged.
3212 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3220 if (last->op_type == (unsigned)type) {
3221 if (type == OP_LIST) { /* already a PUSHMARK there */
3222 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3223 ((LISTOP*)last)->op_first->op_sibling = first;
3224 if (!(first->op_flags & OPf_PARENS))
3225 last->op_flags &= ~OPf_PARENS;
3228 if (!(last->op_flags & OPf_KIDS)) {
3229 ((LISTOP*)last)->op_last = first;
3230 last->op_flags |= OPf_KIDS;
3232 first->op_sibling = ((LISTOP*)last)->op_first;
3233 ((LISTOP*)last)->op_first = first;
3235 last->op_flags |= OPf_KIDS;
3239 return newLISTOP(type, 0, first, last);
3247 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3250 Newxz(tk, 1, TOKEN);
3251 tk->tk_type = (OPCODE)optype;
3252 tk->tk_type = 12345;
3254 tk->tk_mad = madprop;
3259 Perl_token_free(pTHX_ TOKEN* tk)
3261 PERL_ARGS_ASSERT_TOKEN_FREE;
3263 if (tk->tk_type != 12345)
3265 mad_free(tk->tk_mad);
3270 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3275 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3277 if (tk->tk_type != 12345) {
3278 Perl_warner(aTHX_ packWARN(WARN_MISC),
3279 "Invalid TOKEN object ignored");
3286 /* faked up qw list? */
3288 tm->mad_type == MAD_SV &&
3289 SvPVX((SV *)tm->mad_val)[0] == 'q')
3296 /* pretend constant fold didn't happen? */
3297 if (mp->mad_key == 'f' &&
3298 (o->op_type == OP_CONST ||
3299 o->op_type == OP_GV) )
3301 token_getmad(tk,(OP*)mp->mad_val,slot);
3315 if (mp->mad_key == 'X')
3316 mp->mad_key = slot; /* just change the first one */
3326 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3335 /* pretend constant fold didn't happen? */
3336 if (mp->mad_key == 'f' &&
3337 (o->op_type == OP_CONST ||
3338 o->op_type == OP_GV) )
3340 op_getmad(from,(OP*)mp->mad_val,slot);
3347 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3350 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3356 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3365 /* pretend constant fold didn't happen? */
3366 if (mp->mad_key == 'f' &&
3367 (o->op_type == OP_CONST ||
3368 o->op_type == OP_GV) )
3370 op_getmad(from,(OP*)mp->mad_val,slot);
3377 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3380 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3384 PerlIO_printf(PerlIO_stderr(),
3385 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3391 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3409 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3413 addmad(tm, &(o->op_madprop), slot);
3417 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3438 Perl_newMADsv(pTHX_ char key, SV* sv)
3440 PERL_ARGS_ASSERT_NEWMADSV;
3442 return newMADPROP(key, MAD_SV, sv, 0);
3446 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3448 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3451 mp->mad_vlen = vlen;
3452 mp->mad_type = type;
3454 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3459 Perl_mad_free(pTHX_ MADPROP* mp)
3461 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3465 mad_free(mp->mad_next);
3466 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3467 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3468 switch (mp->mad_type) {
3472 Safefree((char*)mp->mad_val);
3475 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3476 op_free((OP*)mp->mad_val);
3479 sv_free(MUTABLE_SV(mp->mad_val));
3482 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3485 PerlMemShared_free(mp);
3491 =head1 Optree construction
3493 =for apidoc Am|OP *|newNULLLIST
3495 Constructs, checks, and returns a new C<stub> op, which represents an
3496 empty list expression.
3502 Perl_newNULLLIST(pTHX)
3504 return newOP(OP_STUB, 0);
3508 S_force_list(pTHX_ OP *o)
3510 if (!o || o->op_type != OP_LIST)
3511 o = newLISTOP(OP_LIST, 0, o, NULL);
3517 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3519 Constructs, checks, and returns an op of any list type. I<type> is
3520 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3521 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3522 supply up to two ops to be direct children of the list op; they are
3523 consumed by this function and become part of the constructed op tree.
3529 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3534 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3536 NewOp(1101, listop, 1, LISTOP);
3538 listop->op_type = (OPCODE)type;
3539 listop->op_ppaddr = PL_ppaddr[type];
3542 listop->op_flags = (U8)flags;
3546 else if (!first && last)
3549 first->op_sibling = last;
3550 listop->op_first = first;
3551 listop->op_last = last;
3552 if (type == OP_LIST) {
3553 OP* const pushop = newOP(OP_PUSHMARK, 0);
3554 pushop->op_sibling = first;
3555 listop->op_first = pushop;
3556 listop->op_flags |= OPf_KIDS;
3558 listop->op_last = pushop;
3561 return CHECKOP(type, listop);
3565 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3567 Constructs, checks, and returns an op of any base type (any type that
3568 has no extra fields). I<type> is the opcode. I<flags> gives the
3569 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3576 Perl_newOP(pTHX_ I32 type, I32 flags)
3581 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3582 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3583 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3584 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3586 NewOp(1101, o, 1, OP);
3587 o->op_type = (OPCODE)type;
3588 o->op_ppaddr = PL_ppaddr[type];
3589 o->op_flags = (U8)flags;
3591 o->op_latefreed = 0;
3595 o->op_private = (U8)(0 | (flags >> 8));
3596 if (PL_opargs[type] & OA_RETSCALAR)
3598 if (PL_opargs[type] & OA_TARGET)
3599 o->op_targ = pad_alloc(type, SVs_PADTMP);
3600 return CHECKOP(type, o);
3604 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3606 Constructs, checks, and returns an op of any unary type. I<type> is
3607 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3608 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3609 bits, the eight bits of C<op_private>, except that the bit with value 1
3610 is automatically set. I<first> supplies an optional op to be the direct
3611 child of the unary op; it is consumed by this function and become part
3612 of the constructed op tree.
3618 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3623 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3624 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3625 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3626 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3627 || type == OP_SASSIGN
3628 || type == OP_ENTERTRY
3629 || type == OP_NULL );
3632 first = newOP(OP_STUB, 0);
3633 if (PL_opargs[type] & OA_MARK)
3634 first = force_list(first);
3636 NewOp(1101, unop, 1, UNOP);
3637 unop->op_type = (OPCODE)type;
3638 unop->op_ppaddr = PL_ppaddr[type];
3639 unop->op_first = first;
3640 unop->op_flags = (U8)(flags | OPf_KIDS);
3641 unop->op_private = (U8)(1 | (flags >> 8));
3642 unop = (UNOP*) CHECKOP(type, unop);
3646 return fold_constants((OP *) unop);
3650 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3652 Constructs, checks, and returns an op of any binary type. I<type>
3653 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3654 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3655 the eight bits of C<op_private>, except that the bit with value 1 or
3656 2 is automatically set as required. I<first> and I<last> supply up to
3657 two ops to be the direct children of the binary op; they are consumed
3658 by this function and become part of the constructed op tree.
3664 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3669 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3670 || type == OP_SASSIGN || type == OP_NULL );
3672 NewOp(1101, binop, 1, BINOP);
3675 first = newOP(OP_NULL, 0);
3677 binop->op_type = (OPCODE)type;
3678 binop->op_ppaddr = PL_ppaddr[type];
3679 binop->op_first = first;
3680 binop->op_flags = (U8)(flags | OPf_KIDS);
3683 binop->op_private = (U8)(1 | (flags >> 8));
3686 binop->op_private = (U8)(2 | (flags >> 8));
3687 first->op_sibling = last;
3690 binop = (BINOP*)CHECKOP(type, binop);
3691 if (binop->op_next || binop->op_type != (OPCODE)type)
3694 binop->op_last = binop->op_first->op_sibling;
3696 return fold_constants((OP *)binop);
3699 static int uvcompare(const void *a, const void *b)
3700 __attribute__nonnull__(1)
3701 __attribute__nonnull__(2)
3702 __attribute__pure__;
3703 static int uvcompare(const void *a, const void *b)
3705 if (*((const UV *)a) < (*(const UV *)b))
3707 if (*((const UV *)a) > (*(const UV *)b))
3709 if (*((const UV *)a+1) < (*(const UV *)b+1))
3711 if (*((const UV *)a+1) > (*(const UV *)b+1))
3717 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3720 SV * const tstr = ((SVOP*)expr)->op_sv;
3723 (repl->op_type == OP_NULL)
3724 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3726 ((SVOP*)repl)->op_sv;
3729 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3730 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3734 register short *tbl;
3736 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3737 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3738 I32 del = o->op_private & OPpTRANS_DELETE;
3741 PERL_ARGS_ASSERT_PMTRANS;
3743 PL_hints |= HINT_BLOCK_SCOPE;
3746 o->op_private |= OPpTRANS_FROM_UTF;
3749 o->op_private |= OPpTRANS_TO_UTF;
3751 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3752 SV* const listsv = newSVpvs("# comment\n");
3754 const U8* tend = t + tlen;
3755 const U8* rend = r + rlen;
3769 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3770 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3773 const U32 flags = UTF8_ALLOW_DEFAULT;
3777 t = tsave = bytes_to_utf8(t, &len);
3780 if (!to_utf && rlen) {
3782 r = rsave = bytes_to_utf8(r, &len);
3786 /* There are several snags with this code on EBCDIC:
3787 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3788 2. scan_const() in toke.c has encoded chars in native encoding which makes
3789 ranges at least in EBCDIC 0..255 range the bottom odd.
3793 U8 tmpbuf[UTF8_MAXBYTES+1];
3796 Newx(cp, 2*tlen, UV);
3798 transv = newSVpvs("");
3800 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3802 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3804 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3808 cp[2*i+1] = cp[2*i];
3812 qsort(cp, i, 2*sizeof(UV), uvcompare);
3813 for (j = 0; j < i; j++) {
3815 diff = val - nextmin;
3817 t = uvuni_to_utf8(tmpbuf,nextmin);
3818 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3820 U8 range_mark = UTF_TO_NATIVE(0xff);
3821 t = uvuni_to_utf8(tmpbuf, val - 1);
3822 sv_catpvn(transv, (char *)&range_mark, 1);
3823 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3830 t = uvuni_to_utf8(tmpbuf,nextmin);
3831 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3833 U8 range_mark = UTF_TO_NATIVE(0xff);
3834 sv_catpvn(transv, (char *)&range_mark, 1);
3836 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3837 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3838 t = (const U8*)SvPVX_const(transv);
3839 tlen = SvCUR(transv);
3843 else if (!rlen && !del) {
3844 r = t; rlen = tlen; rend = tend;
3847 if ((!rlen && !del) || t == r ||
3848 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3850 o->op_private |= OPpTRANS_IDENTICAL;
3854 while (t < tend || tfirst <= tlast) {
3855 /* see if we need more "t" chars */
3856 if (tfirst > tlast) {
3857 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3859 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3861 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3868 /* now see if we need more "r" chars */
3869 if (rfirst > rlast) {
3871 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3873 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3875 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3884 rfirst = rlast = 0xffffffff;
3888 /* now see which range will peter our first, if either. */
3889 tdiff = tlast - tfirst;
3890 rdiff = rlast - rfirst;
3897 if (rfirst == 0xffffffff) {
3898 diff = tdiff; /* oops, pretend rdiff is infinite */
3900 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3901 (long)tfirst, (long)tlast);
3903 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3907 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3908 (long)tfirst, (long)(tfirst + diff),
3911 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3912 (long)tfirst, (long)rfirst);
3914 if (rfirst + diff > max)
3915 max = rfirst + diff;
3917 grows = (tfirst < rfirst &&
3918 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3930 else if (max > 0xff)
3935 PerlMemShared_free(cPVOPo->op_pv);
3936 cPVOPo->op_pv = NULL;
3938 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3940 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3941 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3942 PAD_SETSV(cPADOPo->op_padix, swash);
3944 SvREADONLY_on(swash);
3946 cSVOPo->op_sv = swash;
3948 SvREFCNT_dec(listsv);
3949 SvREFCNT_dec(transv);
3951 if (!del && havefinal && rlen)
3952 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3953 newSVuv((UV)final), 0);
3956 o->op_private |= OPpTRANS_GROWS;
3962 op_getmad(expr,o,'e');
3963 op_getmad(repl,o,'r');
3971 tbl = (short*)cPVOPo->op_pv;
3973 Zero(tbl, 256, short);
3974 for (i = 0; i < (I32)tlen; i++)
3976 for (i = 0, j = 0; i < 256; i++) {
3978 if (j >= (I32)rlen) {
3987 if (i < 128 && r[j] >= 128)
3997 o->op_private |= OPpTRANS_IDENTICAL;
3999 else if (j >= (I32)rlen)
4004 PerlMemShared_realloc(tbl,
4005 (0x101+rlen-j) * sizeof(short));
4006 cPVOPo->op_pv = (char*)tbl;
4008 tbl[0x100] = (short)(rlen - j);
4009 for (i=0; i < (I32)rlen - j; i++)
4010 tbl[0x101+i] = r[j+i];
4014 if (!rlen && !del) {
4017 o->op_private |= OPpTRANS_IDENTICAL;
4019 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4020 o->op_private |= OPpTRANS_IDENTICAL;
4022 for (i = 0; i < 256; i++)
4024 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4025 if (j >= (I32)rlen) {
4027 if (tbl[t[i]] == -1)
4033 if (tbl[t[i]] == -1) {
4034 if (t[i] < 128 && r[j] >= 128)
4041 if(del && rlen == tlen) {
4042 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4043 } else if(rlen > tlen) {
4044 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4048 o->op_private |= OPpTRANS_GROWS;
4050 op_getmad(expr,o,'e');
4051 op_getmad(repl,o,'r');
4061 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4063 Constructs, checks, and returns an op of any pattern matching type.
4064 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4065 and, shifted up eight bits, the eight bits of C<op_private>.
4071 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4076 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4078 NewOp(1101, pmop, 1, PMOP);
4079 pmop->op_type = (OPCODE)type;
4080 pmop->op_ppaddr = PL_ppaddr[type];
4081 pmop->op_flags = (U8)flags;
4082 pmop->op_private = (U8)(0 | (flags >> 8));
4084 if (PL_hints & HINT_RE_TAINT)
4085 pmop->op_pmflags |= PMf_RETAINT;
4086 if (PL_hints & HINT_LOCALE) {
4087 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4089 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
4090 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4092 if (PL_hints & HINT_RE_FLAGS) {
4093 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4094 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4096 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4097 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4098 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4100 if (reflags && SvOK(reflags)) {
4101 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4107 assert(SvPOK(PL_regex_pad[0]));
4108 if (SvCUR(PL_regex_pad[0])) {
4109 /* Pop off the "packed" IV from the end. */
4110 SV *const repointer_list = PL_regex_pad[0];
4111 const char *p = SvEND(repointer_list) - sizeof(IV);
4112 const IV offset = *((IV*)p);
4114 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4116 SvEND_set(repointer_list, p);
4118 pmop->op_pmoffset = offset;
4119 /* This slot should be free, so assert this: */
4120 assert(PL_regex_pad[offset] == &PL_sv_undef);
4122 SV * const repointer = &PL_sv_undef;
4123 av_push(PL_regex_padav, repointer);
4124 pmop->op_pmoffset = av_len(PL_regex_padav);
4125 PL_regex_pad = AvARRAY(PL_regex_padav);
4129 return CHECKOP(type, pmop);
4132 /* Given some sort of match op o, and an expression expr containing a
4133 * pattern, either compile expr into a regex and attach it to o (if it's
4134 * constant), or convert expr into a runtime regcomp op sequence (if it's
4137 * isreg indicates that the pattern is part of a regex construct, eg
4138 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4139 * split "pattern", which aren't. In the former case, expr will be a list
4140 * if the pattern contains more than one term (eg /a$b/) or if it contains
4141 * a replacement, ie s/// or tr///.
4145 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4150 I32 repl_has_vars = 0;
4154 PERL_ARGS_ASSERT_PMRUNTIME;
4157 o->op_type == OP_SUBST
4158 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4160 /* last element in list is the replacement; pop it */
4162 repl = cLISTOPx(expr)->op_last;
4163 kid = cLISTOPx(expr)->op_first;
4164 while (kid->op_sibling != repl)
4165 kid = kid->op_sibling;
4166 kid->op_sibling = NULL;
4167 cLISTOPx(expr)->op_last = kid;
4170 if (isreg && expr->op_type == OP_LIST &&
4171 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4173 /* convert single element list to element */
4174 OP* const oe = expr;
4175 expr = cLISTOPx(oe)->op_first->op_sibling;
4176 cLISTOPx(oe)->op_first->op_sibling = NULL;
4177 cLISTOPx(oe)->op_last = NULL;
4181 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4182 return pmtrans(o, expr, repl);
4185 reglist = isreg && expr->op_type == OP_LIST;
4189 PL_hints |= HINT_BLOCK_SCOPE;
4192 if (expr->op_type == OP_CONST) {
4193 SV *pat = ((SVOP*)expr)->op_sv;
4194 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4196 if (o->op_flags & OPf_SPECIAL)
4197 pm_flags |= RXf_SPLIT;
4200 assert (SvUTF8(pat));
4201 } else if (SvUTF8(pat)) {
4202 /* Not doing UTF-8, despite what the SV says. Is this only if we're
4203 trapped in use 'bytes'? */
4204 /* Make a copy of the octet sequence, but without the flag on, as
4205 the compiler now honours the SvUTF8 flag on pat. */
4207 const char *const p = SvPV(pat, len);
4208 pat = newSVpvn_flags(p, len, SVs_TEMP);
4211 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4214 op_getmad(expr,(OP*)pm,'e');
4220 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4221 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4223 : OP_REGCMAYBE),0,expr);
4225 NewOp(1101, rcop, 1, LOGOP);
4226 rcop->op_type = OP_REGCOMP;
4227 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4228 rcop->op_first = scalar(expr);
4229 rcop->op_flags |= OPf_KIDS
4230 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4231 | (reglist ? OPf_STACKED : 0);
4232 rcop->op_private = 1;
4235 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4237 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4238 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4240 /* establish postfix order */
4241 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4243 rcop->op_next = expr;
4244 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4247 rcop->op_next = LINKLIST(expr);
4248 expr->op_next = (OP*)rcop;
4251 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4256 if (pm->op_pmflags & PMf_EVAL) {
4258 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4259 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4261 else if (repl->op_type == OP_CONST)
4265 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4266 if (curop->op_type == OP_SCOPE
4267 || curop->op_type == OP_LEAVE
4268 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4269 if (curop->op_type == OP_GV) {
4270 GV * const gv = cGVOPx_gv(curop);
4272 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4275 else if (curop->op_type == OP_RV2CV)
4277 else if (curop->op_type == OP_RV2SV ||
4278 curop->op_type == OP_RV2AV ||
4279 curop->op_type == OP_RV2HV ||
4280 curop->op_type == OP_RV2GV) {
4281 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4284 else if (curop->op_type == OP_PADSV ||
4285 curop->op_type == OP_PADAV ||
4286 curop->op_type == OP_PADHV ||
4287 curop->op_type == OP_PADANY)
4291 else if (curop->op_type == OP_PUSHRE)
4292 NOOP; /* Okay here, dangerous in newASSIGNOP */
4302 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4304 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4305 op_prepend_elem(o->op_type, scalar(repl), o);
4308 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4309 pm->op_pmflags |= PMf_MAYBE_CONST;
4311 NewOp(1101, rcop, 1, LOGOP);
4312 rcop->op_type = OP_SUBSTCONT;
4313 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4314 rcop->op_first = scalar(repl);
4315 rcop->op_flags |= OPf_KIDS;
4316 rcop->op_private = 1;
4319 /* establish postfix order */
4320 rcop->op_next = LINKLIST(repl);
4321 repl->op_next = (OP*)rcop;
4323 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4324 assert(!(pm->op_pmflags & PMf_ONCE));
4325 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4334 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4336 Constructs, checks, and returns an op of any type that involves an
4337 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4338 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4339 takes ownership of one reference to it.
4345 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4350 PERL_ARGS_ASSERT_NEWSVOP;
4352 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4353 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4354 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4356 NewOp(1101, svop, 1, SVOP);
4357 svop->op_type = (OPCODE)type;
4358 svop->op_ppaddr = PL_ppaddr[type];
4360 svop->op_next = (OP*)svop;
4361 svop->op_flags = (U8)flags;
4362 if (PL_opargs[type] & OA_RETSCALAR)
4364 if (PL_opargs[type] & OA_TARGET)
4365 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4366 return CHECKOP(type, svop);
4372 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4374 Constructs, checks, and returns an op of any type that involves a
4375 reference to a pad element. I<type> is the opcode. I<flags> gives the
4376 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4377 is populated with I<sv>; this function takes ownership of one reference
4380 This function only exists if Perl has been compiled to use ithreads.
4386 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4391 PERL_ARGS_ASSERT_NEWPADOP;
4393 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4394 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4395 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4397 NewOp(1101, padop, 1, PADOP);
4398 padop->op_type = (OPCODE)type;
4399 padop->op_ppaddr = PL_ppaddr[type];
4400 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4401 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4402 PAD_SETSV(padop->op_padix, sv);
4405 padop->op_next = (OP*)padop;
4406 padop->op_flags = (U8)flags;
4407 if (PL_opargs[type] & OA_RETSCALAR)
4409 if (PL_opargs[type] & OA_TARGET)
4410 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4411 return CHECKOP(type, padop);
4414 #endif /* !USE_ITHREADS */
4417 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4419 Constructs, checks, and returns an op of any type that involves an
4420 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4421 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4422 reference; calling this function does not transfer ownership of any
4429 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4433 PERL_ARGS_ASSERT_NEWGVOP;
4437 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4439 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4444 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4446 Constructs, checks, and returns an op of any type that involves an
4447 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4448 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4449 must have been allocated using L</PerlMemShared_malloc>; the memory will
4450 be freed when the op is destroyed.
4456 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4461 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4462 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4464 NewOp(1101, pvop, 1, PVOP);
4465 pvop->op_type = (OPCODE)type;
4466 pvop->op_ppaddr = PL_ppaddr[type];
4468 pvop->op_next = (OP*)pvop;
4469 pvop->op_flags = (U8)flags;
4470 if (PL_opargs[type] & OA_RETSCALAR)
4472 if (PL_opargs[type] & OA_TARGET)
4473 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4474 return CHECKOP(type, pvop);
4482 Perl_package(pTHX_ OP *o)
4485 SV *const sv = cSVOPo->op_sv;
4490 PERL_ARGS_ASSERT_PACKAGE;
4492 save_hptr(&PL_curstash);
4493 save_item(PL_curstname);
4495 PL_curstash = gv_stashsv(sv, GV_ADD);
4497 sv_setsv(PL_curstname, sv);
4499 PL_hints |= HINT_BLOCK_SCOPE;
4500 PL_parser->copline = NOLINE;
4501 PL_parser->expect = XSTATE;
4506 if (!PL_madskills) {
4511 pegop = newOP(OP_NULL,0);
4512 op_getmad(o,pegop,'P');
4518 Perl_package_version( pTHX_ OP *v )
4521 U32 savehints = PL_hints;
4522 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4523 PL_hints &= ~HINT_STRICT_VARS;
4524 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4525 PL_hints = savehints;
4534 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4541 OP *pegop = newOP(OP_NULL,0);
4543 SV *use_version = NULL;
4545 PERL_ARGS_ASSERT_UTILIZE;
4547 if (idop->op_type != OP_CONST)
4548 Perl_croak(aTHX_ "Module name must be constant");
4551 op_getmad(idop,pegop,'U');
4556 SV * const vesv = ((SVOP*)version)->op_sv;
4559 op_getmad(version,pegop,'V');
4560 if (!arg && !SvNIOKp(vesv)) {
4567 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4568 Perl_croak(aTHX_ "Version number must be a constant number");
4570 /* Make copy of idop so we don't free it twice */
4571 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4573 /* Fake up a method call to VERSION */
4574 meth = newSVpvs_share("VERSION");
4575 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4576 op_append_elem(OP_LIST,
4577 op_prepend_elem(OP_LIST, pack, list(version)),
4578 newSVOP(OP_METHOD_NAMED, 0, meth)));
4582 /* Fake up an import/unimport */
4583 if (arg && arg->op_type == OP_STUB) {
4585 op_getmad(arg,pegop,'S');
4586 imop = arg; /* no import on explicit () */
4588 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4589 imop = NULL; /* use 5.0; */
4591 use_version = ((SVOP*)idop)->op_sv;
4593 idop->op_private |= OPpCONST_NOVER;
4599 op_getmad(arg,pegop,'A');
4601 /* Make copy of idop so we don't free it twice */
4602 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4604 /* Fake up a method call to import/unimport */
4606 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4607 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4608 op_append_elem(OP_LIST,
4609 op_prepend_elem(OP_LIST, pack, list(arg)),
4610 newSVOP(OP_METHOD_NAMED, 0, meth)));
4613 /* Fake up the BEGIN {}, which does its thing immediately. */
4615 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4618 op_append_elem(OP_LINESEQ,
4619 op_append_elem(OP_LINESEQ,
4620 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4621 newSTATEOP(0, NULL, veop)),
4622 newSTATEOP(0, NULL, imop) ));
4625 /* If we request a version >= 5.9.5, load feature.pm with the
4626 * feature bundle that corresponds to the required version. */
4627 use_version = sv_2mortal(new_version(use_version));
4629 if (vcmp(use_version,
4630 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4631 SV *const importsv = vnormal(use_version);
4632 *SvPVX_mutable(importsv) = ':';
4633 ENTER_with_name("load_feature");
4634 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4635 LEAVE_with_name("load_feature");
4637 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4638 if (vcmp(use_version,
4639 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4640 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4644 /* The "did you use incorrect case?" warning used to be here.
4645 * The problem is that on case-insensitive filesystems one
4646 * might get false positives for "use" (and "require"):
4647 * "use Strict" or "require CARP" will work. This causes
4648 * portability problems for the script: in case-strict
4649 * filesystems the script will stop working.
4651 * The "incorrect case" warning checked whether "use Foo"
4652 * imported "Foo" to your namespace, but that is wrong, too:
4653 * there is no requirement nor promise in the language that
4654 * a Foo.pm should or would contain anything in package "Foo".
4656 * There is very little Configure-wise that can be done, either:
4657 * the case-sensitivity of the build filesystem of Perl does not
4658 * help in guessing the case-sensitivity of the runtime environment.
4661 PL_hints |= HINT_BLOCK_SCOPE;
4662 PL_parser->copline = NOLINE;
4663 PL_parser->expect = XSTATE;
4664 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4665 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4669 if (!PL_madskills) {
4670 /* FIXME - don't allocate pegop if !PL_madskills */
4679 =head1 Embedding Functions
4681 =for apidoc load_module
4683 Loads the module whose name is pointed to by the string part of name.
4684 Note that the actual module name, not its filename, should be given.
4685 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4686 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4687 (or 0 for no flags). ver, if specified, provides version semantics
4688 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4689 arguments can be used to specify arguments to the module's import()
4690 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4691 terminated with a final NULL pointer. Note that this list can only
4692 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4693 Otherwise at least a single NULL pointer to designate the default
4694 import list is required.
4699 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4703 PERL_ARGS_ASSERT_LOAD_MODULE;
4705 va_start(args, ver);
4706 vload_module(flags, name, ver, &args);
4710 #ifdef PERL_IMPLICIT_CONTEXT
4712 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4716 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4717 va_start(args, ver);
4718 vload_module(flags, name, ver, &args);
4724 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4728 OP * const modname = newSVOP(OP_CONST, 0, name);
4730 PERL_ARGS_ASSERT_VLOAD_MODULE;
4732 modname->op_private |= OPpCONST_BARE;
4734 veop = newSVOP(OP_CONST, 0, ver);
4738 if (flags & PERL_LOADMOD_NOIMPORT) {
4739 imop = sawparens(newNULLLIST());
4741 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4742 imop = va_arg(*args, OP*);
4747 sv = va_arg(*args, SV*);
4749 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4750 sv = va_arg(*args, SV*);
4754 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4755 * that it has a PL_parser to play with while doing that, and also
4756 * that it doesn't mess with any existing parser, by creating a tmp
4757 * new parser with lex_start(). This won't actually be used for much,
4758 * since pp_require() will create another parser for the real work. */
4761 SAVEVPTR(PL_curcop);
4762 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4763 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4764 veop, modname, imop);
4769 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4775 PERL_ARGS_ASSERT_DOFILE;
4777 if (!force_builtin) {
4778 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4779 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4780 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4781 gv = gvp ? *gvp : NULL;
4785 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4786 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4787 op_append_elem(OP_LIST, term,
4788 scalar(newUNOP(OP_RV2CV, 0,
4789 newGVOP(OP_GV, 0, gv))))));
4792 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4798 =head1 Optree construction
4800 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4802 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4803 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4804 be set automatically, and, shifted up eight bits, the eight bits of
4805 C<op_private>, except that the bit with value 1 or 2 is automatically
4806 set as required. I<listval> and I<subscript> supply the parameters of
4807 the slice; they are consumed by this function and become part of the
4808 constructed op tree.
4814 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4816 return newBINOP(OP_LSLICE, flags,
4817 list(force_list(subscript)),
4818 list(force_list(listval)) );
4822 S_is_list_assignment(pTHX_ register const OP *o)
4830 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4831 o = cUNOPo->op_first;
4833 flags = o->op_flags;
4835 if (type == OP_COND_EXPR) {
4836 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4837 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4842 yyerror("Assignment to both a list and a scalar");
4846 if (type == OP_LIST &&
4847 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4848 o->op_private & OPpLVAL_INTRO)
4851 if (type == OP_LIST || flags & OPf_PARENS ||
4852 type == OP_RV2AV || type == OP_RV2HV ||
4853 type == OP_ASLICE || type == OP_HSLICE)
4856 if (type == OP_PADAV || type == OP_PADHV)
4859 if (type == OP_RV2SV)
4866 Helper function for newASSIGNOP to detection commonality between the
4867 lhs and the rhs. Marks all variables with PL_generation. If it
4868 returns TRUE the assignment must be able to handle common variables.
4870 PERL_STATIC_INLINE bool
4871 S_aassign_common_vars(pTHX_ OP* o)
4874 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
4875 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4876 if (curop->op_type == OP_GV) {
4877 GV *gv = cGVOPx_gv(curop);
4879 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4881 GvASSIGN_GENERATION_set(gv, PL_generation);
4883 else if (curop->op_type == OP_PADSV ||
4884 curop->op_type == OP_PADAV ||
4885 curop->op_type == OP_PADHV ||
4886 curop->op_type == OP_PADANY)
4888 if (PAD_COMPNAME_GEN(curop->op_targ)
4889 == (STRLEN)PL_generation)
4891 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4894 else if (curop->op_type == OP_RV2CV)
4896 else if (curop->op_type == OP_RV2SV ||
4897 curop->op_type == OP_RV2AV ||
4898 curop->op_type == OP_RV2HV ||
4899 curop->op_type == OP_RV2GV) {
4900 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
4903 else if (curop->op_type == OP_PUSHRE) {
4905 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4906 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4908 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4910 GvASSIGN_GENERATION_set(gv, PL_generation);
4914 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4917 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4919 GvASSIGN_GENERATION_set(gv, PL_generation);
4927 if (curop->op_flags & OPf_KIDS) {
4928 if (aassign_common_vars(curop))
4936 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4938 Constructs, checks, and returns an assignment op. I<left> and I<right>
4939 supply the parameters of the assignment; they are consumed by this
4940 function and become part of the constructed op tree.
4942 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4943 a suitable conditional optree is constructed. If I<optype> is the opcode
4944 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4945 performs the binary operation and assigns the result to the left argument.
4946 Either way, if I<optype> is non-zero then I<flags> has no effect.
4948 If I<optype> is zero, then a plain scalar or list assignment is
4949 constructed. Which type of assignment it is is automatically determined.
4950 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4951 will be set automatically, and, shifted up eight bits, the eight bits
4952 of C<op_private>, except that the bit with value 1 or 2 is automatically
4959 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4965 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4966 return newLOGOP(optype, 0,
4967 op_lvalue(scalar(left), optype),
4968 newUNOP(OP_SASSIGN, 0, scalar(right)));
4971 return newBINOP(optype, OPf_STACKED,
4972 op_lvalue(scalar(left), optype), scalar(right));
4976 if (is_list_assignment(left)) {
4977 static const char no_list_state[] = "Initialization of state variables"
4978 " in list context currently forbidden";
4980 bool maybe_common_vars = TRUE;
4983 /* Grandfathering $[ assignment here. Bletch.*/
4984 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4985 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4986 left = op_lvalue(left, OP_AASSIGN);
4989 else if (left->op_type == OP_CONST) {
4990 deprecate("assignment to $[");
4992 /* Result of assignment is always 1 (or we'd be dead already) */
4993 return newSVOP(OP_CONST, 0, newSViv(1));
4995 curop = list(force_list(left));
4996 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4997 o->op_private = (U8)(0 | (flags >> 8));
4999 if ((left->op_type == OP_LIST
5000 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5002 OP* lop = ((LISTOP*)left)->op_first;
5003 maybe_common_vars = FALSE;
5005 if (lop->op_type == OP_PADSV ||
5006 lop->op_type == OP_PADAV ||
5007 lop->op_type == OP_PADHV ||
5008 lop->op_type == OP_PADANY) {
5009 if (!(lop->op_private & OPpLVAL_INTRO))
5010 maybe_common_vars = TRUE;
5012 if (lop->op_private & OPpPAD_STATE) {
5013 if (left->op_private & OPpLVAL_INTRO) {
5014 /* Each variable in state($a, $b, $c) = ... */
5017 /* Each state variable in
5018 (state $a, my $b, our $c, $d, undef) = ... */
5020 yyerror(no_list_state);
5022 /* Each my variable in
5023 (state $a, my $b, our $c, $d, undef) = ... */
5025 } else if (lop->op_type == OP_UNDEF ||
5026 lop->op_type == OP_PUSHMARK) {
5027 /* undef may be interesting in
5028 (state $a, undef, state $c) */
5030 /* Other ops in the list. */
5031 maybe_common_vars = TRUE;
5033 lop = lop->op_sibling;
5036 else if ((left->op_private & OPpLVAL_INTRO)
5037 && ( left->op_type == OP_PADSV
5038 || left->op_type == OP_PADAV
5039 || left->op_type == OP_PADHV
5040 || left->op_type == OP_PADANY))
5042 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5043 if (left->op_private & OPpPAD_STATE) {
5044 /* All single variable list context state assignments, hence
5054 yyerror(no_list_state);
5058 /* PL_generation sorcery:
5059 * an assignment like ($a,$b) = ($c,$d) is easier than
5060 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5061 * To detect whether there are common vars, the global var
5062 * PL_generation is incremented for each assign op we compile.
5063 * Then, while compiling the assign op, we run through all the
5064 * variables on both sides of the assignment, setting a spare slot
5065 * in each of them to PL_generation. If any of them already have
5066 * that value, we know we've got commonality. We could use a
5067 * single bit marker, but then we'd have to make 2 passes, first
5068 * to clear the flag, then to test and set it. To find somewhere
5069 * to store these values, evil chicanery is done with SvUVX().
5072 if (maybe_common_vars) {
5074 if (aassign_common_vars(o))
5075 o->op_private |= OPpASSIGN_COMMON;
5079 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5080 OP* tmpop = ((LISTOP*)right)->op_first;
5081 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5082 PMOP * const pm = (PMOP*)tmpop;
5083 if (left->op_type == OP_RV2AV &&
5084 !(left->op_private & OPpLVAL_INTRO) &&
5085 !(o->op_private & OPpASSIGN_COMMON) )
5087 tmpop = ((UNOP*)left)->op_first;
5088 if (tmpop->op_type == OP_GV
5090 && !pm->op_pmreplrootu.op_pmtargetoff
5092 && !pm->op_pmreplrootu.op_pmtargetgv
5096 pm->op_pmreplrootu.op_pmtargetoff
5097 = cPADOPx(tmpop)->op_padix;
5098 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5100 pm->op_pmreplrootu.op_pmtargetgv
5101 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5102 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5104 pm->op_pmflags |= PMf_ONCE;
5105 tmpop = cUNOPo->op_first; /* to list (nulled) */
5106 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5107 tmpop->op_sibling = NULL; /* don't free split */
5108 right->op_next = tmpop->op_next; /* fix starting loc */
5109 op_free(o); /* blow off assign */
5110 right->op_flags &= ~OPf_WANT;
5111 /* "I don't know and I don't care." */
5116 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5117 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5119 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5120 if (SvIOK(sv) && SvIVX(sv) == 0)
5121 sv_setiv(sv, PL_modcount+1);
5129 right = newOP(OP_UNDEF, 0);
5130 if (right->op_type == OP_READLINE) {
5131 right->op_flags |= OPf_STACKED;
5132 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5136 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
5137 o = newBINOP(OP_SASSIGN, flags,
5138 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5142 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
5143 deprecate("assignment to $[");
5145 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
5146 o->op_private |= OPpCONST_ARYBASE;
5154 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5156 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5157 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5158 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5159 If I<label> is non-null, it supplies the name of a label to attach to
5160 the state op; this function takes ownership of the memory pointed at by
5161 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5164 If I<o> is null, the state op is returned. Otherwise the state op is
5165 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5166 is consumed by this function and becomes part of the returned op tree.
5172 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5175 const U32 seq = intro_my();
5178 NewOp(1101, cop, 1, COP);
5179 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5180 cop->op_type = OP_DBSTATE;
5181 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5184 cop->op_type = OP_NEXTSTATE;
5185 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5187 cop->op_flags = (U8)flags;
5188 CopHINTS_set(cop, PL_hints);
5190 cop->op_private |= NATIVE_HINTS;
5192 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5193 cop->op_next = (OP*)cop;
5196 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
5197 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
5199 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5200 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5202 Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
5204 PL_hints |= HINT_BLOCK_SCOPE;
5205 /* It seems that we need to defer freeing this pointer, as other parts
5206 of the grammar end up wanting to copy it after this op has been
5211 if (PL_parser && PL_parser->copline == NOLINE)
5212 CopLINE_set(cop, CopLINE(PL_curcop));
5214 CopLINE_set(cop, PL_parser->copline);
5216 PL_parser->copline = NOLINE;
5219 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5221 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5223 CopSTASH_set(cop, PL_curstash);
5225 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5226 /* this line can have a breakpoint - store the cop in IV */
5227 AV *av = CopFILEAVx(PL_curcop);
5229 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5230 if (svp && *svp != &PL_sv_undef ) {
5231 (void)SvIOK_on(*svp);
5232 SvIV_set(*svp, PTR2IV(cop));
5237 if (flags & OPf_SPECIAL)
5239 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5243 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5245 Constructs, checks, and returns a logical (flow control) op. I<type>
5246 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5247 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5248 the eight bits of C<op_private>, except that the bit with value 1 is
5249 automatically set. I<first> supplies the expression controlling the
5250 flow, and I<other> supplies the side (alternate) chain of ops; they are
5251 consumed by this function and become part of the constructed op tree.
5257 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5261 PERL_ARGS_ASSERT_NEWLOGOP;
5263 return new_logop(type, flags, &first, &other);
5267 S_search_const(pTHX_ OP *o)
5269 PERL_ARGS_ASSERT_SEARCH_CONST;
5271 switch (o->op_type) {
5275 if (o->op_flags & OPf_KIDS)
5276 return search_const(cUNOPo->op_first);
5283 if (!(o->op_flags & OPf_KIDS))
5285 kid = cLISTOPo->op_first;
5287 switch (kid->op_type) {
5291 kid = kid->op_sibling;
5294 if (kid != cLISTOPo->op_last)
5300 kid = cLISTOPo->op_last;
5302 return search_const(kid);
5310 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5318 int prepend_not = 0;
5320 PERL_ARGS_ASSERT_NEW_LOGOP;
5325 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5326 return newBINOP(type, flags, scalar(first), scalar(other));
5328 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5330 scalarboolean(first);
5331 /* optimize AND and OR ops that have NOTs as children */
5332 if (first->op_type == OP_NOT
5333 && (first->op_flags & OPf_KIDS)
5334 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5335 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5337 if (type == OP_AND || type == OP_OR) {
5343 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5345 prepend_not = 1; /* prepend a NOT op later */
5349 /* search for a constant op that could let us fold the test */
5350 if ((cstop = search_const(first))) {
5351 if (cstop->op_private & OPpCONST_STRICT)
5352 no_bareword_allowed(cstop);
5353 else if ((cstop->op_private & OPpCONST_BARE))
5354 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5355 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5356 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5357 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5359 if (other->op_type == OP_CONST)
5360 other->op_private |= OPpCONST_SHORTCIRCUIT;
5362 OP *newop = newUNOP(OP_NULL, 0, other);
5363 op_getmad(first, newop, '1');
5364 newop->op_targ = type; /* set "was" field */
5368 if (other->op_type == OP_LEAVE)
5369 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5370 else if (other->op_type == OP_MATCH
5371 || other->op_type == OP_SUBST
5372 || other->op_type == OP_TRANSR
5373 || other->op_type == OP_TRANS)
5374 /* Mark the op as being unbindable with =~ */
5375 other->op_flags |= OPf_SPECIAL;
5379 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5380 const OP *o2 = other;
5381 if ( ! (o2->op_type == OP_LIST
5382 && (( o2 = cUNOPx(o2)->op_first))
5383 && o2->op_type == OP_PUSHMARK
5384 && (( o2 = o2->op_sibling)) )
5387 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5388 || o2->op_type == OP_PADHV)
5389 && o2->op_private & OPpLVAL_INTRO
5390 && !(o2->op_private & OPpPAD_STATE))
5392 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5393 "Deprecated use of my() in false conditional");
5397 if (first->op_type == OP_CONST)
5398 first->op_private |= OPpCONST_SHORTCIRCUIT;
5400 first = newUNOP(OP_NULL, 0, first);
5401 op_getmad(other, first, '2');
5402 first->op_targ = type; /* set "was" field */
5409 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5410 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5412 const OP * const k1 = ((UNOP*)first)->op_first;
5413 const OP * const k2 = k1->op_sibling;
5415 switch (first->op_type)
5418 if (k2 && k2->op_type == OP_READLINE
5419 && (k2->op_flags & OPf_STACKED)
5420 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5422 warnop = k2->op_type;
5427 if (k1->op_type == OP_READDIR
5428 || k1->op_type == OP_GLOB
5429 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5430 || k1->op_type == OP_EACH
5431 || k1->op_type == OP_AEACH)
5433 warnop = ((k1->op_type == OP_NULL)
5434 ? (OPCODE)k1->op_targ : k1->op_type);
5439 const line_t oldline = CopLINE(PL_curcop);
5440 CopLINE_set(PL_curcop, PL_parser->copline);
5441 Perl_warner(aTHX_ packWARN(WARN_MISC),
5442 "Value of %s%s can be \"0\"; test with defined()",
5444 ((warnop == OP_READLINE || warnop == OP_GLOB)
5445 ? " construct" : "() operator"));
5446 CopLINE_set(PL_curcop, oldline);
5453 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5454 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5456 NewOp(1101, logop, 1, LOGOP);
5458 logop->op_type = (OPCODE)type;
5459 logop->op_ppaddr = PL_ppaddr[type];
5460 logop->op_first = first;
5461 logop->op_flags = (U8)(flags | OPf_KIDS);
5462 logop->op_other = LINKLIST(other);
5463 logop->op_private = (U8)(1 | (flags >> 8));
5465 /* establish postfix order */
5466 logop->op_next = LINKLIST(first);
5467 first->op_next = (OP*)logop;
5468 first->op_sibling = other;
5470 CHECKOP(type,logop);
5472 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5479 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5481 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5482 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5483 will be set automatically, and, shifted up eight bits, the eight bits of
5484 C<op_private>, except that the bit with value 1 is automatically set.
5485 I<first> supplies the expression selecting between the two branches,
5486 and I<trueop> and I<falseop> supply the branches; they are consumed by
5487 this function and become part of the constructed op tree.
5493 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5501 PERL_ARGS_ASSERT_NEWCONDOP;
5504 return newLOGOP(OP_AND, 0, first, trueop);
5506 return newLOGOP(OP_OR, 0, first, falseop);
5508 scalarboolean(first);
5509 if ((cstop = search_const(first))) {
5510 /* Left or right arm of the conditional? */
5511 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5512 OP *live = left ? trueop : falseop;
5513 OP *const dead = left ? falseop : trueop;
5514 if (cstop->op_private & OPpCONST_BARE &&
5515 cstop->op_private & OPpCONST_STRICT) {
5516 no_bareword_allowed(cstop);
5519 /* This is all dead code when PERL_MAD is not defined. */
5520 live = newUNOP(OP_NULL, 0, live);
5521 op_getmad(first, live, 'C');
5522 op_getmad(dead, live, left ? 'e' : 't');
5527 if (live->op_type == OP_LEAVE)
5528 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5529 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5530 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5531 /* Mark the op as being unbindable with =~ */
5532 live->op_flags |= OPf_SPECIAL;
5535 NewOp(1101, logop, 1, LOGOP);
5536 logop->op_type = OP_COND_EXPR;
5537 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5538 logop->op_first = first;
5539 logop->op_flags = (U8)(flags | OPf_KIDS);
5540 logop->op_private = (U8)(1 | (flags >> 8));
5541 logop->op_other = LINKLIST(trueop);
5542 logop->op_next = LINKLIST(falseop);
5544 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5547 /* establish postfix order */
5548 start = LINKLIST(first);
5549 first->op_next = (OP*)logop;
5551 first->op_sibling = trueop;
5552 trueop->op_sibling = falseop;
5553 o = newUNOP(OP_NULL, 0, (OP*)logop);
5555 trueop->op_next = falseop->op_next = o;
5562 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5564 Constructs and returns a C<range> op, with subordinate C<flip> and
5565 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5566 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5567 for both the C<flip> and C<range> ops, except that the bit with value
5568 1 is automatically set. I<left> and I<right> supply the expressions
5569 controlling the endpoints of the range; they are consumed by this function
5570 and become part of the constructed op tree.
5576 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5585 PERL_ARGS_ASSERT_NEWRANGE;
5587 NewOp(1101, range, 1, LOGOP);
5589 range->op_type = OP_RANGE;
5590 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5591 range->op_first = left;
5592 range->op_flags = OPf_KIDS;
5593 leftstart = LINKLIST(left);
5594 range->op_other = LINKLIST(right);
5595 range->op_private = (U8)(1 | (flags >> 8));
5597 left->op_sibling = right;
5599 range->op_next = (OP*)range;
5600 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5601 flop = newUNOP(OP_FLOP, 0, flip);
5602 o = newUNOP(OP_NULL, 0, flop);
5604 range->op_next = leftstart;
5606 left->op_next = flip;
5607 right->op_next = flop;
5609 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5610 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5611 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5612 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5614 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5615 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5617 /* check barewords before they might be optimized aways */
5618 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5619 no_bareword_allowed(left);
5620 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5621 no_bareword_allowed(right);
5624 if (!flip->op_private || !flop->op_private)
5625 LINKLIST(o); /* blow off optimizer unless constant */
5631 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5633 Constructs, checks, and returns an op tree expressing a loop. This is
5634 only a loop in the control flow through the op tree; it does not have
5635 the heavyweight loop structure that allows exiting the loop by C<last>
5636 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5637 top-level op, except that some bits will be set automatically as required.
5638 I<expr> supplies the expression controlling loop iteration, and I<block>
5639 supplies the body of the loop; they are consumed by this function and
5640 become part of the constructed op tree. I<debuggable> is currently
5641 unused and should always be 1.
5647 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5652 const bool once = block && block->op_flags & OPf_SPECIAL &&
5653 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5655 PERL_UNUSED_ARG(debuggable);
5658 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5659 return block; /* do {} while 0 does once */
5660 if (expr->op_type == OP_READLINE
5661 || expr->op_type == OP_READDIR
5662 || expr->op_type == OP_GLOB
5663 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5664 expr = newUNOP(OP_DEFINED, 0,
5665 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5666 } else if (expr->op_flags & OPf_KIDS) {
5667 const OP * const k1 = ((UNOP*)expr)->op_first;
5668 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5669 switch (expr->op_type) {
5671 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5672 && (k2->op_flags & OPf_STACKED)
5673 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5674 expr = newUNOP(OP_DEFINED, 0, expr);
5678 if (k1 && (k1->op_type == OP_READDIR
5679 || k1->op_type == OP_GLOB
5680 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5681 || k1->op_type == OP_EACH
5682 || k1->op_type == OP_AEACH))
5683 expr = newUNOP(OP_DEFINED, 0, expr);
5689 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5690 * op, in listop. This is wrong. [perl #27024] */
5692 block = newOP(OP_NULL, 0);
5693 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5694 o = new_logop(OP_AND, 0, &expr, &listop);
5697 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5699 if (once && o != listop)
5700 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5703 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5705 o->op_flags |= flags;
5707 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5712 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5714 Constructs, checks, and returns an op tree expressing a C<while> loop.
5715 This is a heavyweight loop, with structure that allows exiting the loop
5716 by C<last> and suchlike.
5718 I<loop> is an optional preconstructed C<enterloop> op to use in the
5719 loop; if it is null then a suitable op will be constructed automatically.
5720 I<expr> supplies the loop's controlling expression. I<block> supplies the
5721 main body of the loop, and I<cont> optionally supplies a C<continue> block
5722 that operates as a second half of the body. All of these optree inputs
5723 are consumed by this function and become part of the constructed op tree.
5725 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5726 op and, shifted up eight bits, the eight bits of C<op_private> for
5727 the C<leaveloop> op, except that (in both cases) some bits will be set
5728 automatically. I<debuggable> is currently unused and should always be 1.
5729 I<has_my> can be supplied as true to force the
5730 loop body to be enclosed in its own scope.
5736 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5737 OP *expr, OP *block, OP *cont, I32 has_my)
5746 PERL_UNUSED_ARG(debuggable);
5749 if (expr->op_type == OP_READLINE
5750 || expr->op_type == OP_READDIR
5751 || expr->op_type == OP_GLOB
5752 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5753 expr = newUNOP(OP_DEFINED, 0,
5754 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5755 } else if (expr->op_flags & OPf_KIDS) {
5756 const OP * const k1 = ((UNOP*)expr)->op_first;
5757 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5758 switch (expr->op_type) {
5760 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5761 && (k2->op_flags & OPf_STACKED)
5762 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5763 expr = newUNOP(OP_DEFINED, 0, expr);
5767 if (k1 && (k1->op_type == OP_READDIR
5768 || k1->op_type == OP_GLOB
5769 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5770 || k1->op_type == OP_EACH
5771 || k1->op_type == OP_AEACH))
5772 expr = newUNOP(OP_DEFINED, 0, expr);
5779 block = newOP(OP_NULL, 0);
5780 else if (cont || has_my) {
5781 block = op_scope(block);
5785 next = LINKLIST(cont);
5788 OP * const unstack = newOP(OP_UNSTACK, 0);
5791 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5795 listop = op_append_list(OP_LINESEQ, block, cont);
5797 redo = LINKLIST(listop);
5801 o = new_logop(OP_AND, 0, &expr, &listop);
5802 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5803 op_free(expr); /* oops, it's a while (0) */
5805 return NULL; /* listop already freed by new_logop */
5808 ((LISTOP*)listop)->op_last->op_next =
5809 (o == listop ? redo : LINKLIST(o));
5815 NewOp(1101,loop,1,LOOP);
5816 loop->op_type = OP_ENTERLOOP;
5817 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5818 loop->op_private = 0;
5819 loop->op_next = (OP*)loop;
5822 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5824 loop->op_redoop = redo;
5825 loop->op_lastop = o;
5826 o->op_private |= loopflags;
5829 loop->op_nextop = next;
5831 loop->op_nextop = o;
5833 o->op_flags |= flags;
5834 o->op_private |= (flags >> 8);
5839 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5841 Constructs, checks, and returns an op tree expressing a C<foreach>
5842 loop (iteration through a list of values). This is a heavyweight loop,
5843 with structure that allows exiting the loop by C<last> and suchlike.
5845 I<sv> optionally supplies the variable that will be aliased to each
5846 item in turn; if null, it defaults to C<$_> (either lexical or global).
5847 I<expr> supplies the list of values to iterate over. I<block> supplies
5848 the main body of the loop, and I<cont> optionally supplies a C<continue>
5849 block that operates as a second half of the body. All of these optree
5850 inputs are consumed by this function and become part of the constructed
5853 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5854 op and, shifted up eight bits, the eight bits of C<op_private> for
5855 the C<leaveloop> op, except that (in both cases) some bits will be set
5862 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5867 PADOFFSET padoff = 0;
5872 PERL_ARGS_ASSERT_NEWFOROP;
5875 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5876 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5877 sv->op_type = OP_RV2GV;
5878 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5880 /* The op_type check is needed to prevent a possible segfault
5881 * if the loop variable is undeclared and 'strict vars' is in
5882 * effect. This is illegal but is nonetheless parsed, so we
5883 * may reach this point with an OP_CONST where we're expecting
5886 if (cUNOPx(sv)->op_first->op_type == OP_GV
5887 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5888 iterpflags |= OPpITER_DEF;
5890 else if (sv->op_type == OP_PADSV) { /* private variable */
5891 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5892 padoff = sv->op_targ;
5902 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5904 SV *const namesv = PAD_COMPNAME_SV(padoff);
5906 const char *const name = SvPV_const(namesv, len);
5908 if (len == 2 && name[0] == '$' && name[1] == '_')
5909 iterpflags |= OPpITER_DEF;
5913 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5914 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5915 sv = newGVOP(OP_GV, 0, PL_defgv);
5920 iterpflags |= OPpITER_DEF;
5922 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5923 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5924 iterflags |= OPf_STACKED;
5926 else if (expr->op_type == OP_NULL &&
5927 (expr->op_flags & OPf_KIDS) &&
5928 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5930 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5931 * set the STACKED flag to indicate that these values are to be
5932 * treated as min/max values by 'pp_iterinit'.
5934 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5935 LOGOP* const range = (LOGOP*) flip->op_first;
5936 OP* const left = range->op_first;
5937 OP* const right = left->op_sibling;
5940 range->op_flags &= ~OPf_KIDS;
5941 range->op_first = NULL;
5943 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5944 listop->op_first->op_next = range->op_next;
5945 left->op_next = range->op_other;
5946 right->op_next = (OP*)listop;
5947 listop->op_next = listop->op_first;
5950 op_getmad(expr,(OP*)listop,'O');
5954 expr = (OP*)(listop);
5956 iterflags |= OPf_STACKED;
5959 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5962 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5963 op_append_elem(OP_LIST, expr, scalar(sv))));
5964 assert(!loop->op_next);
5965 /* for my $x () sets OPpLVAL_INTRO;
5966 * for our $x () sets OPpOUR_INTRO */
5967 loop->op_private = (U8)iterpflags;
5968 #ifdef PL_OP_SLAB_ALLOC
5971 NewOp(1234,tmp,1,LOOP);
5972 Copy(loop,tmp,1,LISTOP);
5973 S_op_destroy(aTHX_ (OP*)loop);
5977 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5979 loop->op_targ = padoff;
5980 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5982 op_getmad(madsv, (OP*)loop, 'v');
5987 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5989 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5990 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5991 determining the target of the op; it is consumed by this function and
5992 become part of the constructed op tree.
5998 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6003 PERL_ARGS_ASSERT_NEWLOOPEX;
6005 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6007 if (type != OP_GOTO || label->op_type == OP_CONST) {
6008 /* "last()" means "last" */
6009 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6010 o = newOP(type, OPf_SPECIAL);
6012 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
6013 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6017 op_getmad(label,o,'L');
6023 /* Check whether it's going to be a goto &function */
6024 if (label->op_type == OP_ENTERSUB
6025 && !(label->op_flags & OPf_STACKED))
6026 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6027 o = newUNOP(type, OPf_STACKED, label);
6029 PL_hints |= HINT_BLOCK_SCOPE;
6033 /* if the condition is a literal array or hash
6034 (or @{ ... } etc), make a reference to it.
6037 S_ref_array_or_hash(pTHX_ OP *cond)
6040 && (cond->op_type == OP_RV2AV
6041 || cond->op_type == OP_PADAV
6042 || cond->op_type == OP_RV2HV
6043 || cond->op_type == OP_PADHV))
6045 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6048 && (cond->op_type == OP_ASLICE
6049 || cond->op_type == OP_HSLICE)) {
6051 /* anonlist now needs a list from this op, was previously used in
6053 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6054 cond->op_flags |= OPf_WANT_LIST;
6056 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6063 /* These construct the optree fragments representing given()
6066 entergiven and enterwhen are LOGOPs; the op_other pointer
6067 points up to the associated leave op. We need this so we
6068 can put it in the context and make break/continue work.
6069 (Also, of course, pp_enterwhen will jump straight to
6070 op_other if the match fails.)
6074 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6075 I32 enter_opcode, I32 leave_opcode,
6076 PADOFFSET entertarg)
6082 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6084 NewOp(1101, enterop, 1, LOGOP);
6085 enterop->op_type = (Optype)enter_opcode;
6086 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6087 enterop->op_flags = (U8) OPf_KIDS;
6088 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6089 enterop->op_private = 0;
6091 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6094 enterop->op_first = scalar(cond);
6095 cond->op_sibling = block;
6097 o->op_next = LINKLIST(cond);
6098 cond->op_next = (OP *) enterop;
6101 /* This is a default {} block */
6102 enterop->op_first = block;
6103 enterop->op_flags |= OPf_SPECIAL;
6105 o->op_next = (OP *) enterop;
6108 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6109 entergiven and enterwhen both
6112 enterop->op_next = LINKLIST(block);
6113 block->op_next = enterop->op_other = o;
6118 /* Does this look like a boolean operation? For these purposes
6119 a boolean operation is:
6120 - a subroutine call [*]
6121 - a logical connective
6122 - a comparison operator
6123 - a filetest operator, with the exception of -s -M -A -C
6124 - defined(), exists() or eof()
6125 - /$re/ or $foo =~ /$re/
6127 [*] possibly surprising
6130 S_looks_like_bool(pTHX_ const OP *o)
6134 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6136 switch(o->op_type) {
6139 return looks_like_bool(cLOGOPo->op_first);
6143 looks_like_bool(cLOGOPo->op_first)
6144 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6149 o->op_flags & OPf_KIDS
6150 && looks_like_bool(cUNOPo->op_first));
6154 case OP_NOT: case OP_XOR:
6156 case OP_EQ: case OP_NE: case OP_LT:
6157 case OP_GT: case OP_LE: case OP_GE:
6159 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6160 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6162 case OP_SEQ: case OP_SNE: case OP_SLT:
6163 case OP_SGT: case OP_SLE: case OP_SGE:
6167 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6168 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6169 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6170 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6171 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6172 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6173 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6174 case OP_FTTEXT: case OP_FTBINARY:
6176 case OP_DEFINED: case OP_EXISTS:
6177 case OP_MATCH: case OP_EOF:
6184 /* Detect comparisons that have been optimized away */
6185 if (cSVOPo->op_sv == &PL_sv_yes
6186 || cSVOPo->op_sv == &PL_sv_no)
6199 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6201 Constructs, checks, and returns an op tree expressing a C<given> block.
6202 I<cond> supplies the expression that will be locally assigned to a lexical
6203 variable, and I<block> supplies the body of the C<given> construct; they
6204 are consumed by this function and become part of the constructed op tree.
6205 I<defsv_off> is the pad offset of the scalar lexical variable that will
6212 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6215 PERL_ARGS_ASSERT_NEWGIVENOP;
6216 return newGIVWHENOP(
6217 ref_array_or_hash(cond),
6219 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6224 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6226 Constructs, checks, and returns an op tree expressing a C<when> block.
6227 I<cond> supplies the test expression, and I<block> supplies the block
6228 that will be executed if the test evaluates to true; they are consumed
6229 by this function and become part of the constructed op tree. I<cond>
6230 will be interpreted DWIMically, often as a comparison against C<$_>,
6231 and may be null to generate a C<default> block.
6237 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6239 const bool cond_llb = (!cond || looks_like_bool(cond));
6242 PERL_ARGS_ASSERT_NEWWHENOP;
6247 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6249 scalar(ref_array_or_hash(cond)));
6252 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6256 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
6259 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
6261 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
6262 || (p && (len != SvCUR(cv) /* Not the same length. */
6263 || memNE(p, SvPVX_const(cv), len))))
6264 && ckWARN_d(WARN_PROTOTYPE)) {
6265 SV* const msg = sv_newmortal();
6269 gv_efullname3(name = sv_newmortal(), gv, NULL);
6270 sv_setpvs(msg, "Prototype mismatch:");
6272 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6274 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
6276 sv_catpvs(msg, ": none");
6277 sv_catpvs(msg, " vs ");
6279 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
6281 sv_catpvs(msg, "none");
6282 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6286 static void const_sv_xsub(pTHX_ CV* cv);
6290 =head1 Optree Manipulation Functions
6292 =for apidoc cv_const_sv
6294 If C<cv> is a constant sub eligible for inlining. returns the constant
6295 value returned by the sub. Otherwise, returns NULL.
6297 Constant subs can be created with C<newCONSTSUB> or as described in
6298 L<perlsub/"Constant Functions">.
6303 Perl_cv_const_sv(pTHX_ const CV *const cv)
6305 PERL_UNUSED_CONTEXT;
6308 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6310 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6313 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6314 * Can be called in 3 ways:
6317 * look for a single OP_CONST with attached value: return the value
6319 * cv && CvCLONE(cv) && !CvCONST(cv)
6321 * examine the clone prototype, and if contains only a single
6322 * OP_CONST referencing a pad const, or a single PADSV referencing
6323 * an outer lexical, return a non-zero value to indicate the CV is
6324 * a candidate for "constizing" at clone time
6328 * We have just cloned an anon prototype that was marked as a const
6329 * candidate. Try to grab the current value, and in the case of
6330 * PADSV, ignore it if it has multiple references. Return the value.
6334 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6345 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6346 o = cLISTOPo->op_first->op_sibling;
6348 for (; o; o = o->op_next) {
6349 const OPCODE type = o->op_type;
6351 if (sv && o->op_next == o)
6353 if (o->op_next != o) {
6354 if (type == OP_NEXTSTATE
6355 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6356 || type == OP_PUSHMARK)
6358 if (type == OP_DBSTATE)
6361 if (type == OP_LEAVESUB || type == OP_RETURN)
6365 if (type == OP_CONST && cSVOPo->op_sv)
6367 else if (cv && type == OP_CONST) {
6368 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6372 else if (cv && type == OP_PADSV) {
6373 if (CvCONST(cv)) { /* newly cloned anon */
6374 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6375 /* the candidate should have 1 ref from this pad and 1 ref
6376 * from the parent */
6377 if (!sv || SvREFCNT(sv) != 2)
6384 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6385 sv = &PL_sv_undef; /* an arbitrary non-null value */
6400 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6403 /* This would be the return value, but the return cannot be reached. */
6404 OP* pegop = newOP(OP_NULL, 0);
6407 PERL_UNUSED_ARG(floor);
6417 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6419 NORETURN_FUNCTION_END;
6424 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6429 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6430 register CV *cv = NULL;
6432 /* If the subroutine has no body, no attributes, and no builtin attributes
6433 then it's just a sub declaration, and we may be able to get away with
6434 storing with a placeholder scalar in the symbol table, rather than a
6435 full GV and CV. If anything is present then it will take a full CV to
6437 const I32 gv_fetch_flags
6438 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6440 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6441 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6445 assert(proto->op_type == OP_CONST);
6446 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6452 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6454 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6455 SV * const sv = sv_newmortal();
6456 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6457 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6458 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6459 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6461 } else if (PL_curstash) {
6462 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6465 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6469 if (!PL_madskills) {
6478 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6479 maximum a prototype before. */
6480 if (SvTYPE(gv) > SVt_NULL) {
6481 if (!SvPOK((const SV *)gv)
6482 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6484 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6486 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6489 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6491 sv_setiv(MUTABLE_SV(gv), -1);
6493 SvREFCNT_dec(PL_compcv);
6494 cv = PL_compcv = NULL;
6498 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6500 if (!block || !ps || *ps || attrs
6501 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6503 || block->op_type == OP_NULL
6508 const_sv = op_const_sv(block, NULL);
6511 const bool exists = CvROOT(cv) || CvXSUB(cv);
6513 /* if the subroutine doesn't exist and wasn't pre-declared
6514 * with a prototype, assume it will be AUTOLOADed,
6515 * skipping the prototype check
6517 if (exists || SvPOK(cv))
6518 cv_ckproto_len(cv, gv, ps, ps_len);
6519 /* already defined (or promised)? */
6520 if (exists || GvASSUMECV(gv)) {
6523 || block->op_type == OP_NULL
6526 if (CvFLAGS(PL_compcv)) {
6527 /* might have had built-in attrs applied */
6528 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6529 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6530 && ckWARN(WARN_MISC))
6531 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6533 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6534 & ~(CVf_LVALUE * pureperl));
6536 if (attrs) goto attrs;
6537 /* just a "sub foo;" when &foo is already defined */
6538 SAVEFREESV(PL_compcv);
6543 && block->op_type != OP_NULL
6546 if (ckWARN(WARN_REDEFINE)
6548 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6550 const line_t oldline = CopLINE(PL_curcop);
6551 if (PL_parser && PL_parser->copline != NOLINE)
6552 CopLINE_set(PL_curcop, PL_parser->copline);
6553 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6554 CvCONST(cv) ? "Constant subroutine %s redefined"
6555 : "Subroutine %s redefined", name);
6556 CopLINE_set(PL_curcop, oldline);
6559 if (!PL_minus_c) /* keep old one around for madskills */
6562 /* (PL_madskills unset in used file.) */
6570 SvREFCNT_inc_simple_void_NN(const_sv);
6572 assert(!CvROOT(cv) && !CvCONST(cv));
6573 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6574 CvXSUBANY(cv).any_ptr = const_sv;
6575 CvXSUB(cv) = const_sv_xsub;
6581 cv = newCONSTSUB(NULL, name, const_sv);
6583 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6584 (CvGV(cv) && GvSTASH(CvGV(cv)))
6593 SvREFCNT_dec(PL_compcv);
6597 if (cv) { /* must reuse cv if autoloaded */
6598 /* transfer PL_compcv to cv */
6601 && block->op_type != OP_NULL
6604 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6605 AV *const temp_av = CvPADLIST(cv);
6606 CV *const temp_cv = CvOUTSIDE(cv);
6608 assert(!CvWEAKOUTSIDE(cv));
6609 assert(!CvCVGV_RC(cv));
6610 assert(CvGV(cv) == gv);
6613 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6614 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6615 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6616 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6617 CvOUTSIDE(PL_compcv) = temp_cv;
6618 CvPADLIST(PL_compcv) = temp_av;
6620 if (CvFILE(cv) && CvDYNFILE(cv)) {
6621 Safefree(CvFILE(cv));
6623 CvFILE_set_from_cop(cv, PL_curcop);
6624 CvSTASH_set(cv, PL_curstash);
6626 /* inner references to PL_compcv must be fixed up ... */
6627 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6628 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6629 ++PL_sub_generation;
6632 /* Might have had built-in attributes applied -- propagate them. */
6633 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6635 /* ... before we throw it away */
6636 SvREFCNT_dec(PL_compcv);
6644 if (strEQ(name, "import")) {
6645 PL_formfeed = MUTABLE_SV(cv);
6646 /* diag_listed_as: SKIPME */
6647 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6651 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6656 CvFILE_set_from_cop(cv, PL_curcop);
6657 CvSTASH_set(cv, PL_curstash);
6661 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6662 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6663 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6667 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
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 SvCUR(tmpstr), sv, 0);
6743 hv = GvHVn(db_postponed);
6744 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), 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 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6837 eligible for inlining at compile-time.
6839 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6840 which won't be called if used as a destructor, but will suppress the overhead
6841 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6848 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6853 const char *const file = CopFILE(PL_curcop);
6855 SV *const temp_sv = CopFILESV(PL_curcop);
6856 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6861 if (IN_PERL_RUNTIME) {
6862 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6863 * an op shared between threads. Use a non-shared COP for our
6865 SAVEVPTR(PL_curcop);
6866 PL_curcop = &PL_compiling;
6868 SAVECOPLINE(PL_curcop);
6869 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6872 PL_hints &= ~HINT_BLOCK_SCOPE;
6875 SAVESPTR(PL_curstash);
6876 SAVECOPSTASH(PL_curcop);
6877 PL_curstash = stash;
6878 CopSTASH_set(PL_curcop,stash);
6881 /* file becomes the CvFILE. For an XS, it's usually static storage,
6882 and so doesn't get free()d. (It's expected to be from the C pre-
6883 processor __FILE__ directive). But we need a dynamically allocated one,
6884 and we need it to get freed. */
6885 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6886 XS_DYNAMIC_FILENAME);
6887 CvXSUBANY(cv).any_ptr = sv;
6892 CopSTASH_free(PL_curcop);
6900 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6901 const char *const filename, const char *const proto,
6904 CV *cv = newXS(name, subaddr, filename);
6906 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6908 if (flags & XS_DYNAMIC_FILENAME) {
6909 CvFILE(cv) = savepv(filename);
6912 sv_setpv(MUTABLE_SV(cv), proto);
6917 =for apidoc U||newXS
6919 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6920 static storage, as it is used directly as CvFILE(), without a copy being made.
6926 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6929 GV * const gv = gv_fetchpv(name ? name :
6930 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6931 GV_ADDMULTI, SVt_PVCV);
6934 PERL_ARGS_ASSERT_NEWXS;
6937 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6939 if ((cv = (name ? GvCV(gv) : NULL))) {
6941 /* just a cached method */
6945 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6946 /* already defined (or promised) */
6947 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6948 if (ckWARN(WARN_REDEFINE)) {
6949 GV * const gvcv = CvGV(cv);
6951 HV * const stash = GvSTASH(gvcv);
6953 const char *redefined_name = HvNAME_get(stash);
6954 if ( strEQ(redefined_name,"autouse") ) {
6955 const line_t oldline = CopLINE(PL_curcop);
6956 if (PL_parser && PL_parser->copline != NOLINE)
6957 CopLINE_set(PL_curcop, PL_parser->copline);
6958 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6959 CvCONST(cv) ? "Constant subroutine %s redefined"
6960 : "Subroutine %s redefined"
6962 CopLINE_set(PL_curcop, oldline);
6972 if (cv) /* must reuse cv if autoloaded */
6975 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6979 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6985 (void)gv_fetchfile(filename);
6986 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6987 an external constant string */
6988 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
6990 CvXSUB(cv) = subaddr;
6993 process_special_blocks(name, gv, cv);
7003 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7008 OP* pegop = newOP(OP_NULL, 0);
7012 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7013 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7016 if ((cv = GvFORM(gv))) {
7017 if (ckWARN(WARN_REDEFINE)) {
7018 const line_t oldline = CopLINE(PL_curcop);
7019 if (PL_parser && PL_parser->copline != NOLINE)
7020 CopLINE_set(PL_curcop, PL_parser->copline);
7022 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7023 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7025 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7026 "Format STDOUT redefined");
7028 CopLINE_set(PL_curcop, oldline);
7035 CvFILE_set_from_cop(cv, PL_curcop);
7038 pad_tidy(padtidy_FORMAT);
7039 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7040 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7041 OpREFCNT_set(CvROOT(cv), 1);
7042 CvSTART(cv) = LINKLIST(CvROOT(cv));
7043 CvROOT(cv)->op_next = 0;
7044 CALL_PEEP(CvSTART(cv));
7045 finalize_optree(CvROOT(cv));
7047 op_getmad(o,pegop,'n');
7048 op_getmad_weak(block, pegop, 'b');
7053 PL_parser->copline = NOLINE;
7061 Perl_newANONLIST(pTHX_ OP *o)
7063 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7067 Perl_newANONHASH(pTHX_ OP *o)
7069 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7073 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7075 return newANONATTRSUB(floor, proto, NULL, block);
7079 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7081 return newUNOP(OP_REFGEN, 0,
7082 newSVOP(OP_ANONCODE, 0,
7083 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7087 Perl_oopsAV(pTHX_ OP *o)
7091 PERL_ARGS_ASSERT_OOPSAV;
7093 switch (o->op_type) {
7095 o->op_type = OP_PADAV;
7096 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7097 return ref(o, OP_RV2AV);
7100 o->op_type = OP_RV2AV;
7101 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7106 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7113 Perl_oopsHV(pTHX_ OP *o)
7117 PERL_ARGS_ASSERT_OOPSHV;
7119 switch (o->op_type) {
7122 o->op_type = OP_PADHV;
7123 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7124 return ref(o, OP_RV2HV);
7128 o->op_type = OP_RV2HV;
7129 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7134 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7141 Perl_newAVREF(pTHX_ OP *o)
7145 PERL_ARGS_ASSERT_NEWAVREF;
7147 if (o->op_type == OP_PADANY) {
7148 o->op_type = OP_PADAV;
7149 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7152 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7153 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7154 "Using an array as a reference is deprecated");
7156 return newUNOP(OP_RV2AV, 0, scalar(o));
7160 Perl_newGVREF(pTHX_ I32 type, OP *o)
7162 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7163 return newUNOP(OP_NULL, 0, o);
7164 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7168 Perl_newHVREF(pTHX_ OP *o)
7172 PERL_ARGS_ASSERT_NEWHVREF;
7174 if (o->op_type == OP_PADANY) {
7175 o->op_type = OP_PADHV;
7176 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7179 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7180 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7181 "Using a hash as a reference is deprecated");
7183 return newUNOP(OP_RV2HV, 0, scalar(o));
7187 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7189 return newUNOP(OP_RV2CV, flags, scalar(o));
7193 Perl_newSVREF(pTHX_ OP *o)
7197 PERL_ARGS_ASSERT_NEWSVREF;
7199 if (o->op_type == OP_PADANY) {
7200 o->op_type = OP_PADSV;
7201 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7204 return newUNOP(OP_RV2SV, 0, scalar(o));
7207 /* Check routines. See the comments at the top of this file for details
7208 * on when these are called */
7211 Perl_ck_anoncode(pTHX_ OP *o)
7213 PERL_ARGS_ASSERT_CK_ANONCODE;
7215 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7217 cSVOPo->op_sv = NULL;
7222 Perl_ck_bitop(pTHX_ OP *o)
7226 PERL_ARGS_ASSERT_CK_BITOP;
7228 #define OP_IS_NUMCOMPARE(op) \
7229 ((op) == OP_LT || (op) == OP_I_LT || \
7230 (op) == OP_GT || (op) == OP_I_GT || \
7231 (op) == OP_LE || (op) == OP_I_LE || \
7232 (op) == OP_GE || (op) == OP_I_GE || \
7233 (op) == OP_EQ || (op) == OP_I_EQ || \
7234 (op) == OP_NE || (op) == OP_I_NE || \
7235 (op) == OP_NCMP || (op) == OP_I_NCMP)
7236 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7237 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7238 && (o->op_type == OP_BIT_OR
7239 || o->op_type == OP_BIT_AND
7240 || o->op_type == OP_BIT_XOR))
7242 const OP * const left = cBINOPo->op_first;
7243 const OP * const right = left->op_sibling;
7244 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7245 (left->op_flags & OPf_PARENS) == 0) ||
7246 (OP_IS_NUMCOMPARE(right->op_type) &&
7247 (right->op_flags & OPf_PARENS) == 0))
7248 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7249 "Possible precedence problem on bitwise %c operator",
7250 o->op_type == OP_BIT_OR ? '|'
7251 : o->op_type == OP_BIT_AND ? '&' : '^'
7258 Perl_ck_concat(pTHX_ OP *o)
7260 const OP * const kid = cUNOPo->op_first;
7262 PERL_ARGS_ASSERT_CK_CONCAT;
7263 PERL_UNUSED_CONTEXT;
7265 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7266 !(kUNOP->op_first->op_flags & OPf_MOD))
7267 o->op_flags |= OPf_STACKED;
7272 Perl_ck_spair(pTHX_ OP *o)
7276 PERL_ARGS_ASSERT_CK_SPAIR;
7278 if (o->op_flags & OPf_KIDS) {
7281 const OPCODE type = o->op_type;
7282 o = modkids(ck_fun(o), type);
7283 kid = cUNOPo->op_first;
7284 newop = kUNOP->op_first->op_sibling;
7286 const OPCODE type = newop->op_type;
7287 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7288 type == OP_PADAV || type == OP_PADHV ||
7289 type == OP_RV2AV || type == OP_RV2HV)
7293 op_getmad(kUNOP->op_first,newop,'K');
7295 op_free(kUNOP->op_first);
7297 kUNOP->op_first = newop;
7299 o->op_ppaddr = PL_ppaddr[++o->op_type];
7304 Perl_ck_delete(pTHX_ OP *o)
7306 PERL_ARGS_ASSERT_CK_DELETE;
7310 if (o->op_flags & OPf_KIDS) {
7311 OP * const kid = cUNOPo->op_first;
7312 switch (kid->op_type) {
7314 o->op_flags |= OPf_SPECIAL;
7317 o->op_private |= OPpSLICE;
7320 o->op_flags |= OPf_SPECIAL;
7325 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7328 if (kid->op_private & OPpLVAL_INTRO)
7329 o->op_private |= OPpLVAL_INTRO;
7336 Perl_ck_die(pTHX_ OP *o)
7338 PERL_ARGS_ASSERT_CK_DIE;
7341 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7347 Perl_ck_eof(pTHX_ OP *o)
7351 PERL_ARGS_ASSERT_CK_EOF;
7353 if (o->op_flags & OPf_KIDS) {
7354 if (cLISTOPo->op_first->op_type == OP_STUB) {
7356 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7358 op_getmad(o,newop,'O');
7370 Perl_ck_eval(pTHX_ OP *o)
7374 PERL_ARGS_ASSERT_CK_EVAL;
7376 PL_hints |= HINT_BLOCK_SCOPE;
7377 if (o->op_flags & OPf_KIDS) {
7378 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7381 o->op_flags &= ~OPf_KIDS;
7384 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7390 cUNOPo->op_first = 0;
7395 NewOp(1101, enter, 1, LOGOP);
7396 enter->op_type = OP_ENTERTRY;
7397 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7398 enter->op_private = 0;
7400 /* establish postfix order */
7401 enter->op_next = (OP*)enter;
7403 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7404 o->op_type = OP_LEAVETRY;
7405 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7406 enter->op_other = o;
7407 op_getmad(oldo,o,'O');
7421 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7422 op_getmad(oldo,o,'O');
7424 o->op_targ = (PADOFFSET)PL_hints;
7425 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7426 /* Store a copy of %^H that pp_entereval can pick up. */
7427 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7428 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7429 cUNOPo->op_first->op_sibling = hhop;
7430 o->op_private |= OPpEVAL_HAS_HH;
7436 Perl_ck_exit(pTHX_ OP *o)
7438 PERL_ARGS_ASSERT_CK_EXIT;
7441 HV * const table = GvHV(PL_hintgv);
7443 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7444 if (svp && *svp && SvTRUE(*svp))
7445 o->op_private |= OPpEXIT_VMSISH;
7447 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7453 Perl_ck_exec(pTHX_ OP *o)
7455 PERL_ARGS_ASSERT_CK_EXEC;
7457 if (o->op_flags & OPf_STACKED) {
7460 kid = cUNOPo->op_first->op_sibling;
7461 if (kid->op_type == OP_RV2GV)
7470 Perl_ck_exists(pTHX_ OP *o)
7474 PERL_ARGS_ASSERT_CK_EXISTS;
7477 if (o->op_flags & OPf_KIDS) {
7478 OP * const kid = cUNOPo->op_first;
7479 if (kid->op_type == OP_ENTERSUB) {
7480 (void) ref(kid, o->op_type);
7481 if (kid->op_type != OP_RV2CV
7482 && !(PL_parser && PL_parser->error_count))
7483 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7485 o->op_private |= OPpEXISTS_SUB;
7487 else if (kid->op_type == OP_AELEM)
7488 o->op_flags |= OPf_SPECIAL;
7489 else if (kid->op_type != OP_HELEM)
7490 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7498 Perl_ck_rvconst(pTHX_ register OP *o)
7501 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7503 PERL_ARGS_ASSERT_CK_RVCONST;
7505 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7506 if (o->op_type == OP_RV2CV)
7507 o->op_private &= ~1;
7509 if (kid->op_type == OP_CONST) {
7512 SV * const kidsv = kid->op_sv;
7514 /* Is it a constant from cv_const_sv()? */
7515 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7516 SV * const rsv = SvRV(kidsv);
7517 const svtype type = SvTYPE(rsv);
7518 const char *badtype = NULL;
7520 switch (o->op_type) {
7522 if (type > SVt_PVMG)
7523 badtype = "a SCALAR";
7526 if (type != SVt_PVAV)
7527 badtype = "an ARRAY";
7530 if (type != SVt_PVHV)
7534 if (type != SVt_PVCV)
7539 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7542 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7543 const char *badthing;
7544 switch (o->op_type) {
7546 badthing = "a SCALAR";
7549 badthing = "an ARRAY";
7552 badthing = "a HASH";
7560 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7561 SVfARG(kidsv), badthing);
7564 * This is a little tricky. We only want to add the symbol if we
7565 * didn't add it in the lexer. Otherwise we get duplicate strict
7566 * warnings. But if we didn't add it in the lexer, we must at
7567 * least pretend like we wanted to add it even if it existed before,
7568 * or we get possible typo warnings. OPpCONST_ENTERED says
7569 * whether the lexer already added THIS instance of this symbol.
7571 iscv = (o->op_type == OP_RV2CV) * 2;
7573 gv = gv_fetchsv(kidsv,
7574 iscv | !(kid->op_private & OPpCONST_ENTERED),
7577 : o->op_type == OP_RV2SV
7579 : o->op_type == OP_RV2AV
7581 : o->op_type == OP_RV2HV
7584 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7586 kid->op_type = OP_GV;
7587 SvREFCNT_dec(kid->op_sv);
7589 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7590 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7591 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7593 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7595 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7597 kid->op_private = 0;
7598 kid->op_ppaddr = PL_ppaddr[OP_GV];
7599 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7607 Perl_ck_ftst(pTHX_ OP *o)
7610 const I32 type = o->op_type;
7612 PERL_ARGS_ASSERT_CK_FTST;
7614 if (o->op_flags & OPf_REF) {
7617 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7618 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7619 const OPCODE kidtype = kid->op_type;
7621 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7622 OP * const newop = newGVOP(type, OPf_REF,
7623 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7625 op_getmad(o,newop,'O');
7631 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7632 o->op_private |= OPpFT_ACCESS;
7633 if (PL_check[kidtype] == Perl_ck_ftst
7634 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7635 o->op_private |= OPpFT_STACKED;
7636 kid->op_private |= OPpFT_STACKING;
7645 if (type == OP_FTTTY)
7646 o = newGVOP(type, OPf_REF, PL_stdingv);
7648 o = newUNOP(type, 0, newDEFSVOP());
7649 op_getmad(oldo,o,'O');
7655 Perl_ck_fun(pTHX_ OP *o)
7658 const int type = o->op_type;
7659 register I32 oa = PL_opargs[type] >> OASHIFT;
7661 PERL_ARGS_ASSERT_CK_FUN;
7663 if (o->op_flags & OPf_STACKED) {
7664 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7667 return no_fh_allowed(o);
7670 if (o->op_flags & OPf_KIDS) {
7671 OP **tokid = &cLISTOPo->op_first;
7672 register OP *kid = cLISTOPo->op_first;
7675 bool seen_optional = FALSE;
7677 if (kid->op_type == OP_PUSHMARK ||
7678 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7680 tokid = &kid->op_sibling;
7681 kid = kid->op_sibling;
7685 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
7686 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
7687 *tokid = kid = newDEFSVOP();
7688 seen_optional = TRUE;
7693 sibl = kid->op_sibling;
7695 if (!sibl && kid->op_type == OP_STUB) {
7702 /* list seen where single (scalar) arg expected? */
7703 if (numargs == 1 && !(oa >> 4)
7704 && kid->op_type == OP_LIST && type != OP_SCALAR)
7706 return too_many_arguments(o,PL_op_desc[type]);
7719 if ((type == OP_PUSH || type == OP_UNSHIFT)
7720 && !kid->op_sibling)
7721 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7722 "Useless use of %s with no values",
7725 if (kid->op_type == OP_CONST &&
7726 (kid->op_private & OPpCONST_BARE))
7728 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7729 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7730 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7731 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7732 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7734 op_getmad(kid,newop,'K');
7739 kid->op_sibling = sibl;
7742 else if (kid->op_type == OP_CONST
7743 && ( !SvROK(cSVOPx_sv(kid))
7744 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7746 bad_type(numargs, "array", PL_op_desc[type], kid);
7747 /* Defer checks to run-time if we have a scalar arg */
7748 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7749 op_lvalue(kid, type);
7753 if (kid->op_type == OP_CONST &&
7754 (kid->op_private & OPpCONST_BARE))
7756 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7757 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7758 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7759 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7760 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7762 op_getmad(kid,newop,'K');
7767 kid->op_sibling = sibl;
7770 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7771 bad_type(numargs, "hash", PL_op_desc[type], kid);
7772 op_lvalue(kid, type);
7776 OP * const newop = newUNOP(OP_NULL, 0, kid);
7777 kid->op_sibling = 0;
7779 newop->op_next = newop;
7781 kid->op_sibling = sibl;
7786 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7787 if (kid->op_type == OP_CONST &&
7788 (kid->op_private & OPpCONST_BARE))
7790 OP * const newop = newGVOP(OP_GV, 0,
7791 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7792 if (!(o->op_private & 1) && /* if not unop */
7793 kid == cLISTOPo->op_last)
7794 cLISTOPo->op_last = newop;
7796 op_getmad(kid,newop,'K');
7802 else if (kid->op_type == OP_READLINE) {
7803 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7804 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7807 I32 flags = OPf_SPECIAL;
7811 /* is this op a FH constructor? */
7812 if (is_handle_constructor(o,numargs)) {
7813 const char *name = NULL;
7817 /* Set a flag to tell rv2gv to vivify
7818 * need to "prove" flag does not mean something
7819 * else already - NI-S 1999/05/07
7822 if (kid->op_type == OP_PADSV) {
7824 = PAD_COMPNAME_SV(kid->op_targ);
7825 name = SvPV_const(namesv, len);
7827 else if (kid->op_type == OP_RV2SV
7828 && kUNOP->op_first->op_type == OP_GV)
7830 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7832 len = GvNAMELEN(gv);
7834 else if (kid->op_type == OP_AELEM
7835 || kid->op_type == OP_HELEM)
7838 OP *op = ((BINOP*)kid)->op_first;
7842 const char * const a =
7843 kid->op_type == OP_AELEM ?
7845 if (((op->op_type == OP_RV2AV) ||
7846 (op->op_type == OP_RV2HV)) &&
7847 (firstop = ((UNOP*)op)->op_first) &&
7848 (firstop->op_type == OP_GV)) {
7849 /* packagevar $a[] or $h{} */
7850 GV * const gv = cGVOPx_gv(firstop);
7858 else if (op->op_type == OP_PADAV
7859 || op->op_type == OP_PADHV) {
7860 /* lexicalvar $a[] or $h{} */
7861 const char * const padname =
7862 PAD_COMPNAME_PV(op->op_targ);
7871 name = SvPV_const(tmpstr, len);
7876 name = "__ANONIO__";
7879 op_lvalue(kid, type);
7883 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7884 namesv = PAD_SVl(targ);
7885 SvUPGRADE(namesv, SVt_PV);
7887 sv_setpvs(namesv, "$");
7888 sv_catpvn(namesv, name, len);
7891 kid->op_sibling = 0;
7892 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7893 kid->op_targ = targ;
7894 kid->op_private |= priv;
7896 kid->op_sibling = sibl;
7902 op_lvalue(scalar(kid), type);
7906 tokid = &kid->op_sibling;
7907 kid = kid->op_sibling;
7910 if (kid && kid->op_type != OP_STUB)
7911 return too_many_arguments(o,OP_DESC(o));
7912 o->op_private |= numargs;
7914 /* FIXME - should the numargs move as for the PERL_MAD case? */
7915 o->op_private |= numargs;
7917 return too_many_arguments(o,OP_DESC(o));
7921 else if (PL_opargs[type] & OA_DEFGV) {
7923 OP *newop = newUNOP(type, 0, newDEFSVOP());
7924 op_getmad(o,newop,'O');
7927 /* Ordering of these two is important to keep f_map.t passing. */
7929 return newUNOP(type, 0, newDEFSVOP());
7934 while (oa & OA_OPTIONAL)
7936 if (oa && oa != OA_LIST)
7937 return too_few_arguments(o,OP_DESC(o));
7943 Perl_ck_glob(pTHX_ OP *o)
7948 PERL_ARGS_ASSERT_CK_GLOB;
7951 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7952 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
7954 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7955 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7957 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7960 #if !defined(PERL_EXTERNAL_GLOB)
7961 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7964 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7965 newSVpvs("File::Glob"), NULL, NULL, NULL);
7966 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7967 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7968 GvCV_set(gv, GvCV(glob_gv));
7969 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7970 GvIMPORTED_CV_on(gv);
7974 #endif /* PERL_EXTERNAL_GLOB */
7976 assert(!(o->op_flags & OPf_SPECIAL));
7977 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7980 * \ null - const(wildcard)
7985 * \ mark - glob - rv2cv
7986 * | \ gv(CORE::GLOBAL::glob)
7988 * \ null - const(wildcard) - const(ix)
7990 o->op_flags |= OPf_SPECIAL;
7991 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
7992 op_append_elem(OP_GLOB, o,
7993 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7994 o = newLISTOP(OP_LIST, 0, o, NULL);
7995 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7996 op_append_elem(OP_LIST, o,
7997 scalar(newUNOP(OP_RV2CV, 0,
7998 newGVOP(OP_GV, 0, gv)))));
7999 o = newUNOP(OP_NULL, 0, ck_subr(o));
8000 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8003 gv = newGVgen("main");
8005 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8011 Perl_ck_grep(pTHX_ OP *o)
8016 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8019 PERL_ARGS_ASSERT_CK_GREP;
8021 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8022 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8024 if (o->op_flags & OPf_STACKED) {
8027 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8028 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8029 return no_fh_allowed(o);
8030 for (k = kid; k; k = k->op_next) {
8033 NewOp(1101, gwop, 1, LOGOP);
8034 kid->op_next = (OP*)gwop;
8035 o->op_flags &= ~OPf_STACKED;
8037 kid = cLISTOPo->op_first->op_sibling;
8038 if (type == OP_MAPWHILE)
8043 if (PL_parser && PL_parser->error_count)
8045 kid = cLISTOPo->op_first->op_sibling;
8046 if (kid->op_type != OP_NULL)
8047 Perl_croak(aTHX_ "panic: ck_grep");
8048 kid = kUNOP->op_first;
8051 NewOp(1101, gwop, 1, LOGOP);
8052 gwop->op_type = type;
8053 gwop->op_ppaddr = PL_ppaddr[type];
8054 gwop->op_first = listkids(o);
8055 gwop->op_flags |= OPf_KIDS;
8056 gwop->op_other = LINKLIST(kid);
8057 kid->op_next = (OP*)gwop;
8058 offset = pad_findmy_pvs("$_", 0);
8059 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8060 o->op_private = gwop->op_private = 0;
8061 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8064 o->op_private = gwop->op_private = OPpGREP_LEX;
8065 gwop->op_targ = o->op_targ = offset;
8068 kid = cLISTOPo->op_first->op_sibling;
8069 if (!kid || !kid->op_sibling)
8070 return too_few_arguments(o,OP_DESC(o));
8071 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8072 op_lvalue(kid, OP_GREPSTART);
8078 Perl_ck_index(pTHX_ OP *o)
8080 PERL_ARGS_ASSERT_CK_INDEX;
8082 if (o->op_flags & OPf_KIDS) {
8083 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8085 kid = kid->op_sibling; /* get past "big" */
8086 if (kid && kid->op_type == OP_CONST) {
8087 const bool save_taint = PL_tainted;
8088 fbm_compile(((SVOP*)kid)->op_sv, 0);
8089 PL_tainted = save_taint;
8096 Perl_ck_lfun(pTHX_ OP *o)
8098 const OPCODE type = o->op_type;
8100 PERL_ARGS_ASSERT_CK_LFUN;
8102 return modkids(ck_fun(o), type);
8106 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8108 PERL_ARGS_ASSERT_CK_DEFINED;
8110 if ((o->op_flags & OPf_KIDS)) {
8111 switch (cUNOPo->op_first->op_type) {
8113 /* This is needed for
8114 if (defined %stash::)
8115 to work. Do not break Tk.
8117 break; /* Globals via GV can be undef */
8119 case OP_AASSIGN: /* Is this a good idea? */
8120 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8121 "defined(@array) is deprecated");
8122 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8123 "\t(Maybe you should just omit the defined()?)\n");
8127 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8128 "defined(%%hash) is deprecated");
8129 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8130 "\t(Maybe you should just omit the defined()?)\n");
8141 Perl_ck_readline(pTHX_ OP *o)
8143 PERL_ARGS_ASSERT_CK_READLINE;
8145 if (!(o->op_flags & OPf_KIDS)) {
8147 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8149 op_getmad(o,newop,'O');
8159 Perl_ck_rfun(pTHX_ OP *o)
8161 const OPCODE type = o->op_type;
8163 PERL_ARGS_ASSERT_CK_RFUN;
8165 return refkids(ck_fun(o), type);
8169 Perl_ck_listiob(pTHX_ OP *o)
8173 PERL_ARGS_ASSERT_CK_LISTIOB;
8175 kid = cLISTOPo->op_first;
8178 kid = cLISTOPo->op_first;
8180 if (kid->op_type == OP_PUSHMARK)
8181 kid = kid->op_sibling;
8182 if (kid && o->op_flags & OPf_STACKED)
8183 kid = kid->op_sibling;
8184 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8185 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8186 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8187 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8188 cLISTOPo->op_first->op_sibling = kid;
8189 cLISTOPo->op_last = kid;
8190 kid = kid->op_sibling;
8195 op_append_elem(o->op_type, o, newDEFSVOP());
8201 Perl_ck_smartmatch(pTHX_ OP *o)
8204 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8205 if (0 == (o->op_flags & OPf_SPECIAL)) {
8206 OP *first = cBINOPo->op_first;
8207 OP *second = first->op_sibling;
8209 /* Implicitly take a reference to an array or hash */
8210 first->op_sibling = NULL;
8211 first = cBINOPo->op_first = ref_array_or_hash(first);
8212 second = first->op_sibling = ref_array_or_hash(second);
8214 /* Implicitly take a reference to a regular expression */
8215 if (first->op_type == OP_MATCH) {
8216 first->op_type = OP_QR;
8217 first->op_ppaddr = PL_ppaddr[OP_QR];
8219 if (second->op_type == OP_MATCH) {
8220 second->op_type = OP_QR;
8221 second->op_ppaddr = PL_ppaddr[OP_QR];
8230 Perl_ck_sassign(pTHX_ OP *o)
8233 OP * const kid = cLISTOPo->op_first;
8235 PERL_ARGS_ASSERT_CK_SASSIGN;
8237 /* has a disposable target? */
8238 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8239 && !(kid->op_flags & OPf_STACKED)
8240 /* Cannot steal the second time! */
8241 && !(kid->op_private & OPpTARGET_MY)
8242 /* Keep the full thing for madskills */
8246 OP * const kkid = kid->op_sibling;
8248 /* Can just relocate the target. */
8249 if (kkid && kkid->op_type == OP_PADSV
8250 && !(kkid->op_private & OPpLVAL_INTRO))
8252 kid->op_targ = kkid->op_targ;
8254 /* Now we do not need PADSV and SASSIGN. */
8255 kid->op_sibling = o->op_sibling; /* NULL */
8256 cLISTOPo->op_first = NULL;
8259 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8263 if (kid->op_sibling) {
8264 OP *kkid = kid->op_sibling;
8265 /* For state variable assignment, kkid is a list op whose op_last
8267 if ((kkid->op_type == OP_PADSV ||
8268 (kkid->op_type == OP_LIST &&
8269 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8272 && (kkid->op_private & OPpLVAL_INTRO)
8273 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8274 const PADOFFSET target = kkid->op_targ;
8275 OP *const other = newOP(OP_PADSV,
8277 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8278 OP *const first = newOP(OP_NULL, 0);
8279 OP *const nullop = newCONDOP(0, first, o, other);
8280 OP *const condop = first->op_next;
8281 /* hijacking PADSTALE for uninitialized state variables */
8282 SvPADSTALE_on(PAD_SVl(target));
8284 condop->op_type = OP_ONCE;
8285 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8286 condop->op_targ = target;
8287 other->op_targ = target;
8289 /* Because we change the type of the op here, we will skip the
8290 assignment binop->op_last = binop->op_first->op_sibling; at the
8291 end of Perl_newBINOP(). So need to do it here. */
8292 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8301 Perl_ck_match(pTHX_ OP *o)
8305 PERL_ARGS_ASSERT_CK_MATCH;
8307 if (o->op_type != OP_QR && PL_compcv) {
8308 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8309 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8310 o->op_targ = offset;
8311 o->op_private |= OPpTARGET_MY;
8314 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8315 o->op_private |= OPpRUNTIME;
8320 Perl_ck_method(pTHX_ OP *o)
8322 OP * const kid = cUNOPo->op_first;
8324 PERL_ARGS_ASSERT_CK_METHOD;
8326 if (kid->op_type == OP_CONST) {
8327 SV* sv = kSVOP->op_sv;
8328 const char * const method = SvPVX_const(sv);
8329 if (!(strchr(method, ':') || strchr(method, '\''))) {
8331 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8332 sv = newSVpvn_share(method, SvCUR(sv), 0);
8335 kSVOP->op_sv = NULL;
8337 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8339 op_getmad(o,cmop,'O');
8350 Perl_ck_null(pTHX_ OP *o)
8352 PERL_ARGS_ASSERT_CK_NULL;
8353 PERL_UNUSED_CONTEXT;
8358 Perl_ck_open(pTHX_ OP *o)
8361 HV * const table = GvHV(PL_hintgv);
8363 PERL_ARGS_ASSERT_CK_OPEN;
8366 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8369 const char *d = SvPV_const(*svp, len);
8370 const I32 mode = mode_from_discipline(d, len);
8371 if (mode & O_BINARY)
8372 o->op_private |= OPpOPEN_IN_RAW;
8373 else if (mode & O_TEXT)
8374 o->op_private |= OPpOPEN_IN_CRLF;
8377 svp = hv_fetchs(table, "open_OUT", FALSE);
8380 const char *d = SvPV_const(*svp, len);
8381 const I32 mode = mode_from_discipline(d, len);
8382 if (mode & O_BINARY)
8383 o->op_private |= OPpOPEN_OUT_RAW;
8384 else if (mode & O_TEXT)
8385 o->op_private |= OPpOPEN_OUT_CRLF;
8388 if (o->op_type == OP_BACKTICK) {
8389 if (!(o->op_flags & OPf_KIDS)) {
8390 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8392 op_getmad(o,newop,'O');
8401 /* In case of three-arg dup open remove strictness
8402 * from the last arg if it is a bareword. */
8403 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8404 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8408 if ((last->op_type == OP_CONST) && /* The bareword. */
8409 (last->op_private & OPpCONST_BARE) &&
8410 (last->op_private & OPpCONST_STRICT) &&
8411 (oa = first->op_sibling) && /* The fh. */
8412 (oa = oa->op_sibling) && /* The mode. */
8413 (oa->op_type == OP_CONST) &&
8414 SvPOK(((SVOP*)oa)->op_sv) &&
8415 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8416 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8417 (last == oa->op_sibling)) /* The bareword. */
8418 last->op_private &= ~OPpCONST_STRICT;
8424 Perl_ck_repeat(pTHX_ OP *o)
8426 PERL_ARGS_ASSERT_CK_REPEAT;
8428 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8429 o->op_private |= OPpREPEAT_DOLIST;
8430 cBINOPo->op_first = force_list(cBINOPo->op_first);
8438 Perl_ck_require(pTHX_ OP *o)
8443 PERL_ARGS_ASSERT_CK_REQUIRE;
8445 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8446 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8448 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8449 SV * const sv = kid->op_sv;
8450 U32 was_readonly = SvREADONLY(sv);
8457 sv_force_normal_flags(sv, 0);
8458 assert(!SvREADONLY(sv));
8468 for (; s < end; s++) {
8469 if (*s == ':' && s[1] == ':') {
8471 Move(s+2, s+1, end - s - 1, char);
8476 sv_catpvs(sv, ".pm");
8477 SvFLAGS(sv) |= was_readonly;
8481 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8482 /* handle override, if any */
8483 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8484 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8485 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8486 gv = gvp ? *gvp : NULL;
8490 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8491 OP * const kid = cUNOPo->op_first;
8494 cUNOPo->op_first = 0;
8498 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8499 op_append_elem(OP_LIST, kid,
8500 scalar(newUNOP(OP_RV2CV, 0,
8503 op_getmad(o,newop,'O');
8507 return scalar(ck_fun(o));
8511 Perl_ck_return(pTHX_ OP *o)
8516 PERL_ARGS_ASSERT_CK_RETURN;
8518 kid = cLISTOPo->op_first->op_sibling;
8519 if (CvLVALUE(PL_compcv)) {
8520 for (; kid; kid = kid->op_sibling)
8521 op_lvalue(kid, OP_LEAVESUBLV);
8528 Perl_ck_select(pTHX_ OP *o)
8533 PERL_ARGS_ASSERT_CK_SELECT;
8535 if (o->op_flags & OPf_KIDS) {
8536 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8537 if (kid && kid->op_sibling) {
8538 o->op_type = OP_SSELECT;
8539 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8541 return fold_constants(o);
8545 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8546 if (kid && kid->op_type == OP_RV2GV)
8547 kid->op_private &= ~HINT_STRICT_REFS;
8552 Perl_ck_shift(pTHX_ OP *o)
8555 const I32 type = o->op_type;
8557 PERL_ARGS_ASSERT_CK_SHIFT;
8559 if (!(o->op_flags & OPf_KIDS)) {
8562 if (!CvUNIQUE(PL_compcv)) {
8563 o->op_flags |= OPf_SPECIAL;
8567 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8570 OP * const oldo = o;
8571 o = newUNOP(type, 0, scalar(argop));
8572 op_getmad(oldo,o,'O');
8577 return newUNOP(type, 0, scalar(argop));
8580 return scalar(ck_fun(o));
8584 Perl_ck_sort(pTHX_ OP *o)
8589 PERL_ARGS_ASSERT_CK_SORT;
8591 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8592 HV * const hinthv = GvHV(PL_hintgv);
8594 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8596 const I32 sorthints = (I32)SvIV(*svp);
8597 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8598 o->op_private |= OPpSORT_QSORT;
8599 if ((sorthints & HINT_SORT_STABLE) != 0)
8600 o->op_private |= OPpSORT_STABLE;
8605 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8607 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8608 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8610 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8612 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8614 if (kid->op_type == OP_SCOPE) {
8618 else if (kid->op_type == OP_LEAVE) {
8619 if (o->op_type == OP_SORT) {
8620 op_null(kid); /* wipe out leave */
8623 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8624 if (k->op_next == kid)
8626 /* don't descend into loops */
8627 else if (k->op_type == OP_ENTERLOOP
8628 || k->op_type == OP_ENTERITER)
8630 k = cLOOPx(k)->op_lastop;
8635 kid->op_next = 0; /* just disconnect the leave */
8636 k = kLISTOP->op_first;
8641 if (o->op_type == OP_SORT) {
8642 /* provide scalar context for comparison function/block */
8648 o->op_flags |= OPf_SPECIAL;
8650 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8653 firstkid = firstkid->op_sibling;
8656 /* provide list context for arguments */
8657 if (o->op_type == OP_SORT)
8664 S_simplify_sort(pTHX_ OP *o)
8667 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8673 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8675 if (!(o->op_flags & OPf_STACKED))
8677 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8678 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8679 kid = kUNOP->op_first; /* get past null */
8680 if (kid->op_type != OP_SCOPE)
8682 kid = kLISTOP->op_last; /* get past scope */
8683 switch(kid->op_type) {
8691 k = kid; /* remember this node*/
8692 if (kBINOP->op_first->op_type != OP_RV2SV)
8694 kid = kBINOP->op_first; /* get past cmp */
8695 if (kUNOP->op_first->op_type != OP_GV)
8697 kid = kUNOP->op_first; /* get past rv2sv */
8699 if (GvSTASH(gv) != PL_curstash)
8701 gvname = GvNAME(gv);
8702 if (*gvname == 'a' && gvname[1] == '\0')
8704 else if (*gvname == 'b' && gvname[1] == '\0')
8709 kid = k; /* back to cmp */
8710 if (kBINOP->op_last->op_type != OP_RV2SV)
8712 kid = kBINOP->op_last; /* down to 2nd arg */
8713 if (kUNOP->op_first->op_type != OP_GV)
8715 kid = kUNOP->op_first; /* get past rv2sv */
8717 if (GvSTASH(gv) != PL_curstash)
8719 gvname = GvNAME(gv);
8721 ? !(*gvname == 'a' && gvname[1] == '\0')
8722 : !(*gvname == 'b' && gvname[1] == '\0'))
8724 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8726 o->op_private |= OPpSORT_DESCEND;
8727 if (k->op_type == OP_NCMP)
8728 o->op_private |= OPpSORT_NUMERIC;
8729 if (k->op_type == OP_I_NCMP)
8730 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8731 kid = cLISTOPo->op_first->op_sibling;
8732 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8734 op_getmad(kid,o,'S'); /* then delete it */
8736 op_free(kid); /* then delete it */
8741 Perl_ck_split(pTHX_ OP *o)
8746 PERL_ARGS_ASSERT_CK_SPLIT;
8748 if (o->op_flags & OPf_STACKED)
8749 return no_fh_allowed(o);
8751 kid = cLISTOPo->op_first;
8752 if (kid->op_type != OP_NULL)
8753 Perl_croak(aTHX_ "panic: ck_split");
8754 kid = kid->op_sibling;
8755 op_free(cLISTOPo->op_first);
8757 cLISTOPo->op_first = kid;
8759 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8760 cLISTOPo->op_last = kid; /* There was only one element previously */
8763 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8764 OP * const sibl = kid->op_sibling;
8765 kid->op_sibling = 0;
8766 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8767 if (cLISTOPo->op_first == cLISTOPo->op_last)
8768 cLISTOPo->op_last = kid;
8769 cLISTOPo->op_first = kid;
8770 kid->op_sibling = sibl;
8773 kid->op_type = OP_PUSHRE;
8774 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8776 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8777 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8778 "Use of /g modifier is meaningless in split");
8781 if (!kid->op_sibling)
8782 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8784 kid = kid->op_sibling;
8787 if (!kid->op_sibling)
8788 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8789 assert(kid->op_sibling);
8791 kid = kid->op_sibling;
8794 if (kid->op_sibling)
8795 return too_many_arguments(o,OP_DESC(o));
8801 Perl_ck_join(pTHX_ OP *o)
8803 const OP * const kid = cLISTOPo->op_first->op_sibling;
8805 PERL_ARGS_ASSERT_CK_JOIN;
8807 if (kid && kid->op_type == OP_MATCH) {
8808 if (ckWARN(WARN_SYNTAX)) {
8809 const REGEXP *re = PM_GETRE(kPMOP);
8810 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8811 const STRLEN len = re ? RX_PRELEN(re) : 6;
8812 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8813 "/%.*s/ should probably be written as \"%.*s\"",
8814 (int)len, pmstr, (int)len, pmstr);
8821 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8823 Examines an op, which is expected to identify a subroutine at runtime,
8824 and attempts to determine at compile time which subroutine it identifies.
8825 This is normally used during Perl compilation to determine whether
8826 a prototype can be applied to a function call. I<cvop> is the op
8827 being considered, normally an C<rv2cv> op. A pointer to the identified
8828 subroutine is returned, if it could be determined statically, and a null
8829 pointer is returned if it was not possible to determine statically.
8831 Currently, the subroutine can be identified statically if the RV that the
8832 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8833 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8834 suitable if the constant value must be an RV pointing to a CV. Details of
8835 this process may change in future versions of Perl. If the C<rv2cv> op
8836 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8837 the subroutine statically: this flag is used to suppress compile-time
8838 magic on a subroutine call, forcing it to use default runtime behaviour.
8840 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8841 of a GV reference is modified. If a GV was examined and its CV slot was
8842 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8843 If the op is not optimised away, and the CV slot is later populated with
8844 a subroutine having a prototype, that flag eventually triggers the warning
8845 "called too early to check prototype".
8847 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8848 of returning a pointer to the subroutine it returns a pointer to the
8849 GV giving the most appropriate name for the subroutine in this context.
8850 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8851 (C<CvANON>) subroutine that is referenced through a GV it will be the
8852 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8853 A null pointer is returned as usual if there is no statically-determinable
8860 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8865 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8866 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8867 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8868 if (cvop->op_type != OP_RV2CV)
8870 if (cvop->op_private & OPpENTERSUB_AMPER)
8872 if (!(cvop->op_flags & OPf_KIDS))
8874 rvop = cUNOPx(cvop)->op_first;
8875 switch (rvop->op_type) {
8877 gv = cGVOPx_gv(rvop);
8880 if (flags & RV2CVOPCV_MARK_EARLY)
8881 rvop->op_private |= OPpEARLY_CV;
8886 SV *rv = cSVOPx_sv(rvop);
8896 if (SvTYPE((SV*)cv) != SVt_PVCV)
8898 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8899 if (!CvANON(cv) || !gv)
8908 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8910 Performs the default fixup of the arguments part of an C<entersub>
8911 op tree. This consists of applying list context to each of the
8912 argument ops. This is the standard treatment used on a call marked
8913 with C<&>, or a method call, or a call through a subroutine reference,
8914 or any other call where the callee can't be identified at compile time,
8915 or a call where the callee has no prototype.
8921 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8924 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8925 aop = cUNOPx(entersubop)->op_first;
8926 if (!aop->op_sibling)
8927 aop = cUNOPx(aop)->op_first;
8928 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8929 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8931 op_lvalue(aop, OP_ENTERSUB);
8938 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8940 Performs the fixup of the arguments part of an C<entersub> op tree
8941 based on a subroutine prototype. This makes various modifications to
8942 the argument ops, from applying context up to inserting C<refgen> ops,
8943 and checking the number and syntactic types of arguments, as directed by
8944 the prototype. This is the standard treatment used on a subroutine call,
8945 not marked with C<&>, where the callee can be identified at compile time
8946 and has a prototype.
8948 I<protosv> supplies the subroutine prototype to be applied to the call.
8949 It may be a normal defined scalar, of which the string value will be used.
8950 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8951 that has been cast to C<SV*>) which has a prototype. The prototype
8952 supplied, in whichever form, does not need to match the actual callee
8953 referenced by the op tree.
8955 If the argument ops disagree with the prototype, for example by having
8956 an unacceptable number of arguments, a valid op tree is returned anyway.
8957 The error is reflected in the parser state, normally resulting in a single
8958 exception at the top level of parsing which covers all the compilation
8959 errors that occurred. In the error message, the callee is referred to
8960 by the name defined by the I<namegv> parameter.
8966 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8969 const char *proto, *proto_end;
8970 OP *aop, *prev, *cvop;
8973 I32 contextclass = 0;
8974 const char *e = NULL;
8975 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8976 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8977 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8978 proto = SvPV(protosv, proto_len);
8979 proto_end = proto + proto_len;
8980 aop = cUNOPx(entersubop)->op_first;
8981 if (!aop->op_sibling)
8982 aop = cUNOPx(aop)->op_first;
8984 aop = aop->op_sibling;
8985 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8986 while (aop != cvop) {
8988 if (PL_madskills && aop->op_type == OP_STUB) {
8989 aop = aop->op_sibling;
8992 if (PL_madskills && aop->op_type == OP_NULL)
8993 o3 = ((UNOP*)aop)->op_first;
8997 if (proto >= proto_end)
8998 return too_many_arguments(entersubop, gv_ename(namegv));
9006 /* _ must be at the end */
9007 if (proto[1] && proto[1] != ';')
9022 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9024 arg == 1 ? "block or sub {}" : "sub {}",
9025 gv_ename(namegv), o3);
9028 /* '*' allows any scalar type, including bareword */
9031 if (o3->op_type == OP_RV2GV)
9032 goto wrapref; /* autoconvert GLOB -> GLOBref */
9033 else if (o3->op_type == OP_CONST)
9034 o3->op_private &= ~OPpCONST_STRICT;
9035 else if (o3->op_type == OP_ENTERSUB) {
9036 /* accidental subroutine, revert to bareword */
9037 OP *gvop = ((UNOP*)o3)->op_first;
9038 if (gvop && gvop->op_type == OP_NULL) {
9039 gvop = ((UNOP*)gvop)->op_first;
9041 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9044 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9045 (gvop = ((UNOP*)gvop)->op_first) &&
9046 gvop->op_type == OP_GV)
9048 GV * const gv = cGVOPx_gv(gvop);
9049 OP * const sibling = aop->op_sibling;
9050 SV * const n = newSVpvs("");
9052 OP * const oldaop = aop;
9056 gv_fullname4(n, gv, "", FALSE);
9057 aop = newSVOP(OP_CONST, 0, n);
9058 op_getmad(oldaop,aop,'O');
9059 prev->op_sibling = aop;
9060 aop->op_sibling = sibling;
9070 if (o3->op_type == OP_RV2AV ||
9071 o3->op_type == OP_PADAV ||
9072 o3->op_type == OP_RV2HV ||
9073 o3->op_type == OP_PADHV
9088 if (contextclass++ == 0) {
9089 e = strchr(proto, ']');
9090 if (!e || e == proto)
9099 const char *p = proto;
9100 const char *const end = proto;
9103 /* \[$] accepts any scalar lvalue */
9105 && Perl_op_lvalue_flags(aTHX_
9107 OP_READ, /* not entersub */
9110 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
9112 gv_ename(namegv), o3);
9117 if (o3->op_type == OP_RV2GV)
9120 bad_type(arg, "symbol", gv_ename(namegv), o3);
9123 if (o3->op_type == OP_ENTERSUB)
9126 bad_type(arg, "subroutine entry", gv_ename(namegv),
9130 if (o3->op_type == OP_RV2SV ||
9131 o3->op_type == OP_PADSV ||
9132 o3->op_type == OP_HELEM ||
9133 o3->op_type == OP_AELEM)
9135 if (!contextclass) {
9136 /* \$ accepts any scalar lvalue */
9137 if (Perl_op_lvalue_flags(aTHX_
9139 OP_READ, /* not entersub */
9142 bad_type(arg, "scalar", gv_ename(namegv), o3);
9146 if (o3->op_type == OP_RV2AV ||
9147 o3->op_type == OP_PADAV)
9150 bad_type(arg, "array", gv_ename(namegv), o3);
9153 if (o3->op_type == OP_RV2HV ||
9154 o3->op_type == OP_PADHV)
9157 bad_type(arg, "hash", gv_ename(namegv), o3);
9161 OP* const kid = aop;
9162 OP* const sib = kid->op_sibling;
9163 kid->op_sibling = 0;
9164 aop = newUNOP(OP_REFGEN, 0, kid);
9165 aop->op_sibling = sib;
9166 prev->op_sibling = aop;
9168 if (contextclass && e) {
9183 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
9184 gv_ename(namegv), SVfARG(protosv));
9187 op_lvalue(aop, OP_ENTERSUB);
9189 aop = aop->op_sibling;
9191 if (aop == cvop && *proto == '_') {
9192 /* generate an access to $_ */
9194 aop->op_sibling = prev->op_sibling;
9195 prev->op_sibling = aop; /* instead of cvop */
9197 if (!optional && proto_end > proto &&
9198 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9199 return too_few_arguments(entersubop, gv_ename(namegv));
9204 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9206 Performs the fixup of the arguments part of an C<entersub> op tree either
9207 based on a subroutine prototype or using default list-context processing.
9208 This is the standard treatment used on a subroutine call, not marked
9209 with C<&>, where the callee can be identified at compile time.
9211 I<protosv> supplies the subroutine prototype to be applied to the call,
9212 or indicates that there is no prototype. It may be a normal scalar,
9213 in which case if it is defined then the string value will be used
9214 as a prototype, and if it is undefined then there is no prototype.
9215 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9216 that has been cast to C<SV*>), of which the prototype will be used if it
9217 has one. The prototype (or lack thereof) supplied, in whichever form,
9218 does not need to match the actual callee referenced by the op tree.
9220 If the argument ops disagree with the prototype, for example by having
9221 an unacceptable number of arguments, a valid op tree is returned anyway.
9222 The error is reflected in the parser state, normally resulting in a single
9223 exception at the top level of parsing which covers all the compilation
9224 errors that occurred. In the error message, the callee is referred to
9225 by the name defined by the I<namegv> parameter.
9231 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9232 GV *namegv, SV *protosv)
9234 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9235 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9236 return ck_entersub_args_proto(entersubop, namegv, protosv);
9238 return ck_entersub_args_list(entersubop);
9242 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9244 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9245 OP *aop = cUNOPx(entersubop)->op_first;
9247 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9251 if (!aop->op_sibling)
9252 aop = cUNOPx(aop)->op_first;
9254 aop = aop->op_sibling;
9255 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9256 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9257 aop = aop->op_sibling;
9261 (void)too_many_arguments(entersubop, GvNAME(namegv));
9263 op_free(entersubop);
9264 switch(GvNAME(namegv)[2]) {
9265 case 'F': return newSVOP(OP_CONST, 0,
9266 newSVpv(CopFILE(PL_curcop),0));
9267 case 'L': return newSVOP(
9270 "%"IVdf, (IV)CopLINE(PL_curcop)
9273 case 'P': return newSVOP(OP_CONST, 0,
9275 ? newSVhek(HvNAME_HEK(PL_curstash))
9286 bool seenarg = FALSE;
9288 if (!aop->op_sibling)
9289 aop = cUNOPx(aop)->op_first;
9292 aop = aop->op_sibling;
9293 prev->op_sibling = NULL;
9296 prev=cvop, cvop = cvop->op_sibling)
9298 if (PL_madskills && cvop->op_sibling
9299 && cvop->op_type != OP_STUB) seenarg = TRUE
9302 prev->op_sibling = NULL;
9303 paren = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9305 if (aop == cvop) aop = NULL;
9306 op_free(entersubop);
9308 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9310 case OA_BASEOP_OR_UNOP:
9312 return aop ? newUNOP(opnum,paren,aop) : newOP(opnum,paren);
9316 if (!PL_madskills || seenarg)
9318 (void)too_many_arguments(aop, GvNAME(namegv));
9321 return newOP(opnum,0);
9323 return convert(opnum,0,aop);
9331 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9333 Retrieves the function that will be used to fix up a call to I<cv>.
9334 Specifically, the function is applied to an C<entersub> op tree for a
9335 subroutine call, not marked with C<&>, where the callee can be identified
9336 at compile time as I<cv>.
9338 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9339 argument for it is returned in I<*ckobj_p>. The function is intended
9340 to be called in this manner:
9342 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9344 In this call, I<entersubop> is a pointer to the C<entersub> op,
9345 which may be replaced by the check function, and I<namegv> is a GV
9346 supplying the name that should be used by the check function to refer
9347 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9348 It is permitted to apply the check function in non-standard situations,
9349 such as to a call to a different subroutine or to a method call.
9351 By default, the function is
9352 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9353 and the SV parameter is I<cv> itself. This implements standard
9354 prototype processing. It can be changed, for a particular subroutine,
9355 by L</cv_set_call_checker>.
9361 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9364 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9365 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9367 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9368 *ckobj_p = callmg->mg_obj;
9370 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9376 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9378 Sets the function that will be used to fix up a call to I<cv>.
9379 Specifically, the function is applied to an C<entersub> op tree for a
9380 subroutine call, not marked with C<&>, where the callee can be identified
9381 at compile time as I<cv>.
9383 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9384 for it is supplied in I<ckobj>. The function is intended to be called
9387 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9389 In this call, I<entersubop> is a pointer to the C<entersub> op,
9390 which may be replaced by the check function, and I<namegv> is a GV
9391 supplying the name that should be used by the check function to refer
9392 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9393 It is permitted to apply the check function in non-standard situations,
9394 such as to a call to a different subroutine or to a method call.
9396 The current setting for a particular CV can be retrieved by
9397 L</cv_get_call_checker>.
9403 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9405 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9406 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9407 if (SvMAGICAL((SV*)cv))
9408 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9411 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9412 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9413 if (callmg->mg_flags & MGf_REFCOUNTED) {
9414 SvREFCNT_dec(callmg->mg_obj);
9415 callmg->mg_flags &= ~MGf_REFCOUNTED;
9417 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9418 callmg->mg_obj = ckobj;
9419 if (ckobj != (SV*)cv) {
9420 SvREFCNT_inc_simple_void_NN(ckobj);
9421 callmg->mg_flags |= MGf_REFCOUNTED;
9427 Perl_ck_subr(pTHX_ OP *o)
9433 PERL_ARGS_ASSERT_CK_SUBR;
9435 aop = cUNOPx(o)->op_first;
9436 if (!aop->op_sibling)
9437 aop = cUNOPx(aop)->op_first;
9438 aop = aop->op_sibling;
9439 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9440 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9441 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9443 o->op_private &= ~1;
9444 o->op_private |= OPpENTERSUB_HASTARG;
9445 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9446 if (PERLDB_SUB && PL_curstash != PL_debstash)
9447 o->op_private |= OPpENTERSUB_DB;
9448 if (cvop->op_type == OP_RV2CV) {
9449 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9451 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9452 if (aop->op_type == OP_CONST)
9453 aop->op_private &= ~OPpCONST_STRICT;
9454 else if (aop->op_type == OP_LIST) {
9455 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9456 if (sib && sib->op_type == OP_CONST)
9457 sib->op_private &= ~OPpCONST_STRICT;
9462 return ck_entersub_args_list(o);
9464 Perl_call_checker ckfun;
9466 cv_get_call_checker(cv, &ckfun, &ckobj);
9467 return ckfun(aTHX_ o, namegv, ckobj);
9472 Perl_ck_svconst(pTHX_ OP *o)
9474 PERL_ARGS_ASSERT_CK_SVCONST;
9475 PERL_UNUSED_CONTEXT;
9476 SvREADONLY_on(cSVOPo->op_sv);
9481 Perl_ck_chdir(pTHX_ OP *o)
9483 PERL_ARGS_ASSERT_CK_CHDIR;
9484 if (o->op_flags & OPf_KIDS) {
9485 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9487 if (kid && kid->op_type == OP_CONST &&
9488 (kid->op_private & OPpCONST_BARE))
9490 o->op_flags |= OPf_SPECIAL;
9491 kid->op_private &= ~OPpCONST_STRICT;
9498 Perl_ck_trunc(pTHX_ OP *o)
9500 PERL_ARGS_ASSERT_CK_TRUNC;
9502 if (o->op_flags & OPf_KIDS) {
9503 SVOP *kid = (SVOP*)cUNOPo->op_first;
9505 if (kid->op_type == OP_NULL)
9506 kid = (SVOP*)kid->op_sibling;
9507 if (kid && kid->op_type == OP_CONST &&
9508 (kid->op_private & OPpCONST_BARE))
9510 o->op_flags |= OPf_SPECIAL;
9511 kid->op_private &= ~OPpCONST_STRICT;
9518 Perl_ck_substr(pTHX_ OP *o)
9520 PERL_ARGS_ASSERT_CK_SUBSTR;
9523 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9524 OP *kid = cLISTOPo->op_first;
9526 if (kid->op_type == OP_NULL)
9527 kid = kid->op_sibling;
9529 kid->op_flags |= OPf_MOD;
9536 Perl_ck_each(pTHX_ OP *o)
9539 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9540 const unsigned orig_type = o->op_type;
9541 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9542 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9543 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9544 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9546 PERL_ARGS_ASSERT_CK_EACH;
9549 switch (kid->op_type) {
9555 CHANGE_TYPE(o, array_type);
9558 if (kid->op_private == OPpCONST_BARE
9559 || !SvROK(cSVOPx_sv(kid))
9560 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9561 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9563 /* we let ck_fun handle it */
9566 CHANGE_TYPE(o, ref_type);
9570 /* if treating as a reference, defer additional checks to runtime */
9571 return o->op_type == ref_type ? o : ck_fun(o);
9574 /* caller is supposed to assign the return to the
9575 container of the rep_op var */
9577 S_opt_scalarhv(pTHX_ OP *rep_op) {
9581 PERL_ARGS_ASSERT_OPT_SCALARHV;
9583 NewOp(1101, unop, 1, UNOP);
9584 unop->op_type = (OPCODE)OP_BOOLKEYS;
9585 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9586 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9587 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9588 unop->op_first = rep_op;
9589 unop->op_next = rep_op->op_next;
9590 rep_op->op_next = (OP*)unop;
9591 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9592 unop->op_sibling = rep_op->op_sibling;
9593 rep_op->op_sibling = NULL;
9594 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9595 if (rep_op->op_type == OP_PADHV) {
9596 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9597 rep_op->op_flags |= OPf_WANT_LIST;
9602 /* Checks if o acts as an in-place operator on an array. oright points to the
9603 * beginning of the right-hand side. Returns the left-hand side of the
9604 * assignment if o acts in-place, or NULL otherwise. */
9607 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9611 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9614 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9615 || oright->op_next != o
9616 || (oright->op_private & OPpLVAL_INTRO)
9620 /* o2 follows the chain of op_nexts through the LHS of the
9621 * assign (if any) to the aassign op itself */
9623 if (!o2 || o2->op_type != OP_NULL)
9626 if (!o2 || o2->op_type != OP_PUSHMARK)
9629 if (o2 && o2->op_type == OP_GV)
9632 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9633 || (o2->op_private & OPpLVAL_INTRO)
9638 if (!o2 || o2->op_type != OP_NULL)
9641 if (!o2 || o2->op_type != OP_AASSIGN
9642 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9645 /* check that the sort is the first arg on RHS of assign */
9647 o2 = cUNOPx(o2)->op_first;
9648 if (!o2 || o2->op_type != OP_NULL)
9650 o2 = cUNOPx(o2)->op_first;
9651 if (!o2 || o2->op_type != OP_PUSHMARK)
9653 if (o2->op_sibling != o)
9656 /* check the array is the same on both sides */
9657 if (oleft->op_type == OP_RV2AV) {
9658 if (oright->op_type != OP_RV2AV
9659 || !cUNOPx(oright)->op_first
9660 || cUNOPx(oright)->op_first->op_type != OP_GV
9661 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9662 cGVOPx_gv(cUNOPx(oright)->op_first)
9666 else if (oright->op_type != OP_PADAV
9667 || oright->op_targ != oleft->op_targ
9674 #define MAX_DEFERRED 4
9677 if (defer_ix == (MAX_DEFERRED-1)) { \
9678 CALL_RPEEP(defer_queue[defer_base]); \
9679 defer_base = (defer_base + 1) % MAX_DEFERRED; \
9682 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
9684 /* A peephole optimizer. We visit the ops in the order they're to execute.
9685 * See the comments at the top of this file for more details about when
9686 * peep() is called */
9689 Perl_rpeep(pTHX_ register OP *o)
9692 register OP* oldop = NULL;
9693 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
9697 if (!o || o->op_opt)
9701 SAVEVPTR(PL_curcop);
9702 for (;; o = o->op_next) {
9706 while (defer_ix >= 0)
9707 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
9711 /* By default, this op has now been optimised. A couple of cases below
9712 clear this again. */
9715 switch (o->op_type) {
9717 PL_curcop = ((COP*)o); /* for warnings */
9720 PL_curcop = ((COP*)o); /* for warnings */
9722 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9723 to carry two labels. For now, take the easier option, and skip
9724 this optimisation if the first NEXTSTATE has a label. */
9725 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9726 OP *nextop = o->op_next;
9727 while (nextop && nextop->op_type == OP_NULL)
9728 nextop = nextop->op_next;
9730 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9731 COP *firstcop = (COP *)o;
9732 COP *secondcop = (COP *)nextop;
9733 /* We want the COP pointed to by o (and anything else) to
9734 become the next COP down the line. */
9737 firstcop->op_next = secondcop->op_next;
9739 /* Now steal all its pointers, and duplicate the other
9741 firstcop->cop_line = secondcop->cop_line;
9743 firstcop->cop_stashpv = secondcop->cop_stashpv;
9744 firstcop->cop_file = secondcop->cop_file;
9746 firstcop->cop_stash = secondcop->cop_stash;
9747 firstcop->cop_filegv = secondcop->cop_filegv;
9749 firstcop->cop_hints = secondcop->cop_hints;
9750 firstcop->cop_seq = secondcop->cop_seq;
9751 firstcop->cop_warnings = secondcop->cop_warnings;
9752 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9755 secondcop->cop_stashpv = NULL;
9756 secondcop->cop_file = NULL;
9758 secondcop->cop_stash = NULL;
9759 secondcop->cop_filegv = NULL;
9761 secondcop->cop_warnings = NULL;
9762 secondcop->cop_hints_hash = NULL;
9764 /* If we use op_null(), and hence leave an ex-COP, some
9765 warnings are misreported. For example, the compile-time
9766 error in 'use strict; no strict refs;' */
9767 secondcop->op_type = OP_NULL;
9768 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9774 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9775 if (o->op_next->op_private & OPpTARGET_MY) {
9776 if (o->op_flags & OPf_STACKED) /* chained concats */
9777 break; /* ignore_optimization */
9779 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9780 o->op_targ = o->op_next->op_targ;
9781 o->op_next->op_targ = 0;
9782 o->op_private |= OPpTARGET_MY;
9785 op_null(o->op_next);
9789 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9790 break; /* Scalar stub must produce undef. List stub is noop */
9794 if (o->op_targ == OP_NEXTSTATE
9795 || o->op_targ == OP_DBSTATE)
9797 PL_curcop = ((COP*)o);
9799 /* XXX: We avoid setting op_seq here to prevent later calls
9800 to rpeep() from mistakenly concluding that optimisation
9801 has already occurred. This doesn't fix the real problem,
9802 though (See 20010220.007). AMS 20010719 */
9803 /* op_seq functionality is now replaced by op_opt */
9810 if (oldop && o->op_next) {
9811 oldop->op_next = o->op_next;
9819 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9820 OP* const pop = (o->op_type == OP_PADAV) ?
9821 o->op_next : o->op_next->op_next;
9823 if (pop && pop->op_type == OP_CONST &&
9824 ((PL_op = pop->op_next)) &&
9825 pop->op_next->op_type == OP_AELEM &&
9826 !(pop->op_next->op_private &
9827 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9828 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9833 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9834 no_bareword_allowed(pop);
9835 if (o->op_type == OP_GV)
9836 op_null(o->op_next);
9837 op_null(pop->op_next);
9839 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9840 o->op_next = pop->op_next->op_next;
9841 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9842 o->op_private = (U8)i;
9843 if (o->op_type == OP_GV) {
9846 o->op_type = OP_AELEMFAST;
9849 o->op_type = OP_AELEMFAST_LEX;
9854 if (o->op_next->op_type == OP_RV2SV) {
9855 if (!(o->op_next->op_private & OPpDEREF)) {
9856 op_null(o->op_next);
9857 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9859 o->op_next = o->op_next->op_next;
9860 o->op_type = OP_GVSV;
9861 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9864 else if (o->op_next->op_type == OP_READLINE
9865 && o->op_next->op_next->op_type == OP_CONCAT
9866 && (o->op_next->op_next->op_flags & OPf_STACKED))
9868 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9869 o->op_type = OP_RCATLINE;
9870 o->op_flags |= OPf_STACKED;
9871 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9872 op_null(o->op_next->op_next);
9873 op_null(o->op_next);
9883 fop = cUNOP->op_first;
9891 fop = cLOGOP->op_first;
9892 sop = fop->op_sibling;
9893 while (cLOGOP->op_other->op_type == OP_NULL)
9894 cLOGOP->op_other = cLOGOP->op_other->op_next;
9895 while (o->op_next && ( o->op_type == o->op_next->op_type
9896 || o->op_next->op_type == OP_NULL))
9897 o->op_next = o->op_next->op_next;
9898 DEFER(cLOGOP->op_other);
9902 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9904 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9909 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9910 while (nop && nop->op_next) {
9911 switch (nop->op_next->op_type) {
9916 lop = nop = nop->op_next;
9927 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9928 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9929 cLOGOP->op_first = opt_scalarhv(fop);
9930 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9931 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9947 while (cLOGOP->op_other->op_type == OP_NULL)
9948 cLOGOP->op_other = cLOGOP->op_other->op_next;
9949 DEFER(cLOGOP->op_other);
9954 while (cLOOP->op_redoop->op_type == OP_NULL)
9955 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9956 while (cLOOP->op_nextop->op_type == OP_NULL)
9957 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9958 while (cLOOP->op_lastop->op_type == OP_NULL)
9959 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9960 /* a while(1) loop doesn't have an op_next that escapes the
9961 * loop, so we have to explicitly follow the op_lastop to
9962 * process the rest of the code */
9963 DEFER(cLOOP->op_lastop);
9967 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9968 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9969 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9970 cPMOP->op_pmstashstartu.op_pmreplstart
9971 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9972 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
9981 ( oldop->op_type == OP_AELEM
9982 || oldop->op_type == OP_PADSV
9983 || oldop->op_type == OP_RV2SV
9984 || oldop->op_type == OP_RV2GV
9985 || oldop->op_type == OP_HELEM
9987 && (oldop->op_private & OPpDEREF)
9989 || ( oldop->op_type == OP_ENTERSUB
9990 && oldop->op_private & OPpENTERSUB_DEREF )
9993 o->op_private |= OPpDEREFed;
9997 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
10001 /* check that RHS of sort is a single plain array */
10002 OP *oright = cUNOPo->op_first;
10003 if (!oright || oright->op_type != OP_PUSHMARK)
10006 /* reverse sort ... can be optimised. */
10007 if (!cUNOPo->op_sibling) {
10008 /* Nothing follows us on the list. */
10009 OP * const reverse = o->op_next;
10011 if (reverse->op_type == OP_REVERSE &&
10012 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10013 OP * const pushmark = cUNOPx(reverse)->op_first;
10014 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10015 && (cUNOPx(pushmark)->op_sibling == o)) {
10016 /* reverse -> pushmark -> sort */
10017 o->op_private |= OPpSORT_REVERSE;
10019 pushmark->op_next = oright->op_next;
10025 /* make @a = sort @a act in-place */
10027 oright = cUNOPx(oright)->op_sibling;
10030 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
10031 oright = cUNOPx(oright)->op_sibling;
10034 oleft = is_inplace_av(o, oright);
10038 /* transfer MODishness etc from LHS arg to RHS arg */
10039 oright->op_flags = oleft->op_flags;
10040 o->op_private |= OPpSORT_INPLACE;
10042 /* excise push->gv->rv2av->null->aassign */
10043 o2 = o->op_next->op_next;
10044 op_null(o2); /* PUSHMARK */
10046 if (o2->op_type == OP_GV) {
10047 op_null(o2); /* GV */
10050 op_null(o2); /* RV2AV or PADAV */
10051 o2 = o2->op_next->op_next;
10052 op_null(o2); /* AASSIGN */
10054 o->op_next = o2->op_next;
10060 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10062 OP *oleft, *oright;
10063 LISTOP *enter, *exlist;
10065 /* @a = reverse @a */
10066 if ((oright = cLISTOPo->op_first)
10067 && (oright->op_type == OP_PUSHMARK)
10068 && (oright = oright->op_sibling)
10069 && (oleft = is_inplace_av(o, oright))) {
10072 /* transfer MODishness etc from LHS arg to RHS arg */
10073 oright->op_flags = oleft->op_flags;
10074 o->op_private |= OPpREVERSE_INPLACE;
10076 /* excise push->gv->rv2av->null->aassign */
10077 o2 = o->op_next->op_next;
10078 op_null(o2); /* PUSHMARK */
10080 if (o2->op_type == OP_GV) {
10081 op_null(o2); /* GV */
10084 op_null(o2); /* RV2AV or PADAV */
10085 o2 = o2->op_next->op_next;
10086 op_null(o2); /* AASSIGN */
10088 o->op_next = o2->op_next;
10092 enter = (LISTOP *) o->op_next;
10095 if (enter->op_type == OP_NULL) {
10096 enter = (LISTOP *) enter->op_next;
10100 /* for $a (...) will have OP_GV then OP_RV2GV here.
10101 for (...) just has an OP_GV. */
10102 if (enter->op_type == OP_GV) {
10103 gvop = (OP *) enter;
10104 enter = (LISTOP *) enter->op_next;
10107 if (enter->op_type == OP_RV2GV) {
10108 enter = (LISTOP *) enter->op_next;
10114 if (enter->op_type != OP_ENTERITER)
10117 iter = enter->op_next;
10118 if (!iter || iter->op_type != OP_ITER)
10121 expushmark = enter->op_first;
10122 if (!expushmark || expushmark->op_type != OP_NULL
10123 || expushmark->op_targ != OP_PUSHMARK)
10126 exlist = (LISTOP *) expushmark->op_sibling;
10127 if (!exlist || exlist->op_type != OP_NULL
10128 || exlist->op_targ != OP_LIST)
10131 if (exlist->op_last != o) {
10132 /* Mmm. Was expecting to point back to this op. */
10135 theirmark = exlist->op_first;
10136 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10139 if (theirmark->op_sibling != o) {
10140 /* There's something between the mark and the reverse, eg
10141 for (1, reverse (...))
10146 ourmark = ((LISTOP *)o)->op_first;
10147 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10150 ourlast = ((LISTOP *)o)->op_last;
10151 if (!ourlast || ourlast->op_next != o)
10154 rv2av = ourmark->op_sibling;
10155 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10156 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10157 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10158 /* We're just reversing a single array. */
10159 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10160 enter->op_flags |= OPf_STACKED;
10163 /* We don't have control over who points to theirmark, so sacrifice
10165 theirmark->op_next = ourmark->op_next;
10166 theirmark->op_flags = ourmark->op_flags;
10167 ourlast->op_next = gvop ? gvop : (OP *) enter;
10170 enter->op_private |= OPpITER_REVERSED;
10171 iter->op_private |= OPpITER_REVERSED;
10178 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10179 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10184 Perl_cpeep_t cpeep =
10185 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10187 cpeep(aTHX_ o, oldop);
10198 Perl_peep(pTHX_ register OP *o)
10204 =head1 Custom Operators
10206 =for apidoc Ao||custom_op_xop
10207 Return the XOP structure for a given custom op. This function should be
10208 considered internal to OP_NAME and the other access macros: use them instead.
10214 Perl_custom_op_xop(pTHX_ const OP *o)
10220 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10222 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10223 assert(o->op_type == OP_CUSTOM);
10225 /* This is wrong. It assumes a function pointer can be cast to IV,
10226 * which isn't guaranteed, but this is what the old custom OP code
10227 * did. In principle it should be safer to Copy the bytes of the
10228 * pointer into a PV: since the new interface is hidden behind
10229 * functions, this can be changed later if necessary. */
10230 /* Change custom_op_xop if this ever happens */
10231 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10234 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10236 /* assume noone will have just registered a desc */
10237 if (!he && PL_custom_op_names &&
10238 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10243 /* XXX does all this need to be shared mem? */
10244 Newxz(xop, 1, XOP);
10245 pv = SvPV(HeVAL(he), l);
10246 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10247 if (PL_custom_op_descs &&
10248 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10250 pv = SvPV(HeVAL(he), l);
10251 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10253 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10257 if (!he) return &xop_null;
10259 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10264 =for apidoc Ao||custom_op_register
10265 Register a custom op. See L<perlguts/"Custom Operators">.
10271 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10275 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10277 /* see the comment in custom_op_xop */
10278 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10280 if (!PL_custom_ops)
10281 PL_custom_ops = newHV();
10283 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10284 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10288 =head1 Functions in file op.c
10290 =for apidoc core_prototype
10291 This function assigns the prototype of the named core function to C<sv>, or
10292 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10293 NULL if the core function has no prototype. C<code> is a code as returned
10294 by C<keyword()>. It must be negative and unequal to -KEY_CORE.
10300 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10303 int i = 0, n = 0, seen_question = 0, defgv = 0;
10305 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10306 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10307 bool nullret = FALSE;
10309 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10311 assert (code < 0 && code != -KEY_CORE);
10313 if (!sv) sv = sv_newmortal();
10315 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10318 case KEY_and : case KEY_chop: case KEY_chomp:
10319 case KEY_cmp : case KEY_exec: case KEY_eq :
10320 case KEY_ge : case KEY_gt : case KEY_le :
10321 case KEY_lt : case KEY_ne : case KEY_or :
10322 case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
10323 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10324 case KEY_keys: retsetpvs("+", OP_KEYS);
10325 case KEY_values: retsetpvs("+", OP_VALUES);
10326 case KEY_each: retsetpvs("+", OP_EACH);
10327 case KEY_push: retsetpvs("+@", OP_PUSH);
10328 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10329 case KEY_pop: retsetpvs(";+", OP_POP);
10330 case KEY_shift: retsetpvs(";+", OP_SHIFT);
10332 retsetpvs("+;$$@", OP_SPLICE);
10333 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10342 while (i < MAXO) { /* The slow way. */
10343 if (strEQ(name, PL_op_name[i])
10344 || strEQ(name, PL_op_desc[i]))
10346 if (nullret) { assert(opnum); *opnum = i; return NULL; }
10351 assert(0); return NULL; /* Should not happen... */
10353 defgv = PL_opargs[i] & OA_DEFGV;
10354 oa = PL_opargs[i] >> OASHIFT;
10356 if (oa & OA_OPTIONAL && !seen_question && (
10357 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
10362 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10363 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10364 /* But globs are already references (kinda) */
10365 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10369 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10370 && !scalar_mod_type(NULL, i)) {
10375 if (i == OP_LOCK) str[n++] = '&';
10379 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10380 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10381 str[n-1] = '_'; defgv = 0;
10385 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
10387 sv_setpvn(sv, str, n - 1);
10388 if (opnum) *opnum = i;
10394 /* Efficient sub that returns a constant scalar value. */
10396 const_sv_xsub(pTHX_ CV* cv)
10400 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10404 /* diag_listed_as: SKIPME */
10405 Perl_croak(aTHX_ "usage: %s::%s()",
10406 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10419 * c-indentation-style: bsd
10420 * c-basic-offset: 4
10421 * indent-tabs-mode: t
10424 * ex: set ts=8 sts=4 sw=4 noet: