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_A_PEEP(peep, o) CALL_FPTR((peep)->fn)(aTHX_ o, peep)
108 #define CALL_PEEP(o) \
110 peep_next_t _next_peep = { PL_peepp, NULL }; \
111 CALL_A_PEEP(&_next_peep, o); \
114 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
116 #if defined(PL_OP_SLAB_ALLOC)
118 #ifdef PERL_DEBUG_READONLY_OPS
119 # define PERL_SLAB_SIZE 4096
120 # include <sys/mman.h>
123 #ifndef PERL_SLAB_SIZE
124 #define PERL_SLAB_SIZE 2048
128 Perl_Slab_Alloc(pTHX_ size_t sz)
132 * To make incrementing use count easy PL_OpSlab is an I32 *
133 * To make inserting the link to slab PL_OpPtr is I32 **
134 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
135 * Add an overhead for pointer to slab and round up as a number of pointers
137 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
138 if ((PL_OpSpace -= sz) < 0) {
139 #ifdef PERL_DEBUG_READONLY_OPS
140 /* We need to allocate chunk by chunk so that we can control the VM
142 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
143 MAP_ANON|MAP_PRIVATE, -1, 0);
145 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
146 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
148 if(PL_OpPtr == MAP_FAILED) {
149 perror("mmap failed");
154 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
159 /* We reserve the 0'th I32 sized chunk as a use count */
160 PL_OpSlab = (I32 *) PL_OpPtr;
161 /* Reduce size by the use count word, and by the size we need.
162 * Latter is to mimic the '-=' in the if() above
164 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
165 /* Allocation pointer starts at the top.
166 Theory: because we build leaves before trunk allocating at end
167 means that at run time access is cache friendly upward
169 PL_OpPtr += PERL_SLAB_SIZE;
171 #ifdef PERL_DEBUG_READONLY_OPS
172 /* We remember this slab. */
173 /* This implementation isn't efficient, but it is simple. */
174 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
175 PL_slabs[PL_slab_count++] = PL_OpSlab;
176 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
179 assert( PL_OpSpace >= 0 );
180 /* Move the allocation pointer down */
182 assert( PL_OpPtr > (I32 **) PL_OpSlab );
183 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
184 (*PL_OpSlab)++; /* Increment use count of slab */
185 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
186 assert( *PL_OpSlab > 0 );
187 return (void *)(PL_OpPtr + 1);
190 #ifdef PERL_DEBUG_READONLY_OPS
192 Perl_pending_Slabs_to_ro(pTHX) {
193 /* Turn all the allocated op slabs read only. */
194 U32 count = PL_slab_count;
195 I32 **const slabs = PL_slabs;
197 /* Reset the array of pending OP slabs, as we're about to turn this lot
198 read only. Also, do it ahead of the loop in case the warn triggers,
199 and a warn handler has an eval */
204 /* Force a new slab for any further allocation. */
208 void *const start = slabs[count];
209 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
210 if(mprotect(start, size, PROT_READ)) {
211 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
212 start, (unsigned long) size, errno);
220 S_Slab_to_rw(pTHX_ void *op)
222 I32 * const * const ptr = (I32 **) op;
223 I32 * const slab = ptr[-1];
225 PERL_ARGS_ASSERT_SLAB_TO_RW;
227 assert( ptr-1 > (I32 **) slab );
228 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
230 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
231 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
232 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
237 Perl_op_refcnt_inc(pTHX_ OP *o)
248 Perl_op_refcnt_dec(pTHX_ OP *o)
250 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
255 # define Slab_to_rw(op)
259 Perl_Slab_Free(pTHX_ void *op)
261 I32 * const * const ptr = (I32 **) op;
262 I32 * const slab = ptr[-1];
263 PERL_ARGS_ASSERT_SLAB_FREE;
264 assert( ptr-1 > (I32 **) slab );
265 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
268 if (--(*slab) == 0) {
270 # define PerlMemShared PerlMem
273 #ifdef PERL_DEBUG_READONLY_OPS
274 U32 count = PL_slab_count;
275 /* Need to remove this slab from our list of slabs */
278 if (PL_slabs[count] == slab) {
280 /* Found it. Move the entry at the end to overwrite it. */
281 DEBUG_m(PerlIO_printf(Perl_debug_log,
282 "Deallocate %p by moving %p from %lu to %lu\n",
284 PL_slabs[PL_slab_count - 1],
285 PL_slab_count, count));
286 PL_slabs[count] = PL_slabs[--PL_slab_count];
287 /* Could realloc smaller at this point, but probably not
289 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
290 perror("munmap failed");
298 PerlMemShared_free(slab);
300 if (slab == PL_OpSlab) {
307 * In the following definition, the ", (OP*)0" is just to make the compiler
308 * think the expression is of the right type: croak actually does a Siglongjmp.
310 #define CHECKOP(type,o) \
311 ((PL_op_mask && PL_op_mask[type]) \
312 ? ( op_free((OP*)o), \
313 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
315 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
317 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
320 S_gv_ename(pTHX_ GV *gv)
322 SV* const tmpsv = sv_newmortal();
324 PERL_ARGS_ASSERT_GV_ENAME;
326 gv_efullname3(tmpsv, gv, NULL);
327 return SvPV_nolen_const(tmpsv);
331 S_no_fh_allowed(pTHX_ OP *o)
333 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
335 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
341 S_too_few_arguments(pTHX_ OP *o, const char *name)
343 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
345 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
350 S_too_many_arguments(pTHX_ OP *o, const char *name)
352 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
354 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
359 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
361 PERL_ARGS_ASSERT_BAD_TYPE;
363 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
364 (int)n, name, t, OP_DESC(kid)));
368 S_no_bareword_allowed(pTHX_ const OP *o)
370 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
373 return; /* various ok barewords are hidden in extra OP_NULL */
374 qerror(Perl_mess(aTHX_
375 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
379 /* "register" allocation */
382 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
386 const bool is_our = (PL_parser->in_my == KEY_our);
388 PERL_ARGS_ASSERT_ALLOCMY;
391 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
394 /* Until we're using the length for real, cross check that we're being
396 assert(strlen(name) == len);
398 /* complain about "my $<special_var>" etc etc */
402 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
403 (name[1] == '_' && (*name == '$' || len > 2))))
405 /* name[2] is true if strlen(name) > 2 */
406 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
407 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
408 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
409 PL_parser->in_my == KEY_state ? "state" : "my"));
411 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
412 PL_parser->in_my == KEY_state ? "state" : "my"));
416 /* allocate a spare slot and store the name in that slot */
418 off = pad_add_name(name, len,
419 is_our ? padadd_OUR :
420 PL_parser->in_my == KEY_state ? padadd_STATE : 0,
421 PL_parser->in_my_stash,
423 /* $_ is always in main::, even with our */
424 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
428 /* anon sub prototypes contains state vars should always be cloned,
429 * otherwise the state var would be shared between anon subs */
431 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
432 CvCLONE_on(PL_compcv);
437 /* free the body of an op without examining its contents.
438 * Always use this rather than FreeOp directly */
441 S_op_destroy(pTHX_ OP *o)
443 if (o->op_latefree) {
451 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
453 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
459 Perl_op_free(pTHX_ OP *o)
466 if (o->op_latefreed) {
473 if (o->op_private & OPpREFCOUNTED) {
484 refcnt = OpREFCNT_dec(o);
487 /* Need to find and remove any pattern match ops from the list
488 we maintain for reset(). */
489 find_and_forget_pmops(o);
499 /* Call the op_free hook if it has been set. Do it now so that it's called
500 * at the right time for refcounted ops, but still before all of the kids
504 if (o->op_flags & OPf_KIDS) {
505 register OP *kid, *nextkid;
506 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
507 nextkid = kid->op_sibling; /* Get before next freeing kid */
512 #ifdef PERL_DEBUG_READONLY_OPS
516 /* COP* is not cleared by op_clear() so that we may track line
517 * numbers etc even after null() */
518 if (type == OP_NEXTSTATE || type == OP_DBSTATE
519 || (type == OP_NULL /* the COP might have been null'ed */
520 && ((OPCODE)o->op_targ == OP_NEXTSTATE
521 || (OPCODE)o->op_targ == OP_DBSTATE))) {
526 type = (OPCODE)o->op_targ;
529 if (o->op_latefree) {
535 #ifdef DEBUG_LEAKING_SCALARS
542 Perl_op_clear(pTHX_ OP *o)
547 PERL_ARGS_ASSERT_OP_CLEAR;
550 /* if (o->op_madprop && o->op_madprop->mad_next)
552 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
553 "modification of a read only value" for a reason I can't fathom why.
554 It's the "" stringification of $_, where $_ was set to '' in a foreach
555 loop, but it defies simplification into a small test case.
556 However, commenting them out has caused ext/List/Util/t/weak.t to fail
559 mad_free(o->op_madprop);
565 switch (o->op_type) {
566 case OP_NULL: /* Was holding old type, if any. */
567 if (PL_madskills && o->op_targ != OP_NULL) {
568 o->op_type = (Optype)o->op_targ;
573 case OP_ENTEREVAL: /* Was holding hints. */
577 if (!(o->op_flags & OPf_REF)
578 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
584 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
585 /* not an OP_PADAV replacement */
586 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
591 /* It's possible during global destruction that the GV is freed
592 before the optree. Whilst the SvREFCNT_inc is happy to bump from
593 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
594 will trigger an assertion failure, because the entry to sv_clear
595 checks that the scalar is not already freed. A check of for
596 !SvIS_FREED(gv) turns out to be invalid, because during global
597 destruction the reference count can be forced down to zero
598 (with SVf_BREAK set). In which case raising to 1 and then
599 dropping to 0 triggers cleanup before it should happen. I
600 *think* that this might actually be a general, systematic,
601 weakness of the whole idea of SVf_BREAK, in that code *is*
602 allowed to raise and lower references during global destruction,
603 so any *valid* code that happens to do this during global
604 destruction might well trigger premature cleanup. */
605 bool still_valid = gv && SvREFCNT(gv);
608 SvREFCNT_inc_simple_void(gv);
610 if (cPADOPo->op_padix > 0) {
611 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
612 * may still exist on the pad */
613 pad_swipe(cPADOPo->op_padix, TRUE);
614 cPADOPo->op_padix = 0;
617 SvREFCNT_dec(cSVOPo->op_sv);
618 cSVOPo->op_sv = NULL;
621 int try_downgrade = SvREFCNT(gv) == 2;
624 gv_try_downgrade(gv);
628 case OP_METHOD_NAMED:
631 SvREFCNT_dec(cSVOPo->op_sv);
632 cSVOPo->op_sv = NULL;
635 Even if op_clear does a pad_free for the target of the op,
636 pad_free doesn't actually remove the sv that exists in the pad;
637 instead it lives on. This results in that it could be reused as
638 a target later on when the pad was reallocated.
641 pad_swipe(o->op_targ,1);
650 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
654 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
656 if (cPADOPo->op_padix > 0) {
657 pad_swipe(cPADOPo->op_padix, TRUE);
658 cPADOPo->op_padix = 0;
661 SvREFCNT_dec(cSVOPo->op_sv);
662 cSVOPo->op_sv = NULL;
666 PerlMemShared_free(cPVOPo->op_pv);
667 cPVOPo->op_pv = NULL;
671 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
675 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
676 /* No GvIN_PAD_off here, because other references may still
677 * exist on the pad */
678 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
681 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
687 forget_pmop(cPMOPo, 1);
688 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
689 /* we use the same protection as the "SAFE" version of the PM_ macros
690 * here since sv_clean_all might release some PMOPs
691 * after PL_regex_padav has been cleared
692 * and the clearing of PL_regex_padav needs to
693 * happen before sv_clean_all
696 if(PL_regex_pad) { /* We could be in destruction */
697 const IV offset = (cPMOPo)->op_pmoffset;
698 ReREFCNT_dec(PM_GETRE(cPMOPo));
699 PL_regex_pad[offset] = &PL_sv_undef;
700 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
704 ReREFCNT_dec(PM_GETRE(cPMOPo));
705 PM_SETRE(cPMOPo, NULL);
711 if (o->op_targ > 0) {
712 pad_free(o->op_targ);
718 S_cop_free(pTHX_ COP* cop)
720 PERL_ARGS_ASSERT_COP_FREE;
724 if (! specialWARN(cop->cop_warnings))
725 PerlMemShared_free(cop->cop_warnings);
726 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
730 S_forget_pmop(pTHX_ PMOP *const o
736 HV * const pmstash = PmopSTASH(o);
738 PERL_ARGS_ASSERT_FORGET_PMOP;
740 if (pmstash && !SvIS_FREED(pmstash)) {
741 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
743 PMOP **const array = (PMOP**) mg->mg_ptr;
744 U32 count = mg->mg_len / sizeof(PMOP**);
749 /* Found it. Move the entry at the end to overwrite it. */
750 array[i] = array[--count];
751 mg->mg_len = count * sizeof(PMOP**);
752 /* Could realloc smaller at this point always, but probably
753 not worth it. Probably worth free()ing if we're the
756 Safefree(mg->mg_ptr);
773 S_find_and_forget_pmops(pTHX_ OP *o)
775 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
777 if (o->op_flags & OPf_KIDS) {
778 OP *kid = cUNOPo->op_first;
780 switch (kid->op_type) {
785 forget_pmop((PMOP*)kid, 0);
787 find_and_forget_pmops(kid);
788 kid = kid->op_sibling;
794 Perl_op_null(pTHX_ OP *o)
798 PERL_ARGS_ASSERT_OP_NULL;
800 if (o->op_type == OP_NULL)
804 o->op_targ = o->op_type;
805 o->op_type = OP_NULL;
806 o->op_ppaddr = PL_ppaddr[OP_NULL];
810 Perl_op_refcnt_lock(pTHX)
818 Perl_op_refcnt_unlock(pTHX)
825 /* Contextualizers */
827 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
830 S_linklist(pTHX_ OP *o)
834 PERL_ARGS_ASSERT_LINKLIST;
839 /* establish postfix order */
840 first = cUNOPo->op_first;
843 o->op_next = LINKLIST(first);
846 if (kid->op_sibling) {
847 kid->op_next = LINKLIST(kid->op_sibling);
848 kid = kid->op_sibling;
862 S_scalarkids(pTHX_ OP *o)
864 if (o && o->op_flags & OPf_KIDS) {
866 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
873 S_scalarboolean(pTHX_ OP *o)
877 PERL_ARGS_ASSERT_SCALARBOOLEAN;
879 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
880 if (ckWARN(WARN_SYNTAX)) {
881 const line_t oldline = CopLINE(PL_curcop);
883 if (PL_parser && PL_parser->copline != NOLINE)
884 CopLINE_set(PL_curcop, PL_parser->copline);
885 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
886 CopLINE_set(PL_curcop, oldline);
893 Perl_scalar(pTHX_ OP *o)
898 /* assumes no premature commitment */
899 if (!o || (PL_parser && PL_parser->error_count)
900 || (o->op_flags & OPf_WANT)
901 || o->op_type == OP_RETURN)
906 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
908 switch (o->op_type) {
910 scalar(cBINOPo->op_first);
915 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
925 if (o->op_flags & OPf_KIDS) {
926 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
932 kid = cLISTOPo->op_first;
934 kid = kid->op_sibling;
937 OP *sib = kid->op_sibling;
938 if (sib && kid->op_type != OP_LEAVEWHEN) {
939 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
949 PL_curcop = &PL_compiling;
954 kid = cLISTOPo->op_first;
957 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
964 Perl_scalarvoid(pTHX_ OP *o)
968 const char* useless = NULL;
972 PERL_ARGS_ASSERT_SCALARVOID;
974 /* trailing mad null ops don't count as "there" for void processing */
976 o->op_type != OP_NULL &&
978 o->op_sibling->op_type == OP_NULL)
981 for (sib = o->op_sibling;
982 sib && sib->op_type == OP_NULL;
983 sib = sib->op_sibling) ;
989 if (o->op_type == OP_NEXTSTATE
990 || o->op_type == OP_DBSTATE
991 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
992 || o->op_targ == OP_DBSTATE)))
993 PL_curcop = (COP*)o; /* for warning below */
995 /* assumes no premature commitment */
996 want = o->op_flags & OPf_WANT;
997 if ((want && want != OPf_WANT_SCALAR)
998 || (PL_parser && PL_parser->error_count)
999 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1004 if ((o->op_private & OPpTARGET_MY)
1005 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1007 return scalar(o); /* As if inside SASSIGN */
1010 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1012 switch (o->op_type) {
1014 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1018 if (o->op_flags & OPf_STACKED)
1022 if (o->op_private == 4)
1065 case OP_GETSOCKNAME:
1066 case OP_GETPEERNAME:
1071 case OP_GETPRIORITY:
1095 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1096 /* Otherwise it's "Useless use of grep iterator" */
1097 useless = OP_DESC(o);
1101 kid = cLISTOPo->op_first;
1102 if (kid && kid->op_type == OP_PUSHRE
1104 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1106 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1108 useless = OP_DESC(o);
1112 kid = cUNOPo->op_first;
1113 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1114 kid->op_type != OP_TRANS) {
1117 useless = "negative pattern binding (!~)";
1121 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1122 useless = "Non-destructive substitution (s///r)";
1129 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1130 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1131 useless = "a variable";
1136 if (cSVOPo->op_private & OPpCONST_STRICT)
1137 no_bareword_allowed(o);
1139 if (ckWARN(WARN_VOID)) {
1141 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1142 "a constant (%"SVf")", sv));
1143 useless = SvPV_nolen(msv);
1146 useless = "a constant (undef)";
1147 if (o->op_private & OPpCONST_ARYBASE)
1149 /* don't warn on optimised away booleans, eg
1150 * use constant Foo, 5; Foo || print; */
1151 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1153 /* the constants 0 and 1 are permitted as they are
1154 conventionally used as dummies in constructs like
1155 1 while some_condition_with_side_effects; */
1156 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1158 else if (SvPOK(sv)) {
1159 /* perl4's way of mixing documentation and code
1160 (before the invention of POD) was based on a
1161 trick to mix nroff and perl code. The trick was
1162 built upon these three nroff macros being used in
1163 void context. The pink camel has the details in
1164 the script wrapman near page 319. */
1165 const char * const maybe_macro = SvPVX_const(sv);
1166 if (strnEQ(maybe_macro, "di", 2) ||
1167 strnEQ(maybe_macro, "ds", 2) ||
1168 strnEQ(maybe_macro, "ig", 2))
1173 op_null(o); /* don't execute or even remember it */
1177 o->op_type = OP_PREINC; /* pre-increment is faster */
1178 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1182 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1183 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1187 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1188 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1192 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1193 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1198 kid = cLOGOPo->op_first;
1199 if (kid->op_type == OP_NOT
1200 && (kid->op_flags & OPf_KIDS)
1202 if (o->op_type == OP_AND) {
1204 o->op_ppaddr = PL_ppaddr[OP_OR];
1206 o->op_type = OP_AND;
1207 o->op_ppaddr = PL_ppaddr[OP_AND];
1216 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1221 if (o->op_flags & OPf_STACKED)
1228 if (!(o->op_flags & OPf_KIDS))
1239 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1249 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1254 S_listkids(pTHX_ OP *o)
1256 if (o && o->op_flags & OPf_KIDS) {
1258 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1265 Perl_list(pTHX_ OP *o)
1270 /* assumes no premature commitment */
1271 if (!o || (o->op_flags & OPf_WANT)
1272 || (PL_parser && PL_parser->error_count)
1273 || o->op_type == OP_RETURN)
1278 if ((o->op_private & OPpTARGET_MY)
1279 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1281 return o; /* As if inside SASSIGN */
1284 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1286 switch (o->op_type) {
1289 list(cBINOPo->op_first);
1294 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1302 if (!(o->op_flags & OPf_KIDS))
1304 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1305 list(cBINOPo->op_first);
1306 return gen_constant_list(o);
1313 kid = cLISTOPo->op_first;
1315 kid = kid->op_sibling;
1318 OP *sib = kid->op_sibling;
1319 if (sib && kid->op_type != OP_LEAVEWHEN) {
1320 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1330 PL_curcop = &PL_compiling;
1334 kid = cLISTOPo->op_first;
1341 S_scalarseq(pTHX_ OP *o)
1345 const OPCODE type = o->op_type;
1347 if (type == OP_LINESEQ || type == OP_SCOPE ||
1348 type == OP_LEAVE || type == OP_LEAVETRY)
1351 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1352 if (kid->op_sibling) {
1356 PL_curcop = &PL_compiling;
1358 o->op_flags &= ~OPf_PARENS;
1359 if (PL_hints & HINT_BLOCK_SCOPE)
1360 o->op_flags |= OPf_PARENS;
1363 o = newOP(OP_STUB, 0);
1368 S_modkids(pTHX_ OP *o, I32 type)
1370 if (o && o->op_flags & OPf_KIDS) {
1372 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1378 /* Propagate lvalue ("modifiable") context to an op and its children.
1379 * 'type' represents the context type, roughly based on the type of op that
1380 * would do the modifying, although local() is represented by OP_NULL.
1381 * It's responsible for detecting things that can't be modified, flag
1382 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1383 * might have to vivify a reference in $x), and so on.
1385 * For example, "$a+1 = 2" would cause mod() to be called with o being
1386 * OP_ADD and type being OP_SASSIGN, and would output an error.
1390 Perl_mod(pTHX_ OP *o, I32 type)
1394 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1397 if (!o || (PL_parser && PL_parser->error_count))
1400 if ((o->op_private & OPpTARGET_MY)
1401 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1406 switch (o->op_type) {
1412 if (!(o->op_private & OPpCONST_ARYBASE))
1415 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1416 CopARYBASE_set(&PL_compiling,
1417 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1421 SAVECOPARYBASE(&PL_compiling);
1422 CopARYBASE_set(&PL_compiling, 0);
1424 else if (type == OP_REFGEN)
1427 Perl_croak(aTHX_ "That use of $[ is unsupported");
1430 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1434 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1435 !(o->op_flags & OPf_STACKED)) {
1436 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1437 /* The default is to set op_private to the number of children,
1438 which for a UNOP such as RV2CV is always 1. And w're using
1439 the bit for a flag in RV2CV, so we need it clear. */
1440 o->op_private &= ~1;
1441 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1442 assert(cUNOPo->op_first->op_type == OP_NULL);
1443 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1446 else if (o->op_private & OPpENTERSUB_NOMOD)
1448 else { /* lvalue subroutine call */
1449 o->op_private |= OPpLVAL_INTRO;
1450 PL_modcount = RETURN_UNLIMITED_NUMBER;
1451 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1452 /* Backward compatibility mode: */
1453 o->op_private |= OPpENTERSUB_INARGS;
1456 else { /* Compile-time error message: */
1457 OP *kid = cUNOPo->op_first;
1461 if (kid->op_type != OP_PUSHMARK) {
1462 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1464 "panic: unexpected lvalue entersub "
1465 "args: type/targ %ld:%"UVuf,
1466 (long)kid->op_type, (UV)kid->op_targ);
1467 kid = kLISTOP->op_first;
1469 while (kid->op_sibling)
1470 kid = kid->op_sibling;
1471 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1473 if (kid->op_type == OP_METHOD_NAMED
1474 || kid->op_type == OP_METHOD)
1478 NewOp(1101, newop, 1, UNOP);
1479 newop->op_type = OP_RV2CV;
1480 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1481 newop->op_first = NULL;
1482 newop->op_next = (OP*)newop;
1483 kid->op_sibling = (OP*)newop;
1484 newop->op_private |= OPpLVAL_INTRO;
1485 newop->op_private &= ~1;
1489 if (kid->op_type != OP_RV2CV)
1491 "panic: unexpected lvalue entersub "
1492 "entry via type/targ %ld:%"UVuf,
1493 (long)kid->op_type, (UV)kid->op_targ);
1494 kid->op_private |= OPpLVAL_INTRO;
1495 break; /* Postpone until runtime */
1499 kid = kUNOP->op_first;
1500 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1501 kid = kUNOP->op_first;
1502 if (kid->op_type == OP_NULL)
1504 "Unexpected constant lvalue entersub "
1505 "entry via type/targ %ld:%"UVuf,
1506 (long)kid->op_type, (UV)kid->op_targ);
1507 if (kid->op_type != OP_GV) {
1508 /* Restore RV2CV to check lvalueness */
1510 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1511 okid->op_next = kid->op_next;
1512 kid->op_next = okid;
1515 okid->op_next = NULL;
1516 okid->op_type = OP_RV2CV;
1518 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1519 okid->op_private |= OPpLVAL_INTRO;
1520 okid->op_private &= ~1;
1524 cv = GvCV(kGVOP_gv);
1534 /* grep, foreach, subcalls, refgen */
1535 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1537 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1538 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1540 : (o->op_type == OP_ENTERSUB
1541 ? "non-lvalue subroutine call"
1543 type ? PL_op_desc[type] : "local"));
1557 case OP_RIGHT_SHIFT:
1566 if (!(o->op_flags & OPf_STACKED))
1573 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1579 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1580 PL_modcount = RETURN_UNLIMITED_NUMBER;
1581 return o; /* Treat \(@foo) like ordinary list. */
1585 if (scalar_mod_type(o, type))
1587 ref(cUNOPo->op_first, o->op_type);
1591 if (type == OP_LEAVESUBLV)
1592 o->op_private |= OPpMAYBE_LVSUB;
1598 PL_modcount = RETURN_UNLIMITED_NUMBER;
1601 PL_hints |= HINT_BLOCK_SCOPE;
1602 if (type == OP_LEAVESUBLV)
1603 o->op_private |= OPpMAYBE_LVSUB;
1607 ref(cUNOPo->op_first, o->op_type);
1611 PL_hints |= HINT_BLOCK_SCOPE;
1626 PL_modcount = RETURN_UNLIMITED_NUMBER;
1627 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1628 return o; /* Treat \(@foo) like ordinary list. */
1629 if (scalar_mod_type(o, type))
1631 if (type == OP_LEAVESUBLV)
1632 o->op_private |= OPpMAYBE_LVSUB;
1636 if (!type) /* local() */
1637 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1638 PAD_COMPNAME_PV(o->op_targ));
1646 if (type != OP_SASSIGN)
1650 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1655 if (type == OP_LEAVESUBLV)
1656 o->op_private |= OPpMAYBE_LVSUB;
1658 pad_free(o->op_targ);
1659 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1660 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1661 if (o->op_flags & OPf_KIDS)
1662 mod(cBINOPo->op_first->op_sibling, type);
1667 ref(cBINOPo->op_first, o->op_type);
1668 if (type == OP_ENTERSUB &&
1669 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1670 o->op_private |= OPpLVAL_DEFER;
1671 if (type == OP_LEAVESUBLV)
1672 o->op_private |= OPpMAYBE_LVSUB;
1682 if (o->op_flags & OPf_KIDS)
1683 mod(cLISTOPo->op_last, type);
1688 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1690 else if (!(o->op_flags & OPf_KIDS))
1692 if (o->op_targ != OP_LIST) {
1693 mod(cBINOPo->op_first, type);
1699 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1704 if (type != OP_LEAVESUBLV)
1706 break; /* mod()ing was handled by ck_return() */
1709 /* [20011101.069] File test operators interpret OPf_REF to mean that
1710 their argument is a filehandle; thus \stat(".") should not set
1712 if (type == OP_REFGEN &&
1713 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1716 if (type != OP_LEAVESUBLV)
1717 o->op_flags |= OPf_MOD;
1719 if (type == OP_AASSIGN || type == OP_SASSIGN)
1720 o->op_flags |= OPf_SPECIAL|OPf_REF;
1721 else if (!type) { /* local() */
1724 o->op_private |= OPpLVAL_INTRO;
1725 o->op_flags &= ~OPf_SPECIAL;
1726 PL_hints |= HINT_BLOCK_SCOPE;
1731 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1732 "Useless localization of %s", OP_DESC(o));
1735 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1736 && type != OP_LEAVESUBLV)
1737 o->op_flags |= OPf_REF;
1742 S_scalar_mod_type(const OP *o, I32 type)
1744 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1748 if (o->op_type == OP_RV2GV)
1772 case OP_RIGHT_SHIFT:
1792 S_is_handle_constructor(const OP *o, I32 numargs)
1794 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1796 switch (o->op_type) {
1804 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1817 S_refkids(pTHX_ OP *o, I32 type)
1819 if (o && o->op_flags & OPf_KIDS) {
1821 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1828 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1833 PERL_ARGS_ASSERT_DOREF;
1835 if (!o || (PL_parser && PL_parser->error_count))
1838 switch (o->op_type) {
1840 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1841 !(o->op_flags & OPf_STACKED)) {
1842 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1843 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1844 assert(cUNOPo->op_first->op_type == OP_NULL);
1845 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1846 o->op_flags |= OPf_SPECIAL;
1847 o->op_private &= ~1;
1852 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1853 doref(kid, type, set_op_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);
1861 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1862 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1863 : type == OP_RV2HV ? OPpDEREF_HV
1865 o->op_flags |= OPf_MOD;
1872 o->op_flags |= OPf_REF;
1875 if (type == OP_DEFINED)
1876 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1877 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1883 o->op_flags |= OPf_REF;
1888 if (!(o->op_flags & OPf_KIDS))
1890 doref(cBINOPo->op_first, type, set_op_ref);
1894 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1895 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1896 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1897 : type == OP_RV2HV ? OPpDEREF_HV
1899 o->op_flags |= OPf_MOD;
1909 if (!(o->op_flags & OPf_KIDS))
1911 doref(cLISTOPo->op_last, type, set_op_ref);
1921 S_dup_attrlist(pTHX_ OP *o)
1926 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1928 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1929 * where the first kid is OP_PUSHMARK and the remaining ones
1930 * are OP_CONST. We need to push the OP_CONST values.
1932 if (o->op_type == OP_CONST)
1933 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1935 else if (o->op_type == OP_NULL)
1939 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1941 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1942 if (o->op_type == OP_CONST)
1943 rop = append_elem(OP_LIST, rop,
1944 newSVOP(OP_CONST, o->op_flags,
1945 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1952 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1957 PERL_ARGS_ASSERT_APPLY_ATTRS;
1959 /* fake up C<use attributes $pkg,$rv,@attrs> */
1960 ENTER; /* need to protect against side-effects of 'use' */
1961 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1963 #define ATTRSMODULE "attributes"
1964 #define ATTRSMODULE_PM "attributes.pm"
1967 /* Don't force the C<use> if we don't need it. */
1968 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1969 if (svp && *svp != &PL_sv_undef)
1970 NOOP; /* already in %INC */
1972 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1973 newSVpvs(ATTRSMODULE), NULL);
1976 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1977 newSVpvs(ATTRSMODULE),
1979 prepend_elem(OP_LIST,
1980 newSVOP(OP_CONST, 0, stashsv),
1981 prepend_elem(OP_LIST,
1982 newSVOP(OP_CONST, 0,
1984 dup_attrlist(attrs))));
1990 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1993 OP *pack, *imop, *arg;
1996 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2001 assert(target->op_type == OP_PADSV ||
2002 target->op_type == OP_PADHV ||
2003 target->op_type == OP_PADAV);
2005 /* Ensure that attributes.pm is loaded. */
2006 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2008 /* Need package name for method call. */
2009 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2011 /* Build up the real arg-list. */
2012 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2014 arg = newOP(OP_PADSV, 0);
2015 arg->op_targ = target->op_targ;
2016 arg = prepend_elem(OP_LIST,
2017 newSVOP(OP_CONST, 0, stashsv),
2018 prepend_elem(OP_LIST,
2019 newUNOP(OP_REFGEN, 0,
2020 mod(arg, OP_REFGEN)),
2021 dup_attrlist(attrs)));
2023 /* Fake up a method call to import */
2024 meth = newSVpvs_share("import");
2025 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2026 append_elem(OP_LIST,
2027 prepend_elem(OP_LIST, pack, list(arg)),
2028 newSVOP(OP_METHOD_NAMED, 0, meth)));
2029 imop->op_private |= OPpENTERSUB_NOMOD;
2031 /* Combine the ops. */
2032 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2036 =notfor apidoc apply_attrs_string
2038 Attempts to apply a list of attributes specified by the C<attrstr> and
2039 C<len> arguments to the subroutine identified by the C<cv> argument which
2040 is expected to be associated with the package identified by the C<stashpv>
2041 argument (see L<attributes>). It gets this wrong, though, in that it
2042 does not correctly identify the boundaries of the individual attribute
2043 specifications within C<attrstr>. This is not really intended for the
2044 public API, but has to be listed here for systems such as AIX which
2045 need an explicit export list for symbols. (It's called from XS code
2046 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2047 to respect attribute syntax properly would be welcome.
2053 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2054 const char *attrstr, STRLEN len)
2058 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2061 len = strlen(attrstr);
2065 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2067 const char * const sstr = attrstr;
2068 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2069 attrs = append_elem(OP_LIST, attrs,
2070 newSVOP(OP_CONST, 0,
2071 newSVpvn(sstr, attrstr-sstr)));
2075 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2076 newSVpvs(ATTRSMODULE),
2077 NULL, prepend_elem(OP_LIST,
2078 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2079 prepend_elem(OP_LIST,
2080 newSVOP(OP_CONST, 0,
2081 newRV(MUTABLE_SV(cv))),
2086 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2091 PERL_ARGS_ASSERT_MY_KID;
2093 if (!o || (PL_parser && PL_parser->error_count))
2097 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2098 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2102 if (type == OP_LIST) {
2104 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2105 my_kid(kid, attrs, imopsp);
2106 } else if (type == OP_UNDEF
2112 } else if (type == OP_RV2SV || /* "our" declaration */
2114 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2115 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2116 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2118 PL_parser->in_my == KEY_our
2120 : PL_parser->in_my == KEY_state ? "state" : "my"));
2122 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2123 PL_parser->in_my = FALSE;
2124 PL_parser->in_my_stash = NULL;
2125 apply_attrs(GvSTASH(gv),
2126 (type == OP_RV2SV ? GvSV(gv) :
2127 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2128 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2131 o->op_private |= OPpOUR_INTRO;
2134 else if (type != OP_PADSV &&
2137 type != OP_PUSHMARK)
2139 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2141 PL_parser->in_my == KEY_our
2143 : PL_parser->in_my == KEY_state ? "state" : "my"));
2146 else if (attrs && type != OP_PUSHMARK) {
2149 PL_parser->in_my = FALSE;
2150 PL_parser->in_my_stash = NULL;
2152 /* check for C<my Dog $spot> when deciding package */
2153 stash = PAD_COMPNAME_TYPE(o->op_targ);
2155 stash = PL_curstash;
2156 apply_attrs_my(stash, o, attrs, imopsp);
2158 o->op_flags |= OPf_MOD;
2159 o->op_private |= OPpLVAL_INTRO;
2160 if (PL_parser->in_my == KEY_state)
2161 o->op_private |= OPpPAD_STATE;
2166 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2170 int maybe_scalar = 0;
2172 PERL_ARGS_ASSERT_MY_ATTRS;
2174 /* [perl #17376]: this appears to be premature, and results in code such as
2175 C< our(%x); > executing in list mode rather than void mode */
2177 if (o->op_flags & OPf_PARENS)
2187 o = my_kid(o, attrs, &rops);
2189 if (maybe_scalar && o->op_type == OP_PADSV) {
2190 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2191 o->op_private |= OPpLVAL_INTRO;
2194 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2196 PL_parser->in_my = FALSE;
2197 PL_parser->in_my_stash = NULL;
2202 Perl_sawparens(pTHX_ OP *o)
2204 PERL_UNUSED_CONTEXT;
2206 o->op_flags |= OPf_PARENS;
2211 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2215 const OPCODE ltype = left->op_type;
2216 const OPCODE rtype = right->op_type;
2218 PERL_ARGS_ASSERT_BIND_MATCH;
2220 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2221 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2223 const char * const desc
2224 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2225 ? (int)rtype : OP_MATCH];
2226 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2227 ? "@array" : "%hash");
2228 Perl_warner(aTHX_ packWARN(WARN_MISC),
2229 "Applying %s to %s will act on scalar(%s)",
2230 desc, sample, sample);
2233 if (rtype == OP_CONST &&
2234 cSVOPx(right)->op_private & OPpCONST_BARE &&
2235 cSVOPx(right)->op_private & OPpCONST_STRICT)
2237 no_bareword_allowed(right);
2240 /* !~ doesn't make sense with s///r, so error on it for now */
2241 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2243 yyerror("Using !~ with s///r doesn't make sense");
2245 ismatchop = rtype == OP_MATCH ||
2246 rtype == OP_SUBST ||
2248 if (ismatchop && right->op_private & OPpTARGET_MY) {
2250 right->op_private &= ~OPpTARGET_MY;
2252 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2255 right->op_flags |= OPf_STACKED;
2256 if (rtype != OP_MATCH &&
2257 ! (rtype == OP_TRANS &&
2258 right->op_private & OPpTRANS_IDENTICAL) &&
2259 ! (rtype == OP_SUBST &&
2260 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2261 newleft = mod(left, rtype);
2264 if (right->op_type == OP_TRANS)
2265 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2267 o = prepend_elem(rtype, scalar(newleft), right);
2269 return newUNOP(OP_NOT, 0, scalar(o));
2273 return bind_match(type, left,
2274 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2278 Perl_invert(pTHX_ OP *o)
2282 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2286 Perl_scope(pTHX_ OP *o)
2290 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2291 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2292 o->op_type = OP_LEAVE;
2293 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2295 else if (o->op_type == OP_LINESEQ) {
2297 o->op_type = OP_SCOPE;
2298 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2299 kid = ((LISTOP*)o)->op_first;
2300 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2303 /* The following deals with things like 'do {1 for 1}' */
2304 kid = kid->op_sibling;
2306 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2311 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2317 Perl_block_start(pTHX_ int full)
2320 const int retval = PL_savestack_ix;
2322 pad_block_start(full);
2324 PL_hints &= ~HINT_BLOCK_SCOPE;
2325 SAVECOMPILEWARNINGS();
2326 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2328 CALL_BLOCK_HOOKS(start, full);
2334 Perl_block_end(pTHX_ I32 floor, OP *seq)
2337 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2338 OP* retval = scalarseq(seq);
2340 CALL_BLOCK_HOOKS(pre_end, &retval);
2343 CopHINTS_set(&PL_compiling, PL_hints);
2345 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2348 CALL_BLOCK_HOOKS(post_end, &retval);
2354 =head1 Compile-time scope hooks
2356 =for apidoc Ao||blockhook_register
2358 Register a set of hooks to be called when the Perl lexical scope changes
2359 at compile time. See L<perlguts/"Compile-time scope hooks">.
2365 Perl_blockhook_register(pTHX_ BHK *hk)
2367 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2369 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2376 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2377 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2378 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2381 OP * const o = newOP(OP_PADSV, 0);
2382 o->op_targ = offset;
2388 Perl_newPROG(pTHX_ OP *o)
2392 PERL_ARGS_ASSERT_NEWPROG;
2397 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2398 ((PL_in_eval & EVAL_KEEPERR)
2399 ? OPf_SPECIAL : 0), o);
2400 PL_eval_start = linklist(PL_eval_root);
2401 PL_eval_root->op_private |= OPpREFCOUNTED;
2402 OpREFCNT_set(PL_eval_root, 1);
2403 PL_eval_root->op_next = 0;
2404 CALL_PEEP(PL_eval_start);
2407 if (o->op_type == OP_STUB) {
2408 PL_comppad_name = 0;
2410 S_op_destroy(aTHX_ o);
2413 PL_main_root = scope(sawparens(scalarvoid(o)));
2414 PL_curcop = &PL_compiling;
2415 PL_main_start = LINKLIST(PL_main_root);
2416 PL_main_root->op_private |= OPpREFCOUNTED;
2417 OpREFCNT_set(PL_main_root, 1);
2418 PL_main_root->op_next = 0;
2419 CALL_PEEP(PL_main_start);
2422 /* Register with debugger */
2424 CV * const cv = get_cvs("DB::postponed", 0);
2428 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2430 call_sv(MUTABLE_SV(cv), G_DISCARD);
2437 Perl_localize(pTHX_ OP *o, I32 lex)
2441 PERL_ARGS_ASSERT_LOCALIZE;
2443 if (o->op_flags & OPf_PARENS)
2444 /* [perl #17376]: this appears to be premature, and results in code such as
2445 C< our(%x); > executing in list mode rather than void mode */
2452 if ( PL_parser->bufptr > PL_parser->oldbufptr
2453 && PL_parser->bufptr[-1] == ','
2454 && ckWARN(WARN_PARENTHESIS))
2456 char *s = PL_parser->bufptr;
2459 /* some heuristics to detect a potential error */
2460 while (*s && (strchr(", \t\n", *s)))
2464 if (*s && strchr("@$%*", *s) && *++s
2465 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2468 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2470 while (*s && (strchr(", \t\n", *s)))
2476 if (sigil && (*s == ';' || *s == '=')) {
2477 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2478 "Parentheses missing around \"%s\" list",
2480 ? (PL_parser->in_my == KEY_our
2482 : PL_parser->in_my == KEY_state
2492 o = mod(o, OP_NULL); /* a bit kludgey */
2493 PL_parser->in_my = FALSE;
2494 PL_parser->in_my_stash = NULL;
2499 Perl_jmaybe(pTHX_ OP *o)
2501 PERL_ARGS_ASSERT_JMAYBE;
2503 if (o->op_type == OP_LIST) {
2505 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2506 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2512 S_fold_constants(pTHX_ register OP *o)
2515 register OP * VOL curop;
2517 VOL I32 type = o->op_type;
2522 SV * const oldwarnhook = PL_warnhook;
2523 SV * const olddiehook = PL_diehook;
2527 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2529 if (PL_opargs[type] & OA_RETSCALAR)
2531 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2532 o->op_targ = pad_alloc(type, SVs_PADTMP);
2534 /* integerize op, unless it happens to be C<-foo>.
2535 * XXX should pp_i_negate() do magic string negation instead? */
2536 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2537 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2538 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2540 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2543 if (!(PL_opargs[type] & OA_FOLDCONST))
2548 /* XXX might want a ck_negate() for this */
2549 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2560 /* XXX what about the numeric ops? */
2561 if (PL_hints & HINT_LOCALE)
2566 if (PL_parser && PL_parser->error_count)
2567 goto nope; /* Don't try to run w/ errors */
2569 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2570 const OPCODE type = curop->op_type;
2571 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2573 type != OP_SCALAR &&
2575 type != OP_PUSHMARK)
2581 curop = LINKLIST(o);
2582 old_next = o->op_next;
2586 oldscope = PL_scopestack_ix;
2587 create_eval_scope(G_FAKINGEVAL);
2589 /* Verify that we don't need to save it: */
2590 assert(PL_curcop == &PL_compiling);
2591 StructCopy(&PL_compiling, ¬_compiling, COP);
2592 PL_curcop = ¬_compiling;
2593 /* The above ensures that we run with all the correct hints of the
2594 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2595 assert(IN_PERL_RUNTIME);
2596 PL_warnhook = PERL_WARNHOOK_FATAL;
2603 sv = *(PL_stack_sp--);
2604 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2605 pad_swipe(o->op_targ, FALSE);
2606 else if (SvTEMP(sv)) { /* grab mortal temp? */
2607 SvREFCNT_inc_simple_void(sv);
2612 /* Something tried to die. Abandon constant folding. */
2613 /* Pretend the error never happened. */
2615 o->op_next = old_next;
2619 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2620 PL_warnhook = oldwarnhook;
2621 PL_diehook = olddiehook;
2622 /* XXX note that this croak may fail as we've already blown away
2623 * the stack - eg any nested evals */
2624 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2627 PL_warnhook = oldwarnhook;
2628 PL_diehook = olddiehook;
2629 PL_curcop = &PL_compiling;
2631 if (PL_scopestack_ix > oldscope)
2632 delete_eval_scope();
2641 if (type == OP_RV2GV)
2642 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2644 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2645 op_getmad(o,newop,'f');
2653 S_gen_constant_list(pTHX_ register OP *o)
2657 const I32 oldtmps_floor = PL_tmps_floor;
2660 if (PL_parser && PL_parser->error_count)
2661 return o; /* Don't attempt to run with errors */
2663 PL_op = curop = LINKLIST(o);
2669 assert (!(curop->op_flags & OPf_SPECIAL));
2670 assert(curop->op_type == OP_RANGE);
2672 PL_tmps_floor = oldtmps_floor;
2674 o->op_type = OP_RV2AV;
2675 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2676 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2677 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2678 o->op_opt = 0; /* needs to be revisited in peep() */
2679 curop = ((UNOP*)o)->op_first;
2680 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2682 op_getmad(curop,o,'O');
2691 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2694 if (!o || o->op_type != OP_LIST)
2695 o = newLISTOP(OP_LIST, 0, o, NULL);
2697 o->op_flags &= ~OPf_WANT;
2699 if (!(PL_opargs[type] & OA_MARK))
2700 op_null(cLISTOPo->op_first);
2702 o->op_type = (OPCODE)type;
2703 o->op_ppaddr = PL_ppaddr[type];
2704 o->op_flags |= flags;
2706 o = CHECKOP(type, o);
2707 if (o->op_type != (unsigned)type)
2710 return fold_constants(o);
2713 /* List constructors */
2716 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2724 if (first->op_type != (unsigned)type
2725 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2727 return newLISTOP(type, 0, first, last);
2730 if (first->op_flags & OPf_KIDS)
2731 ((LISTOP*)first)->op_last->op_sibling = last;
2733 first->op_flags |= OPf_KIDS;
2734 ((LISTOP*)first)->op_first = last;
2736 ((LISTOP*)first)->op_last = last;
2741 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2749 if (first->op_type != (unsigned)type)
2750 return prepend_elem(type, (OP*)first, (OP*)last);
2752 if (last->op_type != (unsigned)type)
2753 return append_elem(type, (OP*)first, (OP*)last);
2755 first->op_last->op_sibling = last->op_first;
2756 first->op_last = last->op_last;
2757 first->op_flags |= (last->op_flags & OPf_KIDS);
2760 if (last->op_first && first->op_madprop) {
2761 MADPROP *mp = last->op_first->op_madprop;
2763 while (mp->mad_next)
2765 mp->mad_next = first->op_madprop;
2768 last->op_first->op_madprop = first->op_madprop;
2771 first->op_madprop = last->op_madprop;
2772 last->op_madprop = 0;
2775 S_op_destroy(aTHX_ (OP*)last);
2781 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2789 if (last->op_type == (unsigned)type) {
2790 if (type == OP_LIST) { /* already a PUSHMARK there */
2791 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2792 ((LISTOP*)last)->op_first->op_sibling = first;
2793 if (!(first->op_flags & OPf_PARENS))
2794 last->op_flags &= ~OPf_PARENS;
2797 if (!(last->op_flags & OPf_KIDS)) {
2798 ((LISTOP*)last)->op_last = first;
2799 last->op_flags |= OPf_KIDS;
2801 first->op_sibling = ((LISTOP*)last)->op_first;
2802 ((LISTOP*)last)->op_first = first;
2804 last->op_flags |= OPf_KIDS;
2808 return newLISTOP(type, 0, first, last);
2816 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2819 Newxz(tk, 1, TOKEN);
2820 tk->tk_type = (OPCODE)optype;
2821 tk->tk_type = 12345;
2823 tk->tk_mad = madprop;
2828 Perl_token_free(pTHX_ TOKEN* tk)
2830 PERL_ARGS_ASSERT_TOKEN_FREE;
2832 if (tk->tk_type != 12345)
2834 mad_free(tk->tk_mad);
2839 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2844 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2846 if (tk->tk_type != 12345) {
2847 Perl_warner(aTHX_ packWARN(WARN_MISC),
2848 "Invalid TOKEN object ignored");
2855 /* faked up qw list? */
2857 tm->mad_type == MAD_SV &&
2858 SvPVX((SV *)tm->mad_val)[0] == 'q')
2865 /* pretend constant fold didn't happen? */
2866 if (mp->mad_key == 'f' &&
2867 (o->op_type == OP_CONST ||
2868 o->op_type == OP_GV) )
2870 token_getmad(tk,(OP*)mp->mad_val,slot);
2884 if (mp->mad_key == 'X')
2885 mp->mad_key = slot; /* just change the first one */
2895 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2904 /* pretend constant fold didn't happen? */
2905 if (mp->mad_key == 'f' &&
2906 (o->op_type == OP_CONST ||
2907 o->op_type == OP_GV) )
2909 op_getmad(from,(OP*)mp->mad_val,slot);
2916 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2919 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2925 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2934 /* pretend constant fold didn't happen? */
2935 if (mp->mad_key == 'f' &&
2936 (o->op_type == OP_CONST ||
2937 o->op_type == OP_GV) )
2939 op_getmad(from,(OP*)mp->mad_val,slot);
2946 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2949 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2953 PerlIO_printf(PerlIO_stderr(),
2954 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2960 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2978 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2982 addmad(tm, &(o->op_madprop), slot);
2986 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3007 Perl_newMADsv(pTHX_ char key, SV* sv)
3009 PERL_ARGS_ASSERT_NEWMADSV;
3011 return newMADPROP(key, MAD_SV, sv, 0);
3015 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3018 Newxz(mp, 1, MADPROP);
3021 mp->mad_vlen = vlen;
3022 mp->mad_type = type;
3024 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3029 Perl_mad_free(pTHX_ MADPROP* mp)
3031 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3035 mad_free(mp->mad_next);
3036 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3037 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3038 switch (mp->mad_type) {
3042 Safefree((char*)mp->mad_val);
3045 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3046 op_free((OP*)mp->mad_val);
3049 sv_free(MUTABLE_SV(mp->mad_val));
3052 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3061 Perl_newNULLLIST(pTHX)
3063 return newOP(OP_STUB, 0);
3067 S_force_list(pTHX_ OP *o)
3069 if (!o || o->op_type != OP_LIST)
3070 o = newLISTOP(OP_LIST, 0, o, NULL);
3076 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3081 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3083 NewOp(1101, listop, 1, LISTOP);
3085 listop->op_type = (OPCODE)type;
3086 listop->op_ppaddr = PL_ppaddr[type];
3089 listop->op_flags = (U8)flags;
3093 else if (!first && last)
3096 first->op_sibling = last;
3097 listop->op_first = first;
3098 listop->op_last = last;
3099 if (type == OP_LIST) {
3100 OP* const pushop = newOP(OP_PUSHMARK, 0);
3101 pushop->op_sibling = first;
3102 listop->op_first = pushop;
3103 listop->op_flags |= OPf_KIDS;
3105 listop->op_last = pushop;
3108 return CHECKOP(type, listop);
3112 Perl_newOP(pTHX_ I32 type, I32 flags)
3117 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3118 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3119 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3120 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3122 NewOp(1101, o, 1, OP);
3123 o->op_type = (OPCODE)type;
3124 o->op_ppaddr = PL_ppaddr[type];
3125 o->op_flags = (U8)flags;
3127 o->op_latefreed = 0;
3131 o->op_private = (U8)(0 | (flags >> 8));
3132 if (PL_opargs[type] & OA_RETSCALAR)
3134 if (PL_opargs[type] & OA_TARGET)
3135 o->op_targ = pad_alloc(type, SVs_PADTMP);
3136 return CHECKOP(type, o);
3140 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3145 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3146 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3147 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3148 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3149 || type == OP_SASSIGN
3150 || type == OP_ENTERTRY
3151 || type == OP_NULL );
3154 first = newOP(OP_STUB, 0);
3155 if (PL_opargs[type] & OA_MARK)
3156 first = force_list(first);
3158 NewOp(1101, unop, 1, UNOP);
3159 unop->op_type = (OPCODE)type;
3160 unop->op_ppaddr = PL_ppaddr[type];
3161 unop->op_first = first;
3162 unop->op_flags = (U8)(flags | OPf_KIDS);
3163 unop->op_private = (U8)(1 | (flags >> 8));
3164 unop = (UNOP*) CHECKOP(type, unop);
3168 return fold_constants((OP *) unop);
3172 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3177 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3178 || type == OP_SASSIGN || type == OP_NULL );
3180 NewOp(1101, binop, 1, BINOP);
3183 first = newOP(OP_NULL, 0);
3185 binop->op_type = (OPCODE)type;
3186 binop->op_ppaddr = PL_ppaddr[type];
3187 binop->op_first = first;
3188 binop->op_flags = (U8)(flags | OPf_KIDS);
3191 binop->op_private = (U8)(1 | (flags >> 8));
3194 binop->op_private = (U8)(2 | (flags >> 8));
3195 first->op_sibling = last;
3198 binop = (BINOP*)CHECKOP(type, binop);
3199 if (binop->op_next || binop->op_type != (OPCODE)type)
3202 binop->op_last = binop->op_first->op_sibling;
3204 return fold_constants((OP *)binop);
3207 static int uvcompare(const void *a, const void *b)
3208 __attribute__nonnull__(1)
3209 __attribute__nonnull__(2)
3210 __attribute__pure__;
3211 static int uvcompare(const void *a, const void *b)
3213 if (*((const UV *)a) < (*(const UV *)b))
3215 if (*((const UV *)a) > (*(const UV *)b))
3217 if (*((const UV *)a+1) < (*(const UV *)b+1))
3219 if (*((const UV *)a+1) > (*(const UV *)b+1))
3225 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3228 SV * const tstr = ((SVOP*)expr)->op_sv;
3231 (repl->op_type == OP_NULL)
3232 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3234 ((SVOP*)repl)->op_sv;
3237 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3238 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3242 register short *tbl;
3244 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3245 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3246 I32 del = o->op_private & OPpTRANS_DELETE;
3249 PERL_ARGS_ASSERT_PMTRANS;
3251 PL_hints |= HINT_BLOCK_SCOPE;
3254 o->op_private |= OPpTRANS_FROM_UTF;
3257 o->op_private |= OPpTRANS_TO_UTF;
3259 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3260 SV* const listsv = newSVpvs("# comment\n");
3262 const U8* tend = t + tlen;
3263 const U8* rend = r + rlen;
3277 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3278 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3281 const U32 flags = UTF8_ALLOW_DEFAULT;
3285 t = tsave = bytes_to_utf8(t, &len);
3288 if (!to_utf && rlen) {
3290 r = rsave = bytes_to_utf8(r, &len);
3294 /* There are several snags with this code on EBCDIC:
3295 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3296 2. scan_const() in toke.c has encoded chars in native encoding which makes
3297 ranges at least in EBCDIC 0..255 range the bottom odd.
3301 U8 tmpbuf[UTF8_MAXBYTES+1];
3304 Newx(cp, 2*tlen, UV);
3306 transv = newSVpvs("");
3308 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3310 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3312 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3316 cp[2*i+1] = cp[2*i];
3320 qsort(cp, i, 2*sizeof(UV), uvcompare);
3321 for (j = 0; j < i; j++) {
3323 diff = val - nextmin;
3325 t = uvuni_to_utf8(tmpbuf,nextmin);
3326 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3328 U8 range_mark = UTF_TO_NATIVE(0xff);
3329 t = uvuni_to_utf8(tmpbuf, val - 1);
3330 sv_catpvn(transv, (char *)&range_mark, 1);
3331 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3338 t = uvuni_to_utf8(tmpbuf,nextmin);
3339 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3341 U8 range_mark = UTF_TO_NATIVE(0xff);
3342 sv_catpvn(transv, (char *)&range_mark, 1);
3344 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3345 UNICODE_ALLOW_SUPER);
3346 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3347 t = (const U8*)SvPVX_const(transv);
3348 tlen = SvCUR(transv);
3352 else if (!rlen && !del) {
3353 r = t; rlen = tlen; rend = tend;
3356 if ((!rlen && !del) || t == r ||
3357 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3359 o->op_private |= OPpTRANS_IDENTICAL;
3363 while (t < tend || tfirst <= tlast) {
3364 /* see if we need more "t" chars */
3365 if (tfirst > tlast) {
3366 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3368 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3370 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3377 /* now see if we need more "r" chars */
3378 if (rfirst > rlast) {
3380 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3382 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3384 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3393 rfirst = rlast = 0xffffffff;
3397 /* now see which range will peter our first, if either. */
3398 tdiff = tlast - tfirst;
3399 rdiff = rlast - rfirst;
3406 if (rfirst == 0xffffffff) {
3407 diff = tdiff; /* oops, pretend rdiff is infinite */
3409 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3410 (long)tfirst, (long)tlast);
3412 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3416 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3417 (long)tfirst, (long)(tfirst + diff),
3420 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3421 (long)tfirst, (long)rfirst);
3423 if (rfirst + diff > max)
3424 max = rfirst + diff;
3426 grows = (tfirst < rfirst &&
3427 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3439 else if (max > 0xff)
3444 PerlMemShared_free(cPVOPo->op_pv);
3445 cPVOPo->op_pv = NULL;
3447 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3449 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3450 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3451 PAD_SETSV(cPADOPo->op_padix, swash);
3453 SvREADONLY_on(swash);
3455 cSVOPo->op_sv = swash;
3457 SvREFCNT_dec(listsv);
3458 SvREFCNT_dec(transv);
3460 if (!del && havefinal && rlen)
3461 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3462 newSVuv((UV)final), 0);
3465 o->op_private |= OPpTRANS_GROWS;
3471 op_getmad(expr,o,'e');
3472 op_getmad(repl,o,'r');
3480 tbl = (short*)cPVOPo->op_pv;
3482 Zero(tbl, 256, short);
3483 for (i = 0; i < (I32)tlen; i++)
3485 for (i = 0, j = 0; i < 256; i++) {
3487 if (j >= (I32)rlen) {
3496 if (i < 128 && r[j] >= 128)
3506 o->op_private |= OPpTRANS_IDENTICAL;
3508 else if (j >= (I32)rlen)
3513 PerlMemShared_realloc(tbl,
3514 (0x101+rlen-j) * sizeof(short));
3515 cPVOPo->op_pv = (char*)tbl;
3517 tbl[0x100] = (short)(rlen - j);
3518 for (i=0; i < (I32)rlen - j; i++)
3519 tbl[0x101+i] = r[j+i];
3523 if (!rlen && !del) {
3526 o->op_private |= OPpTRANS_IDENTICAL;
3528 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3529 o->op_private |= OPpTRANS_IDENTICAL;
3531 for (i = 0; i < 256; i++)
3533 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3534 if (j >= (I32)rlen) {
3536 if (tbl[t[i]] == -1)
3542 if (tbl[t[i]] == -1) {
3543 if (t[i] < 128 && r[j] >= 128)
3550 if(del && rlen == tlen) {
3551 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3552 } else if(rlen > tlen) {
3553 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3557 o->op_private |= OPpTRANS_GROWS;
3559 op_getmad(expr,o,'e');
3560 op_getmad(repl,o,'r');
3570 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3575 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3577 NewOp(1101, pmop, 1, PMOP);
3578 pmop->op_type = (OPCODE)type;
3579 pmop->op_ppaddr = PL_ppaddr[type];
3580 pmop->op_flags = (U8)flags;
3581 pmop->op_private = (U8)(0 | (flags >> 8));
3583 if (PL_hints & HINT_RE_TAINT)
3584 pmop->op_pmflags |= PMf_RETAINT;
3585 if (PL_hints & HINT_LOCALE)
3586 pmop->op_pmflags |= PMf_LOCALE;
3590 assert(SvPOK(PL_regex_pad[0]));
3591 if (SvCUR(PL_regex_pad[0])) {
3592 /* Pop off the "packed" IV from the end. */
3593 SV *const repointer_list = PL_regex_pad[0];
3594 const char *p = SvEND(repointer_list) - sizeof(IV);
3595 const IV offset = *((IV*)p);
3597 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3599 SvEND_set(repointer_list, p);
3601 pmop->op_pmoffset = offset;
3602 /* This slot should be free, so assert this: */
3603 assert(PL_regex_pad[offset] == &PL_sv_undef);
3605 SV * const repointer = &PL_sv_undef;
3606 av_push(PL_regex_padav, repointer);
3607 pmop->op_pmoffset = av_len(PL_regex_padav);
3608 PL_regex_pad = AvARRAY(PL_regex_padav);
3612 return CHECKOP(type, pmop);
3615 /* Given some sort of match op o, and an expression expr containing a
3616 * pattern, either compile expr into a regex and attach it to o (if it's
3617 * constant), or convert expr into a runtime regcomp op sequence (if it's
3620 * isreg indicates that the pattern is part of a regex construct, eg
3621 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3622 * split "pattern", which aren't. In the former case, expr will be a list
3623 * if the pattern contains more than one term (eg /a$b/) or if it contains
3624 * a replacement, ie s/// or tr///.
3628 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3633 I32 repl_has_vars = 0;
3637 PERL_ARGS_ASSERT_PMRUNTIME;
3639 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3640 /* last element in list is the replacement; pop it */
3642 repl = cLISTOPx(expr)->op_last;
3643 kid = cLISTOPx(expr)->op_first;
3644 while (kid->op_sibling != repl)
3645 kid = kid->op_sibling;
3646 kid->op_sibling = NULL;
3647 cLISTOPx(expr)->op_last = kid;
3650 if (isreg && expr->op_type == OP_LIST &&
3651 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3653 /* convert single element list to element */
3654 OP* const oe = expr;
3655 expr = cLISTOPx(oe)->op_first->op_sibling;
3656 cLISTOPx(oe)->op_first->op_sibling = NULL;
3657 cLISTOPx(oe)->op_last = NULL;
3661 if (o->op_type == OP_TRANS) {
3662 return pmtrans(o, expr, repl);
3665 reglist = isreg && expr->op_type == OP_LIST;
3669 PL_hints |= HINT_BLOCK_SCOPE;
3672 if (expr->op_type == OP_CONST) {
3673 SV *pat = ((SVOP*)expr)->op_sv;
3674 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3676 if (o->op_flags & OPf_SPECIAL)
3677 pm_flags |= RXf_SPLIT;
3680 assert (SvUTF8(pat));
3681 } else if (SvUTF8(pat)) {
3682 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3683 trapped in use 'bytes'? */
3684 /* Make a copy of the octet sequence, but without the flag on, as
3685 the compiler now honours the SvUTF8 flag on pat. */
3687 const char *const p = SvPV(pat, len);
3688 pat = newSVpvn_flags(p, len, SVs_TEMP);
3691 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3694 op_getmad(expr,(OP*)pm,'e');
3700 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3701 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3703 : OP_REGCMAYBE),0,expr);
3705 NewOp(1101, rcop, 1, LOGOP);
3706 rcop->op_type = OP_REGCOMP;
3707 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3708 rcop->op_first = scalar(expr);
3709 rcop->op_flags |= OPf_KIDS
3710 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3711 | (reglist ? OPf_STACKED : 0);
3712 rcop->op_private = 1;
3715 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3717 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3720 /* establish postfix order */
3721 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3723 rcop->op_next = expr;
3724 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3727 rcop->op_next = LINKLIST(expr);
3728 expr->op_next = (OP*)rcop;
3731 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3736 if (pm->op_pmflags & PMf_EVAL) {
3738 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3739 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3741 else if (repl->op_type == OP_CONST)
3745 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3746 if (curop->op_type == OP_SCOPE
3747 || curop->op_type == OP_LEAVE
3748 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3749 if (curop->op_type == OP_GV) {
3750 GV * const gv = cGVOPx_gv(curop);
3752 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3755 else if (curop->op_type == OP_RV2CV)
3757 else if (curop->op_type == OP_RV2SV ||
3758 curop->op_type == OP_RV2AV ||
3759 curop->op_type == OP_RV2HV ||
3760 curop->op_type == OP_RV2GV) {
3761 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3764 else if (curop->op_type == OP_PADSV ||
3765 curop->op_type == OP_PADAV ||
3766 curop->op_type == OP_PADHV ||
3767 curop->op_type == OP_PADANY)
3771 else if (curop->op_type == OP_PUSHRE)
3772 NOOP; /* Okay here, dangerous in newASSIGNOP */
3782 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3784 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3785 prepend_elem(o->op_type, scalar(repl), o);
3788 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3789 pm->op_pmflags |= PMf_MAYBE_CONST;
3791 NewOp(1101, rcop, 1, LOGOP);
3792 rcop->op_type = OP_SUBSTCONT;
3793 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3794 rcop->op_first = scalar(repl);
3795 rcop->op_flags |= OPf_KIDS;
3796 rcop->op_private = 1;
3799 /* establish postfix order */
3800 rcop->op_next = LINKLIST(repl);
3801 repl->op_next = (OP*)rcop;
3803 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3804 assert(!(pm->op_pmflags & PMf_ONCE));
3805 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3814 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3819 PERL_ARGS_ASSERT_NEWSVOP;
3821 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3822 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3823 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3825 NewOp(1101, svop, 1, SVOP);
3826 svop->op_type = (OPCODE)type;
3827 svop->op_ppaddr = PL_ppaddr[type];
3829 svop->op_next = (OP*)svop;
3830 svop->op_flags = (U8)flags;
3831 if (PL_opargs[type] & OA_RETSCALAR)
3833 if (PL_opargs[type] & OA_TARGET)
3834 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3835 return CHECKOP(type, svop);
3840 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3845 PERL_ARGS_ASSERT_NEWPADOP;
3847 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3848 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3849 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3851 NewOp(1101, padop, 1, PADOP);
3852 padop->op_type = (OPCODE)type;
3853 padop->op_ppaddr = PL_ppaddr[type];
3854 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3855 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3856 PAD_SETSV(padop->op_padix, sv);
3859 padop->op_next = (OP*)padop;
3860 padop->op_flags = (U8)flags;
3861 if (PL_opargs[type] & OA_RETSCALAR)
3863 if (PL_opargs[type] & OA_TARGET)
3864 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3865 return CHECKOP(type, padop);
3870 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3874 PERL_ARGS_ASSERT_NEWGVOP;
3878 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3880 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3885 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3890 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3891 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3893 NewOp(1101, pvop, 1, PVOP);
3894 pvop->op_type = (OPCODE)type;
3895 pvop->op_ppaddr = PL_ppaddr[type];
3897 pvop->op_next = (OP*)pvop;
3898 pvop->op_flags = (U8)flags;
3899 if (PL_opargs[type] & OA_RETSCALAR)
3901 if (PL_opargs[type] & OA_TARGET)
3902 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3903 return CHECKOP(type, pvop);
3911 Perl_package(pTHX_ OP *o)
3914 SV *const sv = cSVOPo->op_sv;
3919 PERL_ARGS_ASSERT_PACKAGE;
3921 save_hptr(&PL_curstash);
3922 save_item(PL_curstname);
3924 PL_curstash = gv_stashsv(sv, GV_ADD);
3926 sv_setsv(PL_curstname, sv);
3928 PL_hints |= HINT_BLOCK_SCOPE;
3929 PL_parser->copline = NOLINE;
3930 PL_parser->expect = XSTATE;
3935 if (!PL_madskills) {
3940 pegop = newOP(OP_NULL,0);
3941 op_getmad(o,pegop,'P');
3947 Perl_package_version( pTHX_ OP *v )
3950 U32 savehints = PL_hints;
3951 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3952 PL_hints &= ~HINT_STRICT_VARS;
3953 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3954 PL_hints = savehints;
3963 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3970 OP *pegop = newOP(OP_NULL,0);
3973 PERL_ARGS_ASSERT_UTILIZE;
3975 if (idop->op_type != OP_CONST)
3976 Perl_croak(aTHX_ "Module name must be constant");
3979 op_getmad(idop,pegop,'U');
3984 SV * const vesv = ((SVOP*)version)->op_sv;
3987 op_getmad(version,pegop,'V');
3988 if (!arg && !SvNIOKp(vesv)) {
3995 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3996 Perl_croak(aTHX_ "Version number must be a constant number");
3998 /* Make copy of idop so we don't free it twice */
3999 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4001 /* Fake up a method call to VERSION */
4002 meth = newSVpvs_share("VERSION");
4003 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4004 append_elem(OP_LIST,
4005 prepend_elem(OP_LIST, pack, list(version)),
4006 newSVOP(OP_METHOD_NAMED, 0, meth)));
4010 /* Fake up an import/unimport */
4011 if (arg && arg->op_type == OP_STUB) {
4013 op_getmad(arg,pegop,'S');
4014 imop = arg; /* no import on explicit () */
4016 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4017 imop = NULL; /* use 5.0; */
4019 idop->op_private |= OPpCONST_NOVER;
4025 op_getmad(arg,pegop,'A');
4027 /* Make copy of idop so we don't free it twice */
4028 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4030 /* Fake up a method call to import/unimport */
4032 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4033 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4034 append_elem(OP_LIST,
4035 prepend_elem(OP_LIST, pack, list(arg)),
4036 newSVOP(OP_METHOD_NAMED, 0, meth)));
4039 /* Fake up the BEGIN {}, which does its thing immediately. */
4041 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4044 append_elem(OP_LINESEQ,
4045 append_elem(OP_LINESEQ,
4046 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4047 newSTATEOP(0, NULL, veop)),
4048 newSTATEOP(0, NULL, imop) ));
4050 /* The "did you use incorrect case?" warning used to be here.
4051 * The problem is that on case-insensitive filesystems one
4052 * might get false positives for "use" (and "require"):
4053 * "use Strict" or "require CARP" will work. This causes
4054 * portability problems for the script: in case-strict
4055 * filesystems the script will stop working.
4057 * The "incorrect case" warning checked whether "use Foo"
4058 * imported "Foo" to your namespace, but that is wrong, too:
4059 * there is no requirement nor promise in the language that
4060 * a Foo.pm should or would contain anything in package "Foo".
4062 * There is very little Configure-wise that can be done, either:
4063 * the case-sensitivity of the build filesystem of Perl does not
4064 * help in guessing the case-sensitivity of the runtime environment.
4067 PL_hints |= HINT_BLOCK_SCOPE;
4068 PL_parser->copline = NOLINE;
4069 PL_parser->expect = XSTATE;
4070 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4073 if (!PL_madskills) {
4074 /* FIXME - don't allocate pegop if !PL_madskills */
4083 =head1 Embedding Functions
4085 =for apidoc load_module
4087 Loads the module whose name is pointed to by the string part of name.
4088 Note that the actual module name, not its filename, should be given.
4089 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4090 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4091 (or 0 for no flags). ver, if specified, provides version semantics
4092 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4093 arguments can be used to specify arguments to the module's import()
4094 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4095 terminated with a final NULL pointer. Note that this list can only
4096 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4097 Otherwise at least a single NULL pointer to designate the default
4098 import list is required.
4103 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4107 PERL_ARGS_ASSERT_LOAD_MODULE;
4109 va_start(args, ver);
4110 vload_module(flags, name, ver, &args);
4114 #ifdef PERL_IMPLICIT_CONTEXT
4116 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4120 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4121 va_start(args, ver);
4122 vload_module(flags, name, ver, &args);
4128 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4132 OP * const modname = newSVOP(OP_CONST, 0, name);
4134 PERL_ARGS_ASSERT_VLOAD_MODULE;
4136 modname->op_private |= OPpCONST_BARE;
4138 veop = newSVOP(OP_CONST, 0, ver);
4142 if (flags & PERL_LOADMOD_NOIMPORT) {
4143 imop = sawparens(newNULLLIST());
4145 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4146 imop = va_arg(*args, OP*);
4151 sv = va_arg(*args, SV*);
4153 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4154 sv = va_arg(*args, SV*);
4158 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4159 * that it has a PL_parser to play with while doing that, and also
4160 * that it doesn't mess with any existing parser, by creating a tmp
4161 * new parser with lex_start(). This won't actually be used for much,
4162 * since pp_require() will create another parser for the real work. */
4165 SAVEVPTR(PL_curcop);
4166 lex_start(NULL, NULL, FALSE);
4167 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4168 veop, modname, imop);
4173 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4179 PERL_ARGS_ASSERT_DOFILE;
4181 if (!force_builtin) {
4182 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4183 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4184 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4185 gv = gvp ? *gvp : NULL;
4189 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4190 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4191 append_elem(OP_LIST, term,
4192 scalar(newUNOP(OP_RV2CV, 0,
4193 newGVOP(OP_GV, 0, gv))))));
4196 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4202 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4204 return newBINOP(OP_LSLICE, flags,
4205 list(force_list(subscript)),
4206 list(force_list(listval)) );
4210 S_is_list_assignment(pTHX_ register const OP *o)
4218 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4219 o = cUNOPo->op_first;
4221 flags = o->op_flags;
4223 if (type == OP_COND_EXPR) {
4224 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4225 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4230 yyerror("Assignment to both a list and a scalar");
4234 if (type == OP_LIST &&
4235 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4236 o->op_private & OPpLVAL_INTRO)
4239 if (type == OP_LIST || flags & OPf_PARENS ||
4240 type == OP_RV2AV || type == OP_RV2HV ||
4241 type == OP_ASLICE || type == OP_HSLICE)
4244 if (type == OP_PADAV || type == OP_PADHV)
4247 if (type == OP_RV2SV)
4254 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4260 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4261 return newLOGOP(optype, 0,
4262 mod(scalar(left), optype),
4263 newUNOP(OP_SASSIGN, 0, scalar(right)));
4266 return newBINOP(optype, OPf_STACKED,
4267 mod(scalar(left), optype), scalar(right));
4271 if (is_list_assignment(left)) {
4272 static const char no_list_state[] = "Initialization of state variables"
4273 " in list context currently forbidden";
4275 bool maybe_common_vars = TRUE;
4278 /* Grandfathering $[ assignment here. Bletch.*/
4279 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4280 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4281 left = mod(left, OP_AASSIGN);
4284 else if (left->op_type == OP_CONST) {
4286 /* Result of assignment is always 1 (or we'd be dead already) */
4287 return newSVOP(OP_CONST, 0, newSViv(1));
4289 curop = list(force_list(left));
4290 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4291 o->op_private = (U8)(0 | (flags >> 8));
4293 if ((left->op_type == OP_LIST
4294 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4296 OP* lop = ((LISTOP*)left)->op_first;
4297 maybe_common_vars = FALSE;
4299 if (lop->op_type == OP_PADSV ||
4300 lop->op_type == OP_PADAV ||
4301 lop->op_type == OP_PADHV ||
4302 lop->op_type == OP_PADANY) {
4303 if (!(lop->op_private & OPpLVAL_INTRO))
4304 maybe_common_vars = TRUE;
4306 if (lop->op_private & OPpPAD_STATE) {
4307 if (left->op_private & OPpLVAL_INTRO) {
4308 /* Each variable in state($a, $b, $c) = ... */
4311 /* Each state variable in
4312 (state $a, my $b, our $c, $d, undef) = ... */
4314 yyerror(no_list_state);
4316 /* Each my variable in
4317 (state $a, my $b, our $c, $d, undef) = ... */
4319 } else if (lop->op_type == OP_UNDEF ||
4320 lop->op_type == OP_PUSHMARK) {
4321 /* undef may be interesting in
4322 (state $a, undef, state $c) */
4324 /* Other ops in the list. */
4325 maybe_common_vars = TRUE;
4327 lop = lop->op_sibling;
4330 else if ((left->op_private & OPpLVAL_INTRO)
4331 && ( left->op_type == OP_PADSV
4332 || left->op_type == OP_PADAV
4333 || left->op_type == OP_PADHV
4334 || left->op_type == OP_PADANY))
4336 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4337 if (left->op_private & OPpPAD_STATE) {
4338 /* All single variable list context state assignments, hence
4348 yyerror(no_list_state);
4352 /* PL_generation sorcery:
4353 * an assignment like ($a,$b) = ($c,$d) is easier than
4354 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4355 * To detect whether there are common vars, the global var
4356 * PL_generation is incremented for each assign op we compile.
4357 * Then, while compiling the assign op, we run through all the
4358 * variables on both sides of the assignment, setting a spare slot
4359 * in each of them to PL_generation. If any of them already have
4360 * that value, we know we've got commonality. We could use a
4361 * single bit marker, but then we'd have to make 2 passes, first
4362 * to clear the flag, then to test and set it. To find somewhere
4363 * to store these values, evil chicanery is done with SvUVX().
4366 if (maybe_common_vars) {
4369 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4370 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4371 if (curop->op_type == OP_GV) {
4372 GV *gv = cGVOPx_gv(curop);
4374 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4376 GvASSIGN_GENERATION_set(gv, PL_generation);
4378 else if (curop->op_type == OP_PADSV ||
4379 curop->op_type == OP_PADAV ||
4380 curop->op_type == OP_PADHV ||
4381 curop->op_type == OP_PADANY)
4383 if (PAD_COMPNAME_GEN(curop->op_targ)
4384 == (STRLEN)PL_generation)
4386 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4389 else if (curop->op_type == OP_RV2CV)
4391 else if (curop->op_type == OP_RV2SV ||
4392 curop->op_type == OP_RV2AV ||
4393 curop->op_type == OP_RV2HV ||
4394 curop->op_type == OP_RV2GV) {
4395 if (lastop->op_type != OP_GV) /* funny deref? */
4398 else if (curop->op_type == OP_PUSHRE) {
4400 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4401 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4403 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4405 GvASSIGN_GENERATION_set(gv, PL_generation);
4409 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4412 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4414 GvASSIGN_GENERATION_set(gv, PL_generation);
4424 o->op_private |= OPpASSIGN_COMMON;
4427 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4428 OP* tmpop = ((LISTOP*)right)->op_first;
4429 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4430 PMOP * const pm = (PMOP*)tmpop;
4431 if (left->op_type == OP_RV2AV &&
4432 !(left->op_private & OPpLVAL_INTRO) &&
4433 !(o->op_private & OPpASSIGN_COMMON) )
4435 tmpop = ((UNOP*)left)->op_first;
4436 if (tmpop->op_type == OP_GV
4438 && !pm->op_pmreplrootu.op_pmtargetoff
4440 && !pm->op_pmreplrootu.op_pmtargetgv
4444 pm->op_pmreplrootu.op_pmtargetoff
4445 = cPADOPx(tmpop)->op_padix;
4446 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4448 pm->op_pmreplrootu.op_pmtargetgv
4449 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4450 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4452 pm->op_pmflags |= PMf_ONCE;
4453 tmpop = cUNOPo->op_first; /* to list (nulled) */
4454 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4455 tmpop->op_sibling = NULL; /* don't free split */
4456 right->op_next = tmpop->op_next; /* fix starting loc */
4457 op_free(o); /* blow off assign */
4458 right->op_flags &= ~OPf_WANT;
4459 /* "I don't know and I don't care." */
4464 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4465 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4467 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4468 if (SvIOK(sv) && SvIVX(sv) == 0)
4469 sv_setiv(sv, PL_modcount+1);
4477 right = newOP(OP_UNDEF, 0);
4478 if (right->op_type == OP_READLINE) {
4479 right->op_flags |= OPf_STACKED;
4480 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4483 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4484 o = newBINOP(OP_SASSIGN, flags,
4485 scalar(right), mod(scalar(left), OP_SASSIGN) );
4489 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4490 deprecate("assignment to $[");
4492 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4493 o->op_private |= OPpCONST_ARYBASE;
4501 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4504 const U32 seq = intro_my();
4507 NewOp(1101, cop, 1, COP);
4508 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4509 cop->op_type = OP_DBSTATE;
4510 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4513 cop->op_type = OP_NEXTSTATE;
4514 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4516 cop->op_flags = (U8)flags;
4517 CopHINTS_set(cop, PL_hints);
4519 cop->op_private |= NATIVE_HINTS;
4521 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4522 cop->op_next = (OP*)cop;
4525 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4526 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4528 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4529 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4530 if (cop->cop_hints_hash) {
4532 cop->cop_hints_hash->refcounted_he_refcnt++;
4533 HINTS_REFCNT_UNLOCK;
4537 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4539 PL_hints |= HINT_BLOCK_SCOPE;
4540 /* It seems that we need to defer freeing this pointer, as other parts
4541 of the grammar end up wanting to copy it after this op has been
4546 if (PL_parser && PL_parser->copline == NOLINE)
4547 CopLINE_set(cop, CopLINE(PL_curcop));
4549 CopLINE_set(cop, PL_parser->copline);
4551 PL_parser->copline = NOLINE;
4554 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4556 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4558 CopSTASH_set(cop, PL_curstash);
4560 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4561 /* this line can have a breakpoint - store the cop in IV */
4562 AV *av = CopFILEAVx(PL_curcop);
4564 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4565 if (svp && *svp != &PL_sv_undef ) {
4566 (void)SvIOK_on(*svp);
4567 SvIV_set(*svp, PTR2IV(cop));
4572 if (flags & OPf_SPECIAL)
4574 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4579 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4583 PERL_ARGS_ASSERT_NEWLOGOP;
4585 return new_logop(type, flags, &first, &other);
4589 S_search_const(pTHX_ OP *o)
4591 PERL_ARGS_ASSERT_SEARCH_CONST;
4593 switch (o->op_type) {
4597 if (o->op_flags & OPf_KIDS)
4598 return search_const(cUNOPo->op_first);
4605 if (!(o->op_flags & OPf_KIDS))
4607 kid = cLISTOPo->op_first;
4609 switch (kid->op_type) {
4613 kid = kid->op_sibling;
4616 if (kid != cLISTOPo->op_last)
4622 kid = cLISTOPo->op_last;
4624 return search_const(kid);
4632 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4640 int prepend_not = 0;
4642 PERL_ARGS_ASSERT_NEW_LOGOP;
4647 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4648 return newBINOP(type, flags, scalar(first), scalar(other));
4650 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4652 scalarboolean(first);
4653 /* optimize AND and OR ops that have NOTs as children */
4654 if (first->op_type == OP_NOT
4655 && (first->op_flags & OPf_KIDS)
4656 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4657 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4659 if (type == OP_AND || type == OP_OR) {
4665 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4667 prepend_not = 1; /* prepend a NOT op later */
4671 /* search for a constant op that could let us fold the test */
4672 if ((cstop = search_const(first))) {
4673 if (cstop->op_private & OPpCONST_STRICT)
4674 no_bareword_allowed(cstop);
4675 else if ((cstop->op_private & OPpCONST_BARE))
4676 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4677 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4678 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4679 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4681 if (other->op_type == OP_CONST)
4682 other->op_private |= OPpCONST_SHORTCIRCUIT;
4684 OP *newop = newUNOP(OP_NULL, 0, other);
4685 op_getmad(first, newop, '1');
4686 newop->op_targ = type; /* set "was" field */
4690 if (other->op_type == OP_LEAVE)
4691 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4695 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4696 const OP *o2 = other;
4697 if ( ! (o2->op_type == OP_LIST
4698 && (( o2 = cUNOPx(o2)->op_first))
4699 && o2->op_type == OP_PUSHMARK
4700 && (( o2 = o2->op_sibling)) )
4703 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4704 || o2->op_type == OP_PADHV)
4705 && o2->op_private & OPpLVAL_INTRO
4706 && !(o2->op_private & OPpPAD_STATE))
4708 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4709 "Deprecated use of my() in false conditional");
4713 if (first->op_type == OP_CONST)
4714 first->op_private |= OPpCONST_SHORTCIRCUIT;
4716 first = newUNOP(OP_NULL, 0, first);
4717 op_getmad(other, first, '2');
4718 first->op_targ = type; /* set "was" field */
4725 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4726 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4728 const OP * const k1 = ((UNOP*)first)->op_first;
4729 const OP * const k2 = k1->op_sibling;
4731 switch (first->op_type)
4734 if (k2 && k2->op_type == OP_READLINE
4735 && (k2->op_flags & OPf_STACKED)
4736 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4738 warnop = k2->op_type;
4743 if (k1->op_type == OP_READDIR
4744 || k1->op_type == OP_GLOB
4745 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4746 || k1->op_type == OP_EACH)
4748 warnop = ((k1->op_type == OP_NULL)
4749 ? (OPCODE)k1->op_targ : k1->op_type);
4754 const line_t oldline = CopLINE(PL_curcop);
4755 CopLINE_set(PL_curcop, PL_parser->copline);
4756 Perl_warner(aTHX_ packWARN(WARN_MISC),
4757 "Value of %s%s can be \"0\"; test with defined()",
4759 ((warnop == OP_READLINE || warnop == OP_GLOB)
4760 ? " construct" : "() operator"));
4761 CopLINE_set(PL_curcop, oldline);
4768 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4769 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4771 NewOp(1101, logop, 1, LOGOP);
4773 logop->op_type = (OPCODE)type;
4774 logop->op_ppaddr = PL_ppaddr[type];
4775 logop->op_first = first;
4776 logop->op_flags = (U8)(flags | OPf_KIDS);
4777 logop->op_other = LINKLIST(other);
4778 logop->op_private = (U8)(1 | (flags >> 8));
4780 /* establish postfix order */
4781 logop->op_next = LINKLIST(first);
4782 first->op_next = (OP*)logop;
4783 first->op_sibling = other;
4785 CHECKOP(type,logop);
4787 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4794 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4802 PERL_ARGS_ASSERT_NEWCONDOP;
4805 return newLOGOP(OP_AND, 0, first, trueop);
4807 return newLOGOP(OP_OR, 0, first, falseop);
4809 scalarboolean(first);
4810 if ((cstop = search_const(first))) {
4811 /* Left or right arm of the conditional? */
4812 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4813 OP *live = left ? trueop : falseop;
4814 OP *const dead = left ? falseop : trueop;
4815 if (cstop->op_private & OPpCONST_BARE &&
4816 cstop->op_private & OPpCONST_STRICT) {
4817 no_bareword_allowed(cstop);
4820 /* This is all dead code when PERL_MAD is not defined. */
4821 live = newUNOP(OP_NULL, 0, live);
4822 op_getmad(first, live, 'C');
4823 op_getmad(dead, live, left ? 'e' : 't');
4828 if (live->op_type == OP_LEAVE)
4829 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4832 NewOp(1101, logop, 1, LOGOP);
4833 logop->op_type = OP_COND_EXPR;
4834 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4835 logop->op_first = first;
4836 logop->op_flags = (U8)(flags | OPf_KIDS);
4837 logop->op_private = (U8)(1 | (flags >> 8));
4838 logop->op_other = LINKLIST(trueop);
4839 logop->op_next = LINKLIST(falseop);
4841 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4844 /* establish postfix order */
4845 start = LINKLIST(first);
4846 first->op_next = (OP*)logop;
4848 first->op_sibling = trueop;
4849 trueop->op_sibling = falseop;
4850 o = newUNOP(OP_NULL, 0, (OP*)logop);
4852 trueop->op_next = falseop->op_next = o;
4859 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4868 PERL_ARGS_ASSERT_NEWRANGE;
4870 NewOp(1101, range, 1, LOGOP);
4872 range->op_type = OP_RANGE;
4873 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4874 range->op_first = left;
4875 range->op_flags = OPf_KIDS;
4876 leftstart = LINKLIST(left);
4877 range->op_other = LINKLIST(right);
4878 range->op_private = (U8)(1 | (flags >> 8));
4880 left->op_sibling = right;
4882 range->op_next = (OP*)range;
4883 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4884 flop = newUNOP(OP_FLOP, 0, flip);
4885 o = newUNOP(OP_NULL, 0, flop);
4887 range->op_next = leftstart;
4889 left->op_next = flip;
4890 right->op_next = flop;
4892 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4893 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4894 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4895 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4897 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4898 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4901 if (!flip->op_private || !flop->op_private)
4902 linklist(o); /* blow off optimizer unless constant */
4908 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4913 const bool once = block && block->op_flags & OPf_SPECIAL &&
4914 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4916 PERL_UNUSED_ARG(debuggable);
4919 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4920 return block; /* do {} while 0 does once */
4921 if (expr->op_type == OP_READLINE
4922 || expr->op_type == OP_READDIR
4923 || expr->op_type == OP_GLOB
4924 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4925 expr = newUNOP(OP_DEFINED, 0,
4926 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4927 } else if (expr->op_flags & OPf_KIDS) {
4928 const OP * const k1 = ((UNOP*)expr)->op_first;
4929 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4930 switch (expr->op_type) {
4932 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4933 && (k2->op_flags & OPf_STACKED)
4934 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4935 expr = newUNOP(OP_DEFINED, 0, expr);
4939 if (k1 && (k1->op_type == OP_READDIR
4940 || k1->op_type == OP_GLOB
4941 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4942 || k1->op_type == OP_EACH))
4943 expr = newUNOP(OP_DEFINED, 0, expr);
4949 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4950 * op, in listop. This is wrong. [perl #27024] */
4952 block = newOP(OP_NULL, 0);
4953 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4954 o = new_logop(OP_AND, 0, &expr, &listop);
4957 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4959 if (once && o != listop)
4960 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4963 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4965 o->op_flags |= flags;
4967 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4972 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4973 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4982 PERL_UNUSED_ARG(debuggable);
4985 if (expr->op_type == OP_READLINE
4986 || expr->op_type == OP_READDIR
4987 || expr->op_type == OP_GLOB
4988 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4989 expr = newUNOP(OP_DEFINED, 0,
4990 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4991 } else if (expr->op_flags & OPf_KIDS) {
4992 const OP * const k1 = ((UNOP*)expr)->op_first;
4993 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4994 switch (expr->op_type) {
4996 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4997 && (k2->op_flags & OPf_STACKED)
4998 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4999 expr = newUNOP(OP_DEFINED, 0, expr);
5003 if (k1 && (k1->op_type == OP_READDIR
5004 || k1->op_type == OP_GLOB
5005 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5006 || k1->op_type == OP_EACH))
5007 expr = newUNOP(OP_DEFINED, 0, expr);
5014 block = newOP(OP_NULL, 0);
5015 else if (cont || has_my) {
5016 block = scope(block);
5020 next = LINKLIST(cont);
5023 OP * const unstack = newOP(OP_UNSTACK, 0);
5026 cont = append_elem(OP_LINESEQ, cont, unstack);
5030 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
5032 redo = LINKLIST(listop);
5035 PL_parser->copline = (line_t)whileline;
5037 o = new_logop(OP_AND, 0, &expr, &listop);
5038 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5039 op_free(expr); /* oops, it's a while (0) */
5041 return NULL; /* listop already freed by new_logop */
5044 ((LISTOP*)listop)->op_last->op_next =
5045 (o == listop ? redo : LINKLIST(o));
5051 NewOp(1101,loop,1,LOOP);
5052 loop->op_type = OP_ENTERLOOP;
5053 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5054 loop->op_private = 0;
5055 loop->op_next = (OP*)loop;
5058 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5060 loop->op_redoop = redo;
5061 loop->op_lastop = o;
5062 o->op_private |= loopflags;
5065 loop->op_nextop = next;
5067 loop->op_nextop = o;
5069 o->op_flags |= flags;
5070 o->op_private |= (flags >> 8);
5075 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
5080 PADOFFSET padoff = 0;
5085 PERL_ARGS_ASSERT_NEWFOROP;
5088 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5089 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5090 sv->op_type = OP_RV2GV;
5091 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5093 /* The op_type check is needed to prevent a possible segfault
5094 * if the loop variable is undeclared and 'strict vars' is in
5095 * effect. This is illegal but is nonetheless parsed, so we
5096 * may reach this point with an OP_CONST where we're expecting
5099 if (cUNOPx(sv)->op_first->op_type == OP_GV
5100 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5101 iterpflags |= OPpITER_DEF;
5103 else if (sv->op_type == OP_PADSV) { /* private variable */
5104 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5105 padoff = sv->op_targ;
5115 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5117 SV *const namesv = PAD_COMPNAME_SV(padoff);
5119 const char *const name = SvPV_const(namesv, len);
5121 if (len == 2 && name[0] == '$' && name[1] == '_')
5122 iterpflags |= OPpITER_DEF;
5126 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5127 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5128 sv = newGVOP(OP_GV, 0, PL_defgv);
5133 iterpflags |= OPpITER_DEF;
5135 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5136 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5137 iterflags |= OPf_STACKED;
5139 else if (expr->op_type == OP_NULL &&
5140 (expr->op_flags & OPf_KIDS) &&
5141 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5143 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5144 * set the STACKED flag to indicate that these values are to be
5145 * treated as min/max values by 'pp_iterinit'.
5147 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5148 LOGOP* const range = (LOGOP*) flip->op_first;
5149 OP* const left = range->op_first;
5150 OP* const right = left->op_sibling;
5153 range->op_flags &= ~OPf_KIDS;
5154 range->op_first = NULL;
5156 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5157 listop->op_first->op_next = range->op_next;
5158 left->op_next = range->op_other;
5159 right->op_next = (OP*)listop;
5160 listop->op_next = listop->op_first;
5163 op_getmad(expr,(OP*)listop,'O');
5167 expr = (OP*)(listop);
5169 iterflags |= OPf_STACKED;
5172 expr = mod(force_list(expr), OP_GREPSTART);
5175 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5176 append_elem(OP_LIST, expr, scalar(sv))));
5177 assert(!loop->op_next);
5178 /* for my $x () sets OPpLVAL_INTRO;
5179 * for our $x () sets OPpOUR_INTRO */
5180 loop->op_private = (U8)iterpflags;
5181 #ifdef PL_OP_SLAB_ALLOC
5184 NewOp(1234,tmp,1,LOOP);
5185 Copy(loop,tmp,1,LISTOP);
5186 S_op_destroy(aTHX_ (OP*)loop);
5190 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5192 loop->op_targ = padoff;
5193 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5195 op_getmad(madsv, (OP*)loop, 'v');
5196 PL_parser->copline = forline;
5197 return newSTATEOP(0, label, wop);
5201 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5206 PERL_ARGS_ASSERT_NEWLOOPEX;
5208 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5210 if (type != OP_GOTO || label->op_type == OP_CONST) {
5211 /* "last()" means "last" */
5212 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5213 o = newOP(type, OPf_SPECIAL);
5215 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5216 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5220 op_getmad(label,o,'L');
5226 /* Check whether it's going to be a goto &function */
5227 if (label->op_type == OP_ENTERSUB
5228 && !(label->op_flags & OPf_STACKED))
5229 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5230 o = newUNOP(type, OPf_STACKED, label);
5232 PL_hints |= HINT_BLOCK_SCOPE;
5236 /* if the condition is a literal array or hash
5237 (or @{ ... } etc), make a reference to it.
5240 S_ref_array_or_hash(pTHX_ OP *cond)
5243 && (cond->op_type == OP_RV2AV
5244 || cond->op_type == OP_PADAV
5245 || cond->op_type == OP_RV2HV
5246 || cond->op_type == OP_PADHV))
5248 return newUNOP(OP_REFGEN,
5249 0, mod(cond, OP_REFGEN));
5255 /* These construct the optree fragments representing given()
5258 entergiven and enterwhen are LOGOPs; the op_other pointer
5259 points up to the associated leave op. We need this so we
5260 can put it in the context and make break/continue work.
5261 (Also, of course, pp_enterwhen will jump straight to
5262 op_other if the match fails.)
5266 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5267 I32 enter_opcode, I32 leave_opcode,
5268 PADOFFSET entertarg)
5274 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5276 NewOp(1101, enterop, 1, LOGOP);
5277 enterop->op_type = (Optype)enter_opcode;
5278 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5279 enterop->op_flags = (U8) OPf_KIDS;
5280 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5281 enterop->op_private = 0;
5283 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5286 enterop->op_first = scalar(cond);
5287 cond->op_sibling = block;
5289 o->op_next = LINKLIST(cond);
5290 cond->op_next = (OP *) enterop;
5293 /* This is a default {} block */
5294 enterop->op_first = block;
5295 enterop->op_flags |= OPf_SPECIAL;
5297 o->op_next = (OP *) enterop;
5300 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5301 entergiven and enterwhen both
5304 enterop->op_next = LINKLIST(block);
5305 block->op_next = enterop->op_other = o;
5310 /* Does this look like a boolean operation? For these purposes
5311 a boolean operation is:
5312 - a subroutine call [*]
5313 - a logical connective
5314 - a comparison operator
5315 - a filetest operator, with the exception of -s -M -A -C
5316 - defined(), exists() or eof()
5317 - /$re/ or $foo =~ /$re/
5319 [*] possibly surprising
5322 S_looks_like_bool(pTHX_ const OP *o)
5326 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5328 switch(o->op_type) {
5331 return looks_like_bool(cLOGOPo->op_first);
5335 looks_like_bool(cLOGOPo->op_first)
5336 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5341 o->op_flags & OPf_KIDS
5342 && looks_like_bool(cUNOPo->op_first));
5346 case OP_NOT: case OP_XOR:
5348 case OP_EQ: case OP_NE: case OP_LT:
5349 case OP_GT: case OP_LE: case OP_GE:
5351 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5352 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5354 case OP_SEQ: case OP_SNE: case OP_SLT:
5355 case OP_SGT: case OP_SLE: case OP_SGE:
5359 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5360 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5361 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5362 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5363 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5364 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5365 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5366 case OP_FTTEXT: case OP_FTBINARY:
5368 case OP_DEFINED: case OP_EXISTS:
5369 case OP_MATCH: case OP_EOF:
5376 /* Detect comparisons that have been optimized away */
5377 if (cSVOPo->op_sv == &PL_sv_yes
5378 || cSVOPo->op_sv == &PL_sv_no)
5391 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5394 PERL_ARGS_ASSERT_NEWGIVENOP;
5395 return newGIVWHENOP(
5396 ref_array_or_hash(cond),
5398 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5402 /* If cond is null, this is a default {} block */
5404 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5406 const bool cond_llb = (!cond || looks_like_bool(cond));
5409 PERL_ARGS_ASSERT_NEWWHENOP;
5414 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5416 scalar(ref_array_or_hash(cond)));
5419 return newGIVWHENOP(
5421 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5422 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5426 =for apidoc cv_undef
5428 Clear out all the active components of a CV. This can happen either
5429 by an explicit C<undef &foo>, or by the reference count going to zero.
5430 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5431 children can still follow the full lexical scope chain.
5437 Perl_cv_undef(pTHX_ CV *cv)
5441 PERL_ARGS_ASSERT_CV_UNDEF;
5443 DEBUG_X(PerlIO_printf(Perl_debug_log,
5444 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5445 PTR2UV(cv), PTR2UV(PL_comppad))
5449 if (CvFILE(cv) && !CvISXSUB(cv)) {
5450 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5451 Safefree(CvFILE(cv));
5456 if (!CvISXSUB(cv) && CvROOT(cv)) {
5457 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5458 Perl_croak(aTHX_ "Can't undef active subroutine");
5461 PAD_SAVE_SETNULLPAD();
5463 op_free(CvROOT(cv));
5468 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5473 /* remove CvOUTSIDE unless this is an undef rather than a free */
5474 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5475 if (!CvWEAKOUTSIDE(cv))
5476 SvREFCNT_dec(CvOUTSIDE(cv));
5477 CvOUTSIDE(cv) = NULL;
5480 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5483 if (CvISXSUB(cv) && CvXSUB(cv)) {
5486 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
5487 * ref status of CvOUTSIDE and CvGV */
5488 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
5492 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5495 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5497 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5498 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5499 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5500 || (p && (len != SvCUR(cv) /* Not the same length. */
5501 || memNE(p, SvPVX_const(cv), len))))
5502 && ckWARN_d(WARN_PROTOTYPE)) {
5503 SV* const msg = sv_newmortal();
5507 gv_efullname3(name = sv_newmortal(), gv, NULL);
5508 sv_setpvs(msg, "Prototype mismatch:");
5510 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5512 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5514 sv_catpvs(msg, ": none");
5515 sv_catpvs(msg, " vs ");
5517 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5519 sv_catpvs(msg, "none");
5520 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5524 static void const_sv_xsub(pTHX_ CV* cv);
5528 =head1 Optree Manipulation Functions
5530 =for apidoc cv_const_sv
5532 If C<cv> is a constant sub eligible for inlining. returns the constant
5533 value returned by the sub. Otherwise, returns NULL.
5535 Constant subs can be created with C<newCONSTSUB> or as described in
5536 L<perlsub/"Constant Functions">.
5541 Perl_cv_const_sv(pTHX_ const CV *const cv)
5543 PERL_UNUSED_CONTEXT;
5546 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5548 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5551 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5552 * Can be called in 3 ways:
5555 * look for a single OP_CONST with attached value: return the value
5557 * cv && CvCLONE(cv) && !CvCONST(cv)
5559 * examine the clone prototype, and if contains only a single
5560 * OP_CONST referencing a pad const, or a single PADSV referencing
5561 * an outer lexical, return a non-zero value to indicate the CV is
5562 * a candidate for "constizing" at clone time
5566 * We have just cloned an anon prototype that was marked as a const
5567 * candidiate. Try to grab the current value, and in the case of
5568 * PADSV, ignore it if it has multiple references. Return the value.
5572 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5583 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5584 o = cLISTOPo->op_first->op_sibling;
5586 for (; o; o = o->op_next) {
5587 const OPCODE type = o->op_type;
5589 if (sv && o->op_next == o)
5591 if (o->op_next != o) {
5592 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5594 if (type == OP_DBSTATE)
5597 if (type == OP_LEAVESUB || type == OP_RETURN)
5601 if (type == OP_CONST && cSVOPo->op_sv)
5603 else if (cv && type == OP_CONST) {
5604 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5608 else if (cv && type == OP_PADSV) {
5609 if (CvCONST(cv)) { /* newly cloned anon */
5610 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5611 /* the candidate should have 1 ref from this pad and 1 ref
5612 * from the parent */
5613 if (!sv || SvREFCNT(sv) != 2)
5620 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5621 sv = &PL_sv_undef; /* an arbitrary non-null value */
5636 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5639 /* This would be the return value, but the return cannot be reached. */
5640 OP* pegop = newOP(OP_NULL, 0);
5643 PERL_UNUSED_ARG(floor);
5653 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5655 NORETURN_FUNCTION_END;
5660 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5662 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5666 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5671 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
5672 register CV *cv = NULL;
5674 /* If the subroutine has no body, no attributes, and no builtin attributes
5675 then it's just a sub declaration, and we may be able to get away with
5676 storing with a placeholder scalar in the symbol table, rather than a
5677 full GV and CV. If anything is present then it will take a full CV to
5679 const I32 gv_fetch_flags
5680 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5682 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5683 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5687 assert(proto->op_type == OP_CONST);
5688 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5694 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5696 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5697 SV * const sv = sv_newmortal();
5698 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5699 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5700 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5701 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5703 } else if (PL_curstash) {
5704 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5707 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5711 if (!PL_madskills) {
5720 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5721 maximum a prototype before. */
5722 if (SvTYPE(gv) > SVt_NULL) {
5723 if (!SvPOK((const SV *)gv)
5724 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5726 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5728 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5731 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5733 sv_setiv(MUTABLE_SV(gv), -1);
5735 SvREFCNT_dec(PL_compcv);
5736 cv = PL_compcv = NULL;
5740 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5742 if (!block || !ps || *ps || attrs
5743 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5745 || block->op_type == OP_NULL
5750 const_sv = op_const_sv(block, NULL);
5753 const bool exists = CvROOT(cv) || CvXSUB(cv);
5755 /* if the subroutine doesn't exist and wasn't pre-declared
5756 * with a prototype, assume it will be AUTOLOADed,
5757 * skipping the prototype check
5759 if (exists || SvPOK(cv))
5760 cv_ckproto_len(cv, gv, ps, ps_len);
5761 /* already defined (or promised)? */
5762 if (exists || GvASSUMECV(gv)) {
5765 || block->op_type == OP_NULL
5768 if (CvFLAGS(PL_compcv)) {
5769 /* might have had built-in attrs applied */
5770 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
5771 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
5772 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
5774 /* just a "sub foo;" when &foo is already defined */
5775 SAVEFREESV(PL_compcv);
5780 && block->op_type != OP_NULL
5783 if (ckWARN(WARN_REDEFINE)
5785 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5787 const line_t oldline = CopLINE(PL_curcop);
5788 if (PL_parser && PL_parser->copline != NOLINE)
5789 CopLINE_set(PL_curcop, PL_parser->copline);
5790 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5791 CvCONST(cv) ? "Constant subroutine %s redefined"
5792 : "Subroutine %s redefined", name);
5793 CopLINE_set(PL_curcop, oldline);
5796 if (!PL_minus_c) /* keep old one around for madskills */
5799 /* (PL_madskills unset in used file.) */
5807 SvREFCNT_inc_simple_void_NN(const_sv);
5809 assert(!CvROOT(cv) && !CvCONST(cv));
5810 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5811 CvXSUBANY(cv).any_ptr = const_sv;
5812 CvXSUB(cv) = const_sv_xsub;
5818 cv = newCONSTSUB(NULL, name, const_sv);
5820 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5821 (CvGV(cv) && GvSTASH(CvGV(cv)))
5830 SvREFCNT_dec(PL_compcv);
5834 if (cv) { /* must reuse cv if autoloaded */
5835 /* transfer PL_compcv to cv */
5838 && block->op_type != OP_NULL
5841 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
5843 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
5844 if (!CvWEAKOUTSIDE(cv))
5845 SvREFCNT_dec(CvOUTSIDE(cv));
5846 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5847 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5848 CvOUTSIDE(PL_compcv) = 0;
5849 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5850 CvPADLIST(PL_compcv) = 0;
5851 /* inner references to PL_compcv must be fixed up ... */
5852 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5853 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5854 ++PL_sub_generation;
5856 sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
5859 /* Might have had built-in attributes applied -- propagate them. */
5860 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5862 /* ... before we throw it away */
5863 SvREFCNT_dec(PL_compcv);
5871 if (strEQ(name, "import")) {
5872 PL_formfeed = MUTABLE_SV(cv);
5873 /* diag_listed_as: SKIPME */
5874 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
5878 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5883 CvFILE_set_from_cop(cv, PL_curcop);
5884 CvSTASH(cv) = PL_curstash;
5886 Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
5889 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5890 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5891 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5895 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5897 if (PL_parser && PL_parser->error_count) {
5901 const char *s = strrchr(name, ':');
5903 if (strEQ(s, "BEGIN")) {
5904 const char not_safe[] =
5905 "BEGIN not safe after errors--compilation aborted";
5906 if (PL_in_eval & EVAL_KEEPERR)
5907 Perl_croak(aTHX_ not_safe);
5909 /* force display of errors found but not reported */
5910 sv_catpv(ERRSV, not_safe);
5911 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5920 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5921 the debugger could be able to set a breakpoint in, so signal to
5922 pp_entereval that it should not throw away any saved lines at scope
5925 PL_breakable_sub_gen++;
5927 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5928 mod(scalarseq(block), OP_LEAVESUBLV));
5929 block->op_attached = 1;
5932 /* This makes sub {}; work as expected. */
5933 if (block->op_type == OP_STUB) {
5934 OP* const newblock = newSTATEOP(0, NULL, 0);
5936 op_getmad(block,newblock,'B');
5943 block->op_attached = 1;
5944 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5946 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5947 OpREFCNT_set(CvROOT(cv), 1);
5948 CvSTART(cv) = LINKLIST(CvROOT(cv));
5949 CvROOT(cv)->op_next = 0;
5950 CALL_PEEP(CvSTART(cv));
5952 /* now that optimizer has done its work, adjust pad values */
5954 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5957 assert(!CvCONST(cv));
5958 if (ps && !*ps && op_const_sv(block, cv))
5963 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5964 SV * const tmpstr = sv_newmortal();
5965 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5966 GV_ADDMULTI, SVt_PVHV);
5968 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
5971 (long)CopLINE(PL_curcop));
5972 gv_efullname3(tmpstr, gv, NULL);
5973 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5974 SvCUR(tmpstr), sv, 0);
5975 hv = GvHVn(db_postponed);
5976 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5977 CV * const pcv = GvCV(db_postponed);
5983 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5988 if (name && ! (PL_parser && PL_parser->error_count))
5989 process_special_blocks(name, gv, cv);
5994 PL_parser->copline = NOLINE;
6000 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6003 const char *const colon = strrchr(fullname,':');
6004 const char *const name = colon ? colon + 1 : fullname;
6006 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6009 if (strEQ(name, "BEGIN")) {
6010 const I32 oldscope = PL_scopestack_ix;
6012 SAVECOPFILE(&PL_compiling);
6013 SAVECOPLINE(&PL_compiling);
6015 DEBUG_x( dump_sub(gv) );
6016 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6017 GvCV(gv) = 0; /* cv has been hijacked */
6018 call_list(oldscope, PL_beginav);
6020 PL_curcop = &PL_compiling;
6021 CopHINTS_set(&PL_compiling, PL_hints);
6028 if strEQ(name, "END") {
6029 DEBUG_x( dump_sub(gv) );
6030 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6033 } else if (*name == 'U') {
6034 if (strEQ(name, "UNITCHECK")) {
6035 /* It's never too late to run a unitcheck block */
6036 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6040 } else if (*name == 'C') {
6041 if (strEQ(name, "CHECK")) {
6043 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6044 "Too late to run CHECK block");
6045 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6049 } else if (*name == 'I') {
6050 if (strEQ(name, "INIT")) {
6052 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6053 "Too late to run INIT block");
6054 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6060 DEBUG_x( dump_sub(gv) );
6061 GvCV(gv) = 0; /* cv has been hijacked */
6066 =for apidoc newCONSTSUB
6068 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6069 eligible for inlining at compile-time.
6071 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6072 which won't be called if used as a destructor, but will suppress the overhead
6073 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6080 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6085 const char *const file = CopFILE(PL_curcop);
6087 SV *const temp_sv = CopFILESV(PL_curcop);
6088 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6093 if (IN_PERL_RUNTIME) {
6094 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6095 * an op shared between threads. Use a non-shared COP for our
6097 SAVEVPTR(PL_curcop);
6098 PL_curcop = &PL_compiling;
6100 SAVECOPLINE(PL_curcop);
6101 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6104 PL_hints &= ~HINT_BLOCK_SCOPE;
6107 SAVESPTR(PL_curstash);
6108 SAVECOPSTASH(PL_curcop);
6109 PL_curstash = stash;
6110 CopSTASH_set(PL_curcop,stash);
6113 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6114 and so doesn't get free()d. (It's expected to be from the C pre-
6115 processor __FILE__ directive). But we need a dynamically allocated one,
6116 and we need it to get freed. */
6117 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6118 XS_DYNAMIC_FILENAME);
6119 CvXSUBANY(cv).any_ptr = sv;
6124 CopSTASH_free(PL_curcop);
6132 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6133 const char *const filename, const char *const proto,
6136 CV *cv = newXS(name, subaddr, filename);
6138 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6140 if (flags & XS_DYNAMIC_FILENAME) {
6141 /* We need to "make arrangements" (ie cheat) to ensure that the
6142 filename lasts as long as the PVCV we just created, but also doesn't
6144 STRLEN filename_len = strlen(filename);
6145 STRLEN proto_and_file_len = filename_len;
6146 char *proto_and_file;
6150 proto_len = strlen(proto);
6151 proto_and_file_len += proto_len;
6153 Newx(proto_and_file, proto_and_file_len + 1, char);
6154 Copy(proto, proto_and_file, proto_len, char);
6155 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6158 proto_and_file = savepvn(filename, filename_len);
6161 /* This gets free()d. :-) */
6162 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6163 SV_HAS_TRAILING_NUL);
6165 /* This gives us the correct prototype, rather than one with the
6166 file name appended. */
6167 SvCUR_set(cv, proto_len);
6171 CvFILE(cv) = proto_and_file + proto_len;
6173 sv_setpv(MUTABLE_SV(cv), proto);
6179 =for apidoc U||newXS
6181 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6182 static storage, as it is used directly as CvFILE(), without a copy being made.
6188 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6191 GV * const gv = gv_fetchpv(name ? name :
6192 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6193 GV_ADDMULTI, SVt_PVCV);
6196 PERL_ARGS_ASSERT_NEWXS;
6199 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6201 if ((cv = (name ? GvCV(gv) : NULL))) {
6203 /* just a cached method */
6207 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6208 /* already defined (or promised) */
6209 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6210 if (ckWARN(WARN_REDEFINE)) {
6211 GV * const gvcv = CvGV(cv);
6213 HV * const stash = GvSTASH(gvcv);
6215 const char *redefined_name = HvNAME_get(stash);
6216 if ( strEQ(redefined_name,"autouse") ) {
6217 const line_t oldline = CopLINE(PL_curcop);
6218 if (PL_parser && PL_parser->copline != NOLINE)
6219 CopLINE_set(PL_curcop, PL_parser->copline);
6220 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6221 CvCONST(cv) ? "Constant subroutine %s redefined"
6222 : "Subroutine %s redefined"
6224 CopLINE_set(PL_curcop, oldline);
6234 if (cv) /* must reuse cv if autoloaded */
6237 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6241 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6247 (void)gv_fetchfile(filename);
6248 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6249 an external constant string */
6251 CvXSUB(cv) = subaddr;
6254 process_special_blocks(name, gv, cv);
6264 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6269 OP* pegop = newOP(OP_NULL, 0);
6273 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6274 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6277 if ((cv = GvFORM(gv))) {
6278 if (ckWARN(WARN_REDEFINE)) {
6279 const line_t oldline = CopLINE(PL_curcop);
6280 if (PL_parser && PL_parser->copline != NOLINE)
6281 CopLINE_set(PL_curcop, PL_parser->copline);
6283 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6284 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6286 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6287 "Format STDOUT redefined");
6289 CopLINE_set(PL_curcop, oldline);
6296 CvFILE_set_from_cop(cv, PL_curcop);
6299 pad_tidy(padtidy_FORMAT);
6300 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6301 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6302 OpREFCNT_set(CvROOT(cv), 1);
6303 CvSTART(cv) = LINKLIST(CvROOT(cv));
6304 CvROOT(cv)->op_next = 0;
6305 CALL_PEEP(CvSTART(cv));
6307 op_getmad(o,pegop,'n');
6308 op_getmad_weak(block, pegop, 'b');
6313 PL_parser->copline = NOLINE;
6321 Perl_newANONLIST(pTHX_ OP *o)
6323 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6327 Perl_newANONHASH(pTHX_ OP *o)
6329 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6333 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6335 return newANONATTRSUB(floor, proto, NULL, block);
6339 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6341 return newUNOP(OP_REFGEN, 0,
6342 newSVOP(OP_ANONCODE, 0,
6343 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6347 Perl_oopsAV(pTHX_ OP *o)
6351 PERL_ARGS_ASSERT_OOPSAV;
6353 switch (o->op_type) {
6355 o->op_type = OP_PADAV;
6356 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6357 return ref(o, OP_RV2AV);
6360 o->op_type = OP_RV2AV;
6361 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6366 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6373 Perl_oopsHV(pTHX_ OP *o)
6377 PERL_ARGS_ASSERT_OOPSHV;
6379 switch (o->op_type) {
6382 o->op_type = OP_PADHV;
6383 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6384 return ref(o, OP_RV2HV);
6388 o->op_type = OP_RV2HV;
6389 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6394 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6401 Perl_newAVREF(pTHX_ OP *o)
6405 PERL_ARGS_ASSERT_NEWAVREF;
6407 if (o->op_type == OP_PADANY) {
6408 o->op_type = OP_PADAV;
6409 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6412 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6413 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6414 "Using an array as a reference is deprecated");
6416 return newUNOP(OP_RV2AV, 0, scalar(o));
6420 Perl_newGVREF(pTHX_ I32 type, OP *o)
6422 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6423 return newUNOP(OP_NULL, 0, o);
6424 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6428 Perl_newHVREF(pTHX_ OP *o)
6432 PERL_ARGS_ASSERT_NEWHVREF;
6434 if (o->op_type == OP_PADANY) {
6435 o->op_type = OP_PADHV;
6436 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6439 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6440 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6441 "Using a hash as a reference is deprecated");
6443 return newUNOP(OP_RV2HV, 0, scalar(o));
6447 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6449 return newUNOP(OP_RV2CV, flags, scalar(o));
6453 Perl_newSVREF(pTHX_ OP *o)
6457 PERL_ARGS_ASSERT_NEWSVREF;
6459 if (o->op_type == OP_PADANY) {
6460 o->op_type = OP_PADSV;
6461 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6464 return newUNOP(OP_RV2SV, 0, scalar(o));
6467 /* Check routines. See the comments at the top of this file for details
6468 * on when these are called */
6471 Perl_ck_anoncode(pTHX_ OP *o)
6473 PERL_ARGS_ASSERT_CK_ANONCODE;
6475 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6477 cSVOPo->op_sv = NULL;
6482 Perl_ck_bitop(pTHX_ OP *o)
6486 PERL_ARGS_ASSERT_CK_BITOP;
6488 #define OP_IS_NUMCOMPARE(op) \
6489 ((op) == OP_LT || (op) == OP_I_LT || \
6490 (op) == OP_GT || (op) == OP_I_GT || \
6491 (op) == OP_LE || (op) == OP_I_LE || \
6492 (op) == OP_GE || (op) == OP_I_GE || \
6493 (op) == OP_EQ || (op) == OP_I_EQ || \
6494 (op) == OP_NE || (op) == OP_I_NE || \
6495 (op) == OP_NCMP || (op) == OP_I_NCMP)
6496 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6497 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6498 && (o->op_type == OP_BIT_OR
6499 || o->op_type == OP_BIT_AND
6500 || o->op_type == OP_BIT_XOR))
6502 const OP * const left = cBINOPo->op_first;
6503 const OP * const right = left->op_sibling;
6504 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6505 (left->op_flags & OPf_PARENS) == 0) ||
6506 (OP_IS_NUMCOMPARE(right->op_type) &&
6507 (right->op_flags & OPf_PARENS) == 0))
6508 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6509 "Possible precedence problem on bitwise %c operator",
6510 o->op_type == OP_BIT_OR ? '|'
6511 : o->op_type == OP_BIT_AND ? '&' : '^'
6518 Perl_ck_concat(pTHX_ OP *o)
6520 const OP * const kid = cUNOPo->op_first;
6522 PERL_ARGS_ASSERT_CK_CONCAT;
6523 PERL_UNUSED_CONTEXT;
6525 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6526 !(kUNOP->op_first->op_flags & OPf_MOD))
6527 o->op_flags |= OPf_STACKED;
6532 Perl_ck_spair(pTHX_ OP *o)
6536 PERL_ARGS_ASSERT_CK_SPAIR;
6538 if (o->op_flags & OPf_KIDS) {
6541 const OPCODE type = o->op_type;
6542 o = modkids(ck_fun(o), type);
6543 kid = cUNOPo->op_first;
6544 newop = kUNOP->op_first->op_sibling;
6546 const OPCODE type = newop->op_type;
6547 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6548 type == OP_PADAV || type == OP_PADHV ||
6549 type == OP_RV2AV || type == OP_RV2HV)
6553 op_getmad(kUNOP->op_first,newop,'K');
6555 op_free(kUNOP->op_first);
6557 kUNOP->op_first = newop;
6559 o->op_ppaddr = PL_ppaddr[++o->op_type];
6564 Perl_ck_delete(pTHX_ OP *o)
6566 PERL_ARGS_ASSERT_CK_DELETE;
6570 if (o->op_flags & OPf_KIDS) {
6571 OP * const kid = cUNOPo->op_first;
6572 switch (kid->op_type) {
6574 o->op_flags |= OPf_SPECIAL;
6577 o->op_private |= OPpSLICE;
6580 o->op_flags |= OPf_SPECIAL;
6585 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6588 if (kid->op_private & OPpLVAL_INTRO)
6589 o->op_private |= OPpLVAL_INTRO;
6596 Perl_ck_die(pTHX_ OP *o)
6598 PERL_ARGS_ASSERT_CK_DIE;
6601 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6607 Perl_ck_eof(pTHX_ OP *o)
6611 PERL_ARGS_ASSERT_CK_EOF;
6613 if (o->op_flags & OPf_KIDS) {
6614 if (cLISTOPo->op_first->op_type == OP_STUB) {
6616 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6618 op_getmad(o,newop,'O');
6630 Perl_ck_eval(pTHX_ OP *o)
6634 PERL_ARGS_ASSERT_CK_EVAL;
6636 PL_hints |= HINT_BLOCK_SCOPE;
6637 if (o->op_flags & OPf_KIDS) {
6638 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6641 o->op_flags &= ~OPf_KIDS;
6644 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6650 cUNOPo->op_first = 0;
6655 NewOp(1101, enter, 1, LOGOP);
6656 enter->op_type = OP_ENTERTRY;
6657 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6658 enter->op_private = 0;
6660 /* establish postfix order */
6661 enter->op_next = (OP*)enter;
6663 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6664 o->op_type = OP_LEAVETRY;
6665 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6666 enter->op_other = o;
6667 op_getmad(oldo,o,'O');
6681 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6682 op_getmad(oldo,o,'O');
6684 o->op_targ = (PADOFFSET)PL_hints;
6685 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6686 /* Store a copy of %^H that pp_entereval can pick up. */
6687 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6688 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6689 cUNOPo->op_first->op_sibling = hhop;
6690 o->op_private |= OPpEVAL_HAS_HH;
6696 Perl_ck_exit(pTHX_ OP *o)
6698 PERL_ARGS_ASSERT_CK_EXIT;
6701 HV * const table = GvHV(PL_hintgv);
6703 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6704 if (svp && *svp && SvTRUE(*svp))
6705 o->op_private |= OPpEXIT_VMSISH;
6707 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6713 Perl_ck_exec(pTHX_ OP *o)
6715 PERL_ARGS_ASSERT_CK_EXEC;
6717 if (o->op_flags & OPf_STACKED) {
6720 kid = cUNOPo->op_first->op_sibling;
6721 if (kid->op_type == OP_RV2GV)
6730 Perl_ck_exists(pTHX_ OP *o)
6734 PERL_ARGS_ASSERT_CK_EXISTS;
6737 if (o->op_flags & OPf_KIDS) {
6738 OP * const kid = cUNOPo->op_first;
6739 if (kid->op_type == OP_ENTERSUB) {
6740 (void) ref(kid, o->op_type);
6741 if (kid->op_type != OP_RV2CV
6742 && !(PL_parser && PL_parser->error_count))
6743 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6745 o->op_private |= OPpEXISTS_SUB;
6747 else if (kid->op_type == OP_AELEM)
6748 o->op_flags |= OPf_SPECIAL;
6749 else if (kid->op_type != OP_HELEM)
6750 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6758 Perl_ck_rvconst(pTHX_ register OP *o)
6761 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6763 PERL_ARGS_ASSERT_CK_RVCONST;
6765 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6766 if (o->op_type == OP_RV2CV)
6767 o->op_private &= ~1;
6769 if (kid->op_type == OP_CONST) {
6772 SV * const kidsv = kid->op_sv;
6774 /* Is it a constant from cv_const_sv()? */
6775 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6776 SV * const rsv = SvRV(kidsv);
6777 const svtype type = SvTYPE(rsv);
6778 const char *badtype = NULL;
6780 switch (o->op_type) {
6782 if (type > SVt_PVMG)
6783 badtype = "a SCALAR";
6786 if (type != SVt_PVAV)
6787 badtype = "an ARRAY";
6790 if (type != SVt_PVHV)
6794 if (type != SVt_PVCV)
6799 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6802 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6803 const char *badthing;
6804 switch (o->op_type) {
6806 badthing = "a SCALAR";
6809 badthing = "an ARRAY";
6812 badthing = "a HASH";
6820 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6821 SVfARG(kidsv), badthing);
6824 * This is a little tricky. We only want to add the symbol if we
6825 * didn't add it in the lexer. Otherwise we get duplicate strict
6826 * warnings. But if we didn't add it in the lexer, we must at
6827 * least pretend like we wanted to add it even if it existed before,
6828 * or we get possible typo warnings. OPpCONST_ENTERED says
6829 * whether the lexer already added THIS instance of this symbol.
6831 iscv = (o->op_type == OP_RV2CV) * 2;
6833 gv = gv_fetchsv(kidsv,
6834 iscv | !(kid->op_private & OPpCONST_ENTERED),
6837 : o->op_type == OP_RV2SV
6839 : o->op_type == OP_RV2AV
6841 : o->op_type == OP_RV2HV
6844 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6846 kid->op_type = OP_GV;
6847 SvREFCNT_dec(kid->op_sv);
6849 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6850 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6851 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6853 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6855 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6857 kid->op_private = 0;
6858 kid->op_ppaddr = PL_ppaddr[OP_GV];
6865 Perl_ck_ftst(pTHX_ OP *o)
6868 const I32 type = o->op_type;
6870 PERL_ARGS_ASSERT_CK_FTST;
6872 if (o->op_flags & OPf_REF) {
6875 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6876 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6877 const OPCODE kidtype = kid->op_type;
6879 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6880 OP * const newop = newGVOP(type, OPf_REF,
6881 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6883 op_getmad(o,newop,'O');
6889 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6890 o->op_private |= OPpFT_ACCESS;
6891 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6892 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6893 o->op_private |= OPpFT_STACKED;
6901 if (type == OP_FTTTY)
6902 o = newGVOP(type, OPf_REF, PL_stdingv);
6904 o = newUNOP(type, 0, newDEFSVOP());
6905 op_getmad(oldo,o,'O');
6911 Perl_ck_fun(pTHX_ OP *o)
6914 const int type = o->op_type;
6915 register I32 oa = PL_opargs[type] >> OASHIFT;
6917 PERL_ARGS_ASSERT_CK_FUN;
6919 if (o->op_flags & OPf_STACKED) {
6920 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6923 return no_fh_allowed(o);
6926 if (o->op_flags & OPf_KIDS) {
6927 OP **tokid = &cLISTOPo->op_first;
6928 register OP *kid = cLISTOPo->op_first;
6932 if (kid->op_type == OP_PUSHMARK ||
6933 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6935 tokid = &kid->op_sibling;
6936 kid = kid->op_sibling;
6938 if (!kid && PL_opargs[type] & OA_DEFGV)
6939 *tokid = kid = newDEFSVOP();
6943 sibl = kid->op_sibling;
6945 if (!sibl && kid->op_type == OP_STUB) {
6952 /* list seen where single (scalar) arg expected? */
6953 if (numargs == 1 && !(oa >> 4)
6954 && kid->op_type == OP_LIST && type != OP_SCALAR)
6956 return too_many_arguments(o,PL_op_desc[type]);
6969 if ((type == OP_PUSH || type == OP_UNSHIFT)
6970 && !kid->op_sibling)
6971 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6972 "Useless use of %s with no values",
6975 if (kid->op_type == OP_CONST &&
6976 (kid->op_private & OPpCONST_BARE))
6978 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6979 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6980 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6981 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6982 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6984 op_getmad(kid,newop,'K');
6989 kid->op_sibling = sibl;
6992 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6993 bad_type(numargs, "array", PL_op_desc[type], kid);
6997 if (kid->op_type == OP_CONST &&
6998 (kid->op_private & OPpCONST_BARE))
7000 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7001 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7002 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7003 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7004 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7006 op_getmad(kid,newop,'K');
7011 kid->op_sibling = sibl;
7014 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7015 bad_type(numargs, "hash", PL_op_desc[type], kid);
7020 OP * const newop = newUNOP(OP_NULL, 0, kid);
7021 kid->op_sibling = 0;
7023 newop->op_next = newop;
7025 kid->op_sibling = sibl;
7030 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7031 if (kid->op_type == OP_CONST &&
7032 (kid->op_private & OPpCONST_BARE))
7034 OP * const newop = newGVOP(OP_GV, 0,
7035 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7036 if (!(o->op_private & 1) && /* if not unop */
7037 kid == cLISTOPo->op_last)
7038 cLISTOPo->op_last = newop;
7040 op_getmad(kid,newop,'K');
7046 else if (kid->op_type == OP_READLINE) {
7047 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7048 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7051 I32 flags = OPf_SPECIAL;
7055 /* is this op a FH constructor? */
7056 if (is_handle_constructor(o,numargs)) {
7057 const char *name = NULL;
7061 /* Set a flag to tell rv2gv to vivify
7062 * need to "prove" flag does not mean something
7063 * else already - NI-S 1999/05/07
7066 if (kid->op_type == OP_PADSV) {
7068 = PAD_COMPNAME_SV(kid->op_targ);
7069 name = SvPV_const(namesv, len);
7071 else if (kid->op_type == OP_RV2SV
7072 && kUNOP->op_first->op_type == OP_GV)
7074 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7076 len = GvNAMELEN(gv);
7078 else if (kid->op_type == OP_AELEM
7079 || kid->op_type == OP_HELEM)
7082 OP *op = ((BINOP*)kid)->op_first;
7086 const char * const a =
7087 kid->op_type == OP_AELEM ?
7089 if (((op->op_type == OP_RV2AV) ||
7090 (op->op_type == OP_RV2HV)) &&
7091 (firstop = ((UNOP*)op)->op_first) &&
7092 (firstop->op_type == OP_GV)) {
7093 /* packagevar $a[] or $h{} */
7094 GV * const gv = cGVOPx_gv(firstop);
7102 else if (op->op_type == OP_PADAV
7103 || op->op_type == OP_PADHV) {
7104 /* lexicalvar $a[] or $h{} */
7105 const char * const padname =
7106 PAD_COMPNAME_PV(op->op_targ);
7115 name = SvPV_const(tmpstr, len);
7120 name = "__ANONIO__";
7127 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7128 namesv = PAD_SVl(targ);
7129 SvUPGRADE(namesv, SVt_PV);
7131 sv_setpvs(namesv, "$");
7132 sv_catpvn(namesv, name, len);
7135 kid->op_sibling = 0;
7136 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7137 kid->op_targ = targ;
7138 kid->op_private |= priv;
7140 kid->op_sibling = sibl;
7146 mod(scalar(kid), type);
7150 tokid = &kid->op_sibling;
7151 kid = kid->op_sibling;
7154 if (kid && kid->op_type != OP_STUB)
7155 return too_many_arguments(o,OP_DESC(o));
7156 o->op_private |= numargs;
7158 /* FIXME - should the numargs move as for the PERL_MAD case? */
7159 o->op_private |= numargs;
7161 return too_many_arguments(o,OP_DESC(o));
7165 else if (PL_opargs[type] & OA_DEFGV) {
7167 OP *newop = newUNOP(type, 0, newDEFSVOP());
7168 op_getmad(o,newop,'O');
7171 /* Ordering of these two is important to keep f_map.t passing. */
7173 return newUNOP(type, 0, newDEFSVOP());
7178 while (oa & OA_OPTIONAL)
7180 if (oa && oa != OA_LIST)
7181 return too_few_arguments(o,OP_DESC(o));
7187 Perl_ck_glob(pTHX_ OP *o)
7192 PERL_ARGS_ASSERT_CK_GLOB;
7195 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7196 append_elem(OP_GLOB, o, newDEFSVOP());
7198 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7199 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7201 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7204 #if !defined(PERL_EXTERNAL_GLOB)
7205 /* XXX this can be tightened up and made more failsafe. */
7206 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7209 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7210 newSVpvs("File::Glob"), NULL, NULL, NULL);
7211 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7212 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7213 GvCV(gv) = GvCV(glob_gv);
7214 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7215 GvIMPORTED_CV_on(gv);
7219 #endif /* PERL_EXTERNAL_GLOB */
7221 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7222 append_elem(OP_GLOB, o,
7223 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7224 o->op_type = OP_LIST;
7225 o->op_ppaddr = PL_ppaddr[OP_LIST];
7226 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7227 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7228 cLISTOPo->op_first->op_targ = 0;
7229 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7230 append_elem(OP_LIST, o,
7231 scalar(newUNOP(OP_RV2CV, 0,
7232 newGVOP(OP_GV, 0, gv)))));
7233 o = newUNOP(OP_NULL, 0, ck_subr(o));
7234 o->op_targ = OP_GLOB; /* hint at what it used to be */
7237 gv = newGVgen("main");
7239 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7245 Perl_ck_grep(pTHX_ OP *o)
7250 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7253 PERL_ARGS_ASSERT_CK_GREP;
7255 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7256 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7258 if (o->op_flags & OPf_STACKED) {
7261 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7262 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7263 return no_fh_allowed(o);
7264 for (k = kid; k; k = k->op_next) {
7267 NewOp(1101, gwop, 1, LOGOP);
7268 kid->op_next = (OP*)gwop;
7269 o->op_flags &= ~OPf_STACKED;
7271 kid = cLISTOPo->op_first->op_sibling;
7272 if (type == OP_MAPWHILE)
7277 if (PL_parser && PL_parser->error_count)
7279 kid = cLISTOPo->op_first->op_sibling;
7280 if (kid->op_type != OP_NULL)
7281 Perl_croak(aTHX_ "panic: ck_grep");
7282 kid = kUNOP->op_first;
7285 NewOp(1101, gwop, 1, LOGOP);
7286 gwop->op_type = type;
7287 gwop->op_ppaddr = PL_ppaddr[type];
7288 gwop->op_first = listkids(o);
7289 gwop->op_flags |= OPf_KIDS;
7290 gwop->op_other = LINKLIST(kid);
7291 kid->op_next = (OP*)gwop;
7292 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7293 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7294 o->op_private = gwop->op_private = 0;
7295 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7298 o->op_private = gwop->op_private = OPpGREP_LEX;
7299 gwop->op_targ = o->op_targ = offset;
7302 kid = cLISTOPo->op_first->op_sibling;
7303 if (!kid || !kid->op_sibling)
7304 return too_few_arguments(o,OP_DESC(o));
7305 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7306 mod(kid, OP_GREPSTART);
7312 Perl_ck_index(pTHX_ OP *o)
7314 PERL_ARGS_ASSERT_CK_INDEX;
7316 if (o->op_flags & OPf_KIDS) {
7317 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7319 kid = kid->op_sibling; /* get past "big" */
7320 if (kid && kid->op_type == OP_CONST)
7321 fbm_compile(((SVOP*)kid)->op_sv, 0);
7327 Perl_ck_lfun(pTHX_ OP *o)
7329 const OPCODE type = o->op_type;
7331 PERL_ARGS_ASSERT_CK_LFUN;
7333 return modkids(ck_fun(o), type);
7337 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7339 PERL_ARGS_ASSERT_CK_DEFINED;
7341 if ((o->op_flags & OPf_KIDS)) {
7342 switch (cUNOPo->op_first->op_type) {
7344 /* This is needed for
7345 if (defined %stash::)
7346 to work. Do not break Tk.
7348 break; /* Globals via GV can be undef */
7350 case OP_AASSIGN: /* Is this a good idea? */
7351 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7352 "defined(@array) is deprecated");
7353 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7354 "\t(Maybe you should just omit the defined()?)\n");
7358 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7359 "defined(%%hash) is deprecated");
7360 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7361 "\t(Maybe you should just omit the defined()?)\n");
7372 Perl_ck_readline(pTHX_ OP *o)
7374 PERL_ARGS_ASSERT_CK_READLINE;
7376 if (!(o->op_flags & OPf_KIDS)) {
7378 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7380 op_getmad(o,newop,'O');
7390 Perl_ck_rfun(pTHX_ OP *o)
7392 const OPCODE type = o->op_type;
7394 PERL_ARGS_ASSERT_CK_RFUN;
7396 return refkids(ck_fun(o), type);
7400 Perl_ck_listiob(pTHX_ OP *o)
7404 PERL_ARGS_ASSERT_CK_LISTIOB;
7406 kid = cLISTOPo->op_first;
7409 kid = cLISTOPo->op_first;
7411 if (kid->op_type == OP_PUSHMARK)
7412 kid = kid->op_sibling;
7413 if (kid && o->op_flags & OPf_STACKED)
7414 kid = kid->op_sibling;
7415 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7416 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7417 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7418 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7419 cLISTOPo->op_first->op_sibling = kid;
7420 cLISTOPo->op_last = kid;
7421 kid = kid->op_sibling;
7426 append_elem(o->op_type, o, newDEFSVOP());
7432 Perl_ck_smartmatch(pTHX_ OP *o)
7435 if (0 == (o->op_flags & OPf_SPECIAL)) {
7436 OP *first = cBINOPo->op_first;
7437 OP *second = first->op_sibling;
7439 /* Implicitly take a reference to an array or hash */
7440 first->op_sibling = NULL;
7441 first = cBINOPo->op_first = ref_array_or_hash(first);
7442 second = first->op_sibling = ref_array_or_hash(second);
7444 /* Implicitly take a reference to a regular expression */
7445 if (first->op_type == OP_MATCH) {
7446 first->op_type = OP_QR;
7447 first->op_ppaddr = PL_ppaddr[OP_QR];
7449 if (second->op_type == OP_MATCH) {
7450 second->op_type = OP_QR;
7451 second->op_ppaddr = PL_ppaddr[OP_QR];
7460 Perl_ck_sassign(pTHX_ OP *o)
7463 OP * const kid = cLISTOPo->op_first;
7465 PERL_ARGS_ASSERT_CK_SASSIGN;
7467 /* has a disposable target? */
7468 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7469 && !(kid->op_flags & OPf_STACKED)
7470 /* Cannot steal the second time! */
7471 && !(kid->op_private & OPpTARGET_MY)
7472 /* Keep the full thing for madskills */
7476 OP * const kkid = kid->op_sibling;
7478 /* Can just relocate the target. */
7479 if (kkid && kkid->op_type == OP_PADSV
7480 && !(kkid->op_private & OPpLVAL_INTRO))
7482 kid->op_targ = kkid->op_targ;
7484 /* Now we do not need PADSV and SASSIGN. */
7485 kid->op_sibling = o->op_sibling; /* NULL */
7486 cLISTOPo->op_first = NULL;
7489 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7493 if (kid->op_sibling) {
7494 OP *kkid = kid->op_sibling;
7495 if (kkid->op_type == OP_PADSV
7496 && (kkid->op_private & OPpLVAL_INTRO)
7497 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7498 const PADOFFSET target = kkid->op_targ;
7499 OP *const other = newOP(OP_PADSV,
7501 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7502 OP *const first = newOP(OP_NULL, 0);
7503 OP *const nullop = newCONDOP(0, first, o, other);
7504 OP *const condop = first->op_next;
7505 /* hijacking PADSTALE for uninitialized state variables */
7506 SvPADSTALE_on(PAD_SVl(target));
7508 condop->op_type = OP_ONCE;
7509 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7510 condop->op_targ = target;
7511 other->op_targ = target;
7513 /* Because we change the type of the op here, we will skip the
7514 assinment binop->op_last = binop->op_first->op_sibling; at the
7515 end of Perl_newBINOP(). So need to do it here. */
7516 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7525 Perl_ck_match(pTHX_ OP *o)
7529 PERL_ARGS_ASSERT_CK_MATCH;
7531 if (o->op_type != OP_QR && PL_compcv) {
7532 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7533 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7534 o->op_targ = offset;
7535 o->op_private |= OPpTARGET_MY;
7538 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7539 o->op_private |= OPpRUNTIME;
7544 Perl_ck_method(pTHX_ OP *o)
7546 OP * const kid = cUNOPo->op_first;
7548 PERL_ARGS_ASSERT_CK_METHOD;
7550 if (kid->op_type == OP_CONST) {
7551 SV* sv = kSVOP->op_sv;
7552 const char * const method = SvPVX_const(sv);
7553 if (!(strchr(method, ':') || strchr(method, '\''))) {
7555 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7556 sv = newSVpvn_share(method, SvCUR(sv), 0);
7559 kSVOP->op_sv = NULL;
7561 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7563 op_getmad(o,cmop,'O');
7574 Perl_ck_null(pTHX_ OP *o)
7576 PERL_ARGS_ASSERT_CK_NULL;
7577 PERL_UNUSED_CONTEXT;
7582 Perl_ck_open(pTHX_ OP *o)
7585 HV * const table = GvHV(PL_hintgv);
7587 PERL_ARGS_ASSERT_CK_OPEN;
7590 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7593 const char *d = SvPV_const(*svp, len);
7594 const I32 mode = mode_from_discipline(d, len);
7595 if (mode & O_BINARY)
7596 o->op_private |= OPpOPEN_IN_RAW;
7597 else if (mode & O_TEXT)
7598 o->op_private |= OPpOPEN_IN_CRLF;
7601 svp = hv_fetchs(table, "open_OUT", FALSE);
7604 const char *d = SvPV_const(*svp, len);
7605 const I32 mode = mode_from_discipline(d, len);
7606 if (mode & O_BINARY)
7607 o->op_private |= OPpOPEN_OUT_RAW;
7608 else if (mode & O_TEXT)
7609 o->op_private |= OPpOPEN_OUT_CRLF;
7612 if (o->op_type == OP_BACKTICK) {
7613 if (!(o->op_flags & OPf_KIDS)) {
7614 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7616 op_getmad(o,newop,'O');
7625 /* In case of three-arg dup open remove strictness
7626 * from the last arg if it is a bareword. */
7627 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7628 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7632 if ((last->op_type == OP_CONST) && /* The bareword. */
7633 (last->op_private & OPpCONST_BARE) &&
7634 (last->op_private & OPpCONST_STRICT) &&
7635 (oa = first->op_sibling) && /* The fh. */
7636 (oa = oa->op_sibling) && /* The mode. */
7637 (oa->op_type == OP_CONST) &&
7638 SvPOK(((SVOP*)oa)->op_sv) &&
7639 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7640 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7641 (last == oa->op_sibling)) /* The bareword. */
7642 last->op_private &= ~OPpCONST_STRICT;
7648 Perl_ck_repeat(pTHX_ OP *o)
7650 PERL_ARGS_ASSERT_CK_REPEAT;
7652 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7653 o->op_private |= OPpREPEAT_DOLIST;
7654 cBINOPo->op_first = force_list(cBINOPo->op_first);
7662 Perl_ck_require(pTHX_ OP *o)
7667 PERL_ARGS_ASSERT_CK_REQUIRE;
7669 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7670 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7672 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7673 SV * const sv = kid->op_sv;
7674 U32 was_readonly = SvREADONLY(sv);
7681 sv_force_normal_flags(sv, 0);
7682 assert(!SvREADONLY(sv));
7692 for (; s < end; s++) {
7693 if (*s == ':' && s[1] == ':') {
7695 Move(s+2, s+1, end - s - 1, char);
7700 sv_catpvs(sv, ".pm");
7701 SvFLAGS(sv) |= was_readonly;
7705 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7706 /* handle override, if any */
7707 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7708 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7709 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7710 gv = gvp ? *gvp : NULL;
7714 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7715 OP * const kid = cUNOPo->op_first;
7718 cUNOPo->op_first = 0;
7722 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7723 append_elem(OP_LIST, kid,
7724 scalar(newUNOP(OP_RV2CV, 0,
7727 op_getmad(o,newop,'O');
7731 return scalar(ck_fun(o));
7735 Perl_ck_return(pTHX_ OP *o)
7740 PERL_ARGS_ASSERT_CK_RETURN;
7742 kid = cLISTOPo->op_first->op_sibling;
7743 if (CvLVALUE(PL_compcv)) {
7744 for (; kid; kid = kid->op_sibling)
7745 mod(kid, OP_LEAVESUBLV);
7747 for (; kid; kid = kid->op_sibling)
7748 if ((kid->op_type == OP_NULL)
7749 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7750 /* This is a do block */
7751 OP *op = kUNOP->op_first;
7752 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7753 op = cUNOPx(op)->op_first;
7754 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7755 /* Force the use of the caller's context */
7756 op->op_flags |= OPf_SPECIAL;
7765 Perl_ck_select(pTHX_ OP *o)
7770 PERL_ARGS_ASSERT_CK_SELECT;
7772 if (o->op_flags & OPf_KIDS) {
7773 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7774 if (kid && kid->op_sibling) {
7775 o->op_type = OP_SSELECT;
7776 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7778 return fold_constants(o);
7782 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7783 if (kid && kid->op_type == OP_RV2GV)
7784 kid->op_private &= ~HINT_STRICT_REFS;
7789 Perl_ck_shift(pTHX_ OP *o)
7792 const I32 type = o->op_type;
7794 PERL_ARGS_ASSERT_CK_SHIFT;
7796 if (!(o->op_flags & OPf_KIDS)) {
7799 if (!CvUNIQUE(PL_compcv)) {
7800 o->op_flags |= OPf_SPECIAL;
7804 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
7806 OP * const oldo = o;
7807 o = newUNOP(type, 0, scalar(argop));
7808 op_getmad(oldo,o,'O');
7812 return newUNOP(type, 0, scalar(argop));
7815 return scalar(modkids(ck_fun(o), type));
7819 Perl_ck_sort(pTHX_ OP *o)
7824 PERL_ARGS_ASSERT_CK_SORT;
7826 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7827 HV * const hinthv = GvHV(PL_hintgv);
7829 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7831 const I32 sorthints = (I32)SvIV(*svp);
7832 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7833 o->op_private |= OPpSORT_QSORT;
7834 if ((sorthints & HINT_SORT_STABLE) != 0)
7835 o->op_private |= OPpSORT_STABLE;
7840 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7842 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7843 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7845 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7847 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7849 if (kid->op_type == OP_SCOPE) {
7853 else if (kid->op_type == OP_LEAVE) {
7854 if (o->op_type == OP_SORT) {
7855 op_null(kid); /* wipe out leave */
7858 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7859 if (k->op_next == kid)
7861 /* don't descend into loops */
7862 else if (k->op_type == OP_ENTERLOOP
7863 || k->op_type == OP_ENTERITER)
7865 k = cLOOPx(k)->op_lastop;
7870 kid->op_next = 0; /* just disconnect the leave */
7871 k = kLISTOP->op_first;
7876 if (o->op_type == OP_SORT) {
7877 /* provide scalar context for comparison function/block */
7883 o->op_flags |= OPf_SPECIAL;
7885 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7888 firstkid = firstkid->op_sibling;
7891 /* provide list context for arguments */
7892 if (o->op_type == OP_SORT)
7899 S_simplify_sort(pTHX_ OP *o)
7902 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7908 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7910 if (!(o->op_flags & OPf_STACKED))
7912 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7913 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7914 kid = kUNOP->op_first; /* get past null */
7915 if (kid->op_type != OP_SCOPE)
7917 kid = kLISTOP->op_last; /* get past scope */
7918 switch(kid->op_type) {
7926 k = kid; /* remember this node*/
7927 if (kBINOP->op_first->op_type != OP_RV2SV)
7929 kid = kBINOP->op_first; /* get past cmp */
7930 if (kUNOP->op_first->op_type != OP_GV)
7932 kid = kUNOP->op_first; /* get past rv2sv */
7934 if (GvSTASH(gv) != PL_curstash)
7936 gvname = GvNAME(gv);
7937 if (*gvname == 'a' && gvname[1] == '\0')
7939 else if (*gvname == 'b' && gvname[1] == '\0')
7944 kid = k; /* back to cmp */
7945 if (kBINOP->op_last->op_type != OP_RV2SV)
7947 kid = kBINOP->op_last; /* down to 2nd arg */
7948 if (kUNOP->op_first->op_type != OP_GV)
7950 kid = kUNOP->op_first; /* get past rv2sv */
7952 if (GvSTASH(gv) != PL_curstash)
7954 gvname = GvNAME(gv);
7956 ? !(*gvname == 'a' && gvname[1] == '\0')
7957 : !(*gvname == 'b' && gvname[1] == '\0'))
7959 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7961 o->op_private |= OPpSORT_DESCEND;
7962 if (k->op_type == OP_NCMP)
7963 o->op_private |= OPpSORT_NUMERIC;
7964 if (k->op_type == OP_I_NCMP)
7965 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7966 kid = cLISTOPo->op_first->op_sibling;
7967 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7969 op_getmad(kid,o,'S'); /* then delete it */
7971 op_free(kid); /* then delete it */
7976 Perl_ck_split(pTHX_ OP *o)
7981 PERL_ARGS_ASSERT_CK_SPLIT;
7983 if (o->op_flags & OPf_STACKED)
7984 return no_fh_allowed(o);
7986 kid = cLISTOPo->op_first;
7987 if (kid->op_type != OP_NULL)
7988 Perl_croak(aTHX_ "panic: ck_split");
7989 kid = kid->op_sibling;
7990 op_free(cLISTOPo->op_first);
7991 cLISTOPo->op_first = kid;
7993 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7994 cLISTOPo->op_last = kid; /* There was only one element previously */
7997 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7998 OP * const sibl = kid->op_sibling;
7999 kid->op_sibling = 0;
8000 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8001 if (cLISTOPo->op_first == cLISTOPo->op_last)
8002 cLISTOPo->op_last = kid;
8003 cLISTOPo->op_first = kid;
8004 kid->op_sibling = sibl;
8007 kid->op_type = OP_PUSHRE;
8008 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8010 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8011 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8012 "Use of /g modifier is meaningless in split");
8015 if (!kid->op_sibling)
8016 append_elem(OP_SPLIT, o, newDEFSVOP());
8018 kid = kid->op_sibling;
8021 if (!kid->op_sibling)
8022 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8023 assert(kid->op_sibling);
8025 kid = kid->op_sibling;
8028 if (kid->op_sibling)
8029 return too_many_arguments(o,OP_DESC(o));
8035 Perl_ck_join(pTHX_ OP *o)
8037 const OP * const kid = cLISTOPo->op_first->op_sibling;
8039 PERL_ARGS_ASSERT_CK_JOIN;
8041 if (kid && kid->op_type == OP_MATCH) {
8042 if (ckWARN(WARN_SYNTAX)) {
8043 const REGEXP *re = PM_GETRE(kPMOP);
8044 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8045 const STRLEN len = re ? RX_PRELEN(re) : 6;
8046 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8047 "/%.*s/ should probably be written as \"%.*s\"",
8048 (int)len, pmstr, (int)len, pmstr);
8055 Perl_ck_subr(pTHX_ OP *o)
8058 OP *prev = ((cUNOPo->op_first->op_sibling)
8059 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
8060 OP *o2 = prev->op_sibling;
8062 const char *proto = NULL;
8063 const char *proto_end = NULL;
8068 I32 contextclass = 0;
8069 const char *e = NULL;
8072 PERL_ARGS_ASSERT_CK_SUBR;
8074 o->op_private |= OPpENTERSUB_HASTARG;
8075 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
8076 if (cvop->op_type == OP_RV2CV) {
8077 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
8078 op_null(cvop); /* disable rv2cv */
8079 if (!(o->op_private & OPpENTERSUB_AMPER)) {
8080 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
8082 switch (tmpop->op_type) {
8084 gv = cGVOPx_gv(tmpop);
8087 tmpop->op_private |= OPpEARLY_CV;
8090 SV *sv = cSVOPx_sv(tmpop);
8091 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8095 if (cv && SvPOK(cv)) {
8097 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8098 proto = SvPV(MUTABLE_SV(cv), len);
8099 proto_end = proto + len;
8103 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8104 if (o2->op_type == OP_CONST)
8105 o2->op_private &= ~OPpCONST_STRICT;
8106 else if (o2->op_type == OP_LIST) {
8107 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8108 if (sib && sib->op_type == OP_CONST)
8109 sib->op_private &= ~OPpCONST_STRICT;
8112 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8113 if (PERLDB_SUB && PL_curstash != PL_debstash)
8114 o->op_private |= OPpENTERSUB_DB;
8115 while (o2 != cvop) {
8117 if (PL_madskills && o2->op_type == OP_STUB) {
8118 o2 = o2->op_sibling;
8121 if (PL_madskills && o2->op_type == OP_NULL)
8122 o3 = ((UNOP*)o2)->op_first;
8126 if (proto >= proto_end)
8127 return too_many_arguments(o, gv_ename(namegv));
8135 /* _ must be at the end */
8136 if (proto[1] && proto[1] != ';')
8151 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8153 arg == 1 ? "block or sub {}" : "sub {}",
8154 gv_ename(namegv), o3);
8157 /* '*' allows any scalar type, including bareword */
8160 if (o3->op_type == OP_RV2GV)
8161 goto wrapref; /* autoconvert GLOB -> GLOBref */
8162 else if (o3->op_type == OP_CONST)
8163 o3->op_private &= ~OPpCONST_STRICT;
8164 else if (o3->op_type == OP_ENTERSUB) {
8165 /* accidental subroutine, revert to bareword */
8166 OP *gvop = ((UNOP*)o3)->op_first;
8167 if (gvop && gvop->op_type == OP_NULL) {
8168 gvop = ((UNOP*)gvop)->op_first;
8170 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8173 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8174 (gvop = ((UNOP*)gvop)->op_first) &&
8175 gvop->op_type == OP_GV)
8177 GV * const gv = cGVOPx_gv(gvop);
8178 OP * const sibling = o2->op_sibling;
8179 SV * const n = newSVpvs("");
8181 OP * const oldo2 = o2;
8185 gv_fullname4(n, gv, "", FALSE);
8186 o2 = newSVOP(OP_CONST, 0, n);
8187 op_getmad(oldo2,o2,'O');
8188 prev->op_sibling = o2;
8189 o2->op_sibling = sibling;
8205 if (contextclass++ == 0) {
8206 e = strchr(proto, ']');
8207 if (!e || e == proto)
8216 const char *p = proto;
8217 const char *const end = proto;
8219 while (*--p != '[') {}
8220 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8222 gv_ename(namegv), o3);
8227 if (o3->op_type == OP_RV2GV)
8230 bad_type(arg, "symbol", gv_ename(namegv), o3);
8233 if (o3->op_type == OP_ENTERSUB)
8236 bad_type(arg, "subroutine entry", gv_ename(namegv),
8240 if (o3->op_type == OP_RV2SV ||
8241 o3->op_type == OP_PADSV ||
8242 o3->op_type == OP_HELEM ||
8243 o3->op_type == OP_AELEM)
8246 bad_type(arg, "scalar", gv_ename(namegv), o3);
8249 if (o3->op_type == OP_RV2AV ||
8250 o3->op_type == OP_PADAV)
8253 bad_type(arg, "array", gv_ename(namegv), o3);
8256 if (o3->op_type == OP_RV2HV ||
8257 o3->op_type == OP_PADHV)
8260 bad_type(arg, "hash", gv_ename(namegv), o3);
8265 OP* const sib = kid->op_sibling;
8266 kid->op_sibling = 0;
8267 o2 = newUNOP(OP_REFGEN, 0, kid);
8268 o2->op_sibling = sib;
8269 prev->op_sibling = o2;
8271 if (contextclass && e) {
8286 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8287 gv_ename(namegv), SVfARG(cv));
8292 mod(o2, OP_ENTERSUB);
8294 o2 = o2->op_sibling;
8296 if (o2 == cvop && proto && *proto == '_') {
8297 /* generate an access to $_ */
8299 o2->op_sibling = prev->op_sibling;
8300 prev->op_sibling = o2; /* instead of cvop */
8302 if (proto && !optional && proto_end > proto &&
8303 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8304 return too_few_arguments(o, gv_ename(namegv));
8307 OP * const oldo = o;
8311 o=newSVOP(OP_CONST, 0, newSViv(0));
8312 op_getmad(oldo,o,'O');
8318 Perl_ck_svconst(pTHX_ OP *o)
8320 PERL_ARGS_ASSERT_CK_SVCONST;
8321 PERL_UNUSED_CONTEXT;
8322 SvREADONLY_on(cSVOPo->op_sv);
8327 Perl_ck_chdir(pTHX_ OP *o)
8329 if (o->op_flags & OPf_KIDS) {
8330 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8332 if (kid && kid->op_type == OP_CONST &&
8333 (kid->op_private & OPpCONST_BARE))
8335 o->op_flags |= OPf_SPECIAL;
8336 kid->op_private &= ~OPpCONST_STRICT;
8343 Perl_ck_trunc(pTHX_ OP *o)
8345 PERL_ARGS_ASSERT_CK_TRUNC;
8347 if (o->op_flags & OPf_KIDS) {
8348 SVOP *kid = (SVOP*)cUNOPo->op_first;
8350 if (kid->op_type == OP_NULL)
8351 kid = (SVOP*)kid->op_sibling;
8352 if (kid && kid->op_type == OP_CONST &&
8353 (kid->op_private & OPpCONST_BARE))
8355 o->op_flags |= OPf_SPECIAL;
8356 kid->op_private &= ~OPpCONST_STRICT;
8363 Perl_ck_unpack(pTHX_ OP *o)
8365 OP *kid = cLISTOPo->op_first;
8367 PERL_ARGS_ASSERT_CK_UNPACK;
8369 if (kid->op_sibling) {
8370 kid = kid->op_sibling;
8371 if (!kid->op_sibling)
8372 kid->op_sibling = newDEFSVOP();
8378 Perl_ck_substr(pTHX_ OP *o)
8380 PERL_ARGS_ASSERT_CK_SUBSTR;
8383 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8384 OP *kid = cLISTOPo->op_first;
8386 if (kid->op_type == OP_NULL)
8387 kid = kid->op_sibling;
8389 kid->op_flags |= OPf_MOD;
8396 Perl_ck_each(pTHX_ OP *o)
8399 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8401 PERL_ARGS_ASSERT_CK_EACH;
8404 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8405 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8406 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8407 o->op_type = new_type;
8408 o->op_ppaddr = PL_ppaddr[new_type];
8410 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8411 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8413 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8420 /* caller is supposed to assign the return to the
8421 container of the rep_op var */
8423 S_opt_scalarhv(pTHX_ OP *rep_op) {
8427 PERL_ARGS_ASSERT_OPT_SCALARHV;
8429 NewOp(1101, unop, 1, UNOP);
8430 unop->op_type = (OPCODE)OP_BOOLKEYS;
8431 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8432 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8433 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8434 unop->op_first = rep_op;
8435 unop->op_next = rep_op->op_next;
8436 rep_op->op_next = (OP*)unop;
8437 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8438 unop->op_sibling = rep_op->op_sibling;
8439 rep_op->op_sibling = NULL;
8440 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8441 if (rep_op->op_type == OP_PADHV) {
8442 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8443 rep_op->op_flags |= OPf_WANT_LIST;
8448 /* Checks if o acts as an in-place operator on an array. oright points to the
8449 * beginning of the right-hand side. Returns the left-hand side of the
8450 * assignment if o acts in-place, or NULL otherwise. */
8453 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8457 PERL_ARGS_ASSERT_IS_INPLACE_AV;
8460 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8461 || oright->op_next != o
8462 || (oright->op_private & OPpLVAL_INTRO)
8466 /* o2 follows the chain of op_nexts through the LHS of the
8467 * assign (if any) to the aassign op itself */
8469 if (!o2 || o2->op_type != OP_NULL)
8472 if (!o2 || o2->op_type != OP_PUSHMARK)
8475 if (o2 && o2->op_type == OP_GV)
8478 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8479 || (o2->op_private & OPpLVAL_INTRO)
8484 if (!o2 || o2->op_type != OP_NULL)
8487 if (!o2 || o2->op_type != OP_AASSIGN
8488 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8491 /* check that the sort is the first arg on RHS of assign */
8493 o2 = cUNOPx(o2)->op_first;
8494 if (!o2 || o2->op_type != OP_NULL)
8496 o2 = cUNOPx(o2)->op_first;
8497 if (!o2 || o2->op_type != OP_PUSHMARK)
8499 if (o2->op_sibling != o)
8502 /* check the array is the same on both sides */
8503 if (oleft->op_type == OP_RV2AV) {
8504 if (oright->op_type != OP_RV2AV
8505 || !cUNOPx(oright)->op_first
8506 || cUNOPx(oright)->op_first->op_type != OP_GV
8507 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8508 cGVOPx_gv(cUNOPx(oright)->op_first)
8512 else if (oright->op_type != OP_PADAV
8513 || oright->op_targ != oleft->op_targ
8520 /* A peephole optimizer. We visit the ops in the order they're to execute.
8521 * See the comments at the top of this file for more details about when
8522 * peep() is called */
8525 Perl_peep(pTHX_ register OP *o, peep_next_t *next_peep)
8528 register OP* oldop = NULL;
8530 PERL_ARGS_ASSERT_PEEP;
8532 if (!o || o->op_opt)
8536 SAVEVPTR(PL_curcop);
8537 for (; o; o = o->op_next) {
8540 /* By default, this op has now been optimised. A couple of cases below
8541 clear this again. */
8544 switch (o->op_type) {
8547 PL_curcop = ((COP*)o); /* for warnings */
8551 if (cSVOPo->op_private & OPpCONST_STRICT)
8552 no_bareword_allowed(o);
8555 case OP_METHOD_NAMED:
8556 /* Relocate sv to the pad for thread safety.
8557 * Despite being a "constant", the SV is written to,
8558 * for reference counts, sv_upgrade() etc. */
8560 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8561 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8562 /* If op_sv is already a PADTMP then it is being used by
8563 * some pad, so make a copy. */
8564 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8565 SvREADONLY_on(PAD_SVl(ix));
8566 SvREFCNT_dec(cSVOPo->op_sv);
8568 else if (o->op_type != OP_METHOD_NAMED
8569 && cSVOPo->op_sv == &PL_sv_undef) {
8570 /* PL_sv_undef is hack - it's unsafe to store it in the
8571 AV that is the pad, because av_fetch treats values of
8572 PL_sv_undef as a "free" AV entry and will merrily
8573 replace them with a new SV, causing pad_alloc to think
8574 that this pad slot is free. (When, clearly, it is not)
8576 SvOK_off(PAD_SVl(ix));
8577 SvPADTMP_on(PAD_SVl(ix));
8578 SvREADONLY_on(PAD_SVl(ix));
8581 SvREFCNT_dec(PAD_SVl(ix));
8582 SvPADTMP_on(cSVOPo->op_sv);
8583 PAD_SETSV(ix, cSVOPo->op_sv);
8584 /* XXX I don't know how this isn't readonly already. */
8585 SvREADONLY_on(PAD_SVl(ix));
8587 cSVOPo->op_sv = NULL;
8594 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8595 if (o->op_next->op_private & OPpTARGET_MY) {
8596 if (o->op_flags & OPf_STACKED) /* chained concats */
8597 break; /* ignore_optimization */
8599 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8600 o->op_targ = o->op_next->op_targ;
8601 o->op_next->op_targ = 0;
8602 o->op_private |= OPpTARGET_MY;
8605 op_null(o->op_next);
8609 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8610 break; /* Scalar stub must produce undef. List stub is noop */
8614 if (o->op_targ == OP_NEXTSTATE
8615 || o->op_targ == OP_DBSTATE)
8617 PL_curcop = ((COP*)o);
8619 /* XXX: We avoid setting op_seq here to prevent later calls
8620 to peep() from mistakenly concluding that optimisation
8621 has already occurred. This doesn't fix the real problem,
8622 though (See 20010220.007). AMS 20010719 */
8623 /* op_seq functionality is now replaced by op_opt */
8630 if (oldop && o->op_next) {
8631 oldop->op_next = o->op_next;
8639 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8640 OP* const pop = (o->op_type == OP_PADAV) ?
8641 o->op_next : o->op_next->op_next;
8643 if (pop && pop->op_type == OP_CONST &&
8644 ((PL_op = pop->op_next)) &&
8645 pop->op_next->op_type == OP_AELEM &&
8646 !(pop->op_next->op_private &
8647 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8648 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8653 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8654 no_bareword_allowed(pop);
8655 if (o->op_type == OP_GV)
8656 op_null(o->op_next);
8657 op_null(pop->op_next);
8659 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8660 o->op_next = pop->op_next->op_next;
8661 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8662 o->op_private = (U8)i;
8663 if (o->op_type == OP_GV) {
8668 o->op_flags |= OPf_SPECIAL;
8669 o->op_type = OP_AELEMFAST;
8674 if (o->op_next->op_type == OP_RV2SV) {
8675 if (!(o->op_next->op_private & OPpDEREF)) {
8676 op_null(o->op_next);
8677 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8679 o->op_next = o->op_next->op_next;
8680 o->op_type = OP_GVSV;
8681 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8684 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8685 GV * const gv = cGVOPo_gv;
8686 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8687 /* XXX could check prototype here instead of just carping */
8688 SV * const sv = sv_newmortal();
8689 gv_efullname3(sv, gv, NULL);
8690 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8691 "%"SVf"() called too early to check prototype",
8695 else if (o->op_next->op_type == OP_READLINE
8696 && o->op_next->op_next->op_type == OP_CONCAT
8697 && (o->op_next->op_next->op_flags & OPf_STACKED))
8699 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8700 o->op_type = OP_RCATLINE;
8701 o->op_flags |= OPf_STACKED;
8702 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8703 op_null(o->op_next->op_next);
8704 op_null(o->op_next);
8714 fop = cUNOP->op_first;
8722 fop = cLOGOP->op_first;
8723 sop = fop->op_sibling;
8724 while (cLOGOP->op_other->op_type == OP_NULL)
8725 cLOGOP->op_other = cLOGOP->op_other->op_next;
8726 CALL_A_PEEP(next_peep, cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8730 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8732 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8737 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
8738 while (nop && nop->op_next) {
8739 switch (nop->op_next->op_type) {
8744 lop = nop = nop->op_next;
8755 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
8756 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8757 cLOGOP->op_first = opt_scalarhv(fop);
8758 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8759 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8775 while (cLOGOP->op_other->op_type == OP_NULL)
8776 cLOGOP->op_other = cLOGOP->op_other->op_next;
8777 CALL_A_PEEP(next_peep, cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8782 while (cLOOP->op_redoop->op_type == OP_NULL)
8783 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8784 CALL_A_PEEP(next_peep, cLOOP->op_redoop);
8785 while (cLOOP->op_nextop->op_type == OP_NULL)
8786 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8787 CALL_A_PEEP(next_peep, cLOOP->op_nextop);
8788 while (cLOOP->op_lastop->op_type == OP_NULL)
8789 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8790 CALL_A_PEEP(next_peep, cLOOP->op_lastop);
8794 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8795 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8796 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8797 cPMOP->op_pmstashstartu.op_pmreplstart
8798 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8799 CALL_A_PEEP(next_peep, cPMOP->op_pmstashstartu.op_pmreplstart);
8803 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8804 && ckWARN(WARN_SYNTAX))
8806 if (o->op_next->op_sibling) {
8807 const OPCODE type = o->op_next->op_sibling->op_type;
8808 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8809 const line_t oldline = CopLINE(PL_curcop);
8810 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8811 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8812 "Statement unlikely to be reached");
8813 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8814 "\t(Maybe you meant system() when you said exec()?)\n");
8815 CopLINE_set(PL_curcop, oldline);
8826 const char *key = NULL;
8829 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8832 /* Make the CONST have a shared SV */
8833 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8834 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8835 key = SvPV_const(sv, keylen);
8836 lexname = newSVpvn_share(key,
8837 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8843 if ((o->op_private & (OPpLVAL_INTRO)))
8846 rop = (UNOP*)((BINOP*)o)->op_first;
8847 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8849 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8850 if (!SvPAD_TYPED(lexname))
8852 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8853 if (!fields || !GvHV(*fields))
8855 key = SvPV_const(*svp, keylen);
8856 if (!hv_fetch(GvHV(*fields), key,
8857 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8859 Perl_croak(aTHX_ "No such class field \"%s\" "
8860 "in variable %s of type %s",
8861 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8874 SVOP *first_key_op, *key_op;
8876 if ((o->op_private & (OPpLVAL_INTRO))
8877 /* I bet there's always a pushmark... */
8878 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8879 /* hmmm, no optimization if list contains only one key. */
8881 rop = (UNOP*)((LISTOP*)o)->op_last;
8882 if (rop->op_type != OP_RV2HV)
8884 if (rop->op_first->op_type == OP_PADSV)
8885 /* @$hash{qw(keys here)} */
8886 rop = (UNOP*)rop->op_first;
8888 /* @{$hash}{qw(keys here)} */
8889 if (rop->op_first->op_type == OP_SCOPE
8890 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8892 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8898 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8899 if (!SvPAD_TYPED(lexname))
8901 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8902 if (!fields || !GvHV(*fields))
8904 /* Again guessing that the pushmark can be jumped over.... */
8905 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8906 ->op_first->op_sibling;
8907 for (key_op = first_key_op; key_op;
8908 key_op = (SVOP*)key_op->op_sibling) {
8909 if (key_op->op_type != OP_CONST)
8911 svp = cSVOPx_svp(key_op);
8912 key = SvPV_const(*svp, keylen);
8913 if (!hv_fetch(GvHV(*fields), key,
8914 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8916 Perl_croak(aTHX_ "No such class field \"%s\" "
8917 "in variable %s of type %s",
8918 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8927 && ( oldop->op_type == OP_AELEM
8928 || oldop->op_type == OP_PADSV
8929 || oldop->op_type == OP_RV2SV
8930 || oldop->op_type == OP_RV2GV
8931 || oldop->op_type == OP_HELEM
8933 && (oldop->op_private & OPpDEREF)
8935 o->op_private |= OPpDEREFed;
8939 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8943 /* check that RHS of sort is a single plain array */
8944 OP *oright = cUNOPo->op_first;
8945 if (!oright || oright->op_type != OP_PUSHMARK)
8948 /* reverse sort ... can be optimised. */
8949 if (!cUNOPo->op_sibling) {
8950 /* Nothing follows us on the list. */
8951 OP * const reverse = o->op_next;
8953 if (reverse->op_type == OP_REVERSE &&
8954 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8955 OP * const pushmark = cUNOPx(reverse)->op_first;
8956 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8957 && (cUNOPx(pushmark)->op_sibling == o)) {
8958 /* reverse -> pushmark -> sort */
8959 o->op_private |= OPpSORT_REVERSE;
8961 pushmark->op_next = oright->op_next;
8967 /* make @a = sort @a act in-place */
8969 oright = cUNOPx(oright)->op_sibling;
8972 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8973 oright = cUNOPx(oright)->op_sibling;
8976 oleft = is_inplace_av(o, oright);
8980 /* transfer MODishness etc from LHS arg to RHS arg */
8981 oright->op_flags = oleft->op_flags;
8982 o->op_private |= OPpSORT_INPLACE;
8984 /* excise push->gv->rv2av->null->aassign */
8985 o2 = o->op_next->op_next;
8986 op_null(o2); /* PUSHMARK */
8988 if (o2->op_type == OP_GV) {
8989 op_null(o2); /* GV */
8992 op_null(o2); /* RV2AV or PADAV */
8993 o2 = o2->op_next->op_next;
8994 op_null(o2); /* AASSIGN */
8996 o->op_next = o2->op_next;
9002 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9005 LISTOP *enter, *exlist;
9007 /* @a = reverse @a */
9008 if ((oright = cLISTOPo->op_first)
9009 && (oright->op_type == OP_PUSHMARK)
9010 && (oright = oright->op_sibling)
9011 && (oleft = is_inplace_av(o, oright))) {
9014 /* transfer MODishness etc from LHS arg to RHS arg */
9015 oright->op_flags = oleft->op_flags;
9016 o->op_private |= OPpREVERSE_INPLACE;
9018 /* excise push->gv->rv2av->null->aassign */
9019 o2 = o->op_next->op_next;
9020 op_null(o2); /* PUSHMARK */
9022 if (o2->op_type == OP_GV) {
9023 op_null(o2); /* GV */
9026 op_null(o2); /* RV2AV or PADAV */
9027 o2 = o2->op_next->op_next;
9028 op_null(o2); /* AASSIGN */
9030 o->op_next = o2->op_next;
9034 enter = (LISTOP *) o->op_next;
9037 if (enter->op_type == OP_NULL) {
9038 enter = (LISTOP *) enter->op_next;
9042 /* for $a (...) will have OP_GV then OP_RV2GV here.
9043 for (...) just has an OP_GV. */
9044 if (enter->op_type == OP_GV) {
9045 gvop = (OP *) enter;
9046 enter = (LISTOP *) enter->op_next;
9049 if (enter->op_type == OP_RV2GV) {
9050 enter = (LISTOP *) enter->op_next;
9056 if (enter->op_type != OP_ENTERITER)
9059 iter = enter->op_next;
9060 if (!iter || iter->op_type != OP_ITER)
9063 expushmark = enter->op_first;
9064 if (!expushmark || expushmark->op_type != OP_NULL
9065 || expushmark->op_targ != OP_PUSHMARK)
9068 exlist = (LISTOP *) expushmark->op_sibling;
9069 if (!exlist || exlist->op_type != OP_NULL
9070 || exlist->op_targ != OP_LIST)
9073 if (exlist->op_last != o) {
9074 /* Mmm. Was expecting to point back to this op. */
9077 theirmark = exlist->op_first;
9078 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9081 if (theirmark->op_sibling != o) {
9082 /* There's something between the mark and the reverse, eg
9083 for (1, reverse (...))
9088 ourmark = ((LISTOP *)o)->op_first;
9089 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9092 ourlast = ((LISTOP *)o)->op_last;
9093 if (!ourlast || ourlast->op_next != o)
9096 rv2av = ourmark->op_sibling;
9097 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9098 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9099 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9100 /* We're just reversing a single array. */
9101 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9102 enter->op_flags |= OPf_STACKED;
9105 /* We don't have control over who points to theirmark, so sacrifice
9107 theirmark->op_next = ourmark->op_next;
9108 theirmark->op_flags = ourmark->op_flags;
9109 ourlast->op_next = gvop ? gvop : (OP *) enter;
9112 enter->op_private |= OPpITER_REVERSED;
9113 iter->op_private |= OPpITER_REVERSED;
9120 UNOP *refgen, *rv2cv;
9123 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9126 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9129 rv2gv = ((BINOP *)o)->op_last;
9130 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9133 refgen = (UNOP *)((BINOP *)o)->op_first;
9135 if (!refgen || refgen->op_type != OP_REFGEN)
9138 exlist = (LISTOP *)refgen->op_first;
9139 if (!exlist || exlist->op_type != OP_NULL
9140 || exlist->op_targ != OP_LIST)
9143 if (exlist->op_first->op_type != OP_PUSHMARK)
9146 rv2cv = (UNOP*)exlist->op_last;
9148 if (rv2cv->op_type != OP_RV2CV)
9151 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9152 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9153 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9155 o->op_private |= OPpASSIGN_CV_TO_GV;
9156 rv2gv->op_private |= OPpDONT_INIT_GV;
9157 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9165 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9166 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9176 Perl_custom_op_name(pTHX_ const OP* o)
9179 const IV index = PTR2IV(o->op_ppaddr);
9183 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9185 if (!PL_custom_op_names) /* This probably shouldn't happen */
9186 return (char *)PL_op_name[OP_CUSTOM];
9188 keysv = sv_2mortal(newSViv(index));
9190 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9192 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9194 return SvPV_nolen(HeVAL(he));
9198 Perl_custom_op_desc(pTHX_ const OP* o)
9201 const IV index = PTR2IV(o->op_ppaddr);
9205 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9207 if (!PL_custom_op_descs)
9208 return (char *)PL_op_desc[OP_CUSTOM];
9210 keysv = sv_2mortal(newSViv(index));
9212 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9214 return (char *)PL_op_desc[OP_CUSTOM];
9216 return SvPV_nolen(HeVAL(he));
9221 /* Efficient sub that returns a constant scalar value. */
9223 const_sv_xsub(pTHX_ CV* cv)
9227 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9231 /* diag_listed_as: SKIPME */
9232 Perl_croak(aTHX_ "usage: %s::%s()",
9233 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9246 * c-indentation-style: bsd
9248 * indent-tabs-mode: t
9251 * ex: set ts=8 sts=4 sw=4 noet: