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) CALL_FPTR(PL_peepp)(aTHX_ o)
107 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
109 #if defined(PL_OP_SLAB_ALLOC)
111 #ifdef PERL_DEBUG_READONLY_OPS
112 # define PERL_SLAB_SIZE 4096
113 # include <sys/mman.h>
116 #ifndef PERL_SLAB_SIZE
117 #define PERL_SLAB_SIZE 2048
121 Perl_Slab_Alloc(pTHX_ size_t sz)
125 * To make incrementing use count easy PL_OpSlab is an I32 *
126 * To make inserting the link to slab PL_OpPtr is I32 **
127 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
128 * Add an overhead for pointer to slab and round up as a number of pointers
130 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
131 if ((PL_OpSpace -= sz) < 0) {
132 #ifdef PERL_DEBUG_READONLY_OPS
133 /* We need to allocate chunk by chunk so that we can control the VM
135 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
136 MAP_ANON|MAP_PRIVATE, -1, 0);
138 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
139 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
141 if(PL_OpPtr == MAP_FAILED) {
142 perror("mmap failed");
147 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
152 /* We reserve the 0'th I32 sized chunk as a use count */
153 PL_OpSlab = (I32 *) PL_OpPtr;
154 /* Reduce size by the use count word, and by the size we need.
155 * Latter is to mimic the '-=' in the if() above
157 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
158 /* Allocation pointer starts at the top.
159 Theory: because we build leaves before trunk allocating at end
160 means that at run time access is cache friendly upward
162 PL_OpPtr += PERL_SLAB_SIZE;
164 #ifdef PERL_DEBUG_READONLY_OPS
165 /* We remember this slab. */
166 /* This implementation isn't efficient, but it is simple. */
167 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
168 PL_slabs[PL_slab_count++] = PL_OpSlab;
169 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
172 assert( PL_OpSpace >= 0 );
173 /* Move the allocation pointer down */
175 assert( PL_OpPtr > (I32 **) PL_OpSlab );
176 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
177 (*PL_OpSlab)++; /* Increment use count of slab */
178 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
179 assert( *PL_OpSlab > 0 );
180 return (void *)(PL_OpPtr + 1);
183 #ifdef PERL_DEBUG_READONLY_OPS
185 Perl_pending_Slabs_to_ro(pTHX) {
186 /* Turn all the allocated op slabs read only. */
187 U32 count = PL_slab_count;
188 I32 **const slabs = PL_slabs;
190 /* Reset the array of pending OP slabs, as we're about to turn this lot
191 read only. Also, do it ahead of the loop in case the warn triggers,
192 and a warn handler has an eval */
197 /* Force a new slab for any further allocation. */
201 void *const start = slabs[count];
202 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
203 if(mprotect(start, size, PROT_READ)) {
204 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
205 start, (unsigned long) size, errno);
213 S_Slab_to_rw(pTHX_ void *op)
215 I32 * const * const ptr = (I32 **) op;
216 I32 * const slab = ptr[-1];
218 PERL_ARGS_ASSERT_SLAB_TO_RW;
220 assert( ptr-1 > (I32 **) slab );
221 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
223 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
224 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
225 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
230 Perl_op_refcnt_inc(pTHX_ OP *o)
241 Perl_op_refcnt_dec(pTHX_ OP *o)
243 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
248 # define Slab_to_rw(op)
252 Perl_Slab_Free(pTHX_ void *op)
254 I32 * const * const ptr = (I32 **) op;
255 I32 * const slab = ptr[-1];
256 PERL_ARGS_ASSERT_SLAB_FREE;
257 assert( ptr-1 > (I32 **) slab );
258 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
261 if (--(*slab) == 0) {
263 # define PerlMemShared PerlMem
266 #ifdef PERL_DEBUG_READONLY_OPS
267 U32 count = PL_slab_count;
268 /* Need to remove this slab from our list of slabs */
271 if (PL_slabs[count] == slab) {
273 /* Found it. Move the entry at the end to overwrite it. */
274 DEBUG_m(PerlIO_printf(Perl_debug_log,
275 "Deallocate %p by moving %p from %lu to %lu\n",
277 PL_slabs[PL_slab_count - 1],
278 PL_slab_count, count));
279 PL_slabs[count] = PL_slabs[--PL_slab_count];
280 /* Could realloc smaller at this point, but probably not
282 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
283 perror("munmap failed");
291 PerlMemShared_free(slab);
293 if (slab == PL_OpSlab) {
300 * In the following definition, the ", (OP*)0" is just to make the compiler
301 * think the expression is of the right type: croak actually does a Siglongjmp.
303 #define CHECKOP(type,o) \
304 ((PL_op_mask && PL_op_mask[type]) \
305 ? ( op_free((OP*)o), \
306 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
308 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
310 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
313 S_gv_ename(pTHX_ GV *gv)
315 SV* const tmpsv = sv_newmortal();
317 PERL_ARGS_ASSERT_GV_ENAME;
319 gv_efullname3(tmpsv, gv, NULL);
320 return SvPV_nolen_const(tmpsv);
324 S_no_fh_allowed(pTHX_ OP *o)
326 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
328 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
334 S_too_few_arguments(pTHX_ OP *o, const char *name)
336 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
338 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
343 S_too_many_arguments(pTHX_ OP *o, const char *name)
345 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
347 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
352 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
354 PERL_ARGS_ASSERT_BAD_TYPE;
356 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
357 (int)n, name, t, OP_DESC(kid)));
361 S_no_bareword_allowed(pTHX_ const OP *o)
363 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
366 return; /* various ok barewords are hidden in extra OP_NULL */
367 qerror(Perl_mess(aTHX_
368 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
372 /* "register" allocation */
375 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
379 const bool is_our = (PL_parser->in_my == KEY_our);
381 PERL_ARGS_ASSERT_ALLOCMY;
384 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
387 /* Until we're using the length for real, cross check that we're being
389 assert(strlen(name) == len);
391 /* complain about "my $<special_var>" etc etc */
395 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
396 (name[1] == '_' && (*name == '$' || len > 2))))
398 /* name[2] is true if strlen(name) > 2 */
399 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
400 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
401 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
402 PL_parser->in_my == KEY_state ? "state" : "my"));
404 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
405 PL_parser->in_my == KEY_state ? "state" : "my"));
409 /* check for duplicate declaration */
410 pad_check_dup(name, len, is_our ? pad_add_OUR : 0,
411 (PL_curstash ? PL_curstash : PL_defstash));
413 /* allocate a spare slot and store the name in that slot */
415 off = pad_add_name(name, len,
416 PL_parser->in_my == KEY_state ? pad_add_STATE : 0,
417 PL_parser->in_my_stash,
419 /* $_ is always in main::, even with our */
420 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
424 /* anon sub prototypes contains state vars should always be cloned,
425 * otherwise the state var would be shared between anon subs */
427 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
428 CvCLONE_on(PL_compcv);
433 /* free the body of an op without examining its contents.
434 * Always use this rather than FreeOp directly */
437 S_op_destroy(pTHX_ OP *o)
439 if (o->op_latefree) {
447 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
449 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
455 Perl_op_free(pTHX_ OP *o)
462 if (o->op_latefreed) {
469 if (o->op_private & OPpREFCOUNTED) {
480 refcnt = OpREFCNT_dec(o);
483 /* Need to find and remove any pattern match ops from the list
484 we maintain for reset(). */
485 find_and_forget_pmops(o);
495 /* Call the op_free hook if it has been set. Do it now so that it's called
496 * at the right time for refcounted ops, but still before all of the kids
500 if (o->op_flags & OPf_KIDS) {
501 register OP *kid, *nextkid;
502 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
503 nextkid = kid->op_sibling; /* Get before next freeing kid */
508 #ifdef PERL_DEBUG_READONLY_OPS
512 /* COP* is not cleared by op_clear() so that we may track line
513 * numbers etc even after null() */
514 if (type == OP_NEXTSTATE || type == OP_DBSTATE
515 || (type == OP_NULL /* the COP might have been null'ed */
516 && ((OPCODE)o->op_targ == OP_NEXTSTATE
517 || (OPCODE)o->op_targ == OP_DBSTATE))) {
522 type = (OPCODE)o->op_targ;
525 if (o->op_latefree) {
531 #ifdef DEBUG_LEAKING_SCALARS
538 Perl_op_clear(pTHX_ OP *o)
543 PERL_ARGS_ASSERT_OP_CLEAR;
546 /* if (o->op_madprop && o->op_madprop->mad_next)
548 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
549 "modification of a read only value" for a reason I can't fathom why.
550 It's the "" stringification of $_, where $_ was set to '' in a foreach
551 loop, but it defies simplification into a small test case.
552 However, commenting them out has caused ext/List/Util/t/weak.t to fail
555 mad_free(o->op_madprop);
561 switch (o->op_type) {
562 case OP_NULL: /* Was holding old type, if any. */
563 if (PL_madskills && o->op_targ != OP_NULL) {
564 o->op_type = (Optype)o->op_targ;
568 case OP_ENTEREVAL: /* Was holding hints. */
572 if (!(o->op_flags & OPf_REF)
573 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
579 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
580 /* not an OP_PADAV replacement */
581 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
586 /* It's possible during global destruction that the GV is freed
587 before the optree. Whilst the SvREFCNT_inc is happy to bump from
588 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
589 will trigger an assertion failure, because the entry to sv_clear
590 checks that the scalar is not already freed. A check of for
591 !SvIS_FREED(gv) turns out to be invalid, because during global
592 destruction the reference count can be forced down to zero
593 (with SVf_BREAK set). In which case raising to 1 and then
594 dropping to 0 triggers cleanup before it should happen. I
595 *think* that this might actually be a general, systematic,
596 weakness of the whole idea of SVf_BREAK, in that code *is*
597 allowed to raise and lower references during global destruction,
598 so any *valid* code that happens to do this during global
599 destruction might well trigger premature cleanup. */
600 bool still_valid = gv && SvREFCNT(gv);
603 SvREFCNT_inc_simple_void(gv);
605 if (cPADOPo->op_padix > 0) {
606 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
607 * may still exist on the pad */
608 pad_swipe(cPADOPo->op_padix, TRUE);
609 cPADOPo->op_padix = 0;
612 SvREFCNT_dec(cSVOPo->op_sv);
613 cSVOPo->op_sv = NULL;
616 int try_downgrade = SvREFCNT(gv) == 2;
619 gv_try_downgrade(gv);
623 case OP_METHOD_NAMED:
626 SvREFCNT_dec(cSVOPo->op_sv);
627 cSVOPo->op_sv = NULL;
630 Even if op_clear does a pad_free for the target of the op,
631 pad_free doesn't actually remove the sv that exists in the pad;
632 instead it lives on. This results in that it could be reused as
633 a target later on when the pad was reallocated.
636 pad_swipe(o->op_targ,1);
645 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
649 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
651 if (cPADOPo->op_padix > 0) {
652 pad_swipe(cPADOPo->op_padix, TRUE);
653 cPADOPo->op_padix = 0;
656 SvREFCNT_dec(cSVOPo->op_sv);
657 cSVOPo->op_sv = NULL;
661 PerlMemShared_free(cPVOPo->op_pv);
662 cPVOPo->op_pv = NULL;
666 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
670 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
671 /* No GvIN_PAD_off here, because other references may still
672 * exist on the pad */
673 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
676 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
682 forget_pmop(cPMOPo, 1);
683 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
684 /* we use the same protection as the "SAFE" version of the PM_ macros
685 * here since sv_clean_all might release some PMOPs
686 * after PL_regex_padav has been cleared
687 * and the clearing of PL_regex_padav needs to
688 * happen before sv_clean_all
691 if(PL_regex_pad) { /* We could be in destruction */
692 const IV offset = (cPMOPo)->op_pmoffset;
693 ReREFCNT_dec(PM_GETRE(cPMOPo));
694 PL_regex_pad[offset] = &PL_sv_undef;
695 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
699 ReREFCNT_dec(PM_GETRE(cPMOPo));
700 PM_SETRE(cPMOPo, NULL);
706 if (o->op_targ > 0) {
707 pad_free(o->op_targ);
713 S_cop_free(pTHX_ COP* cop)
715 PERL_ARGS_ASSERT_COP_FREE;
719 if (! specialWARN(cop->cop_warnings))
720 PerlMemShared_free(cop->cop_warnings);
721 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
725 S_forget_pmop(pTHX_ PMOP *const o
731 HV * const pmstash = PmopSTASH(o);
733 PERL_ARGS_ASSERT_FORGET_PMOP;
735 if (pmstash && !SvIS_FREED(pmstash)) {
736 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
738 PMOP **const array = (PMOP**) mg->mg_ptr;
739 U32 count = mg->mg_len / sizeof(PMOP**);
744 /* Found it. Move the entry at the end to overwrite it. */
745 array[i] = array[--count];
746 mg->mg_len = count * sizeof(PMOP**);
747 /* Could realloc smaller at this point always, but probably
748 not worth it. Probably worth free()ing if we're the
751 Safefree(mg->mg_ptr);
768 S_find_and_forget_pmops(pTHX_ OP *o)
770 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
772 if (o->op_flags & OPf_KIDS) {
773 OP *kid = cUNOPo->op_first;
775 switch (kid->op_type) {
780 forget_pmop((PMOP*)kid, 0);
782 find_and_forget_pmops(kid);
783 kid = kid->op_sibling;
789 Perl_op_null(pTHX_ OP *o)
793 PERL_ARGS_ASSERT_OP_NULL;
795 if (o->op_type == OP_NULL)
799 o->op_targ = o->op_type;
800 o->op_type = OP_NULL;
801 o->op_ppaddr = PL_ppaddr[OP_NULL];
805 Perl_op_refcnt_lock(pTHX)
813 Perl_op_refcnt_unlock(pTHX)
820 /* Contextualizers */
822 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
825 S_linklist(pTHX_ OP *o)
829 PERL_ARGS_ASSERT_LINKLIST;
834 /* establish postfix order */
835 first = cUNOPo->op_first;
838 o->op_next = LINKLIST(first);
841 if (kid->op_sibling) {
842 kid->op_next = LINKLIST(kid->op_sibling);
843 kid = kid->op_sibling;
857 S_scalarkids(pTHX_ OP *o)
859 if (o && o->op_flags & OPf_KIDS) {
861 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
868 S_scalarboolean(pTHX_ OP *o)
872 PERL_ARGS_ASSERT_SCALARBOOLEAN;
874 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
875 if (ckWARN(WARN_SYNTAX)) {
876 const line_t oldline = CopLINE(PL_curcop);
878 if (PL_parser && PL_parser->copline != NOLINE)
879 CopLINE_set(PL_curcop, PL_parser->copline);
880 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
881 CopLINE_set(PL_curcop, oldline);
888 Perl_scalar(pTHX_ OP *o)
893 /* assumes no premature commitment */
894 if (!o || (PL_parser && PL_parser->error_count)
895 || (o->op_flags & OPf_WANT)
896 || o->op_type == OP_RETURN)
901 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
903 switch (o->op_type) {
905 scalar(cBINOPo->op_first);
910 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
920 if (o->op_flags & OPf_KIDS) {
921 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
927 kid = cLISTOPo->op_first;
929 while ((kid = kid->op_sibling)) {
935 PL_curcop = &PL_compiling;
940 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
946 PL_curcop = &PL_compiling;
949 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
956 Perl_scalarvoid(pTHX_ OP *o)
960 const char* useless = NULL;
964 PERL_ARGS_ASSERT_SCALARVOID;
966 /* trailing mad null ops don't count as "there" for void processing */
968 o->op_type != OP_NULL &&
970 o->op_sibling->op_type == OP_NULL)
973 for (sib = o->op_sibling;
974 sib && sib->op_type == OP_NULL;
975 sib = sib->op_sibling) ;
981 if (o->op_type == OP_NEXTSTATE
982 || o->op_type == OP_DBSTATE
983 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
984 || o->op_targ == OP_DBSTATE)))
985 PL_curcop = (COP*)o; /* for warning below */
987 /* assumes no premature commitment */
988 want = o->op_flags & OPf_WANT;
989 if ((want && want != OPf_WANT_SCALAR)
990 || (PL_parser && PL_parser->error_count)
991 || o->op_type == OP_RETURN)
996 if ((o->op_private & OPpTARGET_MY)
997 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
999 return scalar(o); /* As if inside SASSIGN */
1002 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1004 switch (o->op_type) {
1006 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1010 if (o->op_flags & OPf_STACKED)
1014 if (o->op_private == 4)
1057 case OP_GETSOCKNAME:
1058 case OP_GETPEERNAME:
1063 case OP_GETPRIORITY:
1087 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1088 /* Otherwise it's "Useless use of grep iterator" */
1089 useless = OP_DESC(o);
1093 kid = cUNOPo->op_first;
1094 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1095 kid->op_type != OP_TRANS) {
1098 useless = "negative pattern binding (!~)";
1105 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1106 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1107 useless = "a variable";
1112 if (cSVOPo->op_private & OPpCONST_STRICT)
1113 no_bareword_allowed(o);
1115 if (ckWARN(WARN_VOID)) {
1117 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1118 "a constant (%"SVf")", sv));
1119 useless = SvPV_nolen(msv);
1122 useless = "a constant (undef)";
1123 if (o->op_private & OPpCONST_ARYBASE)
1125 /* don't warn on optimised away booleans, eg
1126 * use constant Foo, 5; Foo || print; */
1127 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1129 /* the constants 0 and 1 are permitted as they are
1130 conventionally used as dummies in constructs like
1131 1 while some_condition_with_side_effects; */
1132 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1134 else if (SvPOK(sv)) {
1135 /* perl4's way of mixing documentation and code
1136 (before the invention of POD) was based on a
1137 trick to mix nroff and perl code. The trick was
1138 built upon these three nroff macros being used in
1139 void context. The pink camel has the details in
1140 the script wrapman near page 319. */
1141 const char * const maybe_macro = SvPVX_const(sv);
1142 if (strnEQ(maybe_macro, "di", 2) ||
1143 strnEQ(maybe_macro, "ds", 2) ||
1144 strnEQ(maybe_macro, "ig", 2))
1149 op_null(o); /* don't execute or even remember it */
1153 o->op_type = OP_PREINC; /* pre-increment is faster */
1154 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1158 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1159 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1163 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1164 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1168 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1169 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1174 kid = cLOGOPo->op_first;
1175 if (kid->op_type == OP_NOT
1176 && (kid->op_flags & OPf_KIDS)
1178 if (o->op_type == OP_AND) {
1180 o->op_ppaddr = PL_ppaddr[OP_OR];
1182 o->op_type = OP_AND;
1183 o->op_ppaddr = PL_ppaddr[OP_AND];
1192 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1197 if (o->op_flags & OPf_STACKED)
1204 if (!(o->op_flags & OPf_KIDS))
1215 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1222 /* all requires must return a boolean value */
1223 o->op_flags &= ~OPf_WANT;
1229 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1234 S_listkids(pTHX_ OP *o)
1236 if (o && o->op_flags & OPf_KIDS) {
1238 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1245 Perl_list(pTHX_ OP *o)
1250 /* assumes no premature commitment */
1251 if (!o || (o->op_flags & OPf_WANT)
1252 || (PL_parser && PL_parser->error_count)
1253 || o->op_type == OP_RETURN)
1258 if ((o->op_private & OPpTARGET_MY)
1259 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1261 return o; /* As if inside SASSIGN */
1264 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1266 switch (o->op_type) {
1269 list(cBINOPo->op_first);
1274 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1282 if (!(o->op_flags & OPf_KIDS))
1284 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1285 list(cBINOPo->op_first);
1286 return gen_constant_list(o);
1293 kid = cLISTOPo->op_first;
1295 while ((kid = kid->op_sibling)) {
1296 if (kid->op_sibling)
1301 PL_curcop = &PL_compiling;
1305 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1306 if (kid->op_sibling)
1311 PL_curcop = &PL_compiling;
1314 /* all requires must return a boolean value */
1315 o->op_flags &= ~OPf_WANT;
1322 S_scalarseq(pTHX_ OP *o)
1326 const OPCODE type = o->op_type;
1328 if (type == OP_LINESEQ || type == OP_SCOPE ||
1329 type == OP_LEAVE || type == OP_LEAVETRY)
1332 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1333 if (kid->op_sibling) {
1337 PL_curcop = &PL_compiling;
1339 o->op_flags &= ~OPf_PARENS;
1340 if (PL_hints & HINT_BLOCK_SCOPE)
1341 o->op_flags |= OPf_PARENS;
1344 o = newOP(OP_STUB, 0);
1349 S_modkids(pTHX_ OP *o, I32 type)
1351 if (o && o->op_flags & OPf_KIDS) {
1353 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1359 /* Propagate lvalue ("modifiable") context to an op and its children.
1360 * 'type' represents the context type, roughly based on the type of op that
1361 * would do the modifying, although local() is represented by OP_NULL.
1362 * It's responsible for detecting things that can't be modified, flag
1363 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1364 * might have to vivify a reference in $x), and so on.
1366 * For example, "$a+1 = 2" would cause mod() to be called with o being
1367 * OP_ADD and type being OP_SASSIGN, and would output an error.
1371 Perl_mod(pTHX_ OP *o, I32 type)
1375 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1378 if (!o || (PL_parser && PL_parser->error_count))
1381 if ((o->op_private & OPpTARGET_MY)
1382 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1387 switch (o->op_type) {
1393 if (!(o->op_private & OPpCONST_ARYBASE))
1396 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1397 CopARYBASE_set(&PL_compiling,
1398 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1402 SAVECOPARYBASE(&PL_compiling);
1403 CopARYBASE_set(&PL_compiling, 0);
1405 else if (type == OP_REFGEN)
1408 Perl_croak(aTHX_ "That use of $[ is unsupported");
1411 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1415 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1416 !(o->op_flags & OPf_STACKED)) {
1417 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1418 /* The default is to set op_private to the number of children,
1419 which for a UNOP such as RV2CV is always 1. And w're using
1420 the bit for a flag in RV2CV, so we need it clear. */
1421 o->op_private &= ~1;
1422 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1423 assert(cUNOPo->op_first->op_type == OP_NULL);
1424 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1427 else if (o->op_private & OPpENTERSUB_NOMOD)
1429 else { /* lvalue subroutine call */
1430 o->op_private |= OPpLVAL_INTRO;
1431 PL_modcount = RETURN_UNLIMITED_NUMBER;
1432 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1433 /* Backward compatibility mode: */
1434 o->op_private |= OPpENTERSUB_INARGS;
1437 else { /* Compile-time error message: */
1438 OP *kid = cUNOPo->op_first;
1442 if (kid->op_type != OP_PUSHMARK) {
1443 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1445 "panic: unexpected lvalue entersub "
1446 "args: type/targ %ld:%"UVuf,
1447 (long)kid->op_type, (UV)kid->op_targ);
1448 kid = kLISTOP->op_first;
1450 while (kid->op_sibling)
1451 kid = kid->op_sibling;
1452 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1454 if (kid->op_type == OP_METHOD_NAMED
1455 || kid->op_type == OP_METHOD)
1459 NewOp(1101, newop, 1, UNOP);
1460 newop->op_type = OP_RV2CV;
1461 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1462 newop->op_first = NULL;
1463 newop->op_next = (OP*)newop;
1464 kid->op_sibling = (OP*)newop;
1465 newop->op_private |= OPpLVAL_INTRO;
1466 newop->op_private &= ~1;
1470 if (kid->op_type != OP_RV2CV)
1472 "panic: unexpected lvalue entersub "
1473 "entry via type/targ %ld:%"UVuf,
1474 (long)kid->op_type, (UV)kid->op_targ);
1475 kid->op_private |= OPpLVAL_INTRO;
1476 break; /* Postpone until runtime */
1480 kid = kUNOP->op_first;
1481 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1482 kid = kUNOP->op_first;
1483 if (kid->op_type == OP_NULL)
1485 "Unexpected constant lvalue entersub "
1486 "entry via type/targ %ld:%"UVuf,
1487 (long)kid->op_type, (UV)kid->op_targ);
1488 if (kid->op_type != OP_GV) {
1489 /* Restore RV2CV to check lvalueness */
1491 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1492 okid->op_next = kid->op_next;
1493 kid->op_next = okid;
1496 okid->op_next = NULL;
1497 okid->op_type = OP_RV2CV;
1499 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1500 okid->op_private |= OPpLVAL_INTRO;
1501 okid->op_private &= ~1;
1505 cv = GvCV(kGVOP_gv);
1515 /* grep, foreach, subcalls, refgen */
1516 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1518 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1519 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1521 : (o->op_type == OP_ENTERSUB
1522 ? "non-lvalue subroutine call"
1524 type ? PL_op_desc[type] : "local"));
1538 case OP_RIGHT_SHIFT:
1547 if (!(o->op_flags & OPf_STACKED))
1554 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1560 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1561 PL_modcount = RETURN_UNLIMITED_NUMBER;
1562 return o; /* Treat \(@foo) like ordinary list. */
1566 if (scalar_mod_type(o, type))
1568 ref(cUNOPo->op_first, o->op_type);
1572 if (type == OP_LEAVESUBLV)
1573 o->op_private |= OPpMAYBE_LVSUB;
1579 PL_modcount = RETURN_UNLIMITED_NUMBER;
1582 PL_hints |= HINT_BLOCK_SCOPE;
1583 if (type == OP_LEAVESUBLV)
1584 o->op_private |= OPpMAYBE_LVSUB;
1588 ref(cUNOPo->op_first, o->op_type);
1592 PL_hints |= HINT_BLOCK_SCOPE;
1607 PL_modcount = RETURN_UNLIMITED_NUMBER;
1608 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1609 return o; /* Treat \(@foo) like ordinary list. */
1610 if (scalar_mod_type(o, type))
1612 if (type == OP_LEAVESUBLV)
1613 o->op_private |= OPpMAYBE_LVSUB;
1617 if (!type) /* local() */
1618 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1619 PAD_COMPNAME_PV(o->op_targ));
1627 if (type != OP_SASSIGN)
1631 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1636 if (type == OP_LEAVESUBLV)
1637 o->op_private |= OPpMAYBE_LVSUB;
1639 pad_free(o->op_targ);
1640 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1641 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1642 if (o->op_flags & OPf_KIDS)
1643 mod(cBINOPo->op_first->op_sibling, type);
1648 ref(cBINOPo->op_first, o->op_type);
1649 if (type == OP_ENTERSUB &&
1650 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1651 o->op_private |= OPpLVAL_DEFER;
1652 if (type == OP_LEAVESUBLV)
1653 o->op_private |= OPpMAYBE_LVSUB;
1663 if (o->op_flags & OPf_KIDS)
1664 mod(cLISTOPo->op_last, type);
1669 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1671 else if (!(o->op_flags & OPf_KIDS))
1673 if (o->op_targ != OP_LIST) {
1674 mod(cBINOPo->op_first, type);
1680 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1685 if (type != OP_LEAVESUBLV)
1687 break; /* mod()ing was handled by ck_return() */
1690 /* [20011101.069] File test operators interpret OPf_REF to mean that
1691 their argument is a filehandle; thus \stat(".") should not set
1693 if (type == OP_REFGEN &&
1694 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1697 if (type != OP_LEAVESUBLV)
1698 o->op_flags |= OPf_MOD;
1700 if (type == OP_AASSIGN || type == OP_SASSIGN)
1701 o->op_flags |= OPf_SPECIAL|OPf_REF;
1702 else if (!type) { /* local() */
1705 o->op_private |= OPpLVAL_INTRO;
1706 o->op_flags &= ~OPf_SPECIAL;
1707 PL_hints |= HINT_BLOCK_SCOPE;
1712 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1713 "Useless localization of %s", OP_DESC(o));
1716 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1717 && type != OP_LEAVESUBLV)
1718 o->op_flags |= OPf_REF;
1723 S_scalar_mod_type(const OP *o, I32 type)
1725 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1729 if (o->op_type == OP_RV2GV)
1753 case OP_RIGHT_SHIFT:
1773 S_is_handle_constructor(const OP *o, I32 numargs)
1775 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1777 switch (o->op_type) {
1785 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1798 S_refkids(pTHX_ OP *o, I32 type)
1800 if (o && o->op_flags & OPf_KIDS) {
1802 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1809 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1814 PERL_ARGS_ASSERT_DOREF;
1816 if (!o || (PL_parser && PL_parser->error_count))
1819 switch (o->op_type) {
1821 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1822 !(o->op_flags & OPf_STACKED)) {
1823 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1824 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1825 assert(cUNOPo->op_first->op_type == OP_NULL);
1826 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1827 o->op_flags |= OPf_SPECIAL;
1828 o->op_private &= ~1;
1833 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1834 doref(kid, type, set_op_ref);
1837 if (type == OP_DEFINED)
1838 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1839 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1842 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1843 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1844 : type == OP_RV2HV ? OPpDEREF_HV
1846 o->op_flags |= OPf_MOD;
1853 o->op_flags |= OPf_REF;
1856 if (type == OP_DEFINED)
1857 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1858 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1864 o->op_flags |= OPf_REF;
1869 if (!(o->op_flags & OPf_KIDS))
1871 doref(cBINOPo->op_first, type, set_op_ref);
1875 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1876 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1877 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1878 : type == OP_RV2HV ? OPpDEREF_HV
1880 o->op_flags |= OPf_MOD;
1890 if (!(o->op_flags & OPf_KIDS))
1892 doref(cLISTOPo->op_last, type, set_op_ref);
1902 S_dup_attrlist(pTHX_ OP *o)
1907 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1909 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1910 * where the first kid is OP_PUSHMARK and the remaining ones
1911 * are OP_CONST. We need to push the OP_CONST values.
1913 if (o->op_type == OP_CONST)
1914 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1916 else if (o->op_type == OP_NULL)
1920 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1922 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1923 if (o->op_type == OP_CONST)
1924 rop = append_elem(OP_LIST, rop,
1925 newSVOP(OP_CONST, o->op_flags,
1926 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1933 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1938 PERL_ARGS_ASSERT_APPLY_ATTRS;
1940 /* fake up C<use attributes $pkg,$rv,@attrs> */
1941 ENTER; /* need to protect against side-effects of 'use' */
1942 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1944 #define ATTRSMODULE "attributes"
1945 #define ATTRSMODULE_PM "attributes.pm"
1948 /* Don't force the C<use> if we don't need it. */
1949 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1950 if (svp && *svp != &PL_sv_undef)
1951 NOOP; /* already in %INC */
1953 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1954 newSVpvs(ATTRSMODULE), NULL);
1957 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1958 newSVpvs(ATTRSMODULE),
1960 prepend_elem(OP_LIST,
1961 newSVOP(OP_CONST, 0, stashsv),
1962 prepend_elem(OP_LIST,
1963 newSVOP(OP_CONST, 0,
1965 dup_attrlist(attrs))));
1971 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1974 OP *pack, *imop, *arg;
1977 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1982 assert(target->op_type == OP_PADSV ||
1983 target->op_type == OP_PADHV ||
1984 target->op_type == OP_PADAV);
1986 /* Ensure that attributes.pm is loaded. */
1987 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1989 /* Need package name for method call. */
1990 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1992 /* Build up the real arg-list. */
1993 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1995 arg = newOP(OP_PADSV, 0);
1996 arg->op_targ = target->op_targ;
1997 arg = prepend_elem(OP_LIST,
1998 newSVOP(OP_CONST, 0, stashsv),
1999 prepend_elem(OP_LIST,
2000 newUNOP(OP_REFGEN, 0,
2001 mod(arg, OP_REFGEN)),
2002 dup_attrlist(attrs)));
2004 /* Fake up a method call to import */
2005 meth = newSVpvs_share("import");
2006 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2007 append_elem(OP_LIST,
2008 prepend_elem(OP_LIST, pack, list(arg)),
2009 newSVOP(OP_METHOD_NAMED, 0, meth)));
2010 imop->op_private |= OPpENTERSUB_NOMOD;
2012 /* Combine the ops. */
2013 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2017 =notfor apidoc apply_attrs_string
2019 Attempts to apply a list of attributes specified by the C<attrstr> and
2020 C<len> arguments to the subroutine identified by the C<cv> argument which
2021 is expected to be associated with the package identified by the C<stashpv>
2022 argument (see L<attributes>). It gets this wrong, though, in that it
2023 does not correctly identify the boundaries of the individual attribute
2024 specifications within C<attrstr>. This is not really intended for the
2025 public API, but has to be listed here for systems such as AIX which
2026 need an explicit export list for symbols. (It's called from XS code
2027 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2028 to respect attribute syntax properly would be welcome.
2034 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2035 const char *attrstr, STRLEN len)
2039 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2042 len = strlen(attrstr);
2046 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2048 const char * const sstr = attrstr;
2049 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2050 attrs = append_elem(OP_LIST, attrs,
2051 newSVOP(OP_CONST, 0,
2052 newSVpvn(sstr, attrstr-sstr)));
2056 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2057 newSVpvs(ATTRSMODULE),
2058 NULL, prepend_elem(OP_LIST,
2059 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2060 prepend_elem(OP_LIST,
2061 newSVOP(OP_CONST, 0,
2062 newRV(MUTABLE_SV(cv))),
2067 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2072 PERL_ARGS_ASSERT_MY_KID;
2074 if (!o || (PL_parser && PL_parser->error_count))
2078 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2079 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2083 if (type == OP_LIST) {
2085 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2086 my_kid(kid, attrs, imopsp);
2087 } else if (type == OP_UNDEF
2093 } else if (type == OP_RV2SV || /* "our" declaration */
2095 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2096 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2097 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2099 PL_parser->in_my == KEY_our
2101 : PL_parser->in_my == KEY_state ? "state" : "my"));
2103 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2104 PL_parser->in_my = FALSE;
2105 PL_parser->in_my_stash = NULL;
2106 apply_attrs(GvSTASH(gv),
2107 (type == OP_RV2SV ? GvSV(gv) :
2108 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2109 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2112 o->op_private |= OPpOUR_INTRO;
2115 else if (type != OP_PADSV &&
2118 type != OP_PUSHMARK)
2120 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2122 PL_parser->in_my == KEY_our
2124 : PL_parser->in_my == KEY_state ? "state" : "my"));
2127 else if (attrs && type != OP_PUSHMARK) {
2130 PL_parser->in_my = FALSE;
2131 PL_parser->in_my_stash = NULL;
2133 /* check for C<my Dog $spot> when deciding package */
2134 stash = PAD_COMPNAME_TYPE(o->op_targ);
2136 stash = PL_curstash;
2137 apply_attrs_my(stash, o, attrs, imopsp);
2139 o->op_flags |= OPf_MOD;
2140 o->op_private |= OPpLVAL_INTRO;
2141 if (PL_parser->in_my == KEY_state)
2142 o->op_private |= OPpPAD_STATE;
2147 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2151 int maybe_scalar = 0;
2153 PERL_ARGS_ASSERT_MY_ATTRS;
2155 /* [perl #17376]: this appears to be premature, and results in code such as
2156 C< our(%x); > executing in list mode rather than void mode */
2158 if (o->op_flags & OPf_PARENS)
2168 o = my_kid(o, attrs, &rops);
2170 if (maybe_scalar && o->op_type == OP_PADSV) {
2171 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2172 o->op_private |= OPpLVAL_INTRO;
2175 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2177 PL_parser->in_my = FALSE;
2178 PL_parser->in_my_stash = NULL;
2183 Perl_sawparens(pTHX_ OP *o)
2185 PERL_UNUSED_CONTEXT;
2187 o->op_flags |= OPf_PARENS;
2192 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2196 const OPCODE ltype = left->op_type;
2197 const OPCODE rtype = right->op_type;
2199 PERL_ARGS_ASSERT_BIND_MATCH;
2201 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2202 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2204 const char * const desc
2205 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2206 ? (int)rtype : OP_MATCH];
2207 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2208 ? "@array" : "%hash");
2209 Perl_warner(aTHX_ packWARN(WARN_MISC),
2210 "Applying %s to %s will act on scalar(%s)",
2211 desc, sample, sample);
2214 if (rtype == OP_CONST &&
2215 cSVOPx(right)->op_private & OPpCONST_BARE &&
2216 cSVOPx(right)->op_private & OPpCONST_STRICT)
2218 no_bareword_allowed(right);
2221 ismatchop = rtype == OP_MATCH ||
2222 rtype == OP_SUBST ||
2224 if (ismatchop && right->op_private & OPpTARGET_MY) {
2226 right->op_private &= ~OPpTARGET_MY;
2228 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2231 right->op_flags |= OPf_STACKED;
2232 if (rtype != OP_MATCH &&
2233 ! (rtype == OP_TRANS &&
2234 right->op_private & OPpTRANS_IDENTICAL))
2235 newleft = mod(left, rtype);
2238 if (right->op_type == OP_TRANS)
2239 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2241 o = prepend_elem(rtype, scalar(newleft), right);
2243 return newUNOP(OP_NOT, 0, scalar(o));
2247 return bind_match(type, left,
2248 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2252 Perl_invert(pTHX_ OP *o)
2256 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2260 Perl_scope(pTHX_ OP *o)
2264 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2265 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2266 o->op_type = OP_LEAVE;
2267 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2269 else if (o->op_type == OP_LINESEQ) {
2271 o->op_type = OP_SCOPE;
2272 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2273 kid = ((LISTOP*)o)->op_first;
2274 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2277 /* The following deals with things like 'do {1 for 1}' */
2278 kid = kid->op_sibling;
2280 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2285 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2291 Perl_block_start(pTHX_ int full)
2294 const int retval = PL_savestack_ix;
2295 pad_block_start(full);
2297 PL_hints &= ~HINT_BLOCK_SCOPE;
2298 SAVECOMPILEWARNINGS();
2299 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2304 Perl_block_end(pTHX_ I32 floor, OP *seq)
2307 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2308 OP* const retval = scalarseq(seq);
2310 CopHINTS_set(&PL_compiling, PL_hints);
2312 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2321 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2322 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2323 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2326 OP * const o = newOP(OP_PADSV, 0);
2327 o->op_targ = offset;
2333 Perl_newPROG(pTHX_ OP *o)
2337 PERL_ARGS_ASSERT_NEWPROG;
2342 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2343 ((PL_in_eval & EVAL_KEEPERR)
2344 ? OPf_SPECIAL : 0), o);
2345 PL_eval_start = linklist(PL_eval_root);
2346 PL_eval_root->op_private |= OPpREFCOUNTED;
2347 OpREFCNT_set(PL_eval_root, 1);
2348 PL_eval_root->op_next = 0;
2349 CALL_PEEP(PL_eval_start);
2352 if (o->op_type == OP_STUB) {
2353 PL_comppad_name = 0;
2355 S_op_destroy(aTHX_ o);
2358 PL_main_root = scope(sawparens(scalarvoid(o)));
2359 PL_curcop = &PL_compiling;
2360 PL_main_start = LINKLIST(PL_main_root);
2361 PL_main_root->op_private |= OPpREFCOUNTED;
2362 OpREFCNT_set(PL_main_root, 1);
2363 PL_main_root->op_next = 0;
2364 CALL_PEEP(PL_main_start);
2367 /* Register with debugger */
2369 CV * const cv = get_cvs("DB::postponed", 0);
2373 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2375 call_sv(MUTABLE_SV(cv), G_DISCARD);
2382 Perl_localize(pTHX_ OP *o, I32 lex)
2386 PERL_ARGS_ASSERT_LOCALIZE;
2388 if (o->op_flags & OPf_PARENS)
2389 /* [perl #17376]: this appears to be premature, and results in code such as
2390 C< our(%x); > executing in list mode rather than void mode */
2397 if ( PL_parser->bufptr > PL_parser->oldbufptr
2398 && PL_parser->bufptr[-1] == ','
2399 && ckWARN(WARN_PARENTHESIS))
2401 char *s = PL_parser->bufptr;
2404 /* some heuristics to detect a potential error */
2405 while (*s && (strchr(", \t\n", *s)))
2409 if (*s && strchr("@$%*", *s) && *++s
2410 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2413 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2415 while (*s && (strchr(", \t\n", *s)))
2421 if (sigil && (*s == ';' || *s == '=')) {
2422 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2423 "Parentheses missing around \"%s\" list",
2425 ? (PL_parser->in_my == KEY_our
2427 : PL_parser->in_my == KEY_state
2437 o = mod(o, OP_NULL); /* a bit kludgey */
2438 PL_parser->in_my = FALSE;
2439 PL_parser->in_my_stash = NULL;
2444 Perl_jmaybe(pTHX_ OP *o)
2446 PERL_ARGS_ASSERT_JMAYBE;
2448 if (o->op_type == OP_LIST) {
2450 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2451 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2457 S_fold_constants(pTHX_ register OP *o)
2460 register OP * VOL curop;
2462 VOL I32 type = o->op_type;
2467 SV * const oldwarnhook = PL_warnhook;
2468 SV * const olddiehook = PL_diehook;
2472 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2474 if (PL_opargs[type] & OA_RETSCALAR)
2476 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2477 o->op_targ = pad_alloc(type, SVs_PADTMP);
2479 /* integerize op, unless it happens to be C<-foo>.
2480 * XXX should pp_i_negate() do magic string negation instead? */
2481 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2482 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2483 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2485 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2488 if (!(PL_opargs[type] & OA_FOLDCONST))
2493 /* XXX might want a ck_negate() for this */
2494 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2505 /* XXX what about the numeric ops? */
2506 if (PL_hints & HINT_LOCALE)
2511 if (PL_parser && PL_parser->error_count)
2512 goto nope; /* Don't try to run w/ errors */
2514 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2515 const OPCODE type = curop->op_type;
2516 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2518 type != OP_SCALAR &&
2520 type != OP_PUSHMARK)
2526 curop = LINKLIST(o);
2527 old_next = o->op_next;
2531 oldscope = PL_scopestack_ix;
2532 create_eval_scope(G_FAKINGEVAL);
2534 /* Verify that we don't need to save it: */
2535 assert(PL_curcop == &PL_compiling);
2536 StructCopy(&PL_compiling, ¬_compiling, COP);
2537 PL_curcop = ¬_compiling;
2538 /* The above ensures that we run with all the correct hints of the
2539 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2540 assert(IN_PERL_RUNTIME);
2541 PL_warnhook = PERL_WARNHOOK_FATAL;
2548 sv = *(PL_stack_sp--);
2549 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2550 pad_swipe(o->op_targ, FALSE);
2551 else if (SvTEMP(sv)) { /* grab mortal temp? */
2552 SvREFCNT_inc_simple_void(sv);
2557 /* Something tried to die. Abandon constant folding. */
2558 /* Pretend the error never happened. */
2560 o->op_next = old_next;
2564 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2565 PL_warnhook = oldwarnhook;
2566 PL_diehook = olddiehook;
2567 /* XXX note that this croak may fail as we've already blown away
2568 * the stack - eg any nested evals */
2569 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2572 PL_warnhook = oldwarnhook;
2573 PL_diehook = olddiehook;
2574 PL_curcop = &PL_compiling;
2576 if (PL_scopestack_ix > oldscope)
2577 delete_eval_scope();
2586 if (type == OP_RV2GV)
2587 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2589 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2590 op_getmad(o,newop,'f');
2598 S_gen_constant_list(pTHX_ register OP *o)
2602 const I32 oldtmps_floor = PL_tmps_floor;
2605 if (PL_parser && PL_parser->error_count)
2606 return o; /* Don't attempt to run with errors */
2608 PL_op = curop = LINKLIST(o);
2614 assert (!(curop->op_flags & OPf_SPECIAL));
2615 assert(curop->op_type == OP_RANGE);
2617 PL_tmps_floor = oldtmps_floor;
2619 o->op_type = OP_RV2AV;
2620 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2621 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2622 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2623 o->op_opt = 0; /* needs to be revisited in peep() */
2624 curop = ((UNOP*)o)->op_first;
2625 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2627 op_getmad(curop,o,'O');
2636 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2639 if (!o || o->op_type != OP_LIST)
2640 o = newLISTOP(OP_LIST, 0, o, NULL);
2642 o->op_flags &= ~OPf_WANT;
2644 if (!(PL_opargs[type] & OA_MARK))
2645 op_null(cLISTOPo->op_first);
2647 o->op_type = (OPCODE)type;
2648 o->op_ppaddr = PL_ppaddr[type];
2649 o->op_flags |= flags;
2651 o = CHECKOP(type, o);
2652 if (o->op_type != (unsigned)type)
2655 return fold_constants(o);
2658 /* List constructors */
2661 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2669 if (first->op_type != (unsigned)type
2670 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2672 return newLISTOP(type, 0, first, last);
2675 if (first->op_flags & OPf_KIDS)
2676 ((LISTOP*)first)->op_last->op_sibling = last;
2678 first->op_flags |= OPf_KIDS;
2679 ((LISTOP*)first)->op_first = last;
2681 ((LISTOP*)first)->op_last = last;
2686 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2694 if (first->op_type != (unsigned)type)
2695 return prepend_elem(type, (OP*)first, (OP*)last);
2697 if (last->op_type != (unsigned)type)
2698 return append_elem(type, (OP*)first, (OP*)last);
2700 first->op_last->op_sibling = last->op_first;
2701 first->op_last = last->op_last;
2702 first->op_flags |= (last->op_flags & OPf_KIDS);
2705 if (last->op_first && first->op_madprop) {
2706 MADPROP *mp = last->op_first->op_madprop;
2708 while (mp->mad_next)
2710 mp->mad_next = first->op_madprop;
2713 last->op_first->op_madprop = first->op_madprop;
2716 first->op_madprop = last->op_madprop;
2717 last->op_madprop = 0;
2720 S_op_destroy(aTHX_ (OP*)last);
2726 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2734 if (last->op_type == (unsigned)type) {
2735 if (type == OP_LIST) { /* already a PUSHMARK there */
2736 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2737 ((LISTOP*)last)->op_first->op_sibling = first;
2738 if (!(first->op_flags & OPf_PARENS))
2739 last->op_flags &= ~OPf_PARENS;
2742 if (!(last->op_flags & OPf_KIDS)) {
2743 ((LISTOP*)last)->op_last = first;
2744 last->op_flags |= OPf_KIDS;
2746 first->op_sibling = ((LISTOP*)last)->op_first;
2747 ((LISTOP*)last)->op_first = first;
2749 last->op_flags |= OPf_KIDS;
2753 return newLISTOP(type, 0, first, last);
2761 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2764 Newxz(tk, 1, TOKEN);
2765 tk->tk_type = (OPCODE)optype;
2766 tk->tk_type = 12345;
2768 tk->tk_mad = madprop;
2773 Perl_token_free(pTHX_ TOKEN* tk)
2775 PERL_ARGS_ASSERT_TOKEN_FREE;
2777 if (tk->tk_type != 12345)
2779 mad_free(tk->tk_mad);
2784 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2789 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2791 if (tk->tk_type != 12345) {
2792 Perl_warner(aTHX_ packWARN(WARN_MISC),
2793 "Invalid TOKEN object ignored");
2800 /* faked up qw list? */
2802 tm->mad_type == MAD_SV &&
2803 SvPVX((SV *)tm->mad_val)[0] == 'q')
2810 /* pretend constant fold didn't happen? */
2811 if (mp->mad_key == 'f' &&
2812 (o->op_type == OP_CONST ||
2813 o->op_type == OP_GV) )
2815 token_getmad(tk,(OP*)mp->mad_val,slot);
2829 if (mp->mad_key == 'X')
2830 mp->mad_key = slot; /* just change the first one */
2840 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2849 /* pretend constant fold didn't happen? */
2850 if (mp->mad_key == 'f' &&
2851 (o->op_type == OP_CONST ||
2852 o->op_type == OP_GV) )
2854 op_getmad(from,(OP*)mp->mad_val,slot);
2861 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2864 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2870 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2879 /* pretend constant fold didn't happen? */
2880 if (mp->mad_key == 'f' &&
2881 (o->op_type == OP_CONST ||
2882 o->op_type == OP_GV) )
2884 op_getmad(from,(OP*)mp->mad_val,slot);
2891 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2894 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2898 PerlIO_printf(PerlIO_stderr(),
2899 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2905 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2923 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2927 addmad(tm, &(o->op_madprop), slot);
2931 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2952 Perl_newMADsv(pTHX_ char key, SV* sv)
2954 PERL_ARGS_ASSERT_NEWMADSV;
2956 return newMADPROP(key, MAD_SV, sv, 0);
2960 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2963 Newxz(mp, 1, MADPROP);
2966 mp->mad_vlen = vlen;
2967 mp->mad_type = type;
2969 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2974 Perl_mad_free(pTHX_ MADPROP* mp)
2976 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2980 mad_free(mp->mad_next);
2981 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2982 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2983 switch (mp->mad_type) {
2987 Safefree((char*)mp->mad_val);
2990 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2991 op_free((OP*)mp->mad_val);
2994 sv_free(MUTABLE_SV(mp->mad_val));
2997 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3006 Perl_newNULLLIST(pTHX)
3008 return newOP(OP_STUB, 0);
3012 S_force_list(pTHX_ OP *o)
3014 if (!o || o->op_type != OP_LIST)
3015 o = newLISTOP(OP_LIST, 0, o, NULL);
3021 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3026 NewOp(1101, listop, 1, LISTOP);
3028 listop->op_type = (OPCODE)type;
3029 listop->op_ppaddr = PL_ppaddr[type];
3032 listop->op_flags = (U8)flags;
3036 else if (!first && last)
3039 first->op_sibling = last;
3040 listop->op_first = first;
3041 listop->op_last = last;
3042 if (type == OP_LIST) {
3043 OP* const pushop = newOP(OP_PUSHMARK, 0);
3044 pushop->op_sibling = first;
3045 listop->op_first = pushop;
3046 listop->op_flags |= OPf_KIDS;
3048 listop->op_last = pushop;
3051 return CHECKOP(type, listop);
3055 Perl_newOP(pTHX_ I32 type, I32 flags)
3059 NewOp(1101, o, 1, OP);
3060 o->op_type = (OPCODE)type;
3061 o->op_ppaddr = PL_ppaddr[type];
3062 o->op_flags = (U8)flags;
3064 o->op_latefreed = 0;
3068 o->op_private = (U8)(0 | (flags >> 8));
3069 if (PL_opargs[type] & OA_RETSCALAR)
3071 if (PL_opargs[type] & OA_TARGET)
3072 o->op_targ = pad_alloc(type, SVs_PADTMP);
3073 return CHECKOP(type, o);
3077 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3083 first = newOP(OP_STUB, 0);
3084 if (PL_opargs[type] & OA_MARK)
3085 first = force_list(first);
3087 NewOp(1101, unop, 1, UNOP);
3088 unop->op_type = (OPCODE)type;
3089 unop->op_ppaddr = PL_ppaddr[type];
3090 unop->op_first = first;
3091 unop->op_flags = (U8)(flags | OPf_KIDS);
3092 unop->op_private = (U8)(1 | (flags >> 8));
3093 unop = (UNOP*) CHECKOP(type, unop);
3097 return fold_constants((OP *) unop);
3101 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3105 NewOp(1101, binop, 1, BINOP);
3108 first = newOP(OP_NULL, 0);
3110 binop->op_type = (OPCODE)type;
3111 binop->op_ppaddr = PL_ppaddr[type];
3112 binop->op_first = first;
3113 binop->op_flags = (U8)(flags | OPf_KIDS);
3116 binop->op_private = (U8)(1 | (flags >> 8));
3119 binop->op_private = (U8)(2 | (flags >> 8));
3120 first->op_sibling = last;
3123 binop = (BINOP*)CHECKOP(type, binop);
3124 if (binop->op_next || binop->op_type != (OPCODE)type)
3127 binop->op_last = binop->op_first->op_sibling;
3129 return fold_constants((OP *)binop);
3132 static int uvcompare(const void *a, const void *b)
3133 __attribute__nonnull__(1)
3134 __attribute__nonnull__(2)
3135 __attribute__pure__;
3136 static int uvcompare(const void *a, const void *b)
3138 if (*((const UV *)a) < (*(const UV *)b))
3140 if (*((const UV *)a) > (*(const UV *)b))
3142 if (*((const UV *)a+1) < (*(const UV *)b+1))
3144 if (*((const UV *)a+1) > (*(const UV *)b+1))
3150 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3153 SV * const tstr = ((SVOP*)expr)->op_sv;
3156 (repl->op_type == OP_NULL)
3157 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3159 ((SVOP*)repl)->op_sv;
3162 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3163 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3167 register short *tbl;
3169 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3170 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3171 I32 del = o->op_private & OPpTRANS_DELETE;
3174 PERL_ARGS_ASSERT_PMTRANS;
3176 PL_hints |= HINT_BLOCK_SCOPE;
3179 o->op_private |= OPpTRANS_FROM_UTF;
3182 o->op_private |= OPpTRANS_TO_UTF;
3184 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3185 SV* const listsv = newSVpvs("# comment\n");
3187 const U8* tend = t + tlen;
3188 const U8* rend = r + rlen;
3202 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3203 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3206 const U32 flags = UTF8_ALLOW_DEFAULT;
3210 t = tsave = bytes_to_utf8(t, &len);
3213 if (!to_utf && rlen) {
3215 r = rsave = bytes_to_utf8(r, &len);
3219 /* There are several snags with this code on EBCDIC:
3220 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3221 2. scan_const() in toke.c has encoded chars in native encoding which makes
3222 ranges at least in EBCDIC 0..255 range the bottom odd.
3226 U8 tmpbuf[UTF8_MAXBYTES+1];
3229 Newx(cp, 2*tlen, UV);
3231 transv = newSVpvs("");
3233 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3235 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3237 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3241 cp[2*i+1] = cp[2*i];
3245 qsort(cp, i, 2*sizeof(UV), uvcompare);
3246 for (j = 0; j < i; j++) {
3248 diff = val - nextmin;
3250 t = uvuni_to_utf8(tmpbuf,nextmin);
3251 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3253 U8 range_mark = UTF_TO_NATIVE(0xff);
3254 t = uvuni_to_utf8(tmpbuf, val - 1);
3255 sv_catpvn(transv, (char *)&range_mark, 1);
3256 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3263 t = uvuni_to_utf8(tmpbuf,nextmin);
3264 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3266 U8 range_mark = UTF_TO_NATIVE(0xff);
3267 sv_catpvn(transv, (char *)&range_mark, 1);
3269 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3270 UNICODE_ALLOW_SUPER);
3271 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3272 t = (const U8*)SvPVX_const(transv);
3273 tlen = SvCUR(transv);
3277 else if (!rlen && !del) {
3278 r = t; rlen = tlen; rend = tend;
3281 if ((!rlen && !del) || t == r ||
3282 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3284 o->op_private |= OPpTRANS_IDENTICAL;
3288 while (t < tend || tfirst <= tlast) {
3289 /* see if we need more "t" chars */
3290 if (tfirst > tlast) {
3291 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3293 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3295 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3302 /* now see if we need more "r" chars */
3303 if (rfirst > rlast) {
3305 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3307 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3309 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3318 rfirst = rlast = 0xffffffff;
3322 /* now see which range will peter our first, if either. */
3323 tdiff = tlast - tfirst;
3324 rdiff = rlast - rfirst;
3331 if (rfirst == 0xffffffff) {
3332 diff = tdiff; /* oops, pretend rdiff is infinite */
3334 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3335 (long)tfirst, (long)tlast);
3337 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3341 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3342 (long)tfirst, (long)(tfirst + diff),
3345 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3346 (long)tfirst, (long)rfirst);
3348 if (rfirst + diff > max)
3349 max = rfirst + diff;
3351 grows = (tfirst < rfirst &&
3352 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3364 else if (max > 0xff)
3369 PerlMemShared_free(cPVOPo->op_pv);
3370 cPVOPo->op_pv = NULL;
3372 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3374 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3375 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3376 PAD_SETSV(cPADOPo->op_padix, swash);
3378 SvREADONLY_on(swash);
3380 cSVOPo->op_sv = swash;
3382 SvREFCNT_dec(listsv);
3383 SvREFCNT_dec(transv);
3385 if (!del && havefinal && rlen)
3386 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3387 newSVuv((UV)final), 0);
3390 o->op_private |= OPpTRANS_GROWS;
3396 op_getmad(expr,o,'e');
3397 op_getmad(repl,o,'r');
3405 tbl = (short*)cPVOPo->op_pv;
3407 Zero(tbl, 256, short);
3408 for (i = 0; i < (I32)tlen; i++)
3410 for (i = 0, j = 0; i < 256; i++) {
3412 if (j >= (I32)rlen) {
3421 if (i < 128 && r[j] >= 128)
3431 o->op_private |= OPpTRANS_IDENTICAL;
3433 else if (j >= (I32)rlen)
3438 PerlMemShared_realloc(tbl,
3439 (0x101+rlen-j) * sizeof(short));
3440 cPVOPo->op_pv = (char*)tbl;
3442 tbl[0x100] = (short)(rlen - j);
3443 for (i=0; i < (I32)rlen - j; i++)
3444 tbl[0x101+i] = r[j+i];
3448 if (!rlen && !del) {
3451 o->op_private |= OPpTRANS_IDENTICAL;
3453 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3454 o->op_private |= OPpTRANS_IDENTICAL;
3456 for (i = 0; i < 256; i++)
3458 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3459 if (j >= (I32)rlen) {
3461 if (tbl[t[i]] == -1)
3467 if (tbl[t[i]] == -1) {
3468 if (t[i] < 128 && r[j] >= 128)
3475 if(del && rlen == tlen) {
3476 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3477 } else if(rlen > tlen) {
3478 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3482 o->op_private |= OPpTRANS_GROWS;
3484 op_getmad(expr,o,'e');
3485 op_getmad(repl,o,'r');
3495 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3500 NewOp(1101, pmop, 1, PMOP);
3501 pmop->op_type = (OPCODE)type;
3502 pmop->op_ppaddr = PL_ppaddr[type];
3503 pmop->op_flags = (U8)flags;
3504 pmop->op_private = (U8)(0 | (flags >> 8));
3506 if (PL_hints & HINT_RE_TAINT)
3507 pmop->op_pmflags |= PMf_RETAINT;
3508 if (PL_hints & HINT_LOCALE)
3509 pmop->op_pmflags |= PMf_LOCALE;
3513 assert(SvPOK(PL_regex_pad[0]));
3514 if (SvCUR(PL_regex_pad[0])) {
3515 /* Pop off the "packed" IV from the end. */
3516 SV *const repointer_list = PL_regex_pad[0];
3517 const char *p = SvEND(repointer_list) - sizeof(IV);
3518 const IV offset = *((IV*)p);
3520 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3522 SvEND_set(repointer_list, p);
3524 pmop->op_pmoffset = offset;
3525 /* This slot should be free, so assert this: */
3526 assert(PL_regex_pad[offset] == &PL_sv_undef);
3528 SV * const repointer = &PL_sv_undef;
3529 av_push(PL_regex_padav, repointer);
3530 pmop->op_pmoffset = av_len(PL_regex_padav);
3531 PL_regex_pad = AvARRAY(PL_regex_padav);
3535 return CHECKOP(type, pmop);
3538 /* Given some sort of match op o, and an expression expr containing a
3539 * pattern, either compile expr into a regex and attach it to o (if it's
3540 * constant), or convert expr into a runtime regcomp op sequence (if it's
3543 * isreg indicates that the pattern is part of a regex construct, eg
3544 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3545 * split "pattern", which aren't. In the former case, expr will be a list
3546 * if the pattern contains more than one term (eg /a$b/) or if it contains
3547 * a replacement, ie s/// or tr///.
3551 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3556 I32 repl_has_vars = 0;
3560 PERL_ARGS_ASSERT_PMRUNTIME;
3562 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3563 /* last element in list is the replacement; pop it */
3565 repl = cLISTOPx(expr)->op_last;
3566 kid = cLISTOPx(expr)->op_first;
3567 while (kid->op_sibling != repl)
3568 kid = kid->op_sibling;
3569 kid->op_sibling = NULL;
3570 cLISTOPx(expr)->op_last = kid;
3573 if (isreg && expr->op_type == OP_LIST &&
3574 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3576 /* convert single element list to element */
3577 OP* const oe = expr;
3578 expr = cLISTOPx(oe)->op_first->op_sibling;
3579 cLISTOPx(oe)->op_first->op_sibling = NULL;
3580 cLISTOPx(oe)->op_last = NULL;
3584 if (o->op_type == OP_TRANS) {
3585 return pmtrans(o, expr, repl);
3588 reglist = isreg && expr->op_type == OP_LIST;
3592 PL_hints |= HINT_BLOCK_SCOPE;
3595 if (expr->op_type == OP_CONST) {
3596 SV *pat = ((SVOP*)expr)->op_sv;
3597 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3599 if (o->op_flags & OPf_SPECIAL)
3600 pm_flags |= RXf_SPLIT;
3603 assert (SvUTF8(pat));
3604 } else if (SvUTF8(pat)) {
3605 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3606 trapped in use 'bytes'? */
3607 /* Make a copy of the octet sequence, but without the flag on, as
3608 the compiler now honours the SvUTF8 flag on pat. */
3610 const char *const p = SvPV(pat, len);
3611 pat = newSVpvn_flags(p, len, SVs_TEMP);
3614 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3617 op_getmad(expr,(OP*)pm,'e');
3623 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3624 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3626 : OP_REGCMAYBE),0,expr);
3628 NewOp(1101, rcop, 1, LOGOP);
3629 rcop->op_type = OP_REGCOMP;
3630 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3631 rcop->op_first = scalar(expr);
3632 rcop->op_flags |= OPf_KIDS
3633 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3634 | (reglist ? OPf_STACKED : 0);
3635 rcop->op_private = 1;
3638 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3640 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3643 /* establish postfix order */
3644 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3646 rcop->op_next = expr;
3647 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3650 rcop->op_next = LINKLIST(expr);
3651 expr->op_next = (OP*)rcop;
3654 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3659 if (pm->op_pmflags & PMf_EVAL) {
3661 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3662 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3664 else if (repl->op_type == OP_CONST)
3668 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3669 if (curop->op_type == OP_SCOPE
3670 || curop->op_type == OP_LEAVE
3671 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3672 if (curop->op_type == OP_GV) {
3673 GV * const gv = cGVOPx_gv(curop);
3675 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3678 else if (curop->op_type == OP_RV2CV)
3680 else if (curop->op_type == OP_RV2SV ||
3681 curop->op_type == OP_RV2AV ||
3682 curop->op_type == OP_RV2HV ||
3683 curop->op_type == OP_RV2GV) {
3684 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3687 else if (curop->op_type == OP_PADSV ||
3688 curop->op_type == OP_PADAV ||
3689 curop->op_type == OP_PADHV ||
3690 curop->op_type == OP_PADANY)
3694 else if (curop->op_type == OP_PUSHRE)
3695 NOOP; /* Okay here, dangerous in newASSIGNOP */
3705 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3707 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3708 prepend_elem(o->op_type, scalar(repl), o);
3711 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3712 pm->op_pmflags |= PMf_MAYBE_CONST;
3714 NewOp(1101, rcop, 1, LOGOP);
3715 rcop->op_type = OP_SUBSTCONT;
3716 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3717 rcop->op_first = scalar(repl);
3718 rcop->op_flags |= OPf_KIDS;
3719 rcop->op_private = 1;
3722 /* establish postfix order */
3723 rcop->op_next = LINKLIST(repl);
3724 repl->op_next = (OP*)rcop;
3726 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3727 assert(!(pm->op_pmflags & PMf_ONCE));
3728 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3737 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3742 PERL_ARGS_ASSERT_NEWSVOP;
3744 NewOp(1101, svop, 1, SVOP);
3745 svop->op_type = (OPCODE)type;
3746 svop->op_ppaddr = PL_ppaddr[type];
3748 svop->op_next = (OP*)svop;
3749 svop->op_flags = (U8)flags;
3750 if (PL_opargs[type] & OA_RETSCALAR)
3752 if (PL_opargs[type] & OA_TARGET)
3753 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3754 return CHECKOP(type, svop);
3759 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3764 PERL_ARGS_ASSERT_NEWPADOP;
3766 NewOp(1101, padop, 1, PADOP);
3767 padop->op_type = (OPCODE)type;
3768 padop->op_ppaddr = PL_ppaddr[type];
3769 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3770 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3771 PAD_SETSV(padop->op_padix, sv);
3774 padop->op_next = (OP*)padop;
3775 padop->op_flags = (U8)flags;
3776 if (PL_opargs[type] & OA_RETSCALAR)
3778 if (PL_opargs[type] & OA_TARGET)
3779 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3780 return CHECKOP(type, padop);
3785 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3789 PERL_ARGS_ASSERT_NEWGVOP;
3793 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3795 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3800 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3804 NewOp(1101, pvop, 1, PVOP);
3805 pvop->op_type = (OPCODE)type;
3806 pvop->op_ppaddr = PL_ppaddr[type];
3808 pvop->op_next = (OP*)pvop;
3809 pvop->op_flags = (U8)flags;
3810 if (PL_opargs[type] & OA_RETSCALAR)
3812 if (PL_opargs[type] & OA_TARGET)
3813 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3814 return CHECKOP(type, pvop);
3822 Perl_package(pTHX_ OP *o)
3825 SV *const sv = cSVOPo->op_sv;
3830 PERL_ARGS_ASSERT_PACKAGE;
3832 save_hptr(&PL_curstash);
3833 save_item(PL_curstname);
3835 PL_curstash = gv_stashsv(sv, GV_ADD);
3837 sv_setsv(PL_curstname, sv);
3839 PL_hints |= HINT_BLOCK_SCOPE;
3840 PL_parser->copline = NOLINE;
3841 PL_parser->expect = XSTATE;
3846 if (!PL_madskills) {
3851 pegop = newOP(OP_NULL,0);
3852 op_getmad(o,pegop,'P');
3858 Perl_package_version( pTHX_ OP *v )
3861 U32 savehints = PL_hints;
3862 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3863 PL_hints &= ~HINT_STRICT_VARS;
3864 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3865 PL_hints = savehints;
3874 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3881 OP *pegop = newOP(OP_NULL,0);
3884 PERL_ARGS_ASSERT_UTILIZE;
3886 if (idop->op_type != OP_CONST)
3887 Perl_croak(aTHX_ "Module name must be constant");
3890 op_getmad(idop,pegop,'U');
3895 SV * const vesv = ((SVOP*)version)->op_sv;
3898 op_getmad(version,pegop,'V');
3899 if (!arg && !SvNIOKp(vesv)) {
3906 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3907 Perl_croak(aTHX_ "Version number must be a constant number");
3909 /* Make copy of idop so we don't free it twice */
3910 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3912 /* Fake up a method call to VERSION */
3913 meth = newSVpvs_share("VERSION");
3914 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3915 append_elem(OP_LIST,
3916 prepend_elem(OP_LIST, pack, list(version)),
3917 newSVOP(OP_METHOD_NAMED, 0, meth)));
3921 /* Fake up an import/unimport */
3922 if (arg && arg->op_type == OP_STUB) {
3924 op_getmad(arg,pegop,'S');
3925 imop = arg; /* no import on explicit () */
3927 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3928 imop = NULL; /* use 5.0; */
3930 idop->op_private |= OPpCONST_NOVER;
3936 op_getmad(arg,pegop,'A');
3938 /* Make copy of idop so we don't free it twice */
3939 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3941 /* Fake up a method call to import/unimport */
3943 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3944 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3945 append_elem(OP_LIST,
3946 prepend_elem(OP_LIST, pack, list(arg)),
3947 newSVOP(OP_METHOD_NAMED, 0, meth)));
3950 /* Fake up the BEGIN {}, which does its thing immediately. */
3952 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3955 append_elem(OP_LINESEQ,
3956 append_elem(OP_LINESEQ,
3957 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3958 newSTATEOP(0, NULL, veop)),
3959 newSTATEOP(0, NULL, imop) ));
3961 /* The "did you use incorrect case?" warning used to be here.
3962 * The problem is that on case-insensitive filesystems one
3963 * might get false positives for "use" (and "require"):
3964 * "use Strict" or "require CARP" will work. This causes
3965 * portability problems for the script: in case-strict
3966 * filesystems the script will stop working.
3968 * The "incorrect case" warning checked whether "use Foo"
3969 * imported "Foo" to your namespace, but that is wrong, too:
3970 * there is no requirement nor promise in the language that
3971 * a Foo.pm should or would contain anything in package "Foo".
3973 * There is very little Configure-wise that can be done, either:
3974 * the case-sensitivity of the build filesystem of Perl does not
3975 * help in guessing the case-sensitivity of the runtime environment.
3978 PL_hints |= HINT_BLOCK_SCOPE;
3979 PL_parser->copline = NOLINE;
3980 PL_parser->expect = XSTATE;
3981 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3984 if (!PL_madskills) {
3985 /* FIXME - don't allocate pegop if !PL_madskills */
3994 =head1 Embedding Functions
3996 =for apidoc load_module
3998 Loads the module whose name is pointed to by the string part of name.
3999 Note that the actual module name, not its filename, should be given.
4000 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4001 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4002 (or 0 for no flags). ver, if specified, provides version semantics
4003 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4004 arguments can be used to specify arguments to the module's import()
4005 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4006 terminated with a final NULL pointer. Note that this list can only
4007 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4008 Otherwise at least a single NULL pointer to designate the default
4009 import list is required.
4014 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4018 PERL_ARGS_ASSERT_LOAD_MODULE;
4020 va_start(args, ver);
4021 vload_module(flags, name, ver, &args);
4025 #ifdef PERL_IMPLICIT_CONTEXT
4027 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4031 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4032 va_start(args, ver);
4033 vload_module(flags, name, ver, &args);
4039 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4043 OP * const modname = newSVOP(OP_CONST, 0, name);
4045 PERL_ARGS_ASSERT_VLOAD_MODULE;
4047 modname->op_private |= OPpCONST_BARE;
4049 veop = newSVOP(OP_CONST, 0, ver);
4053 if (flags & PERL_LOADMOD_NOIMPORT) {
4054 imop = sawparens(newNULLLIST());
4056 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4057 imop = va_arg(*args, OP*);
4062 sv = va_arg(*args, SV*);
4064 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4065 sv = va_arg(*args, SV*);
4069 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4070 * that it has a PL_parser to play with while doing that, and also
4071 * that it doesn't mess with any existing parser, by creating a tmp
4072 * new parser with lex_start(). This won't actually be used for much,
4073 * since pp_require() will create another parser for the real work. */
4076 SAVEVPTR(PL_curcop);
4077 lex_start(NULL, NULL, FALSE);
4078 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4079 veop, modname, imop);
4084 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4090 PERL_ARGS_ASSERT_DOFILE;
4092 if (!force_builtin) {
4093 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4094 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4095 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4096 gv = gvp ? *gvp : NULL;
4100 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4101 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4102 append_elem(OP_LIST, term,
4103 scalar(newUNOP(OP_RV2CV, 0,
4104 newGVOP(OP_GV, 0, gv))))));
4107 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4113 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4115 return newBINOP(OP_LSLICE, flags,
4116 list(force_list(subscript)),
4117 list(force_list(listval)) );
4121 S_is_list_assignment(pTHX_ register const OP *o)
4129 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4130 o = cUNOPo->op_first;
4132 flags = o->op_flags;
4134 if (type == OP_COND_EXPR) {
4135 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4136 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4141 yyerror("Assignment to both a list and a scalar");
4145 if (type == OP_LIST &&
4146 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4147 o->op_private & OPpLVAL_INTRO)
4150 if (type == OP_LIST || flags & OPf_PARENS ||
4151 type == OP_RV2AV || type == OP_RV2HV ||
4152 type == OP_ASLICE || type == OP_HSLICE)
4155 if (type == OP_PADAV || type == OP_PADHV)
4158 if (type == OP_RV2SV)
4165 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4171 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4172 return newLOGOP(optype, 0,
4173 mod(scalar(left), optype),
4174 newUNOP(OP_SASSIGN, 0, scalar(right)));
4177 return newBINOP(optype, OPf_STACKED,
4178 mod(scalar(left), optype), scalar(right));
4182 if (is_list_assignment(left)) {
4183 static const char no_list_state[] = "Initialization of state variables"
4184 " in list context currently forbidden";
4186 bool maybe_common_vars = TRUE;
4189 /* Grandfathering $[ assignment here. Bletch.*/
4190 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4191 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4192 left = mod(left, OP_AASSIGN);
4195 else if (left->op_type == OP_CONST) {
4197 /* Result of assignment is always 1 (or we'd be dead already) */
4198 return newSVOP(OP_CONST, 0, newSViv(1));
4200 curop = list(force_list(left));
4201 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4202 o->op_private = (U8)(0 | (flags >> 8));
4204 if ((left->op_type == OP_LIST
4205 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4207 OP* lop = ((LISTOP*)left)->op_first;
4208 maybe_common_vars = FALSE;
4210 if (lop->op_type == OP_PADSV ||
4211 lop->op_type == OP_PADAV ||
4212 lop->op_type == OP_PADHV ||
4213 lop->op_type == OP_PADANY) {
4214 if (!(lop->op_private & OPpLVAL_INTRO))
4215 maybe_common_vars = TRUE;
4217 if (lop->op_private & OPpPAD_STATE) {
4218 if (left->op_private & OPpLVAL_INTRO) {
4219 /* Each variable in state($a, $b, $c) = ... */
4222 /* Each state variable in
4223 (state $a, my $b, our $c, $d, undef) = ... */
4225 yyerror(no_list_state);
4227 /* Each my variable in
4228 (state $a, my $b, our $c, $d, undef) = ... */
4230 } else if (lop->op_type == OP_UNDEF ||
4231 lop->op_type == OP_PUSHMARK) {
4232 /* undef may be interesting in
4233 (state $a, undef, state $c) */
4235 /* Other ops in the list. */
4236 maybe_common_vars = TRUE;
4238 lop = lop->op_sibling;
4241 else if ((left->op_private & OPpLVAL_INTRO)
4242 && ( left->op_type == OP_PADSV
4243 || left->op_type == OP_PADAV
4244 || left->op_type == OP_PADHV
4245 || left->op_type == OP_PADANY))
4247 maybe_common_vars = FALSE;
4248 if (left->op_private & OPpPAD_STATE) {
4249 /* All single variable list context state assignments, hence
4259 yyerror(no_list_state);
4263 /* PL_generation sorcery:
4264 * an assignment like ($a,$b) = ($c,$d) is easier than
4265 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4266 * To detect whether there are common vars, the global var
4267 * PL_generation is incremented for each assign op we compile.
4268 * Then, while compiling the assign op, we run through all the
4269 * variables on both sides of the assignment, setting a spare slot
4270 * in each of them to PL_generation. If any of them already have
4271 * that value, we know we've got commonality. We could use a
4272 * single bit marker, but then we'd have to make 2 passes, first
4273 * to clear the flag, then to test and set it. To find somewhere
4274 * to store these values, evil chicanery is done with SvUVX().
4277 if (maybe_common_vars) {
4280 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4281 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4282 if (curop->op_type == OP_GV) {
4283 GV *gv = cGVOPx_gv(curop);
4285 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4287 GvASSIGN_GENERATION_set(gv, PL_generation);
4289 else if (curop->op_type == OP_PADSV ||
4290 curop->op_type == OP_PADAV ||
4291 curop->op_type == OP_PADHV ||
4292 curop->op_type == OP_PADANY)
4294 if (PAD_COMPNAME_GEN(curop->op_targ)
4295 == (STRLEN)PL_generation)
4297 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4300 else if (curop->op_type == OP_RV2CV)
4302 else if (curop->op_type == OP_RV2SV ||
4303 curop->op_type == OP_RV2AV ||
4304 curop->op_type == OP_RV2HV ||
4305 curop->op_type == OP_RV2GV) {
4306 if (lastop->op_type != OP_GV) /* funny deref? */
4309 else if (curop->op_type == OP_PUSHRE) {
4311 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4312 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4314 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4316 GvASSIGN_GENERATION_set(gv, PL_generation);
4320 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4323 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4325 GvASSIGN_GENERATION_set(gv, PL_generation);
4335 o->op_private |= OPpASSIGN_COMMON;
4338 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4339 OP* tmpop = ((LISTOP*)right)->op_first;
4340 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4341 PMOP * const pm = (PMOP*)tmpop;
4342 if (left->op_type == OP_RV2AV &&
4343 !(left->op_private & OPpLVAL_INTRO) &&
4344 !(o->op_private & OPpASSIGN_COMMON) )
4346 tmpop = ((UNOP*)left)->op_first;
4347 if (tmpop->op_type == OP_GV
4349 && !pm->op_pmreplrootu.op_pmtargetoff
4351 && !pm->op_pmreplrootu.op_pmtargetgv
4355 pm->op_pmreplrootu.op_pmtargetoff
4356 = cPADOPx(tmpop)->op_padix;
4357 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4359 pm->op_pmreplrootu.op_pmtargetgv
4360 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4361 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4363 pm->op_pmflags |= PMf_ONCE;
4364 tmpop = cUNOPo->op_first; /* to list (nulled) */
4365 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4366 tmpop->op_sibling = NULL; /* don't free split */
4367 right->op_next = tmpop->op_next; /* fix starting loc */
4368 op_free(o); /* blow off assign */
4369 right->op_flags &= ~OPf_WANT;
4370 /* "I don't know and I don't care." */
4375 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4376 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4378 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4379 if (SvIOK(sv) && SvIVX(sv) == 0)
4380 sv_setiv(sv, PL_modcount+1);
4388 right = newOP(OP_UNDEF, 0);
4389 if (right->op_type == OP_READLINE) {
4390 right->op_flags |= OPf_STACKED;
4391 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4394 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4395 o = newBINOP(OP_SASSIGN, flags,
4396 scalar(right), mod(scalar(left), OP_SASSIGN) );
4400 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4401 deprecate("assignment to $[");
4403 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4404 o->op_private |= OPpCONST_ARYBASE;
4412 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4415 const U32 seq = intro_my();
4418 NewOp(1101, cop, 1, COP);
4419 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4420 cop->op_type = OP_DBSTATE;
4421 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4424 cop->op_type = OP_NEXTSTATE;
4425 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4427 cop->op_flags = (U8)flags;
4428 CopHINTS_set(cop, PL_hints);
4430 cop->op_private |= NATIVE_HINTS;
4432 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4433 cop->op_next = (OP*)cop;
4436 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4437 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4439 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4440 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4441 if (cop->cop_hints_hash) {
4443 cop->cop_hints_hash->refcounted_he_refcnt++;
4444 HINTS_REFCNT_UNLOCK;
4448 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4450 PL_hints |= HINT_BLOCK_SCOPE;
4451 /* It seems that we need to defer freeing this pointer, as other parts
4452 of the grammar end up wanting to copy it after this op has been
4457 if (PL_parser && PL_parser->copline == NOLINE)
4458 CopLINE_set(cop, CopLINE(PL_curcop));
4460 CopLINE_set(cop, PL_parser->copline);
4462 PL_parser->copline = NOLINE;
4465 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4467 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4469 CopSTASH_set(cop, PL_curstash);
4471 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4472 /* this line can have a breakpoint - store the cop in IV */
4473 AV *av = CopFILEAVx(PL_curcop);
4475 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4476 if (svp && *svp != &PL_sv_undef ) {
4477 (void)SvIOK_on(*svp);
4478 SvIV_set(*svp, PTR2IV(cop));
4483 if (flags & OPf_SPECIAL)
4485 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4490 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4494 PERL_ARGS_ASSERT_NEWLOGOP;
4496 return new_logop(type, flags, &first, &other);
4500 S_search_const(pTHX_ OP *o)
4502 PERL_ARGS_ASSERT_SEARCH_CONST;
4504 switch (o->op_type) {
4508 if (o->op_flags & OPf_KIDS)
4509 return search_const(cUNOPo->op_first);
4516 if (!(o->op_flags & OPf_KIDS))
4518 kid = cLISTOPo->op_first;
4520 switch (kid->op_type) {
4524 kid = kid->op_sibling;
4527 if (kid != cLISTOPo->op_last)
4533 kid = cLISTOPo->op_last;
4535 return search_const(kid);
4543 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4551 int prepend_not = 0;
4553 PERL_ARGS_ASSERT_NEW_LOGOP;
4558 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4559 return newBINOP(type, flags, scalar(first), scalar(other));
4561 scalarboolean(first);
4562 /* optimize AND and OR ops that have NOTs as children */
4563 if (first->op_type == OP_NOT
4564 && (first->op_flags & OPf_KIDS)
4565 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4566 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4568 if (type == OP_AND || type == OP_OR) {
4574 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4576 prepend_not = 1; /* prepend a NOT op later */
4580 /* search for a constant op that could let us fold the test */
4581 if ((cstop = search_const(first))) {
4582 if (cstop->op_private & OPpCONST_STRICT)
4583 no_bareword_allowed(cstop);
4584 else if ((cstop->op_private & OPpCONST_BARE))
4585 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4586 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4587 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4588 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4590 if (other->op_type == OP_CONST)
4591 other->op_private |= OPpCONST_SHORTCIRCUIT;
4593 OP *newop = newUNOP(OP_NULL, 0, other);
4594 op_getmad(first, newop, '1');
4595 newop->op_targ = type; /* set "was" field */
4599 if (other->op_type == OP_LEAVE)
4600 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4604 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4605 const OP *o2 = other;
4606 if ( ! (o2->op_type == OP_LIST
4607 && (( o2 = cUNOPx(o2)->op_first))
4608 && o2->op_type == OP_PUSHMARK
4609 && (( o2 = o2->op_sibling)) )
4612 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4613 || o2->op_type == OP_PADHV)
4614 && o2->op_private & OPpLVAL_INTRO
4615 && !(o2->op_private & OPpPAD_STATE))
4617 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4618 "Deprecated use of my() in false conditional");
4622 if (first->op_type == OP_CONST)
4623 first->op_private |= OPpCONST_SHORTCIRCUIT;
4625 first = newUNOP(OP_NULL, 0, first);
4626 op_getmad(other, first, '2');
4627 first->op_targ = type; /* set "was" field */
4634 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4635 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4637 const OP * const k1 = ((UNOP*)first)->op_first;
4638 const OP * const k2 = k1->op_sibling;
4640 switch (first->op_type)
4643 if (k2 && k2->op_type == OP_READLINE
4644 && (k2->op_flags & OPf_STACKED)
4645 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4647 warnop = k2->op_type;
4652 if (k1->op_type == OP_READDIR
4653 || k1->op_type == OP_GLOB
4654 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4655 || k1->op_type == OP_EACH)
4657 warnop = ((k1->op_type == OP_NULL)
4658 ? (OPCODE)k1->op_targ : k1->op_type);
4663 const line_t oldline = CopLINE(PL_curcop);
4664 CopLINE_set(PL_curcop, PL_parser->copline);
4665 Perl_warner(aTHX_ packWARN(WARN_MISC),
4666 "Value of %s%s can be \"0\"; test with defined()",
4668 ((warnop == OP_READLINE || warnop == OP_GLOB)
4669 ? " construct" : "() operator"));
4670 CopLINE_set(PL_curcop, oldline);
4677 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4678 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4680 NewOp(1101, logop, 1, LOGOP);
4682 logop->op_type = (OPCODE)type;
4683 logop->op_ppaddr = PL_ppaddr[type];
4684 logop->op_first = first;
4685 logop->op_flags = (U8)(flags | OPf_KIDS);
4686 logop->op_other = LINKLIST(other);
4687 logop->op_private = (U8)(1 | (flags >> 8));
4689 /* establish postfix order */
4690 logop->op_next = LINKLIST(first);
4691 first->op_next = (OP*)logop;
4692 first->op_sibling = other;
4694 CHECKOP(type,logop);
4696 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4703 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4711 PERL_ARGS_ASSERT_NEWCONDOP;
4714 return newLOGOP(OP_AND, 0, first, trueop);
4716 return newLOGOP(OP_OR, 0, first, falseop);
4718 scalarboolean(first);
4719 if ((cstop = search_const(first))) {
4720 /* Left or right arm of the conditional? */
4721 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4722 OP *live = left ? trueop : falseop;
4723 OP *const dead = left ? falseop : trueop;
4724 if (cstop->op_private & OPpCONST_BARE &&
4725 cstop->op_private & OPpCONST_STRICT) {
4726 no_bareword_allowed(cstop);
4729 /* This is all dead code when PERL_MAD is not defined. */
4730 live = newUNOP(OP_NULL, 0, live);
4731 op_getmad(first, live, 'C');
4732 op_getmad(dead, live, left ? 'e' : 't');
4737 if (live->op_type == OP_LEAVE)
4738 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4741 NewOp(1101, logop, 1, LOGOP);
4742 logop->op_type = OP_COND_EXPR;
4743 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4744 logop->op_first = first;
4745 logop->op_flags = (U8)(flags | OPf_KIDS);
4746 logop->op_private = (U8)(1 | (flags >> 8));
4747 logop->op_other = LINKLIST(trueop);
4748 logop->op_next = LINKLIST(falseop);
4750 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4753 /* establish postfix order */
4754 start = LINKLIST(first);
4755 first->op_next = (OP*)logop;
4757 first->op_sibling = trueop;
4758 trueop->op_sibling = falseop;
4759 o = newUNOP(OP_NULL, 0, (OP*)logop);
4761 trueop->op_next = falseop->op_next = o;
4768 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4777 PERL_ARGS_ASSERT_NEWRANGE;
4779 NewOp(1101, range, 1, LOGOP);
4781 range->op_type = OP_RANGE;
4782 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4783 range->op_first = left;
4784 range->op_flags = OPf_KIDS;
4785 leftstart = LINKLIST(left);
4786 range->op_other = LINKLIST(right);
4787 range->op_private = (U8)(1 | (flags >> 8));
4789 left->op_sibling = right;
4791 range->op_next = (OP*)range;
4792 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4793 flop = newUNOP(OP_FLOP, 0, flip);
4794 o = newUNOP(OP_NULL, 0, flop);
4796 range->op_next = leftstart;
4798 left->op_next = flip;
4799 right->op_next = flop;
4801 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4802 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4803 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4804 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4806 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4807 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4810 if (!flip->op_private || !flop->op_private)
4811 linklist(o); /* blow off optimizer unless constant */
4817 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4822 const bool once = block && block->op_flags & OPf_SPECIAL &&
4823 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4825 PERL_UNUSED_ARG(debuggable);
4828 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4829 return block; /* do {} while 0 does once */
4830 if (expr->op_type == OP_READLINE
4831 || expr->op_type == OP_READDIR
4832 || expr->op_type == OP_GLOB
4833 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4834 expr = newUNOP(OP_DEFINED, 0,
4835 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4836 } else if (expr->op_flags & OPf_KIDS) {
4837 const OP * const k1 = ((UNOP*)expr)->op_first;
4838 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4839 switch (expr->op_type) {
4841 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4842 && (k2->op_flags & OPf_STACKED)
4843 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4844 expr = newUNOP(OP_DEFINED, 0, expr);
4848 if (k1 && (k1->op_type == OP_READDIR
4849 || k1->op_type == OP_GLOB
4850 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4851 || k1->op_type == OP_EACH))
4852 expr = newUNOP(OP_DEFINED, 0, expr);
4858 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4859 * op, in listop. This is wrong. [perl #27024] */
4861 block = newOP(OP_NULL, 0);
4862 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4863 o = new_logop(OP_AND, 0, &expr, &listop);
4866 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4868 if (once && o != listop)
4869 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4872 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4874 o->op_flags |= flags;
4876 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4881 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4882 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4891 PERL_UNUSED_ARG(debuggable);
4894 if (expr->op_type == OP_READLINE
4895 || expr->op_type == OP_READDIR
4896 || expr->op_type == OP_GLOB
4897 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4898 expr = newUNOP(OP_DEFINED, 0,
4899 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4900 } else if (expr->op_flags & OPf_KIDS) {
4901 const OP * const k1 = ((UNOP*)expr)->op_first;
4902 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4903 switch (expr->op_type) {
4905 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4906 && (k2->op_flags & OPf_STACKED)
4907 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4908 expr = newUNOP(OP_DEFINED, 0, expr);
4912 if (k1 && (k1->op_type == OP_READDIR
4913 || k1->op_type == OP_GLOB
4914 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4915 || k1->op_type == OP_EACH))
4916 expr = newUNOP(OP_DEFINED, 0, expr);
4923 block = newOP(OP_NULL, 0);
4924 else if (cont || has_my) {
4925 block = scope(block);
4929 next = LINKLIST(cont);
4932 OP * const unstack = newOP(OP_UNSTACK, 0);
4935 cont = append_elem(OP_LINESEQ, cont, unstack);
4939 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4941 redo = LINKLIST(listop);
4944 PL_parser->copline = (line_t)whileline;
4946 o = new_logop(OP_AND, 0, &expr, &listop);
4947 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4948 op_free(expr); /* oops, it's a while (0) */
4950 return NULL; /* listop already freed by new_logop */
4953 ((LISTOP*)listop)->op_last->op_next =
4954 (o == listop ? redo : LINKLIST(o));
4960 NewOp(1101,loop,1,LOOP);
4961 loop->op_type = OP_ENTERLOOP;
4962 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4963 loop->op_private = 0;
4964 loop->op_next = (OP*)loop;
4967 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4969 loop->op_redoop = redo;
4970 loop->op_lastop = o;
4971 o->op_private |= loopflags;
4974 loop->op_nextop = next;
4976 loop->op_nextop = o;
4978 o->op_flags |= flags;
4979 o->op_private |= (flags >> 8);
4984 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4989 PADOFFSET padoff = 0;
4994 PERL_ARGS_ASSERT_NEWFOROP;
4997 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4998 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4999 sv->op_type = OP_RV2GV;
5000 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5002 /* The op_type check is needed to prevent a possible segfault
5003 * if the loop variable is undeclared and 'strict vars' is in
5004 * effect. This is illegal but is nonetheless parsed, so we
5005 * may reach this point with an OP_CONST where we're expecting
5008 if (cUNOPx(sv)->op_first->op_type == OP_GV
5009 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5010 iterpflags |= OPpITER_DEF;
5012 else if (sv->op_type == OP_PADSV) { /* private variable */
5013 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5014 padoff = sv->op_targ;
5024 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5026 SV *const namesv = PAD_COMPNAME_SV(padoff);
5028 const char *const name = SvPV_const(namesv, len);
5030 if (len == 2 && name[0] == '$' && name[1] == '_')
5031 iterpflags |= OPpITER_DEF;
5035 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5036 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5037 sv = newGVOP(OP_GV, 0, PL_defgv);
5042 iterpflags |= OPpITER_DEF;
5044 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5045 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5046 iterflags |= OPf_STACKED;
5048 else if (expr->op_type == OP_NULL &&
5049 (expr->op_flags & OPf_KIDS) &&
5050 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5052 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5053 * set the STACKED flag to indicate that these values are to be
5054 * treated as min/max values by 'pp_iterinit'.
5056 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5057 LOGOP* const range = (LOGOP*) flip->op_first;
5058 OP* const left = range->op_first;
5059 OP* const right = left->op_sibling;
5062 range->op_flags &= ~OPf_KIDS;
5063 range->op_first = NULL;
5065 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5066 listop->op_first->op_next = range->op_next;
5067 left->op_next = range->op_other;
5068 right->op_next = (OP*)listop;
5069 listop->op_next = listop->op_first;
5072 op_getmad(expr,(OP*)listop,'O');
5076 expr = (OP*)(listop);
5078 iterflags |= OPf_STACKED;
5081 expr = mod(force_list(expr), OP_GREPSTART);
5084 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5085 append_elem(OP_LIST, expr, scalar(sv))));
5086 assert(!loop->op_next);
5087 /* for my $x () sets OPpLVAL_INTRO;
5088 * for our $x () sets OPpOUR_INTRO */
5089 loop->op_private = (U8)iterpflags;
5090 #ifdef PL_OP_SLAB_ALLOC
5093 NewOp(1234,tmp,1,LOOP);
5094 Copy(loop,tmp,1,LISTOP);
5095 S_op_destroy(aTHX_ (OP*)loop);
5099 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5101 loop->op_targ = padoff;
5102 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5104 op_getmad(madsv, (OP*)loop, 'v');
5105 PL_parser->copline = forline;
5106 return newSTATEOP(0, label, wop);
5110 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5115 PERL_ARGS_ASSERT_NEWLOOPEX;
5117 if (type != OP_GOTO || label->op_type == OP_CONST) {
5118 /* "last()" means "last" */
5119 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5120 o = newOP(type, OPf_SPECIAL);
5122 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5123 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5127 op_getmad(label,o,'L');
5133 /* Check whether it's going to be a goto &function */
5134 if (label->op_type == OP_ENTERSUB
5135 && !(label->op_flags & OPf_STACKED))
5136 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5137 o = newUNOP(type, OPf_STACKED, label);
5139 PL_hints |= HINT_BLOCK_SCOPE;
5143 /* if the condition is a literal array or hash
5144 (or @{ ... } etc), make a reference to it.
5147 S_ref_array_or_hash(pTHX_ OP *cond)
5150 && (cond->op_type == OP_RV2AV
5151 || cond->op_type == OP_PADAV
5152 || cond->op_type == OP_RV2HV
5153 || cond->op_type == OP_PADHV))
5155 return newUNOP(OP_REFGEN,
5156 0, mod(cond, OP_REFGEN));
5162 /* These construct the optree fragments representing given()
5165 entergiven and enterwhen are LOGOPs; the op_other pointer
5166 points up to the associated leave op. We need this so we
5167 can put it in the context and make break/continue work.
5168 (Also, of course, pp_enterwhen will jump straight to
5169 op_other if the match fails.)
5173 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5174 I32 enter_opcode, I32 leave_opcode,
5175 PADOFFSET entertarg)
5181 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5183 NewOp(1101, enterop, 1, LOGOP);
5184 enterop->op_type = (Optype)enter_opcode;
5185 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5186 enterop->op_flags = (U8) OPf_KIDS;
5187 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5188 enterop->op_private = 0;
5190 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5193 enterop->op_first = scalar(cond);
5194 cond->op_sibling = block;
5196 o->op_next = LINKLIST(cond);
5197 cond->op_next = (OP *) enterop;
5200 /* This is a default {} block */
5201 enterop->op_first = block;
5202 enterop->op_flags |= OPf_SPECIAL;
5204 o->op_next = (OP *) enterop;
5207 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5208 entergiven and enterwhen both
5211 enterop->op_next = LINKLIST(block);
5212 block->op_next = enterop->op_other = o;
5217 /* Does this look like a boolean operation? For these purposes
5218 a boolean operation is:
5219 - a subroutine call [*]
5220 - a logical connective
5221 - a comparison operator
5222 - a filetest operator, with the exception of -s -M -A -C
5223 - defined(), exists() or eof()
5224 - /$re/ or $foo =~ /$re/
5226 [*] possibly surprising
5229 S_looks_like_bool(pTHX_ const OP *o)
5233 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5235 switch(o->op_type) {
5238 return looks_like_bool(cLOGOPo->op_first);
5242 looks_like_bool(cLOGOPo->op_first)
5243 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5247 o->op_flags & OPf_KIDS
5248 && looks_like_bool(cUNOPo->op_first));
5251 return looks_like_bool(cUNOPo->op_first);
5256 case OP_NOT: case OP_XOR:
5258 case OP_EQ: case OP_NE: case OP_LT:
5259 case OP_GT: case OP_LE: case OP_GE:
5261 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5262 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5264 case OP_SEQ: case OP_SNE: case OP_SLT:
5265 case OP_SGT: case OP_SLE: case OP_SGE:
5269 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5270 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5271 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5272 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5273 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5274 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5275 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5276 case OP_FTTEXT: case OP_FTBINARY:
5278 case OP_DEFINED: case OP_EXISTS:
5279 case OP_MATCH: case OP_EOF:
5286 /* Detect comparisons that have been optimized away */
5287 if (cSVOPo->op_sv == &PL_sv_yes
5288 || cSVOPo->op_sv == &PL_sv_no)
5301 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5304 PERL_ARGS_ASSERT_NEWGIVENOP;
5305 return newGIVWHENOP(
5306 ref_array_or_hash(cond),
5308 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5312 /* If cond is null, this is a default {} block */
5314 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5316 const bool cond_llb = (!cond || looks_like_bool(cond));
5319 PERL_ARGS_ASSERT_NEWWHENOP;
5324 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5326 scalar(ref_array_or_hash(cond)));
5329 return newGIVWHENOP(
5331 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5332 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5336 =for apidoc cv_undef
5338 Clear out all the active components of a CV. This can happen either
5339 by an explicit C<undef &foo>, or by the reference count going to zero.
5340 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5341 children can still follow the full lexical scope chain.
5347 Perl_cv_undef(pTHX_ CV *cv)
5351 PERL_ARGS_ASSERT_CV_UNDEF;
5353 DEBUG_X(PerlIO_printf(Perl_debug_log,
5354 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5355 PTR2UV(cv), PTR2UV(PL_comppad))
5359 if (CvFILE(cv) && !CvISXSUB(cv)) {
5360 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5361 Safefree(CvFILE(cv));
5366 if (!CvISXSUB(cv) && CvROOT(cv)) {
5367 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5368 Perl_croak(aTHX_ "Can't undef active subroutine");
5371 PAD_SAVE_SETNULLPAD();
5373 op_free(CvROOT(cv));
5378 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5383 /* remove CvOUTSIDE unless this is an undef rather than a free */
5384 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5385 if (!CvWEAKOUTSIDE(cv))
5386 SvREFCNT_dec(CvOUTSIDE(cv));
5387 CvOUTSIDE(cv) = NULL;
5390 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5393 if (CvISXSUB(cv) && CvXSUB(cv)) {
5396 /* delete all flags except WEAKOUTSIDE */
5397 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5401 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5404 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5406 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5407 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5408 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5409 || (p && (len != SvCUR(cv) /* Not the same length. */
5410 || memNE(p, SvPVX_const(cv), len))))
5411 && ckWARN_d(WARN_PROTOTYPE)) {
5412 SV* const msg = sv_newmortal();
5416 gv_efullname3(name = sv_newmortal(), gv, NULL);
5417 sv_setpvs(msg, "Prototype mismatch:");
5419 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5421 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5423 sv_catpvs(msg, ": none");
5424 sv_catpvs(msg, " vs ");
5426 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5428 sv_catpvs(msg, "none");
5429 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5433 static void const_sv_xsub(pTHX_ CV* cv);
5437 =head1 Optree Manipulation Functions
5439 =for apidoc cv_const_sv
5441 If C<cv> is a constant sub eligible for inlining. returns the constant
5442 value returned by the sub. Otherwise, returns NULL.
5444 Constant subs can be created with C<newCONSTSUB> or as described in
5445 L<perlsub/"Constant Functions">.
5450 Perl_cv_const_sv(pTHX_ const CV *const cv)
5452 PERL_UNUSED_CONTEXT;
5455 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5457 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5460 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5461 * Can be called in 3 ways:
5464 * look for a single OP_CONST with attached value: return the value
5466 * cv && CvCLONE(cv) && !CvCONST(cv)
5468 * examine the clone prototype, and if contains only a single
5469 * OP_CONST referencing a pad const, or a single PADSV referencing
5470 * an outer lexical, return a non-zero value to indicate the CV is
5471 * a candidate for "constizing" at clone time
5475 * We have just cloned an anon prototype that was marked as a const
5476 * candidiate. Try to grab the current value, and in the case of
5477 * PADSV, ignore it if it has multiple references. Return the value.
5481 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5492 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5493 o = cLISTOPo->op_first->op_sibling;
5495 for (; o; o = o->op_next) {
5496 const OPCODE type = o->op_type;
5498 if (sv && o->op_next == o)
5500 if (o->op_next != o) {
5501 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5503 if (type == OP_DBSTATE)
5506 if (type == OP_LEAVESUB || type == OP_RETURN)
5510 if (type == OP_CONST && cSVOPo->op_sv)
5512 else if (cv && type == OP_CONST) {
5513 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5517 else if (cv && type == OP_PADSV) {
5518 if (CvCONST(cv)) { /* newly cloned anon */
5519 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5520 /* the candidate should have 1 ref from this pad and 1 ref
5521 * from the parent */
5522 if (!sv || SvREFCNT(sv) != 2)
5529 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5530 sv = &PL_sv_undef; /* an arbitrary non-null value */
5545 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5548 /* This would be the return value, but the return cannot be reached. */
5549 OP* pegop = newOP(OP_NULL, 0);
5552 PERL_UNUSED_ARG(floor);
5562 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5564 NORETURN_FUNCTION_END;
5569 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5571 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5575 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5581 register CV *cv = NULL;
5583 /* If the subroutine has no body, no attributes, and no builtin attributes
5584 then it's just a sub declaration, and we may be able to get away with
5585 storing with a placeholder scalar in the symbol table, rather than a
5586 full GV and CV. If anything is present then it will take a full CV to
5588 const I32 gv_fetch_flags
5589 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5591 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5592 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5596 assert(proto->op_type == OP_CONST);
5597 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5603 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5605 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5606 SV * const sv = sv_newmortal();
5607 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5608 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5609 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5610 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5612 } else if (PL_curstash) {
5613 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5616 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5620 if (!PL_madskills) {
5629 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5630 maximum a prototype before. */
5631 if (SvTYPE(gv) > SVt_NULL) {
5632 if (!SvPOK((const SV *)gv)
5633 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5635 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5637 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5640 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5642 sv_setiv(MUTABLE_SV(gv), -1);
5644 SvREFCNT_dec(PL_compcv);
5645 cv = PL_compcv = NULL;
5649 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5651 if (!block || !ps || *ps || attrs
5652 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5654 || block->op_type == OP_NULL
5659 const_sv = op_const_sv(block, NULL);
5662 const bool exists = CvROOT(cv) || CvXSUB(cv);
5664 /* if the subroutine doesn't exist and wasn't pre-declared
5665 * with a prototype, assume it will be AUTOLOADed,
5666 * skipping the prototype check
5668 if (exists || SvPOK(cv))
5669 cv_ckproto_len(cv, gv, ps, ps_len);
5670 /* already defined (or promised)? */
5671 if (exists || GvASSUMECV(gv)) {
5674 || block->op_type == OP_NULL
5677 if (CvFLAGS(PL_compcv)) {
5678 /* might have had built-in attrs applied */
5679 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5681 /* just a "sub foo;" when &foo is already defined */
5682 SAVEFREESV(PL_compcv);
5687 && block->op_type != OP_NULL
5690 if (ckWARN(WARN_REDEFINE)
5692 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5694 const line_t oldline = CopLINE(PL_curcop);
5695 if (PL_parser && PL_parser->copline != NOLINE)
5696 CopLINE_set(PL_curcop, PL_parser->copline);
5697 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5698 CvCONST(cv) ? "Constant subroutine %s redefined"
5699 : "Subroutine %s redefined", name);
5700 CopLINE_set(PL_curcop, oldline);
5703 if (!PL_minus_c) /* keep old one around for madskills */
5706 /* (PL_madskills unset in used file.) */
5714 SvREFCNT_inc_simple_void_NN(const_sv);
5716 assert(!CvROOT(cv) && !CvCONST(cv));
5717 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5718 CvXSUBANY(cv).any_ptr = const_sv;
5719 CvXSUB(cv) = const_sv_xsub;
5725 cv = newCONSTSUB(NULL, name, const_sv);
5727 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5728 (CvGV(cv) && GvSTASH(CvGV(cv)))
5737 SvREFCNT_dec(PL_compcv);
5741 if (cv) { /* must reuse cv if autoloaded */
5742 /* transfer PL_compcv to cv */
5745 && block->op_type != OP_NULL
5749 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5750 if (!CvWEAKOUTSIDE(cv))
5751 SvREFCNT_dec(CvOUTSIDE(cv));
5752 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5753 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5754 CvOUTSIDE(PL_compcv) = 0;
5755 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5756 CvPADLIST(PL_compcv) = 0;
5757 /* inner references to PL_compcv must be fixed up ... */
5758 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5759 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5760 ++PL_sub_generation;
5763 /* Might have had built-in attributes applied -- propagate them. */
5764 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5766 /* ... before we throw it away */
5767 SvREFCNT_dec(PL_compcv);
5775 if (strEQ(name, "import")) {
5776 PL_formfeed = MUTABLE_SV(cv);
5777 /* diag_listed_as: SKIPME */
5778 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", (UV)cv);
5782 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5787 CvFILE_set_from_cop(cv, PL_curcop);
5788 CvSTASH(cv) = PL_curstash;
5791 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5792 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5793 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5797 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5799 if (PL_parser && PL_parser->error_count) {
5803 const char *s = strrchr(name, ':');
5805 if (strEQ(s, "BEGIN")) {
5806 const char not_safe[] =
5807 "BEGIN not safe after errors--compilation aborted";
5808 if (PL_in_eval & EVAL_KEEPERR)
5809 Perl_croak(aTHX_ not_safe);
5811 /* force display of errors found but not reported */
5812 sv_catpv(ERRSV, not_safe);
5813 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5822 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5823 the debugger could be able to set a breakpoint in, so signal to
5824 pp_entereval that it should not throw away any saved lines at scope
5827 PL_breakable_sub_gen++;
5829 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5830 mod(scalarseq(block), OP_LEAVESUBLV));
5831 block->op_attached = 1;
5834 /* This makes sub {}; work as expected. */
5835 if (block->op_type == OP_STUB) {
5836 OP* const newblock = newSTATEOP(0, NULL, 0);
5838 op_getmad(block,newblock,'B');
5845 block->op_attached = 1;
5846 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5848 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5849 OpREFCNT_set(CvROOT(cv), 1);
5850 CvSTART(cv) = LINKLIST(CvROOT(cv));
5851 CvROOT(cv)->op_next = 0;
5852 CALL_PEEP(CvSTART(cv));
5854 /* now that optimizer has done its work, adjust pad values */
5856 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5859 assert(!CvCONST(cv));
5860 if (ps && !*ps && op_const_sv(block, cv))
5865 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5866 SV * const sv = newSV(0);
5867 SV * const tmpstr = sv_newmortal();
5868 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5869 GV_ADDMULTI, SVt_PVHV);
5872 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5874 (long)PL_subline, (long)CopLINE(PL_curcop));
5875 gv_efullname3(tmpstr, gv, NULL);
5876 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5877 SvCUR(tmpstr), sv, 0);
5878 hv = GvHVn(db_postponed);
5879 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5880 CV * const pcv = GvCV(db_postponed);
5886 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5891 if (name && ! (PL_parser && PL_parser->error_count))
5892 process_special_blocks(name, gv, cv);
5897 PL_parser->copline = NOLINE;
5903 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5906 const char *const colon = strrchr(fullname,':');
5907 const char *const name = colon ? colon + 1 : fullname;
5909 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5912 if (strEQ(name, "BEGIN")) {
5913 const I32 oldscope = PL_scopestack_ix;
5915 SAVECOPFILE(&PL_compiling);
5916 SAVECOPLINE(&PL_compiling);
5918 DEBUG_x( dump_sub(gv) );
5919 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5920 GvCV(gv) = 0; /* cv has been hijacked */
5921 call_list(oldscope, PL_beginav);
5923 PL_curcop = &PL_compiling;
5924 CopHINTS_set(&PL_compiling, PL_hints);
5931 if strEQ(name, "END") {
5932 DEBUG_x( dump_sub(gv) );
5933 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5936 } else if (*name == 'U') {
5937 if (strEQ(name, "UNITCHECK")) {
5938 /* It's never too late to run a unitcheck block */
5939 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5943 } else if (*name == 'C') {
5944 if (strEQ(name, "CHECK")) {
5946 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5947 "Too late to run CHECK block");
5948 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5952 } else if (*name == 'I') {
5953 if (strEQ(name, "INIT")) {
5955 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5956 "Too late to run INIT block");
5957 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5963 DEBUG_x( dump_sub(gv) );
5964 GvCV(gv) = 0; /* cv has been hijacked */
5969 =for apidoc newCONSTSUB
5971 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5972 eligible for inlining at compile-time.
5974 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5975 which won't be called if used as a destructor, but will suppress the overhead
5976 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5983 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5988 const char *const file = CopFILE(PL_curcop);
5990 SV *const temp_sv = CopFILESV(PL_curcop);
5991 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5996 if (IN_PERL_RUNTIME) {
5997 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5998 * an op shared between threads. Use a non-shared COP for our
6000 SAVEVPTR(PL_curcop);
6001 PL_curcop = &PL_compiling;
6003 SAVECOPLINE(PL_curcop);
6004 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6007 PL_hints &= ~HINT_BLOCK_SCOPE;
6010 SAVESPTR(PL_curstash);
6011 SAVECOPSTASH(PL_curcop);
6012 PL_curstash = stash;
6013 CopSTASH_set(PL_curcop,stash);
6016 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6017 and so doesn't get free()d. (It's expected to be from the C pre-
6018 processor __FILE__ directive). But we need a dynamically allocated one,
6019 and we need it to get freed. */
6020 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6021 XS_DYNAMIC_FILENAME);
6022 CvXSUBANY(cv).any_ptr = sv;
6027 CopSTASH_free(PL_curcop);
6035 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6036 const char *const filename, const char *const proto,
6039 CV *cv = newXS(name, subaddr, filename);
6041 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6043 if (flags & XS_DYNAMIC_FILENAME) {
6044 /* We need to "make arrangements" (ie cheat) to ensure that the
6045 filename lasts as long as the PVCV we just created, but also doesn't
6047 STRLEN filename_len = strlen(filename);
6048 STRLEN proto_and_file_len = filename_len;
6049 char *proto_and_file;
6053 proto_len = strlen(proto);
6054 proto_and_file_len += proto_len;
6056 Newx(proto_and_file, proto_and_file_len + 1, char);
6057 Copy(proto, proto_and_file, proto_len, char);
6058 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6061 proto_and_file = savepvn(filename, filename_len);
6064 /* This gets free()d. :-) */
6065 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6066 SV_HAS_TRAILING_NUL);
6068 /* This gives us the correct prototype, rather than one with the
6069 file name appended. */
6070 SvCUR_set(cv, proto_len);
6074 CvFILE(cv) = proto_and_file + proto_len;
6076 sv_setpv(MUTABLE_SV(cv), proto);
6082 =for apidoc U||newXS
6084 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6085 static storage, as it is used directly as CvFILE(), without a copy being made.
6091 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6094 GV * const gv = gv_fetchpv(name ? name :
6095 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6096 GV_ADDMULTI, SVt_PVCV);
6099 PERL_ARGS_ASSERT_NEWXS;
6102 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6104 if ((cv = (name ? GvCV(gv) : NULL))) {
6106 /* just a cached method */
6110 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6111 /* already defined (or promised) */
6112 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6113 if (ckWARN(WARN_REDEFINE)) {
6114 GV * const gvcv = CvGV(cv);
6116 HV * const stash = GvSTASH(gvcv);
6118 const char *redefined_name = HvNAME_get(stash);
6119 if ( strEQ(redefined_name,"autouse") ) {
6120 const line_t oldline = CopLINE(PL_curcop);
6121 if (PL_parser && PL_parser->copline != NOLINE)
6122 CopLINE_set(PL_curcop, PL_parser->copline);
6123 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6124 CvCONST(cv) ? "Constant subroutine %s redefined"
6125 : "Subroutine %s redefined"
6127 CopLINE_set(PL_curcop, oldline);
6137 if (cv) /* must reuse cv if autoloaded */
6140 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6144 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6148 (void)gv_fetchfile(filename);
6149 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6150 an external constant string */
6152 CvXSUB(cv) = subaddr;
6155 process_special_blocks(name, gv, cv);
6167 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6172 OP* pegop = newOP(OP_NULL, 0);
6176 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6177 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6180 if ((cv = GvFORM(gv))) {
6181 if (ckWARN(WARN_REDEFINE)) {
6182 const line_t oldline = CopLINE(PL_curcop);
6183 if (PL_parser && PL_parser->copline != NOLINE)
6184 CopLINE_set(PL_curcop, PL_parser->copline);
6186 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6187 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6189 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6190 "Format STDOUT redefined");
6192 CopLINE_set(PL_curcop, oldline);
6199 CvFILE_set_from_cop(cv, PL_curcop);
6202 pad_tidy(padtidy_FORMAT);
6203 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6204 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6205 OpREFCNT_set(CvROOT(cv), 1);
6206 CvSTART(cv) = LINKLIST(CvROOT(cv));
6207 CvROOT(cv)->op_next = 0;
6208 CALL_PEEP(CvSTART(cv));
6210 op_getmad(o,pegop,'n');
6211 op_getmad_weak(block, pegop, 'b');
6216 PL_parser->copline = NOLINE;
6224 Perl_newANONLIST(pTHX_ OP *o)
6226 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6230 Perl_newANONHASH(pTHX_ OP *o)
6232 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6236 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6238 return newANONATTRSUB(floor, proto, NULL, block);
6242 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6244 return newUNOP(OP_REFGEN, 0,
6245 newSVOP(OP_ANONCODE, 0,
6246 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6250 Perl_oopsAV(pTHX_ OP *o)
6254 PERL_ARGS_ASSERT_OOPSAV;
6256 switch (o->op_type) {
6258 o->op_type = OP_PADAV;
6259 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6260 return ref(o, OP_RV2AV);
6263 o->op_type = OP_RV2AV;
6264 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6269 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6276 Perl_oopsHV(pTHX_ OP *o)
6280 PERL_ARGS_ASSERT_OOPSHV;
6282 switch (o->op_type) {
6285 o->op_type = OP_PADHV;
6286 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6287 return ref(o, OP_RV2HV);
6291 o->op_type = OP_RV2HV;
6292 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6297 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6304 Perl_newAVREF(pTHX_ OP *o)
6308 PERL_ARGS_ASSERT_NEWAVREF;
6310 if (o->op_type == OP_PADANY) {
6311 o->op_type = OP_PADAV;
6312 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6315 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6316 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6317 "Using an array as a reference is deprecated");
6319 return newUNOP(OP_RV2AV, 0, scalar(o));
6323 Perl_newGVREF(pTHX_ I32 type, OP *o)
6325 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6326 return newUNOP(OP_NULL, 0, o);
6327 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6331 Perl_newHVREF(pTHX_ OP *o)
6335 PERL_ARGS_ASSERT_NEWHVREF;
6337 if (o->op_type == OP_PADANY) {
6338 o->op_type = OP_PADHV;
6339 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6342 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6343 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6344 "Using a hash as a reference is deprecated");
6346 return newUNOP(OP_RV2HV, 0, scalar(o));
6350 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6352 return newUNOP(OP_RV2CV, flags, scalar(o));
6356 Perl_newSVREF(pTHX_ OP *o)
6360 PERL_ARGS_ASSERT_NEWSVREF;
6362 if (o->op_type == OP_PADANY) {
6363 o->op_type = OP_PADSV;
6364 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6367 return newUNOP(OP_RV2SV, 0, scalar(o));
6370 /* Check routines. See the comments at the top of this file for details
6371 * on when these are called */
6374 Perl_ck_anoncode(pTHX_ OP *o)
6376 PERL_ARGS_ASSERT_CK_ANONCODE;
6378 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6380 cSVOPo->op_sv = NULL;
6385 Perl_ck_bitop(pTHX_ OP *o)
6389 PERL_ARGS_ASSERT_CK_BITOP;
6391 #define OP_IS_NUMCOMPARE(op) \
6392 ((op) == OP_LT || (op) == OP_I_LT || \
6393 (op) == OP_GT || (op) == OP_I_GT || \
6394 (op) == OP_LE || (op) == OP_I_LE || \
6395 (op) == OP_GE || (op) == OP_I_GE || \
6396 (op) == OP_EQ || (op) == OP_I_EQ || \
6397 (op) == OP_NE || (op) == OP_I_NE || \
6398 (op) == OP_NCMP || (op) == OP_I_NCMP)
6399 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6400 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6401 && (o->op_type == OP_BIT_OR
6402 || o->op_type == OP_BIT_AND
6403 || o->op_type == OP_BIT_XOR))
6405 const OP * const left = cBINOPo->op_first;
6406 const OP * const right = left->op_sibling;
6407 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6408 (left->op_flags & OPf_PARENS) == 0) ||
6409 (OP_IS_NUMCOMPARE(right->op_type) &&
6410 (right->op_flags & OPf_PARENS) == 0))
6411 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6412 "Possible precedence problem on bitwise %c operator",
6413 o->op_type == OP_BIT_OR ? '|'
6414 : o->op_type == OP_BIT_AND ? '&' : '^'
6421 Perl_ck_concat(pTHX_ OP *o)
6423 const OP * const kid = cUNOPo->op_first;
6425 PERL_ARGS_ASSERT_CK_CONCAT;
6426 PERL_UNUSED_CONTEXT;
6428 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6429 !(kUNOP->op_first->op_flags & OPf_MOD))
6430 o->op_flags |= OPf_STACKED;
6435 Perl_ck_spair(pTHX_ OP *o)
6439 PERL_ARGS_ASSERT_CK_SPAIR;
6441 if (o->op_flags & OPf_KIDS) {
6444 const OPCODE type = o->op_type;
6445 o = modkids(ck_fun(o), type);
6446 kid = cUNOPo->op_first;
6447 newop = kUNOP->op_first->op_sibling;
6449 const OPCODE type = newop->op_type;
6450 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6451 type == OP_PADAV || type == OP_PADHV ||
6452 type == OP_RV2AV || type == OP_RV2HV)
6456 op_getmad(kUNOP->op_first,newop,'K');
6458 op_free(kUNOP->op_first);
6460 kUNOP->op_first = newop;
6462 o->op_ppaddr = PL_ppaddr[++o->op_type];
6467 Perl_ck_delete(pTHX_ OP *o)
6469 PERL_ARGS_ASSERT_CK_DELETE;
6473 if (o->op_flags & OPf_KIDS) {
6474 OP * const kid = cUNOPo->op_first;
6475 switch (kid->op_type) {
6477 o->op_flags |= OPf_SPECIAL;
6480 o->op_private |= OPpSLICE;
6483 o->op_flags |= OPf_SPECIAL;
6488 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6491 if (kid->op_private & OPpLVAL_INTRO)
6492 o->op_private |= OPpLVAL_INTRO;
6499 Perl_ck_die(pTHX_ OP *o)
6501 PERL_ARGS_ASSERT_CK_DIE;
6504 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6510 Perl_ck_eof(pTHX_ OP *o)
6514 PERL_ARGS_ASSERT_CK_EOF;
6516 if (o->op_flags & OPf_KIDS) {
6517 if (cLISTOPo->op_first->op_type == OP_STUB) {
6519 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6521 op_getmad(o,newop,'O');
6533 Perl_ck_eval(pTHX_ OP *o)
6537 PERL_ARGS_ASSERT_CK_EVAL;
6539 PL_hints |= HINT_BLOCK_SCOPE;
6540 if (o->op_flags & OPf_KIDS) {
6541 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6544 o->op_flags &= ~OPf_KIDS;
6547 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6553 cUNOPo->op_first = 0;
6558 NewOp(1101, enter, 1, LOGOP);
6559 enter->op_type = OP_ENTERTRY;
6560 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6561 enter->op_private = 0;
6563 /* establish postfix order */
6564 enter->op_next = (OP*)enter;
6566 CHECKOP(OP_ENTERTRY, enter);
6568 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6569 o->op_type = OP_LEAVETRY;
6570 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6571 enter->op_other = o;
6572 op_getmad(oldo,o,'O');
6586 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6587 op_getmad(oldo,o,'O');
6589 o->op_targ = (PADOFFSET)PL_hints;
6590 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6591 /* Store a copy of %^H that pp_entereval can pick up. */
6592 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6593 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6594 cUNOPo->op_first->op_sibling = hhop;
6595 o->op_private |= OPpEVAL_HAS_HH;
6601 Perl_ck_exit(pTHX_ OP *o)
6603 PERL_ARGS_ASSERT_CK_EXIT;
6606 HV * const table = GvHV(PL_hintgv);
6608 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6609 if (svp && *svp && SvTRUE(*svp))
6610 o->op_private |= OPpEXIT_VMSISH;
6612 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6618 Perl_ck_exec(pTHX_ OP *o)
6620 PERL_ARGS_ASSERT_CK_EXEC;
6622 if (o->op_flags & OPf_STACKED) {
6625 kid = cUNOPo->op_first->op_sibling;
6626 if (kid->op_type == OP_RV2GV)
6635 Perl_ck_exists(pTHX_ OP *o)
6639 PERL_ARGS_ASSERT_CK_EXISTS;
6642 if (o->op_flags & OPf_KIDS) {
6643 OP * const kid = cUNOPo->op_first;
6644 if (kid->op_type == OP_ENTERSUB) {
6645 (void) ref(kid, o->op_type);
6646 if (kid->op_type != OP_RV2CV
6647 && !(PL_parser && PL_parser->error_count))
6648 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6650 o->op_private |= OPpEXISTS_SUB;
6652 else if (kid->op_type == OP_AELEM)
6653 o->op_flags |= OPf_SPECIAL;
6654 else if (kid->op_type != OP_HELEM)
6655 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6663 Perl_ck_rvconst(pTHX_ register OP *o)
6666 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6668 PERL_ARGS_ASSERT_CK_RVCONST;
6670 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6671 if (o->op_type == OP_RV2CV)
6672 o->op_private &= ~1;
6674 if (kid->op_type == OP_CONST) {
6677 SV * const kidsv = kid->op_sv;
6679 /* Is it a constant from cv_const_sv()? */
6680 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6681 SV * const rsv = SvRV(kidsv);
6682 const svtype type = SvTYPE(rsv);
6683 const char *badtype = NULL;
6685 switch (o->op_type) {
6687 if (type > SVt_PVMG)
6688 badtype = "a SCALAR";
6691 if (type != SVt_PVAV)
6692 badtype = "an ARRAY";
6695 if (type != SVt_PVHV)
6699 if (type != SVt_PVCV)
6704 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6707 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6708 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6709 /* If this is an access to a stash, disable "strict refs", because
6710 * stashes aren't auto-vivified at compile-time (unless we store
6711 * symbols in them), and we don't want to produce a run-time
6712 * stricture error when auto-vivifying the stash. */
6713 const char *s = SvPV_nolen(kidsv);
6714 const STRLEN l = SvCUR(kidsv);
6715 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6716 o->op_private &= ~HINT_STRICT_REFS;
6718 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6719 const char *badthing;
6720 switch (o->op_type) {
6722 badthing = "a SCALAR";
6725 badthing = "an ARRAY";
6728 badthing = "a HASH";
6736 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6737 SVfARG(kidsv), badthing);
6740 * This is a little tricky. We only want to add the symbol if we
6741 * didn't add it in the lexer. Otherwise we get duplicate strict
6742 * warnings. But if we didn't add it in the lexer, we must at
6743 * least pretend like we wanted to add it even if it existed before,
6744 * or we get possible typo warnings. OPpCONST_ENTERED says
6745 * whether the lexer already added THIS instance of this symbol.
6747 iscv = (o->op_type == OP_RV2CV) * 2;
6749 gv = gv_fetchsv(kidsv,
6750 iscv | !(kid->op_private & OPpCONST_ENTERED),
6753 : o->op_type == OP_RV2SV
6755 : o->op_type == OP_RV2AV
6757 : o->op_type == OP_RV2HV
6760 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6762 kid->op_type = OP_GV;
6763 SvREFCNT_dec(kid->op_sv);
6765 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6766 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6767 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6769 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6771 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6773 kid->op_private = 0;
6774 kid->op_ppaddr = PL_ppaddr[OP_GV];
6781 Perl_ck_ftst(pTHX_ OP *o)
6784 const I32 type = o->op_type;
6786 PERL_ARGS_ASSERT_CK_FTST;
6788 if (o->op_flags & OPf_REF) {
6791 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6792 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6793 const OPCODE kidtype = kid->op_type;
6795 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6796 OP * const newop = newGVOP(type, OPf_REF,
6797 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6799 op_getmad(o,newop,'O');
6805 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6806 o->op_private |= OPpFT_ACCESS;
6807 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6808 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6809 o->op_private |= OPpFT_STACKED;
6817 if (type == OP_FTTTY)
6818 o = newGVOP(type, OPf_REF, PL_stdingv);
6820 o = newUNOP(type, 0, newDEFSVOP());
6821 op_getmad(oldo,o,'O');
6827 Perl_ck_fun(pTHX_ OP *o)
6830 const int type = o->op_type;
6831 register I32 oa = PL_opargs[type] >> OASHIFT;
6833 PERL_ARGS_ASSERT_CK_FUN;
6835 if (o->op_flags & OPf_STACKED) {
6836 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6839 return no_fh_allowed(o);
6842 if (o->op_flags & OPf_KIDS) {
6843 OP **tokid = &cLISTOPo->op_first;
6844 register OP *kid = cLISTOPo->op_first;
6848 if (kid->op_type == OP_PUSHMARK ||
6849 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6851 tokid = &kid->op_sibling;
6852 kid = kid->op_sibling;
6854 if (!kid && PL_opargs[type] & OA_DEFGV)
6855 *tokid = kid = newDEFSVOP();
6859 sibl = kid->op_sibling;
6861 if (!sibl && kid->op_type == OP_STUB) {
6868 /* list seen where single (scalar) arg expected? */
6869 if (numargs == 1 && !(oa >> 4)
6870 && kid->op_type == OP_LIST && type != OP_SCALAR)
6872 return too_many_arguments(o,PL_op_desc[type]);
6885 if ((type == OP_PUSH || type == OP_UNSHIFT)
6886 && !kid->op_sibling)
6887 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6888 "Useless use of %s with no values",
6891 if (kid->op_type == OP_CONST &&
6892 (kid->op_private & OPpCONST_BARE))
6894 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6895 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6896 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6897 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6898 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6900 op_getmad(kid,newop,'K');
6905 kid->op_sibling = sibl;
6908 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6909 bad_type(numargs, "array", PL_op_desc[type], kid);
6913 if (kid->op_type == OP_CONST &&
6914 (kid->op_private & OPpCONST_BARE))
6916 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6917 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6918 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6919 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6920 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6922 op_getmad(kid,newop,'K');
6927 kid->op_sibling = sibl;
6930 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6931 bad_type(numargs, "hash", PL_op_desc[type], kid);
6936 OP * const newop = newUNOP(OP_NULL, 0, kid);
6937 kid->op_sibling = 0;
6939 newop->op_next = newop;
6941 kid->op_sibling = sibl;
6946 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6947 if (kid->op_type == OP_CONST &&
6948 (kid->op_private & OPpCONST_BARE))
6950 OP * const newop = newGVOP(OP_GV, 0,
6951 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6952 if (!(o->op_private & 1) && /* if not unop */
6953 kid == cLISTOPo->op_last)
6954 cLISTOPo->op_last = newop;
6956 op_getmad(kid,newop,'K');
6962 else if (kid->op_type == OP_READLINE) {
6963 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6964 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6967 I32 flags = OPf_SPECIAL;
6971 /* is this op a FH constructor? */
6972 if (is_handle_constructor(o,numargs)) {
6973 const char *name = NULL;
6977 /* Set a flag to tell rv2gv to vivify
6978 * need to "prove" flag does not mean something
6979 * else already - NI-S 1999/05/07
6982 if (kid->op_type == OP_PADSV) {
6984 = PAD_COMPNAME_SV(kid->op_targ);
6985 name = SvPV_const(namesv, len);
6987 else if (kid->op_type == OP_RV2SV
6988 && kUNOP->op_first->op_type == OP_GV)
6990 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6992 len = GvNAMELEN(gv);
6994 else if (kid->op_type == OP_AELEM
6995 || kid->op_type == OP_HELEM)
6998 OP *op = ((BINOP*)kid)->op_first;
7002 const char * const a =
7003 kid->op_type == OP_AELEM ?
7005 if (((op->op_type == OP_RV2AV) ||
7006 (op->op_type == OP_RV2HV)) &&
7007 (firstop = ((UNOP*)op)->op_first) &&
7008 (firstop->op_type == OP_GV)) {
7009 /* packagevar $a[] or $h{} */
7010 GV * const gv = cGVOPx_gv(firstop);
7018 else if (op->op_type == OP_PADAV
7019 || op->op_type == OP_PADHV) {
7020 /* lexicalvar $a[] or $h{} */
7021 const char * const padname =
7022 PAD_COMPNAME_PV(op->op_targ);
7031 name = SvPV_const(tmpstr, len);
7036 name = "__ANONIO__";
7043 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7044 namesv = PAD_SVl(targ);
7045 SvUPGRADE(namesv, SVt_PV);
7047 sv_setpvs(namesv, "$");
7048 sv_catpvn(namesv, name, len);
7051 kid->op_sibling = 0;
7052 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7053 kid->op_targ = targ;
7054 kid->op_private |= priv;
7056 kid->op_sibling = sibl;
7062 mod(scalar(kid), type);
7066 tokid = &kid->op_sibling;
7067 kid = kid->op_sibling;
7070 if (kid && kid->op_type != OP_STUB)
7071 return too_many_arguments(o,OP_DESC(o));
7072 o->op_private |= numargs;
7074 /* FIXME - should the numargs move as for the PERL_MAD case? */
7075 o->op_private |= numargs;
7077 return too_many_arguments(o,OP_DESC(o));
7081 else if (PL_opargs[type] & OA_DEFGV) {
7083 OP *newop = newUNOP(type, 0, newDEFSVOP());
7084 op_getmad(o,newop,'O');
7087 /* Ordering of these two is important to keep f_map.t passing. */
7089 return newUNOP(type, 0, newDEFSVOP());
7094 while (oa & OA_OPTIONAL)
7096 if (oa && oa != OA_LIST)
7097 return too_few_arguments(o,OP_DESC(o));
7103 Perl_ck_glob(pTHX_ OP *o)
7108 PERL_ARGS_ASSERT_CK_GLOB;
7111 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7112 append_elem(OP_GLOB, o, newDEFSVOP());
7114 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7115 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7117 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7120 #if !defined(PERL_EXTERNAL_GLOB)
7121 /* XXX this can be tightened up and made more failsafe. */
7122 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7125 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7126 newSVpvs("File::Glob"), NULL, NULL, NULL);
7127 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7128 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7129 GvCV(gv) = GvCV(glob_gv);
7130 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7131 GvIMPORTED_CV_on(gv);
7134 #endif /* PERL_EXTERNAL_GLOB */
7136 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7137 append_elem(OP_GLOB, o,
7138 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7139 o->op_type = OP_LIST;
7140 o->op_ppaddr = PL_ppaddr[OP_LIST];
7141 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7142 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7143 cLISTOPo->op_first->op_targ = 0;
7144 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7145 append_elem(OP_LIST, o,
7146 scalar(newUNOP(OP_RV2CV, 0,
7147 newGVOP(OP_GV, 0, gv)))));
7148 o = newUNOP(OP_NULL, 0, ck_subr(o));
7149 o->op_targ = OP_GLOB; /* hint at what it used to be */
7152 gv = newGVgen("main");
7154 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7160 Perl_ck_grep(pTHX_ OP *o)
7165 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7168 PERL_ARGS_ASSERT_CK_GREP;
7170 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7171 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7173 if (o->op_flags & OPf_STACKED) {
7176 kid = cLISTOPo->op_first->op_sibling;
7177 if (!cUNOPx(kid)->op_next)
7178 Perl_croak(aTHX_ "panic: ck_grep");
7179 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7182 NewOp(1101, gwop, 1, LOGOP);
7183 kid->op_next = (OP*)gwop;
7184 o->op_flags &= ~OPf_STACKED;
7186 kid = cLISTOPo->op_first->op_sibling;
7187 if (type == OP_MAPWHILE)
7192 if (PL_parser && PL_parser->error_count)
7194 kid = cLISTOPo->op_first->op_sibling;
7195 if (kid->op_type != OP_NULL)
7196 Perl_croak(aTHX_ "panic: ck_grep");
7197 kid = kUNOP->op_first;
7200 NewOp(1101, gwop, 1, LOGOP);
7201 gwop->op_type = type;
7202 gwop->op_ppaddr = PL_ppaddr[type];
7203 gwop->op_first = listkids(o);
7204 gwop->op_flags |= OPf_KIDS;
7205 gwop->op_other = LINKLIST(kid);
7206 kid->op_next = (OP*)gwop;
7207 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7208 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7209 o->op_private = gwop->op_private = 0;
7210 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7213 o->op_private = gwop->op_private = OPpGREP_LEX;
7214 gwop->op_targ = o->op_targ = offset;
7217 kid = cLISTOPo->op_first->op_sibling;
7218 if (!kid || !kid->op_sibling)
7219 return too_few_arguments(o,OP_DESC(o));
7220 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7221 mod(kid, OP_GREPSTART);
7227 Perl_ck_index(pTHX_ OP *o)
7229 PERL_ARGS_ASSERT_CK_INDEX;
7231 if (o->op_flags & OPf_KIDS) {
7232 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7234 kid = kid->op_sibling; /* get past "big" */
7235 if (kid && kid->op_type == OP_CONST)
7236 fbm_compile(((SVOP*)kid)->op_sv, 0);
7242 Perl_ck_lfun(pTHX_ OP *o)
7244 const OPCODE type = o->op_type;
7246 PERL_ARGS_ASSERT_CK_LFUN;
7248 return modkids(ck_fun(o), type);
7252 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7254 PERL_ARGS_ASSERT_CK_DEFINED;
7256 if ((o->op_flags & OPf_KIDS)) {
7257 switch (cUNOPo->op_first->op_type) {
7259 /* This is needed for
7260 if (defined %stash::)
7261 to work. Do not break Tk.
7263 break; /* Globals via GV can be undef */
7265 case OP_AASSIGN: /* Is this a good idea? */
7266 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7267 "defined(@array) is deprecated");
7268 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7269 "\t(Maybe you should just omit the defined()?)\n");
7273 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7274 "defined(%%hash) is deprecated");
7275 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7276 "\t(Maybe you should just omit the defined()?)\n");
7287 Perl_ck_readline(pTHX_ OP *o)
7289 PERL_ARGS_ASSERT_CK_READLINE;
7291 if (!(o->op_flags & OPf_KIDS)) {
7293 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7295 op_getmad(o,newop,'O');
7305 Perl_ck_rfun(pTHX_ OP *o)
7307 const OPCODE type = o->op_type;
7309 PERL_ARGS_ASSERT_CK_RFUN;
7311 return refkids(ck_fun(o), type);
7315 Perl_ck_listiob(pTHX_ OP *o)
7319 PERL_ARGS_ASSERT_CK_LISTIOB;
7321 kid = cLISTOPo->op_first;
7324 kid = cLISTOPo->op_first;
7326 if (kid->op_type == OP_PUSHMARK)
7327 kid = kid->op_sibling;
7328 if (kid && o->op_flags & OPf_STACKED)
7329 kid = kid->op_sibling;
7330 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7331 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7332 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7333 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7334 cLISTOPo->op_first->op_sibling = kid;
7335 cLISTOPo->op_last = kid;
7336 kid = kid->op_sibling;
7341 append_elem(o->op_type, o, newDEFSVOP());
7347 Perl_ck_smartmatch(pTHX_ OP *o)
7350 if (0 == (o->op_flags & OPf_SPECIAL)) {
7351 OP *first = cBINOPo->op_first;
7352 OP *second = first->op_sibling;
7354 /* Implicitly take a reference to an array or hash */
7355 first->op_sibling = NULL;
7356 first = cBINOPo->op_first = ref_array_or_hash(first);
7357 second = first->op_sibling = ref_array_or_hash(second);
7359 /* Implicitly take a reference to a regular expression */
7360 if (first->op_type == OP_MATCH) {
7361 first->op_type = OP_QR;
7362 first->op_ppaddr = PL_ppaddr[OP_QR];
7364 if (second->op_type == OP_MATCH) {
7365 second->op_type = OP_QR;
7366 second->op_ppaddr = PL_ppaddr[OP_QR];
7375 Perl_ck_sassign(pTHX_ OP *o)
7378 OP * const kid = cLISTOPo->op_first;
7380 PERL_ARGS_ASSERT_CK_SASSIGN;
7382 /* has a disposable target? */
7383 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7384 && !(kid->op_flags & OPf_STACKED)
7385 /* Cannot steal the second time! */
7386 && !(kid->op_private & OPpTARGET_MY)
7387 /* Keep the full thing for madskills */
7391 OP * const kkid = kid->op_sibling;
7393 /* Can just relocate the target. */
7394 if (kkid && kkid->op_type == OP_PADSV
7395 && !(kkid->op_private & OPpLVAL_INTRO))
7397 kid->op_targ = kkid->op_targ;
7399 /* Now we do not need PADSV and SASSIGN. */
7400 kid->op_sibling = o->op_sibling; /* NULL */
7401 cLISTOPo->op_first = NULL;
7404 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7408 if (kid->op_sibling) {
7409 OP *kkid = kid->op_sibling;
7410 if (kkid->op_type == OP_PADSV
7411 && (kkid->op_private & OPpLVAL_INTRO)
7412 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7413 const PADOFFSET target = kkid->op_targ;
7414 OP *const other = newOP(OP_PADSV,
7416 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7417 OP *const first = newOP(OP_NULL, 0);
7418 OP *const nullop = newCONDOP(0, first, o, other);
7419 OP *const condop = first->op_next;
7420 /* hijacking PADSTALE for uninitialized state variables */
7421 SvPADSTALE_on(PAD_SVl(target));
7423 condop->op_type = OP_ONCE;
7424 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7425 condop->op_targ = target;
7426 other->op_targ = target;
7428 /* Because we change the type of the op here, we will skip the
7429 assinment binop->op_last = binop->op_first->op_sibling; at the
7430 end of Perl_newBINOP(). So need to do it here. */
7431 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7440 Perl_ck_match(pTHX_ OP *o)
7444 PERL_ARGS_ASSERT_CK_MATCH;
7446 if (o->op_type != OP_QR && PL_compcv) {
7447 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7448 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7449 o->op_targ = offset;
7450 o->op_private |= OPpTARGET_MY;
7453 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7454 o->op_private |= OPpRUNTIME;
7459 Perl_ck_method(pTHX_ OP *o)
7461 OP * const kid = cUNOPo->op_first;
7463 PERL_ARGS_ASSERT_CK_METHOD;
7465 if (kid->op_type == OP_CONST) {
7466 SV* sv = kSVOP->op_sv;
7467 const char * const method = SvPVX_const(sv);
7468 if (!(strchr(method, ':') || strchr(method, '\''))) {
7470 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7471 sv = newSVpvn_share(method, SvCUR(sv), 0);
7474 kSVOP->op_sv = NULL;
7476 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7478 op_getmad(o,cmop,'O');
7489 Perl_ck_null(pTHX_ OP *o)
7491 PERL_ARGS_ASSERT_CK_NULL;
7492 PERL_UNUSED_CONTEXT;
7497 Perl_ck_open(pTHX_ OP *o)
7500 HV * const table = GvHV(PL_hintgv);
7502 PERL_ARGS_ASSERT_CK_OPEN;
7505 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7508 const char *d = SvPV_const(*svp, len);
7509 const I32 mode = mode_from_discipline(d, len);
7510 if (mode & O_BINARY)
7511 o->op_private |= OPpOPEN_IN_RAW;
7512 else if (mode & O_TEXT)
7513 o->op_private |= OPpOPEN_IN_CRLF;
7516 svp = hv_fetchs(table, "open_OUT", FALSE);
7519 const char *d = SvPV_const(*svp, len);
7520 const I32 mode = mode_from_discipline(d, len);
7521 if (mode & O_BINARY)
7522 o->op_private |= OPpOPEN_OUT_RAW;
7523 else if (mode & O_TEXT)
7524 o->op_private |= OPpOPEN_OUT_CRLF;
7527 if (o->op_type == OP_BACKTICK) {
7528 if (!(o->op_flags & OPf_KIDS)) {
7529 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7531 op_getmad(o,newop,'O');
7540 /* In case of three-arg dup open remove strictness
7541 * from the last arg if it is a bareword. */
7542 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7543 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7547 if ((last->op_type == OP_CONST) && /* The bareword. */
7548 (last->op_private & OPpCONST_BARE) &&
7549 (last->op_private & OPpCONST_STRICT) &&
7550 (oa = first->op_sibling) && /* The fh. */
7551 (oa = oa->op_sibling) && /* The mode. */
7552 (oa->op_type == OP_CONST) &&
7553 SvPOK(((SVOP*)oa)->op_sv) &&
7554 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7555 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7556 (last == oa->op_sibling)) /* The bareword. */
7557 last->op_private &= ~OPpCONST_STRICT;
7563 Perl_ck_repeat(pTHX_ OP *o)
7565 PERL_ARGS_ASSERT_CK_REPEAT;
7567 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7568 o->op_private |= OPpREPEAT_DOLIST;
7569 cBINOPo->op_first = force_list(cBINOPo->op_first);
7577 Perl_ck_require(pTHX_ OP *o)
7582 PERL_ARGS_ASSERT_CK_REQUIRE;
7584 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7585 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7587 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7588 SV * const sv = kid->op_sv;
7589 U32 was_readonly = SvREADONLY(sv);
7596 sv_force_normal_flags(sv, 0);
7597 assert(!SvREADONLY(sv));
7607 for (; s < end; s++) {
7608 if (*s == ':' && s[1] == ':') {
7610 Move(s+2, s+1, end - s - 1, char);
7615 sv_catpvs(sv, ".pm");
7616 SvFLAGS(sv) |= was_readonly;
7620 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7621 /* handle override, if any */
7622 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7623 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7624 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7625 gv = gvp ? *gvp : NULL;
7629 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7630 OP * const kid = cUNOPo->op_first;
7633 cUNOPo->op_first = 0;
7637 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7638 append_elem(OP_LIST, kid,
7639 scalar(newUNOP(OP_RV2CV, 0,
7642 op_getmad(o,newop,'O');
7650 Perl_ck_return(pTHX_ OP *o)
7655 PERL_ARGS_ASSERT_CK_RETURN;
7657 kid = cLISTOPo->op_first->op_sibling;
7658 if (CvLVALUE(PL_compcv)) {
7659 for (; kid; kid = kid->op_sibling)
7660 mod(kid, OP_LEAVESUBLV);
7662 for (; kid; kid = kid->op_sibling)
7663 if ((kid->op_type == OP_NULL)
7664 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7665 /* This is a do block */
7666 OP *op = kUNOP->op_first;
7667 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7668 op = cUNOPx(op)->op_first;
7669 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7670 /* Force the use of the caller's context */
7671 op->op_flags |= OPf_SPECIAL;
7680 Perl_ck_select(pTHX_ OP *o)
7685 PERL_ARGS_ASSERT_CK_SELECT;
7687 if (o->op_flags & OPf_KIDS) {
7688 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7689 if (kid && kid->op_sibling) {
7690 o->op_type = OP_SSELECT;
7691 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7693 return fold_constants(o);
7697 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7698 if (kid && kid->op_type == OP_RV2GV)
7699 kid->op_private &= ~HINT_STRICT_REFS;
7704 Perl_ck_shift(pTHX_ OP *o)
7707 const I32 type = o->op_type;
7709 PERL_ARGS_ASSERT_CK_SHIFT;
7711 if (!(o->op_flags & OPf_KIDS)) {
7712 OP *argop = newUNOP(OP_RV2AV, 0,
7713 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7715 OP * const oldo = o;
7716 o = newUNOP(type, 0, scalar(argop));
7717 op_getmad(oldo,o,'O');
7721 return newUNOP(type, 0, scalar(argop));
7724 return scalar(modkids(ck_fun(o), type));
7728 Perl_ck_sort(pTHX_ OP *o)
7733 PERL_ARGS_ASSERT_CK_SORT;
7735 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7736 HV * const hinthv = GvHV(PL_hintgv);
7738 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7740 const I32 sorthints = (I32)SvIV(*svp);
7741 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7742 o->op_private |= OPpSORT_QSORT;
7743 if ((sorthints & HINT_SORT_STABLE) != 0)
7744 o->op_private |= OPpSORT_STABLE;
7749 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7751 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7752 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7754 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7756 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7758 if (kid->op_type == OP_SCOPE) {
7762 else if (kid->op_type == OP_LEAVE) {
7763 if (o->op_type == OP_SORT) {
7764 op_null(kid); /* wipe out leave */
7767 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7768 if (k->op_next == kid)
7770 /* don't descend into loops */
7771 else if (k->op_type == OP_ENTERLOOP
7772 || k->op_type == OP_ENTERITER)
7774 k = cLOOPx(k)->op_lastop;
7779 kid->op_next = 0; /* just disconnect the leave */
7780 k = kLISTOP->op_first;
7785 if (o->op_type == OP_SORT) {
7786 /* provide scalar context for comparison function/block */
7792 o->op_flags |= OPf_SPECIAL;
7794 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7797 firstkid = firstkid->op_sibling;
7800 /* provide list context for arguments */
7801 if (o->op_type == OP_SORT)
7808 S_simplify_sort(pTHX_ OP *o)
7811 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7817 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7819 if (!(o->op_flags & OPf_STACKED))
7821 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7822 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7823 kid = kUNOP->op_first; /* get past null */
7824 if (kid->op_type != OP_SCOPE)
7826 kid = kLISTOP->op_last; /* get past scope */
7827 switch(kid->op_type) {
7835 k = kid; /* remember this node*/
7836 if (kBINOP->op_first->op_type != OP_RV2SV)
7838 kid = kBINOP->op_first; /* get past cmp */
7839 if (kUNOP->op_first->op_type != OP_GV)
7841 kid = kUNOP->op_first; /* get past rv2sv */
7843 if (GvSTASH(gv) != PL_curstash)
7845 gvname = GvNAME(gv);
7846 if (*gvname == 'a' && gvname[1] == '\0')
7848 else if (*gvname == 'b' && gvname[1] == '\0')
7853 kid = k; /* back to cmp */
7854 if (kBINOP->op_last->op_type != OP_RV2SV)
7856 kid = kBINOP->op_last; /* down to 2nd arg */
7857 if (kUNOP->op_first->op_type != OP_GV)
7859 kid = kUNOP->op_first; /* get past rv2sv */
7861 if (GvSTASH(gv) != PL_curstash)
7863 gvname = GvNAME(gv);
7865 ? !(*gvname == 'a' && gvname[1] == '\0')
7866 : !(*gvname == 'b' && gvname[1] == '\0'))
7868 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7870 o->op_private |= OPpSORT_DESCEND;
7871 if (k->op_type == OP_NCMP)
7872 o->op_private |= OPpSORT_NUMERIC;
7873 if (k->op_type == OP_I_NCMP)
7874 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7875 kid = cLISTOPo->op_first->op_sibling;
7876 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7878 op_getmad(kid,o,'S'); /* then delete it */
7880 op_free(kid); /* then delete it */
7885 Perl_ck_split(pTHX_ OP *o)
7890 PERL_ARGS_ASSERT_CK_SPLIT;
7892 if (o->op_flags & OPf_STACKED)
7893 return no_fh_allowed(o);
7895 kid = cLISTOPo->op_first;
7896 if (kid->op_type != OP_NULL)
7897 Perl_croak(aTHX_ "panic: ck_split");
7898 kid = kid->op_sibling;
7899 op_free(cLISTOPo->op_first);
7900 cLISTOPo->op_first = kid;
7902 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7903 cLISTOPo->op_last = kid; /* There was only one element previously */
7906 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7907 OP * const sibl = kid->op_sibling;
7908 kid->op_sibling = 0;
7909 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7910 if (cLISTOPo->op_first == cLISTOPo->op_last)
7911 cLISTOPo->op_last = kid;
7912 cLISTOPo->op_first = kid;
7913 kid->op_sibling = sibl;
7916 kid->op_type = OP_PUSHRE;
7917 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7919 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7920 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7921 "Use of /g modifier is meaningless in split");
7924 if (!kid->op_sibling)
7925 append_elem(OP_SPLIT, o, newDEFSVOP());
7927 kid = kid->op_sibling;
7930 if (!kid->op_sibling)
7931 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7932 assert(kid->op_sibling);
7934 kid = kid->op_sibling;
7937 if (kid->op_sibling)
7938 return too_many_arguments(o,OP_DESC(o));
7944 Perl_ck_join(pTHX_ OP *o)
7946 const OP * const kid = cLISTOPo->op_first->op_sibling;
7948 PERL_ARGS_ASSERT_CK_JOIN;
7950 if (kid && kid->op_type == OP_MATCH) {
7951 if (ckWARN(WARN_SYNTAX)) {
7952 const REGEXP *re = PM_GETRE(kPMOP);
7953 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7954 const STRLEN len = re ? RX_PRELEN(re) : 6;
7955 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7956 "/%.*s/ should probably be written as \"%.*s\"",
7957 (int)len, pmstr, (int)len, pmstr);
7964 Perl_ck_subr(pTHX_ OP *o)
7967 OP *prev = ((cUNOPo->op_first->op_sibling)
7968 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7969 OP *o2 = prev->op_sibling;
7971 const char *proto = NULL;
7972 const char *proto_end = NULL;
7977 I32 contextclass = 0;
7978 const char *e = NULL;
7981 PERL_ARGS_ASSERT_CK_SUBR;
7983 o->op_private |= OPpENTERSUB_HASTARG;
7984 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7985 if (cvop->op_type == OP_RV2CV) {
7986 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7987 op_null(cvop); /* disable rv2cv */
7988 if (!(o->op_private & OPpENTERSUB_AMPER)) {
7989 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7991 switch (tmpop->op_type) {
7993 gv = cGVOPx_gv(tmpop);
7996 tmpop->op_private |= OPpEARLY_CV;
7999 SV *sv = cSVOPx_sv(tmpop);
8000 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8004 if (cv && SvPOK(cv)) {
8006 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8007 proto = SvPV(MUTABLE_SV(cv), len);
8008 proto_end = proto + len;
8012 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8013 if (o2->op_type == OP_CONST)
8014 o2->op_private &= ~OPpCONST_STRICT;
8015 else if (o2->op_type == OP_LIST) {
8016 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8017 if (sib && sib->op_type == OP_CONST)
8018 sib->op_private &= ~OPpCONST_STRICT;
8021 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8022 if (PERLDB_SUB && PL_curstash != PL_debstash)
8023 o->op_private |= OPpENTERSUB_DB;
8024 while (o2 != cvop) {
8026 if (PL_madskills && o2->op_type == OP_STUB) {
8027 o2 = o2->op_sibling;
8030 if (PL_madskills && o2->op_type == OP_NULL)
8031 o3 = ((UNOP*)o2)->op_first;
8035 if (proto >= proto_end)
8036 return too_many_arguments(o, gv_ename(namegv));
8044 /* _ must be at the end */
8045 if (proto[1] && proto[1] != ';')
8060 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8062 arg == 1 ? "block or sub {}" : "sub {}",
8063 gv_ename(namegv), o3);
8066 /* '*' allows any scalar type, including bareword */
8069 if (o3->op_type == OP_RV2GV)
8070 goto wrapref; /* autoconvert GLOB -> GLOBref */
8071 else if (o3->op_type == OP_CONST)
8072 o3->op_private &= ~OPpCONST_STRICT;
8073 else if (o3->op_type == OP_ENTERSUB) {
8074 /* accidental subroutine, revert to bareword */
8075 OP *gvop = ((UNOP*)o3)->op_first;
8076 if (gvop && gvop->op_type == OP_NULL) {
8077 gvop = ((UNOP*)gvop)->op_first;
8079 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8082 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8083 (gvop = ((UNOP*)gvop)->op_first) &&
8084 gvop->op_type == OP_GV)
8086 GV * const gv = cGVOPx_gv(gvop);
8087 OP * const sibling = o2->op_sibling;
8088 SV * const n = newSVpvs("");
8090 OP * const oldo2 = o2;
8094 gv_fullname4(n, gv, "", FALSE);
8095 o2 = newSVOP(OP_CONST, 0, n);
8096 op_getmad(oldo2,o2,'O');
8097 prev->op_sibling = o2;
8098 o2->op_sibling = sibling;
8114 if (contextclass++ == 0) {
8115 e = strchr(proto, ']');
8116 if (!e || e == proto)
8125 const char *p = proto;
8126 const char *const end = proto;
8128 while (*--p != '[') {}
8129 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8131 gv_ename(namegv), o3);
8136 if (o3->op_type == OP_RV2GV)
8139 bad_type(arg, "symbol", gv_ename(namegv), o3);
8142 if (o3->op_type == OP_ENTERSUB)
8145 bad_type(arg, "subroutine entry", gv_ename(namegv),
8149 if (o3->op_type == OP_RV2SV ||
8150 o3->op_type == OP_PADSV ||
8151 o3->op_type == OP_HELEM ||
8152 o3->op_type == OP_AELEM)
8155 bad_type(arg, "scalar", gv_ename(namegv), o3);
8158 if (o3->op_type == OP_RV2AV ||
8159 o3->op_type == OP_PADAV)
8162 bad_type(arg, "array", gv_ename(namegv), o3);
8165 if (o3->op_type == OP_RV2HV ||
8166 o3->op_type == OP_PADHV)
8169 bad_type(arg, "hash", gv_ename(namegv), o3);
8174 OP* const sib = kid->op_sibling;
8175 kid->op_sibling = 0;
8176 o2 = newUNOP(OP_REFGEN, 0, kid);
8177 o2->op_sibling = sib;
8178 prev->op_sibling = o2;
8180 if (contextclass && e) {
8195 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8196 gv_ename(namegv), SVfARG(cv));
8201 mod(o2, OP_ENTERSUB);
8203 o2 = o2->op_sibling;
8205 if (o2 == cvop && proto && *proto == '_') {
8206 /* generate an access to $_ */
8208 o2->op_sibling = prev->op_sibling;
8209 prev->op_sibling = o2; /* instead of cvop */
8211 if (proto && !optional && proto_end > proto &&
8212 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8213 return too_few_arguments(o, gv_ename(namegv));
8216 OP * const oldo = o;
8220 o=newSVOP(OP_CONST, 0, newSViv(0));
8221 op_getmad(oldo,o,'O');
8227 Perl_ck_svconst(pTHX_ OP *o)
8229 PERL_ARGS_ASSERT_CK_SVCONST;
8230 PERL_UNUSED_CONTEXT;
8231 SvREADONLY_on(cSVOPo->op_sv);
8236 Perl_ck_chdir(pTHX_ OP *o)
8238 if (o->op_flags & OPf_KIDS) {
8239 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8241 if (kid && kid->op_type == OP_CONST &&
8242 (kid->op_private & OPpCONST_BARE))
8244 o->op_flags |= OPf_SPECIAL;
8245 kid->op_private &= ~OPpCONST_STRICT;
8252 Perl_ck_trunc(pTHX_ OP *o)
8254 PERL_ARGS_ASSERT_CK_TRUNC;
8256 if (o->op_flags & OPf_KIDS) {
8257 SVOP *kid = (SVOP*)cUNOPo->op_first;
8259 if (kid->op_type == OP_NULL)
8260 kid = (SVOP*)kid->op_sibling;
8261 if (kid && kid->op_type == OP_CONST &&
8262 (kid->op_private & OPpCONST_BARE))
8264 o->op_flags |= OPf_SPECIAL;
8265 kid->op_private &= ~OPpCONST_STRICT;
8272 Perl_ck_unpack(pTHX_ OP *o)
8274 OP *kid = cLISTOPo->op_first;
8276 PERL_ARGS_ASSERT_CK_UNPACK;
8278 if (kid->op_sibling) {
8279 kid = kid->op_sibling;
8280 if (!kid->op_sibling)
8281 kid->op_sibling = newDEFSVOP();
8287 Perl_ck_substr(pTHX_ OP *o)
8289 PERL_ARGS_ASSERT_CK_SUBSTR;
8292 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8293 OP *kid = cLISTOPo->op_first;
8295 if (kid->op_type == OP_NULL)
8296 kid = kid->op_sibling;
8298 kid->op_flags |= OPf_MOD;
8305 Perl_ck_each(pTHX_ OP *o)
8308 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8310 PERL_ARGS_ASSERT_CK_EACH;
8313 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8314 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8315 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8316 o->op_type = new_type;
8317 o->op_ppaddr = PL_ppaddr[new_type];
8319 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8320 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8322 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8329 /* caller is supposed to assign the return to the
8330 container of the rep_op var */
8332 S_opt_scalarhv(pTHX_ OP *rep_op) {
8335 PERL_ARGS_ASSERT_OPT_SCALARHV;
8337 NewOp(1101, unop, 1, UNOP);
8338 unop->op_type = (OPCODE)OP_BOOLKEYS;
8339 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8340 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8341 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8342 unop->op_first = rep_op;
8343 unop->op_next = rep_op->op_next;
8344 rep_op->op_next = (OP*)unop;
8345 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8346 unop->op_sibling = rep_op->op_sibling;
8347 rep_op->op_sibling = NULL;
8348 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8349 if (rep_op->op_type == OP_PADHV) {
8350 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8351 rep_op->op_flags |= OPf_WANT_LIST;
8356 /* Checks if o acts as an in-place operator on an array. oright points to the
8357 * beginning of the right-hand side. Returns the left-hand side of the
8358 * assignment if o acts in-place, or NULL otherwise. */
8361 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8365 PERL_ARGS_ASSERT_IS_INPLACE_AV;
8368 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8369 || oright->op_next != o
8370 || (oright->op_private & OPpLVAL_INTRO)
8374 /* o2 follows the chain of op_nexts through the LHS of the
8375 * assign (if any) to the aassign op itself */
8377 if (!o2 || o2->op_type != OP_NULL)
8380 if (!o2 || o2->op_type != OP_PUSHMARK)
8383 if (o2 && o2->op_type == OP_GV)
8386 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8387 || (o2->op_private & OPpLVAL_INTRO)
8392 if (!o2 || o2->op_type != OP_NULL)
8395 if (!o2 || o2->op_type != OP_AASSIGN
8396 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8399 /* check that the sort is the first arg on RHS of assign */
8401 o2 = cUNOPx(o2)->op_first;
8402 if (!o2 || o2->op_type != OP_NULL)
8404 o2 = cUNOPx(o2)->op_first;
8405 if (!o2 || o2->op_type != OP_PUSHMARK)
8407 if (o2->op_sibling != o)
8410 /* check the array is the same on both sides */
8411 if (oleft->op_type == OP_RV2AV) {
8412 if (oright->op_type != OP_RV2AV
8413 || !cUNOPx(oright)->op_first
8414 || cUNOPx(oright)->op_first->op_type != OP_GV
8415 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8416 cGVOPx_gv(cUNOPx(oright)->op_first)
8420 else if (oright->op_type != OP_PADAV
8421 || oright->op_targ != oleft->op_targ
8428 /* A peephole optimizer. We visit the ops in the order they're to execute.
8429 * See the comments at the top of this file for more details about when
8430 * peep() is called */
8433 Perl_peep(pTHX_ register OP *o)
8436 register OP* oldop = NULL;
8438 if (!o || o->op_opt)
8442 SAVEVPTR(PL_curcop);
8443 for (; o; o = o->op_next) {
8446 /* By default, this op has now been optimised. A couple of cases below
8447 clear this again. */
8450 switch (o->op_type) {
8453 PL_curcop = ((COP*)o); /* for warnings */
8457 if (cSVOPo->op_private & OPpCONST_STRICT)
8458 no_bareword_allowed(o);
8461 case OP_METHOD_NAMED:
8462 /* Relocate sv to the pad for thread safety.
8463 * Despite being a "constant", the SV is written to,
8464 * for reference counts, sv_upgrade() etc. */
8466 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8467 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8468 /* If op_sv is already a PADTMP then it is being used by
8469 * some pad, so make a copy. */
8470 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8471 SvREADONLY_on(PAD_SVl(ix));
8472 SvREFCNT_dec(cSVOPo->op_sv);
8474 else if (o->op_type != OP_METHOD_NAMED
8475 && cSVOPo->op_sv == &PL_sv_undef) {
8476 /* PL_sv_undef is hack - it's unsafe to store it in the
8477 AV that is the pad, because av_fetch treats values of
8478 PL_sv_undef as a "free" AV entry and will merrily
8479 replace them with a new SV, causing pad_alloc to think
8480 that this pad slot is free. (When, clearly, it is not)
8482 SvOK_off(PAD_SVl(ix));
8483 SvPADTMP_on(PAD_SVl(ix));
8484 SvREADONLY_on(PAD_SVl(ix));
8487 SvREFCNT_dec(PAD_SVl(ix));
8488 SvPADTMP_on(cSVOPo->op_sv);
8489 PAD_SETSV(ix, cSVOPo->op_sv);
8490 /* XXX I don't know how this isn't readonly already. */
8491 SvREADONLY_on(PAD_SVl(ix));
8493 cSVOPo->op_sv = NULL;
8500 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8501 if (o->op_next->op_private & OPpTARGET_MY) {
8502 if (o->op_flags & OPf_STACKED) /* chained concats */
8503 break; /* ignore_optimization */
8505 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8506 o->op_targ = o->op_next->op_targ;
8507 o->op_next->op_targ = 0;
8508 o->op_private |= OPpTARGET_MY;
8511 op_null(o->op_next);
8515 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8516 break; /* Scalar stub must produce undef. List stub is noop */
8520 if (o->op_targ == OP_NEXTSTATE
8521 || o->op_targ == OP_DBSTATE)
8523 PL_curcop = ((COP*)o);
8525 /* XXX: We avoid setting op_seq here to prevent later calls
8526 to peep() from mistakenly concluding that optimisation
8527 has already occurred. This doesn't fix the real problem,
8528 though (See 20010220.007). AMS 20010719 */
8529 /* op_seq functionality is now replaced by op_opt */
8536 if (oldop && o->op_next) {
8537 oldop->op_next = o->op_next;
8545 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8546 OP* const pop = (o->op_type == OP_PADAV) ?
8547 o->op_next : o->op_next->op_next;
8549 if (pop && pop->op_type == OP_CONST &&
8550 ((PL_op = pop->op_next)) &&
8551 pop->op_next->op_type == OP_AELEM &&
8552 !(pop->op_next->op_private &
8553 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8554 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8559 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8560 no_bareword_allowed(pop);
8561 if (o->op_type == OP_GV)
8562 op_null(o->op_next);
8563 op_null(pop->op_next);
8565 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8566 o->op_next = pop->op_next->op_next;
8567 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8568 o->op_private = (U8)i;
8569 if (o->op_type == OP_GV) {
8574 o->op_flags |= OPf_SPECIAL;
8575 o->op_type = OP_AELEMFAST;
8580 if (o->op_next->op_type == OP_RV2SV) {
8581 if (!(o->op_next->op_private & OPpDEREF)) {
8582 op_null(o->op_next);
8583 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8585 o->op_next = o->op_next->op_next;
8586 o->op_type = OP_GVSV;
8587 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8590 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8591 GV * const gv = cGVOPo_gv;
8592 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8593 /* XXX could check prototype here instead of just carping */
8594 SV * const sv = sv_newmortal();
8595 gv_efullname3(sv, gv, NULL);
8596 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8597 "%"SVf"() called too early to check prototype",
8601 else if (o->op_next->op_type == OP_READLINE
8602 && o->op_next->op_next->op_type == OP_CONCAT
8603 && (o->op_next->op_next->op_flags & OPf_STACKED))
8605 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8606 o->op_type = OP_RCATLINE;
8607 o->op_flags |= OPf_STACKED;
8608 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8609 op_null(o->op_next->op_next);
8610 op_null(o->op_next);
8620 fop = cUNOP->op_first;
8628 fop = cLOGOP->op_first;
8629 sop = fop->op_sibling;
8630 while (cLOGOP->op_other->op_type == OP_NULL)
8631 cLOGOP->op_other = cLOGOP->op_other->op_next;
8632 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8636 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8638 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8643 if (!(nop->op_flags && OPf_WANT_VOID)) {
8644 while (nop && nop->op_next) {
8645 switch (nop->op_next->op_type) {
8650 lop = nop = nop->op_next;
8661 if (lop->op_flags && OPf_WANT_VOID) {
8662 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8663 cLOGOP->op_first = opt_scalarhv(fop);
8664 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8665 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8681 while (cLOGOP->op_other->op_type == OP_NULL)
8682 cLOGOP->op_other = cLOGOP->op_other->op_next;
8683 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8688 while (cLOOP->op_redoop->op_type == OP_NULL)
8689 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8690 peep(cLOOP->op_redoop);
8691 while (cLOOP->op_nextop->op_type == OP_NULL)
8692 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8693 peep(cLOOP->op_nextop);
8694 while (cLOOP->op_lastop->op_type == OP_NULL)
8695 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8696 peep(cLOOP->op_lastop);
8700 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8701 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8702 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8703 cPMOP->op_pmstashstartu.op_pmreplstart
8704 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8705 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8709 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8710 && ckWARN(WARN_SYNTAX))
8712 if (o->op_next->op_sibling) {
8713 const OPCODE type = o->op_next->op_sibling->op_type;
8714 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8715 const line_t oldline = CopLINE(PL_curcop);
8716 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8717 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8718 "Statement unlikely to be reached");
8719 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8720 "\t(Maybe you meant system() when you said exec()?)\n");
8721 CopLINE_set(PL_curcop, oldline);
8732 const char *key = NULL;
8735 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8738 /* Make the CONST have a shared SV */
8739 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8740 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8741 key = SvPV_const(sv, keylen);
8742 lexname = newSVpvn_share(key,
8743 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8749 if ((o->op_private & (OPpLVAL_INTRO)))
8752 rop = (UNOP*)((BINOP*)o)->op_first;
8753 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8755 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8756 if (!SvPAD_TYPED(lexname))
8758 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8759 if (!fields || !GvHV(*fields))
8761 key = SvPV_const(*svp, keylen);
8762 if (!hv_fetch(GvHV(*fields), key,
8763 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8765 Perl_croak(aTHX_ "No such class field \"%s\" "
8766 "in variable %s of type %s",
8767 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8780 SVOP *first_key_op, *key_op;
8782 if ((o->op_private & (OPpLVAL_INTRO))
8783 /* I bet there's always a pushmark... */
8784 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8785 /* hmmm, no optimization if list contains only one key. */
8787 rop = (UNOP*)((LISTOP*)o)->op_last;
8788 if (rop->op_type != OP_RV2HV)
8790 if (rop->op_first->op_type == OP_PADSV)
8791 /* @$hash{qw(keys here)} */
8792 rop = (UNOP*)rop->op_first;
8794 /* @{$hash}{qw(keys here)} */
8795 if (rop->op_first->op_type == OP_SCOPE
8796 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8798 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8804 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8805 if (!SvPAD_TYPED(lexname))
8807 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8808 if (!fields || !GvHV(*fields))
8810 /* Again guessing that the pushmark can be jumped over.... */
8811 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8812 ->op_first->op_sibling;
8813 for (key_op = first_key_op; key_op;
8814 key_op = (SVOP*)key_op->op_sibling) {
8815 if (key_op->op_type != OP_CONST)
8817 svp = cSVOPx_svp(key_op);
8818 key = SvPV_const(*svp, keylen);
8819 if (!hv_fetch(GvHV(*fields), key,
8820 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8822 Perl_croak(aTHX_ "No such class field \"%s\" "
8823 "in variable %s of type %s",
8824 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8831 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8835 /* check that RHS of sort is a single plain array */
8836 OP *oright = cUNOPo->op_first;
8837 if (!oright || oright->op_type != OP_PUSHMARK)
8840 /* reverse sort ... can be optimised. */
8841 if (!cUNOPo->op_sibling) {
8842 /* Nothing follows us on the list. */
8843 OP * const reverse = o->op_next;
8845 if (reverse->op_type == OP_REVERSE &&
8846 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8847 OP * const pushmark = cUNOPx(reverse)->op_first;
8848 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8849 && (cUNOPx(pushmark)->op_sibling == o)) {
8850 /* reverse -> pushmark -> sort */
8851 o->op_private |= OPpSORT_REVERSE;
8853 pushmark->op_next = oright->op_next;
8859 /* make @a = sort @a act in-place */
8861 oright = cUNOPx(oright)->op_sibling;
8864 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8865 oright = cUNOPx(oright)->op_sibling;
8868 oleft = is_inplace_av(o, oright);
8872 /* transfer MODishness etc from LHS arg to RHS arg */
8873 oright->op_flags = oleft->op_flags;
8874 o->op_private |= OPpSORT_INPLACE;
8876 /* excise push->gv->rv2av->null->aassign */
8877 o2 = o->op_next->op_next;
8878 op_null(o2); /* PUSHMARK */
8880 if (o2->op_type == OP_GV) {
8881 op_null(o2); /* GV */
8884 op_null(o2); /* RV2AV or PADAV */
8885 o2 = o2->op_next->op_next;
8886 op_null(o2); /* AASSIGN */
8888 o->op_next = o2->op_next;
8894 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8897 LISTOP *enter, *exlist;
8899 /* @a = reverse @a */
8900 if ((oright = cLISTOPo->op_first)
8901 && (oright->op_type == OP_PUSHMARK)
8902 && (oright = oright->op_sibling)
8903 && (oleft = is_inplace_av(o, oright))) {
8906 /* transfer MODishness etc from LHS arg to RHS arg */
8907 oright->op_flags = oleft->op_flags;
8908 o->op_private |= OPpREVERSE_INPLACE;
8910 /* excise push->gv->rv2av->null->aassign */
8911 o2 = o->op_next->op_next;
8912 op_null(o2); /* PUSHMARK */
8914 if (o2->op_type == OP_GV) {
8915 op_null(o2); /* GV */
8918 op_null(o2); /* RV2AV or PADAV */
8919 o2 = o2->op_next->op_next;
8920 op_null(o2); /* AASSIGN */
8922 o->op_next = o2->op_next;
8926 enter = (LISTOP *) o->op_next;
8929 if (enter->op_type == OP_NULL) {
8930 enter = (LISTOP *) enter->op_next;
8934 /* for $a (...) will have OP_GV then OP_RV2GV here.
8935 for (...) just has an OP_GV. */
8936 if (enter->op_type == OP_GV) {
8937 gvop = (OP *) enter;
8938 enter = (LISTOP *) enter->op_next;
8941 if (enter->op_type == OP_RV2GV) {
8942 enter = (LISTOP *) enter->op_next;
8948 if (enter->op_type != OP_ENTERITER)
8951 iter = enter->op_next;
8952 if (!iter || iter->op_type != OP_ITER)
8955 expushmark = enter->op_first;
8956 if (!expushmark || expushmark->op_type != OP_NULL
8957 || expushmark->op_targ != OP_PUSHMARK)
8960 exlist = (LISTOP *) expushmark->op_sibling;
8961 if (!exlist || exlist->op_type != OP_NULL
8962 || exlist->op_targ != OP_LIST)
8965 if (exlist->op_last != o) {
8966 /* Mmm. Was expecting to point back to this op. */
8969 theirmark = exlist->op_first;
8970 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8973 if (theirmark->op_sibling != o) {
8974 /* There's something between the mark and the reverse, eg
8975 for (1, reverse (...))
8980 ourmark = ((LISTOP *)o)->op_first;
8981 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8984 ourlast = ((LISTOP *)o)->op_last;
8985 if (!ourlast || ourlast->op_next != o)
8988 rv2av = ourmark->op_sibling;
8989 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8990 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8991 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8992 /* We're just reversing a single array. */
8993 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8994 enter->op_flags |= OPf_STACKED;
8997 /* We don't have control over who points to theirmark, so sacrifice
8999 theirmark->op_next = ourmark->op_next;
9000 theirmark->op_flags = ourmark->op_flags;
9001 ourlast->op_next = gvop ? gvop : (OP *) enter;
9004 enter->op_private |= OPpITER_REVERSED;
9005 iter->op_private |= OPpITER_REVERSED;
9012 UNOP *refgen, *rv2cv;
9015 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9018 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9021 rv2gv = ((BINOP *)o)->op_last;
9022 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9025 refgen = (UNOP *)((BINOP *)o)->op_first;
9027 if (!refgen || refgen->op_type != OP_REFGEN)
9030 exlist = (LISTOP *)refgen->op_first;
9031 if (!exlist || exlist->op_type != OP_NULL
9032 || exlist->op_targ != OP_LIST)
9035 if (exlist->op_first->op_type != OP_PUSHMARK)
9038 rv2cv = (UNOP*)exlist->op_last;
9040 if (rv2cv->op_type != OP_RV2CV)
9043 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9044 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9045 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9047 o->op_private |= OPpASSIGN_CV_TO_GV;
9048 rv2gv->op_private |= OPpDONT_INIT_GV;
9049 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9057 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9058 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9068 Perl_custom_op_name(pTHX_ const OP* o)
9071 const IV index = PTR2IV(o->op_ppaddr);
9075 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9077 if (!PL_custom_op_names) /* This probably shouldn't happen */
9078 return (char *)PL_op_name[OP_CUSTOM];
9080 keysv = sv_2mortal(newSViv(index));
9082 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9084 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9086 return SvPV_nolen(HeVAL(he));
9090 Perl_custom_op_desc(pTHX_ const OP* o)
9093 const IV index = PTR2IV(o->op_ppaddr);
9097 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9099 if (!PL_custom_op_descs)
9100 return (char *)PL_op_desc[OP_CUSTOM];
9102 keysv = sv_2mortal(newSViv(index));
9104 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9106 return (char *)PL_op_desc[OP_CUSTOM];
9108 return SvPV_nolen(HeVAL(he));
9113 /* Efficient sub that returns a constant scalar value. */
9115 const_sv_xsub(pTHX_ CV* cv)
9119 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9123 /* diag_listed_as: SKIPME */
9124 Perl_croak(aTHX_ "usage: %s::%s()",
9125 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9138 * c-indentation-style: bsd
9140 * indent-tabs-mode: t
9143 * ex: set ts=8 sts=4 sw=4 noet: