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 /* don't warn on optimised away booleans, eg
1174 * use constant Foo, 5; Foo || print; */
1175 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1177 /* the constants 0 and 1 are permitted as they are
1178 conventionally used as dummies in constructs like
1179 1 while some_condition_with_side_effects; */
1180 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1182 else if (SvPOK(sv)) {
1183 /* perl4's way of mixing documentation and code
1184 (before the invention of POD) was based on a
1185 trick to mix nroff and perl code. The trick was
1186 built upon these three nroff macros being used in
1187 void context. The pink camel has the details in
1188 the script wrapman near page 319. */
1189 const char * const maybe_macro = SvPVX_const(sv);
1190 if (strnEQ(maybe_macro, "di", 2) ||
1191 strnEQ(maybe_macro, "ds", 2) ||
1192 strnEQ(maybe_macro, "ig", 2))
1197 op_null(o); /* don't execute or even remember it */
1201 o->op_type = OP_PREINC; /* pre-increment is faster */
1202 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1206 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1207 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1211 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1212 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1216 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1217 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1222 UNOP *refgen, *rv2cv;
1225 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1228 rv2gv = ((BINOP *)o)->op_last;
1229 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1232 refgen = (UNOP *)((BINOP *)o)->op_first;
1234 if (!refgen || refgen->op_type != OP_REFGEN)
1237 exlist = (LISTOP *)refgen->op_first;
1238 if (!exlist || exlist->op_type != OP_NULL
1239 || exlist->op_targ != OP_LIST)
1242 if (exlist->op_first->op_type != OP_PUSHMARK)
1245 rv2cv = (UNOP*)exlist->op_last;
1247 if (rv2cv->op_type != OP_RV2CV)
1250 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1251 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1252 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1254 o->op_private |= OPpASSIGN_CV_TO_GV;
1255 rv2gv->op_private |= OPpDONT_INIT_GV;
1256 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1268 kid = cLOGOPo->op_first;
1269 if (kid->op_type == OP_NOT
1270 && (kid->op_flags & OPf_KIDS)
1272 if (o->op_type == OP_AND) {
1274 o->op_ppaddr = PL_ppaddr[OP_OR];
1276 o->op_type = OP_AND;
1277 o->op_ppaddr = PL_ppaddr[OP_AND];
1286 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1291 if (o->op_flags & OPf_STACKED)
1298 if (!(o->op_flags & OPf_KIDS))
1309 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1319 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1324 S_listkids(pTHX_ OP *o)
1326 if (o && o->op_flags & OPf_KIDS) {
1328 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1335 Perl_list(pTHX_ OP *o)
1340 /* assumes no premature commitment */
1341 if (!o || (o->op_flags & OPf_WANT)
1342 || (PL_parser && PL_parser->error_count)
1343 || o->op_type == OP_RETURN)
1348 if ((o->op_private & OPpTARGET_MY)
1349 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1351 return o; /* As if inside SASSIGN */
1354 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1356 switch (o->op_type) {
1359 list(cBINOPo->op_first);
1364 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1372 if (!(o->op_flags & OPf_KIDS))
1374 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1375 list(cBINOPo->op_first);
1376 return gen_constant_list(o);
1383 kid = cLISTOPo->op_first;
1385 kid = kid->op_sibling;
1388 OP *sib = kid->op_sibling;
1389 if (sib && kid->op_type != OP_LEAVEWHEN)
1395 PL_curcop = &PL_compiling;
1399 kid = cLISTOPo->op_first;
1406 S_scalarseq(pTHX_ OP *o)
1410 const OPCODE type = o->op_type;
1412 if (type == OP_LINESEQ || type == OP_SCOPE ||
1413 type == OP_LEAVE || type == OP_LEAVETRY)
1416 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1417 if (kid->op_sibling) {
1421 PL_curcop = &PL_compiling;
1423 o->op_flags &= ~OPf_PARENS;
1424 if (PL_hints & HINT_BLOCK_SCOPE)
1425 o->op_flags |= OPf_PARENS;
1428 o = newOP(OP_STUB, 0);
1433 S_modkids(pTHX_ OP *o, I32 type)
1435 if (o && o->op_flags & OPf_KIDS) {
1437 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1438 op_lvalue(kid, type);
1444 =for apidoc finalize_optree
1446 This function finalizes the optree. Should be called directly after
1447 the complete optree is built. It does some additional
1448 checking which can't be done in the normal ck_xxx functions and makes
1449 the tree thread-safe.
1454 Perl_finalize_optree(pTHX_ OP* o)
1456 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1459 SAVEVPTR(PL_curcop);
1467 S_finalize_op(pTHX_ OP* o)
1469 PERL_ARGS_ASSERT_FINALIZE_OP;
1471 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1473 /* Make sure mad ops are also thread-safe */
1474 MADPROP *mp = o->op_madprop;
1476 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1477 OP *prop_op = (OP *) mp->mad_val;
1478 /* We only need "Relocate sv to the pad for thread safety.", but this
1479 easiest way to make sure it traverses everything */
1480 if (prop_op->op_type == OP_CONST)
1481 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1482 finalize_op(prop_op);
1489 switch (o->op_type) {
1492 PL_curcop = ((COP*)o); /* for warnings */
1496 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1497 && ckWARN(WARN_SYNTAX))
1499 if (o->op_sibling->op_sibling) {
1500 const OPCODE type = o->op_sibling->op_sibling->op_type;
1501 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1502 const line_t oldline = CopLINE(PL_curcop);
1503 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1504 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1505 "Statement unlikely to be reached");
1506 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1507 "\t(Maybe you meant system() when you said exec()?)\n");
1508 CopLINE_set(PL_curcop, oldline);
1515 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1516 GV * const gv = cGVOPo_gv;
1517 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1518 /* XXX could check prototype here instead of just carping */
1519 SV * const sv = sv_newmortal();
1520 gv_efullname3(sv, gv, NULL);
1521 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1522 "%"SVf"() called too early to check prototype",
1529 if (cSVOPo->op_private & OPpCONST_STRICT)
1530 no_bareword_allowed(o);
1534 case OP_METHOD_NAMED:
1535 /* Relocate sv to the pad for thread safety.
1536 * Despite being a "constant", the SV is written to,
1537 * for reference counts, sv_upgrade() etc. */
1538 if (cSVOPo->op_sv) {
1539 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1540 if (o->op_type != OP_METHOD_NAMED &&
1541 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1543 /* If op_sv is already a PADTMP/MY then it is being used by
1544 * some pad, so make a copy. */
1545 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1546 SvREADONLY_on(PAD_SVl(ix));
1547 SvREFCNT_dec(cSVOPo->op_sv);
1549 else if (o->op_type != OP_METHOD_NAMED
1550 && cSVOPo->op_sv == &PL_sv_undef) {
1551 /* PL_sv_undef is hack - it's unsafe to store it in the
1552 AV that is the pad, because av_fetch treats values of
1553 PL_sv_undef as a "free" AV entry and will merrily
1554 replace them with a new SV, causing pad_alloc to think
1555 that this pad slot is free. (When, clearly, it is not)
1557 SvOK_off(PAD_SVl(ix));
1558 SvPADTMP_on(PAD_SVl(ix));
1559 SvREADONLY_on(PAD_SVl(ix));
1562 SvREFCNT_dec(PAD_SVl(ix));
1563 SvPADTMP_on(cSVOPo->op_sv);
1564 PAD_SETSV(ix, cSVOPo->op_sv);
1565 /* XXX I don't know how this isn't readonly already. */
1566 SvREADONLY_on(PAD_SVl(ix));
1568 cSVOPo->op_sv = NULL;
1579 const char *key = NULL;
1582 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1585 /* Make the CONST have a shared SV */
1586 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1587 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1588 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1589 key = SvPV_const(sv, keylen);
1590 lexname = newSVpvn_share(key,
1591 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1597 if ((o->op_private & (OPpLVAL_INTRO)))
1600 rop = (UNOP*)((BINOP*)o)->op_first;
1601 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1603 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1604 if (!SvPAD_TYPED(lexname))
1606 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1607 if (!fields || !GvHV(*fields))
1609 key = SvPV_const(*svp, keylen);
1610 if (!hv_fetch(GvHV(*fields), key,
1611 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1612 Perl_croak(aTHX_ "No such class field \"%s\" "
1613 "in variable %s of type %s",
1614 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
1626 SVOP *first_key_op, *key_op;
1628 if ((o->op_private & (OPpLVAL_INTRO))
1629 /* I bet there's always a pushmark... */
1630 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1631 /* hmmm, no optimization if list contains only one key. */
1633 rop = (UNOP*)((LISTOP*)o)->op_last;
1634 if (rop->op_type != OP_RV2HV)
1636 if (rop->op_first->op_type == OP_PADSV)
1637 /* @$hash{qw(keys here)} */
1638 rop = (UNOP*)rop->op_first;
1640 /* @{$hash}{qw(keys here)} */
1641 if (rop->op_first->op_type == OP_SCOPE
1642 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1644 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1650 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1651 if (!SvPAD_TYPED(lexname))
1653 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1654 if (!fields || !GvHV(*fields))
1656 /* Again guessing that the pushmark can be jumped over.... */
1657 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1658 ->op_first->op_sibling;
1659 for (key_op = first_key_op; key_op;
1660 key_op = (SVOP*)key_op->op_sibling) {
1661 if (key_op->op_type != OP_CONST)
1663 svp = cSVOPx_svp(key_op);
1664 key = SvPV_const(*svp, keylen);
1665 if (!hv_fetch(GvHV(*fields), key,
1666 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1667 Perl_croak(aTHX_ "No such class field \"%s\" "
1668 "in variable %s of type %s",
1669 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
1675 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1676 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1683 if (o->op_flags & OPf_KIDS) {
1685 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1691 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1693 Propagate lvalue ("modifiable") context to an op and its children.
1694 I<type> represents the context type, roughly based on the type of op that
1695 would do the modifying, although C<local()> is represented by OP_NULL,
1696 because it has no op type of its own (it is signalled by a flag on
1699 This function detects things that can't be modified, such as C<$x+1>, and
1700 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1701 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1703 It also flags things that need to behave specially in an lvalue context,
1704 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1710 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1714 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1717 if (!o || (PL_parser && PL_parser->error_count))
1720 if ((o->op_private & OPpTARGET_MY)
1721 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1726 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1728 switch (o->op_type) {
1734 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1738 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1739 !(o->op_flags & OPf_STACKED)) {
1740 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1741 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1742 poses, so we need it clear. */
1743 o->op_private &= ~1;
1744 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1745 assert(cUNOPo->op_first->op_type == OP_NULL);
1746 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1749 else { /* lvalue subroutine call */
1750 o->op_private |= OPpLVAL_INTRO
1751 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1752 PL_modcount = RETURN_UNLIMITED_NUMBER;
1753 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1754 /* Backward compatibility mode: */
1755 o->op_private |= OPpENTERSUB_INARGS;
1758 else { /* Compile-time error message: */
1759 OP *kid = cUNOPo->op_first;
1763 if (kid->op_type != OP_PUSHMARK) {
1764 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1766 "panic: unexpected lvalue entersub "
1767 "args: type/targ %ld:%"UVuf,
1768 (long)kid->op_type, (UV)kid->op_targ);
1769 kid = kLISTOP->op_first;
1771 while (kid->op_sibling)
1772 kid = kid->op_sibling;
1773 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1775 if (kid->op_type == OP_METHOD_NAMED
1776 || kid->op_type == OP_METHOD)
1780 NewOp(1101, newop, 1, UNOP);
1781 newop->op_type = OP_RV2CV;
1782 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1783 newop->op_first = NULL;
1784 newop->op_next = (OP*)newop;
1785 kid->op_sibling = (OP*)newop;
1786 newop->op_private |= OPpLVAL_INTRO;
1787 newop->op_private &= ~1;
1791 if (kid->op_type != OP_RV2CV)
1793 "panic: unexpected lvalue entersub "
1794 "entry via type/targ %ld:%"UVuf,
1795 (long)kid->op_type, (UV)kid->op_targ);
1796 kid->op_private |= OPpLVAL_INTRO;
1797 break; /* Postpone until runtime */
1801 kid = kUNOP->op_first;
1802 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1803 kid = kUNOP->op_first;
1804 if (kid->op_type == OP_NULL)
1806 "Unexpected constant lvalue entersub "
1807 "entry via type/targ %ld:%"UVuf,
1808 (long)kid->op_type, (UV)kid->op_targ);
1809 if (kid->op_type != OP_GV) {
1810 /* Restore RV2CV to check lvalueness */
1812 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1813 okid->op_next = kid->op_next;
1814 kid->op_next = okid;
1817 okid->op_next = NULL;
1818 okid->op_type = OP_RV2CV;
1820 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1821 okid->op_private |= OPpLVAL_INTRO;
1822 okid->op_private &= ~1;
1826 cv = GvCV(kGVOP_gv);
1836 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1837 /* grep, foreach, subcalls, refgen */
1838 if (type == OP_GREPSTART || type == OP_ENTERSUB
1839 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1841 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1842 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1844 : (o->op_type == OP_ENTERSUB
1845 ? "non-lvalue subroutine call"
1847 type ? PL_op_desc[type] : "local"));
1861 case OP_RIGHT_SHIFT:
1870 if (!(o->op_flags & OPf_STACKED))
1877 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1878 op_lvalue(kid, type);
1883 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1884 PL_modcount = RETURN_UNLIMITED_NUMBER;
1885 return o; /* Treat \(@foo) like ordinary list. */
1889 if (scalar_mod_type(o, type))
1891 ref(cUNOPo->op_first, o->op_type);
1895 if (type == OP_LEAVESUBLV)
1896 o->op_private |= OPpMAYBE_LVSUB;
1902 PL_modcount = RETURN_UNLIMITED_NUMBER;
1905 PL_hints |= HINT_BLOCK_SCOPE;
1906 if (type == OP_LEAVESUBLV)
1907 o->op_private |= OPpMAYBE_LVSUB;
1911 ref(cUNOPo->op_first, o->op_type);
1915 PL_hints |= HINT_BLOCK_SCOPE;
1924 case OP_AELEMFAST_LEX:
1931 PL_modcount = RETURN_UNLIMITED_NUMBER;
1932 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1933 return o; /* Treat \(@foo) like ordinary list. */
1934 if (scalar_mod_type(o, type))
1936 if (type == OP_LEAVESUBLV)
1937 o->op_private |= OPpMAYBE_LVSUB;
1941 if (!type) /* local() */
1942 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1943 PAD_COMPNAME_SV(o->op_targ));
1952 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1956 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1962 if (type == OP_LEAVESUBLV)
1963 o->op_private |= OPpMAYBE_LVSUB;
1964 pad_free(o->op_targ);
1965 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1966 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1967 if (o->op_flags & OPf_KIDS)
1968 op_lvalue(cBINOPo->op_first->op_sibling, type);
1973 ref(cBINOPo->op_first, o->op_type);
1974 if (type == OP_ENTERSUB &&
1975 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1976 o->op_private |= OPpLVAL_DEFER;
1977 if (type == OP_LEAVESUBLV)
1978 o->op_private |= OPpMAYBE_LVSUB;
1988 if (o->op_flags & OPf_KIDS)
1989 op_lvalue(cLISTOPo->op_last, type);
1994 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1996 else if (!(o->op_flags & OPf_KIDS))
1998 if (o->op_targ != OP_LIST) {
1999 op_lvalue(cBINOPo->op_first, type);
2005 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2006 /* elements might be in void context because the list is
2007 in scalar context or because they are attribute sub calls */
2008 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2009 op_lvalue(kid, type);
2013 if (type != OP_LEAVESUBLV)
2015 break; /* op_lvalue()ing was handled by ck_return() */
2018 /* [20011101.069] File test operators interpret OPf_REF to mean that
2019 their argument is a filehandle; thus \stat(".") should not set
2021 if (type == OP_REFGEN &&
2022 PL_check[o->op_type] == Perl_ck_ftst)
2025 if (type != OP_LEAVESUBLV)
2026 o->op_flags |= OPf_MOD;
2028 if (type == OP_AASSIGN || type == OP_SASSIGN)
2029 o->op_flags |= OPf_SPECIAL|OPf_REF;
2030 else if (!type) { /* local() */
2033 o->op_private |= OPpLVAL_INTRO;
2034 o->op_flags &= ~OPf_SPECIAL;
2035 PL_hints |= HINT_BLOCK_SCOPE;
2040 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2041 "Useless localization of %s", OP_DESC(o));
2044 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2045 && type != OP_LEAVESUBLV)
2046 o->op_flags |= OPf_REF;
2051 S_scalar_mod_type(const OP *o, I32 type)
2053 assert(o || type != OP_SASSIGN);
2057 if (o->op_type == OP_RV2GV)
2081 case OP_RIGHT_SHIFT:
2102 S_is_handle_constructor(const OP *o, I32 numargs)
2104 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2106 switch (o->op_type) {
2114 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2127 S_refkids(pTHX_ OP *o, I32 type)
2129 if (o && o->op_flags & OPf_KIDS) {
2131 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2138 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2143 PERL_ARGS_ASSERT_DOREF;
2145 if (!o || (PL_parser && PL_parser->error_count))
2148 switch (o->op_type) {
2150 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2151 !(o->op_flags & OPf_STACKED)) {
2152 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2153 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2154 assert(cUNOPo->op_first->op_type == OP_NULL);
2155 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2156 o->op_flags |= OPf_SPECIAL;
2157 o->op_private &= ~1;
2159 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2160 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2161 : type == OP_RV2HV ? OPpDEREF_HV
2163 o->op_flags |= OPf_MOD;
2169 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2170 doref(kid, type, set_op_ref);
2173 if (type == OP_DEFINED)
2174 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2175 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2178 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2179 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2180 : type == OP_RV2HV ? OPpDEREF_HV
2182 o->op_flags |= OPf_MOD;
2189 o->op_flags |= OPf_REF;
2192 if (type == OP_DEFINED)
2193 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2194 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2200 o->op_flags |= OPf_REF;
2205 if (!(o->op_flags & OPf_KIDS))
2207 doref(cBINOPo->op_first, type, set_op_ref);
2211 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2212 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2213 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2214 : type == OP_RV2HV ? OPpDEREF_HV
2216 o->op_flags |= OPf_MOD;
2226 if (!(o->op_flags & OPf_KIDS))
2228 doref(cLISTOPo->op_last, type, set_op_ref);
2238 S_dup_attrlist(pTHX_ OP *o)
2243 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2245 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2246 * where the first kid is OP_PUSHMARK and the remaining ones
2247 * are OP_CONST. We need to push the OP_CONST values.
2249 if (o->op_type == OP_CONST)
2250 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2252 else if (o->op_type == OP_NULL)
2256 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2258 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2259 if (o->op_type == OP_CONST)
2260 rop = op_append_elem(OP_LIST, rop,
2261 newSVOP(OP_CONST, o->op_flags,
2262 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2269 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2274 PERL_ARGS_ASSERT_APPLY_ATTRS;
2276 /* fake up C<use attributes $pkg,$rv,@attrs> */
2277 ENTER; /* need to protect against side-effects of 'use' */
2278 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2280 #define ATTRSMODULE "attributes"
2281 #define ATTRSMODULE_PM "attributes.pm"
2284 /* Don't force the C<use> if we don't need it. */
2285 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2286 if (svp && *svp != &PL_sv_undef)
2287 NOOP; /* already in %INC */
2289 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2290 newSVpvs(ATTRSMODULE), NULL);
2293 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2294 newSVpvs(ATTRSMODULE),
2296 op_prepend_elem(OP_LIST,
2297 newSVOP(OP_CONST, 0, stashsv),
2298 op_prepend_elem(OP_LIST,
2299 newSVOP(OP_CONST, 0,
2301 dup_attrlist(attrs))));
2307 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2310 OP *pack, *imop, *arg;
2313 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2318 assert(target->op_type == OP_PADSV ||
2319 target->op_type == OP_PADHV ||
2320 target->op_type == OP_PADAV);
2322 /* Ensure that attributes.pm is loaded. */
2323 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2325 /* Need package name for method call. */
2326 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2328 /* Build up the real arg-list. */
2329 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2331 arg = newOP(OP_PADSV, 0);
2332 arg->op_targ = target->op_targ;
2333 arg = op_prepend_elem(OP_LIST,
2334 newSVOP(OP_CONST, 0, stashsv),
2335 op_prepend_elem(OP_LIST,
2336 newUNOP(OP_REFGEN, 0,
2337 op_lvalue(arg, OP_REFGEN)),
2338 dup_attrlist(attrs)));
2340 /* Fake up a method call to import */
2341 meth = newSVpvs_share("import");
2342 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2343 op_append_elem(OP_LIST,
2344 op_prepend_elem(OP_LIST, pack, list(arg)),
2345 newSVOP(OP_METHOD_NAMED, 0, meth)));
2347 /* Combine the ops. */
2348 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2352 =notfor apidoc apply_attrs_string
2354 Attempts to apply a list of attributes specified by the C<attrstr> and
2355 C<len> arguments to the subroutine identified by the C<cv> argument which
2356 is expected to be associated with the package identified by the C<stashpv>
2357 argument (see L<attributes>). It gets this wrong, though, in that it
2358 does not correctly identify the boundaries of the individual attribute
2359 specifications within C<attrstr>. This is not really intended for the
2360 public API, but has to be listed here for systems such as AIX which
2361 need an explicit export list for symbols. (It's called from XS code
2362 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2363 to respect attribute syntax properly would be welcome.
2369 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2370 const char *attrstr, STRLEN len)
2374 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2377 len = strlen(attrstr);
2381 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2383 const char * const sstr = attrstr;
2384 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2385 attrs = op_append_elem(OP_LIST, attrs,
2386 newSVOP(OP_CONST, 0,
2387 newSVpvn(sstr, attrstr-sstr)));
2391 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2392 newSVpvs(ATTRSMODULE),
2393 NULL, op_prepend_elem(OP_LIST,
2394 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2395 op_prepend_elem(OP_LIST,
2396 newSVOP(OP_CONST, 0,
2397 newRV(MUTABLE_SV(cv))),
2402 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2406 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2408 PERL_ARGS_ASSERT_MY_KID;
2410 if (!o || (PL_parser && PL_parser->error_count))
2414 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2415 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2419 if (type == OP_LIST) {
2421 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2422 my_kid(kid, attrs, imopsp);
2423 } else if (type == OP_UNDEF
2429 } else if (type == OP_RV2SV || /* "our" declaration */
2431 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2432 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2433 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2435 PL_parser->in_my == KEY_our
2437 : PL_parser->in_my == KEY_state ? "state" : "my"));
2439 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2440 PL_parser->in_my = FALSE;
2441 PL_parser->in_my_stash = NULL;
2442 apply_attrs(GvSTASH(gv),
2443 (type == OP_RV2SV ? GvSV(gv) :
2444 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2445 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2448 o->op_private |= OPpOUR_INTRO;
2451 else if (type != OP_PADSV &&
2454 type != OP_PUSHMARK)
2456 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2458 PL_parser->in_my == KEY_our
2460 : PL_parser->in_my == KEY_state ? "state" : "my"));
2463 else if (attrs && type != OP_PUSHMARK) {
2466 PL_parser->in_my = FALSE;
2467 PL_parser->in_my_stash = NULL;
2469 /* check for C<my Dog $spot> when deciding package */
2470 stash = PAD_COMPNAME_TYPE(o->op_targ);
2472 stash = PL_curstash;
2473 apply_attrs_my(stash, o, attrs, imopsp);
2475 o->op_flags |= OPf_MOD;
2476 o->op_private |= OPpLVAL_INTRO;
2478 o->op_private |= OPpPAD_STATE;
2483 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2487 int maybe_scalar = 0;
2489 PERL_ARGS_ASSERT_MY_ATTRS;
2491 /* [perl #17376]: this appears to be premature, and results in code such as
2492 C< our(%x); > executing in list mode rather than void mode */
2494 if (o->op_flags & OPf_PARENS)
2504 o = my_kid(o, attrs, &rops);
2506 if (maybe_scalar && o->op_type == OP_PADSV) {
2507 o = scalar(op_append_list(OP_LIST, rops, o));
2508 o->op_private |= OPpLVAL_INTRO;
2511 /* The listop in rops might have a pushmark at the beginning,
2512 which will mess up list assignment. */
2513 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2514 if (rops->op_type == OP_LIST &&
2515 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2517 OP * const pushmark = lrops->op_first;
2518 lrops->op_first = pushmark->op_sibling;
2521 o = op_append_list(OP_LIST, o, rops);
2524 PL_parser->in_my = FALSE;
2525 PL_parser->in_my_stash = NULL;
2530 Perl_sawparens(pTHX_ OP *o)
2532 PERL_UNUSED_CONTEXT;
2534 o->op_flags |= OPf_PARENS;
2539 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2543 const OPCODE ltype = left->op_type;
2544 const OPCODE rtype = right->op_type;
2546 PERL_ARGS_ASSERT_BIND_MATCH;
2548 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2549 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2551 const char * const desc
2553 rtype == OP_SUBST || rtype == OP_TRANS
2554 || rtype == OP_TRANSR
2556 ? (int)rtype : OP_MATCH];
2557 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2558 ? "@array" : "%hash");
2559 Perl_warner(aTHX_ packWARN(WARN_MISC),
2560 "Applying %s to %s will act on scalar(%s)",
2561 desc, sample, sample);
2564 if (rtype == OP_CONST &&
2565 cSVOPx(right)->op_private & OPpCONST_BARE &&
2566 cSVOPx(right)->op_private & OPpCONST_STRICT)
2568 no_bareword_allowed(right);
2571 /* !~ doesn't make sense with /r, so error on it for now */
2572 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2574 yyerror("Using !~ with s///r doesn't make sense");
2575 if (rtype == OP_TRANSR && type == OP_NOT)
2576 yyerror("Using !~ with tr///r doesn't make sense");
2578 ismatchop = (rtype == OP_MATCH ||
2579 rtype == OP_SUBST ||
2580 rtype == OP_TRANS || rtype == OP_TRANSR)
2581 && !(right->op_flags & OPf_SPECIAL);
2582 if (ismatchop && right->op_private & OPpTARGET_MY) {
2584 right->op_private &= ~OPpTARGET_MY;
2586 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2589 right->op_flags |= OPf_STACKED;
2590 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2591 ! (rtype == OP_TRANS &&
2592 right->op_private & OPpTRANS_IDENTICAL) &&
2593 ! (rtype == OP_SUBST &&
2594 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2595 newleft = op_lvalue(left, rtype);
2598 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2599 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2601 o = op_prepend_elem(rtype, scalar(newleft), right);
2603 return newUNOP(OP_NOT, 0, scalar(o));
2607 return bind_match(type, left,
2608 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2612 Perl_invert(pTHX_ OP *o)
2616 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2620 =for apidoc Amx|OP *|op_scope|OP *o
2622 Wraps up an op tree with some additional ops so that at runtime a dynamic
2623 scope will be created. The original ops run in the new dynamic scope,
2624 and then, provided that they exit normally, the scope will be unwound.
2625 The additional ops used to create and unwind the dynamic scope will
2626 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2627 instead if the ops are simple enough to not need the full dynamic scope
2634 Perl_op_scope(pTHX_ OP *o)
2638 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2639 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2640 o->op_type = OP_LEAVE;
2641 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2643 else if (o->op_type == OP_LINESEQ) {
2645 o->op_type = OP_SCOPE;
2646 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2647 kid = ((LISTOP*)o)->op_first;
2648 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2651 /* The following deals with things like 'do {1 for 1}' */
2652 kid = kid->op_sibling;
2654 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2659 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2665 Perl_block_start(pTHX_ int full)
2668 const int retval = PL_savestack_ix;
2670 pad_block_start(full);
2672 PL_hints &= ~HINT_BLOCK_SCOPE;
2673 SAVECOMPILEWARNINGS();
2674 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2676 CALL_BLOCK_HOOKS(bhk_start, full);
2682 Perl_block_end(pTHX_ I32 floor, OP *seq)
2685 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2686 OP* retval = scalarseq(seq);
2688 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2691 CopHINTS_set(&PL_compiling, PL_hints);
2693 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2696 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2702 =head1 Compile-time scope hooks
2704 =for apidoc Aox||blockhook_register
2706 Register a set of hooks to be called when the Perl lexical scope changes
2707 at compile time. See L<perlguts/"Compile-time scope hooks">.
2713 Perl_blockhook_register(pTHX_ BHK *hk)
2715 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2717 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2724 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2725 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2726 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2729 OP * const o = newOP(OP_PADSV, 0);
2730 o->op_targ = offset;
2736 Perl_newPROG(pTHX_ OP *o)
2740 PERL_ARGS_ASSERT_NEWPROG;
2746 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2747 ((PL_in_eval & EVAL_KEEPERR)
2748 ? OPf_SPECIAL : 0), o);
2750 cx = &cxstack[cxstack_ix];
2751 assert(CxTYPE(cx) == CXt_EVAL);
2753 if ((cx->blk_gimme & G_WANT) == G_VOID)
2754 scalarvoid(PL_eval_root);
2755 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2758 scalar(PL_eval_root);
2760 /* don't use LINKLIST, since PL_eval_root might indirect through
2761 * a rather expensive function call and LINKLIST evaluates its
2762 * argument more than once */
2763 PL_eval_start = op_linklist(PL_eval_root);
2764 PL_eval_root->op_private |= OPpREFCOUNTED;
2765 OpREFCNT_set(PL_eval_root, 1);
2766 PL_eval_root->op_next = 0;
2767 CALL_PEEP(PL_eval_start);
2768 finalize_optree(PL_eval_root);
2772 if (o->op_type == OP_STUB) {
2773 PL_comppad_name = 0;
2775 S_op_destroy(aTHX_ o);
2778 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2779 PL_curcop = &PL_compiling;
2780 PL_main_start = LINKLIST(PL_main_root);
2781 PL_main_root->op_private |= OPpREFCOUNTED;
2782 OpREFCNT_set(PL_main_root, 1);
2783 PL_main_root->op_next = 0;
2784 CALL_PEEP(PL_main_start);
2785 finalize_optree(PL_main_root);
2788 /* Register with debugger */
2790 CV * const cv = get_cvs("DB::postponed", 0);
2794 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2796 call_sv(MUTABLE_SV(cv), G_DISCARD);
2803 Perl_localize(pTHX_ OP *o, I32 lex)
2807 PERL_ARGS_ASSERT_LOCALIZE;
2809 if (o->op_flags & OPf_PARENS)
2810 /* [perl #17376]: this appears to be premature, and results in code such as
2811 C< our(%x); > executing in list mode rather than void mode */
2818 if ( PL_parser->bufptr > PL_parser->oldbufptr
2819 && PL_parser->bufptr[-1] == ','
2820 && ckWARN(WARN_PARENTHESIS))
2822 char *s = PL_parser->bufptr;
2825 /* some heuristics to detect a potential error */
2826 while (*s && (strchr(", \t\n", *s)))
2830 if (*s && strchr("@$%*", *s) && *++s
2831 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2834 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2836 while (*s && (strchr(", \t\n", *s)))
2842 if (sigil && (*s == ';' || *s == '=')) {
2843 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2844 "Parentheses missing around \"%s\" list",
2846 ? (PL_parser->in_my == KEY_our
2848 : PL_parser->in_my == KEY_state
2858 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2859 PL_parser->in_my = FALSE;
2860 PL_parser->in_my_stash = NULL;
2865 Perl_jmaybe(pTHX_ OP *o)
2867 PERL_ARGS_ASSERT_JMAYBE;
2869 if (o->op_type == OP_LIST) {
2871 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2872 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2877 PERL_STATIC_INLINE OP *
2878 S_op_std_init(pTHX_ OP *o)
2880 I32 type = o->op_type;
2882 PERL_ARGS_ASSERT_OP_STD_INIT;
2884 if (PL_opargs[type] & OA_RETSCALAR)
2886 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2887 o->op_targ = pad_alloc(type, SVs_PADTMP);
2892 PERL_STATIC_INLINE OP *
2893 S_op_integerize(pTHX_ OP *o)
2895 I32 type = o->op_type;
2897 PERL_ARGS_ASSERT_OP_INTEGERIZE;
2899 /* integerize op, unless it happens to be C<-foo>.
2900 * XXX should pp_i_negate() do magic string negation instead? */
2901 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2902 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2903 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2906 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2909 if (type == OP_NEGATE)
2910 /* XXX might want a ck_negate() for this */
2911 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2917 S_fold_constants(pTHX_ register OP *o)
2920 register OP * VOL curop;
2922 VOL I32 type = o->op_type;
2927 SV * const oldwarnhook = PL_warnhook;
2928 SV * const olddiehook = PL_diehook;
2932 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2934 if (!(PL_opargs[type] & OA_FOLDCONST))
2948 /* XXX what about the numeric ops? */
2949 if (PL_hints & HINT_LOCALE)
2954 if (PL_parser && PL_parser->error_count)
2955 goto nope; /* Don't try to run w/ errors */
2957 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2958 const OPCODE type = curop->op_type;
2959 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2961 type != OP_SCALAR &&
2963 type != OP_PUSHMARK)
2969 curop = LINKLIST(o);
2970 old_next = o->op_next;
2974 oldscope = PL_scopestack_ix;
2975 create_eval_scope(G_FAKINGEVAL);
2977 /* Verify that we don't need to save it: */
2978 assert(PL_curcop == &PL_compiling);
2979 StructCopy(&PL_compiling, ¬_compiling, COP);
2980 PL_curcop = ¬_compiling;
2981 /* The above ensures that we run with all the correct hints of the
2982 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2983 assert(IN_PERL_RUNTIME);
2984 PL_warnhook = PERL_WARNHOOK_FATAL;
2991 sv = *(PL_stack_sp--);
2992 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2994 /* Can't simply swipe the SV from the pad, because that relies on
2995 the op being freed "real soon now". Under MAD, this doesn't
2996 happen (see the #ifdef below). */
2999 pad_swipe(o->op_targ, FALSE);
3002 else if (SvTEMP(sv)) { /* grab mortal temp? */
3003 SvREFCNT_inc_simple_void(sv);
3008 /* Something tried to die. Abandon constant folding. */
3009 /* Pretend the error never happened. */
3011 o->op_next = old_next;
3015 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3016 PL_warnhook = oldwarnhook;
3017 PL_diehook = olddiehook;
3018 /* XXX note that this croak may fail as we've already blown away
3019 * the stack - eg any nested evals */
3020 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3023 PL_warnhook = oldwarnhook;
3024 PL_diehook = olddiehook;
3025 PL_curcop = &PL_compiling;
3027 if (PL_scopestack_ix > oldscope)
3028 delete_eval_scope();
3037 if (type == OP_RV2GV)
3038 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3040 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3041 op_getmad(o,newop,'f');
3049 S_gen_constant_list(pTHX_ register OP *o)
3053 const I32 oldtmps_floor = PL_tmps_floor;
3056 if (PL_parser && PL_parser->error_count)
3057 return o; /* Don't attempt to run with errors */
3059 PL_op = curop = LINKLIST(o);
3062 Perl_pp_pushmark(aTHX);
3065 assert (!(curop->op_flags & OPf_SPECIAL));
3066 assert(curop->op_type == OP_RANGE);
3067 Perl_pp_anonlist(aTHX);
3068 PL_tmps_floor = oldtmps_floor;
3070 o->op_type = OP_RV2AV;
3071 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3072 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3073 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3074 o->op_opt = 0; /* needs to be revisited in rpeep() */
3075 curop = ((UNOP*)o)->op_first;
3076 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3078 op_getmad(curop,o,'O');
3087 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3090 if (!o || o->op_type != OP_LIST)
3091 o = newLISTOP(OP_LIST, 0, o, NULL);
3093 o->op_flags &= ~OPf_WANT;
3095 if (!(PL_opargs[type] & OA_MARK))
3096 op_null(cLISTOPo->op_first);
3098 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3099 if (kid2 && kid2->op_type == OP_COREARGS) {
3100 op_null(cLISTOPo->op_first);
3101 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3105 o->op_type = (OPCODE)type;
3106 o->op_ppaddr = PL_ppaddr[type];
3107 o->op_flags |= flags;
3109 o = CHECKOP(type, o);
3110 if (o->op_type != (unsigned)type)
3113 return fold_constants(op_integerize(op_std_init(o)));
3117 =head1 Optree Manipulation Functions
3120 /* List constructors */
3123 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3125 Append an item to the list of ops contained directly within a list-type
3126 op, returning the lengthened list. I<first> is the list-type op,
3127 and I<last> is the op to append to the list. I<optype> specifies the
3128 intended opcode for the list. If I<first> is not already a list of the
3129 right type, it will be upgraded into one. If either I<first> or I<last>
3130 is null, the other is returned unchanged.
3136 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3144 if (first->op_type != (unsigned)type
3145 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3147 return newLISTOP(type, 0, first, last);
3150 if (first->op_flags & OPf_KIDS)
3151 ((LISTOP*)first)->op_last->op_sibling = last;
3153 first->op_flags |= OPf_KIDS;
3154 ((LISTOP*)first)->op_first = last;
3156 ((LISTOP*)first)->op_last = last;
3161 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3163 Concatenate the lists of ops contained directly within two list-type ops,
3164 returning the combined list. I<first> and I<last> are the list-type ops
3165 to concatenate. I<optype> specifies the intended opcode for the list.
3166 If either I<first> or I<last> is not already a list of the right type,
3167 it will be upgraded into one. If either I<first> or I<last> is null,
3168 the other is returned unchanged.
3174 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3182 if (first->op_type != (unsigned)type)
3183 return op_prepend_elem(type, first, last);
3185 if (last->op_type != (unsigned)type)
3186 return op_append_elem(type, first, last);
3188 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3189 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3190 first->op_flags |= (last->op_flags & OPf_KIDS);
3193 if (((LISTOP*)last)->op_first && first->op_madprop) {
3194 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3196 while (mp->mad_next)
3198 mp->mad_next = first->op_madprop;
3201 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3204 first->op_madprop = last->op_madprop;
3205 last->op_madprop = 0;
3208 S_op_destroy(aTHX_ last);
3214 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3216 Prepend an item to the list of ops contained directly within a list-type
3217 op, returning the lengthened list. I<first> is the op to prepend to the
3218 list, and I<last> is the list-type op. I<optype> specifies the intended
3219 opcode for the list. If I<last> is not already a list of the right type,
3220 it will be upgraded into one. If either I<first> or I<last> is null,
3221 the other is returned unchanged.
3227 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3235 if (last->op_type == (unsigned)type) {
3236 if (type == OP_LIST) { /* already a PUSHMARK there */
3237 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3238 ((LISTOP*)last)->op_first->op_sibling = first;
3239 if (!(first->op_flags & OPf_PARENS))
3240 last->op_flags &= ~OPf_PARENS;
3243 if (!(last->op_flags & OPf_KIDS)) {
3244 ((LISTOP*)last)->op_last = first;
3245 last->op_flags |= OPf_KIDS;
3247 first->op_sibling = ((LISTOP*)last)->op_first;
3248 ((LISTOP*)last)->op_first = first;
3250 last->op_flags |= OPf_KIDS;
3254 return newLISTOP(type, 0, first, last);
3262 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3265 Newxz(tk, 1, TOKEN);
3266 tk->tk_type = (OPCODE)optype;
3267 tk->tk_type = 12345;
3269 tk->tk_mad = madprop;
3274 Perl_token_free(pTHX_ TOKEN* tk)
3276 PERL_ARGS_ASSERT_TOKEN_FREE;
3278 if (tk->tk_type != 12345)
3280 mad_free(tk->tk_mad);
3285 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3290 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3292 if (tk->tk_type != 12345) {
3293 Perl_warner(aTHX_ packWARN(WARN_MISC),
3294 "Invalid TOKEN object ignored");
3301 /* faked up qw list? */
3303 tm->mad_type == MAD_SV &&
3304 SvPVX((SV *)tm->mad_val)[0] == 'q')
3311 /* pretend constant fold didn't happen? */
3312 if (mp->mad_key == 'f' &&
3313 (o->op_type == OP_CONST ||
3314 o->op_type == OP_GV) )
3316 token_getmad(tk,(OP*)mp->mad_val,slot);
3330 if (mp->mad_key == 'X')
3331 mp->mad_key = slot; /* just change the first one */
3341 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3350 /* pretend constant fold didn't happen? */
3351 if (mp->mad_key == 'f' &&
3352 (o->op_type == OP_CONST ||
3353 o->op_type == OP_GV) )
3355 op_getmad(from,(OP*)mp->mad_val,slot);
3362 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3365 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3371 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3380 /* pretend constant fold didn't happen? */
3381 if (mp->mad_key == 'f' &&
3382 (o->op_type == OP_CONST ||
3383 o->op_type == OP_GV) )
3385 op_getmad(from,(OP*)mp->mad_val,slot);
3392 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3395 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3399 PerlIO_printf(PerlIO_stderr(),
3400 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3406 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3424 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3428 addmad(tm, &(o->op_madprop), slot);
3432 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3453 Perl_newMADsv(pTHX_ char key, SV* sv)
3455 PERL_ARGS_ASSERT_NEWMADSV;
3457 return newMADPROP(key, MAD_SV, sv, 0);
3461 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3463 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3466 mp->mad_vlen = vlen;
3467 mp->mad_type = type;
3469 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3474 Perl_mad_free(pTHX_ MADPROP* mp)
3476 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3480 mad_free(mp->mad_next);
3481 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3482 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3483 switch (mp->mad_type) {
3487 Safefree((char*)mp->mad_val);
3490 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3491 op_free((OP*)mp->mad_val);
3494 sv_free(MUTABLE_SV(mp->mad_val));
3497 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3500 PerlMemShared_free(mp);
3506 =head1 Optree construction
3508 =for apidoc Am|OP *|newNULLLIST
3510 Constructs, checks, and returns a new C<stub> op, which represents an
3511 empty list expression.
3517 Perl_newNULLLIST(pTHX)
3519 return newOP(OP_STUB, 0);
3523 S_force_list(pTHX_ OP *o)
3525 if (!o || o->op_type != OP_LIST)
3526 o = newLISTOP(OP_LIST, 0, o, NULL);
3532 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3534 Constructs, checks, and returns an op of any list type. I<type> is
3535 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3536 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3537 supply up to two ops to be direct children of the list op; they are
3538 consumed by this function and become part of the constructed op tree.
3544 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3549 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3551 NewOp(1101, listop, 1, LISTOP);
3553 listop->op_type = (OPCODE)type;
3554 listop->op_ppaddr = PL_ppaddr[type];
3557 listop->op_flags = (U8)flags;
3561 else if (!first && last)
3564 first->op_sibling = last;
3565 listop->op_first = first;
3566 listop->op_last = last;
3567 if (type == OP_LIST) {
3568 OP* const pushop = newOP(OP_PUSHMARK, 0);
3569 pushop->op_sibling = first;
3570 listop->op_first = pushop;
3571 listop->op_flags |= OPf_KIDS;
3573 listop->op_last = pushop;
3576 return CHECKOP(type, listop);
3580 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3582 Constructs, checks, and returns an op of any base type (any type that
3583 has no extra fields). I<type> is the opcode. I<flags> gives the
3584 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3591 Perl_newOP(pTHX_ I32 type, I32 flags)
3596 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3597 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3598 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3599 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3601 NewOp(1101, o, 1, OP);
3602 o->op_type = (OPCODE)type;
3603 o->op_ppaddr = PL_ppaddr[type];
3604 o->op_flags = (U8)flags;
3606 o->op_latefreed = 0;
3610 o->op_private = (U8)(0 | (flags >> 8));
3611 if (PL_opargs[type] & OA_RETSCALAR)
3613 if (PL_opargs[type] & OA_TARGET)
3614 o->op_targ = pad_alloc(type, SVs_PADTMP);
3615 return CHECKOP(type, o);
3619 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3621 Constructs, checks, and returns an op of any unary type. I<type> is
3622 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3623 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3624 bits, the eight bits of C<op_private>, except that the bit with value 1
3625 is automatically set. I<first> supplies an optional op to be the direct
3626 child of the unary op; it is consumed by this function and become part
3627 of the constructed op tree.
3633 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3638 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3639 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3640 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3641 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3642 || type == OP_SASSIGN
3643 || type == OP_ENTERTRY
3644 || type == OP_NULL );
3647 first = newOP(OP_STUB, 0);
3648 if (PL_opargs[type] & OA_MARK)
3649 first = force_list(first);
3651 NewOp(1101, unop, 1, UNOP);
3652 unop->op_type = (OPCODE)type;
3653 unop->op_ppaddr = PL_ppaddr[type];
3654 unop->op_first = first;
3655 unop->op_flags = (U8)(flags | OPf_KIDS);
3656 unop->op_private = (U8)(1 | (flags >> 8));
3657 unop = (UNOP*) CHECKOP(type, unop);
3661 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3665 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3667 Constructs, checks, and returns an op of any binary type. I<type>
3668 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3669 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3670 the eight bits of C<op_private>, except that the bit with value 1 or
3671 2 is automatically set as required. I<first> and I<last> supply up to
3672 two ops to be the direct children of the binary op; they are consumed
3673 by this function and become part of the constructed op tree.
3679 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3684 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3685 || type == OP_SASSIGN || type == OP_NULL );
3687 NewOp(1101, binop, 1, BINOP);
3690 first = newOP(OP_NULL, 0);
3692 binop->op_type = (OPCODE)type;
3693 binop->op_ppaddr = PL_ppaddr[type];
3694 binop->op_first = first;
3695 binop->op_flags = (U8)(flags | OPf_KIDS);
3698 binop->op_private = (U8)(1 | (flags >> 8));
3701 binop->op_private = (U8)(2 | (flags >> 8));
3702 first->op_sibling = last;
3705 binop = (BINOP*)CHECKOP(type, binop);
3706 if (binop->op_next || binop->op_type != (OPCODE)type)
3709 binop->op_last = binop->op_first->op_sibling;
3711 return fold_constants(op_integerize(op_std_init((OP *)binop)));
3714 static int uvcompare(const void *a, const void *b)
3715 __attribute__nonnull__(1)
3716 __attribute__nonnull__(2)
3717 __attribute__pure__;
3718 static int uvcompare(const void *a, const void *b)
3720 if (*((const UV *)a) < (*(const UV *)b))
3722 if (*((const UV *)a) > (*(const UV *)b))
3724 if (*((const UV *)a+1) < (*(const UV *)b+1))
3726 if (*((const UV *)a+1) > (*(const UV *)b+1))
3732 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3735 SV * const tstr = ((SVOP*)expr)->op_sv;
3738 (repl->op_type == OP_NULL)
3739 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3741 ((SVOP*)repl)->op_sv;
3744 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3745 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3749 register short *tbl;
3751 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3752 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3753 I32 del = o->op_private & OPpTRANS_DELETE;
3756 PERL_ARGS_ASSERT_PMTRANS;
3758 PL_hints |= HINT_BLOCK_SCOPE;
3761 o->op_private |= OPpTRANS_FROM_UTF;
3764 o->op_private |= OPpTRANS_TO_UTF;
3766 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3767 SV* const listsv = newSVpvs("# comment\n");
3769 const U8* tend = t + tlen;
3770 const U8* rend = r + rlen;
3784 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3785 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3788 const U32 flags = UTF8_ALLOW_DEFAULT;
3792 t = tsave = bytes_to_utf8(t, &len);
3795 if (!to_utf && rlen) {
3797 r = rsave = bytes_to_utf8(r, &len);
3801 /* There are several snags with this code on EBCDIC:
3802 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3803 2. scan_const() in toke.c has encoded chars in native encoding which makes
3804 ranges at least in EBCDIC 0..255 range the bottom odd.
3808 U8 tmpbuf[UTF8_MAXBYTES+1];
3811 Newx(cp, 2*tlen, UV);
3813 transv = newSVpvs("");
3815 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3817 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3819 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3823 cp[2*i+1] = cp[2*i];
3827 qsort(cp, i, 2*sizeof(UV), uvcompare);
3828 for (j = 0; j < i; j++) {
3830 diff = val - nextmin;
3832 t = uvuni_to_utf8(tmpbuf,nextmin);
3833 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3835 U8 range_mark = UTF_TO_NATIVE(0xff);
3836 t = uvuni_to_utf8(tmpbuf, val - 1);
3837 sv_catpvn(transv, (char *)&range_mark, 1);
3838 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3845 t = uvuni_to_utf8(tmpbuf,nextmin);
3846 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3848 U8 range_mark = UTF_TO_NATIVE(0xff);
3849 sv_catpvn(transv, (char *)&range_mark, 1);
3851 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3852 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3853 t = (const U8*)SvPVX_const(transv);
3854 tlen = SvCUR(transv);
3858 else if (!rlen && !del) {
3859 r = t; rlen = tlen; rend = tend;
3862 if ((!rlen && !del) || t == r ||
3863 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3865 o->op_private |= OPpTRANS_IDENTICAL;
3869 while (t < tend || tfirst <= tlast) {
3870 /* see if we need more "t" chars */
3871 if (tfirst > tlast) {
3872 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3874 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3876 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3883 /* now see if we need more "r" chars */
3884 if (rfirst > rlast) {
3886 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3888 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3890 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3899 rfirst = rlast = 0xffffffff;
3903 /* now see which range will peter our first, if either. */
3904 tdiff = tlast - tfirst;
3905 rdiff = rlast - rfirst;
3912 if (rfirst == 0xffffffff) {
3913 diff = tdiff; /* oops, pretend rdiff is infinite */
3915 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3916 (long)tfirst, (long)tlast);
3918 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3922 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3923 (long)tfirst, (long)(tfirst + diff),
3926 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3927 (long)tfirst, (long)rfirst);
3929 if (rfirst + diff > max)
3930 max = rfirst + diff;
3932 grows = (tfirst < rfirst &&
3933 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3945 else if (max > 0xff)
3950 PerlMemShared_free(cPVOPo->op_pv);
3951 cPVOPo->op_pv = NULL;
3953 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3955 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3956 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3957 PAD_SETSV(cPADOPo->op_padix, swash);
3959 SvREADONLY_on(swash);
3961 cSVOPo->op_sv = swash;
3963 SvREFCNT_dec(listsv);
3964 SvREFCNT_dec(transv);
3966 if (!del && havefinal && rlen)
3967 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3968 newSVuv((UV)final), 0);
3971 o->op_private |= OPpTRANS_GROWS;
3977 op_getmad(expr,o,'e');
3978 op_getmad(repl,o,'r');
3986 tbl = (short*)cPVOPo->op_pv;
3988 Zero(tbl, 256, short);
3989 for (i = 0; i < (I32)tlen; i++)
3991 for (i = 0, j = 0; i < 256; i++) {
3993 if (j >= (I32)rlen) {
4002 if (i < 128 && r[j] >= 128)
4012 o->op_private |= OPpTRANS_IDENTICAL;
4014 else if (j >= (I32)rlen)
4019 PerlMemShared_realloc(tbl,
4020 (0x101+rlen-j) * sizeof(short));
4021 cPVOPo->op_pv = (char*)tbl;
4023 tbl[0x100] = (short)(rlen - j);
4024 for (i=0; i < (I32)rlen - j; i++)
4025 tbl[0x101+i] = r[j+i];
4029 if (!rlen && !del) {
4032 o->op_private |= OPpTRANS_IDENTICAL;
4034 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4035 o->op_private |= OPpTRANS_IDENTICAL;
4037 for (i = 0; i < 256; i++)
4039 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4040 if (j >= (I32)rlen) {
4042 if (tbl[t[i]] == -1)
4048 if (tbl[t[i]] == -1) {
4049 if (t[i] < 128 && r[j] >= 128)
4056 if(del && rlen == tlen) {
4057 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4058 } else if(rlen > tlen) {
4059 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4063 o->op_private |= OPpTRANS_GROWS;
4065 op_getmad(expr,o,'e');
4066 op_getmad(repl,o,'r');
4076 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4078 Constructs, checks, and returns an op of any pattern matching type.
4079 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4080 and, shifted up eight bits, the eight bits of C<op_private>.
4086 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4091 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4093 NewOp(1101, pmop, 1, PMOP);
4094 pmop->op_type = (OPCODE)type;
4095 pmop->op_ppaddr = PL_ppaddr[type];
4096 pmop->op_flags = (U8)flags;
4097 pmop->op_private = (U8)(0 | (flags >> 8));
4099 if (PL_hints & HINT_RE_TAINT)
4100 pmop->op_pmflags |= PMf_RETAINT;
4101 if (PL_hints & HINT_LOCALE) {
4102 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4104 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
4105 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4107 if (PL_hints & HINT_RE_FLAGS) {
4108 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4109 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4111 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4112 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4113 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4115 if (reflags && SvOK(reflags)) {
4116 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4122 assert(SvPOK(PL_regex_pad[0]));
4123 if (SvCUR(PL_regex_pad[0])) {
4124 /* Pop off the "packed" IV from the end. */
4125 SV *const repointer_list = PL_regex_pad[0];
4126 const char *p = SvEND(repointer_list) - sizeof(IV);
4127 const IV offset = *((IV*)p);
4129 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4131 SvEND_set(repointer_list, p);
4133 pmop->op_pmoffset = offset;
4134 /* This slot should be free, so assert this: */
4135 assert(PL_regex_pad[offset] == &PL_sv_undef);
4137 SV * const repointer = &PL_sv_undef;
4138 av_push(PL_regex_padav, repointer);
4139 pmop->op_pmoffset = av_len(PL_regex_padav);
4140 PL_regex_pad = AvARRAY(PL_regex_padav);
4144 return CHECKOP(type, pmop);
4147 /* Given some sort of match op o, and an expression expr containing a
4148 * pattern, either compile expr into a regex and attach it to o (if it's
4149 * constant), or convert expr into a runtime regcomp op sequence (if it's
4152 * isreg indicates that the pattern is part of a regex construct, eg
4153 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4154 * split "pattern", which aren't. In the former case, expr will be a list
4155 * if the pattern contains more than one term (eg /a$b/) or if it contains
4156 * a replacement, ie s/// or tr///.
4160 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4165 I32 repl_has_vars = 0;
4169 PERL_ARGS_ASSERT_PMRUNTIME;
4172 o->op_type == OP_SUBST
4173 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4175 /* last element in list is the replacement; pop it */
4177 repl = cLISTOPx(expr)->op_last;
4178 kid = cLISTOPx(expr)->op_first;
4179 while (kid->op_sibling != repl)
4180 kid = kid->op_sibling;
4181 kid->op_sibling = NULL;
4182 cLISTOPx(expr)->op_last = kid;
4185 if (isreg && expr->op_type == OP_LIST &&
4186 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4188 /* convert single element list to element */
4189 OP* const oe = expr;
4190 expr = cLISTOPx(oe)->op_first->op_sibling;
4191 cLISTOPx(oe)->op_first->op_sibling = NULL;
4192 cLISTOPx(oe)->op_last = NULL;
4196 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4197 return pmtrans(o, expr, repl);
4200 reglist = isreg && expr->op_type == OP_LIST;
4204 PL_hints |= HINT_BLOCK_SCOPE;
4207 if (expr->op_type == OP_CONST) {
4208 SV *pat = ((SVOP*)expr)->op_sv;
4209 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4211 if (o->op_flags & OPf_SPECIAL)
4212 pm_flags |= RXf_SPLIT;
4215 assert (SvUTF8(pat));
4216 } else if (SvUTF8(pat)) {
4217 /* Not doing UTF-8, despite what the SV says. Is this only if we're
4218 trapped in use 'bytes'? */
4219 /* Make a copy of the octet sequence, but without the flag on, as
4220 the compiler now honours the SvUTF8 flag on pat. */
4222 const char *const p = SvPV(pat, len);
4223 pat = newSVpvn_flags(p, len, SVs_TEMP);
4226 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4229 op_getmad(expr,(OP*)pm,'e');
4235 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4236 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4238 : OP_REGCMAYBE),0,expr);
4240 NewOp(1101, rcop, 1, LOGOP);
4241 rcop->op_type = OP_REGCOMP;
4242 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4243 rcop->op_first = scalar(expr);
4244 rcop->op_flags |= OPf_KIDS
4245 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4246 | (reglist ? OPf_STACKED : 0);
4247 rcop->op_private = 1;
4250 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4252 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4253 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4255 /* establish postfix order */
4256 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4258 rcop->op_next = expr;
4259 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4262 rcop->op_next = LINKLIST(expr);
4263 expr->op_next = (OP*)rcop;
4266 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4271 if (pm->op_pmflags & PMf_EVAL) {
4273 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4274 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4276 else if (repl->op_type == OP_CONST)
4280 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4281 if (curop->op_type == OP_SCOPE
4282 || curop->op_type == OP_LEAVE
4283 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4284 if (curop->op_type == OP_GV) {
4285 GV * const gv = cGVOPx_gv(curop);
4287 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4290 else if (curop->op_type == OP_RV2CV)
4292 else if (curop->op_type == OP_RV2SV ||
4293 curop->op_type == OP_RV2AV ||
4294 curop->op_type == OP_RV2HV ||
4295 curop->op_type == OP_RV2GV) {
4296 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4299 else if (curop->op_type == OP_PADSV ||
4300 curop->op_type == OP_PADAV ||
4301 curop->op_type == OP_PADHV ||
4302 curop->op_type == OP_PADANY)
4306 else if (curop->op_type == OP_PUSHRE)
4307 NOOP; /* Okay here, dangerous in newASSIGNOP */
4317 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4319 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4320 op_prepend_elem(o->op_type, scalar(repl), o);
4323 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4324 pm->op_pmflags |= PMf_MAYBE_CONST;
4326 NewOp(1101, rcop, 1, LOGOP);
4327 rcop->op_type = OP_SUBSTCONT;
4328 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4329 rcop->op_first = scalar(repl);
4330 rcop->op_flags |= OPf_KIDS;
4331 rcop->op_private = 1;
4334 /* establish postfix order */
4335 rcop->op_next = LINKLIST(repl);
4336 repl->op_next = (OP*)rcop;
4338 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4339 assert(!(pm->op_pmflags & PMf_ONCE));
4340 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4349 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4351 Constructs, checks, and returns an op of any type that involves an
4352 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4353 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4354 takes ownership of one reference to it.
4360 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4365 PERL_ARGS_ASSERT_NEWSVOP;
4367 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4368 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4369 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4371 NewOp(1101, svop, 1, SVOP);
4372 svop->op_type = (OPCODE)type;
4373 svop->op_ppaddr = PL_ppaddr[type];
4375 svop->op_next = (OP*)svop;
4376 svop->op_flags = (U8)flags;
4377 if (PL_opargs[type] & OA_RETSCALAR)
4379 if (PL_opargs[type] & OA_TARGET)
4380 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4381 return CHECKOP(type, svop);
4387 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4389 Constructs, checks, and returns an op of any type that involves a
4390 reference to a pad element. I<type> is the opcode. I<flags> gives the
4391 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4392 is populated with I<sv>; this function takes ownership of one reference
4395 This function only exists if Perl has been compiled to use ithreads.
4401 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4406 PERL_ARGS_ASSERT_NEWPADOP;
4408 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4409 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4410 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4412 NewOp(1101, padop, 1, PADOP);
4413 padop->op_type = (OPCODE)type;
4414 padop->op_ppaddr = PL_ppaddr[type];
4415 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4416 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4417 PAD_SETSV(padop->op_padix, sv);
4420 padop->op_next = (OP*)padop;
4421 padop->op_flags = (U8)flags;
4422 if (PL_opargs[type] & OA_RETSCALAR)
4424 if (PL_opargs[type] & OA_TARGET)
4425 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4426 return CHECKOP(type, padop);
4429 #endif /* !USE_ITHREADS */
4432 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4434 Constructs, checks, and returns an op of any type that involves an
4435 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4436 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4437 reference; calling this function does not transfer ownership of any
4444 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4448 PERL_ARGS_ASSERT_NEWGVOP;
4452 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4454 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4459 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4461 Constructs, checks, and returns an op of any type that involves an
4462 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4463 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4464 must have been allocated using L</PerlMemShared_malloc>; the memory will
4465 be freed when the op is destroyed.
4471 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4476 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4477 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4479 NewOp(1101, pvop, 1, PVOP);
4480 pvop->op_type = (OPCODE)type;
4481 pvop->op_ppaddr = PL_ppaddr[type];
4483 pvop->op_next = (OP*)pvop;
4484 pvop->op_flags = (U8)flags;
4485 if (PL_opargs[type] & OA_RETSCALAR)
4487 if (PL_opargs[type] & OA_TARGET)
4488 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4489 return CHECKOP(type, pvop);
4497 Perl_package(pTHX_ OP *o)
4500 SV *const sv = cSVOPo->op_sv;
4505 PERL_ARGS_ASSERT_PACKAGE;
4507 save_hptr(&PL_curstash);
4508 save_item(PL_curstname);
4510 PL_curstash = gv_stashsv(sv, GV_ADD);
4512 sv_setsv(PL_curstname, sv);
4514 PL_hints |= HINT_BLOCK_SCOPE;
4515 PL_parser->copline = NOLINE;
4516 PL_parser->expect = XSTATE;
4521 if (!PL_madskills) {
4526 pegop = newOP(OP_NULL,0);
4527 op_getmad(o,pegop,'P');
4533 Perl_package_version( pTHX_ OP *v )
4536 U32 savehints = PL_hints;
4537 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4538 PL_hints &= ~HINT_STRICT_VARS;
4539 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4540 PL_hints = savehints;
4549 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4556 OP *pegop = newOP(OP_NULL,0);
4558 SV *use_version = NULL;
4560 PERL_ARGS_ASSERT_UTILIZE;
4562 if (idop->op_type != OP_CONST)
4563 Perl_croak(aTHX_ "Module name must be constant");
4566 op_getmad(idop,pegop,'U');
4571 SV * const vesv = ((SVOP*)version)->op_sv;
4574 op_getmad(version,pegop,'V');
4575 if (!arg && !SvNIOKp(vesv)) {
4582 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4583 Perl_croak(aTHX_ "Version number must be a constant number");
4585 /* Make copy of idop so we don't free it twice */
4586 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4588 /* Fake up a method call to VERSION */
4589 meth = newSVpvs_share("VERSION");
4590 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4591 op_append_elem(OP_LIST,
4592 op_prepend_elem(OP_LIST, pack, list(version)),
4593 newSVOP(OP_METHOD_NAMED, 0, meth)));
4597 /* Fake up an import/unimport */
4598 if (arg && arg->op_type == OP_STUB) {
4600 op_getmad(arg,pegop,'S');
4601 imop = arg; /* no import on explicit () */
4603 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4604 imop = NULL; /* use 5.0; */
4606 use_version = ((SVOP*)idop)->op_sv;
4608 idop->op_private |= OPpCONST_NOVER;
4614 op_getmad(arg,pegop,'A');
4616 /* Make copy of idop so we don't free it twice */
4617 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4619 /* Fake up a method call to import/unimport */
4621 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4622 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4623 op_append_elem(OP_LIST,
4624 op_prepend_elem(OP_LIST, pack, list(arg)),
4625 newSVOP(OP_METHOD_NAMED, 0, meth)));
4628 /* Fake up the BEGIN {}, which does its thing immediately. */
4630 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4633 op_append_elem(OP_LINESEQ,
4634 op_append_elem(OP_LINESEQ,
4635 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4636 newSTATEOP(0, NULL, veop)),
4637 newSTATEOP(0, NULL, imop) ));
4640 /* If we request a version >= 5.9.5, load feature.pm with the
4641 * feature bundle that corresponds to the required version. */
4642 use_version = sv_2mortal(new_version(use_version));
4644 if (vcmp(use_version,
4645 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4646 SV *const importsv = vnormal(use_version);
4647 *SvPVX_mutable(importsv) = ':';
4648 ENTER_with_name("load_feature");
4649 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4650 LEAVE_with_name("load_feature");
4652 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4653 if (vcmp(use_version,
4654 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4655 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4659 /* The "did you use incorrect case?" warning used to be here.
4660 * The problem is that on case-insensitive filesystems one
4661 * might get false positives for "use" (and "require"):
4662 * "use Strict" or "require CARP" will work. This causes
4663 * portability problems for the script: in case-strict
4664 * filesystems the script will stop working.
4666 * The "incorrect case" warning checked whether "use Foo"
4667 * imported "Foo" to your namespace, but that is wrong, too:
4668 * there is no requirement nor promise in the language that
4669 * a Foo.pm should or would contain anything in package "Foo".
4671 * There is very little Configure-wise that can be done, either:
4672 * the case-sensitivity of the build filesystem of Perl does not
4673 * help in guessing the case-sensitivity of the runtime environment.
4676 PL_hints |= HINT_BLOCK_SCOPE;
4677 PL_parser->copline = NOLINE;
4678 PL_parser->expect = XSTATE;
4679 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4680 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4684 if (!PL_madskills) {
4685 /* FIXME - don't allocate pegop if !PL_madskills */
4694 =head1 Embedding Functions
4696 =for apidoc load_module
4698 Loads the module whose name is pointed to by the string part of name.
4699 Note that the actual module name, not its filename, should be given.
4700 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4701 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4702 (or 0 for no flags). ver, if specified, provides version semantics
4703 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4704 arguments can be used to specify arguments to the module's import()
4705 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4706 terminated with a final NULL pointer. Note that this list can only
4707 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4708 Otherwise at least a single NULL pointer to designate the default
4709 import list is required.
4714 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4718 PERL_ARGS_ASSERT_LOAD_MODULE;
4720 va_start(args, ver);
4721 vload_module(flags, name, ver, &args);
4725 #ifdef PERL_IMPLICIT_CONTEXT
4727 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4731 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4732 va_start(args, ver);
4733 vload_module(flags, name, ver, &args);
4739 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4743 OP * const modname = newSVOP(OP_CONST, 0, name);
4745 PERL_ARGS_ASSERT_VLOAD_MODULE;
4747 modname->op_private |= OPpCONST_BARE;
4749 veop = newSVOP(OP_CONST, 0, ver);
4753 if (flags & PERL_LOADMOD_NOIMPORT) {
4754 imop = sawparens(newNULLLIST());
4756 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4757 imop = va_arg(*args, OP*);
4762 sv = va_arg(*args, SV*);
4764 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4765 sv = va_arg(*args, SV*);
4769 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4770 * that it has a PL_parser to play with while doing that, and also
4771 * that it doesn't mess with any existing parser, by creating a tmp
4772 * new parser with lex_start(). This won't actually be used for much,
4773 * since pp_require() will create another parser for the real work. */
4776 SAVEVPTR(PL_curcop);
4777 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4778 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4779 veop, modname, imop);
4784 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4790 PERL_ARGS_ASSERT_DOFILE;
4792 if (!force_builtin) {
4793 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4794 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4795 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4796 gv = gvp ? *gvp : NULL;
4800 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4801 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4802 op_append_elem(OP_LIST, term,
4803 scalar(newUNOP(OP_RV2CV, 0,
4804 newGVOP(OP_GV, 0, gv))))));
4807 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4813 =head1 Optree construction
4815 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4817 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4818 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4819 be set automatically, and, shifted up eight bits, the eight bits of
4820 C<op_private>, except that the bit with value 1 or 2 is automatically
4821 set as required. I<listval> and I<subscript> supply the parameters of
4822 the slice; they are consumed by this function and become part of the
4823 constructed op tree.
4829 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4831 return newBINOP(OP_LSLICE, flags,
4832 list(force_list(subscript)),
4833 list(force_list(listval)) );
4837 S_is_list_assignment(pTHX_ register const OP *o)
4845 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4846 o = cUNOPo->op_first;
4848 flags = o->op_flags;
4850 if (type == OP_COND_EXPR) {
4851 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4852 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4857 yyerror("Assignment to both a list and a scalar");
4861 if (type == OP_LIST &&
4862 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4863 o->op_private & OPpLVAL_INTRO)
4866 if (type == OP_LIST || flags & OPf_PARENS ||
4867 type == OP_RV2AV || type == OP_RV2HV ||
4868 type == OP_ASLICE || type == OP_HSLICE)
4871 if (type == OP_PADAV || type == OP_PADHV)
4874 if (type == OP_RV2SV)
4881 Helper function for newASSIGNOP to detection commonality between the
4882 lhs and the rhs. Marks all variables with PL_generation. If it
4883 returns TRUE the assignment must be able to handle common variables.
4885 PERL_STATIC_INLINE bool
4886 S_aassign_common_vars(pTHX_ OP* o)
4889 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
4890 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4891 if (curop->op_type == OP_GV) {
4892 GV *gv = cGVOPx_gv(curop);
4894 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4896 GvASSIGN_GENERATION_set(gv, PL_generation);
4898 else if (curop->op_type == OP_PADSV ||
4899 curop->op_type == OP_PADAV ||
4900 curop->op_type == OP_PADHV ||
4901 curop->op_type == OP_PADANY)
4903 if (PAD_COMPNAME_GEN(curop->op_targ)
4904 == (STRLEN)PL_generation)
4906 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4909 else if (curop->op_type == OP_RV2CV)
4911 else if (curop->op_type == OP_RV2SV ||
4912 curop->op_type == OP_RV2AV ||
4913 curop->op_type == OP_RV2HV ||
4914 curop->op_type == OP_RV2GV) {
4915 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
4918 else if (curop->op_type == OP_PUSHRE) {
4920 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4921 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4923 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4925 GvASSIGN_GENERATION_set(gv, PL_generation);
4929 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4932 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4934 GvASSIGN_GENERATION_set(gv, PL_generation);
4942 if (curop->op_flags & OPf_KIDS) {
4943 if (aassign_common_vars(curop))
4951 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4953 Constructs, checks, and returns an assignment op. I<left> and I<right>
4954 supply the parameters of the assignment; they are consumed by this
4955 function and become part of the constructed op tree.
4957 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4958 a suitable conditional optree is constructed. If I<optype> is the opcode
4959 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4960 performs the binary operation and assigns the result to the left argument.
4961 Either way, if I<optype> is non-zero then I<flags> has no effect.
4963 If I<optype> is zero, then a plain scalar or list assignment is
4964 constructed. Which type of assignment it is is automatically determined.
4965 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4966 will be set automatically, and, shifted up eight bits, the eight bits
4967 of C<op_private>, except that the bit with value 1 or 2 is automatically
4974 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4980 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4981 return newLOGOP(optype, 0,
4982 op_lvalue(scalar(left), optype),
4983 newUNOP(OP_SASSIGN, 0, scalar(right)));
4986 return newBINOP(optype, OPf_STACKED,
4987 op_lvalue(scalar(left), optype), scalar(right));
4991 if (is_list_assignment(left)) {
4992 static const char no_list_state[] = "Initialization of state variables"
4993 " in list context currently forbidden";
4995 bool maybe_common_vars = TRUE;
4998 left = op_lvalue(left, OP_AASSIGN);
4999 curop = list(force_list(left));
5000 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5001 o->op_private = (U8)(0 | (flags >> 8));
5003 if ((left->op_type == OP_LIST
5004 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5006 OP* lop = ((LISTOP*)left)->op_first;
5007 maybe_common_vars = FALSE;
5009 if (lop->op_type == OP_PADSV ||
5010 lop->op_type == OP_PADAV ||
5011 lop->op_type == OP_PADHV ||
5012 lop->op_type == OP_PADANY) {
5013 if (!(lop->op_private & OPpLVAL_INTRO))
5014 maybe_common_vars = TRUE;
5016 if (lop->op_private & OPpPAD_STATE) {
5017 if (left->op_private & OPpLVAL_INTRO) {
5018 /* Each variable in state($a, $b, $c) = ... */
5021 /* Each state variable in
5022 (state $a, my $b, our $c, $d, undef) = ... */
5024 yyerror(no_list_state);
5026 /* Each my variable in
5027 (state $a, my $b, our $c, $d, undef) = ... */
5029 } else if (lop->op_type == OP_UNDEF ||
5030 lop->op_type == OP_PUSHMARK) {
5031 /* undef may be interesting in
5032 (state $a, undef, state $c) */
5034 /* Other ops in the list. */
5035 maybe_common_vars = TRUE;
5037 lop = lop->op_sibling;
5040 else if ((left->op_private & OPpLVAL_INTRO)
5041 && ( left->op_type == OP_PADSV
5042 || left->op_type == OP_PADAV
5043 || left->op_type == OP_PADHV
5044 || left->op_type == OP_PADANY))
5046 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5047 if (left->op_private & OPpPAD_STATE) {
5048 /* All single variable list context state assignments, hence
5058 yyerror(no_list_state);
5062 /* PL_generation sorcery:
5063 * an assignment like ($a,$b) = ($c,$d) is easier than
5064 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5065 * To detect whether there are common vars, the global var
5066 * PL_generation is incremented for each assign op we compile.
5067 * Then, while compiling the assign op, we run through all the
5068 * variables on both sides of the assignment, setting a spare slot
5069 * in each of them to PL_generation. If any of them already have
5070 * that value, we know we've got commonality. We could use a
5071 * single bit marker, but then we'd have to make 2 passes, first
5072 * to clear the flag, then to test and set it. To find somewhere
5073 * to store these values, evil chicanery is done with SvUVX().
5076 if (maybe_common_vars) {
5078 if (aassign_common_vars(o))
5079 o->op_private |= OPpASSIGN_COMMON;
5083 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5084 OP* tmpop = ((LISTOP*)right)->op_first;
5085 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5086 PMOP * const pm = (PMOP*)tmpop;
5087 if (left->op_type == OP_RV2AV &&
5088 !(left->op_private & OPpLVAL_INTRO) &&
5089 !(o->op_private & OPpASSIGN_COMMON) )
5091 tmpop = ((UNOP*)left)->op_first;
5092 if (tmpop->op_type == OP_GV
5094 && !pm->op_pmreplrootu.op_pmtargetoff
5096 && !pm->op_pmreplrootu.op_pmtargetgv
5100 pm->op_pmreplrootu.op_pmtargetoff
5101 = cPADOPx(tmpop)->op_padix;
5102 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5104 pm->op_pmreplrootu.op_pmtargetgv
5105 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5106 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5108 pm->op_pmflags |= PMf_ONCE;
5109 tmpop = cUNOPo->op_first; /* to list (nulled) */
5110 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5111 tmpop->op_sibling = NULL; /* don't free split */
5112 right->op_next = tmpop->op_next; /* fix starting loc */
5113 op_free(o); /* blow off assign */
5114 right->op_flags &= ~OPf_WANT;
5115 /* "I don't know and I don't care." */
5120 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5121 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5123 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5124 if (SvIOK(sv) && SvIVX(sv) == 0)
5125 sv_setiv(sv, PL_modcount+1);
5133 right = newOP(OP_UNDEF, 0);
5134 if (right->op_type == OP_READLINE) {
5135 right->op_flags |= OPf_STACKED;
5136 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5140 o = newBINOP(OP_SASSIGN, flags,
5141 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5147 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5149 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5150 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5151 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5152 If I<label> is non-null, it supplies the name of a label to attach to
5153 the state op; this function takes ownership of the memory pointed at by
5154 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5157 If I<o> is null, the state op is returned. Otherwise the state op is
5158 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5159 is consumed by this function and becomes part of the returned op tree.
5165 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5168 const U32 seq = intro_my();
5171 NewOp(1101, cop, 1, COP);
5172 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5173 cop->op_type = OP_DBSTATE;
5174 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5177 cop->op_type = OP_NEXTSTATE;
5178 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5180 cop->op_flags = (U8)flags;
5181 CopHINTS_set(cop, PL_hints);
5183 cop->op_private |= NATIVE_HINTS;
5185 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5186 cop->op_next = (OP*)cop;
5189 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5190 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5192 Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
5194 PL_hints |= HINT_BLOCK_SCOPE;
5195 /* It seems that we need to defer freeing this pointer, as other parts
5196 of the grammar end up wanting to copy it after this op has been
5201 if (PL_parser && PL_parser->copline == NOLINE)
5202 CopLINE_set(cop, CopLINE(PL_curcop));
5204 CopLINE_set(cop, PL_parser->copline);
5206 PL_parser->copline = NOLINE;
5209 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5211 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5213 CopSTASH_set(cop, PL_curstash);
5215 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5216 /* this line can have a breakpoint - store the cop in IV */
5217 AV *av = CopFILEAVx(PL_curcop);
5219 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5220 if (svp && *svp != &PL_sv_undef ) {
5221 (void)SvIOK_on(*svp);
5222 SvIV_set(*svp, PTR2IV(cop));
5227 if (flags & OPf_SPECIAL)
5229 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5233 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5235 Constructs, checks, and returns a logical (flow control) op. I<type>
5236 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5237 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5238 the eight bits of C<op_private>, except that the bit with value 1 is
5239 automatically set. I<first> supplies the expression controlling the
5240 flow, and I<other> supplies the side (alternate) chain of ops; they are
5241 consumed by this function and become part of the constructed op tree.
5247 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5251 PERL_ARGS_ASSERT_NEWLOGOP;
5253 return new_logop(type, flags, &first, &other);
5257 S_search_const(pTHX_ OP *o)
5259 PERL_ARGS_ASSERT_SEARCH_CONST;
5261 switch (o->op_type) {
5265 if (o->op_flags & OPf_KIDS)
5266 return search_const(cUNOPo->op_first);
5273 if (!(o->op_flags & OPf_KIDS))
5275 kid = cLISTOPo->op_first;
5277 switch (kid->op_type) {
5281 kid = kid->op_sibling;
5284 if (kid != cLISTOPo->op_last)
5290 kid = cLISTOPo->op_last;
5292 return search_const(kid);
5300 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5308 int prepend_not = 0;
5310 PERL_ARGS_ASSERT_NEW_LOGOP;
5315 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5316 return newBINOP(type, flags, scalar(first), scalar(other));
5318 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5320 scalarboolean(first);
5321 /* optimize AND and OR ops that have NOTs as children */
5322 if (first->op_type == OP_NOT
5323 && (first->op_flags & OPf_KIDS)
5324 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5325 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5327 if (type == OP_AND || type == OP_OR) {
5333 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5335 prepend_not = 1; /* prepend a NOT op later */
5339 /* search for a constant op that could let us fold the test */
5340 if ((cstop = search_const(first))) {
5341 if (cstop->op_private & OPpCONST_STRICT)
5342 no_bareword_allowed(cstop);
5343 else if ((cstop->op_private & OPpCONST_BARE))
5344 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5345 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5346 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5347 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5349 if (other->op_type == OP_CONST)
5350 other->op_private |= OPpCONST_SHORTCIRCUIT;
5352 OP *newop = newUNOP(OP_NULL, 0, other);
5353 op_getmad(first, newop, '1');
5354 newop->op_targ = type; /* set "was" field */
5358 if (other->op_type == OP_LEAVE)
5359 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5360 else if (other->op_type == OP_MATCH
5361 || other->op_type == OP_SUBST
5362 || other->op_type == OP_TRANSR
5363 || other->op_type == OP_TRANS)
5364 /* Mark the op as being unbindable with =~ */
5365 other->op_flags |= OPf_SPECIAL;
5369 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5370 const OP *o2 = other;
5371 if ( ! (o2->op_type == OP_LIST
5372 && (( o2 = cUNOPx(o2)->op_first))
5373 && o2->op_type == OP_PUSHMARK
5374 && (( o2 = o2->op_sibling)) )
5377 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5378 || o2->op_type == OP_PADHV)
5379 && o2->op_private & OPpLVAL_INTRO
5380 && !(o2->op_private & OPpPAD_STATE))
5382 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5383 "Deprecated use of my() in false conditional");
5387 if (first->op_type == OP_CONST)
5388 first->op_private |= OPpCONST_SHORTCIRCUIT;
5390 first = newUNOP(OP_NULL, 0, first);
5391 op_getmad(other, first, '2');
5392 first->op_targ = type; /* set "was" field */
5399 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5400 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5402 const OP * const k1 = ((UNOP*)first)->op_first;
5403 const OP * const k2 = k1->op_sibling;
5405 switch (first->op_type)
5408 if (k2 && k2->op_type == OP_READLINE
5409 && (k2->op_flags & OPf_STACKED)
5410 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5412 warnop = k2->op_type;
5417 if (k1->op_type == OP_READDIR
5418 || k1->op_type == OP_GLOB
5419 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5420 || k1->op_type == OP_EACH
5421 || k1->op_type == OP_AEACH)
5423 warnop = ((k1->op_type == OP_NULL)
5424 ? (OPCODE)k1->op_targ : k1->op_type);
5429 const line_t oldline = CopLINE(PL_curcop);
5430 CopLINE_set(PL_curcop, PL_parser->copline);
5431 Perl_warner(aTHX_ packWARN(WARN_MISC),
5432 "Value of %s%s can be \"0\"; test with defined()",
5434 ((warnop == OP_READLINE || warnop == OP_GLOB)
5435 ? " construct" : "() operator"));
5436 CopLINE_set(PL_curcop, oldline);
5443 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5444 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5446 NewOp(1101, logop, 1, LOGOP);
5448 logop->op_type = (OPCODE)type;
5449 logop->op_ppaddr = PL_ppaddr[type];
5450 logop->op_first = first;
5451 logop->op_flags = (U8)(flags | OPf_KIDS);
5452 logop->op_other = LINKLIST(other);
5453 logop->op_private = (U8)(1 | (flags >> 8));
5455 /* establish postfix order */
5456 logop->op_next = LINKLIST(first);
5457 first->op_next = (OP*)logop;
5458 first->op_sibling = other;
5460 CHECKOP(type,logop);
5462 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5469 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5471 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5472 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5473 will be set automatically, and, shifted up eight bits, the eight bits of
5474 C<op_private>, except that the bit with value 1 is automatically set.
5475 I<first> supplies the expression selecting between the two branches,
5476 and I<trueop> and I<falseop> supply the branches; they are consumed by
5477 this function and become part of the constructed op tree.
5483 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5491 PERL_ARGS_ASSERT_NEWCONDOP;
5494 return newLOGOP(OP_AND, 0, first, trueop);
5496 return newLOGOP(OP_OR, 0, first, falseop);
5498 scalarboolean(first);
5499 if ((cstop = search_const(first))) {
5500 /* Left or right arm of the conditional? */
5501 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5502 OP *live = left ? trueop : falseop;
5503 OP *const dead = left ? falseop : trueop;
5504 if (cstop->op_private & OPpCONST_BARE &&
5505 cstop->op_private & OPpCONST_STRICT) {
5506 no_bareword_allowed(cstop);
5509 /* This is all dead code when PERL_MAD is not defined. */
5510 live = newUNOP(OP_NULL, 0, live);
5511 op_getmad(first, live, 'C');
5512 op_getmad(dead, live, left ? 'e' : 't');
5517 if (live->op_type == OP_LEAVE)
5518 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5519 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5520 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5521 /* Mark the op as being unbindable with =~ */
5522 live->op_flags |= OPf_SPECIAL;
5525 NewOp(1101, logop, 1, LOGOP);
5526 logop->op_type = OP_COND_EXPR;
5527 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5528 logop->op_first = first;
5529 logop->op_flags = (U8)(flags | OPf_KIDS);
5530 logop->op_private = (U8)(1 | (flags >> 8));
5531 logop->op_other = LINKLIST(trueop);
5532 logop->op_next = LINKLIST(falseop);
5534 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5537 /* establish postfix order */
5538 start = LINKLIST(first);
5539 first->op_next = (OP*)logop;
5541 first->op_sibling = trueop;
5542 trueop->op_sibling = falseop;
5543 o = newUNOP(OP_NULL, 0, (OP*)logop);
5545 trueop->op_next = falseop->op_next = o;
5552 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5554 Constructs and returns a C<range> op, with subordinate C<flip> and
5555 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5556 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5557 for both the C<flip> and C<range> ops, except that the bit with value
5558 1 is automatically set. I<left> and I<right> supply the expressions
5559 controlling the endpoints of the range; they are consumed by this function
5560 and become part of the constructed op tree.
5566 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5575 PERL_ARGS_ASSERT_NEWRANGE;
5577 NewOp(1101, range, 1, LOGOP);
5579 range->op_type = OP_RANGE;
5580 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5581 range->op_first = left;
5582 range->op_flags = OPf_KIDS;
5583 leftstart = LINKLIST(left);
5584 range->op_other = LINKLIST(right);
5585 range->op_private = (U8)(1 | (flags >> 8));
5587 left->op_sibling = right;
5589 range->op_next = (OP*)range;
5590 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5591 flop = newUNOP(OP_FLOP, 0, flip);
5592 o = newUNOP(OP_NULL, 0, flop);
5594 range->op_next = leftstart;
5596 left->op_next = flip;
5597 right->op_next = flop;
5599 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5600 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5601 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5602 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5604 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5605 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5607 /* check barewords before they might be optimized aways */
5608 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5609 no_bareword_allowed(left);
5610 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5611 no_bareword_allowed(right);
5614 if (!flip->op_private || !flop->op_private)
5615 LINKLIST(o); /* blow off optimizer unless constant */
5621 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5623 Constructs, checks, and returns an op tree expressing a loop. This is
5624 only a loop in the control flow through the op tree; it does not have
5625 the heavyweight loop structure that allows exiting the loop by C<last>
5626 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5627 top-level op, except that some bits will be set automatically as required.
5628 I<expr> supplies the expression controlling loop iteration, and I<block>
5629 supplies the body of the loop; they are consumed by this function and
5630 become part of the constructed op tree. I<debuggable> is currently
5631 unused and should always be 1.
5637 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5642 const bool once = block && block->op_flags & OPf_SPECIAL &&
5643 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5645 PERL_UNUSED_ARG(debuggable);
5648 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5649 return block; /* do {} while 0 does once */
5650 if (expr->op_type == OP_READLINE
5651 || expr->op_type == OP_READDIR
5652 || expr->op_type == OP_GLOB
5653 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5654 expr = newUNOP(OP_DEFINED, 0,
5655 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5656 } else if (expr->op_flags & OPf_KIDS) {
5657 const OP * const k1 = ((UNOP*)expr)->op_first;
5658 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5659 switch (expr->op_type) {
5661 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5662 && (k2->op_flags & OPf_STACKED)
5663 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5664 expr = newUNOP(OP_DEFINED, 0, expr);
5668 if (k1 && (k1->op_type == OP_READDIR
5669 || k1->op_type == OP_GLOB
5670 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5671 || k1->op_type == OP_EACH
5672 || k1->op_type == OP_AEACH))
5673 expr = newUNOP(OP_DEFINED, 0, expr);
5679 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5680 * op, in listop. This is wrong. [perl #27024] */
5682 block = newOP(OP_NULL, 0);
5683 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5684 o = new_logop(OP_AND, 0, &expr, &listop);
5687 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5689 if (once && o != listop)
5690 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5693 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5695 o->op_flags |= flags;
5697 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5702 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5704 Constructs, checks, and returns an op tree expressing a C<while> loop.
5705 This is a heavyweight loop, with structure that allows exiting the loop
5706 by C<last> and suchlike.
5708 I<loop> is an optional preconstructed C<enterloop> op to use in the
5709 loop; if it is null then a suitable op will be constructed automatically.
5710 I<expr> supplies the loop's controlling expression. I<block> supplies the
5711 main body of the loop, and I<cont> optionally supplies a C<continue> block
5712 that operates as a second half of the body. All of these optree inputs
5713 are consumed by this function and become part of the constructed op tree.
5715 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5716 op and, shifted up eight bits, the eight bits of C<op_private> for
5717 the C<leaveloop> op, except that (in both cases) some bits will be set
5718 automatically. I<debuggable> is currently unused and should always be 1.
5719 I<has_my> can be supplied as true to force the
5720 loop body to be enclosed in its own scope.
5726 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5727 OP *expr, OP *block, OP *cont, I32 has_my)
5736 PERL_UNUSED_ARG(debuggable);
5739 if (expr->op_type == OP_READLINE
5740 || expr->op_type == OP_READDIR
5741 || expr->op_type == OP_GLOB
5742 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5743 expr = newUNOP(OP_DEFINED, 0,
5744 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5745 } else if (expr->op_flags & OPf_KIDS) {
5746 const OP * const k1 = ((UNOP*)expr)->op_first;
5747 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5748 switch (expr->op_type) {
5750 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5751 && (k2->op_flags & OPf_STACKED)
5752 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5753 expr = newUNOP(OP_DEFINED, 0, expr);
5757 if (k1 && (k1->op_type == OP_READDIR
5758 || k1->op_type == OP_GLOB
5759 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5760 || k1->op_type == OP_EACH
5761 || k1->op_type == OP_AEACH))
5762 expr = newUNOP(OP_DEFINED, 0, expr);
5769 block = newOP(OP_NULL, 0);
5770 else if (cont || has_my) {
5771 block = op_scope(block);
5775 next = LINKLIST(cont);
5778 OP * const unstack = newOP(OP_UNSTACK, 0);
5781 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5785 listop = op_append_list(OP_LINESEQ, block, cont);
5787 redo = LINKLIST(listop);
5791 o = new_logop(OP_AND, 0, &expr, &listop);
5792 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5793 op_free(expr); /* oops, it's a while (0) */
5795 return NULL; /* listop already freed by new_logop */
5798 ((LISTOP*)listop)->op_last->op_next =
5799 (o == listop ? redo : LINKLIST(o));
5805 NewOp(1101,loop,1,LOOP);
5806 loop->op_type = OP_ENTERLOOP;
5807 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5808 loop->op_private = 0;
5809 loop->op_next = (OP*)loop;
5812 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5814 loop->op_redoop = redo;
5815 loop->op_lastop = o;
5816 o->op_private |= loopflags;
5819 loop->op_nextop = next;
5821 loop->op_nextop = o;
5823 o->op_flags |= flags;
5824 o->op_private |= (flags >> 8);
5829 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5831 Constructs, checks, and returns an op tree expressing a C<foreach>
5832 loop (iteration through a list of values). This is a heavyweight loop,
5833 with structure that allows exiting the loop by C<last> and suchlike.
5835 I<sv> optionally supplies the variable that will be aliased to each
5836 item in turn; if null, it defaults to C<$_> (either lexical or global).
5837 I<expr> supplies the list of values to iterate over. I<block> supplies
5838 the main body of the loop, and I<cont> optionally supplies a C<continue>
5839 block that operates as a second half of the body. All of these optree
5840 inputs are consumed by this function and become part of the constructed
5843 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5844 op and, shifted up eight bits, the eight bits of C<op_private> for
5845 the C<leaveloop> op, except that (in both cases) some bits will be set
5852 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5857 PADOFFSET padoff = 0;
5862 PERL_ARGS_ASSERT_NEWFOROP;
5865 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5866 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5867 sv->op_type = OP_RV2GV;
5868 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5870 /* The op_type check is needed to prevent a possible segfault
5871 * if the loop variable is undeclared and 'strict vars' is in
5872 * effect. This is illegal but is nonetheless parsed, so we
5873 * may reach this point with an OP_CONST where we're expecting
5876 if (cUNOPx(sv)->op_first->op_type == OP_GV
5877 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5878 iterpflags |= OPpITER_DEF;
5880 else if (sv->op_type == OP_PADSV) { /* private variable */
5881 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5882 padoff = sv->op_targ;
5892 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5894 SV *const namesv = PAD_COMPNAME_SV(padoff);
5896 const char *const name = SvPV_const(namesv, len);
5898 if (len == 2 && name[0] == '$' && name[1] == '_')
5899 iterpflags |= OPpITER_DEF;
5903 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5904 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5905 sv = newGVOP(OP_GV, 0, PL_defgv);
5910 iterpflags |= OPpITER_DEF;
5912 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5913 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5914 iterflags |= OPf_STACKED;
5916 else if (expr->op_type == OP_NULL &&
5917 (expr->op_flags & OPf_KIDS) &&
5918 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5920 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5921 * set the STACKED flag to indicate that these values are to be
5922 * treated as min/max values by 'pp_iterinit'.
5924 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5925 LOGOP* const range = (LOGOP*) flip->op_first;
5926 OP* const left = range->op_first;
5927 OP* const right = left->op_sibling;
5930 range->op_flags &= ~OPf_KIDS;
5931 range->op_first = NULL;
5933 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5934 listop->op_first->op_next = range->op_next;
5935 left->op_next = range->op_other;
5936 right->op_next = (OP*)listop;
5937 listop->op_next = listop->op_first;
5940 op_getmad(expr,(OP*)listop,'O');
5944 expr = (OP*)(listop);
5946 iterflags |= OPf_STACKED;
5949 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5952 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5953 op_append_elem(OP_LIST, expr, scalar(sv))));
5954 assert(!loop->op_next);
5955 /* for my $x () sets OPpLVAL_INTRO;
5956 * for our $x () sets OPpOUR_INTRO */
5957 loop->op_private = (U8)iterpflags;
5958 #ifdef PL_OP_SLAB_ALLOC
5961 NewOp(1234,tmp,1,LOOP);
5962 Copy(loop,tmp,1,LISTOP);
5963 S_op_destroy(aTHX_ (OP*)loop);
5967 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5969 loop->op_targ = padoff;
5970 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5972 op_getmad(madsv, (OP*)loop, 'v');
5977 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5979 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5980 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5981 determining the target of the op; it is consumed by this function and
5982 become part of the constructed op tree.
5988 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5993 PERL_ARGS_ASSERT_NEWLOOPEX;
5995 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5997 if (type != OP_GOTO || label->op_type == OP_CONST) {
5998 /* "last()" means "last" */
5999 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6000 o = newOP(type, OPf_SPECIAL);
6002 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
6003 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6007 op_getmad(label,o,'L');
6013 /* Check whether it's going to be a goto &function */
6014 if (label->op_type == OP_ENTERSUB
6015 && !(label->op_flags & OPf_STACKED))
6016 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6017 o = newUNOP(type, OPf_STACKED, label);
6019 PL_hints |= HINT_BLOCK_SCOPE;
6023 /* if the condition is a literal array or hash
6024 (or @{ ... } etc), make a reference to it.
6027 S_ref_array_or_hash(pTHX_ OP *cond)
6030 && (cond->op_type == OP_RV2AV
6031 || cond->op_type == OP_PADAV
6032 || cond->op_type == OP_RV2HV
6033 || cond->op_type == OP_PADHV))
6035 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6038 && (cond->op_type == OP_ASLICE
6039 || cond->op_type == OP_HSLICE)) {
6041 /* anonlist now needs a list from this op, was previously used in
6043 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6044 cond->op_flags |= OPf_WANT_LIST;
6046 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6053 /* These construct the optree fragments representing given()
6056 entergiven and enterwhen are LOGOPs; the op_other pointer
6057 points up to the associated leave op. We need this so we
6058 can put it in the context and make break/continue work.
6059 (Also, of course, pp_enterwhen will jump straight to
6060 op_other if the match fails.)
6064 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6065 I32 enter_opcode, I32 leave_opcode,
6066 PADOFFSET entertarg)
6072 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6074 NewOp(1101, enterop, 1, LOGOP);
6075 enterop->op_type = (Optype)enter_opcode;
6076 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6077 enterop->op_flags = (U8) OPf_KIDS;
6078 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6079 enterop->op_private = 0;
6081 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6084 enterop->op_first = scalar(cond);
6085 cond->op_sibling = block;
6087 o->op_next = LINKLIST(cond);
6088 cond->op_next = (OP *) enterop;
6091 /* This is a default {} block */
6092 enterop->op_first = block;
6093 enterop->op_flags |= OPf_SPECIAL;
6095 o->op_next = (OP *) enterop;
6098 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6099 entergiven and enterwhen both
6102 enterop->op_next = LINKLIST(block);
6103 block->op_next = enterop->op_other = o;
6108 /* Does this look like a boolean operation? For these purposes
6109 a boolean operation is:
6110 - a subroutine call [*]
6111 - a logical connective
6112 - a comparison operator
6113 - a filetest operator, with the exception of -s -M -A -C
6114 - defined(), exists() or eof()
6115 - /$re/ or $foo =~ /$re/
6117 [*] possibly surprising
6120 S_looks_like_bool(pTHX_ const OP *o)
6124 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6126 switch(o->op_type) {
6129 return looks_like_bool(cLOGOPo->op_first);
6133 looks_like_bool(cLOGOPo->op_first)
6134 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6139 o->op_flags & OPf_KIDS
6140 && looks_like_bool(cUNOPo->op_first));
6144 case OP_NOT: case OP_XOR:
6146 case OP_EQ: case OP_NE: case OP_LT:
6147 case OP_GT: case OP_LE: case OP_GE:
6149 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6150 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6152 case OP_SEQ: case OP_SNE: case OP_SLT:
6153 case OP_SGT: case OP_SLE: case OP_SGE:
6157 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6158 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6159 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6160 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6161 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6162 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6163 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6164 case OP_FTTEXT: case OP_FTBINARY:
6166 case OP_DEFINED: case OP_EXISTS:
6167 case OP_MATCH: case OP_EOF:
6174 /* Detect comparisons that have been optimized away */
6175 if (cSVOPo->op_sv == &PL_sv_yes
6176 || cSVOPo->op_sv == &PL_sv_no)
6189 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6191 Constructs, checks, and returns an op tree expressing a C<given> block.
6192 I<cond> supplies the expression that will be locally assigned to a lexical
6193 variable, and I<block> supplies the body of the C<given> construct; they
6194 are consumed by this function and become part of the constructed op tree.
6195 I<defsv_off> is the pad offset of the scalar lexical variable that will
6202 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6205 PERL_ARGS_ASSERT_NEWGIVENOP;
6206 return newGIVWHENOP(
6207 ref_array_or_hash(cond),
6209 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6214 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6216 Constructs, checks, and returns an op tree expressing a C<when> block.
6217 I<cond> supplies the test expression, and I<block> supplies the block
6218 that will be executed if the test evaluates to true; they are consumed
6219 by this function and become part of the constructed op tree. I<cond>
6220 will be interpreted DWIMically, often as a comparison against C<$_>,
6221 and may be null to generate a C<default> block.
6227 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6229 const bool cond_llb = (!cond || looks_like_bool(cond));
6232 PERL_ARGS_ASSERT_NEWWHENOP;
6237 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6239 scalar(ref_array_or_hash(cond)));
6242 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6246 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
6249 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
6251 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
6252 || (p && (len != SvCUR(cv) /* Not the same length. */
6253 || memNE(p, SvPVX_const(cv), len))))
6254 && ckWARN_d(WARN_PROTOTYPE)) {
6255 SV* const msg = sv_newmortal();
6259 gv_efullname3(name = sv_newmortal(), gv, NULL);
6260 sv_setpvs(msg, "Prototype mismatch:");
6262 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6264 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
6266 sv_catpvs(msg, ": none");
6267 sv_catpvs(msg, " vs ");
6269 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
6271 sv_catpvs(msg, "none");
6272 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6276 static void const_sv_xsub(pTHX_ CV* cv);
6280 =head1 Optree Manipulation Functions
6282 =for apidoc cv_const_sv
6284 If C<cv> is a constant sub eligible for inlining. returns the constant
6285 value returned by the sub. Otherwise, returns NULL.
6287 Constant subs can be created with C<newCONSTSUB> or as described in
6288 L<perlsub/"Constant Functions">.
6293 Perl_cv_const_sv(pTHX_ const CV *const cv)
6295 PERL_UNUSED_CONTEXT;
6298 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6300 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6303 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6304 * Can be called in 3 ways:
6307 * look for a single OP_CONST with attached value: return the value
6309 * cv && CvCLONE(cv) && !CvCONST(cv)
6311 * examine the clone prototype, and if contains only a single
6312 * OP_CONST referencing a pad const, or a single PADSV referencing
6313 * an outer lexical, return a non-zero value to indicate the CV is
6314 * a candidate for "constizing" at clone time
6318 * We have just cloned an anon prototype that was marked as a const
6319 * candidate. Try to grab the current value, and in the case of
6320 * PADSV, ignore it if it has multiple references. Return the value.
6324 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6335 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6336 o = cLISTOPo->op_first->op_sibling;
6338 for (; o; o = o->op_next) {
6339 const OPCODE type = o->op_type;
6341 if (sv && o->op_next == o)
6343 if (o->op_next != o) {
6344 if (type == OP_NEXTSTATE
6345 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6346 || type == OP_PUSHMARK)
6348 if (type == OP_DBSTATE)
6351 if (type == OP_LEAVESUB || type == OP_RETURN)
6355 if (type == OP_CONST && cSVOPo->op_sv)
6357 else if (cv && type == OP_CONST) {
6358 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6362 else if (cv && type == OP_PADSV) {
6363 if (CvCONST(cv)) { /* newly cloned anon */
6364 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6365 /* the candidate should have 1 ref from this pad and 1 ref
6366 * from the parent */
6367 if (!sv || SvREFCNT(sv) != 2)
6374 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6375 sv = &PL_sv_undef; /* an arbitrary non-null value */
6390 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6393 /* This would be the return value, but the return cannot be reached. */
6394 OP* pegop = newOP(OP_NULL, 0);
6397 PERL_UNUSED_ARG(floor);
6407 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6409 NORETURN_FUNCTION_END;
6414 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6419 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6420 register CV *cv = NULL;
6422 /* If the subroutine has no body, no attributes, and no builtin attributes
6423 then it's just a sub declaration, and we may be able to get away with
6424 storing with a placeholder scalar in the symbol table, rather than a
6425 full GV and CV. If anything is present then it will take a full CV to
6427 const I32 gv_fetch_flags
6428 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6430 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6431 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6435 assert(proto->op_type == OP_CONST);
6436 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6442 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6444 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6445 SV * const sv = sv_newmortal();
6446 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6447 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6448 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6449 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6451 } else if (PL_curstash) {
6452 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6455 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6459 if (!PL_madskills) {
6468 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6469 maximum a prototype before. */
6470 if (SvTYPE(gv) > SVt_NULL) {
6471 if (!SvPOK((const SV *)gv)
6472 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6474 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6476 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6479 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6481 sv_setiv(MUTABLE_SV(gv), -1);
6483 SvREFCNT_dec(PL_compcv);
6484 cv = PL_compcv = NULL;
6488 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6490 if (!block || !ps || *ps || attrs
6491 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6493 || block->op_type == OP_NULL
6498 const_sv = op_const_sv(block, NULL);
6501 const bool exists = CvROOT(cv) || CvXSUB(cv);
6503 /* if the subroutine doesn't exist and wasn't pre-declared
6504 * with a prototype, assume it will be AUTOLOADed,
6505 * skipping the prototype check
6507 if (exists || SvPOK(cv))
6508 cv_ckproto_len(cv, gv, ps, ps_len);
6509 /* already defined (or promised)? */
6510 if (exists || GvASSUMECV(gv)) {
6513 || block->op_type == OP_NULL
6516 if (CvFLAGS(PL_compcv)) {
6517 /* might have had built-in attrs applied */
6518 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6519 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6520 && ckWARN(WARN_MISC))
6521 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6523 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6524 & ~(CVf_LVALUE * pureperl));
6526 if (attrs) goto attrs;
6527 /* just a "sub foo;" when &foo is already defined */
6528 SAVEFREESV(PL_compcv);
6533 && block->op_type != OP_NULL
6536 if (ckWARN(WARN_REDEFINE)
6538 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6540 const line_t oldline = CopLINE(PL_curcop);
6541 if (PL_parser && PL_parser->copline != NOLINE)
6542 CopLINE_set(PL_curcop, PL_parser->copline);
6543 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6544 CvCONST(cv) ? "Constant subroutine %s redefined"
6545 : "Subroutine %s redefined", name);
6546 CopLINE_set(PL_curcop, oldline);
6549 if (!PL_minus_c) /* keep old one around for madskills */
6552 /* (PL_madskills unset in used file.) */
6560 SvREFCNT_inc_simple_void_NN(const_sv);
6562 assert(!CvROOT(cv) && !CvCONST(cv));
6563 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6564 CvXSUBANY(cv).any_ptr = const_sv;
6565 CvXSUB(cv) = const_sv_xsub;
6571 cv = newCONSTSUB(NULL, name, const_sv);
6573 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6574 (CvGV(cv) && GvSTASH(CvGV(cv)))
6583 SvREFCNT_dec(PL_compcv);
6587 if (cv) { /* must reuse cv if autoloaded */
6588 /* transfer PL_compcv to cv */
6591 && block->op_type != OP_NULL
6594 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6595 AV *const temp_av = CvPADLIST(cv);
6596 CV *const temp_cv = CvOUTSIDE(cv);
6598 assert(!CvWEAKOUTSIDE(cv));
6599 assert(!CvCVGV_RC(cv));
6600 assert(CvGV(cv) == gv);
6603 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6604 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6605 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6606 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6607 CvOUTSIDE(PL_compcv) = temp_cv;
6608 CvPADLIST(PL_compcv) = temp_av;
6610 if (CvFILE(cv) && CvDYNFILE(cv)) {
6611 Safefree(CvFILE(cv));
6613 CvFILE_set_from_cop(cv, PL_curcop);
6614 CvSTASH_set(cv, PL_curstash);
6616 /* inner references to PL_compcv must be fixed up ... */
6617 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6618 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6619 ++PL_sub_generation;
6622 /* Might have had built-in attributes applied -- propagate them. */
6623 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6625 /* ... before we throw it away */
6626 SvREFCNT_dec(PL_compcv);
6634 if (strEQ(name, "import")) {
6635 PL_formfeed = MUTABLE_SV(cv);
6636 /* diag_listed_as: SKIPME */
6637 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6641 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6646 CvFILE_set_from_cop(cv, PL_curcop);
6647 CvSTASH_set(cv, PL_curstash);
6651 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6652 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6653 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6657 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6659 if (PL_parser && PL_parser->error_count) {
6663 const char *s = strrchr(name, ':');
6665 if (strEQ(s, "BEGIN")) {
6666 const char not_safe[] =
6667 "BEGIN not safe after errors--compilation aborted";
6668 if (PL_in_eval & EVAL_KEEPERR)
6669 Perl_croak(aTHX_ not_safe);
6671 /* force display of errors found but not reported */
6672 sv_catpv(ERRSV, not_safe);
6673 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6682 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6683 the debugger could be able to set a breakpoint in, so signal to
6684 pp_entereval that it should not throw away any saved lines at scope
6687 PL_breakable_sub_gen++;
6688 /* This makes sub {}; work as expected. */
6689 if (block->op_type == OP_STUB) {
6690 OP* const newblock = newSTATEOP(0, NULL, 0);
6692 op_getmad(block,newblock,'B');
6698 else block->op_attached = 1;
6699 CvROOT(cv) = CvLVALUE(cv)
6700 ? newUNOP(OP_LEAVESUBLV, 0,
6701 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6702 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6703 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6704 OpREFCNT_set(CvROOT(cv), 1);
6705 CvSTART(cv) = LINKLIST(CvROOT(cv));
6706 CvROOT(cv)->op_next = 0;
6707 CALL_PEEP(CvSTART(cv));
6708 finalize_optree(CvROOT(cv));
6710 /* now that optimizer has done its work, adjust pad values */
6712 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6715 assert(!CvCONST(cv));
6716 if (ps && !*ps && op_const_sv(block, cv))
6721 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6722 SV * const tmpstr = sv_newmortal();
6723 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6724 GV_ADDMULTI, SVt_PVHV);
6726 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6729 (long)CopLINE(PL_curcop));
6730 gv_efullname3(tmpstr, gv, NULL);
6731 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6732 SvCUR(tmpstr), sv, 0);
6733 hv = GvHVn(db_postponed);
6734 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6735 CV * const pcv = GvCV(db_postponed);
6741 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6746 if (name && ! (PL_parser && PL_parser->error_count))
6747 process_special_blocks(name, gv, cv);
6752 PL_parser->copline = NOLINE;
6758 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6761 const char *const colon = strrchr(fullname,':');
6762 const char *const name = colon ? colon + 1 : fullname;
6764 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6767 if (strEQ(name, "BEGIN")) {
6768 const I32 oldscope = PL_scopestack_ix;
6770 SAVECOPFILE(&PL_compiling);
6771 SAVECOPLINE(&PL_compiling);
6773 DEBUG_x( dump_sub(gv) );
6774 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6775 GvCV_set(gv,0); /* cv has been hijacked */
6776 call_list(oldscope, PL_beginav);
6778 PL_curcop = &PL_compiling;
6779 CopHINTS_set(&PL_compiling, PL_hints);
6786 if strEQ(name, "END") {
6787 DEBUG_x( dump_sub(gv) );
6788 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6791 } else if (*name == 'U') {
6792 if (strEQ(name, "UNITCHECK")) {
6793 /* It's never too late to run a unitcheck block */
6794 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6798 } else if (*name == 'C') {
6799 if (strEQ(name, "CHECK")) {
6801 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6802 "Too late to run CHECK block");
6803 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6807 } else if (*name == 'I') {
6808 if (strEQ(name, "INIT")) {
6810 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6811 "Too late to run INIT block");
6812 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6818 DEBUG_x( dump_sub(gv) );
6819 GvCV_set(gv,0); /* cv has been hijacked */
6824 =for apidoc newCONSTSUB
6826 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6827 eligible for inlining at compile-time.
6829 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6830 which won't be called if used as a destructor, but will suppress the overhead
6831 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6838 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6843 const char *const file = CopFILE(PL_curcop);
6845 SV *const temp_sv = CopFILESV(PL_curcop);
6846 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6851 if (IN_PERL_RUNTIME) {
6852 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6853 * an op shared between threads. Use a non-shared COP for our
6855 SAVEVPTR(PL_curcop);
6856 PL_curcop = &PL_compiling;
6858 SAVECOPLINE(PL_curcop);
6859 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6862 PL_hints &= ~HINT_BLOCK_SCOPE;
6865 SAVESPTR(PL_curstash);
6866 SAVECOPSTASH(PL_curcop);
6867 PL_curstash = stash;
6868 CopSTASH_set(PL_curcop,stash);
6871 /* file becomes the CvFILE. For an XS, it's usually static storage,
6872 and so doesn't get free()d. (It's expected to be from the C pre-
6873 processor __FILE__ directive). But we need a dynamically allocated one,
6874 and we need it to get freed. */
6875 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6876 XS_DYNAMIC_FILENAME);
6877 CvXSUBANY(cv).any_ptr = sv;
6882 CopSTASH_free(PL_curcop);
6890 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6891 const char *const filename, const char *const proto,
6894 CV *cv = newXS(name, subaddr, filename);
6896 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6898 if (flags & XS_DYNAMIC_FILENAME) {
6899 CvFILE(cv) = savepv(filename);
6902 sv_setpv(MUTABLE_SV(cv), proto);
6907 =for apidoc U||newXS
6909 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6910 static storage, as it is used directly as CvFILE(), without a copy being made.
6916 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6919 GV * const gv = gv_fetchpv(name ? name :
6920 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6921 GV_ADDMULTI, SVt_PVCV);
6924 PERL_ARGS_ASSERT_NEWXS;
6927 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6929 if ((cv = (name ? GvCV(gv) : NULL))) {
6931 /* just a cached method */
6935 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6936 /* already defined (or promised) */
6937 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6938 if (ckWARN(WARN_REDEFINE)) {
6939 GV * const gvcv = CvGV(cv);
6941 HV * const stash = GvSTASH(gvcv);
6943 const char *redefined_name = HvNAME_get(stash);
6944 if ( strEQ(redefined_name,"autouse") ) {
6945 const line_t oldline = CopLINE(PL_curcop);
6946 if (PL_parser && PL_parser->copline != NOLINE)
6947 CopLINE_set(PL_curcop, PL_parser->copline);
6948 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6949 CvCONST(cv) ? "Constant subroutine %s redefined"
6950 : "Subroutine %s redefined"
6952 CopLINE_set(PL_curcop, oldline);
6962 if (cv) /* must reuse cv if autoloaded */
6965 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6969 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6975 (void)gv_fetchfile(filename);
6976 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6977 an external constant string */
6978 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
6980 CvXSUB(cv) = subaddr;
6983 process_special_blocks(name, gv, cv);
6993 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6998 OP* pegop = newOP(OP_NULL, 0);
7002 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7003 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7006 if ((cv = GvFORM(gv))) {
7007 if (ckWARN(WARN_REDEFINE)) {
7008 const line_t oldline = CopLINE(PL_curcop);
7009 if (PL_parser && PL_parser->copline != NOLINE)
7010 CopLINE_set(PL_curcop, PL_parser->copline);
7012 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7013 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7015 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7016 "Format STDOUT redefined");
7018 CopLINE_set(PL_curcop, oldline);
7025 CvFILE_set_from_cop(cv, PL_curcop);
7028 pad_tidy(padtidy_FORMAT);
7029 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7030 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7031 OpREFCNT_set(CvROOT(cv), 1);
7032 CvSTART(cv) = LINKLIST(CvROOT(cv));
7033 CvROOT(cv)->op_next = 0;
7034 CALL_PEEP(CvSTART(cv));
7035 finalize_optree(CvROOT(cv));
7037 op_getmad(o,pegop,'n');
7038 op_getmad_weak(block, pegop, 'b');
7043 PL_parser->copline = NOLINE;
7051 Perl_newANONLIST(pTHX_ OP *o)
7053 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7057 Perl_newANONHASH(pTHX_ OP *o)
7059 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7063 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7065 return newANONATTRSUB(floor, proto, NULL, block);
7069 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7071 return newUNOP(OP_REFGEN, 0,
7072 newSVOP(OP_ANONCODE, 0,
7073 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7077 Perl_oopsAV(pTHX_ OP *o)
7081 PERL_ARGS_ASSERT_OOPSAV;
7083 switch (o->op_type) {
7085 o->op_type = OP_PADAV;
7086 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7087 return ref(o, OP_RV2AV);
7090 o->op_type = OP_RV2AV;
7091 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7096 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7103 Perl_oopsHV(pTHX_ OP *o)
7107 PERL_ARGS_ASSERT_OOPSHV;
7109 switch (o->op_type) {
7112 o->op_type = OP_PADHV;
7113 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7114 return ref(o, OP_RV2HV);
7118 o->op_type = OP_RV2HV;
7119 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7124 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7131 Perl_newAVREF(pTHX_ OP *o)
7135 PERL_ARGS_ASSERT_NEWAVREF;
7137 if (o->op_type == OP_PADANY) {
7138 o->op_type = OP_PADAV;
7139 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7142 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7143 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7144 "Using an array as a reference is deprecated");
7146 return newUNOP(OP_RV2AV, 0, scalar(o));
7150 Perl_newGVREF(pTHX_ I32 type, OP *o)
7152 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7153 return newUNOP(OP_NULL, 0, o);
7154 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7158 Perl_newHVREF(pTHX_ OP *o)
7162 PERL_ARGS_ASSERT_NEWHVREF;
7164 if (o->op_type == OP_PADANY) {
7165 o->op_type = OP_PADHV;
7166 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7169 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7170 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7171 "Using a hash as a reference is deprecated");
7173 return newUNOP(OP_RV2HV, 0, scalar(o));
7177 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7179 return newUNOP(OP_RV2CV, flags, scalar(o));
7183 Perl_newSVREF(pTHX_ OP *o)
7187 PERL_ARGS_ASSERT_NEWSVREF;
7189 if (o->op_type == OP_PADANY) {
7190 o->op_type = OP_PADSV;
7191 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7194 return newUNOP(OP_RV2SV, 0, scalar(o));
7197 /* Check routines. See the comments at the top of this file for details
7198 * on when these are called */
7201 Perl_ck_anoncode(pTHX_ OP *o)
7203 PERL_ARGS_ASSERT_CK_ANONCODE;
7205 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7207 cSVOPo->op_sv = NULL;
7212 Perl_ck_bitop(pTHX_ OP *o)
7216 PERL_ARGS_ASSERT_CK_BITOP;
7218 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7219 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7220 && (o->op_type == OP_BIT_OR
7221 || o->op_type == OP_BIT_AND
7222 || o->op_type == OP_BIT_XOR))
7224 const OP * const left = cBINOPo->op_first;
7225 const OP * const right = left->op_sibling;
7226 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7227 (left->op_flags & OPf_PARENS) == 0) ||
7228 (OP_IS_NUMCOMPARE(right->op_type) &&
7229 (right->op_flags & OPf_PARENS) == 0))
7230 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7231 "Possible precedence problem on bitwise %c operator",
7232 o->op_type == OP_BIT_OR ? '|'
7233 : o->op_type == OP_BIT_AND ? '&' : '^'
7240 Perl_ck_concat(pTHX_ OP *o)
7242 const OP * const kid = cUNOPo->op_first;
7244 PERL_ARGS_ASSERT_CK_CONCAT;
7245 PERL_UNUSED_CONTEXT;
7247 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7248 !(kUNOP->op_first->op_flags & OPf_MOD))
7249 o->op_flags |= OPf_STACKED;
7254 Perl_ck_spair(pTHX_ OP *o)
7258 PERL_ARGS_ASSERT_CK_SPAIR;
7260 if (o->op_flags & OPf_KIDS) {
7263 const OPCODE type = o->op_type;
7264 o = modkids(ck_fun(o), type);
7265 kid = cUNOPo->op_first;
7266 newop = kUNOP->op_first->op_sibling;
7268 const OPCODE type = newop->op_type;
7269 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7270 type == OP_PADAV || type == OP_PADHV ||
7271 type == OP_RV2AV || type == OP_RV2HV)
7275 op_getmad(kUNOP->op_first,newop,'K');
7277 op_free(kUNOP->op_first);
7279 kUNOP->op_first = newop;
7281 o->op_ppaddr = PL_ppaddr[++o->op_type];
7286 Perl_ck_delete(pTHX_ OP *o)
7288 PERL_ARGS_ASSERT_CK_DELETE;
7292 if (o->op_flags & OPf_KIDS) {
7293 OP * const kid = cUNOPo->op_first;
7294 switch (kid->op_type) {
7296 o->op_flags |= OPf_SPECIAL;
7299 o->op_private |= OPpSLICE;
7302 o->op_flags |= OPf_SPECIAL;
7307 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7310 if (kid->op_private & OPpLVAL_INTRO)
7311 o->op_private |= OPpLVAL_INTRO;
7318 Perl_ck_die(pTHX_ OP *o)
7320 PERL_ARGS_ASSERT_CK_DIE;
7323 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7329 Perl_ck_eof(pTHX_ OP *o)
7333 PERL_ARGS_ASSERT_CK_EOF;
7335 if (o->op_flags & OPf_KIDS) {
7336 if (cLISTOPo->op_first->op_type == OP_STUB) {
7338 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7340 op_getmad(o,newop,'O');
7352 Perl_ck_eval(pTHX_ OP *o)
7356 PERL_ARGS_ASSERT_CK_EVAL;
7358 PL_hints |= HINT_BLOCK_SCOPE;
7359 if (o->op_flags & OPf_KIDS) {
7360 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7363 o->op_flags &= ~OPf_KIDS;
7366 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7372 cUNOPo->op_first = 0;
7377 NewOp(1101, enter, 1, LOGOP);
7378 enter->op_type = OP_ENTERTRY;
7379 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7380 enter->op_private = 0;
7382 /* establish postfix order */
7383 enter->op_next = (OP*)enter;
7385 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7386 o->op_type = OP_LEAVETRY;
7387 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7388 enter->op_other = o;
7389 op_getmad(oldo,o,'O');
7403 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7404 op_getmad(oldo,o,'O');
7406 o->op_targ = (PADOFFSET)PL_hints;
7407 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7408 /* Store a copy of %^H that pp_entereval can pick up. */
7409 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7410 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7411 cUNOPo->op_first->op_sibling = hhop;
7412 o->op_private |= OPpEVAL_HAS_HH;
7418 Perl_ck_exit(pTHX_ OP *o)
7420 PERL_ARGS_ASSERT_CK_EXIT;
7423 HV * const table = GvHV(PL_hintgv);
7425 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7426 if (svp && *svp && SvTRUE(*svp))
7427 o->op_private |= OPpEXIT_VMSISH;
7429 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7435 Perl_ck_exec(pTHX_ OP *o)
7437 PERL_ARGS_ASSERT_CK_EXEC;
7439 if (o->op_flags & OPf_STACKED) {
7442 kid = cUNOPo->op_first->op_sibling;
7443 if (kid->op_type == OP_RV2GV)
7452 Perl_ck_exists(pTHX_ OP *o)
7456 PERL_ARGS_ASSERT_CK_EXISTS;
7459 if (o->op_flags & OPf_KIDS) {
7460 OP * const kid = cUNOPo->op_first;
7461 if (kid->op_type == OP_ENTERSUB) {
7462 (void) ref(kid, o->op_type);
7463 if (kid->op_type != OP_RV2CV
7464 && !(PL_parser && PL_parser->error_count))
7465 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7467 o->op_private |= OPpEXISTS_SUB;
7469 else if (kid->op_type == OP_AELEM)
7470 o->op_flags |= OPf_SPECIAL;
7471 else if (kid->op_type != OP_HELEM)
7472 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7480 Perl_ck_rvconst(pTHX_ register OP *o)
7483 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7485 PERL_ARGS_ASSERT_CK_RVCONST;
7487 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7488 if (o->op_type == OP_RV2CV)
7489 o->op_private &= ~1;
7491 if (kid->op_type == OP_CONST) {
7494 SV * const kidsv = kid->op_sv;
7496 /* Is it a constant from cv_const_sv()? */
7497 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7498 SV * const rsv = SvRV(kidsv);
7499 const svtype type = SvTYPE(rsv);
7500 const char *badtype = NULL;
7502 switch (o->op_type) {
7504 if (type > SVt_PVMG)
7505 badtype = "a SCALAR";
7508 if (type != SVt_PVAV)
7509 badtype = "an ARRAY";
7512 if (type != SVt_PVHV)
7516 if (type != SVt_PVCV)
7521 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7524 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7525 const char *badthing;
7526 switch (o->op_type) {
7528 badthing = "a SCALAR";
7531 badthing = "an ARRAY";
7534 badthing = "a HASH";
7542 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7543 SVfARG(kidsv), badthing);
7546 * This is a little tricky. We only want to add the symbol if we
7547 * didn't add it in the lexer. Otherwise we get duplicate strict
7548 * warnings. But if we didn't add it in the lexer, we must at
7549 * least pretend like we wanted to add it even if it existed before,
7550 * or we get possible typo warnings. OPpCONST_ENTERED says
7551 * whether the lexer already added THIS instance of this symbol.
7553 iscv = (o->op_type == OP_RV2CV) * 2;
7555 gv = gv_fetchsv(kidsv,
7556 iscv | !(kid->op_private & OPpCONST_ENTERED),
7559 : o->op_type == OP_RV2SV
7561 : o->op_type == OP_RV2AV
7563 : o->op_type == OP_RV2HV
7566 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7568 kid->op_type = OP_GV;
7569 SvREFCNT_dec(kid->op_sv);
7571 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7572 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7573 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7575 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7577 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7579 kid->op_private = 0;
7580 kid->op_ppaddr = PL_ppaddr[OP_GV];
7581 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7589 Perl_ck_ftst(pTHX_ OP *o)
7592 const I32 type = o->op_type;
7594 PERL_ARGS_ASSERT_CK_FTST;
7596 if (o->op_flags & OPf_REF) {
7599 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7600 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7601 const OPCODE kidtype = kid->op_type;
7603 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7604 OP * const newop = newGVOP(type, OPf_REF,
7605 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7607 op_getmad(o,newop,'O');
7613 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7614 o->op_private |= OPpFT_ACCESS;
7615 if (PL_check[kidtype] == Perl_ck_ftst
7616 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7617 o->op_private |= OPpFT_STACKED;
7618 kid->op_private |= OPpFT_STACKING;
7627 if (type == OP_FTTTY)
7628 o = newGVOP(type, OPf_REF, PL_stdingv);
7630 o = newUNOP(type, 0, newDEFSVOP());
7631 op_getmad(oldo,o,'O');
7637 Perl_ck_fun(pTHX_ OP *o)
7640 const int type = o->op_type;
7641 register I32 oa = PL_opargs[type] >> OASHIFT;
7643 PERL_ARGS_ASSERT_CK_FUN;
7645 if (o->op_flags & OPf_STACKED) {
7646 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7649 return no_fh_allowed(o);
7652 if (o->op_flags & OPf_KIDS) {
7653 OP **tokid = &cLISTOPo->op_first;
7654 register OP *kid = cLISTOPo->op_first;
7657 bool seen_optional = FALSE;
7659 if (kid->op_type == OP_PUSHMARK ||
7660 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7662 tokid = &kid->op_sibling;
7663 kid = kid->op_sibling;
7665 if (kid && kid->op_type == OP_COREARGS) {
7666 bool optional = FALSE;
7669 if (oa & OA_OPTIONAL) optional = TRUE;
7672 if (optional) o->op_private |= numargs;
7677 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
7678 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
7679 *tokid = kid = newDEFSVOP();
7680 seen_optional = TRUE;
7685 sibl = kid->op_sibling;
7687 if (!sibl && kid->op_type == OP_STUB) {
7694 /* list seen where single (scalar) arg expected? */
7695 if (numargs == 1 && !(oa >> 4)
7696 && kid->op_type == OP_LIST && type != OP_SCALAR)
7698 return too_many_arguments(o,PL_op_desc[type]);
7711 if ((type == OP_PUSH || type == OP_UNSHIFT)
7712 && !kid->op_sibling)
7713 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7714 "Useless use of %s with no values",
7717 if (kid->op_type == OP_CONST &&
7718 (kid->op_private & OPpCONST_BARE))
7720 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7721 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7722 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7723 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7724 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7726 op_getmad(kid,newop,'K');
7731 kid->op_sibling = sibl;
7734 else if (kid->op_type == OP_CONST
7735 && ( !SvROK(cSVOPx_sv(kid))
7736 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7738 bad_type(numargs, "array", PL_op_desc[type], kid);
7739 /* Defer checks to run-time if we have a scalar arg */
7740 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7741 op_lvalue(kid, type);
7745 if (kid->op_type == OP_CONST &&
7746 (kid->op_private & OPpCONST_BARE))
7748 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7749 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7750 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7751 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7752 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7754 op_getmad(kid,newop,'K');
7759 kid->op_sibling = sibl;
7762 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7763 bad_type(numargs, "hash", PL_op_desc[type], kid);
7764 op_lvalue(kid, type);
7768 OP * const newop = newUNOP(OP_NULL, 0, kid);
7769 kid->op_sibling = 0;
7771 newop->op_next = newop;
7773 kid->op_sibling = sibl;
7778 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7779 if (kid->op_type == OP_CONST &&
7780 (kid->op_private & OPpCONST_BARE))
7782 OP * const newop = newGVOP(OP_GV, 0,
7783 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7784 if (!(o->op_private & 1) && /* if not unop */
7785 kid == cLISTOPo->op_last)
7786 cLISTOPo->op_last = newop;
7788 op_getmad(kid,newop,'K');
7794 else if (kid->op_type == OP_READLINE) {
7795 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7796 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7799 I32 flags = OPf_SPECIAL;
7803 /* is this op a FH constructor? */
7804 if (is_handle_constructor(o,numargs)) {
7805 const char *name = NULL;
7809 /* Set a flag to tell rv2gv to vivify
7810 * need to "prove" flag does not mean something
7811 * else already - NI-S 1999/05/07
7814 if (kid->op_type == OP_PADSV) {
7816 = PAD_COMPNAME_SV(kid->op_targ);
7817 name = SvPV_const(namesv, len);
7819 else if (kid->op_type == OP_RV2SV
7820 && kUNOP->op_first->op_type == OP_GV)
7822 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7824 len = GvNAMELEN(gv);
7826 else if (kid->op_type == OP_AELEM
7827 || kid->op_type == OP_HELEM)
7830 OP *op = ((BINOP*)kid)->op_first;
7834 const char * const a =
7835 kid->op_type == OP_AELEM ?
7837 if (((op->op_type == OP_RV2AV) ||
7838 (op->op_type == OP_RV2HV)) &&
7839 (firstop = ((UNOP*)op)->op_first) &&
7840 (firstop->op_type == OP_GV)) {
7841 /* packagevar $a[] or $h{} */
7842 GV * const gv = cGVOPx_gv(firstop);
7850 else if (op->op_type == OP_PADAV
7851 || op->op_type == OP_PADHV) {
7852 /* lexicalvar $a[] or $h{} */
7853 const char * const padname =
7854 PAD_COMPNAME_PV(op->op_targ);
7863 name = SvPV_const(tmpstr, len);
7868 name = "__ANONIO__";
7871 op_lvalue(kid, type);
7875 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7876 namesv = PAD_SVl(targ);
7877 SvUPGRADE(namesv, SVt_PV);
7879 sv_setpvs(namesv, "$");
7880 sv_catpvn(namesv, name, len);
7883 kid->op_sibling = 0;
7884 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7885 kid->op_targ = targ;
7886 kid->op_private |= priv;
7888 kid->op_sibling = sibl;
7894 op_lvalue(scalar(kid), type);
7898 tokid = &kid->op_sibling;
7899 kid = kid->op_sibling;
7902 if (kid && kid->op_type != OP_STUB)
7903 return too_many_arguments(o,OP_DESC(o));
7904 o->op_private |= numargs;
7906 /* FIXME - should the numargs move as for the PERL_MAD case? */
7907 o->op_private |= numargs;
7909 return too_many_arguments(o,OP_DESC(o));
7913 else if (PL_opargs[type] & OA_DEFGV) {
7915 OP *newop = newUNOP(type, 0, newDEFSVOP());
7916 op_getmad(o,newop,'O');
7919 /* Ordering of these two is important to keep f_map.t passing. */
7921 return newUNOP(type, 0, newDEFSVOP());
7926 while (oa & OA_OPTIONAL)
7928 if (oa && oa != OA_LIST)
7929 return too_few_arguments(o,OP_DESC(o));
7935 Perl_ck_glob(pTHX_ OP *o)
7940 PERL_ARGS_ASSERT_CK_GLOB;
7943 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7944 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
7946 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7947 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7949 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7952 #if !defined(PERL_EXTERNAL_GLOB)
7953 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7956 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7957 newSVpvs("File::Glob"), NULL, NULL, NULL);
7958 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7959 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7960 GvCV_set(gv, GvCV(glob_gv));
7961 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7962 GvIMPORTED_CV_on(gv);
7966 #endif /* PERL_EXTERNAL_GLOB */
7968 assert(!(o->op_flags & OPf_SPECIAL));
7969 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7972 * \ null - const(wildcard)
7977 * \ mark - glob - rv2cv
7978 * | \ gv(CORE::GLOBAL::glob)
7980 * \ null - const(wildcard) - const(ix)
7982 o->op_flags |= OPf_SPECIAL;
7983 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
7984 op_append_elem(OP_GLOB, o,
7985 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7986 o = newLISTOP(OP_LIST, 0, o, NULL);
7987 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7988 op_append_elem(OP_LIST, o,
7989 scalar(newUNOP(OP_RV2CV, 0,
7990 newGVOP(OP_GV, 0, gv)))));
7991 o = newUNOP(OP_NULL, 0, ck_subr(o));
7992 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
7995 gv = newGVgen("main");
7997 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8003 Perl_ck_grep(pTHX_ OP *o)
8008 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8011 PERL_ARGS_ASSERT_CK_GREP;
8013 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8014 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8016 if (o->op_flags & OPf_STACKED) {
8019 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8020 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8021 return no_fh_allowed(o);
8022 for (k = kid; k; k = k->op_next) {
8025 NewOp(1101, gwop, 1, LOGOP);
8026 kid->op_next = (OP*)gwop;
8027 o->op_flags &= ~OPf_STACKED;
8029 kid = cLISTOPo->op_first->op_sibling;
8030 if (type == OP_MAPWHILE)
8035 if (PL_parser && PL_parser->error_count)
8037 kid = cLISTOPo->op_first->op_sibling;
8038 if (kid->op_type != OP_NULL)
8039 Perl_croak(aTHX_ "panic: ck_grep");
8040 kid = kUNOP->op_first;
8043 NewOp(1101, gwop, 1, LOGOP);
8044 gwop->op_type = type;
8045 gwop->op_ppaddr = PL_ppaddr[type];
8046 gwop->op_first = listkids(o);
8047 gwop->op_flags |= OPf_KIDS;
8048 gwop->op_other = LINKLIST(kid);
8049 kid->op_next = (OP*)gwop;
8050 offset = pad_findmy_pvs("$_", 0);
8051 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8052 o->op_private = gwop->op_private = 0;
8053 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8056 o->op_private = gwop->op_private = OPpGREP_LEX;
8057 gwop->op_targ = o->op_targ = offset;
8060 kid = cLISTOPo->op_first->op_sibling;
8061 if (!kid || !kid->op_sibling)
8062 return too_few_arguments(o,OP_DESC(o));
8063 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8064 op_lvalue(kid, OP_GREPSTART);
8070 Perl_ck_index(pTHX_ OP *o)
8072 PERL_ARGS_ASSERT_CK_INDEX;
8074 if (o->op_flags & OPf_KIDS) {
8075 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8077 kid = kid->op_sibling; /* get past "big" */
8078 if (kid && kid->op_type == OP_CONST) {
8079 const bool save_taint = PL_tainted;
8080 fbm_compile(((SVOP*)kid)->op_sv, 0);
8081 PL_tainted = save_taint;
8088 Perl_ck_lfun(pTHX_ OP *o)
8090 const OPCODE type = o->op_type;
8092 PERL_ARGS_ASSERT_CK_LFUN;
8094 return modkids(ck_fun(o), type);
8098 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8100 PERL_ARGS_ASSERT_CK_DEFINED;
8102 if ((o->op_flags & OPf_KIDS)) {
8103 switch (cUNOPo->op_first->op_type) {
8105 /* This is needed for
8106 if (defined %stash::)
8107 to work. Do not break Tk.
8109 break; /* Globals via GV can be undef */
8111 case OP_AASSIGN: /* Is this a good idea? */
8112 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8113 "defined(@array) is deprecated");
8114 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8115 "\t(Maybe you should just omit the defined()?)\n");
8119 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8120 "defined(%%hash) is deprecated");
8121 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8122 "\t(Maybe you should just omit the defined()?)\n");
8133 Perl_ck_readline(pTHX_ OP *o)
8135 PERL_ARGS_ASSERT_CK_READLINE;
8137 if (!(o->op_flags & OPf_KIDS)) {
8139 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8141 op_getmad(o,newop,'O');
8151 Perl_ck_rfun(pTHX_ OP *o)
8153 const OPCODE type = o->op_type;
8155 PERL_ARGS_ASSERT_CK_RFUN;
8157 return refkids(ck_fun(o), type);
8161 Perl_ck_listiob(pTHX_ OP *o)
8165 PERL_ARGS_ASSERT_CK_LISTIOB;
8167 kid = cLISTOPo->op_first;
8170 kid = cLISTOPo->op_first;
8172 if (kid->op_type == OP_PUSHMARK)
8173 kid = kid->op_sibling;
8174 if (kid && o->op_flags & OPf_STACKED)
8175 kid = kid->op_sibling;
8176 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8177 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8178 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8179 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8180 cLISTOPo->op_first->op_sibling = kid;
8181 cLISTOPo->op_last = kid;
8182 kid = kid->op_sibling;
8187 op_append_elem(o->op_type, o, newDEFSVOP());
8193 Perl_ck_smartmatch(pTHX_ OP *o)
8196 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8197 if (0 == (o->op_flags & OPf_SPECIAL)) {
8198 OP *first = cBINOPo->op_first;
8199 OP *second = first->op_sibling;
8201 /* Implicitly take a reference to an array or hash */
8202 first->op_sibling = NULL;
8203 first = cBINOPo->op_first = ref_array_or_hash(first);
8204 second = first->op_sibling = ref_array_or_hash(second);
8206 /* Implicitly take a reference to a regular expression */
8207 if (first->op_type == OP_MATCH) {
8208 first->op_type = OP_QR;
8209 first->op_ppaddr = PL_ppaddr[OP_QR];
8211 if (second->op_type == OP_MATCH) {
8212 second->op_type = OP_QR;
8213 second->op_ppaddr = PL_ppaddr[OP_QR];
8222 Perl_ck_sassign(pTHX_ OP *o)
8225 OP * const kid = cLISTOPo->op_first;
8227 PERL_ARGS_ASSERT_CK_SASSIGN;
8229 /* has a disposable target? */
8230 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8231 && !(kid->op_flags & OPf_STACKED)
8232 /* Cannot steal the second time! */
8233 && !(kid->op_private & OPpTARGET_MY)
8234 /* Keep the full thing for madskills */
8238 OP * const kkid = kid->op_sibling;
8240 /* Can just relocate the target. */
8241 if (kkid && kkid->op_type == OP_PADSV
8242 && !(kkid->op_private & OPpLVAL_INTRO))
8244 kid->op_targ = kkid->op_targ;
8246 /* Now we do not need PADSV and SASSIGN. */
8247 kid->op_sibling = o->op_sibling; /* NULL */
8248 cLISTOPo->op_first = NULL;
8251 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8255 if (kid->op_sibling) {
8256 OP *kkid = kid->op_sibling;
8257 /* For state variable assignment, kkid is a list op whose op_last
8259 if ((kkid->op_type == OP_PADSV ||
8260 (kkid->op_type == OP_LIST &&
8261 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8264 && (kkid->op_private & OPpLVAL_INTRO)
8265 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8266 const PADOFFSET target = kkid->op_targ;
8267 OP *const other = newOP(OP_PADSV,
8269 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8270 OP *const first = newOP(OP_NULL, 0);
8271 OP *const nullop = newCONDOP(0, first, o, other);
8272 OP *const condop = first->op_next;
8273 /* hijacking PADSTALE for uninitialized state variables */
8274 SvPADSTALE_on(PAD_SVl(target));
8276 condop->op_type = OP_ONCE;
8277 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8278 condop->op_targ = target;
8279 other->op_targ = target;
8281 /* Because we change the type of the op here, we will skip the
8282 assignment binop->op_last = binop->op_first->op_sibling; at the
8283 end of Perl_newBINOP(). So need to do it here. */
8284 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8293 Perl_ck_match(pTHX_ OP *o)
8297 PERL_ARGS_ASSERT_CK_MATCH;
8299 if (o->op_type != OP_QR && PL_compcv) {
8300 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8301 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8302 o->op_targ = offset;
8303 o->op_private |= OPpTARGET_MY;
8306 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8307 o->op_private |= OPpRUNTIME;
8312 Perl_ck_method(pTHX_ OP *o)
8314 OP * const kid = cUNOPo->op_first;
8316 PERL_ARGS_ASSERT_CK_METHOD;
8318 if (kid->op_type == OP_CONST) {
8319 SV* sv = kSVOP->op_sv;
8320 const char * const method = SvPVX_const(sv);
8321 if (!(strchr(method, ':') || strchr(method, '\''))) {
8323 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8324 sv = newSVpvn_share(method, SvCUR(sv), 0);
8327 kSVOP->op_sv = NULL;
8329 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8331 op_getmad(o,cmop,'O');
8342 Perl_ck_null(pTHX_ OP *o)
8344 PERL_ARGS_ASSERT_CK_NULL;
8345 PERL_UNUSED_CONTEXT;
8350 Perl_ck_open(pTHX_ OP *o)
8353 HV * const table = GvHV(PL_hintgv);
8355 PERL_ARGS_ASSERT_CK_OPEN;
8358 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8361 const char *d = SvPV_const(*svp, len);
8362 const I32 mode = mode_from_discipline(d, len);
8363 if (mode & O_BINARY)
8364 o->op_private |= OPpOPEN_IN_RAW;
8365 else if (mode & O_TEXT)
8366 o->op_private |= OPpOPEN_IN_CRLF;
8369 svp = hv_fetchs(table, "open_OUT", FALSE);
8372 const char *d = SvPV_const(*svp, len);
8373 const I32 mode = mode_from_discipline(d, len);
8374 if (mode & O_BINARY)
8375 o->op_private |= OPpOPEN_OUT_RAW;
8376 else if (mode & O_TEXT)
8377 o->op_private |= OPpOPEN_OUT_CRLF;
8380 if (o->op_type == OP_BACKTICK) {
8381 if (!(o->op_flags & OPf_KIDS)) {
8382 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8384 op_getmad(o,newop,'O');
8393 /* In case of three-arg dup open remove strictness
8394 * from the last arg if it is a bareword. */
8395 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8396 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8400 if ((last->op_type == OP_CONST) && /* The bareword. */
8401 (last->op_private & OPpCONST_BARE) &&
8402 (last->op_private & OPpCONST_STRICT) &&
8403 (oa = first->op_sibling) && /* The fh. */
8404 (oa = oa->op_sibling) && /* The mode. */
8405 (oa->op_type == OP_CONST) &&
8406 SvPOK(((SVOP*)oa)->op_sv) &&
8407 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8408 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8409 (last == oa->op_sibling)) /* The bareword. */
8410 last->op_private &= ~OPpCONST_STRICT;
8416 Perl_ck_repeat(pTHX_ OP *o)
8418 PERL_ARGS_ASSERT_CK_REPEAT;
8420 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8421 o->op_private |= OPpREPEAT_DOLIST;
8422 cBINOPo->op_first = force_list(cBINOPo->op_first);
8430 Perl_ck_require(pTHX_ OP *o)
8435 PERL_ARGS_ASSERT_CK_REQUIRE;
8437 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8438 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8440 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8441 SV * const sv = kid->op_sv;
8442 U32 was_readonly = SvREADONLY(sv);
8449 sv_force_normal_flags(sv, 0);
8450 assert(!SvREADONLY(sv));
8460 for (; s < end; s++) {
8461 if (*s == ':' && s[1] == ':') {
8463 Move(s+2, s+1, end - s - 1, char);
8468 sv_catpvs(sv, ".pm");
8469 SvFLAGS(sv) |= was_readonly;
8473 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8474 /* handle override, if any */
8475 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8476 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8477 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8478 gv = gvp ? *gvp : NULL;
8482 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8483 OP * const kid = cUNOPo->op_first;
8486 cUNOPo->op_first = 0;
8490 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8491 op_append_elem(OP_LIST, kid,
8492 scalar(newUNOP(OP_RV2CV, 0,
8495 op_getmad(o,newop,'O');
8499 return scalar(ck_fun(o));
8503 Perl_ck_return(pTHX_ OP *o)
8508 PERL_ARGS_ASSERT_CK_RETURN;
8510 kid = cLISTOPo->op_first->op_sibling;
8511 if (CvLVALUE(PL_compcv)) {
8512 for (; kid; kid = kid->op_sibling)
8513 op_lvalue(kid, OP_LEAVESUBLV);
8520 Perl_ck_select(pTHX_ OP *o)
8525 PERL_ARGS_ASSERT_CK_SELECT;
8527 if (o->op_flags & OPf_KIDS) {
8528 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8529 if (kid && kid->op_sibling) {
8530 o->op_type = OP_SSELECT;
8531 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8533 return fold_constants(op_integerize(op_std_init(o)));
8537 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8538 if (kid && kid->op_type == OP_RV2GV)
8539 kid->op_private &= ~HINT_STRICT_REFS;
8544 Perl_ck_shift(pTHX_ OP *o)
8547 const I32 type = o->op_type;
8549 PERL_ARGS_ASSERT_CK_SHIFT;
8551 if (!(o->op_flags & OPf_KIDS)) {
8554 if (!CvUNIQUE(PL_compcv)) {
8555 o->op_flags |= OPf_SPECIAL;
8559 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8562 OP * const oldo = o;
8563 o = newUNOP(type, 0, scalar(argop));
8564 op_getmad(oldo,o,'O');
8569 return newUNOP(type, 0, scalar(argop));
8572 return scalar(ck_fun(o));
8576 Perl_ck_sort(pTHX_ OP *o)
8581 PERL_ARGS_ASSERT_CK_SORT;
8583 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8584 HV * const hinthv = GvHV(PL_hintgv);
8586 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8588 const I32 sorthints = (I32)SvIV(*svp);
8589 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8590 o->op_private |= OPpSORT_QSORT;
8591 if ((sorthints & HINT_SORT_STABLE) != 0)
8592 o->op_private |= OPpSORT_STABLE;
8597 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8599 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8600 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8602 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8604 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8606 if (kid->op_type == OP_SCOPE) {
8610 else if (kid->op_type == OP_LEAVE) {
8611 if (o->op_type == OP_SORT) {
8612 op_null(kid); /* wipe out leave */
8615 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8616 if (k->op_next == kid)
8618 /* don't descend into loops */
8619 else if (k->op_type == OP_ENTERLOOP
8620 || k->op_type == OP_ENTERITER)
8622 k = cLOOPx(k)->op_lastop;
8627 kid->op_next = 0; /* just disconnect the leave */
8628 k = kLISTOP->op_first;
8633 if (o->op_type == OP_SORT) {
8634 /* provide scalar context for comparison function/block */
8640 o->op_flags |= OPf_SPECIAL;
8642 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8645 firstkid = firstkid->op_sibling;
8648 /* provide list context for arguments */
8649 if (o->op_type == OP_SORT)
8656 S_simplify_sort(pTHX_ OP *o)
8659 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8665 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8667 if (!(o->op_flags & OPf_STACKED))
8669 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8670 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8671 kid = kUNOP->op_first; /* get past null */
8672 if (kid->op_type != OP_SCOPE)
8674 kid = kLISTOP->op_last; /* get past scope */
8675 switch(kid->op_type) {
8683 k = kid; /* remember this node*/
8684 if (kBINOP->op_first->op_type != OP_RV2SV)
8686 kid = kBINOP->op_first; /* get past cmp */
8687 if (kUNOP->op_first->op_type != OP_GV)
8689 kid = kUNOP->op_first; /* get past rv2sv */
8691 if (GvSTASH(gv) != PL_curstash)
8693 gvname = GvNAME(gv);
8694 if (*gvname == 'a' && gvname[1] == '\0')
8696 else if (*gvname == 'b' && gvname[1] == '\0')
8701 kid = k; /* back to cmp */
8702 if (kBINOP->op_last->op_type != OP_RV2SV)
8704 kid = kBINOP->op_last; /* down to 2nd arg */
8705 if (kUNOP->op_first->op_type != OP_GV)
8707 kid = kUNOP->op_first; /* get past rv2sv */
8709 if (GvSTASH(gv) != PL_curstash)
8711 gvname = GvNAME(gv);
8713 ? !(*gvname == 'a' && gvname[1] == '\0')
8714 : !(*gvname == 'b' && gvname[1] == '\0'))
8716 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8718 o->op_private |= OPpSORT_DESCEND;
8719 if (k->op_type == OP_NCMP)
8720 o->op_private |= OPpSORT_NUMERIC;
8721 if (k->op_type == OP_I_NCMP)
8722 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8723 kid = cLISTOPo->op_first->op_sibling;
8724 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8726 op_getmad(kid,o,'S'); /* then delete it */
8728 op_free(kid); /* then delete it */
8733 Perl_ck_split(pTHX_ OP *o)
8738 PERL_ARGS_ASSERT_CK_SPLIT;
8740 if (o->op_flags & OPf_STACKED)
8741 return no_fh_allowed(o);
8743 kid = cLISTOPo->op_first;
8744 if (kid->op_type != OP_NULL)
8745 Perl_croak(aTHX_ "panic: ck_split");
8746 kid = kid->op_sibling;
8747 op_free(cLISTOPo->op_first);
8749 cLISTOPo->op_first = kid;
8751 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8752 cLISTOPo->op_last = kid; /* There was only one element previously */
8755 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8756 OP * const sibl = kid->op_sibling;
8757 kid->op_sibling = 0;
8758 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8759 if (cLISTOPo->op_first == cLISTOPo->op_last)
8760 cLISTOPo->op_last = kid;
8761 cLISTOPo->op_first = kid;
8762 kid->op_sibling = sibl;
8765 kid->op_type = OP_PUSHRE;
8766 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8768 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8769 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8770 "Use of /g modifier is meaningless in split");
8773 if (!kid->op_sibling)
8774 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8776 kid = kid->op_sibling;
8779 if (!kid->op_sibling)
8780 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8781 assert(kid->op_sibling);
8783 kid = kid->op_sibling;
8786 if (kid->op_sibling)
8787 return too_many_arguments(o,OP_DESC(o));
8793 Perl_ck_join(pTHX_ OP *o)
8795 const OP * const kid = cLISTOPo->op_first->op_sibling;
8797 PERL_ARGS_ASSERT_CK_JOIN;
8799 if (kid && kid->op_type == OP_MATCH) {
8800 if (ckWARN(WARN_SYNTAX)) {
8801 const REGEXP *re = PM_GETRE(kPMOP);
8802 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8803 const STRLEN len = re ? RX_PRELEN(re) : 6;
8804 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8805 "/%.*s/ should probably be written as \"%.*s\"",
8806 (int)len, pmstr, (int)len, pmstr);
8813 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8815 Examines an op, which is expected to identify a subroutine at runtime,
8816 and attempts to determine at compile time which subroutine it identifies.
8817 This is normally used during Perl compilation to determine whether
8818 a prototype can be applied to a function call. I<cvop> is the op
8819 being considered, normally an C<rv2cv> op. A pointer to the identified
8820 subroutine is returned, if it could be determined statically, and a null
8821 pointer is returned if it was not possible to determine statically.
8823 Currently, the subroutine can be identified statically if the RV that the
8824 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8825 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8826 suitable if the constant value must be an RV pointing to a CV. Details of
8827 this process may change in future versions of Perl. If the C<rv2cv> op
8828 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8829 the subroutine statically: this flag is used to suppress compile-time
8830 magic on a subroutine call, forcing it to use default runtime behaviour.
8832 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8833 of a GV reference is modified. If a GV was examined and its CV slot was
8834 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8835 If the op is not optimised away, and the CV slot is later populated with
8836 a subroutine having a prototype, that flag eventually triggers the warning
8837 "called too early to check prototype".
8839 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8840 of returning a pointer to the subroutine it returns a pointer to the
8841 GV giving the most appropriate name for the subroutine in this context.
8842 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8843 (C<CvANON>) subroutine that is referenced through a GV it will be the
8844 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8845 A null pointer is returned as usual if there is no statically-determinable
8852 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8857 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8858 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8859 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8860 if (cvop->op_type != OP_RV2CV)
8862 if (cvop->op_private & OPpENTERSUB_AMPER)
8864 if (!(cvop->op_flags & OPf_KIDS))
8866 rvop = cUNOPx(cvop)->op_first;
8867 switch (rvop->op_type) {
8869 gv = cGVOPx_gv(rvop);
8872 if (flags & RV2CVOPCV_MARK_EARLY)
8873 rvop->op_private |= OPpEARLY_CV;
8878 SV *rv = cSVOPx_sv(rvop);
8888 if (SvTYPE((SV*)cv) != SVt_PVCV)
8890 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8891 if (!CvANON(cv) || !gv)
8900 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8902 Performs the default fixup of the arguments part of an C<entersub>
8903 op tree. This consists of applying list context to each of the
8904 argument ops. This is the standard treatment used on a call marked
8905 with C<&>, or a method call, or a call through a subroutine reference,
8906 or any other call where the callee can't be identified at compile time,
8907 or a call where the callee has no prototype.
8913 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8916 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8917 aop = cUNOPx(entersubop)->op_first;
8918 if (!aop->op_sibling)
8919 aop = cUNOPx(aop)->op_first;
8920 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8921 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8923 op_lvalue(aop, OP_ENTERSUB);
8930 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8932 Performs the fixup of the arguments part of an C<entersub> op tree
8933 based on a subroutine prototype. This makes various modifications to
8934 the argument ops, from applying context up to inserting C<refgen> ops,
8935 and checking the number and syntactic types of arguments, as directed by
8936 the prototype. This is the standard treatment used on a subroutine call,
8937 not marked with C<&>, where the callee can be identified at compile time
8938 and has a prototype.
8940 I<protosv> supplies the subroutine prototype to be applied to the call.
8941 It may be a normal defined scalar, of which the string value will be used.
8942 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8943 that has been cast to C<SV*>) which has a prototype. The prototype
8944 supplied, in whichever form, does not need to match the actual callee
8945 referenced by the op tree.
8947 If the argument ops disagree with the prototype, for example by having
8948 an unacceptable number of arguments, a valid op tree is returned anyway.
8949 The error is reflected in the parser state, normally resulting in a single
8950 exception at the top level of parsing which covers all the compilation
8951 errors that occurred. In the error message, the callee is referred to
8952 by the name defined by the I<namegv> parameter.
8958 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8961 const char *proto, *proto_end;
8962 OP *aop, *prev, *cvop;
8965 I32 contextclass = 0;
8966 const char *e = NULL;
8967 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8968 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8969 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8970 proto = SvPV(protosv, proto_len);
8971 proto_end = proto + proto_len;
8972 aop = cUNOPx(entersubop)->op_first;
8973 if (!aop->op_sibling)
8974 aop = cUNOPx(aop)->op_first;
8976 aop = aop->op_sibling;
8977 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8978 while (aop != cvop) {
8980 if (PL_madskills && aop->op_type == OP_STUB) {
8981 aop = aop->op_sibling;
8984 if (PL_madskills && aop->op_type == OP_NULL)
8985 o3 = ((UNOP*)aop)->op_first;
8989 if (proto >= proto_end)
8990 return too_many_arguments(entersubop, gv_ename(namegv));
8998 /* _ must be at the end */
8999 if (proto[1] && proto[1] != ';')
9014 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9016 arg == 1 ? "block or sub {}" : "sub {}",
9017 gv_ename(namegv), o3);
9020 /* '*' allows any scalar type, including bareword */
9023 if (o3->op_type == OP_RV2GV)
9024 goto wrapref; /* autoconvert GLOB -> GLOBref */
9025 else if (o3->op_type == OP_CONST)
9026 o3->op_private &= ~OPpCONST_STRICT;
9027 else if (o3->op_type == OP_ENTERSUB) {
9028 /* accidental subroutine, revert to bareword */
9029 OP *gvop = ((UNOP*)o3)->op_first;
9030 if (gvop && gvop->op_type == OP_NULL) {
9031 gvop = ((UNOP*)gvop)->op_first;
9033 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9036 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9037 (gvop = ((UNOP*)gvop)->op_first) &&
9038 gvop->op_type == OP_GV)
9040 GV * const gv = cGVOPx_gv(gvop);
9041 OP * const sibling = aop->op_sibling;
9042 SV * const n = newSVpvs("");
9044 OP * const oldaop = aop;
9048 gv_fullname4(n, gv, "", FALSE);
9049 aop = newSVOP(OP_CONST, 0, n);
9050 op_getmad(oldaop,aop,'O');
9051 prev->op_sibling = aop;
9052 aop->op_sibling = sibling;
9062 if (o3->op_type == OP_RV2AV ||
9063 o3->op_type == OP_PADAV ||
9064 o3->op_type == OP_RV2HV ||
9065 o3->op_type == OP_PADHV
9080 if (contextclass++ == 0) {
9081 e = strchr(proto, ']');
9082 if (!e || e == proto)
9091 const char *p = proto;
9092 const char *const end = proto;
9095 /* \[$] accepts any scalar lvalue */
9097 && Perl_op_lvalue_flags(aTHX_
9099 OP_READ, /* not entersub */
9102 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
9104 gv_ename(namegv), o3);
9109 if (o3->op_type == OP_RV2GV)
9112 bad_type(arg, "symbol", gv_ename(namegv), o3);
9115 if (o3->op_type == OP_ENTERSUB)
9118 bad_type(arg, "subroutine entry", gv_ename(namegv),
9122 if (o3->op_type == OP_RV2SV ||
9123 o3->op_type == OP_PADSV ||
9124 o3->op_type == OP_HELEM ||
9125 o3->op_type == OP_AELEM)
9127 if (!contextclass) {
9128 /* \$ accepts any scalar lvalue */
9129 if (Perl_op_lvalue_flags(aTHX_
9131 OP_READ, /* not entersub */
9134 bad_type(arg, "scalar", gv_ename(namegv), o3);
9138 if (o3->op_type == OP_RV2AV ||
9139 o3->op_type == OP_PADAV)
9142 bad_type(arg, "array", gv_ename(namegv), o3);
9145 if (o3->op_type == OP_RV2HV ||
9146 o3->op_type == OP_PADHV)
9149 bad_type(arg, "hash", gv_ename(namegv), o3);
9153 OP* const kid = aop;
9154 OP* const sib = kid->op_sibling;
9155 kid->op_sibling = 0;
9156 aop = newUNOP(OP_REFGEN, 0, kid);
9157 aop->op_sibling = sib;
9158 prev->op_sibling = aop;
9160 if (contextclass && e) {
9175 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
9176 gv_ename(namegv), SVfARG(protosv));
9179 op_lvalue(aop, OP_ENTERSUB);
9181 aop = aop->op_sibling;
9183 if (aop == cvop && *proto == '_') {
9184 /* generate an access to $_ */
9186 aop->op_sibling = prev->op_sibling;
9187 prev->op_sibling = aop; /* instead of cvop */
9189 if (!optional && proto_end > proto &&
9190 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9191 return too_few_arguments(entersubop, gv_ename(namegv));
9196 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9198 Performs the fixup of the arguments part of an C<entersub> op tree either
9199 based on a subroutine prototype or using default list-context processing.
9200 This is the standard treatment used on a subroutine call, not marked
9201 with C<&>, where the callee can be identified at compile time.
9203 I<protosv> supplies the subroutine prototype to be applied to the call,
9204 or indicates that there is no prototype. It may be a normal scalar,
9205 in which case if it is defined then the string value will be used
9206 as a prototype, and if it is undefined then there is no prototype.
9207 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9208 that has been cast to C<SV*>), of which the prototype will be used if it
9209 has one. The prototype (or lack thereof) supplied, in whichever form,
9210 does not need to match the actual callee referenced by the op tree.
9212 If the argument ops disagree with the prototype, for example by having
9213 an unacceptable number of arguments, a valid op tree is returned anyway.
9214 The error is reflected in the parser state, normally resulting in a single
9215 exception at the top level of parsing which covers all the compilation
9216 errors that occurred. In the error message, the callee is referred to
9217 by the name defined by the I<namegv> parameter.
9223 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9224 GV *namegv, SV *protosv)
9226 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9227 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9228 return ck_entersub_args_proto(entersubop, namegv, protosv);
9230 return ck_entersub_args_list(entersubop);
9234 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9236 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9237 OP *aop = cUNOPx(entersubop)->op_first;
9239 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9243 if (!aop->op_sibling)
9244 aop = cUNOPx(aop)->op_first;
9245 aop = aop->op_sibling;
9246 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9247 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9248 aop = aop->op_sibling;
9252 (void)too_many_arguments(entersubop, GvNAME(namegv));
9254 op_free(entersubop);
9255 switch(GvNAME(namegv)[2]) {
9256 case 'F': return newSVOP(OP_CONST, 0,
9257 newSVpv(CopFILE(PL_curcop),0));
9258 case 'L': return newSVOP(
9261 "%"IVdf, (IV)CopLINE(PL_curcop)
9264 case 'P': return newSVOP(OP_CONST, 0,
9266 ? newSVhek(HvNAME_HEK(PL_curstash))
9277 bool seenarg = FALSE;
9279 if (!aop->op_sibling)
9280 aop = cUNOPx(aop)->op_first;
9283 aop = aop->op_sibling;
9284 prev->op_sibling = NULL;
9287 prev=cvop, cvop = cvop->op_sibling)
9289 if (PL_madskills && cvop->op_sibling
9290 && cvop->op_type != OP_STUB) seenarg = TRUE
9293 prev->op_sibling = NULL;
9294 paren = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9296 if (aop == cvop) aop = NULL;
9297 op_free(entersubop);
9299 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9301 case OA_BASEOP_OR_UNOP:
9303 return aop ? newUNOP(opnum,paren,aop) : newOP(opnum,paren);
9307 if (!PL_madskills || seenarg)
9309 (void)too_many_arguments(aop, GvNAME(namegv));
9312 return newOP(opnum,0);
9314 return convert(opnum,0,aop);
9322 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9324 Retrieves the function that will be used to fix up a call to I<cv>.
9325 Specifically, the function is applied to an C<entersub> op tree for a
9326 subroutine call, not marked with C<&>, where the callee can be identified
9327 at compile time as I<cv>.
9329 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9330 argument for it is returned in I<*ckobj_p>. The function is intended
9331 to be called in this manner:
9333 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9335 In this call, I<entersubop> is a pointer to the C<entersub> op,
9336 which may be replaced by the check function, and I<namegv> is a GV
9337 supplying the name that should be used by the check function to refer
9338 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9339 It is permitted to apply the check function in non-standard situations,
9340 such as to a call to a different subroutine or to a method call.
9342 By default, the function is
9343 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9344 and the SV parameter is I<cv> itself. This implements standard
9345 prototype processing. It can be changed, for a particular subroutine,
9346 by L</cv_set_call_checker>.
9352 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9355 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9356 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9358 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9359 *ckobj_p = callmg->mg_obj;
9361 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9367 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9369 Sets the function that will be used to fix up a call to I<cv>.
9370 Specifically, the function is applied to an C<entersub> op tree for a
9371 subroutine call, not marked with C<&>, where the callee can be identified
9372 at compile time as I<cv>.
9374 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9375 for it is supplied in I<ckobj>. The function is intended to be called
9378 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9380 In this call, I<entersubop> is a pointer to the C<entersub> op,
9381 which may be replaced by the check function, and I<namegv> is a GV
9382 supplying the name that should be used by the check function to refer
9383 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9384 It is permitted to apply the check function in non-standard situations,
9385 such as to a call to a different subroutine or to a method call.
9387 The current setting for a particular CV can be retrieved by
9388 L</cv_get_call_checker>.
9394 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9396 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9397 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9398 if (SvMAGICAL((SV*)cv))
9399 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9402 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9403 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9404 if (callmg->mg_flags & MGf_REFCOUNTED) {
9405 SvREFCNT_dec(callmg->mg_obj);
9406 callmg->mg_flags &= ~MGf_REFCOUNTED;
9408 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9409 callmg->mg_obj = ckobj;
9410 if (ckobj != (SV*)cv) {
9411 SvREFCNT_inc_simple_void_NN(ckobj);
9412 callmg->mg_flags |= MGf_REFCOUNTED;
9418 Perl_ck_subr(pTHX_ OP *o)
9424 PERL_ARGS_ASSERT_CK_SUBR;
9426 aop = cUNOPx(o)->op_first;
9427 if (!aop->op_sibling)
9428 aop = cUNOPx(aop)->op_first;
9429 aop = aop->op_sibling;
9430 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9431 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9432 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9434 o->op_private &= ~1;
9435 o->op_private |= OPpENTERSUB_HASTARG;
9436 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9437 if (PERLDB_SUB && PL_curstash != PL_debstash)
9438 o->op_private |= OPpENTERSUB_DB;
9439 if (cvop->op_type == OP_RV2CV) {
9440 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9442 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9443 if (aop->op_type == OP_CONST)
9444 aop->op_private &= ~OPpCONST_STRICT;
9445 else if (aop->op_type == OP_LIST) {
9446 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9447 if (sib && sib->op_type == OP_CONST)
9448 sib->op_private &= ~OPpCONST_STRICT;
9453 return ck_entersub_args_list(o);
9455 Perl_call_checker ckfun;
9457 cv_get_call_checker(cv, &ckfun, &ckobj);
9458 return ckfun(aTHX_ o, namegv, ckobj);
9463 Perl_ck_svconst(pTHX_ OP *o)
9465 PERL_ARGS_ASSERT_CK_SVCONST;
9466 PERL_UNUSED_CONTEXT;
9467 SvREADONLY_on(cSVOPo->op_sv);
9472 Perl_ck_chdir(pTHX_ OP *o)
9474 PERL_ARGS_ASSERT_CK_CHDIR;
9475 if (o->op_flags & OPf_KIDS) {
9476 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9478 if (kid && kid->op_type == OP_CONST &&
9479 (kid->op_private & OPpCONST_BARE))
9481 o->op_flags |= OPf_SPECIAL;
9482 kid->op_private &= ~OPpCONST_STRICT;
9489 Perl_ck_trunc(pTHX_ OP *o)
9491 PERL_ARGS_ASSERT_CK_TRUNC;
9493 if (o->op_flags & OPf_KIDS) {
9494 SVOP *kid = (SVOP*)cUNOPo->op_first;
9496 if (kid->op_type == OP_NULL)
9497 kid = (SVOP*)kid->op_sibling;
9498 if (kid && kid->op_type == OP_CONST &&
9499 (kid->op_private & OPpCONST_BARE))
9501 o->op_flags |= OPf_SPECIAL;
9502 kid->op_private &= ~OPpCONST_STRICT;
9509 Perl_ck_substr(pTHX_ OP *o)
9511 PERL_ARGS_ASSERT_CK_SUBSTR;
9514 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9515 OP *kid = cLISTOPo->op_first;
9517 if (kid->op_type == OP_NULL)
9518 kid = kid->op_sibling;
9520 kid->op_flags |= OPf_MOD;
9527 Perl_ck_each(pTHX_ OP *o)
9530 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9531 const unsigned orig_type = o->op_type;
9532 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9533 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9534 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9535 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9537 PERL_ARGS_ASSERT_CK_EACH;
9540 switch (kid->op_type) {
9546 CHANGE_TYPE(o, array_type);
9549 if (kid->op_private == OPpCONST_BARE
9550 || !SvROK(cSVOPx_sv(kid))
9551 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9552 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9554 /* we let ck_fun handle it */
9557 CHANGE_TYPE(o, ref_type);
9561 /* if treating as a reference, defer additional checks to runtime */
9562 return o->op_type == ref_type ? o : ck_fun(o);
9565 /* caller is supposed to assign the return to the
9566 container of the rep_op var */
9568 S_opt_scalarhv(pTHX_ OP *rep_op) {
9572 PERL_ARGS_ASSERT_OPT_SCALARHV;
9574 NewOp(1101, unop, 1, UNOP);
9575 unop->op_type = (OPCODE)OP_BOOLKEYS;
9576 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9577 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9578 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9579 unop->op_first = rep_op;
9580 unop->op_next = rep_op->op_next;
9581 rep_op->op_next = (OP*)unop;
9582 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9583 unop->op_sibling = rep_op->op_sibling;
9584 rep_op->op_sibling = NULL;
9585 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9586 if (rep_op->op_type == OP_PADHV) {
9587 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9588 rep_op->op_flags |= OPf_WANT_LIST;
9593 /* Check for in place reverse and sort assignments like "@a = reverse @a"
9594 and modify the optree to make them work inplace */
9597 S_inplace_aassign(pTHX_ OP *o) {
9599 OP *modop, *modop_pushmark;
9601 OP *oleft, *oleft_pushmark;
9603 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
9605 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
9607 assert(cUNOPo->op_first->op_type == OP_NULL);
9608 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
9609 assert(modop_pushmark->op_type == OP_PUSHMARK);
9610 modop = modop_pushmark->op_sibling;
9612 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
9615 /* no other operation except sort/reverse */
9616 if (modop->op_sibling)
9619 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
9620 oright = cUNOPx(modop)->op_first->op_sibling;
9622 if (modop->op_flags & OPf_STACKED) {
9623 /* skip sort subroutine/block */
9624 assert(oright->op_type == OP_NULL);
9625 oright = oright->op_sibling;
9628 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
9629 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
9630 assert(oleft_pushmark->op_type == OP_PUSHMARK);
9631 oleft = oleft_pushmark->op_sibling;
9633 /* Check the lhs is an array */
9635 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
9636 || oleft->op_sibling
9637 || (oleft->op_private & OPpLVAL_INTRO)
9641 /* Only one thing on the rhs */
9642 if (oright->op_sibling)
9645 /* check the array is the same on both sides */
9646 if (oleft->op_type == OP_RV2AV) {
9647 if (oright->op_type != OP_RV2AV
9648 || !cUNOPx(oright)->op_first
9649 || cUNOPx(oright)->op_first->op_type != OP_GV
9650 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9651 cGVOPx_gv(cUNOPx(oright)->op_first)
9655 else if (oright->op_type != OP_PADAV
9656 || oright->op_targ != oleft->op_targ
9660 /* This actually is an inplace assignment */
9662 modop->op_private |= OPpSORT_INPLACE;
9664 /* transfer MODishness etc from LHS arg to RHS arg */
9665 oright->op_flags = oleft->op_flags;
9667 /* remove the aassign op and the lhs */
9669 op_null(oleft_pushmark);
9670 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
9671 op_null(cUNOPx(oleft)->op_first);
9675 #define MAX_DEFERRED 4
9678 if (defer_ix == (MAX_DEFERRED-1)) { \
9679 CALL_RPEEP(defer_queue[defer_base]); \
9680 defer_base = (defer_base + 1) % MAX_DEFERRED; \
9683 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
9685 /* A peephole optimizer. We visit the ops in the order they're to execute.
9686 * See the comments at the top of this file for more details about when
9687 * peep() is called */
9690 Perl_rpeep(pTHX_ register OP *o)
9693 register OP* oldop = NULL;
9694 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
9698 if (!o || o->op_opt)
9702 SAVEVPTR(PL_curcop);
9703 for (;; o = o->op_next) {
9707 while (defer_ix >= 0)
9708 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
9712 /* By default, this op has now been optimised. A couple of cases below
9713 clear this again. */
9716 switch (o->op_type) {
9718 PL_curcop = ((COP*)o); /* for warnings */
9721 PL_curcop = ((COP*)o); /* for warnings */
9723 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9724 to carry two labels. For now, take the easier option, and skip
9725 this optimisation if the first NEXTSTATE has a label. */
9726 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9727 OP *nextop = o->op_next;
9728 while (nextop && nextop->op_type == OP_NULL)
9729 nextop = nextop->op_next;
9731 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9732 COP *firstcop = (COP *)o;
9733 COP *secondcop = (COP *)nextop;
9734 /* We want the COP pointed to by o (and anything else) to
9735 become the next COP down the line. */
9738 firstcop->op_next = secondcop->op_next;
9740 /* Now steal all its pointers, and duplicate the other
9742 firstcop->cop_line = secondcop->cop_line;
9744 firstcop->cop_stashpv = secondcop->cop_stashpv;
9745 firstcop->cop_file = secondcop->cop_file;
9747 firstcop->cop_stash = secondcop->cop_stash;
9748 firstcop->cop_filegv = secondcop->cop_filegv;
9750 firstcop->cop_hints = secondcop->cop_hints;
9751 firstcop->cop_seq = secondcop->cop_seq;
9752 firstcop->cop_warnings = secondcop->cop_warnings;
9753 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9756 secondcop->cop_stashpv = NULL;
9757 secondcop->cop_file = NULL;
9759 secondcop->cop_stash = NULL;
9760 secondcop->cop_filegv = NULL;
9762 secondcop->cop_warnings = NULL;
9763 secondcop->cop_hints_hash = NULL;
9765 /* If we use op_null(), and hence leave an ex-COP, some
9766 warnings are misreported. For example, the compile-time
9767 error in 'use strict; no strict refs;' */
9768 secondcop->op_type = OP_NULL;
9769 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9775 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9776 if (o->op_next->op_private & OPpTARGET_MY) {
9777 if (o->op_flags & OPf_STACKED) /* chained concats */
9778 break; /* ignore_optimization */
9780 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9781 o->op_targ = o->op_next->op_targ;
9782 o->op_next->op_targ = 0;
9783 o->op_private |= OPpTARGET_MY;
9786 op_null(o->op_next);
9790 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9791 break; /* Scalar stub must produce undef. List stub is noop */
9795 if (o->op_targ == OP_NEXTSTATE
9796 || o->op_targ == OP_DBSTATE)
9798 PL_curcop = ((COP*)o);
9800 /* XXX: We avoid setting op_seq here to prevent later calls
9801 to rpeep() from mistakenly concluding that optimisation
9802 has already occurred. This doesn't fix the real problem,
9803 though (See 20010220.007). AMS 20010719 */
9804 /* op_seq functionality is now replaced by op_opt */
9811 if (oldop && o->op_next) {
9812 oldop->op_next = o->op_next;
9820 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9821 OP* const pop = (o->op_type == OP_PADAV) ?
9822 o->op_next : o->op_next->op_next;
9824 if (pop && pop->op_type == OP_CONST &&
9825 ((PL_op = pop->op_next)) &&
9826 pop->op_next->op_type == OP_AELEM &&
9827 !(pop->op_next->op_private &
9828 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9829 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
9832 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9833 no_bareword_allowed(pop);
9834 if (o->op_type == OP_GV)
9835 op_null(o->op_next);
9836 op_null(pop->op_next);
9838 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9839 o->op_next = pop->op_next->op_next;
9840 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9841 o->op_private = (U8)i;
9842 if (o->op_type == OP_GV) {
9845 o->op_type = OP_AELEMFAST;
9848 o->op_type = OP_AELEMFAST_LEX;
9853 if (o->op_next->op_type == OP_RV2SV) {
9854 if (!(o->op_next->op_private & OPpDEREF)) {
9855 op_null(o->op_next);
9856 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9858 o->op_next = o->op_next->op_next;
9859 o->op_type = OP_GVSV;
9860 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9863 else if (o->op_next->op_type == OP_READLINE
9864 && o->op_next->op_next->op_type == OP_CONCAT
9865 && (o->op_next->op_next->op_flags & OPf_STACKED))
9867 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9868 o->op_type = OP_RCATLINE;
9869 o->op_flags |= OPf_STACKED;
9870 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9871 op_null(o->op_next->op_next);
9872 op_null(o->op_next);
9882 fop = cUNOP->op_first;
9890 fop = cLOGOP->op_first;
9891 sop = fop->op_sibling;
9892 while (cLOGOP->op_other->op_type == OP_NULL)
9893 cLOGOP->op_other = cLOGOP->op_other->op_next;
9894 while (o->op_next && ( o->op_type == o->op_next->op_type
9895 || o->op_next->op_type == OP_NULL))
9896 o->op_next = o->op_next->op_next;
9897 DEFER(cLOGOP->op_other);
9901 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9903 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9908 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9909 while (nop && nop->op_next) {
9910 switch (nop->op_next->op_type) {
9915 lop = nop = nop->op_next;
9926 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9927 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9928 cLOGOP->op_first = opt_scalarhv(fop);
9929 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9930 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9946 while (cLOGOP->op_other->op_type == OP_NULL)
9947 cLOGOP->op_other = cLOGOP->op_other->op_next;
9948 DEFER(cLOGOP->op_other);
9953 while (cLOOP->op_redoop->op_type == OP_NULL)
9954 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9955 while (cLOOP->op_nextop->op_type == OP_NULL)
9956 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9957 while (cLOOP->op_lastop->op_type == OP_NULL)
9958 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9959 /* a while(1) loop doesn't have an op_next that escapes the
9960 * loop, so we have to explicitly follow the op_lastop to
9961 * process the rest of the code */
9962 DEFER(cLOOP->op_lastop);
9966 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9967 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9968 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9969 cPMOP->op_pmstashstartu.op_pmreplstart
9970 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9971 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
9975 /* check that RHS of sort is a single plain array */
9976 OP *oright = cUNOPo->op_first;
9977 if (!oright || oright->op_type != OP_PUSHMARK)
9980 if (o->op_private & OPpSORT_INPLACE)
9983 /* reverse sort ... can be optimised. */
9984 if (!cUNOPo->op_sibling) {
9985 /* Nothing follows us on the list. */
9986 OP * const reverse = o->op_next;
9988 if (reverse->op_type == OP_REVERSE &&
9989 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9990 OP * const pushmark = cUNOPx(reverse)->op_first;
9991 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9992 && (cUNOPx(pushmark)->op_sibling == o)) {
9993 /* reverse -> pushmark -> sort */
9994 o->op_private |= OPpSORT_REVERSE;
9996 pushmark->op_next = oright->op_next;
10006 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10008 LISTOP *enter, *exlist;
10010 if (o->op_private & OPpSORT_INPLACE)
10013 enter = (LISTOP *) o->op_next;
10016 if (enter->op_type == OP_NULL) {
10017 enter = (LISTOP *) enter->op_next;
10021 /* for $a (...) will have OP_GV then OP_RV2GV here.
10022 for (...) just has an OP_GV. */
10023 if (enter->op_type == OP_GV) {
10024 gvop = (OP *) enter;
10025 enter = (LISTOP *) enter->op_next;
10028 if (enter->op_type == OP_RV2GV) {
10029 enter = (LISTOP *) enter->op_next;
10035 if (enter->op_type != OP_ENTERITER)
10038 iter = enter->op_next;
10039 if (!iter || iter->op_type != OP_ITER)
10042 expushmark = enter->op_first;
10043 if (!expushmark || expushmark->op_type != OP_NULL
10044 || expushmark->op_targ != OP_PUSHMARK)
10047 exlist = (LISTOP *) expushmark->op_sibling;
10048 if (!exlist || exlist->op_type != OP_NULL
10049 || exlist->op_targ != OP_LIST)
10052 if (exlist->op_last != o) {
10053 /* Mmm. Was expecting to point back to this op. */
10056 theirmark = exlist->op_first;
10057 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10060 if (theirmark->op_sibling != o) {
10061 /* There's something between the mark and the reverse, eg
10062 for (1, reverse (...))
10067 ourmark = ((LISTOP *)o)->op_first;
10068 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10071 ourlast = ((LISTOP *)o)->op_last;
10072 if (!ourlast || ourlast->op_next != o)
10075 rv2av = ourmark->op_sibling;
10076 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10077 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10078 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10079 /* We're just reversing a single array. */
10080 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10081 enter->op_flags |= OPf_STACKED;
10084 /* We don't have control over who points to theirmark, so sacrifice
10086 theirmark->op_next = ourmark->op_next;
10087 theirmark->op_flags = ourmark->op_flags;
10088 ourlast->op_next = gvop ? gvop : (OP *) enter;
10091 enter->op_private |= OPpITER_REVERSED;
10092 iter->op_private |= OPpITER_REVERSED;
10099 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10100 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10105 Perl_cpeep_t cpeep =
10106 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10108 cpeep(aTHX_ o, oldop);
10119 Perl_peep(pTHX_ register OP *o)
10125 =head1 Custom Operators
10127 =for apidoc Ao||custom_op_xop
10128 Return the XOP structure for a given custom op. This function should be
10129 considered internal to OP_NAME and the other access macros: use them instead.
10135 Perl_custom_op_xop(pTHX_ const OP *o)
10141 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10143 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10144 assert(o->op_type == OP_CUSTOM);
10146 /* This is wrong. It assumes a function pointer can be cast to IV,
10147 * which isn't guaranteed, but this is what the old custom OP code
10148 * did. In principle it should be safer to Copy the bytes of the
10149 * pointer into a PV: since the new interface is hidden behind
10150 * functions, this can be changed later if necessary. */
10151 /* Change custom_op_xop if this ever happens */
10152 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10155 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10157 /* assume noone will have just registered a desc */
10158 if (!he && PL_custom_op_names &&
10159 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10164 /* XXX does all this need to be shared mem? */
10165 Newxz(xop, 1, XOP);
10166 pv = SvPV(HeVAL(he), l);
10167 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10168 if (PL_custom_op_descs &&
10169 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10171 pv = SvPV(HeVAL(he), l);
10172 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10174 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10178 if (!he) return &xop_null;
10180 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10185 =for apidoc Ao||custom_op_register
10186 Register a custom op. See L<perlguts/"Custom Operators">.
10192 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10196 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10198 /* see the comment in custom_op_xop */
10199 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10201 if (!PL_custom_ops)
10202 PL_custom_ops = newHV();
10204 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10205 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10209 =head1 Functions in file op.c
10211 =for apidoc core_prototype
10212 This function assigns the prototype of the named core function to C<sv>, or
10213 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10214 NULL if the core function has no prototype. C<code> is a code as returned
10215 by C<keyword()>. It must be negative and unequal to -KEY_CORE.
10221 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10224 int i = 0, n = 0, seen_question = 0, defgv = 0;
10226 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10227 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10228 bool nullret = FALSE;
10230 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10232 assert (code < 0 && code != -KEY_CORE);
10234 if (!sv) sv = sv_newmortal();
10236 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10239 case KEY_and : case KEY_chop: case KEY_chomp:
10240 case KEY_cmp : case KEY_exec: case KEY_eq :
10241 case KEY_ge : case KEY_gt : case KEY_le :
10242 case KEY_lt : case KEY_ne : case KEY_or :
10243 case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
10244 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10245 case KEY_keys: retsetpvs("+", OP_KEYS);
10246 case KEY_values: retsetpvs("+", OP_VALUES);
10247 case KEY_each: retsetpvs("+", OP_EACH);
10248 case KEY_push: retsetpvs("+@", OP_PUSH);
10249 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10250 case KEY_pop: retsetpvs(";+", OP_POP);
10251 case KEY_shift: retsetpvs(";+", OP_SHIFT);
10253 retsetpvs("+;$$@", OP_SPLICE);
10254 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10263 while (i < MAXO) { /* The slow way. */
10264 if (strEQ(name, PL_op_name[i])
10265 || strEQ(name, PL_op_desc[i]))
10267 if (nullret) { assert(opnum); *opnum = i; return NULL; }
10272 assert(0); return NULL; /* Should not happen... */
10274 defgv = PL_opargs[i] & OA_DEFGV;
10275 oa = PL_opargs[i] >> OASHIFT;
10277 if (oa & OA_OPTIONAL && !seen_question && (
10278 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
10283 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10284 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10285 /* But globs are already references (kinda) */
10286 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10290 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10291 && !scalar_mod_type(NULL, i)) {
10296 if (i == OP_LOCK) str[n++] = '&';
10300 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10301 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10302 str[n-1] = '_'; defgv = 0;
10306 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
10308 sv_setpvn(sv, str, n - 1);
10309 if (opnum) *opnum = i;
10314 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
10317 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
10320 PERL_ARGS_ASSERT_CORESUB_OP;
10324 return op_append_elem(OP_LINESEQ,
10327 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
10331 case OP_SELECT: /* which represents OP_SSELECT as well */
10336 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
10337 newSVOP(OP_CONST, 0, newSVuv(1))
10339 coresub_op(newSVuv((UV)OP_SSELECT), 0,
10341 coresub_op(coreargssv, 0, OP_SELECT)
10345 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10347 return op_append_elem(
10350 opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0)
10352 case OA_BASEOP_OR_UNOP:
10353 o = newUNOP(opnum,0,argop);
10354 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
10357 if (is_handle_constructor(o, 1))
10358 argop->op_private |= OPpCOREARGS_DEREF1;
10362 o = convert(opnum,0,argop);
10363 if (is_handle_constructor(o, 2))
10364 argop->op_private |= OPpCOREARGS_DEREF2;
10365 if (scalar_mod_type(NULL, opnum))
10366 argop->op_private |= OPpCOREARGS_SCALARMOD;
10367 if (opnum == OP_SUBSTR) {
10368 o->op_private |= OPpMAYBE_LVSUB;
10378 /* Efficient sub that returns a constant scalar value. */
10380 const_sv_xsub(pTHX_ CV* cv)
10384 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10388 /* diag_listed_as: SKIPME */
10389 Perl_croak(aTHX_ "usage: %s::%s()",
10390 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10403 * c-indentation-style: bsd
10404 * c-basic-offset: 4
10405 * indent-tabs-mode: t
10408 * ex: set ts=8 sts=4 sw=4 noet: