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; \
111 _next_peep.fn = PL_peepp; \
112 _next_peep.user_data = NULL; \
113 CALL_A_PEEP(&_next_peep, o); \
116 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
118 #if defined(PL_OP_SLAB_ALLOC)
120 #ifdef PERL_DEBUG_READONLY_OPS
121 # define PERL_SLAB_SIZE 4096
122 # include <sys/mman.h>
125 #ifndef PERL_SLAB_SIZE
126 #define PERL_SLAB_SIZE 2048
130 Perl_Slab_Alloc(pTHX_ size_t sz)
134 * To make incrementing use count easy PL_OpSlab is an I32 *
135 * To make inserting the link to slab PL_OpPtr is I32 **
136 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
137 * Add an overhead for pointer to slab and round up as a number of pointers
139 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
140 if ((PL_OpSpace -= sz) < 0) {
141 #ifdef PERL_DEBUG_READONLY_OPS
142 /* We need to allocate chunk by chunk so that we can control the VM
144 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
145 MAP_ANON|MAP_PRIVATE, -1, 0);
147 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
148 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
150 if(PL_OpPtr == MAP_FAILED) {
151 perror("mmap failed");
156 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
161 /* We reserve the 0'th I32 sized chunk as a use count */
162 PL_OpSlab = (I32 *) PL_OpPtr;
163 /* Reduce size by the use count word, and by the size we need.
164 * Latter is to mimic the '-=' in the if() above
166 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
167 /* Allocation pointer starts at the top.
168 Theory: because we build leaves before trunk allocating at end
169 means that at run time access is cache friendly upward
171 PL_OpPtr += PERL_SLAB_SIZE;
173 #ifdef PERL_DEBUG_READONLY_OPS
174 /* We remember this slab. */
175 /* This implementation isn't efficient, but it is simple. */
176 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
177 PL_slabs[PL_slab_count++] = PL_OpSlab;
178 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
181 assert( PL_OpSpace >= 0 );
182 /* Move the allocation pointer down */
184 assert( PL_OpPtr > (I32 **) PL_OpSlab );
185 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
186 (*PL_OpSlab)++; /* Increment use count of slab */
187 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
188 assert( *PL_OpSlab > 0 );
189 return (void *)(PL_OpPtr + 1);
192 #ifdef PERL_DEBUG_READONLY_OPS
194 Perl_pending_Slabs_to_ro(pTHX) {
195 /* Turn all the allocated op slabs read only. */
196 U32 count = PL_slab_count;
197 I32 **const slabs = PL_slabs;
199 /* Reset the array of pending OP slabs, as we're about to turn this lot
200 read only. Also, do it ahead of the loop in case the warn triggers,
201 and a warn handler has an eval */
206 /* Force a new slab for any further allocation. */
210 void *const start = slabs[count];
211 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
212 if(mprotect(start, size, PROT_READ)) {
213 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
214 start, (unsigned long) size, errno);
222 S_Slab_to_rw(pTHX_ void *op)
224 I32 * const * const ptr = (I32 **) op;
225 I32 * const slab = ptr[-1];
227 PERL_ARGS_ASSERT_SLAB_TO_RW;
229 assert( ptr-1 > (I32 **) slab );
230 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
232 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
233 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
234 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
239 Perl_op_refcnt_inc(pTHX_ OP *o)
250 Perl_op_refcnt_dec(pTHX_ OP *o)
252 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
257 # define Slab_to_rw(op)
261 Perl_Slab_Free(pTHX_ void *op)
263 I32 * const * const ptr = (I32 **) op;
264 I32 * const slab = ptr[-1];
265 PERL_ARGS_ASSERT_SLAB_FREE;
266 assert( ptr-1 > (I32 **) slab );
267 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
270 if (--(*slab) == 0) {
272 # define PerlMemShared PerlMem
275 #ifdef PERL_DEBUG_READONLY_OPS
276 U32 count = PL_slab_count;
277 /* Need to remove this slab from our list of slabs */
280 if (PL_slabs[count] == slab) {
282 /* Found it. Move the entry at the end to overwrite it. */
283 DEBUG_m(PerlIO_printf(Perl_debug_log,
284 "Deallocate %p by moving %p from %lu to %lu\n",
286 PL_slabs[PL_slab_count - 1],
287 PL_slab_count, count));
288 PL_slabs[count] = PL_slabs[--PL_slab_count];
289 /* Could realloc smaller at this point, but probably not
291 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
292 perror("munmap failed");
300 PerlMemShared_free(slab);
302 if (slab == PL_OpSlab) {
309 * In the following definition, the ", (OP*)0" is just to make the compiler
310 * think the expression is of the right type: croak actually does a Siglongjmp.
312 #define CHECKOP(type,o) \
313 ((PL_op_mask && PL_op_mask[type]) \
314 ? ( op_free((OP*)o), \
315 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
317 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
319 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
322 S_gv_ename(pTHX_ GV *gv)
324 SV* const tmpsv = sv_newmortal();
326 PERL_ARGS_ASSERT_GV_ENAME;
328 gv_efullname3(tmpsv, gv, NULL);
329 return SvPV_nolen_const(tmpsv);
333 S_no_fh_allowed(pTHX_ OP *o)
335 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
337 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
343 S_too_few_arguments(pTHX_ OP *o, const char *name)
345 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
347 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
352 S_too_many_arguments(pTHX_ OP *o, const char *name)
354 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
356 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
361 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
363 PERL_ARGS_ASSERT_BAD_TYPE;
365 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
366 (int)n, name, t, OP_DESC(kid)));
370 S_no_bareword_allowed(pTHX_ const OP *o)
372 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
375 return; /* various ok barewords are hidden in extra OP_NULL */
376 qerror(Perl_mess(aTHX_
377 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
381 /* "register" allocation */
384 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
388 const bool is_our = (PL_parser->in_my == KEY_our);
390 PERL_ARGS_ASSERT_ALLOCMY;
393 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
396 /* Until we're using the length for real, cross check that we're being
398 assert(strlen(name) == len);
400 /* complain about "my $<special_var>" etc etc */
404 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
405 (name[1] == '_' && (*name == '$' || len > 2))))
407 /* name[2] is true if strlen(name) > 2 */
408 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
409 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
410 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
411 PL_parser->in_my == KEY_state ? "state" : "my"));
413 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
414 PL_parser->in_my == KEY_state ? "state" : "my"));
418 /* allocate a spare slot and store the name in that slot */
420 off = pad_add_name(name, len,
421 is_our ? padadd_OUR :
422 PL_parser->in_my == KEY_state ? padadd_STATE : 0,
423 PL_parser->in_my_stash,
425 /* $_ is always in main::, even with our */
426 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
430 /* anon sub prototypes contains state vars should always be cloned,
431 * otherwise the state var would be shared between anon subs */
433 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
434 CvCLONE_on(PL_compcv);
439 /* free the body of an op without examining its contents.
440 * Always use this rather than FreeOp directly */
443 S_op_destroy(pTHX_ OP *o)
445 if (o->op_latefree) {
453 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
455 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
461 Perl_op_free(pTHX_ OP *o)
468 if (o->op_latefreed) {
475 if (o->op_private & OPpREFCOUNTED) {
486 refcnt = OpREFCNT_dec(o);
489 /* Need to find and remove any pattern match ops from the list
490 we maintain for reset(). */
491 find_and_forget_pmops(o);
501 /* Call the op_free hook if it has been set. Do it now so that it's called
502 * at the right time for refcounted ops, but still before all of the kids
506 if (o->op_flags & OPf_KIDS) {
507 register OP *kid, *nextkid;
508 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
509 nextkid = kid->op_sibling; /* Get before next freeing kid */
514 #ifdef PERL_DEBUG_READONLY_OPS
518 /* COP* is not cleared by op_clear() so that we may track line
519 * numbers etc even after null() */
520 if (type == OP_NEXTSTATE || type == OP_DBSTATE
521 || (type == OP_NULL /* the COP might have been null'ed */
522 && ((OPCODE)o->op_targ == OP_NEXTSTATE
523 || (OPCODE)o->op_targ == OP_DBSTATE))) {
528 type = (OPCODE)o->op_targ;
531 if (o->op_latefree) {
537 #ifdef DEBUG_LEAKING_SCALARS
544 Perl_op_clear(pTHX_ OP *o)
549 PERL_ARGS_ASSERT_OP_CLEAR;
552 /* if (o->op_madprop && o->op_madprop->mad_next)
554 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
555 "modification of a read only value" for a reason I can't fathom why.
556 It's the "" stringification of $_, where $_ was set to '' in a foreach
557 loop, but it defies simplification into a small test case.
558 However, commenting them out has caused ext/List/Util/t/weak.t to fail
561 mad_free(o->op_madprop);
567 switch (o->op_type) {
568 case OP_NULL: /* Was holding old type, if any. */
569 if (PL_madskills && o->op_targ != OP_NULL) {
570 o->op_type = (Optype)o->op_targ;
575 case OP_ENTEREVAL: /* Was holding hints. */
579 if (!(o->op_flags & OPf_REF)
580 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
586 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
587 /* not an OP_PADAV replacement */
588 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
593 /* It's possible during global destruction that the GV is freed
594 before the optree. Whilst the SvREFCNT_inc is happy to bump from
595 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
596 will trigger an assertion failure, because the entry to sv_clear
597 checks that the scalar is not already freed. A check of for
598 !SvIS_FREED(gv) turns out to be invalid, because during global
599 destruction the reference count can be forced down to zero
600 (with SVf_BREAK set). In which case raising to 1 and then
601 dropping to 0 triggers cleanup before it should happen. I
602 *think* that this might actually be a general, systematic,
603 weakness of the whole idea of SVf_BREAK, in that code *is*
604 allowed to raise and lower references during global destruction,
605 so any *valid* code that happens to do this during global
606 destruction might well trigger premature cleanup. */
607 bool still_valid = gv && SvREFCNT(gv);
610 SvREFCNT_inc_simple_void(gv);
612 if (cPADOPo->op_padix > 0) {
613 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
614 * may still exist on the pad */
615 pad_swipe(cPADOPo->op_padix, TRUE);
616 cPADOPo->op_padix = 0;
619 SvREFCNT_dec(cSVOPo->op_sv);
620 cSVOPo->op_sv = NULL;
623 int try_downgrade = SvREFCNT(gv) == 2;
626 gv_try_downgrade(gv);
630 case OP_METHOD_NAMED:
633 SvREFCNT_dec(cSVOPo->op_sv);
634 cSVOPo->op_sv = NULL;
637 Even if op_clear does a pad_free for the target of the op,
638 pad_free doesn't actually remove the sv that exists in the pad;
639 instead it lives on. This results in that it could be reused as
640 a target later on when the pad was reallocated.
643 pad_swipe(o->op_targ,1);
652 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
656 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
658 if (cPADOPo->op_padix > 0) {
659 pad_swipe(cPADOPo->op_padix, TRUE);
660 cPADOPo->op_padix = 0;
663 SvREFCNT_dec(cSVOPo->op_sv);
664 cSVOPo->op_sv = NULL;
668 PerlMemShared_free(cPVOPo->op_pv);
669 cPVOPo->op_pv = NULL;
673 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
677 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
678 /* No GvIN_PAD_off here, because other references may still
679 * exist on the pad */
680 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
683 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
689 forget_pmop(cPMOPo, 1);
690 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
691 /* we use the same protection as the "SAFE" version of the PM_ macros
692 * here since sv_clean_all might release some PMOPs
693 * after PL_regex_padav has been cleared
694 * and the clearing of PL_regex_padav needs to
695 * happen before sv_clean_all
698 if(PL_regex_pad) { /* We could be in destruction */
699 const IV offset = (cPMOPo)->op_pmoffset;
700 ReREFCNT_dec(PM_GETRE(cPMOPo));
701 PL_regex_pad[offset] = &PL_sv_undef;
702 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
706 ReREFCNT_dec(PM_GETRE(cPMOPo));
707 PM_SETRE(cPMOPo, NULL);
713 if (o->op_targ > 0) {
714 pad_free(o->op_targ);
720 S_cop_free(pTHX_ COP* cop)
722 PERL_ARGS_ASSERT_COP_FREE;
726 if (! specialWARN(cop->cop_warnings))
727 PerlMemShared_free(cop->cop_warnings);
728 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
732 S_forget_pmop(pTHX_ PMOP *const o
738 HV * const pmstash = PmopSTASH(o);
740 PERL_ARGS_ASSERT_FORGET_PMOP;
742 if (pmstash && !SvIS_FREED(pmstash)) {
743 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
745 PMOP **const array = (PMOP**) mg->mg_ptr;
746 U32 count = mg->mg_len / sizeof(PMOP**);
751 /* Found it. Move the entry at the end to overwrite it. */
752 array[i] = array[--count];
753 mg->mg_len = count * sizeof(PMOP**);
754 /* Could realloc smaller at this point always, but probably
755 not worth it. Probably worth free()ing if we're the
758 Safefree(mg->mg_ptr);
775 S_find_and_forget_pmops(pTHX_ OP *o)
777 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
779 if (o->op_flags & OPf_KIDS) {
780 OP *kid = cUNOPo->op_first;
782 switch (kid->op_type) {
787 forget_pmop((PMOP*)kid, 0);
789 find_and_forget_pmops(kid);
790 kid = kid->op_sibling;
796 Perl_op_null(pTHX_ OP *o)
800 PERL_ARGS_ASSERT_OP_NULL;
802 if (o->op_type == OP_NULL)
806 o->op_targ = o->op_type;
807 o->op_type = OP_NULL;
808 o->op_ppaddr = PL_ppaddr[OP_NULL];
812 Perl_op_refcnt_lock(pTHX)
820 Perl_op_refcnt_unlock(pTHX)
827 /* Contextualizers */
829 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
832 S_linklist(pTHX_ OP *o)
836 PERL_ARGS_ASSERT_LINKLIST;
841 /* establish postfix order */
842 first = cUNOPo->op_first;
845 o->op_next = LINKLIST(first);
848 if (kid->op_sibling) {
849 kid->op_next = LINKLIST(kid->op_sibling);
850 kid = kid->op_sibling;
864 S_scalarkids(pTHX_ OP *o)
866 if (o && o->op_flags & OPf_KIDS) {
868 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
875 S_scalarboolean(pTHX_ OP *o)
879 PERL_ARGS_ASSERT_SCALARBOOLEAN;
881 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
882 if (ckWARN(WARN_SYNTAX)) {
883 const line_t oldline = CopLINE(PL_curcop);
885 if (PL_parser && PL_parser->copline != NOLINE)
886 CopLINE_set(PL_curcop, PL_parser->copline);
887 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
888 CopLINE_set(PL_curcop, oldline);
895 Perl_scalar(pTHX_ OP *o)
900 /* assumes no premature commitment */
901 if (!o || (PL_parser && PL_parser->error_count)
902 || (o->op_flags & OPf_WANT)
903 || o->op_type == OP_RETURN)
908 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
910 switch (o->op_type) {
912 scalar(cBINOPo->op_first);
917 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
927 if (o->op_flags & OPf_KIDS) {
928 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
934 kid = cLISTOPo->op_first;
936 kid = kid->op_sibling;
939 OP *sib = kid->op_sibling;
940 if (sib && kid->op_type != OP_LEAVEWHEN) {
941 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
951 PL_curcop = &PL_compiling;
956 kid = cLISTOPo->op_first;
959 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
966 Perl_scalarvoid(pTHX_ OP *o)
970 const char* useless = NULL;
974 PERL_ARGS_ASSERT_SCALARVOID;
976 /* trailing mad null ops don't count as "there" for void processing */
978 o->op_type != OP_NULL &&
980 o->op_sibling->op_type == OP_NULL)
983 for (sib = o->op_sibling;
984 sib && sib->op_type == OP_NULL;
985 sib = sib->op_sibling) ;
991 if (o->op_type == OP_NEXTSTATE
992 || o->op_type == OP_DBSTATE
993 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
994 || o->op_targ == OP_DBSTATE)))
995 PL_curcop = (COP*)o; /* for warning below */
997 /* assumes no premature commitment */
998 want = o->op_flags & OPf_WANT;
999 if ((want && want != OPf_WANT_SCALAR)
1000 || (PL_parser && PL_parser->error_count)
1001 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1006 if ((o->op_private & OPpTARGET_MY)
1007 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1009 return scalar(o); /* As if inside SASSIGN */
1012 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1014 switch (o->op_type) {
1016 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1020 if (o->op_flags & OPf_STACKED)
1024 if (o->op_private == 4)
1067 case OP_GETSOCKNAME:
1068 case OP_GETPEERNAME:
1073 case OP_GETPRIORITY:
1097 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1098 /* Otherwise it's "Useless use of grep iterator" */
1099 useless = OP_DESC(o);
1103 kid = cLISTOPo->op_first;
1104 if (kid && kid->op_type == OP_PUSHRE
1106 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1108 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1110 useless = OP_DESC(o);
1114 kid = cUNOPo->op_first;
1115 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1116 kid->op_type != OP_TRANS) {
1119 useless = "negative pattern binding (!~)";
1123 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1124 useless = "Non-destructive substitution (s///r)";
1131 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1132 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1133 useless = "a variable";
1138 if (cSVOPo->op_private & OPpCONST_STRICT)
1139 no_bareword_allowed(o);
1141 if (ckWARN(WARN_VOID)) {
1143 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1144 "a constant (%"SVf")", sv));
1145 useless = SvPV_nolen(msv);
1148 useless = "a constant (undef)";
1149 if (o->op_private & OPpCONST_ARYBASE)
1151 /* don't warn on optimised away booleans, eg
1152 * use constant Foo, 5; Foo || print; */
1153 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1155 /* the constants 0 and 1 are permitted as they are
1156 conventionally used as dummies in constructs like
1157 1 while some_condition_with_side_effects; */
1158 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1160 else if (SvPOK(sv)) {
1161 /* perl4's way of mixing documentation and code
1162 (before the invention of POD) was based on a
1163 trick to mix nroff and perl code. The trick was
1164 built upon these three nroff macros being used in
1165 void context. The pink camel has the details in
1166 the script wrapman near page 319. */
1167 const char * const maybe_macro = SvPVX_const(sv);
1168 if (strnEQ(maybe_macro, "di", 2) ||
1169 strnEQ(maybe_macro, "ds", 2) ||
1170 strnEQ(maybe_macro, "ig", 2))
1175 op_null(o); /* don't execute or even remember it */
1179 o->op_type = OP_PREINC; /* pre-increment is faster */
1180 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1184 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1185 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1189 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1190 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1194 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1195 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1200 kid = cLOGOPo->op_first;
1201 if (kid->op_type == OP_NOT
1202 && (kid->op_flags & OPf_KIDS)
1204 if (o->op_type == OP_AND) {
1206 o->op_ppaddr = PL_ppaddr[OP_OR];
1208 o->op_type = OP_AND;
1209 o->op_ppaddr = PL_ppaddr[OP_AND];
1218 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1223 if (o->op_flags & OPf_STACKED)
1230 if (!(o->op_flags & OPf_KIDS))
1241 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1251 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1256 S_listkids(pTHX_ OP *o)
1258 if (o && o->op_flags & OPf_KIDS) {
1260 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1267 Perl_list(pTHX_ OP *o)
1272 /* assumes no premature commitment */
1273 if (!o || (o->op_flags & OPf_WANT)
1274 || (PL_parser && PL_parser->error_count)
1275 || o->op_type == OP_RETURN)
1280 if ((o->op_private & OPpTARGET_MY)
1281 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1283 return o; /* As if inside SASSIGN */
1286 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1288 switch (o->op_type) {
1291 list(cBINOPo->op_first);
1296 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1304 if (!(o->op_flags & OPf_KIDS))
1306 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1307 list(cBINOPo->op_first);
1308 return gen_constant_list(o);
1315 kid = cLISTOPo->op_first;
1317 kid = kid->op_sibling;
1320 OP *sib = kid->op_sibling;
1321 if (sib && kid->op_type != OP_LEAVEWHEN) {
1322 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1332 PL_curcop = &PL_compiling;
1336 kid = cLISTOPo->op_first;
1343 S_scalarseq(pTHX_ OP *o)
1347 const OPCODE type = o->op_type;
1349 if (type == OP_LINESEQ || type == OP_SCOPE ||
1350 type == OP_LEAVE || type == OP_LEAVETRY)
1353 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1354 if (kid->op_sibling) {
1358 PL_curcop = &PL_compiling;
1360 o->op_flags &= ~OPf_PARENS;
1361 if (PL_hints & HINT_BLOCK_SCOPE)
1362 o->op_flags |= OPf_PARENS;
1365 o = newOP(OP_STUB, 0);
1370 S_modkids(pTHX_ OP *o, I32 type)
1372 if (o && o->op_flags & OPf_KIDS) {
1374 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1380 /* Propagate lvalue ("modifiable") context to an op and its children.
1381 * 'type' represents the context type, roughly based on the type of op that
1382 * would do the modifying, although local() is represented by OP_NULL.
1383 * It's responsible for detecting things that can't be modified, flag
1384 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1385 * might have to vivify a reference in $x), and so on.
1387 * For example, "$a+1 = 2" would cause mod() to be called with o being
1388 * OP_ADD and type being OP_SASSIGN, and would output an error.
1392 Perl_mod(pTHX_ OP *o, I32 type)
1396 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1399 if (!o || (PL_parser && PL_parser->error_count))
1402 if ((o->op_private & OPpTARGET_MY)
1403 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1408 switch (o->op_type) {
1414 if (!(o->op_private & OPpCONST_ARYBASE))
1417 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1418 CopARYBASE_set(&PL_compiling,
1419 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1423 SAVECOPARYBASE(&PL_compiling);
1424 CopARYBASE_set(&PL_compiling, 0);
1426 else if (type == OP_REFGEN)
1429 Perl_croak(aTHX_ "That use of $[ is unsupported");
1432 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1436 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1437 !(o->op_flags & OPf_STACKED)) {
1438 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1439 /* The default is to set op_private to the number of children,
1440 which for a UNOP such as RV2CV is always 1. And w're using
1441 the bit for a flag in RV2CV, so we need it clear. */
1442 o->op_private &= ~1;
1443 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1444 assert(cUNOPo->op_first->op_type == OP_NULL);
1445 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1448 else if (o->op_private & OPpENTERSUB_NOMOD)
1450 else { /* lvalue subroutine call */
1451 o->op_private |= OPpLVAL_INTRO;
1452 PL_modcount = RETURN_UNLIMITED_NUMBER;
1453 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1454 /* Backward compatibility mode: */
1455 o->op_private |= OPpENTERSUB_INARGS;
1458 else { /* Compile-time error message: */
1459 OP *kid = cUNOPo->op_first;
1463 if (kid->op_type != OP_PUSHMARK) {
1464 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1466 "panic: unexpected lvalue entersub "
1467 "args: type/targ %ld:%"UVuf,
1468 (long)kid->op_type, (UV)kid->op_targ);
1469 kid = kLISTOP->op_first;
1471 while (kid->op_sibling)
1472 kid = kid->op_sibling;
1473 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1475 if (kid->op_type == OP_METHOD_NAMED
1476 || kid->op_type == OP_METHOD)
1480 NewOp(1101, newop, 1, UNOP);
1481 newop->op_type = OP_RV2CV;
1482 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1483 newop->op_first = NULL;
1484 newop->op_next = (OP*)newop;
1485 kid->op_sibling = (OP*)newop;
1486 newop->op_private |= OPpLVAL_INTRO;
1487 newop->op_private &= ~1;
1491 if (kid->op_type != OP_RV2CV)
1493 "panic: unexpected lvalue entersub "
1494 "entry via type/targ %ld:%"UVuf,
1495 (long)kid->op_type, (UV)kid->op_targ);
1496 kid->op_private |= OPpLVAL_INTRO;
1497 break; /* Postpone until runtime */
1501 kid = kUNOP->op_first;
1502 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1503 kid = kUNOP->op_first;
1504 if (kid->op_type == OP_NULL)
1506 "Unexpected constant lvalue entersub "
1507 "entry via type/targ %ld:%"UVuf,
1508 (long)kid->op_type, (UV)kid->op_targ);
1509 if (kid->op_type != OP_GV) {
1510 /* Restore RV2CV to check lvalueness */
1512 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1513 okid->op_next = kid->op_next;
1514 kid->op_next = okid;
1517 okid->op_next = NULL;
1518 okid->op_type = OP_RV2CV;
1520 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1521 okid->op_private |= OPpLVAL_INTRO;
1522 okid->op_private &= ~1;
1526 cv = GvCV(kGVOP_gv);
1536 /* grep, foreach, subcalls, refgen */
1537 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1539 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1540 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1542 : (o->op_type == OP_ENTERSUB
1543 ? "non-lvalue subroutine call"
1545 type ? PL_op_desc[type] : "local"));
1559 case OP_RIGHT_SHIFT:
1568 if (!(o->op_flags & OPf_STACKED))
1575 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1581 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1582 PL_modcount = RETURN_UNLIMITED_NUMBER;
1583 return o; /* Treat \(@foo) like ordinary list. */
1587 if (scalar_mod_type(o, type))
1589 ref(cUNOPo->op_first, o->op_type);
1593 if (type == OP_LEAVESUBLV)
1594 o->op_private |= OPpMAYBE_LVSUB;
1600 PL_modcount = RETURN_UNLIMITED_NUMBER;
1603 PL_hints |= HINT_BLOCK_SCOPE;
1604 if (type == OP_LEAVESUBLV)
1605 o->op_private |= OPpMAYBE_LVSUB;
1609 ref(cUNOPo->op_first, o->op_type);
1613 PL_hints |= HINT_BLOCK_SCOPE;
1628 PL_modcount = RETURN_UNLIMITED_NUMBER;
1629 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1630 return o; /* Treat \(@foo) like ordinary list. */
1631 if (scalar_mod_type(o, type))
1633 if (type == OP_LEAVESUBLV)
1634 o->op_private |= OPpMAYBE_LVSUB;
1638 if (!type) /* local() */
1639 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1640 PAD_COMPNAME_PV(o->op_targ));
1648 if (type != OP_SASSIGN)
1652 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1657 if (type == OP_LEAVESUBLV)
1658 o->op_private |= OPpMAYBE_LVSUB;
1660 pad_free(o->op_targ);
1661 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1662 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1663 if (o->op_flags & OPf_KIDS)
1664 mod(cBINOPo->op_first->op_sibling, type);
1669 ref(cBINOPo->op_first, o->op_type);
1670 if (type == OP_ENTERSUB &&
1671 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1672 o->op_private |= OPpLVAL_DEFER;
1673 if (type == OP_LEAVESUBLV)
1674 o->op_private |= OPpMAYBE_LVSUB;
1684 if (o->op_flags & OPf_KIDS)
1685 mod(cLISTOPo->op_last, type);
1690 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1692 else if (!(o->op_flags & OPf_KIDS))
1694 if (o->op_targ != OP_LIST) {
1695 mod(cBINOPo->op_first, type);
1701 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1706 if (type != OP_LEAVESUBLV)
1708 break; /* mod()ing was handled by ck_return() */
1711 /* [20011101.069] File test operators interpret OPf_REF to mean that
1712 their argument is a filehandle; thus \stat(".") should not set
1714 if (type == OP_REFGEN &&
1715 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1718 if (type != OP_LEAVESUBLV)
1719 o->op_flags |= OPf_MOD;
1721 if (type == OP_AASSIGN || type == OP_SASSIGN)
1722 o->op_flags |= OPf_SPECIAL|OPf_REF;
1723 else if (!type) { /* local() */
1726 o->op_private |= OPpLVAL_INTRO;
1727 o->op_flags &= ~OPf_SPECIAL;
1728 PL_hints |= HINT_BLOCK_SCOPE;
1733 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1734 "Useless localization of %s", OP_DESC(o));
1737 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1738 && type != OP_LEAVESUBLV)
1739 o->op_flags |= OPf_REF;
1744 S_scalar_mod_type(const OP *o, I32 type)
1746 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1750 if (o->op_type == OP_RV2GV)
1774 case OP_RIGHT_SHIFT:
1794 S_is_handle_constructor(const OP *o, I32 numargs)
1796 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1798 switch (o->op_type) {
1806 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1819 S_refkids(pTHX_ OP *o, I32 type)
1821 if (o && o->op_flags & OPf_KIDS) {
1823 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1830 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1835 PERL_ARGS_ASSERT_DOREF;
1837 if (!o || (PL_parser && PL_parser->error_count))
1840 switch (o->op_type) {
1842 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1843 !(o->op_flags & OPf_STACKED)) {
1844 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1845 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1846 assert(cUNOPo->op_first->op_type == OP_NULL);
1847 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1848 o->op_flags |= OPf_SPECIAL;
1849 o->op_private &= ~1;
1854 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1855 doref(kid, type, set_op_ref);
1858 if (type == OP_DEFINED)
1859 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1860 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1863 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1864 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1865 : type == OP_RV2HV ? OPpDEREF_HV
1867 o->op_flags |= OPf_MOD;
1874 o->op_flags |= OPf_REF;
1877 if (type == OP_DEFINED)
1878 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1879 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1885 o->op_flags |= OPf_REF;
1890 if (!(o->op_flags & OPf_KIDS))
1892 doref(cBINOPo->op_first, type, set_op_ref);
1896 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1897 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1898 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1899 : type == OP_RV2HV ? OPpDEREF_HV
1901 o->op_flags |= OPf_MOD;
1911 if (!(o->op_flags & OPf_KIDS))
1913 doref(cLISTOPo->op_last, type, set_op_ref);
1923 S_dup_attrlist(pTHX_ OP *o)
1928 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1930 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1931 * where the first kid is OP_PUSHMARK and the remaining ones
1932 * are OP_CONST. We need to push the OP_CONST values.
1934 if (o->op_type == OP_CONST)
1935 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1937 else if (o->op_type == OP_NULL)
1941 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1943 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1944 if (o->op_type == OP_CONST)
1945 rop = append_elem(OP_LIST, rop,
1946 newSVOP(OP_CONST, o->op_flags,
1947 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1954 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1959 PERL_ARGS_ASSERT_APPLY_ATTRS;
1961 /* fake up C<use attributes $pkg,$rv,@attrs> */
1962 ENTER; /* need to protect against side-effects of 'use' */
1963 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1965 #define ATTRSMODULE "attributes"
1966 #define ATTRSMODULE_PM "attributes.pm"
1969 /* Don't force the C<use> if we don't need it. */
1970 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1971 if (svp && *svp != &PL_sv_undef)
1972 NOOP; /* already in %INC */
1974 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1975 newSVpvs(ATTRSMODULE), NULL);
1978 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1979 newSVpvs(ATTRSMODULE),
1981 prepend_elem(OP_LIST,
1982 newSVOP(OP_CONST, 0, stashsv),
1983 prepend_elem(OP_LIST,
1984 newSVOP(OP_CONST, 0,
1986 dup_attrlist(attrs))));
1992 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1995 OP *pack, *imop, *arg;
1998 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2003 assert(target->op_type == OP_PADSV ||
2004 target->op_type == OP_PADHV ||
2005 target->op_type == OP_PADAV);
2007 /* Ensure that attributes.pm is loaded. */
2008 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2010 /* Need package name for method call. */
2011 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2013 /* Build up the real arg-list. */
2014 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2016 arg = newOP(OP_PADSV, 0);
2017 arg->op_targ = target->op_targ;
2018 arg = prepend_elem(OP_LIST,
2019 newSVOP(OP_CONST, 0, stashsv),
2020 prepend_elem(OP_LIST,
2021 newUNOP(OP_REFGEN, 0,
2022 mod(arg, OP_REFGEN)),
2023 dup_attrlist(attrs)));
2025 /* Fake up a method call to import */
2026 meth = newSVpvs_share("import");
2027 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2028 append_elem(OP_LIST,
2029 prepend_elem(OP_LIST, pack, list(arg)),
2030 newSVOP(OP_METHOD_NAMED, 0, meth)));
2031 imop->op_private |= OPpENTERSUB_NOMOD;
2033 /* Combine the ops. */
2034 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2038 =notfor apidoc apply_attrs_string
2040 Attempts to apply a list of attributes specified by the C<attrstr> and
2041 C<len> arguments to the subroutine identified by the C<cv> argument which
2042 is expected to be associated with the package identified by the C<stashpv>
2043 argument (see L<attributes>). It gets this wrong, though, in that it
2044 does not correctly identify the boundaries of the individual attribute
2045 specifications within C<attrstr>. This is not really intended for the
2046 public API, but has to be listed here for systems such as AIX which
2047 need an explicit export list for symbols. (It's called from XS code
2048 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2049 to respect attribute syntax properly would be welcome.
2055 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2056 const char *attrstr, STRLEN len)
2060 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2063 len = strlen(attrstr);
2067 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2069 const char * const sstr = attrstr;
2070 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2071 attrs = append_elem(OP_LIST, attrs,
2072 newSVOP(OP_CONST, 0,
2073 newSVpvn(sstr, attrstr-sstr)));
2077 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2078 newSVpvs(ATTRSMODULE),
2079 NULL, prepend_elem(OP_LIST,
2080 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2081 prepend_elem(OP_LIST,
2082 newSVOP(OP_CONST, 0,
2083 newRV(MUTABLE_SV(cv))),
2088 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2093 PERL_ARGS_ASSERT_MY_KID;
2095 if (!o || (PL_parser && PL_parser->error_count))
2099 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2100 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2104 if (type == OP_LIST) {
2106 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2107 my_kid(kid, attrs, imopsp);
2108 } else if (type == OP_UNDEF
2114 } else if (type == OP_RV2SV || /* "our" declaration */
2116 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2117 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2118 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2120 PL_parser->in_my == KEY_our
2122 : PL_parser->in_my == KEY_state ? "state" : "my"));
2124 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2125 PL_parser->in_my = FALSE;
2126 PL_parser->in_my_stash = NULL;
2127 apply_attrs(GvSTASH(gv),
2128 (type == OP_RV2SV ? GvSV(gv) :
2129 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2130 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2133 o->op_private |= OPpOUR_INTRO;
2136 else if (type != OP_PADSV &&
2139 type != OP_PUSHMARK)
2141 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2143 PL_parser->in_my == KEY_our
2145 : PL_parser->in_my == KEY_state ? "state" : "my"));
2148 else if (attrs && type != OP_PUSHMARK) {
2151 PL_parser->in_my = FALSE;
2152 PL_parser->in_my_stash = NULL;
2154 /* check for C<my Dog $spot> when deciding package */
2155 stash = PAD_COMPNAME_TYPE(o->op_targ);
2157 stash = PL_curstash;
2158 apply_attrs_my(stash, o, attrs, imopsp);
2160 o->op_flags |= OPf_MOD;
2161 o->op_private |= OPpLVAL_INTRO;
2162 if (PL_parser->in_my == KEY_state)
2163 o->op_private |= OPpPAD_STATE;
2168 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2172 int maybe_scalar = 0;
2174 PERL_ARGS_ASSERT_MY_ATTRS;
2176 /* [perl #17376]: this appears to be premature, and results in code such as
2177 C< our(%x); > executing in list mode rather than void mode */
2179 if (o->op_flags & OPf_PARENS)
2189 o = my_kid(o, attrs, &rops);
2191 if (maybe_scalar && o->op_type == OP_PADSV) {
2192 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2193 o->op_private |= OPpLVAL_INTRO;
2196 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2198 PL_parser->in_my = FALSE;
2199 PL_parser->in_my_stash = NULL;
2204 Perl_sawparens(pTHX_ OP *o)
2206 PERL_UNUSED_CONTEXT;
2208 o->op_flags |= OPf_PARENS;
2213 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2217 const OPCODE ltype = left->op_type;
2218 const OPCODE rtype = right->op_type;
2220 PERL_ARGS_ASSERT_BIND_MATCH;
2222 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2223 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2225 const char * const desc
2226 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2227 ? (int)rtype : OP_MATCH];
2228 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2229 ? "@array" : "%hash");
2230 Perl_warner(aTHX_ packWARN(WARN_MISC),
2231 "Applying %s to %s will act on scalar(%s)",
2232 desc, sample, sample);
2235 if (rtype == OP_CONST &&
2236 cSVOPx(right)->op_private & OPpCONST_BARE &&
2237 cSVOPx(right)->op_private & OPpCONST_STRICT)
2239 no_bareword_allowed(right);
2242 /* !~ doesn't make sense with s///r, so error on it for now */
2243 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2245 yyerror("Using !~ with s///r doesn't make sense");
2247 ismatchop = rtype == OP_MATCH ||
2248 rtype == OP_SUBST ||
2250 if (ismatchop && right->op_private & OPpTARGET_MY) {
2252 right->op_private &= ~OPpTARGET_MY;
2254 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2257 right->op_flags |= OPf_STACKED;
2258 if (rtype != OP_MATCH &&
2259 ! (rtype == OP_TRANS &&
2260 right->op_private & OPpTRANS_IDENTICAL) &&
2261 ! (rtype == OP_SUBST &&
2262 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2263 newleft = mod(left, rtype);
2266 if (right->op_type == OP_TRANS)
2267 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2269 o = prepend_elem(rtype, scalar(newleft), right);
2271 return newUNOP(OP_NOT, 0, scalar(o));
2275 return bind_match(type, left,
2276 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2280 Perl_invert(pTHX_ OP *o)
2284 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2288 Perl_scope(pTHX_ OP *o)
2292 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2293 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2294 o->op_type = OP_LEAVE;
2295 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2297 else if (o->op_type == OP_LINESEQ) {
2299 o->op_type = OP_SCOPE;
2300 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2301 kid = ((LISTOP*)o)->op_first;
2302 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2305 /* The following deals with things like 'do {1 for 1}' */
2306 kid = kid->op_sibling;
2308 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2313 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2319 Perl_block_start(pTHX_ int full)
2322 const int retval = PL_savestack_ix;
2324 pad_block_start(full);
2326 PL_hints &= ~HINT_BLOCK_SCOPE;
2327 SAVECOMPILEWARNINGS();
2328 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2330 CALL_BLOCK_HOOKS(start, full);
2336 Perl_block_end(pTHX_ I32 floor, OP *seq)
2339 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2340 OP* retval = scalarseq(seq);
2342 CALL_BLOCK_HOOKS(pre_end, &retval);
2345 CopHINTS_set(&PL_compiling, PL_hints);
2347 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2350 CALL_BLOCK_HOOKS(post_end, &retval);
2356 =head1 Compile-time scope hooks
2358 =for apidoc Ao||blockhook_register
2360 Register a set of hooks to be called when the Perl lexical scope changes
2361 at compile time. See L<perlguts/"Compile-time scope hooks">.
2367 Perl_blockhook_register(pTHX_ BHK *hk)
2369 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2371 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2378 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2379 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2380 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2383 OP * const o = newOP(OP_PADSV, 0);
2384 o->op_targ = offset;
2390 Perl_newPROG(pTHX_ OP *o)
2394 PERL_ARGS_ASSERT_NEWPROG;
2399 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2400 ((PL_in_eval & EVAL_KEEPERR)
2401 ? OPf_SPECIAL : 0), o);
2402 PL_eval_start = linklist(PL_eval_root);
2403 PL_eval_root->op_private |= OPpREFCOUNTED;
2404 OpREFCNT_set(PL_eval_root, 1);
2405 PL_eval_root->op_next = 0;
2406 CALL_PEEP(PL_eval_start);
2409 if (o->op_type == OP_STUB) {
2410 PL_comppad_name = 0;
2412 S_op_destroy(aTHX_ o);
2415 PL_main_root = scope(sawparens(scalarvoid(o)));
2416 PL_curcop = &PL_compiling;
2417 PL_main_start = LINKLIST(PL_main_root);
2418 PL_main_root->op_private |= OPpREFCOUNTED;
2419 OpREFCNT_set(PL_main_root, 1);
2420 PL_main_root->op_next = 0;
2421 CALL_PEEP(PL_main_start);
2424 /* Register with debugger */
2426 CV * const cv = get_cvs("DB::postponed", 0);
2430 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2432 call_sv(MUTABLE_SV(cv), G_DISCARD);
2439 Perl_localize(pTHX_ OP *o, I32 lex)
2443 PERL_ARGS_ASSERT_LOCALIZE;
2445 if (o->op_flags & OPf_PARENS)
2446 /* [perl #17376]: this appears to be premature, and results in code such as
2447 C< our(%x); > executing in list mode rather than void mode */
2454 if ( PL_parser->bufptr > PL_parser->oldbufptr
2455 && PL_parser->bufptr[-1] == ','
2456 && ckWARN(WARN_PARENTHESIS))
2458 char *s = PL_parser->bufptr;
2461 /* some heuristics to detect a potential error */
2462 while (*s && (strchr(", \t\n", *s)))
2466 if (*s && strchr("@$%*", *s) && *++s
2467 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2470 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2472 while (*s && (strchr(", \t\n", *s)))
2478 if (sigil && (*s == ';' || *s == '=')) {
2479 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2480 "Parentheses missing around \"%s\" list",
2482 ? (PL_parser->in_my == KEY_our
2484 : PL_parser->in_my == KEY_state
2494 o = mod(o, OP_NULL); /* a bit kludgey */
2495 PL_parser->in_my = FALSE;
2496 PL_parser->in_my_stash = NULL;
2501 Perl_jmaybe(pTHX_ OP *o)
2503 PERL_ARGS_ASSERT_JMAYBE;
2505 if (o->op_type == OP_LIST) {
2507 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2508 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2514 S_fold_constants(pTHX_ register OP *o)
2517 register OP * VOL curop;
2519 VOL I32 type = o->op_type;
2524 SV * const oldwarnhook = PL_warnhook;
2525 SV * const olddiehook = PL_diehook;
2529 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2531 if (PL_opargs[type] & OA_RETSCALAR)
2533 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2534 o->op_targ = pad_alloc(type, SVs_PADTMP);
2536 /* integerize op, unless it happens to be C<-foo>.
2537 * XXX should pp_i_negate() do magic string negation instead? */
2538 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2539 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2540 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2542 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2545 if (!(PL_opargs[type] & OA_FOLDCONST))
2550 /* XXX might want a ck_negate() for this */
2551 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2562 /* XXX what about the numeric ops? */
2563 if (PL_hints & HINT_LOCALE)
2568 if (PL_parser && PL_parser->error_count)
2569 goto nope; /* Don't try to run w/ errors */
2571 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2572 const OPCODE type = curop->op_type;
2573 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2575 type != OP_SCALAR &&
2577 type != OP_PUSHMARK)
2583 curop = LINKLIST(o);
2584 old_next = o->op_next;
2588 oldscope = PL_scopestack_ix;
2589 create_eval_scope(G_FAKINGEVAL);
2591 /* Verify that we don't need to save it: */
2592 assert(PL_curcop == &PL_compiling);
2593 StructCopy(&PL_compiling, ¬_compiling, COP);
2594 PL_curcop = ¬_compiling;
2595 /* The above ensures that we run with all the correct hints of the
2596 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2597 assert(IN_PERL_RUNTIME);
2598 PL_warnhook = PERL_WARNHOOK_FATAL;
2605 sv = *(PL_stack_sp--);
2606 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2607 pad_swipe(o->op_targ, FALSE);
2608 else if (SvTEMP(sv)) { /* grab mortal temp? */
2609 SvREFCNT_inc_simple_void(sv);
2614 /* Something tried to die. Abandon constant folding. */
2615 /* Pretend the error never happened. */
2617 o->op_next = old_next;
2621 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2622 PL_warnhook = oldwarnhook;
2623 PL_diehook = olddiehook;
2624 /* XXX note that this croak may fail as we've already blown away
2625 * the stack - eg any nested evals */
2626 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2629 PL_warnhook = oldwarnhook;
2630 PL_diehook = olddiehook;
2631 PL_curcop = &PL_compiling;
2633 if (PL_scopestack_ix > oldscope)
2634 delete_eval_scope();
2643 if (type == OP_RV2GV)
2644 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2646 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2647 op_getmad(o,newop,'f');
2655 S_gen_constant_list(pTHX_ register OP *o)
2659 const I32 oldtmps_floor = PL_tmps_floor;
2662 if (PL_parser && PL_parser->error_count)
2663 return o; /* Don't attempt to run with errors */
2665 PL_op = curop = LINKLIST(o);
2671 assert (!(curop->op_flags & OPf_SPECIAL));
2672 assert(curop->op_type == OP_RANGE);
2674 PL_tmps_floor = oldtmps_floor;
2676 o->op_type = OP_RV2AV;
2677 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2678 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2679 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2680 o->op_opt = 0; /* needs to be revisited in peep() */
2681 curop = ((UNOP*)o)->op_first;
2682 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2684 op_getmad(curop,o,'O');
2693 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2696 if (!o || o->op_type != OP_LIST)
2697 o = newLISTOP(OP_LIST, 0, o, NULL);
2699 o->op_flags &= ~OPf_WANT;
2701 if (!(PL_opargs[type] & OA_MARK))
2702 op_null(cLISTOPo->op_first);
2704 o->op_type = (OPCODE)type;
2705 o->op_ppaddr = PL_ppaddr[type];
2706 o->op_flags |= flags;
2708 o = CHECKOP(type, o);
2709 if (o->op_type != (unsigned)type)
2712 return fold_constants(o);
2715 /* List constructors */
2718 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2726 if (first->op_type != (unsigned)type
2727 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2729 return newLISTOP(type, 0, first, last);
2732 if (first->op_flags & OPf_KIDS)
2733 ((LISTOP*)first)->op_last->op_sibling = last;
2735 first->op_flags |= OPf_KIDS;
2736 ((LISTOP*)first)->op_first = last;
2738 ((LISTOP*)first)->op_last = last;
2743 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2751 if (first->op_type != (unsigned)type)
2752 return prepend_elem(type, (OP*)first, (OP*)last);
2754 if (last->op_type != (unsigned)type)
2755 return append_elem(type, (OP*)first, (OP*)last);
2757 first->op_last->op_sibling = last->op_first;
2758 first->op_last = last->op_last;
2759 first->op_flags |= (last->op_flags & OPf_KIDS);
2762 if (last->op_first && first->op_madprop) {
2763 MADPROP *mp = last->op_first->op_madprop;
2765 while (mp->mad_next)
2767 mp->mad_next = first->op_madprop;
2770 last->op_first->op_madprop = first->op_madprop;
2773 first->op_madprop = last->op_madprop;
2774 last->op_madprop = 0;
2777 S_op_destroy(aTHX_ (OP*)last);
2783 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2791 if (last->op_type == (unsigned)type) {
2792 if (type == OP_LIST) { /* already a PUSHMARK there */
2793 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2794 ((LISTOP*)last)->op_first->op_sibling = first;
2795 if (!(first->op_flags & OPf_PARENS))
2796 last->op_flags &= ~OPf_PARENS;
2799 if (!(last->op_flags & OPf_KIDS)) {
2800 ((LISTOP*)last)->op_last = first;
2801 last->op_flags |= OPf_KIDS;
2803 first->op_sibling = ((LISTOP*)last)->op_first;
2804 ((LISTOP*)last)->op_first = first;
2806 last->op_flags |= OPf_KIDS;
2810 return newLISTOP(type, 0, first, last);
2818 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2821 Newxz(tk, 1, TOKEN);
2822 tk->tk_type = (OPCODE)optype;
2823 tk->tk_type = 12345;
2825 tk->tk_mad = madprop;
2830 Perl_token_free(pTHX_ TOKEN* tk)
2832 PERL_ARGS_ASSERT_TOKEN_FREE;
2834 if (tk->tk_type != 12345)
2836 mad_free(tk->tk_mad);
2841 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2846 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2848 if (tk->tk_type != 12345) {
2849 Perl_warner(aTHX_ packWARN(WARN_MISC),
2850 "Invalid TOKEN object ignored");
2857 /* faked up qw list? */
2859 tm->mad_type == MAD_SV &&
2860 SvPVX((SV *)tm->mad_val)[0] == 'q')
2867 /* pretend constant fold didn't happen? */
2868 if (mp->mad_key == 'f' &&
2869 (o->op_type == OP_CONST ||
2870 o->op_type == OP_GV) )
2872 token_getmad(tk,(OP*)mp->mad_val,slot);
2886 if (mp->mad_key == 'X')
2887 mp->mad_key = slot; /* just change the first one */
2897 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2906 /* pretend constant fold didn't happen? */
2907 if (mp->mad_key == 'f' &&
2908 (o->op_type == OP_CONST ||
2909 o->op_type == OP_GV) )
2911 op_getmad(from,(OP*)mp->mad_val,slot);
2918 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2921 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2927 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2936 /* pretend constant fold didn't happen? */
2937 if (mp->mad_key == 'f' &&
2938 (o->op_type == OP_CONST ||
2939 o->op_type == OP_GV) )
2941 op_getmad(from,(OP*)mp->mad_val,slot);
2948 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2951 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2955 PerlIO_printf(PerlIO_stderr(),
2956 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2962 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2980 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2984 addmad(tm, &(o->op_madprop), slot);
2988 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3009 Perl_newMADsv(pTHX_ char key, SV* sv)
3011 PERL_ARGS_ASSERT_NEWMADSV;
3013 return newMADPROP(key, MAD_SV, sv, 0);
3017 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3020 Newxz(mp, 1, MADPROP);
3023 mp->mad_vlen = vlen;
3024 mp->mad_type = type;
3026 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3031 Perl_mad_free(pTHX_ MADPROP* mp)
3033 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3037 mad_free(mp->mad_next);
3038 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3039 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3040 switch (mp->mad_type) {
3044 Safefree((char*)mp->mad_val);
3047 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3048 op_free((OP*)mp->mad_val);
3051 sv_free(MUTABLE_SV(mp->mad_val));
3054 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3063 Perl_newNULLLIST(pTHX)
3065 return newOP(OP_STUB, 0);
3069 S_force_list(pTHX_ OP *o)
3071 if (!o || o->op_type != OP_LIST)
3072 o = newLISTOP(OP_LIST, 0, o, NULL);
3078 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3083 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3085 NewOp(1101, listop, 1, LISTOP);
3087 listop->op_type = (OPCODE)type;
3088 listop->op_ppaddr = PL_ppaddr[type];
3091 listop->op_flags = (U8)flags;
3095 else if (!first && last)
3098 first->op_sibling = last;
3099 listop->op_first = first;
3100 listop->op_last = last;
3101 if (type == OP_LIST) {
3102 OP* const pushop = newOP(OP_PUSHMARK, 0);
3103 pushop->op_sibling = first;
3104 listop->op_first = pushop;
3105 listop->op_flags |= OPf_KIDS;
3107 listop->op_last = pushop;
3110 return CHECKOP(type, listop);
3114 Perl_newOP(pTHX_ I32 type, I32 flags)
3119 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3120 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3121 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3122 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3124 NewOp(1101, o, 1, OP);
3125 o->op_type = (OPCODE)type;
3126 o->op_ppaddr = PL_ppaddr[type];
3127 o->op_flags = (U8)flags;
3129 o->op_latefreed = 0;
3133 o->op_private = (U8)(0 | (flags >> 8));
3134 if (PL_opargs[type] & OA_RETSCALAR)
3136 if (PL_opargs[type] & OA_TARGET)
3137 o->op_targ = pad_alloc(type, SVs_PADTMP);
3138 return CHECKOP(type, o);
3142 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3147 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3148 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3149 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3150 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3151 || type == OP_SASSIGN
3152 || type == OP_ENTERTRY
3153 || type == OP_NULL );
3156 first = newOP(OP_STUB, 0);
3157 if (PL_opargs[type] & OA_MARK)
3158 first = force_list(first);
3160 NewOp(1101, unop, 1, UNOP);
3161 unop->op_type = (OPCODE)type;
3162 unop->op_ppaddr = PL_ppaddr[type];
3163 unop->op_first = first;
3164 unop->op_flags = (U8)(flags | OPf_KIDS);
3165 unop->op_private = (U8)(1 | (flags >> 8));
3166 unop = (UNOP*) CHECKOP(type, unop);
3170 return fold_constants((OP *) unop);
3174 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3179 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3180 || type == OP_SASSIGN || type == OP_NULL );
3182 NewOp(1101, binop, 1, BINOP);
3185 first = newOP(OP_NULL, 0);
3187 binop->op_type = (OPCODE)type;
3188 binop->op_ppaddr = PL_ppaddr[type];
3189 binop->op_first = first;
3190 binop->op_flags = (U8)(flags | OPf_KIDS);
3193 binop->op_private = (U8)(1 | (flags >> 8));
3196 binop->op_private = (U8)(2 | (flags >> 8));
3197 first->op_sibling = last;
3200 binop = (BINOP*)CHECKOP(type, binop);
3201 if (binop->op_next || binop->op_type != (OPCODE)type)
3204 binop->op_last = binop->op_first->op_sibling;
3206 return fold_constants((OP *)binop);
3209 static int uvcompare(const void *a, const void *b)
3210 __attribute__nonnull__(1)
3211 __attribute__nonnull__(2)
3212 __attribute__pure__;
3213 static int uvcompare(const void *a, const void *b)
3215 if (*((const UV *)a) < (*(const UV *)b))
3217 if (*((const UV *)a) > (*(const UV *)b))
3219 if (*((const UV *)a+1) < (*(const UV *)b+1))
3221 if (*((const UV *)a+1) > (*(const UV *)b+1))
3227 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3230 SV * const tstr = ((SVOP*)expr)->op_sv;
3233 (repl->op_type == OP_NULL)
3234 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3236 ((SVOP*)repl)->op_sv;
3239 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3240 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3244 register short *tbl;
3246 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3247 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3248 I32 del = o->op_private & OPpTRANS_DELETE;
3251 PERL_ARGS_ASSERT_PMTRANS;
3253 PL_hints |= HINT_BLOCK_SCOPE;
3256 o->op_private |= OPpTRANS_FROM_UTF;
3259 o->op_private |= OPpTRANS_TO_UTF;
3261 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3262 SV* const listsv = newSVpvs("# comment\n");
3264 const U8* tend = t + tlen;
3265 const U8* rend = r + rlen;
3279 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3280 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3283 const U32 flags = UTF8_ALLOW_DEFAULT;
3287 t = tsave = bytes_to_utf8(t, &len);
3290 if (!to_utf && rlen) {
3292 r = rsave = bytes_to_utf8(r, &len);
3296 /* There are several snags with this code on EBCDIC:
3297 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3298 2. scan_const() in toke.c has encoded chars in native encoding which makes
3299 ranges at least in EBCDIC 0..255 range the bottom odd.
3303 U8 tmpbuf[UTF8_MAXBYTES+1];
3306 Newx(cp, 2*tlen, UV);
3308 transv = newSVpvs("");
3310 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3312 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3314 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3318 cp[2*i+1] = cp[2*i];
3322 qsort(cp, i, 2*sizeof(UV), uvcompare);
3323 for (j = 0; j < i; j++) {
3325 diff = val - nextmin;
3327 t = uvuni_to_utf8(tmpbuf,nextmin);
3328 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3330 U8 range_mark = UTF_TO_NATIVE(0xff);
3331 t = uvuni_to_utf8(tmpbuf, val - 1);
3332 sv_catpvn(transv, (char *)&range_mark, 1);
3333 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3340 t = uvuni_to_utf8(tmpbuf,nextmin);
3341 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3343 U8 range_mark = UTF_TO_NATIVE(0xff);
3344 sv_catpvn(transv, (char *)&range_mark, 1);
3346 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3347 UNICODE_ALLOW_SUPER);
3348 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3349 t = (const U8*)SvPVX_const(transv);
3350 tlen = SvCUR(transv);
3354 else if (!rlen && !del) {
3355 r = t; rlen = tlen; rend = tend;
3358 if ((!rlen && !del) || t == r ||
3359 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3361 o->op_private |= OPpTRANS_IDENTICAL;
3365 while (t < tend || tfirst <= tlast) {
3366 /* see if we need more "t" chars */
3367 if (tfirst > tlast) {
3368 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3370 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3372 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3379 /* now see if we need more "r" chars */
3380 if (rfirst > rlast) {
3382 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3384 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3386 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3395 rfirst = rlast = 0xffffffff;
3399 /* now see which range will peter our first, if either. */
3400 tdiff = tlast - tfirst;
3401 rdiff = rlast - rfirst;
3408 if (rfirst == 0xffffffff) {
3409 diff = tdiff; /* oops, pretend rdiff is infinite */
3411 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3412 (long)tfirst, (long)tlast);
3414 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3418 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3419 (long)tfirst, (long)(tfirst + diff),
3422 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3423 (long)tfirst, (long)rfirst);
3425 if (rfirst + diff > max)
3426 max = rfirst + diff;
3428 grows = (tfirst < rfirst &&
3429 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3441 else if (max > 0xff)
3446 PerlMemShared_free(cPVOPo->op_pv);
3447 cPVOPo->op_pv = NULL;
3449 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3451 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3452 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3453 PAD_SETSV(cPADOPo->op_padix, swash);
3455 SvREADONLY_on(swash);
3457 cSVOPo->op_sv = swash;
3459 SvREFCNT_dec(listsv);
3460 SvREFCNT_dec(transv);
3462 if (!del && havefinal && rlen)
3463 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3464 newSVuv((UV)final), 0);
3467 o->op_private |= OPpTRANS_GROWS;
3473 op_getmad(expr,o,'e');
3474 op_getmad(repl,o,'r');
3482 tbl = (short*)cPVOPo->op_pv;
3484 Zero(tbl, 256, short);
3485 for (i = 0; i < (I32)tlen; i++)
3487 for (i = 0, j = 0; i < 256; i++) {
3489 if (j >= (I32)rlen) {
3498 if (i < 128 && r[j] >= 128)
3508 o->op_private |= OPpTRANS_IDENTICAL;
3510 else if (j >= (I32)rlen)
3515 PerlMemShared_realloc(tbl,
3516 (0x101+rlen-j) * sizeof(short));
3517 cPVOPo->op_pv = (char*)tbl;
3519 tbl[0x100] = (short)(rlen - j);
3520 for (i=0; i < (I32)rlen - j; i++)
3521 tbl[0x101+i] = r[j+i];
3525 if (!rlen && !del) {
3528 o->op_private |= OPpTRANS_IDENTICAL;
3530 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3531 o->op_private |= OPpTRANS_IDENTICAL;
3533 for (i = 0; i < 256; i++)
3535 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3536 if (j >= (I32)rlen) {
3538 if (tbl[t[i]] == -1)
3544 if (tbl[t[i]] == -1) {
3545 if (t[i] < 128 && r[j] >= 128)
3552 if(del && rlen == tlen) {
3553 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3554 } else if(rlen > tlen) {
3555 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3559 o->op_private |= OPpTRANS_GROWS;
3561 op_getmad(expr,o,'e');
3562 op_getmad(repl,o,'r');
3572 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3577 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3579 NewOp(1101, pmop, 1, PMOP);
3580 pmop->op_type = (OPCODE)type;
3581 pmop->op_ppaddr = PL_ppaddr[type];
3582 pmop->op_flags = (U8)flags;
3583 pmop->op_private = (U8)(0 | (flags >> 8));
3585 if (PL_hints & HINT_RE_TAINT)
3586 pmop->op_pmflags |= PMf_RETAINT;
3587 if (PL_hints & HINT_LOCALE)
3588 pmop->op_pmflags |= PMf_LOCALE;
3592 assert(SvPOK(PL_regex_pad[0]));
3593 if (SvCUR(PL_regex_pad[0])) {
3594 /* Pop off the "packed" IV from the end. */
3595 SV *const repointer_list = PL_regex_pad[0];
3596 const char *p = SvEND(repointer_list) - sizeof(IV);
3597 const IV offset = *((IV*)p);
3599 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3601 SvEND_set(repointer_list, p);
3603 pmop->op_pmoffset = offset;
3604 /* This slot should be free, so assert this: */
3605 assert(PL_regex_pad[offset] == &PL_sv_undef);
3607 SV * const repointer = &PL_sv_undef;
3608 av_push(PL_regex_padav, repointer);
3609 pmop->op_pmoffset = av_len(PL_regex_padav);
3610 PL_regex_pad = AvARRAY(PL_regex_padav);
3614 return CHECKOP(type, pmop);
3617 /* Given some sort of match op o, and an expression expr containing a
3618 * pattern, either compile expr into a regex and attach it to o (if it's
3619 * constant), or convert expr into a runtime regcomp op sequence (if it's
3622 * isreg indicates that the pattern is part of a regex construct, eg
3623 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3624 * split "pattern", which aren't. In the former case, expr will be a list
3625 * if the pattern contains more than one term (eg /a$b/) or if it contains
3626 * a replacement, ie s/// or tr///.
3630 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3635 I32 repl_has_vars = 0;
3639 PERL_ARGS_ASSERT_PMRUNTIME;
3641 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3642 /* last element in list is the replacement; pop it */
3644 repl = cLISTOPx(expr)->op_last;
3645 kid = cLISTOPx(expr)->op_first;
3646 while (kid->op_sibling != repl)
3647 kid = kid->op_sibling;
3648 kid->op_sibling = NULL;
3649 cLISTOPx(expr)->op_last = kid;
3652 if (isreg && expr->op_type == OP_LIST &&
3653 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3655 /* convert single element list to element */
3656 OP* const oe = expr;
3657 expr = cLISTOPx(oe)->op_first->op_sibling;
3658 cLISTOPx(oe)->op_first->op_sibling = NULL;
3659 cLISTOPx(oe)->op_last = NULL;
3663 if (o->op_type == OP_TRANS) {
3664 return pmtrans(o, expr, repl);
3667 reglist = isreg && expr->op_type == OP_LIST;
3671 PL_hints |= HINT_BLOCK_SCOPE;
3674 if (expr->op_type == OP_CONST) {
3675 SV *pat = ((SVOP*)expr)->op_sv;
3676 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3678 if (o->op_flags & OPf_SPECIAL)
3679 pm_flags |= RXf_SPLIT;
3682 assert (SvUTF8(pat));
3683 } else if (SvUTF8(pat)) {
3684 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3685 trapped in use 'bytes'? */
3686 /* Make a copy of the octet sequence, but without the flag on, as
3687 the compiler now honours the SvUTF8 flag on pat. */
3689 const char *const p = SvPV(pat, len);
3690 pat = newSVpvn_flags(p, len, SVs_TEMP);
3693 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3696 op_getmad(expr,(OP*)pm,'e');
3702 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3703 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3705 : OP_REGCMAYBE),0,expr);
3707 NewOp(1101, rcop, 1, LOGOP);
3708 rcop->op_type = OP_REGCOMP;
3709 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3710 rcop->op_first = scalar(expr);
3711 rcop->op_flags |= OPf_KIDS
3712 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3713 | (reglist ? OPf_STACKED : 0);
3714 rcop->op_private = 1;
3717 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3719 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3722 /* establish postfix order */
3723 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3725 rcop->op_next = expr;
3726 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3729 rcop->op_next = LINKLIST(expr);
3730 expr->op_next = (OP*)rcop;
3733 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3738 if (pm->op_pmflags & PMf_EVAL) {
3740 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3741 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3743 else if (repl->op_type == OP_CONST)
3747 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3748 if (curop->op_type == OP_SCOPE
3749 || curop->op_type == OP_LEAVE
3750 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3751 if (curop->op_type == OP_GV) {
3752 GV * const gv = cGVOPx_gv(curop);
3754 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3757 else if (curop->op_type == OP_RV2CV)
3759 else if (curop->op_type == OP_RV2SV ||
3760 curop->op_type == OP_RV2AV ||
3761 curop->op_type == OP_RV2HV ||
3762 curop->op_type == OP_RV2GV) {
3763 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3766 else if (curop->op_type == OP_PADSV ||
3767 curop->op_type == OP_PADAV ||
3768 curop->op_type == OP_PADHV ||
3769 curop->op_type == OP_PADANY)
3773 else if (curop->op_type == OP_PUSHRE)
3774 NOOP; /* Okay here, dangerous in newASSIGNOP */
3784 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3786 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3787 prepend_elem(o->op_type, scalar(repl), o);
3790 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3791 pm->op_pmflags |= PMf_MAYBE_CONST;
3793 NewOp(1101, rcop, 1, LOGOP);
3794 rcop->op_type = OP_SUBSTCONT;
3795 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3796 rcop->op_first = scalar(repl);
3797 rcop->op_flags |= OPf_KIDS;
3798 rcop->op_private = 1;
3801 /* establish postfix order */
3802 rcop->op_next = LINKLIST(repl);
3803 repl->op_next = (OP*)rcop;
3805 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3806 assert(!(pm->op_pmflags & PMf_ONCE));
3807 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3816 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3821 PERL_ARGS_ASSERT_NEWSVOP;
3823 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3824 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3825 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3827 NewOp(1101, svop, 1, SVOP);
3828 svop->op_type = (OPCODE)type;
3829 svop->op_ppaddr = PL_ppaddr[type];
3831 svop->op_next = (OP*)svop;
3832 svop->op_flags = (U8)flags;
3833 if (PL_opargs[type] & OA_RETSCALAR)
3835 if (PL_opargs[type] & OA_TARGET)
3836 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3837 return CHECKOP(type, svop);
3842 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3847 PERL_ARGS_ASSERT_NEWPADOP;
3849 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3850 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3851 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3853 NewOp(1101, padop, 1, PADOP);
3854 padop->op_type = (OPCODE)type;
3855 padop->op_ppaddr = PL_ppaddr[type];
3856 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3857 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3858 PAD_SETSV(padop->op_padix, sv);
3861 padop->op_next = (OP*)padop;
3862 padop->op_flags = (U8)flags;
3863 if (PL_opargs[type] & OA_RETSCALAR)
3865 if (PL_opargs[type] & OA_TARGET)
3866 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3867 return CHECKOP(type, padop);
3872 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3876 PERL_ARGS_ASSERT_NEWGVOP;
3880 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3882 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3887 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3892 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3893 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3895 NewOp(1101, pvop, 1, PVOP);
3896 pvop->op_type = (OPCODE)type;
3897 pvop->op_ppaddr = PL_ppaddr[type];
3899 pvop->op_next = (OP*)pvop;
3900 pvop->op_flags = (U8)flags;
3901 if (PL_opargs[type] & OA_RETSCALAR)
3903 if (PL_opargs[type] & OA_TARGET)
3904 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3905 return CHECKOP(type, pvop);
3913 Perl_package(pTHX_ OP *o)
3916 SV *const sv = cSVOPo->op_sv;
3921 PERL_ARGS_ASSERT_PACKAGE;
3923 save_hptr(&PL_curstash);
3924 save_item(PL_curstname);
3926 PL_curstash = gv_stashsv(sv, GV_ADD);
3928 sv_setsv(PL_curstname, sv);
3930 PL_hints |= HINT_BLOCK_SCOPE;
3931 PL_parser->copline = NOLINE;
3932 PL_parser->expect = XSTATE;
3937 if (!PL_madskills) {
3942 pegop = newOP(OP_NULL,0);
3943 op_getmad(o,pegop,'P');
3949 Perl_package_version( pTHX_ OP *v )
3952 U32 savehints = PL_hints;
3953 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3954 PL_hints &= ~HINT_STRICT_VARS;
3955 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3956 PL_hints = savehints;
3965 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3972 OP *pegop = newOP(OP_NULL,0);
3975 PERL_ARGS_ASSERT_UTILIZE;
3977 if (idop->op_type != OP_CONST)
3978 Perl_croak(aTHX_ "Module name must be constant");
3981 op_getmad(idop,pegop,'U');
3986 SV * const vesv = ((SVOP*)version)->op_sv;
3989 op_getmad(version,pegop,'V');
3990 if (!arg && !SvNIOKp(vesv)) {
3997 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3998 Perl_croak(aTHX_ "Version number must be a constant number");
4000 /* Make copy of idop so we don't free it twice */
4001 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4003 /* Fake up a method call to VERSION */
4004 meth = newSVpvs_share("VERSION");
4005 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4006 append_elem(OP_LIST,
4007 prepend_elem(OP_LIST, pack, list(version)),
4008 newSVOP(OP_METHOD_NAMED, 0, meth)));
4012 /* Fake up an import/unimport */
4013 if (arg && arg->op_type == OP_STUB) {
4015 op_getmad(arg,pegop,'S');
4016 imop = arg; /* no import on explicit () */
4018 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4019 imop = NULL; /* use 5.0; */
4021 idop->op_private |= OPpCONST_NOVER;
4027 op_getmad(arg,pegop,'A');
4029 /* Make copy of idop so we don't free it twice */
4030 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4032 /* Fake up a method call to import/unimport */
4034 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4035 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4036 append_elem(OP_LIST,
4037 prepend_elem(OP_LIST, pack, list(arg)),
4038 newSVOP(OP_METHOD_NAMED, 0, meth)));
4041 /* Fake up the BEGIN {}, which does its thing immediately. */
4043 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4046 append_elem(OP_LINESEQ,
4047 append_elem(OP_LINESEQ,
4048 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4049 newSTATEOP(0, NULL, veop)),
4050 newSTATEOP(0, NULL, imop) ));
4052 /* The "did you use incorrect case?" warning used to be here.
4053 * The problem is that on case-insensitive filesystems one
4054 * might get false positives for "use" (and "require"):
4055 * "use Strict" or "require CARP" will work. This causes
4056 * portability problems for the script: in case-strict
4057 * filesystems the script will stop working.
4059 * The "incorrect case" warning checked whether "use Foo"
4060 * imported "Foo" to your namespace, but that is wrong, too:
4061 * there is no requirement nor promise in the language that
4062 * a Foo.pm should or would contain anything in package "Foo".
4064 * There is very little Configure-wise that can be done, either:
4065 * the case-sensitivity of the build filesystem of Perl does not
4066 * help in guessing the case-sensitivity of the runtime environment.
4069 PL_hints |= HINT_BLOCK_SCOPE;
4070 PL_parser->copline = NOLINE;
4071 PL_parser->expect = XSTATE;
4072 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4075 if (!PL_madskills) {
4076 /* FIXME - don't allocate pegop if !PL_madskills */
4085 =head1 Embedding Functions
4087 =for apidoc load_module
4089 Loads the module whose name is pointed to by the string part of name.
4090 Note that the actual module name, not its filename, should be given.
4091 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4092 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4093 (or 0 for no flags). ver, if specified, provides version semantics
4094 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4095 arguments can be used to specify arguments to the module's import()
4096 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4097 terminated with a final NULL pointer. Note that this list can only
4098 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4099 Otherwise at least a single NULL pointer to designate the default
4100 import list is required.
4105 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4109 PERL_ARGS_ASSERT_LOAD_MODULE;
4111 va_start(args, ver);
4112 vload_module(flags, name, ver, &args);
4116 #ifdef PERL_IMPLICIT_CONTEXT
4118 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4122 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4123 va_start(args, ver);
4124 vload_module(flags, name, ver, &args);
4130 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4134 OP * const modname = newSVOP(OP_CONST, 0, name);
4136 PERL_ARGS_ASSERT_VLOAD_MODULE;
4138 modname->op_private |= OPpCONST_BARE;
4140 veop = newSVOP(OP_CONST, 0, ver);
4144 if (flags & PERL_LOADMOD_NOIMPORT) {
4145 imop = sawparens(newNULLLIST());
4147 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4148 imop = va_arg(*args, OP*);
4153 sv = va_arg(*args, SV*);
4155 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4156 sv = va_arg(*args, SV*);
4160 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4161 * that it has a PL_parser to play with while doing that, and also
4162 * that it doesn't mess with any existing parser, by creating a tmp
4163 * new parser with lex_start(). This won't actually be used for much,
4164 * since pp_require() will create another parser for the real work. */
4167 SAVEVPTR(PL_curcop);
4168 lex_start(NULL, NULL, FALSE);
4169 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4170 veop, modname, imop);
4175 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4181 PERL_ARGS_ASSERT_DOFILE;
4183 if (!force_builtin) {
4184 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4185 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4186 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4187 gv = gvp ? *gvp : NULL;
4191 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4192 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4193 append_elem(OP_LIST, term,
4194 scalar(newUNOP(OP_RV2CV, 0,
4195 newGVOP(OP_GV, 0, gv))))));
4198 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4204 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4206 return newBINOP(OP_LSLICE, flags,
4207 list(force_list(subscript)),
4208 list(force_list(listval)) );
4212 S_is_list_assignment(pTHX_ register const OP *o)
4220 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4221 o = cUNOPo->op_first;
4223 flags = o->op_flags;
4225 if (type == OP_COND_EXPR) {
4226 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4227 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4232 yyerror("Assignment to both a list and a scalar");
4236 if (type == OP_LIST &&
4237 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4238 o->op_private & OPpLVAL_INTRO)
4241 if (type == OP_LIST || flags & OPf_PARENS ||
4242 type == OP_RV2AV || type == OP_RV2HV ||
4243 type == OP_ASLICE || type == OP_HSLICE)
4246 if (type == OP_PADAV || type == OP_PADHV)
4249 if (type == OP_RV2SV)
4256 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4262 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4263 return newLOGOP(optype, 0,
4264 mod(scalar(left), optype),
4265 newUNOP(OP_SASSIGN, 0, scalar(right)));
4268 return newBINOP(optype, OPf_STACKED,
4269 mod(scalar(left), optype), scalar(right));
4273 if (is_list_assignment(left)) {
4274 static const char no_list_state[] = "Initialization of state variables"
4275 " in list context currently forbidden";
4277 bool maybe_common_vars = TRUE;
4280 /* Grandfathering $[ assignment here. Bletch.*/
4281 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4282 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4283 left = mod(left, OP_AASSIGN);
4286 else if (left->op_type == OP_CONST) {
4288 /* Result of assignment is always 1 (or we'd be dead already) */
4289 return newSVOP(OP_CONST, 0, newSViv(1));
4291 curop = list(force_list(left));
4292 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4293 o->op_private = (U8)(0 | (flags >> 8));
4295 if ((left->op_type == OP_LIST
4296 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4298 OP* lop = ((LISTOP*)left)->op_first;
4299 maybe_common_vars = FALSE;
4301 if (lop->op_type == OP_PADSV ||
4302 lop->op_type == OP_PADAV ||
4303 lop->op_type == OP_PADHV ||
4304 lop->op_type == OP_PADANY) {
4305 if (!(lop->op_private & OPpLVAL_INTRO))
4306 maybe_common_vars = TRUE;
4308 if (lop->op_private & OPpPAD_STATE) {
4309 if (left->op_private & OPpLVAL_INTRO) {
4310 /* Each variable in state($a, $b, $c) = ... */
4313 /* Each state variable in
4314 (state $a, my $b, our $c, $d, undef) = ... */
4316 yyerror(no_list_state);
4318 /* Each my variable in
4319 (state $a, my $b, our $c, $d, undef) = ... */
4321 } else if (lop->op_type == OP_UNDEF ||
4322 lop->op_type == OP_PUSHMARK) {
4323 /* undef may be interesting in
4324 (state $a, undef, state $c) */
4326 /* Other ops in the list. */
4327 maybe_common_vars = TRUE;
4329 lop = lop->op_sibling;
4332 else if ((left->op_private & OPpLVAL_INTRO)
4333 && ( left->op_type == OP_PADSV
4334 || left->op_type == OP_PADAV
4335 || left->op_type == OP_PADHV
4336 || left->op_type == OP_PADANY))
4338 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4339 if (left->op_private & OPpPAD_STATE) {
4340 /* All single variable list context state assignments, hence
4350 yyerror(no_list_state);
4354 /* PL_generation sorcery:
4355 * an assignment like ($a,$b) = ($c,$d) is easier than
4356 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4357 * To detect whether there are common vars, the global var
4358 * PL_generation is incremented for each assign op we compile.
4359 * Then, while compiling the assign op, we run through all the
4360 * variables on both sides of the assignment, setting a spare slot
4361 * in each of them to PL_generation. If any of them already have
4362 * that value, we know we've got commonality. We could use a
4363 * single bit marker, but then we'd have to make 2 passes, first
4364 * to clear the flag, then to test and set it. To find somewhere
4365 * to store these values, evil chicanery is done with SvUVX().
4368 if (maybe_common_vars) {
4371 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4372 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4373 if (curop->op_type == OP_GV) {
4374 GV *gv = cGVOPx_gv(curop);
4376 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4378 GvASSIGN_GENERATION_set(gv, PL_generation);
4380 else if (curop->op_type == OP_PADSV ||
4381 curop->op_type == OP_PADAV ||
4382 curop->op_type == OP_PADHV ||
4383 curop->op_type == OP_PADANY)
4385 if (PAD_COMPNAME_GEN(curop->op_targ)
4386 == (STRLEN)PL_generation)
4388 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4391 else if (curop->op_type == OP_RV2CV)
4393 else if (curop->op_type == OP_RV2SV ||
4394 curop->op_type == OP_RV2AV ||
4395 curop->op_type == OP_RV2HV ||
4396 curop->op_type == OP_RV2GV) {
4397 if (lastop->op_type != OP_GV) /* funny deref? */
4400 else if (curop->op_type == OP_PUSHRE) {
4402 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4403 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4405 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4407 GvASSIGN_GENERATION_set(gv, PL_generation);
4411 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4414 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4416 GvASSIGN_GENERATION_set(gv, PL_generation);
4426 o->op_private |= OPpASSIGN_COMMON;
4429 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4430 OP* tmpop = ((LISTOP*)right)->op_first;
4431 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4432 PMOP * const pm = (PMOP*)tmpop;
4433 if (left->op_type == OP_RV2AV &&
4434 !(left->op_private & OPpLVAL_INTRO) &&
4435 !(o->op_private & OPpASSIGN_COMMON) )
4437 tmpop = ((UNOP*)left)->op_first;
4438 if (tmpop->op_type == OP_GV
4440 && !pm->op_pmreplrootu.op_pmtargetoff
4442 && !pm->op_pmreplrootu.op_pmtargetgv
4446 pm->op_pmreplrootu.op_pmtargetoff
4447 = cPADOPx(tmpop)->op_padix;
4448 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4450 pm->op_pmreplrootu.op_pmtargetgv
4451 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4452 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4454 pm->op_pmflags |= PMf_ONCE;
4455 tmpop = cUNOPo->op_first; /* to list (nulled) */
4456 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4457 tmpop->op_sibling = NULL; /* don't free split */
4458 right->op_next = tmpop->op_next; /* fix starting loc */
4459 op_free(o); /* blow off assign */
4460 right->op_flags &= ~OPf_WANT;
4461 /* "I don't know and I don't care." */
4466 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4467 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4469 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4470 if (SvIOK(sv) && SvIVX(sv) == 0)
4471 sv_setiv(sv, PL_modcount+1);
4479 right = newOP(OP_UNDEF, 0);
4480 if (right->op_type == OP_READLINE) {
4481 right->op_flags |= OPf_STACKED;
4482 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4485 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4486 o = newBINOP(OP_SASSIGN, flags,
4487 scalar(right), mod(scalar(left), OP_SASSIGN) );
4491 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4492 deprecate("assignment to $[");
4494 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4495 o->op_private |= OPpCONST_ARYBASE;
4503 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4506 const U32 seq = intro_my();
4509 NewOp(1101, cop, 1, COP);
4510 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4511 cop->op_type = OP_DBSTATE;
4512 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4515 cop->op_type = OP_NEXTSTATE;
4516 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4518 cop->op_flags = (U8)flags;
4519 CopHINTS_set(cop, PL_hints);
4521 cop->op_private |= NATIVE_HINTS;
4523 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4524 cop->op_next = (OP*)cop;
4527 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4528 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4530 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4531 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4532 if (cop->cop_hints_hash) {
4534 cop->cop_hints_hash->refcounted_he_refcnt++;
4535 HINTS_REFCNT_UNLOCK;
4539 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4541 PL_hints |= HINT_BLOCK_SCOPE;
4542 /* It seems that we need to defer freeing this pointer, as other parts
4543 of the grammar end up wanting to copy it after this op has been
4548 if (PL_parser && PL_parser->copline == NOLINE)
4549 CopLINE_set(cop, CopLINE(PL_curcop));
4551 CopLINE_set(cop, PL_parser->copline);
4553 PL_parser->copline = NOLINE;
4556 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4558 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4560 CopSTASH_set(cop, PL_curstash);
4562 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4563 /* this line can have a breakpoint - store the cop in IV */
4564 AV *av = CopFILEAVx(PL_curcop);
4566 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4567 if (svp && *svp != &PL_sv_undef ) {
4568 (void)SvIOK_on(*svp);
4569 SvIV_set(*svp, PTR2IV(cop));
4574 if (flags & OPf_SPECIAL)
4576 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4581 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4585 PERL_ARGS_ASSERT_NEWLOGOP;
4587 return new_logop(type, flags, &first, &other);
4591 S_search_const(pTHX_ OP *o)
4593 PERL_ARGS_ASSERT_SEARCH_CONST;
4595 switch (o->op_type) {
4599 if (o->op_flags & OPf_KIDS)
4600 return search_const(cUNOPo->op_first);
4607 if (!(o->op_flags & OPf_KIDS))
4609 kid = cLISTOPo->op_first;
4611 switch (kid->op_type) {
4615 kid = kid->op_sibling;
4618 if (kid != cLISTOPo->op_last)
4624 kid = cLISTOPo->op_last;
4626 return search_const(kid);
4634 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4642 int prepend_not = 0;
4644 PERL_ARGS_ASSERT_NEW_LOGOP;
4649 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4650 return newBINOP(type, flags, scalar(first), scalar(other));
4652 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4654 scalarboolean(first);
4655 /* optimize AND and OR ops that have NOTs as children */
4656 if (first->op_type == OP_NOT
4657 && (first->op_flags & OPf_KIDS)
4658 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4659 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4661 if (type == OP_AND || type == OP_OR) {
4667 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4669 prepend_not = 1; /* prepend a NOT op later */
4673 /* search for a constant op that could let us fold the test */
4674 if ((cstop = search_const(first))) {
4675 if (cstop->op_private & OPpCONST_STRICT)
4676 no_bareword_allowed(cstop);
4677 else if ((cstop->op_private & OPpCONST_BARE))
4678 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4679 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4680 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4681 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4683 if (other->op_type == OP_CONST)
4684 other->op_private |= OPpCONST_SHORTCIRCUIT;
4686 OP *newop = newUNOP(OP_NULL, 0, other);
4687 op_getmad(first, newop, '1');
4688 newop->op_targ = type; /* set "was" field */
4692 if (other->op_type == OP_LEAVE)
4693 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4697 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4698 const OP *o2 = other;
4699 if ( ! (o2->op_type == OP_LIST
4700 && (( o2 = cUNOPx(o2)->op_first))
4701 && o2->op_type == OP_PUSHMARK
4702 && (( o2 = o2->op_sibling)) )
4705 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4706 || o2->op_type == OP_PADHV)
4707 && o2->op_private & OPpLVAL_INTRO
4708 && !(o2->op_private & OPpPAD_STATE))
4710 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4711 "Deprecated use of my() in false conditional");
4715 if (first->op_type == OP_CONST)
4716 first->op_private |= OPpCONST_SHORTCIRCUIT;
4718 first = newUNOP(OP_NULL, 0, first);
4719 op_getmad(other, first, '2');
4720 first->op_targ = type; /* set "was" field */
4727 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4728 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4730 const OP * const k1 = ((UNOP*)first)->op_first;
4731 const OP * const k2 = k1->op_sibling;
4733 switch (first->op_type)
4736 if (k2 && k2->op_type == OP_READLINE
4737 && (k2->op_flags & OPf_STACKED)
4738 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4740 warnop = k2->op_type;
4745 if (k1->op_type == OP_READDIR
4746 || k1->op_type == OP_GLOB
4747 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4748 || k1->op_type == OP_EACH)
4750 warnop = ((k1->op_type == OP_NULL)
4751 ? (OPCODE)k1->op_targ : k1->op_type);
4756 const line_t oldline = CopLINE(PL_curcop);
4757 CopLINE_set(PL_curcop, PL_parser->copline);
4758 Perl_warner(aTHX_ packWARN(WARN_MISC),
4759 "Value of %s%s can be \"0\"; test with defined()",
4761 ((warnop == OP_READLINE || warnop == OP_GLOB)
4762 ? " construct" : "() operator"));
4763 CopLINE_set(PL_curcop, oldline);
4770 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4771 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4773 NewOp(1101, logop, 1, LOGOP);
4775 logop->op_type = (OPCODE)type;
4776 logop->op_ppaddr = PL_ppaddr[type];
4777 logop->op_first = first;
4778 logop->op_flags = (U8)(flags | OPf_KIDS);
4779 logop->op_other = LINKLIST(other);
4780 logop->op_private = (U8)(1 | (flags >> 8));
4782 /* establish postfix order */
4783 logop->op_next = LINKLIST(first);
4784 first->op_next = (OP*)logop;
4785 first->op_sibling = other;
4787 CHECKOP(type,logop);
4789 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4796 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4804 PERL_ARGS_ASSERT_NEWCONDOP;
4807 return newLOGOP(OP_AND, 0, first, trueop);
4809 return newLOGOP(OP_OR, 0, first, falseop);
4811 scalarboolean(first);
4812 if ((cstop = search_const(first))) {
4813 /* Left or right arm of the conditional? */
4814 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4815 OP *live = left ? trueop : falseop;
4816 OP *const dead = left ? falseop : trueop;
4817 if (cstop->op_private & OPpCONST_BARE &&
4818 cstop->op_private & OPpCONST_STRICT) {
4819 no_bareword_allowed(cstop);
4822 /* This is all dead code when PERL_MAD is not defined. */
4823 live = newUNOP(OP_NULL, 0, live);
4824 op_getmad(first, live, 'C');
4825 op_getmad(dead, live, left ? 'e' : 't');
4830 if (live->op_type == OP_LEAVE)
4831 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4834 NewOp(1101, logop, 1, LOGOP);
4835 logop->op_type = OP_COND_EXPR;
4836 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4837 logop->op_first = first;
4838 logop->op_flags = (U8)(flags | OPf_KIDS);
4839 logop->op_private = (U8)(1 | (flags >> 8));
4840 logop->op_other = LINKLIST(trueop);
4841 logop->op_next = LINKLIST(falseop);
4843 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4846 /* establish postfix order */
4847 start = LINKLIST(first);
4848 first->op_next = (OP*)logop;
4850 first->op_sibling = trueop;
4851 trueop->op_sibling = falseop;
4852 o = newUNOP(OP_NULL, 0, (OP*)logop);
4854 trueop->op_next = falseop->op_next = o;
4861 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4870 PERL_ARGS_ASSERT_NEWRANGE;
4872 NewOp(1101, range, 1, LOGOP);
4874 range->op_type = OP_RANGE;
4875 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4876 range->op_first = left;
4877 range->op_flags = OPf_KIDS;
4878 leftstart = LINKLIST(left);
4879 range->op_other = LINKLIST(right);
4880 range->op_private = (U8)(1 | (flags >> 8));
4882 left->op_sibling = right;
4884 range->op_next = (OP*)range;
4885 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4886 flop = newUNOP(OP_FLOP, 0, flip);
4887 o = newUNOP(OP_NULL, 0, flop);
4889 range->op_next = leftstart;
4891 left->op_next = flip;
4892 right->op_next = flop;
4894 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4895 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4896 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4897 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4899 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4900 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4903 if (!flip->op_private || !flop->op_private)
4904 linklist(o); /* blow off optimizer unless constant */
4910 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4915 const bool once = block && block->op_flags & OPf_SPECIAL &&
4916 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4918 PERL_UNUSED_ARG(debuggable);
4921 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4922 return block; /* do {} while 0 does once */
4923 if (expr->op_type == OP_READLINE
4924 || expr->op_type == OP_READDIR
4925 || expr->op_type == OP_GLOB
4926 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4927 expr = newUNOP(OP_DEFINED, 0,
4928 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4929 } else if (expr->op_flags & OPf_KIDS) {
4930 const OP * const k1 = ((UNOP*)expr)->op_first;
4931 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4932 switch (expr->op_type) {
4934 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4935 && (k2->op_flags & OPf_STACKED)
4936 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4937 expr = newUNOP(OP_DEFINED, 0, expr);
4941 if (k1 && (k1->op_type == OP_READDIR
4942 || k1->op_type == OP_GLOB
4943 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4944 || k1->op_type == OP_EACH))
4945 expr = newUNOP(OP_DEFINED, 0, expr);
4951 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4952 * op, in listop. This is wrong. [perl #27024] */
4954 block = newOP(OP_NULL, 0);
4955 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4956 o = new_logop(OP_AND, 0, &expr, &listop);
4959 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4961 if (once && o != listop)
4962 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4965 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4967 o->op_flags |= flags;
4969 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4974 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4975 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4984 PERL_UNUSED_ARG(debuggable);
4987 if (expr->op_type == OP_READLINE
4988 || expr->op_type == OP_READDIR
4989 || expr->op_type == OP_GLOB
4990 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4991 expr = newUNOP(OP_DEFINED, 0,
4992 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4993 } else if (expr->op_flags & OPf_KIDS) {
4994 const OP * const k1 = ((UNOP*)expr)->op_first;
4995 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4996 switch (expr->op_type) {
4998 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4999 && (k2->op_flags & OPf_STACKED)
5000 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5001 expr = newUNOP(OP_DEFINED, 0, expr);
5005 if (k1 && (k1->op_type == OP_READDIR
5006 || k1->op_type == OP_GLOB
5007 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5008 || k1->op_type == OP_EACH))
5009 expr = newUNOP(OP_DEFINED, 0, expr);
5016 block = newOP(OP_NULL, 0);
5017 else if (cont || has_my) {
5018 block = scope(block);
5022 next = LINKLIST(cont);
5025 OP * const unstack = newOP(OP_UNSTACK, 0);
5028 cont = append_elem(OP_LINESEQ, cont, unstack);
5032 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
5034 redo = LINKLIST(listop);
5037 PL_parser->copline = (line_t)whileline;
5039 o = new_logop(OP_AND, 0, &expr, &listop);
5040 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5041 op_free(expr); /* oops, it's a while (0) */
5043 return NULL; /* listop already freed by new_logop */
5046 ((LISTOP*)listop)->op_last->op_next =
5047 (o == listop ? redo : LINKLIST(o));
5053 NewOp(1101,loop,1,LOOP);
5054 loop->op_type = OP_ENTERLOOP;
5055 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5056 loop->op_private = 0;
5057 loop->op_next = (OP*)loop;
5060 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5062 loop->op_redoop = redo;
5063 loop->op_lastop = o;
5064 o->op_private |= loopflags;
5067 loop->op_nextop = next;
5069 loop->op_nextop = o;
5071 o->op_flags |= flags;
5072 o->op_private |= (flags >> 8);
5077 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
5082 PADOFFSET padoff = 0;
5087 PERL_ARGS_ASSERT_NEWFOROP;
5090 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5091 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5092 sv->op_type = OP_RV2GV;
5093 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5095 /* The op_type check is needed to prevent a possible segfault
5096 * if the loop variable is undeclared and 'strict vars' is in
5097 * effect. This is illegal but is nonetheless parsed, so we
5098 * may reach this point with an OP_CONST where we're expecting
5101 if (cUNOPx(sv)->op_first->op_type == OP_GV
5102 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5103 iterpflags |= OPpITER_DEF;
5105 else if (sv->op_type == OP_PADSV) { /* private variable */
5106 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5107 padoff = sv->op_targ;
5117 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5119 SV *const namesv = PAD_COMPNAME_SV(padoff);
5121 const char *const name = SvPV_const(namesv, len);
5123 if (len == 2 && name[0] == '$' && name[1] == '_')
5124 iterpflags |= OPpITER_DEF;
5128 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5129 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5130 sv = newGVOP(OP_GV, 0, PL_defgv);
5135 iterpflags |= OPpITER_DEF;
5137 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5138 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5139 iterflags |= OPf_STACKED;
5141 else if (expr->op_type == OP_NULL &&
5142 (expr->op_flags & OPf_KIDS) &&
5143 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5145 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5146 * set the STACKED flag to indicate that these values are to be
5147 * treated as min/max values by 'pp_iterinit'.
5149 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5150 LOGOP* const range = (LOGOP*) flip->op_first;
5151 OP* const left = range->op_first;
5152 OP* const right = left->op_sibling;
5155 range->op_flags &= ~OPf_KIDS;
5156 range->op_first = NULL;
5158 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5159 listop->op_first->op_next = range->op_next;
5160 left->op_next = range->op_other;
5161 right->op_next = (OP*)listop;
5162 listop->op_next = listop->op_first;
5165 op_getmad(expr,(OP*)listop,'O');
5169 expr = (OP*)(listop);
5171 iterflags |= OPf_STACKED;
5174 expr = mod(force_list(expr), OP_GREPSTART);
5177 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5178 append_elem(OP_LIST, expr, scalar(sv))));
5179 assert(!loop->op_next);
5180 /* for my $x () sets OPpLVAL_INTRO;
5181 * for our $x () sets OPpOUR_INTRO */
5182 loop->op_private = (U8)iterpflags;
5183 #ifdef PL_OP_SLAB_ALLOC
5186 NewOp(1234,tmp,1,LOOP);
5187 Copy(loop,tmp,1,LISTOP);
5188 S_op_destroy(aTHX_ (OP*)loop);
5192 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5194 loop->op_targ = padoff;
5195 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5197 op_getmad(madsv, (OP*)loop, 'v');
5198 PL_parser->copline = forline;
5199 return newSTATEOP(0, label, wop);
5203 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5208 PERL_ARGS_ASSERT_NEWLOOPEX;
5210 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5212 if (type != OP_GOTO || label->op_type == OP_CONST) {
5213 /* "last()" means "last" */
5214 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5215 o = newOP(type, OPf_SPECIAL);
5217 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5218 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5222 op_getmad(label,o,'L');
5228 /* Check whether it's going to be a goto &function */
5229 if (label->op_type == OP_ENTERSUB
5230 && !(label->op_flags & OPf_STACKED))
5231 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5232 o = newUNOP(type, OPf_STACKED, label);
5234 PL_hints |= HINT_BLOCK_SCOPE;
5238 /* if the condition is a literal array or hash
5239 (or @{ ... } etc), make a reference to it.
5242 S_ref_array_or_hash(pTHX_ OP *cond)
5245 && (cond->op_type == OP_RV2AV
5246 || cond->op_type == OP_PADAV
5247 || cond->op_type == OP_RV2HV
5248 || cond->op_type == OP_PADHV))
5250 return newUNOP(OP_REFGEN,
5251 0, mod(cond, OP_REFGEN));
5257 /* These construct the optree fragments representing given()
5260 entergiven and enterwhen are LOGOPs; the op_other pointer
5261 points up to the associated leave op. We need this so we
5262 can put it in the context and make break/continue work.
5263 (Also, of course, pp_enterwhen will jump straight to
5264 op_other if the match fails.)
5268 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5269 I32 enter_opcode, I32 leave_opcode,
5270 PADOFFSET entertarg)
5276 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5278 NewOp(1101, enterop, 1, LOGOP);
5279 enterop->op_type = (Optype)enter_opcode;
5280 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5281 enterop->op_flags = (U8) OPf_KIDS;
5282 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5283 enterop->op_private = 0;
5285 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5288 enterop->op_first = scalar(cond);
5289 cond->op_sibling = block;
5291 o->op_next = LINKLIST(cond);
5292 cond->op_next = (OP *) enterop;
5295 /* This is a default {} block */
5296 enterop->op_first = block;
5297 enterop->op_flags |= OPf_SPECIAL;
5299 o->op_next = (OP *) enterop;
5302 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5303 entergiven and enterwhen both
5306 enterop->op_next = LINKLIST(block);
5307 block->op_next = enterop->op_other = o;
5312 /* Does this look like a boolean operation? For these purposes
5313 a boolean operation is:
5314 - a subroutine call [*]
5315 - a logical connective
5316 - a comparison operator
5317 - a filetest operator, with the exception of -s -M -A -C
5318 - defined(), exists() or eof()
5319 - /$re/ or $foo =~ /$re/
5321 [*] possibly surprising
5324 S_looks_like_bool(pTHX_ const OP *o)
5328 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5330 switch(o->op_type) {
5333 return looks_like_bool(cLOGOPo->op_first);
5337 looks_like_bool(cLOGOPo->op_first)
5338 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5343 o->op_flags & OPf_KIDS
5344 && looks_like_bool(cUNOPo->op_first));
5348 case OP_NOT: case OP_XOR:
5350 case OP_EQ: case OP_NE: case OP_LT:
5351 case OP_GT: case OP_LE: case OP_GE:
5353 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5354 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5356 case OP_SEQ: case OP_SNE: case OP_SLT:
5357 case OP_SGT: case OP_SLE: case OP_SGE:
5361 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5362 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5363 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5364 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5365 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5366 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5367 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5368 case OP_FTTEXT: case OP_FTBINARY:
5370 case OP_DEFINED: case OP_EXISTS:
5371 case OP_MATCH: case OP_EOF:
5378 /* Detect comparisons that have been optimized away */
5379 if (cSVOPo->op_sv == &PL_sv_yes
5380 || cSVOPo->op_sv == &PL_sv_no)
5393 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5396 PERL_ARGS_ASSERT_NEWGIVENOP;
5397 return newGIVWHENOP(
5398 ref_array_or_hash(cond),
5400 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5404 /* If cond is null, this is a default {} block */
5406 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5408 const bool cond_llb = (!cond || looks_like_bool(cond));
5411 PERL_ARGS_ASSERT_NEWWHENOP;
5416 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5418 scalar(ref_array_or_hash(cond)));
5421 return newGIVWHENOP(
5423 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5424 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5428 =for apidoc cv_undef
5430 Clear out all the active components of a CV. This can happen either
5431 by an explicit C<undef &foo>, or by the reference count going to zero.
5432 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5433 children can still follow the full lexical scope chain.
5439 Perl_cv_undef(pTHX_ CV *cv)
5443 PERL_ARGS_ASSERT_CV_UNDEF;
5445 DEBUG_X(PerlIO_printf(Perl_debug_log,
5446 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5447 PTR2UV(cv), PTR2UV(PL_comppad))
5451 if (CvFILE(cv) && !CvISXSUB(cv)) {
5452 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5453 Safefree(CvFILE(cv));
5458 if (!CvISXSUB(cv) && CvROOT(cv)) {
5459 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5460 Perl_croak(aTHX_ "Can't undef active subroutine");
5463 PAD_SAVE_SETNULLPAD();
5465 op_free(CvROOT(cv));
5470 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5475 /* remove CvOUTSIDE unless this is an undef rather than a free */
5476 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5477 if (!CvWEAKOUTSIDE(cv))
5478 SvREFCNT_dec(CvOUTSIDE(cv));
5479 CvOUTSIDE(cv) = NULL;
5482 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5485 if (CvISXSUB(cv) && CvXSUB(cv)) {
5488 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
5489 * ref status of CvOUTSIDE and CvGV */
5490 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
5494 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5497 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5499 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5500 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5501 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5502 || (p && (len != SvCUR(cv) /* Not the same length. */
5503 || memNE(p, SvPVX_const(cv), len))))
5504 && ckWARN_d(WARN_PROTOTYPE)) {
5505 SV* const msg = sv_newmortal();
5509 gv_efullname3(name = sv_newmortal(), gv, NULL);
5510 sv_setpvs(msg, "Prototype mismatch:");
5512 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5514 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5516 sv_catpvs(msg, ": none");
5517 sv_catpvs(msg, " vs ");
5519 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5521 sv_catpvs(msg, "none");
5522 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5526 static void const_sv_xsub(pTHX_ CV* cv);
5530 =head1 Optree Manipulation Functions
5532 =for apidoc cv_const_sv
5534 If C<cv> is a constant sub eligible for inlining. returns the constant
5535 value returned by the sub. Otherwise, returns NULL.
5537 Constant subs can be created with C<newCONSTSUB> or as described in
5538 L<perlsub/"Constant Functions">.
5543 Perl_cv_const_sv(pTHX_ const CV *const cv)
5545 PERL_UNUSED_CONTEXT;
5548 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5550 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5553 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5554 * Can be called in 3 ways:
5557 * look for a single OP_CONST with attached value: return the value
5559 * cv && CvCLONE(cv) && !CvCONST(cv)
5561 * examine the clone prototype, and if contains only a single
5562 * OP_CONST referencing a pad const, or a single PADSV referencing
5563 * an outer lexical, return a non-zero value to indicate the CV is
5564 * a candidate for "constizing" at clone time
5568 * We have just cloned an anon prototype that was marked as a const
5569 * candidiate. Try to grab the current value, and in the case of
5570 * PADSV, ignore it if it has multiple references. Return the value.
5574 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5585 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5586 o = cLISTOPo->op_first->op_sibling;
5588 for (; o; o = o->op_next) {
5589 const OPCODE type = o->op_type;
5591 if (sv && o->op_next == o)
5593 if (o->op_next != o) {
5594 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5596 if (type == OP_DBSTATE)
5599 if (type == OP_LEAVESUB || type == OP_RETURN)
5603 if (type == OP_CONST && cSVOPo->op_sv)
5605 else if (cv && type == OP_CONST) {
5606 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5610 else if (cv && type == OP_PADSV) {
5611 if (CvCONST(cv)) { /* newly cloned anon */
5612 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5613 /* the candidate should have 1 ref from this pad and 1 ref
5614 * from the parent */
5615 if (!sv || SvREFCNT(sv) != 2)
5622 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5623 sv = &PL_sv_undef; /* an arbitrary non-null value */
5638 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5641 /* This would be the return value, but the return cannot be reached. */
5642 OP* pegop = newOP(OP_NULL, 0);
5645 PERL_UNUSED_ARG(floor);
5655 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5657 NORETURN_FUNCTION_END;
5662 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5664 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5668 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5673 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
5674 register CV *cv = NULL;
5676 /* If the subroutine has no body, no attributes, and no builtin attributes
5677 then it's just a sub declaration, and we may be able to get away with
5678 storing with a placeholder scalar in the symbol table, rather than a
5679 full GV and CV. If anything is present then it will take a full CV to
5681 const I32 gv_fetch_flags
5682 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5684 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5685 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5689 assert(proto->op_type == OP_CONST);
5690 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5696 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5698 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5699 SV * const sv = sv_newmortal();
5700 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5701 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5702 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5703 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5705 } else if (PL_curstash) {
5706 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5709 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5713 if (!PL_madskills) {
5722 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5723 maximum a prototype before. */
5724 if (SvTYPE(gv) > SVt_NULL) {
5725 if (!SvPOK((const SV *)gv)
5726 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5728 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5730 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5733 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5735 sv_setiv(MUTABLE_SV(gv), -1);
5737 SvREFCNT_dec(PL_compcv);
5738 cv = PL_compcv = NULL;
5742 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5744 if (!block || !ps || *ps || attrs
5745 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5747 || block->op_type == OP_NULL
5752 const_sv = op_const_sv(block, NULL);
5755 const bool exists = CvROOT(cv) || CvXSUB(cv);
5757 /* if the subroutine doesn't exist and wasn't pre-declared
5758 * with a prototype, assume it will be AUTOLOADed,
5759 * skipping the prototype check
5761 if (exists || SvPOK(cv))
5762 cv_ckproto_len(cv, gv, ps, ps_len);
5763 /* already defined (or promised)? */
5764 if (exists || GvASSUMECV(gv)) {
5767 || block->op_type == OP_NULL
5770 if (CvFLAGS(PL_compcv)) {
5771 /* might have had built-in attrs applied */
5772 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
5773 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
5774 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
5776 /* just a "sub foo;" when &foo is already defined */
5777 SAVEFREESV(PL_compcv);
5782 && block->op_type != OP_NULL
5785 if (ckWARN(WARN_REDEFINE)
5787 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5789 const line_t oldline = CopLINE(PL_curcop);
5790 if (PL_parser && PL_parser->copline != NOLINE)
5791 CopLINE_set(PL_curcop, PL_parser->copline);
5792 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5793 CvCONST(cv) ? "Constant subroutine %s redefined"
5794 : "Subroutine %s redefined", name);
5795 CopLINE_set(PL_curcop, oldline);
5798 if (!PL_minus_c) /* keep old one around for madskills */
5801 /* (PL_madskills unset in used file.) */
5809 SvREFCNT_inc_simple_void_NN(const_sv);
5811 assert(!CvROOT(cv) && !CvCONST(cv));
5812 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5813 CvXSUBANY(cv).any_ptr = const_sv;
5814 CvXSUB(cv) = const_sv_xsub;
5820 cv = newCONSTSUB(NULL, name, const_sv);
5822 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5823 (CvGV(cv) && GvSTASH(CvGV(cv)))
5832 SvREFCNT_dec(PL_compcv);
5836 if (cv) { /* must reuse cv if autoloaded */
5837 /* transfer PL_compcv to cv */
5840 && block->op_type != OP_NULL
5843 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
5845 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
5846 if (!CvWEAKOUTSIDE(cv))
5847 SvREFCNT_dec(CvOUTSIDE(cv));
5848 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5849 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5850 CvOUTSIDE(PL_compcv) = 0;
5851 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5852 CvPADLIST(PL_compcv) = 0;
5853 /* inner references to PL_compcv must be fixed up ... */
5854 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5855 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5856 ++PL_sub_generation;
5858 sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
5861 /* Might have had built-in attributes applied -- propagate them. */
5862 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5864 /* ... before we throw it away */
5865 SvREFCNT_dec(PL_compcv);
5873 if (strEQ(name, "import")) {
5874 PL_formfeed = MUTABLE_SV(cv);
5875 /* diag_listed_as: SKIPME */
5876 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
5880 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5885 CvFILE_set_from_cop(cv, PL_curcop);
5886 CvSTASH(cv) = PL_curstash;
5888 Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
5891 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5892 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5893 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5897 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5899 if (PL_parser && PL_parser->error_count) {
5903 const char *s = strrchr(name, ':');
5905 if (strEQ(s, "BEGIN")) {
5906 const char not_safe[] =
5907 "BEGIN not safe after errors--compilation aborted";
5908 if (PL_in_eval & EVAL_KEEPERR)
5909 Perl_croak(aTHX_ not_safe);
5911 /* force display of errors found but not reported */
5912 sv_catpv(ERRSV, not_safe);
5913 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5922 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5923 the debugger could be able to set a breakpoint in, so signal to
5924 pp_entereval that it should not throw away any saved lines at scope
5927 PL_breakable_sub_gen++;
5929 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5930 mod(scalarseq(block), OP_LEAVESUBLV));
5931 block->op_attached = 1;
5934 /* This makes sub {}; work as expected. */
5935 if (block->op_type == OP_STUB) {
5936 OP* const newblock = newSTATEOP(0, NULL, 0);
5938 op_getmad(block,newblock,'B');
5945 block->op_attached = 1;
5946 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5948 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5949 OpREFCNT_set(CvROOT(cv), 1);
5950 CvSTART(cv) = LINKLIST(CvROOT(cv));
5951 CvROOT(cv)->op_next = 0;
5952 CALL_PEEP(CvSTART(cv));
5954 /* now that optimizer has done its work, adjust pad values */
5956 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5959 assert(!CvCONST(cv));
5960 if (ps && !*ps && op_const_sv(block, cv))
5965 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5966 SV * const tmpstr = sv_newmortal();
5967 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5968 GV_ADDMULTI, SVt_PVHV);
5970 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
5973 (long)CopLINE(PL_curcop));
5974 gv_efullname3(tmpstr, gv, NULL);
5975 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5976 SvCUR(tmpstr), sv, 0);
5977 hv = GvHVn(db_postponed);
5978 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5979 CV * const pcv = GvCV(db_postponed);
5985 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5990 if (name && ! (PL_parser && PL_parser->error_count))
5991 process_special_blocks(name, gv, cv);
5996 PL_parser->copline = NOLINE;
6002 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6005 const char *const colon = strrchr(fullname,':');
6006 const char *const name = colon ? colon + 1 : fullname;
6008 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6011 if (strEQ(name, "BEGIN")) {
6012 const I32 oldscope = PL_scopestack_ix;
6014 SAVECOPFILE(&PL_compiling);
6015 SAVECOPLINE(&PL_compiling);
6017 DEBUG_x( dump_sub(gv) );
6018 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6019 GvCV(gv) = 0; /* cv has been hijacked */
6020 call_list(oldscope, PL_beginav);
6022 PL_curcop = &PL_compiling;
6023 CopHINTS_set(&PL_compiling, PL_hints);
6030 if strEQ(name, "END") {
6031 DEBUG_x( dump_sub(gv) );
6032 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6035 } else if (*name == 'U') {
6036 if (strEQ(name, "UNITCHECK")) {
6037 /* It's never too late to run a unitcheck block */
6038 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6042 } else if (*name == 'C') {
6043 if (strEQ(name, "CHECK")) {
6045 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6046 "Too late to run CHECK block");
6047 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6051 } else if (*name == 'I') {
6052 if (strEQ(name, "INIT")) {
6054 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6055 "Too late to run INIT block");
6056 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6062 DEBUG_x( dump_sub(gv) );
6063 GvCV(gv) = 0; /* cv has been hijacked */
6068 =for apidoc newCONSTSUB
6070 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6071 eligible for inlining at compile-time.
6073 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6074 which won't be called if used as a destructor, but will suppress the overhead
6075 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6082 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6087 const char *const file = CopFILE(PL_curcop);
6089 SV *const temp_sv = CopFILESV(PL_curcop);
6090 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6095 if (IN_PERL_RUNTIME) {
6096 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6097 * an op shared between threads. Use a non-shared COP for our
6099 SAVEVPTR(PL_curcop);
6100 PL_curcop = &PL_compiling;
6102 SAVECOPLINE(PL_curcop);
6103 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6106 PL_hints &= ~HINT_BLOCK_SCOPE;
6109 SAVESPTR(PL_curstash);
6110 SAVECOPSTASH(PL_curcop);
6111 PL_curstash = stash;
6112 CopSTASH_set(PL_curcop,stash);
6115 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6116 and so doesn't get free()d. (It's expected to be from the C pre-
6117 processor __FILE__ directive). But we need a dynamically allocated one,
6118 and we need it to get freed. */
6119 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6120 XS_DYNAMIC_FILENAME);
6121 CvXSUBANY(cv).any_ptr = sv;
6126 CopSTASH_free(PL_curcop);
6134 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6135 const char *const filename, const char *const proto,
6138 CV *cv = newXS(name, subaddr, filename);
6140 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6142 if (flags & XS_DYNAMIC_FILENAME) {
6143 /* We need to "make arrangements" (ie cheat) to ensure that the
6144 filename lasts as long as the PVCV we just created, but also doesn't
6146 STRLEN filename_len = strlen(filename);
6147 STRLEN proto_and_file_len = filename_len;
6148 char *proto_and_file;
6152 proto_len = strlen(proto);
6153 proto_and_file_len += proto_len;
6155 Newx(proto_and_file, proto_and_file_len + 1, char);
6156 Copy(proto, proto_and_file, proto_len, char);
6157 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6160 proto_and_file = savepvn(filename, filename_len);
6163 /* This gets free()d. :-) */
6164 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6165 SV_HAS_TRAILING_NUL);
6167 /* This gives us the correct prototype, rather than one with the
6168 file name appended. */
6169 SvCUR_set(cv, proto_len);
6173 CvFILE(cv) = proto_and_file + proto_len;
6175 sv_setpv(MUTABLE_SV(cv), proto);
6181 =for apidoc U||newXS
6183 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6184 static storage, as it is used directly as CvFILE(), without a copy being made.
6190 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6193 GV * const gv = gv_fetchpv(name ? name :
6194 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6195 GV_ADDMULTI, SVt_PVCV);
6198 PERL_ARGS_ASSERT_NEWXS;
6201 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6203 if ((cv = (name ? GvCV(gv) : NULL))) {
6205 /* just a cached method */
6209 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6210 /* already defined (or promised) */
6211 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6212 if (ckWARN(WARN_REDEFINE)) {
6213 GV * const gvcv = CvGV(cv);
6215 HV * const stash = GvSTASH(gvcv);
6217 const char *redefined_name = HvNAME_get(stash);
6218 if ( strEQ(redefined_name,"autouse") ) {
6219 const line_t oldline = CopLINE(PL_curcop);
6220 if (PL_parser && PL_parser->copline != NOLINE)
6221 CopLINE_set(PL_curcop, PL_parser->copline);
6222 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6223 CvCONST(cv) ? "Constant subroutine %s redefined"
6224 : "Subroutine %s redefined"
6226 CopLINE_set(PL_curcop, oldline);
6236 if (cv) /* must reuse cv if autoloaded */
6239 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6243 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6249 (void)gv_fetchfile(filename);
6250 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6251 an external constant string */
6253 CvXSUB(cv) = subaddr;
6256 process_special_blocks(name, gv, cv);
6266 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6271 OP* pegop = newOP(OP_NULL, 0);
6275 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6276 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6279 if ((cv = GvFORM(gv))) {
6280 if (ckWARN(WARN_REDEFINE)) {
6281 const line_t oldline = CopLINE(PL_curcop);
6282 if (PL_parser && PL_parser->copline != NOLINE)
6283 CopLINE_set(PL_curcop, PL_parser->copline);
6285 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6286 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6288 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6289 "Format STDOUT redefined");
6291 CopLINE_set(PL_curcop, oldline);
6298 CvFILE_set_from_cop(cv, PL_curcop);
6301 pad_tidy(padtidy_FORMAT);
6302 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6303 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6304 OpREFCNT_set(CvROOT(cv), 1);
6305 CvSTART(cv) = LINKLIST(CvROOT(cv));
6306 CvROOT(cv)->op_next = 0;
6307 CALL_PEEP(CvSTART(cv));
6309 op_getmad(o,pegop,'n');
6310 op_getmad_weak(block, pegop, 'b');
6315 PL_parser->copline = NOLINE;
6323 Perl_newANONLIST(pTHX_ OP *o)
6325 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6329 Perl_newANONHASH(pTHX_ OP *o)
6331 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6335 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6337 return newANONATTRSUB(floor, proto, NULL, block);
6341 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6343 return newUNOP(OP_REFGEN, 0,
6344 newSVOP(OP_ANONCODE, 0,
6345 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6349 Perl_oopsAV(pTHX_ OP *o)
6353 PERL_ARGS_ASSERT_OOPSAV;
6355 switch (o->op_type) {
6357 o->op_type = OP_PADAV;
6358 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6359 return ref(o, OP_RV2AV);
6362 o->op_type = OP_RV2AV;
6363 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6368 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6375 Perl_oopsHV(pTHX_ OP *o)
6379 PERL_ARGS_ASSERT_OOPSHV;
6381 switch (o->op_type) {
6384 o->op_type = OP_PADHV;
6385 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6386 return ref(o, OP_RV2HV);
6390 o->op_type = OP_RV2HV;
6391 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6396 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6403 Perl_newAVREF(pTHX_ OP *o)
6407 PERL_ARGS_ASSERT_NEWAVREF;
6409 if (o->op_type == OP_PADANY) {
6410 o->op_type = OP_PADAV;
6411 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6414 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6415 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6416 "Using an array as a reference is deprecated");
6418 return newUNOP(OP_RV2AV, 0, scalar(o));
6422 Perl_newGVREF(pTHX_ I32 type, OP *o)
6424 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6425 return newUNOP(OP_NULL, 0, o);
6426 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6430 Perl_newHVREF(pTHX_ OP *o)
6434 PERL_ARGS_ASSERT_NEWHVREF;
6436 if (o->op_type == OP_PADANY) {
6437 o->op_type = OP_PADHV;
6438 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6441 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6442 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6443 "Using a hash as a reference is deprecated");
6445 return newUNOP(OP_RV2HV, 0, scalar(o));
6449 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6451 return newUNOP(OP_RV2CV, flags, scalar(o));
6455 Perl_newSVREF(pTHX_ OP *o)
6459 PERL_ARGS_ASSERT_NEWSVREF;
6461 if (o->op_type == OP_PADANY) {
6462 o->op_type = OP_PADSV;
6463 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6466 return newUNOP(OP_RV2SV, 0, scalar(o));
6469 /* Check routines. See the comments at the top of this file for details
6470 * on when these are called */
6473 Perl_ck_anoncode(pTHX_ OP *o)
6475 PERL_ARGS_ASSERT_CK_ANONCODE;
6477 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6479 cSVOPo->op_sv = NULL;
6484 Perl_ck_bitop(pTHX_ OP *o)
6488 PERL_ARGS_ASSERT_CK_BITOP;
6490 #define OP_IS_NUMCOMPARE(op) \
6491 ((op) == OP_LT || (op) == OP_I_LT || \
6492 (op) == OP_GT || (op) == OP_I_GT || \
6493 (op) == OP_LE || (op) == OP_I_LE || \
6494 (op) == OP_GE || (op) == OP_I_GE || \
6495 (op) == OP_EQ || (op) == OP_I_EQ || \
6496 (op) == OP_NE || (op) == OP_I_NE || \
6497 (op) == OP_NCMP || (op) == OP_I_NCMP)
6498 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6499 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6500 && (o->op_type == OP_BIT_OR
6501 || o->op_type == OP_BIT_AND
6502 || o->op_type == OP_BIT_XOR))
6504 const OP * const left = cBINOPo->op_first;
6505 const OP * const right = left->op_sibling;
6506 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6507 (left->op_flags & OPf_PARENS) == 0) ||
6508 (OP_IS_NUMCOMPARE(right->op_type) &&
6509 (right->op_flags & OPf_PARENS) == 0))
6510 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6511 "Possible precedence problem on bitwise %c operator",
6512 o->op_type == OP_BIT_OR ? '|'
6513 : o->op_type == OP_BIT_AND ? '&' : '^'
6520 Perl_ck_concat(pTHX_ OP *o)
6522 const OP * const kid = cUNOPo->op_first;
6524 PERL_ARGS_ASSERT_CK_CONCAT;
6525 PERL_UNUSED_CONTEXT;
6527 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6528 !(kUNOP->op_first->op_flags & OPf_MOD))
6529 o->op_flags |= OPf_STACKED;
6534 Perl_ck_spair(pTHX_ OP *o)
6538 PERL_ARGS_ASSERT_CK_SPAIR;
6540 if (o->op_flags & OPf_KIDS) {
6543 const OPCODE type = o->op_type;
6544 o = modkids(ck_fun(o), type);
6545 kid = cUNOPo->op_first;
6546 newop = kUNOP->op_first->op_sibling;
6548 const OPCODE type = newop->op_type;
6549 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6550 type == OP_PADAV || type == OP_PADHV ||
6551 type == OP_RV2AV || type == OP_RV2HV)
6555 op_getmad(kUNOP->op_first,newop,'K');
6557 op_free(kUNOP->op_first);
6559 kUNOP->op_first = newop;
6561 o->op_ppaddr = PL_ppaddr[++o->op_type];
6566 Perl_ck_delete(pTHX_ OP *o)
6568 PERL_ARGS_ASSERT_CK_DELETE;
6572 if (o->op_flags & OPf_KIDS) {
6573 OP * const kid = cUNOPo->op_first;
6574 switch (kid->op_type) {
6576 o->op_flags |= OPf_SPECIAL;
6579 o->op_private |= OPpSLICE;
6582 o->op_flags |= OPf_SPECIAL;
6587 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6590 if (kid->op_private & OPpLVAL_INTRO)
6591 o->op_private |= OPpLVAL_INTRO;
6598 Perl_ck_die(pTHX_ OP *o)
6600 PERL_ARGS_ASSERT_CK_DIE;
6603 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6609 Perl_ck_eof(pTHX_ OP *o)
6613 PERL_ARGS_ASSERT_CK_EOF;
6615 if (o->op_flags & OPf_KIDS) {
6616 if (cLISTOPo->op_first->op_type == OP_STUB) {
6618 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6620 op_getmad(o,newop,'O');
6632 Perl_ck_eval(pTHX_ OP *o)
6636 PERL_ARGS_ASSERT_CK_EVAL;
6638 PL_hints |= HINT_BLOCK_SCOPE;
6639 if (o->op_flags & OPf_KIDS) {
6640 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6643 o->op_flags &= ~OPf_KIDS;
6646 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6652 cUNOPo->op_first = 0;
6657 NewOp(1101, enter, 1, LOGOP);
6658 enter->op_type = OP_ENTERTRY;
6659 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6660 enter->op_private = 0;
6662 /* establish postfix order */
6663 enter->op_next = (OP*)enter;
6665 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6666 o->op_type = OP_LEAVETRY;
6667 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6668 enter->op_other = o;
6669 op_getmad(oldo,o,'O');
6683 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6684 op_getmad(oldo,o,'O');
6686 o->op_targ = (PADOFFSET)PL_hints;
6687 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6688 /* Store a copy of %^H that pp_entereval can pick up. */
6689 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6690 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6691 cUNOPo->op_first->op_sibling = hhop;
6692 o->op_private |= OPpEVAL_HAS_HH;
6698 Perl_ck_exit(pTHX_ OP *o)
6700 PERL_ARGS_ASSERT_CK_EXIT;
6703 HV * const table = GvHV(PL_hintgv);
6705 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6706 if (svp && *svp && SvTRUE(*svp))
6707 o->op_private |= OPpEXIT_VMSISH;
6709 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6715 Perl_ck_exec(pTHX_ OP *o)
6717 PERL_ARGS_ASSERT_CK_EXEC;
6719 if (o->op_flags & OPf_STACKED) {
6722 kid = cUNOPo->op_first->op_sibling;
6723 if (kid->op_type == OP_RV2GV)
6732 Perl_ck_exists(pTHX_ OP *o)
6736 PERL_ARGS_ASSERT_CK_EXISTS;
6739 if (o->op_flags & OPf_KIDS) {
6740 OP * const kid = cUNOPo->op_first;
6741 if (kid->op_type == OP_ENTERSUB) {
6742 (void) ref(kid, o->op_type);
6743 if (kid->op_type != OP_RV2CV
6744 && !(PL_parser && PL_parser->error_count))
6745 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6747 o->op_private |= OPpEXISTS_SUB;
6749 else if (kid->op_type == OP_AELEM)
6750 o->op_flags |= OPf_SPECIAL;
6751 else if (kid->op_type != OP_HELEM)
6752 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6760 Perl_ck_rvconst(pTHX_ register OP *o)
6763 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6765 PERL_ARGS_ASSERT_CK_RVCONST;
6767 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6768 if (o->op_type == OP_RV2CV)
6769 o->op_private &= ~1;
6771 if (kid->op_type == OP_CONST) {
6774 SV * const kidsv = kid->op_sv;
6776 /* Is it a constant from cv_const_sv()? */
6777 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6778 SV * const rsv = SvRV(kidsv);
6779 const svtype type = SvTYPE(rsv);
6780 const char *badtype = NULL;
6782 switch (o->op_type) {
6784 if (type > SVt_PVMG)
6785 badtype = "a SCALAR";
6788 if (type != SVt_PVAV)
6789 badtype = "an ARRAY";
6792 if (type != SVt_PVHV)
6796 if (type != SVt_PVCV)
6801 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6804 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6805 const char *badthing;
6806 switch (o->op_type) {
6808 badthing = "a SCALAR";
6811 badthing = "an ARRAY";
6814 badthing = "a HASH";
6822 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6823 SVfARG(kidsv), badthing);
6826 * This is a little tricky. We only want to add the symbol if we
6827 * didn't add it in the lexer. Otherwise we get duplicate strict
6828 * warnings. But if we didn't add it in the lexer, we must at
6829 * least pretend like we wanted to add it even if it existed before,
6830 * or we get possible typo warnings. OPpCONST_ENTERED says
6831 * whether the lexer already added THIS instance of this symbol.
6833 iscv = (o->op_type == OP_RV2CV) * 2;
6835 gv = gv_fetchsv(kidsv,
6836 iscv | !(kid->op_private & OPpCONST_ENTERED),
6839 : o->op_type == OP_RV2SV
6841 : o->op_type == OP_RV2AV
6843 : o->op_type == OP_RV2HV
6846 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6848 kid->op_type = OP_GV;
6849 SvREFCNT_dec(kid->op_sv);
6851 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6852 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6853 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6855 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6857 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6859 kid->op_private = 0;
6860 kid->op_ppaddr = PL_ppaddr[OP_GV];
6867 Perl_ck_ftst(pTHX_ OP *o)
6870 const I32 type = o->op_type;
6872 PERL_ARGS_ASSERT_CK_FTST;
6874 if (o->op_flags & OPf_REF) {
6877 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6878 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6879 const OPCODE kidtype = kid->op_type;
6881 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6882 OP * const newop = newGVOP(type, OPf_REF,
6883 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6885 op_getmad(o,newop,'O');
6891 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6892 o->op_private |= OPpFT_ACCESS;
6893 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6894 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6895 o->op_private |= OPpFT_STACKED;
6903 if (type == OP_FTTTY)
6904 o = newGVOP(type, OPf_REF, PL_stdingv);
6906 o = newUNOP(type, 0, newDEFSVOP());
6907 op_getmad(oldo,o,'O');
6913 Perl_ck_fun(pTHX_ OP *o)
6916 const int type = o->op_type;
6917 register I32 oa = PL_opargs[type] >> OASHIFT;
6919 PERL_ARGS_ASSERT_CK_FUN;
6921 if (o->op_flags & OPf_STACKED) {
6922 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6925 return no_fh_allowed(o);
6928 if (o->op_flags & OPf_KIDS) {
6929 OP **tokid = &cLISTOPo->op_first;
6930 register OP *kid = cLISTOPo->op_first;
6934 if (kid->op_type == OP_PUSHMARK ||
6935 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6937 tokid = &kid->op_sibling;
6938 kid = kid->op_sibling;
6940 if (!kid && PL_opargs[type] & OA_DEFGV)
6941 *tokid = kid = newDEFSVOP();
6945 sibl = kid->op_sibling;
6947 if (!sibl && kid->op_type == OP_STUB) {
6954 /* list seen where single (scalar) arg expected? */
6955 if (numargs == 1 && !(oa >> 4)
6956 && kid->op_type == OP_LIST && type != OP_SCALAR)
6958 return too_many_arguments(o,PL_op_desc[type]);
6971 if ((type == OP_PUSH || type == OP_UNSHIFT)
6972 && !kid->op_sibling)
6973 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6974 "Useless use of %s with no values",
6977 if (kid->op_type == OP_CONST &&
6978 (kid->op_private & OPpCONST_BARE))
6980 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6981 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6982 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6983 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6984 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6986 op_getmad(kid,newop,'K');
6991 kid->op_sibling = sibl;
6994 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6995 bad_type(numargs, "array", PL_op_desc[type], kid);
6999 if (kid->op_type == OP_CONST &&
7000 (kid->op_private & OPpCONST_BARE))
7002 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7003 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7004 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7005 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7006 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7008 op_getmad(kid,newop,'K');
7013 kid->op_sibling = sibl;
7016 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7017 bad_type(numargs, "hash", PL_op_desc[type], kid);
7022 OP * const newop = newUNOP(OP_NULL, 0, kid);
7023 kid->op_sibling = 0;
7025 newop->op_next = newop;
7027 kid->op_sibling = sibl;
7032 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7033 if (kid->op_type == OP_CONST &&
7034 (kid->op_private & OPpCONST_BARE))
7036 OP * const newop = newGVOP(OP_GV, 0,
7037 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7038 if (!(o->op_private & 1) && /* if not unop */
7039 kid == cLISTOPo->op_last)
7040 cLISTOPo->op_last = newop;
7042 op_getmad(kid,newop,'K');
7048 else if (kid->op_type == OP_READLINE) {
7049 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7050 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7053 I32 flags = OPf_SPECIAL;
7057 /* is this op a FH constructor? */
7058 if (is_handle_constructor(o,numargs)) {
7059 const char *name = NULL;
7063 /* Set a flag to tell rv2gv to vivify
7064 * need to "prove" flag does not mean something
7065 * else already - NI-S 1999/05/07
7068 if (kid->op_type == OP_PADSV) {
7070 = PAD_COMPNAME_SV(kid->op_targ);
7071 name = SvPV_const(namesv, len);
7073 else if (kid->op_type == OP_RV2SV
7074 && kUNOP->op_first->op_type == OP_GV)
7076 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7078 len = GvNAMELEN(gv);
7080 else if (kid->op_type == OP_AELEM
7081 || kid->op_type == OP_HELEM)
7084 OP *op = ((BINOP*)kid)->op_first;
7088 const char * const a =
7089 kid->op_type == OP_AELEM ?
7091 if (((op->op_type == OP_RV2AV) ||
7092 (op->op_type == OP_RV2HV)) &&
7093 (firstop = ((UNOP*)op)->op_first) &&
7094 (firstop->op_type == OP_GV)) {
7095 /* packagevar $a[] or $h{} */
7096 GV * const gv = cGVOPx_gv(firstop);
7104 else if (op->op_type == OP_PADAV
7105 || op->op_type == OP_PADHV) {
7106 /* lexicalvar $a[] or $h{} */
7107 const char * const padname =
7108 PAD_COMPNAME_PV(op->op_targ);
7117 name = SvPV_const(tmpstr, len);
7122 name = "__ANONIO__";
7129 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7130 namesv = PAD_SVl(targ);
7131 SvUPGRADE(namesv, SVt_PV);
7133 sv_setpvs(namesv, "$");
7134 sv_catpvn(namesv, name, len);
7137 kid->op_sibling = 0;
7138 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7139 kid->op_targ = targ;
7140 kid->op_private |= priv;
7142 kid->op_sibling = sibl;
7148 mod(scalar(kid), type);
7152 tokid = &kid->op_sibling;
7153 kid = kid->op_sibling;
7156 if (kid && kid->op_type != OP_STUB)
7157 return too_many_arguments(o,OP_DESC(o));
7158 o->op_private |= numargs;
7160 /* FIXME - should the numargs move as for the PERL_MAD case? */
7161 o->op_private |= numargs;
7163 return too_many_arguments(o,OP_DESC(o));
7167 else if (PL_opargs[type] & OA_DEFGV) {
7169 OP *newop = newUNOP(type, 0, newDEFSVOP());
7170 op_getmad(o,newop,'O');
7173 /* Ordering of these two is important to keep f_map.t passing. */
7175 return newUNOP(type, 0, newDEFSVOP());
7180 while (oa & OA_OPTIONAL)
7182 if (oa && oa != OA_LIST)
7183 return too_few_arguments(o,OP_DESC(o));
7189 Perl_ck_glob(pTHX_ OP *o)
7194 PERL_ARGS_ASSERT_CK_GLOB;
7197 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7198 append_elem(OP_GLOB, o, newDEFSVOP());
7200 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7201 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7203 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7206 #if !defined(PERL_EXTERNAL_GLOB)
7207 /* XXX this can be tightened up and made more failsafe. */
7208 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7211 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7212 newSVpvs("File::Glob"), NULL, NULL, NULL);
7213 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7214 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7215 GvCV(gv) = GvCV(glob_gv);
7216 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7217 GvIMPORTED_CV_on(gv);
7221 #endif /* PERL_EXTERNAL_GLOB */
7223 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7224 append_elem(OP_GLOB, o,
7225 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7226 o->op_type = OP_LIST;
7227 o->op_ppaddr = PL_ppaddr[OP_LIST];
7228 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7229 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7230 cLISTOPo->op_first->op_targ = 0;
7231 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7232 append_elem(OP_LIST, o,
7233 scalar(newUNOP(OP_RV2CV, 0,
7234 newGVOP(OP_GV, 0, gv)))));
7235 o = newUNOP(OP_NULL, 0, ck_subr(o));
7236 o->op_targ = OP_GLOB; /* hint at what it used to be */
7239 gv = newGVgen("main");
7241 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7247 Perl_ck_grep(pTHX_ OP *o)
7252 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7255 PERL_ARGS_ASSERT_CK_GREP;
7257 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7258 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7260 if (o->op_flags & OPf_STACKED) {
7263 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7264 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7265 return no_fh_allowed(o);
7266 for (k = kid; k; k = k->op_next) {
7269 NewOp(1101, gwop, 1, LOGOP);
7270 kid->op_next = (OP*)gwop;
7271 o->op_flags &= ~OPf_STACKED;
7273 kid = cLISTOPo->op_first->op_sibling;
7274 if (type == OP_MAPWHILE)
7279 if (PL_parser && PL_parser->error_count)
7281 kid = cLISTOPo->op_first->op_sibling;
7282 if (kid->op_type != OP_NULL)
7283 Perl_croak(aTHX_ "panic: ck_grep");
7284 kid = kUNOP->op_first;
7287 NewOp(1101, gwop, 1, LOGOP);
7288 gwop->op_type = type;
7289 gwop->op_ppaddr = PL_ppaddr[type];
7290 gwop->op_first = listkids(o);
7291 gwop->op_flags |= OPf_KIDS;
7292 gwop->op_other = LINKLIST(kid);
7293 kid->op_next = (OP*)gwop;
7294 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7295 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7296 o->op_private = gwop->op_private = 0;
7297 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7300 o->op_private = gwop->op_private = OPpGREP_LEX;
7301 gwop->op_targ = o->op_targ = offset;
7304 kid = cLISTOPo->op_first->op_sibling;
7305 if (!kid || !kid->op_sibling)
7306 return too_few_arguments(o,OP_DESC(o));
7307 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7308 mod(kid, OP_GREPSTART);
7314 Perl_ck_index(pTHX_ OP *o)
7316 PERL_ARGS_ASSERT_CK_INDEX;
7318 if (o->op_flags & OPf_KIDS) {
7319 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7321 kid = kid->op_sibling; /* get past "big" */
7322 if (kid && kid->op_type == OP_CONST)
7323 fbm_compile(((SVOP*)kid)->op_sv, 0);
7329 Perl_ck_lfun(pTHX_ OP *o)
7331 const OPCODE type = o->op_type;
7333 PERL_ARGS_ASSERT_CK_LFUN;
7335 return modkids(ck_fun(o), type);
7339 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7341 PERL_ARGS_ASSERT_CK_DEFINED;
7343 if ((o->op_flags & OPf_KIDS)) {
7344 switch (cUNOPo->op_first->op_type) {
7346 /* This is needed for
7347 if (defined %stash::)
7348 to work. Do not break Tk.
7350 break; /* Globals via GV can be undef */
7352 case OP_AASSIGN: /* Is this a good idea? */
7353 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7354 "defined(@array) is deprecated");
7355 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7356 "\t(Maybe you should just omit the defined()?)\n");
7360 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7361 "defined(%%hash) is deprecated");
7362 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7363 "\t(Maybe you should just omit the defined()?)\n");
7374 Perl_ck_readline(pTHX_ OP *o)
7376 PERL_ARGS_ASSERT_CK_READLINE;
7378 if (!(o->op_flags & OPf_KIDS)) {
7380 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7382 op_getmad(o,newop,'O');
7392 Perl_ck_rfun(pTHX_ OP *o)
7394 const OPCODE type = o->op_type;
7396 PERL_ARGS_ASSERT_CK_RFUN;
7398 return refkids(ck_fun(o), type);
7402 Perl_ck_listiob(pTHX_ OP *o)
7406 PERL_ARGS_ASSERT_CK_LISTIOB;
7408 kid = cLISTOPo->op_first;
7411 kid = cLISTOPo->op_first;
7413 if (kid->op_type == OP_PUSHMARK)
7414 kid = kid->op_sibling;
7415 if (kid && o->op_flags & OPf_STACKED)
7416 kid = kid->op_sibling;
7417 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7418 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7419 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7420 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7421 cLISTOPo->op_first->op_sibling = kid;
7422 cLISTOPo->op_last = kid;
7423 kid = kid->op_sibling;
7428 append_elem(o->op_type, o, newDEFSVOP());
7434 Perl_ck_smartmatch(pTHX_ OP *o)
7437 if (0 == (o->op_flags & OPf_SPECIAL)) {
7438 OP *first = cBINOPo->op_first;
7439 OP *second = first->op_sibling;
7441 /* Implicitly take a reference to an array or hash */
7442 first->op_sibling = NULL;
7443 first = cBINOPo->op_first = ref_array_or_hash(first);
7444 second = first->op_sibling = ref_array_or_hash(second);
7446 /* Implicitly take a reference to a regular expression */
7447 if (first->op_type == OP_MATCH) {
7448 first->op_type = OP_QR;
7449 first->op_ppaddr = PL_ppaddr[OP_QR];
7451 if (second->op_type == OP_MATCH) {
7452 second->op_type = OP_QR;
7453 second->op_ppaddr = PL_ppaddr[OP_QR];
7462 Perl_ck_sassign(pTHX_ OP *o)
7465 OP * const kid = cLISTOPo->op_first;
7467 PERL_ARGS_ASSERT_CK_SASSIGN;
7469 /* has a disposable target? */
7470 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7471 && !(kid->op_flags & OPf_STACKED)
7472 /* Cannot steal the second time! */
7473 && !(kid->op_private & OPpTARGET_MY)
7474 /* Keep the full thing for madskills */
7478 OP * const kkid = kid->op_sibling;
7480 /* Can just relocate the target. */
7481 if (kkid && kkid->op_type == OP_PADSV
7482 && !(kkid->op_private & OPpLVAL_INTRO))
7484 kid->op_targ = kkid->op_targ;
7486 /* Now we do not need PADSV and SASSIGN. */
7487 kid->op_sibling = o->op_sibling; /* NULL */
7488 cLISTOPo->op_first = NULL;
7491 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7495 if (kid->op_sibling) {
7496 OP *kkid = kid->op_sibling;
7497 if (kkid->op_type == OP_PADSV
7498 && (kkid->op_private & OPpLVAL_INTRO)
7499 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7500 const PADOFFSET target = kkid->op_targ;
7501 OP *const other = newOP(OP_PADSV,
7503 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7504 OP *const first = newOP(OP_NULL, 0);
7505 OP *const nullop = newCONDOP(0, first, o, other);
7506 OP *const condop = first->op_next;
7507 /* hijacking PADSTALE for uninitialized state variables */
7508 SvPADSTALE_on(PAD_SVl(target));
7510 condop->op_type = OP_ONCE;
7511 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7512 condop->op_targ = target;
7513 other->op_targ = target;
7515 /* Because we change the type of the op here, we will skip the
7516 assinment binop->op_last = binop->op_first->op_sibling; at the
7517 end of Perl_newBINOP(). So need to do it here. */
7518 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7527 Perl_ck_match(pTHX_ OP *o)
7531 PERL_ARGS_ASSERT_CK_MATCH;
7533 if (o->op_type != OP_QR && PL_compcv) {
7534 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7535 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7536 o->op_targ = offset;
7537 o->op_private |= OPpTARGET_MY;
7540 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7541 o->op_private |= OPpRUNTIME;
7546 Perl_ck_method(pTHX_ OP *o)
7548 OP * const kid = cUNOPo->op_first;
7550 PERL_ARGS_ASSERT_CK_METHOD;
7552 if (kid->op_type == OP_CONST) {
7553 SV* sv = kSVOP->op_sv;
7554 const char * const method = SvPVX_const(sv);
7555 if (!(strchr(method, ':') || strchr(method, '\''))) {
7557 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7558 sv = newSVpvn_share(method, SvCUR(sv), 0);
7561 kSVOP->op_sv = NULL;
7563 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7565 op_getmad(o,cmop,'O');
7576 Perl_ck_null(pTHX_ OP *o)
7578 PERL_ARGS_ASSERT_CK_NULL;
7579 PERL_UNUSED_CONTEXT;
7584 Perl_ck_open(pTHX_ OP *o)
7587 HV * const table = GvHV(PL_hintgv);
7589 PERL_ARGS_ASSERT_CK_OPEN;
7592 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7595 const char *d = SvPV_const(*svp, len);
7596 const I32 mode = mode_from_discipline(d, len);
7597 if (mode & O_BINARY)
7598 o->op_private |= OPpOPEN_IN_RAW;
7599 else if (mode & O_TEXT)
7600 o->op_private |= OPpOPEN_IN_CRLF;
7603 svp = hv_fetchs(table, "open_OUT", FALSE);
7606 const char *d = SvPV_const(*svp, len);
7607 const I32 mode = mode_from_discipline(d, len);
7608 if (mode & O_BINARY)
7609 o->op_private |= OPpOPEN_OUT_RAW;
7610 else if (mode & O_TEXT)
7611 o->op_private |= OPpOPEN_OUT_CRLF;
7614 if (o->op_type == OP_BACKTICK) {
7615 if (!(o->op_flags & OPf_KIDS)) {
7616 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7618 op_getmad(o,newop,'O');
7627 /* In case of three-arg dup open remove strictness
7628 * from the last arg if it is a bareword. */
7629 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7630 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7634 if ((last->op_type == OP_CONST) && /* The bareword. */
7635 (last->op_private & OPpCONST_BARE) &&
7636 (last->op_private & OPpCONST_STRICT) &&
7637 (oa = first->op_sibling) && /* The fh. */
7638 (oa = oa->op_sibling) && /* The mode. */
7639 (oa->op_type == OP_CONST) &&
7640 SvPOK(((SVOP*)oa)->op_sv) &&
7641 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7642 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7643 (last == oa->op_sibling)) /* The bareword. */
7644 last->op_private &= ~OPpCONST_STRICT;
7650 Perl_ck_repeat(pTHX_ OP *o)
7652 PERL_ARGS_ASSERT_CK_REPEAT;
7654 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7655 o->op_private |= OPpREPEAT_DOLIST;
7656 cBINOPo->op_first = force_list(cBINOPo->op_first);
7664 Perl_ck_require(pTHX_ OP *o)
7669 PERL_ARGS_ASSERT_CK_REQUIRE;
7671 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7672 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7674 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7675 SV * const sv = kid->op_sv;
7676 U32 was_readonly = SvREADONLY(sv);
7683 sv_force_normal_flags(sv, 0);
7684 assert(!SvREADONLY(sv));
7694 for (; s < end; s++) {
7695 if (*s == ':' && s[1] == ':') {
7697 Move(s+2, s+1, end - s - 1, char);
7702 sv_catpvs(sv, ".pm");
7703 SvFLAGS(sv) |= was_readonly;
7707 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7708 /* handle override, if any */
7709 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7710 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7711 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7712 gv = gvp ? *gvp : NULL;
7716 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7717 OP * const kid = cUNOPo->op_first;
7720 cUNOPo->op_first = 0;
7724 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7725 append_elem(OP_LIST, kid,
7726 scalar(newUNOP(OP_RV2CV, 0,
7729 op_getmad(o,newop,'O');
7733 return scalar(ck_fun(o));
7737 Perl_ck_return(pTHX_ OP *o)
7742 PERL_ARGS_ASSERT_CK_RETURN;
7744 kid = cLISTOPo->op_first->op_sibling;
7745 if (CvLVALUE(PL_compcv)) {
7746 for (; kid; kid = kid->op_sibling)
7747 mod(kid, OP_LEAVESUBLV);
7749 for (; kid; kid = kid->op_sibling)
7750 if ((kid->op_type == OP_NULL)
7751 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7752 /* This is a do block */
7753 OP *op = kUNOP->op_first;
7754 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7755 op = cUNOPx(op)->op_first;
7756 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7757 /* Force the use of the caller's context */
7758 op->op_flags |= OPf_SPECIAL;
7767 Perl_ck_select(pTHX_ OP *o)
7772 PERL_ARGS_ASSERT_CK_SELECT;
7774 if (o->op_flags & OPf_KIDS) {
7775 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7776 if (kid && kid->op_sibling) {
7777 o->op_type = OP_SSELECT;
7778 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7780 return fold_constants(o);
7784 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7785 if (kid && kid->op_type == OP_RV2GV)
7786 kid->op_private &= ~HINT_STRICT_REFS;
7791 Perl_ck_shift(pTHX_ OP *o)
7794 const I32 type = o->op_type;
7796 PERL_ARGS_ASSERT_CK_SHIFT;
7798 if (!(o->op_flags & OPf_KIDS)) {
7801 if (!CvUNIQUE(PL_compcv)) {
7802 o->op_flags |= OPf_SPECIAL;
7806 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
7808 OP * const oldo = o;
7809 o = newUNOP(type, 0, scalar(argop));
7810 op_getmad(oldo,o,'O');
7814 return newUNOP(type, 0, scalar(argop));
7817 return scalar(modkids(ck_fun(o), type));
7821 Perl_ck_sort(pTHX_ OP *o)
7826 PERL_ARGS_ASSERT_CK_SORT;
7828 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7829 HV * const hinthv = GvHV(PL_hintgv);
7831 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7833 const I32 sorthints = (I32)SvIV(*svp);
7834 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7835 o->op_private |= OPpSORT_QSORT;
7836 if ((sorthints & HINT_SORT_STABLE) != 0)
7837 o->op_private |= OPpSORT_STABLE;
7842 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7844 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7845 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7847 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7849 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7851 if (kid->op_type == OP_SCOPE) {
7855 else if (kid->op_type == OP_LEAVE) {
7856 if (o->op_type == OP_SORT) {
7857 op_null(kid); /* wipe out leave */
7860 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7861 if (k->op_next == kid)
7863 /* don't descend into loops */
7864 else if (k->op_type == OP_ENTERLOOP
7865 || k->op_type == OP_ENTERITER)
7867 k = cLOOPx(k)->op_lastop;
7872 kid->op_next = 0; /* just disconnect the leave */
7873 k = kLISTOP->op_first;
7878 if (o->op_type == OP_SORT) {
7879 /* provide scalar context for comparison function/block */
7885 o->op_flags |= OPf_SPECIAL;
7887 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7890 firstkid = firstkid->op_sibling;
7893 /* provide list context for arguments */
7894 if (o->op_type == OP_SORT)
7901 S_simplify_sort(pTHX_ OP *o)
7904 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7910 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7912 if (!(o->op_flags & OPf_STACKED))
7914 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7915 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7916 kid = kUNOP->op_first; /* get past null */
7917 if (kid->op_type != OP_SCOPE)
7919 kid = kLISTOP->op_last; /* get past scope */
7920 switch(kid->op_type) {
7928 k = kid; /* remember this node*/
7929 if (kBINOP->op_first->op_type != OP_RV2SV)
7931 kid = kBINOP->op_first; /* get past cmp */
7932 if (kUNOP->op_first->op_type != OP_GV)
7934 kid = kUNOP->op_first; /* get past rv2sv */
7936 if (GvSTASH(gv) != PL_curstash)
7938 gvname = GvNAME(gv);
7939 if (*gvname == 'a' && gvname[1] == '\0')
7941 else if (*gvname == 'b' && gvname[1] == '\0')
7946 kid = k; /* back to cmp */
7947 if (kBINOP->op_last->op_type != OP_RV2SV)
7949 kid = kBINOP->op_last; /* down to 2nd arg */
7950 if (kUNOP->op_first->op_type != OP_GV)
7952 kid = kUNOP->op_first; /* get past rv2sv */
7954 if (GvSTASH(gv) != PL_curstash)
7956 gvname = GvNAME(gv);
7958 ? !(*gvname == 'a' && gvname[1] == '\0')
7959 : !(*gvname == 'b' && gvname[1] == '\0'))
7961 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7963 o->op_private |= OPpSORT_DESCEND;
7964 if (k->op_type == OP_NCMP)
7965 o->op_private |= OPpSORT_NUMERIC;
7966 if (k->op_type == OP_I_NCMP)
7967 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7968 kid = cLISTOPo->op_first->op_sibling;
7969 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7971 op_getmad(kid,o,'S'); /* then delete it */
7973 op_free(kid); /* then delete it */
7978 Perl_ck_split(pTHX_ OP *o)
7983 PERL_ARGS_ASSERT_CK_SPLIT;
7985 if (o->op_flags & OPf_STACKED)
7986 return no_fh_allowed(o);
7988 kid = cLISTOPo->op_first;
7989 if (kid->op_type != OP_NULL)
7990 Perl_croak(aTHX_ "panic: ck_split");
7991 kid = kid->op_sibling;
7992 op_free(cLISTOPo->op_first);
7993 cLISTOPo->op_first = kid;
7995 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7996 cLISTOPo->op_last = kid; /* There was only one element previously */
7999 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8000 OP * const sibl = kid->op_sibling;
8001 kid->op_sibling = 0;
8002 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8003 if (cLISTOPo->op_first == cLISTOPo->op_last)
8004 cLISTOPo->op_last = kid;
8005 cLISTOPo->op_first = kid;
8006 kid->op_sibling = sibl;
8009 kid->op_type = OP_PUSHRE;
8010 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8012 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8013 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8014 "Use of /g modifier is meaningless in split");
8017 if (!kid->op_sibling)
8018 append_elem(OP_SPLIT, o, newDEFSVOP());
8020 kid = kid->op_sibling;
8023 if (!kid->op_sibling)
8024 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8025 assert(kid->op_sibling);
8027 kid = kid->op_sibling;
8030 if (kid->op_sibling)
8031 return too_many_arguments(o,OP_DESC(o));
8037 Perl_ck_join(pTHX_ OP *o)
8039 const OP * const kid = cLISTOPo->op_first->op_sibling;
8041 PERL_ARGS_ASSERT_CK_JOIN;
8043 if (kid && kid->op_type == OP_MATCH) {
8044 if (ckWARN(WARN_SYNTAX)) {
8045 const REGEXP *re = PM_GETRE(kPMOP);
8046 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8047 const STRLEN len = re ? RX_PRELEN(re) : 6;
8048 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8049 "/%.*s/ should probably be written as \"%.*s\"",
8050 (int)len, pmstr, (int)len, pmstr);
8057 Perl_ck_subr(pTHX_ OP *o)
8060 OP *prev = ((cUNOPo->op_first->op_sibling)
8061 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
8062 OP *o2 = prev->op_sibling;
8064 const char *proto = NULL;
8065 const char *proto_end = NULL;
8070 I32 contextclass = 0;
8071 const char *e = NULL;
8074 PERL_ARGS_ASSERT_CK_SUBR;
8076 o->op_private |= OPpENTERSUB_HASTARG;
8077 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
8078 if (cvop->op_type == OP_RV2CV) {
8079 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
8080 op_null(cvop); /* disable rv2cv */
8081 if (!(o->op_private & OPpENTERSUB_AMPER)) {
8082 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
8084 switch (tmpop->op_type) {
8086 gv = cGVOPx_gv(tmpop);
8089 tmpop->op_private |= OPpEARLY_CV;
8092 SV *sv = cSVOPx_sv(tmpop);
8093 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8097 if (cv && SvPOK(cv)) {
8099 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8100 proto = SvPV(MUTABLE_SV(cv), len);
8101 proto_end = proto + len;
8105 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8106 if (o2->op_type == OP_CONST)
8107 o2->op_private &= ~OPpCONST_STRICT;
8108 else if (o2->op_type == OP_LIST) {
8109 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8110 if (sib && sib->op_type == OP_CONST)
8111 sib->op_private &= ~OPpCONST_STRICT;
8114 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8115 if (PERLDB_SUB && PL_curstash != PL_debstash)
8116 o->op_private |= OPpENTERSUB_DB;
8117 while (o2 != cvop) {
8119 if (PL_madskills && o2->op_type == OP_STUB) {
8120 o2 = o2->op_sibling;
8123 if (PL_madskills && o2->op_type == OP_NULL)
8124 o3 = ((UNOP*)o2)->op_first;
8128 if (proto >= proto_end)
8129 return too_many_arguments(o, gv_ename(namegv));
8137 /* _ must be at the end */
8138 if (proto[1] && proto[1] != ';')
8153 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8155 arg == 1 ? "block or sub {}" : "sub {}",
8156 gv_ename(namegv), o3);
8159 /* '*' allows any scalar type, including bareword */
8162 if (o3->op_type == OP_RV2GV)
8163 goto wrapref; /* autoconvert GLOB -> GLOBref */
8164 else if (o3->op_type == OP_CONST)
8165 o3->op_private &= ~OPpCONST_STRICT;
8166 else if (o3->op_type == OP_ENTERSUB) {
8167 /* accidental subroutine, revert to bareword */
8168 OP *gvop = ((UNOP*)o3)->op_first;
8169 if (gvop && gvop->op_type == OP_NULL) {
8170 gvop = ((UNOP*)gvop)->op_first;
8172 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8175 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8176 (gvop = ((UNOP*)gvop)->op_first) &&
8177 gvop->op_type == OP_GV)
8179 GV * const gv = cGVOPx_gv(gvop);
8180 OP * const sibling = o2->op_sibling;
8181 SV * const n = newSVpvs("");
8183 OP * const oldo2 = o2;
8187 gv_fullname4(n, gv, "", FALSE);
8188 o2 = newSVOP(OP_CONST, 0, n);
8189 op_getmad(oldo2,o2,'O');
8190 prev->op_sibling = o2;
8191 o2->op_sibling = sibling;
8207 if (contextclass++ == 0) {
8208 e = strchr(proto, ']');
8209 if (!e || e == proto)
8218 const char *p = proto;
8219 const char *const end = proto;
8221 while (*--p != '[') {}
8222 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8224 gv_ename(namegv), o3);
8229 if (o3->op_type == OP_RV2GV)
8232 bad_type(arg, "symbol", gv_ename(namegv), o3);
8235 if (o3->op_type == OP_ENTERSUB)
8238 bad_type(arg, "subroutine entry", gv_ename(namegv),
8242 if (o3->op_type == OP_RV2SV ||
8243 o3->op_type == OP_PADSV ||
8244 o3->op_type == OP_HELEM ||
8245 o3->op_type == OP_AELEM)
8248 bad_type(arg, "scalar", gv_ename(namegv), o3);
8251 if (o3->op_type == OP_RV2AV ||
8252 o3->op_type == OP_PADAV)
8255 bad_type(arg, "array", gv_ename(namegv), o3);
8258 if (o3->op_type == OP_RV2HV ||
8259 o3->op_type == OP_PADHV)
8262 bad_type(arg, "hash", gv_ename(namegv), o3);
8267 OP* const sib = kid->op_sibling;
8268 kid->op_sibling = 0;
8269 o2 = newUNOP(OP_REFGEN, 0, kid);
8270 o2->op_sibling = sib;
8271 prev->op_sibling = o2;
8273 if (contextclass && e) {
8288 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8289 gv_ename(namegv), SVfARG(cv));
8294 mod(o2, OP_ENTERSUB);
8296 o2 = o2->op_sibling;
8298 if (o2 == cvop && proto && *proto == '_') {
8299 /* generate an access to $_ */
8301 o2->op_sibling = prev->op_sibling;
8302 prev->op_sibling = o2; /* instead of cvop */
8304 if (proto && !optional && proto_end > proto &&
8305 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8306 return too_few_arguments(o, gv_ename(namegv));
8309 OP * const oldo = o;
8313 o=newSVOP(OP_CONST, 0, newSViv(0));
8314 op_getmad(oldo,o,'O');
8320 Perl_ck_svconst(pTHX_ OP *o)
8322 PERL_ARGS_ASSERT_CK_SVCONST;
8323 PERL_UNUSED_CONTEXT;
8324 SvREADONLY_on(cSVOPo->op_sv);
8329 Perl_ck_chdir(pTHX_ OP *o)
8331 if (o->op_flags & OPf_KIDS) {
8332 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8334 if (kid && kid->op_type == OP_CONST &&
8335 (kid->op_private & OPpCONST_BARE))
8337 o->op_flags |= OPf_SPECIAL;
8338 kid->op_private &= ~OPpCONST_STRICT;
8345 Perl_ck_trunc(pTHX_ OP *o)
8347 PERL_ARGS_ASSERT_CK_TRUNC;
8349 if (o->op_flags & OPf_KIDS) {
8350 SVOP *kid = (SVOP*)cUNOPo->op_first;
8352 if (kid->op_type == OP_NULL)
8353 kid = (SVOP*)kid->op_sibling;
8354 if (kid && kid->op_type == OP_CONST &&
8355 (kid->op_private & OPpCONST_BARE))
8357 o->op_flags |= OPf_SPECIAL;
8358 kid->op_private &= ~OPpCONST_STRICT;
8365 Perl_ck_unpack(pTHX_ OP *o)
8367 OP *kid = cLISTOPo->op_first;
8369 PERL_ARGS_ASSERT_CK_UNPACK;
8371 if (kid->op_sibling) {
8372 kid = kid->op_sibling;
8373 if (!kid->op_sibling)
8374 kid->op_sibling = newDEFSVOP();
8380 Perl_ck_substr(pTHX_ OP *o)
8382 PERL_ARGS_ASSERT_CK_SUBSTR;
8385 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8386 OP *kid = cLISTOPo->op_first;
8388 if (kid->op_type == OP_NULL)
8389 kid = kid->op_sibling;
8391 kid->op_flags |= OPf_MOD;
8398 Perl_ck_each(pTHX_ OP *o)
8401 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8403 PERL_ARGS_ASSERT_CK_EACH;
8406 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8407 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8408 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8409 o->op_type = new_type;
8410 o->op_ppaddr = PL_ppaddr[new_type];
8412 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8413 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8415 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8422 /* caller is supposed to assign the return to the
8423 container of the rep_op var */
8425 S_opt_scalarhv(pTHX_ OP *rep_op) {
8429 PERL_ARGS_ASSERT_OPT_SCALARHV;
8431 NewOp(1101, unop, 1, UNOP);
8432 unop->op_type = (OPCODE)OP_BOOLKEYS;
8433 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8434 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8435 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8436 unop->op_first = rep_op;
8437 unop->op_next = rep_op->op_next;
8438 rep_op->op_next = (OP*)unop;
8439 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8440 unop->op_sibling = rep_op->op_sibling;
8441 rep_op->op_sibling = NULL;
8442 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8443 if (rep_op->op_type == OP_PADHV) {
8444 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8445 rep_op->op_flags |= OPf_WANT_LIST;
8450 /* Checks if o acts as an in-place operator on an array. oright points to the
8451 * beginning of the right-hand side. Returns the left-hand side of the
8452 * assignment if o acts in-place, or NULL otherwise. */
8455 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8459 PERL_ARGS_ASSERT_IS_INPLACE_AV;
8462 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8463 || oright->op_next != o
8464 || (oright->op_private & OPpLVAL_INTRO)
8468 /* o2 follows the chain of op_nexts through the LHS of the
8469 * assign (if any) to the aassign op itself */
8471 if (!o2 || o2->op_type != OP_NULL)
8474 if (!o2 || o2->op_type != OP_PUSHMARK)
8477 if (o2 && o2->op_type == OP_GV)
8480 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8481 || (o2->op_private & OPpLVAL_INTRO)
8486 if (!o2 || o2->op_type != OP_NULL)
8489 if (!o2 || o2->op_type != OP_AASSIGN
8490 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8493 /* check that the sort is the first arg on RHS of assign */
8495 o2 = cUNOPx(o2)->op_first;
8496 if (!o2 || o2->op_type != OP_NULL)
8498 o2 = cUNOPx(o2)->op_first;
8499 if (!o2 || o2->op_type != OP_PUSHMARK)
8501 if (o2->op_sibling != o)
8504 /* check the array is the same on both sides */
8505 if (oleft->op_type == OP_RV2AV) {
8506 if (oright->op_type != OP_RV2AV
8507 || !cUNOPx(oright)->op_first
8508 || cUNOPx(oright)->op_first->op_type != OP_GV
8509 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8510 cGVOPx_gv(cUNOPx(oright)->op_first)
8514 else if (oright->op_type != OP_PADAV
8515 || oright->op_targ != oleft->op_targ
8522 /* A peephole optimizer. We visit the ops in the order they're to execute.
8523 * See the comments at the top of this file for more details about when
8524 * peep() is called */
8527 Perl_peep(pTHX_ register OP *o, peep_next_t *next_peep)
8530 register OP* oldop = NULL;
8532 PERL_ARGS_ASSERT_PEEP;
8534 if (!o || o->op_opt)
8538 SAVEVPTR(PL_curcop);
8539 for (; o; o = o->op_next) {
8542 /* By default, this op has now been optimised. A couple of cases below
8543 clear this again. */
8546 switch (o->op_type) {
8549 PL_curcop = ((COP*)o); /* for warnings */
8553 if (cSVOPo->op_private & OPpCONST_STRICT)
8554 no_bareword_allowed(o);
8557 case OP_METHOD_NAMED:
8558 /* Relocate sv to the pad for thread safety.
8559 * Despite being a "constant", the SV is written to,
8560 * for reference counts, sv_upgrade() etc. */
8562 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8563 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8564 /* If op_sv is already a PADTMP then it is being used by
8565 * some pad, so make a copy. */
8566 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8567 SvREADONLY_on(PAD_SVl(ix));
8568 SvREFCNT_dec(cSVOPo->op_sv);
8570 else if (o->op_type != OP_METHOD_NAMED
8571 && cSVOPo->op_sv == &PL_sv_undef) {
8572 /* PL_sv_undef is hack - it's unsafe to store it in the
8573 AV that is the pad, because av_fetch treats values of
8574 PL_sv_undef as a "free" AV entry and will merrily
8575 replace them with a new SV, causing pad_alloc to think
8576 that this pad slot is free. (When, clearly, it is not)
8578 SvOK_off(PAD_SVl(ix));
8579 SvPADTMP_on(PAD_SVl(ix));
8580 SvREADONLY_on(PAD_SVl(ix));
8583 SvREFCNT_dec(PAD_SVl(ix));
8584 SvPADTMP_on(cSVOPo->op_sv);
8585 PAD_SETSV(ix, cSVOPo->op_sv);
8586 /* XXX I don't know how this isn't readonly already. */
8587 SvREADONLY_on(PAD_SVl(ix));
8589 cSVOPo->op_sv = NULL;
8596 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8597 if (o->op_next->op_private & OPpTARGET_MY) {
8598 if (o->op_flags & OPf_STACKED) /* chained concats */
8599 break; /* ignore_optimization */
8601 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8602 o->op_targ = o->op_next->op_targ;
8603 o->op_next->op_targ = 0;
8604 o->op_private |= OPpTARGET_MY;
8607 op_null(o->op_next);
8611 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8612 break; /* Scalar stub must produce undef. List stub is noop */
8616 if (o->op_targ == OP_NEXTSTATE
8617 || o->op_targ == OP_DBSTATE)
8619 PL_curcop = ((COP*)o);
8621 /* XXX: We avoid setting op_seq here to prevent later calls
8622 to peep() from mistakenly concluding that optimisation
8623 has already occurred. This doesn't fix the real problem,
8624 though (See 20010220.007). AMS 20010719 */
8625 /* op_seq functionality is now replaced by op_opt */
8632 if (oldop && o->op_next) {
8633 oldop->op_next = o->op_next;
8641 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8642 OP* const pop = (o->op_type == OP_PADAV) ?
8643 o->op_next : o->op_next->op_next;
8645 if (pop && pop->op_type == OP_CONST &&
8646 ((PL_op = pop->op_next)) &&
8647 pop->op_next->op_type == OP_AELEM &&
8648 !(pop->op_next->op_private &
8649 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8650 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8655 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8656 no_bareword_allowed(pop);
8657 if (o->op_type == OP_GV)
8658 op_null(o->op_next);
8659 op_null(pop->op_next);
8661 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8662 o->op_next = pop->op_next->op_next;
8663 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8664 o->op_private = (U8)i;
8665 if (o->op_type == OP_GV) {
8670 o->op_flags |= OPf_SPECIAL;
8671 o->op_type = OP_AELEMFAST;
8676 if (o->op_next->op_type == OP_RV2SV) {
8677 if (!(o->op_next->op_private & OPpDEREF)) {
8678 op_null(o->op_next);
8679 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8681 o->op_next = o->op_next->op_next;
8682 o->op_type = OP_GVSV;
8683 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8686 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8687 GV * const gv = cGVOPo_gv;
8688 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8689 /* XXX could check prototype here instead of just carping */
8690 SV * const sv = sv_newmortal();
8691 gv_efullname3(sv, gv, NULL);
8692 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8693 "%"SVf"() called too early to check prototype",
8697 else if (o->op_next->op_type == OP_READLINE
8698 && o->op_next->op_next->op_type == OP_CONCAT
8699 && (o->op_next->op_next->op_flags & OPf_STACKED))
8701 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8702 o->op_type = OP_RCATLINE;
8703 o->op_flags |= OPf_STACKED;
8704 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8705 op_null(o->op_next->op_next);
8706 op_null(o->op_next);
8716 fop = cUNOP->op_first;
8724 fop = cLOGOP->op_first;
8725 sop = fop->op_sibling;
8726 while (cLOGOP->op_other->op_type == OP_NULL)
8727 cLOGOP->op_other = cLOGOP->op_other->op_next;
8728 CALL_A_PEEP(next_peep, cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8732 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8734 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8739 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
8740 while (nop && nop->op_next) {
8741 switch (nop->op_next->op_type) {
8746 lop = nop = nop->op_next;
8757 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
8758 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8759 cLOGOP->op_first = opt_scalarhv(fop);
8760 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8761 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8777 while (cLOGOP->op_other->op_type == OP_NULL)
8778 cLOGOP->op_other = cLOGOP->op_other->op_next;
8779 CALL_A_PEEP(next_peep, cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8784 while (cLOOP->op_redoop->op_type == OP_NULL)
8785 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8786 CALL_A_PEEP(next_peep, cLOOP->op_redoop);
8787 while (cLOOP->op_nextop->op_type == OP_NULL)
8788 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8789 CALL_A_PEEP(next_peep, cLOOP->op_nextop);
8790 while (cLOOP->op_lastop->op_type == OP_NULL)
8791 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8792 CALL_A_PEEP(next_peep, cLOOP->op_lastop);
8796 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8797 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8798 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8799 cPMOP->op_pmstashstartu.op_pmreplstart
8800 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8801 CALL_A_PEEP(next_peep, cPMOP->op_pmstashstartu.op_pmreplstart);
8805 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8806 && ckWARN(WARN_SYNTAX))
8808 if (o->op_next->op_sibling) {
8809 const OPCODE type = o->op_next->op_sibling->op_type;
8810 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8811 const line_t oldline = CopLINE(PL_curcop);
8812 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8813 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8814 "Statement unlikely to be reached");
8815 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8816 "\t(Maybe you meant system() when you said exec()?)\n");
8817 CopLINE_set(PL_curcop, oldline);
8828 const char *key = NULL;
8831 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8834 /* Make the CONST have a shared SV */
8835 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8836 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8837 key = SvPV_const(sv, keylen);
8838 lexname = newSVpvn_share(key,
8839 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8845 if ((o->op_private & (OPpLVAL_INTRO)))
8848 rop = (UNOP*)((BINOP*)o)->op_first;
8849 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8851 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8852 if (!SvPAD_TYPED(lexname))
8854 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8855 if (!fields || !GvHV(*fields))
8857 key = SvPV_const(*svp, keylen);
8858 if (!hv_fetch(GvHV(*fields), key,
8859 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8861 Perl_croak(aTHX_ "No such class field \"%s\" "
8862 "in variable %s of type %s",
8863 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8876 SVOP *first_key_op, *key_op;
8878 if ((o->op_private & (OPpLVAL_INTRO))
8879 /* I bet there's always a pushmark... */
8880 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8881 /* hmmm, no optimization if list contains only one key. */
8883 rop = (UNOP*)((LISTOP*)o)->op_last;
8884 if (rop->op_type != OP_RV2HV)
8886 if (rop->op_first->op_type == OP_PADSV)
8887 /* @$hash{qw(keys here)} */
8888 rop = (UNOP*)rop->op_first;
8890 /* @{$hash}{qw(keys here)} */
8891 if (rop->op_first->op_type == OP_SCOPE
8892 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8894 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8900 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8901 if (!SvPAD_TYPED(lexname))
8903 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8904 if (!fields || !GvHV(*fields))
8906 /* Again guessing that the pushmark can be jumped over.... */
8907 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8908 ->op_first->op_sibling;
8909 for (key_op = first_key_op; key_op;
8910 key_op = (SVOP*)key_op->op_sibling) {
8911 if (key_op->op_type != OP_CONST)
8913 svp = cSVOPx_svp(key_op);
8914 key = SvPV_const(*svp, keylen);
8915 if (!hv_fetch(GvHV(*fields), key,
8916 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8918 Perl_croak(aTHX_ "No such class field \"%s\" "
8919 "in variable %s of type %s",
8920 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8929 && ( oldop->op_type == OP_AELEM
8930 || oldop->op_type == OP_PADSV
8931 || oldop->op_type == OP_RV2SV
8932 || oldop->op_type == OP_RV2GV
8933 || oldop->op_type == OP_HELEM
8935 && (oldop->op_private & OPpDEREF)
8937 o->op_private |= OPpDEREFed;
8941 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8945 /* check that RHS of sort is a single plain array */
8946 OP *oright = cUNOPo->op_first;
8947 if (!oright || oright->op_type != OP_PUSHMARK)
8950 /* reverse sort ... can be optimised. */
8951 if (!cUNOPo->op_sibling) {
8952 /* Nothing follows us on the list. */
8953 OP * const reverse = o->op_next;
8955 if (reverse->op_type == OP_REVERSE &&
8956 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8957 OP * const pushmark = cUNOPx(reverse)->op_first;
8958 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8959 && (cUNOPx(pushmark)->op_sibling == o)) {
8960 /* reverse -> pushmark -> sort */
8961 o->op_private |= OPpSORT_REVERSE;
8963 pushmark->op_next = oright->op_next;
8969 /* make @a = sort @a act in-place */
8971 oright = cUNOPx(oright)->op_sibling;
8974 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8975 oright = cUNOPx(oright)->op_sibling;
8978 oleft = is_inplace_av(o, oright);
8982 /* transfer MODishness etc from LHS arg to RHS arg */
8983 oright->op_flags = oleft->op_flags;
8984 o->op_private |= OPpSORT_INPLACE;
8986 /* excise push->gv->rv2av->null->aassign */
8987 o2 = o->op_next->op_next;
8988 op_null(o2); /* PUSHMARK */
8990 if (o2->op_type == OP_GV) {
8991 op_null(o2); /* GV */
8994 op_null(o2); /* RV2AV or PADAV */
8995 o2 = o2->op_next->op_next;
8996 op_null(o2); /* AASSIGN */
8998 o->op_next = o2->op_next;
9004 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9007 LISTOP *enter, *exlist;
9009 /* @a = reverse @a */
9010 if ((oright = cLISTOPo->op_first)
9011 && (oright->op_type == OP_PUSHMARK)
9012 && (oright = oright->op_sibling)
9013 && (oleft = is_inplace_av(o, oright))) {
9016 /* transfer MODishness etc from LHS arg to RHS arg */
9017 oright->op_flags = oleft->op_flags;
9018 o->op_private |= OPpREVERSE_INPLACE;
9020 /* excise push->gv->rv2av->null->aassign */
9021 o2 = o->op_next->op_next;
9022 op_null(o2); /* PUSHMARK */
9024 if (o2->op_type == OP_GV) {
9025 op_null(o2); /* GV */
9028 op_null(o2); /* RV2AV or PADAV */
9029 o2 = o2->op_next->op_next;
9030 op_null(o2); /* AASSIGN */
9032 o->op_next = o2->op_next;
9036 enter = (LISTOP *) o->op_next;
9039 if (enter->op_type == OP_NULL) {
9040 enter = (LISTOP *) enter->op_next;
9044 /* for $a (...) will have OP_GV then OP_RV2GV here.
9045 for (...) just has an OP_GV. */
9046 if (enter->op_type == OP_GV) {
9047 gvop = (OP *) enter;
9048 enter = (LISTOP *) enter->op_next;
9051 if (enter->op_type == OP_RV2GV) {
9052 enter = (LISTOP *) enter->op_next;
9058 if (enter->op_type != OP_ENTERITER)
9061 iter = enter->op_next;
9062 if (!iter || iter->op_type != OP_ITER)
9065 expushmark = enter->op_first;
9066 if (!expushmark || expushmark->op_type != OP_NULL
9067 || expushmark->op_targ != OP_PUSHMARK)
9070 exlist = (LISTOP *) expushmark->op_sibling;
9071 if (!exlist || exlist->op_type != OP_NULL
9072 || exlist->op_targ != OP_LIST)
9075 if (exlist->op_last != o) {
9076 /* Mmm. Was expecting to point back to this op. */
9079 theirmark = exlist->op_first;
9080 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9083 if (theirmark->op_sibling != o) {
9084 /* There's something between the mark and the reverse, eg
9085 for (1, reverse (...))
9090 ourmark = ((LISTOP *)o)->op_first;
9091 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9094 ourlast = ((LISTOP *)o)->op_last;
9095 if (!ourlast || ourlast->op_next != o)
9098 rv2av = ourmark->op_sibling;
9099 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9100 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9101 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9102 /* We're just reversing a single array. */
9103 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9104 enter->op_flags |= OPf_STACKED;
9107 /* We don't have control over who points to theirmark, so sacrifice
9109 theirmark->op_next = ourmark->op_next;
9110 theirmark->op_flags = ourmark->op_flags;
9111 ourlast->op_next = gvop ? gvop : (OP *) enter;
9114 enter->op_private |= OPpITER_REVERSED;
9115 iter->op_private |= OPpITER_REVERSED;
9122 UNOP *refgen, *rv2cv;
9125 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9128 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9131 rv2gv = ((BINOP *)o)->op_last;
9132 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9135 refgen = (UNOP *)((BINOP *)o)->op_first;
9137 if (!refgen || refgen->op_type != OP_REFGEN)
9140 exlist = (LISTOP *)refgen->op_first;
9141 if (!exlist || exlist->op_type != OP_NULL
9142 || exlist->op_targ != OP_LIST)
9145 if (exlist->op_first->op_type != OP_PUSHMARK)
9148 rv2cv = (UNOP*)exlist->op_last;
9150 if (rv2cv->op_type != OP_RV2CV)
9153 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9154 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9155 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9157 o->op_private |= OPpASSIGN_CV_TO_GV;
9158 rv2gv->op_private |= OPpDONT_INIT_GV;
9159 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9167 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9168 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9178 Perl_custom_op_name(pTHX_ const OP* o)
9181 const IV index = PTR2IV(o->op_ppaddr);
9185 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9187 if (!PL_custom_op_names) /* This probably shouldn't happen */
9188 return (char *)PL_op_name[OP_CUSTOM];
9190 keysv = sv_2mortal(newSViv(index));
9192 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9194 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9196 return SvPV_nolen(HeVAL(he));
9200 Perl_custom_op_desc(pTHX_ const OP* o)
9203 const IV index = PTR2IV(o->op_ppaddr);
9207 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9209 if (!PL_custom_op_descs)
9210 return (char *)PL_op_desc[OP_CUSTOM];
9212 keysv = sv_2mortal(newSViv(index));
9214 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9216 return (char *)PL_op_desc[OP_CUSTOM];
9218 return SvPV_nolen(HeVAL(he));
9223 /* Efficient sub that returns a constant scalar value. */
9225 const_sv_xsub(pTHX_ CV* cv)
9229 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9233 /* diag_listed_as: SKIPME */
9234 Perl_croak(aTHX_ "usage: %s::%s()",
9235 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9248 * c-indentation-style: bsd
9250 * indent-tabs-mode: t
9253 * ex: set ts=8 sts=4 sw=4 noet: