3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me.' --the Gaffer
18 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
21 /* This file contains the functions that create, manipulate and optimize
22 * the OP structures that hold a compiled perl program.
24 * A Perl program is compiled into a tree of OPs. Each op contains
25 * structural pointers (eg to its siblings and the next op in the
26 * execution sequence), a pointer to the function that would execute the
27 * op, plus any data specific to that op. For example, an OP_CONST op
28 * points to the pp_const() function and to an SV containing the constant
29 * value. When pp_const() is executed, its job is to push that SV onto the
32 * OPs are mainly created by the newFOO() functions, which are mainly
33 * called from the parser (in perly.y) as the code is parsed. For example
34 * the Perl code $a + $b * $c would cause the equivalent of the following
35 * to be called (oversimplifying a bit):
37 * newBINOP(OP_ADD, flags,
39 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
42 * Note that during the build of miniperl, a temporary copy of this file
43 * is made, called opmini.c.
47 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
51 An execution-order pass
53 The bottom-up pass is represented by all the "newOP" routines and
54 the ck_ routines. The bottom-upness is actually driven by yacc.
55 So at the point that a ck_ routine fires, we have no idea what the
56 context is, either upward in the syntax tree, or either forward or
57 backward in the execution order. (The bottom-up parser builds that
58 part of the execution order it knows about, but if you follow the "next"
59 links around, you'll find it's actually a closed loop through the
62 Whenever the bottom-up parser gets to a node that supplies context to
63 its components, it invokes that portion of the top-down pass that applies
64 to that part of the subtree (and marks the top node as processed, so
65 if a node further up supplies context, it doesn't have to take the
66 plunge again). As a particular subcase of this, as the new node is
67 built, it takes all the closed execution loops of its subcomponents
68 and links them into a new closed loop for the higher level node. But
69 it's still not the real execution order.
71 The actual execution order is not known till we get a grammar reduction
72 to a top-level unit like a subroutine or file that will be called by
73 "name" rather than via a "next" pointer. At that point, we can call
74 into peep() to do that code's portion of the 3rd pass. It has to be
75 recursive, but it's recursive on basic blocks, not on tree nodes.
78 /* To implement user lexical pragmas, there needs to be a way at run time to
79 get the compile time state of %^H for that block. Storing %^H in every
80 block (or even COP) would be very expensive, so a different approach is
81 taken. The (running) state of %^H is serialised into a tree of HE-like
82 structs. Stores into %^H are chained onto the current leaf as a struct
83 refcounted_he * with the key and the value. Deletes from %^H are saved
84 with a value of PL_sv_placeholder. The state of %^H at any point can be
85 turned back into a regular HV by walking back up the tree from that point's
86 leaf, ignoring any key you've already seen (placeholder or not), storing
87 the rest into the HV structure, then removing the placeholders. Hence
88 memory is only used to store the %^H deltas from the enclosing COP, rather
89 than the entire %^H on each COP.
91 To cause actions on %^H to write out the serialisation records, it has
92 magic type 'H'. This magic (itself) does nothing, but its presence causes
93 the values to gain magic type 'h', which has entries for set and clear.
94 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
95 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
96 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
97 it will be correctly restored when any inner compiling scope is exited.
103 #include "keywords.h"
105 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
106 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
108 #if defined(PL_OP_SLAB_ALLOC)
110 #ifdef PERL_DEBUG_READONLY_OPS
111 # define PERL_SLAB_SIZE 4096
112 # include <sys/mman.h>
115 #ifndef PERL_SLAB_SIZE
116 #define PERL_SLAB_SIZE 2048
120 Perl_Slab_Alloc(pTHX_ size_t sz)
124 * To make incrementing use count easy PL_OpSlab is an I32 *
125 * To make inserting the link to slab PL_OpPtr is I32 **
126 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
127 * Add an overhead for pointer to slab and round up as a number of pointers
129 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
130 if ((PL_OpSpace -= sz) < 0) {
131 #ifdef PERL_DEBUG_READONLY_OPS
132 /* We need to allocate chunk by chunk so that we can control the VM
134 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
135 MAP_ANON|MAP_PRIVATE, -1, 0);
137 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
138 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
140 if(PL_OpPtr == MAP_FAILED) {
141 perror("mmap failed");
146 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
151 /* We reserve the 0'th I32 sized chunk as a use count */
152 PL_OpSlab = (I32 *) PL_OpPtr;
153 /* Reduce size by the use count word, and by the size we need.
154 * Latter is to mimic the '-=' in the if() above
156 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
157 /* Allocation pointer starts at the top.
158 Theory: because we build leaves before trunk allocating at end
159 means that at run time access is cache friendly upward
161 PL_OpPtr += PERL_SLAB_SIZE;
163 #ifdef PERL_DEBUG_READONLY_OPS
164 /* We remember this slab. */
165 /* This implementation isn't efficient, but it is simple. */
166 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
167 PL_slabs[PL_slab_count++] = PL_OpSlab;
168 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
171 assert( PL_OpSpace >= 0 );
172 /* Move the allocation pointer down */
174 assert( PL_OpPtr > (I32 **) PL_OpSlab );
175 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
176 (*PL_OpSlab)++; /* Increment use count of slab */
177 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
178 assert( *PL_OpSlab > 0 );
179 return (void *)(PL_OpPtr + 1);
182 #ifdef PERL_DEBUG_READONLY_OPS
184 Perl_pending_Slabs_to_ro(pTHX) {
185 /* Turn all the allocated op slabs read only. */
186 U32 count = PL_slab_count;
187 I32 **const slabs = PL_slabs;
189 /* Reset the array of pending OP slabs, as we're about to turn this lot
190 read only. Also, do it ahead of the loop in case the warn triggers,
191 and a warn handler has an eval */
196 /* Force a new slab for any further allocation. */
200 void *const start = slabs[count];
201 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
202 if(mprotect(start, size, PROT_READ)) {
203 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
204 start, (unsigned long) size, errno);
212 S_Slab_to_rw(pTHX_ void *op)
214 I32 * const * const ptr = (I32 **) op;
215 I32 * const slab = ptr[-1];
217 PERL_ARGS_ASSERT_SLAB_TO_RW;
219 assert( ptr-1 > (I32 **) slab );
220 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
222 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
223 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
224 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
229 Perl_op_refcnt_inc(pTHX_ OP *o)
240 Perl_op_refcnt_dec(pTHX_ OP *o)
242 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
247 # define Slab_to_rw(op)
251 Perl_Slab_Free(pTHX_ void *op)
253 I32 * const * const ptr = (I32 **) op;
254 I32 * const slab = ptr[-1];
255 PERL_ARGS_ASSERT_SLAB_FREE;
256 assert( ptr-1 > (I32 **) slab );
257 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
260 if (--(*slab) == 0) {
262 # define PerlMemShared PerlMem
265 #ifdef PERL_DEBUG_READONLY_OPS
266 U32 count = PL_slab_count;
267 /* Need to remove this slab from our list of slabs */
270 if (PL_slabs[count] == slab) {
272 /* Found it. Move the entry at the end to overwrite it. */
273 DEBUG_m(PerlIO_printf(Perl_debug_log,
274 "Deallocate %p by moving %p from %lu to %lu\n",
276 PL_slabs[PL_slab_count - 1],
277 PL_slab_count, count));
278 PL_slabs[count] = PL_slabs[--PL_slab_count];
279 /* Could realloc smaller at this point, but probably not
281 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
282 perror("munmap failed");
290 PerlMemShared_free(slab);
292 if (slab == PL_OpSlab) {
299 * In the following definition, the ", (OP*)0" is just to make the compiler
300 * think the expression is of the right type: croak actually does a Siglongjmp.
302 #define CHECKOP(type,o) \
303 ((PL_op_mask && PL_op_mask[type]) \
304 ? ( op_free((OP*)o), \
305 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
307 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
309 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
312 S_gv_ename(pTHX_ GV *gv)
314 SV* const tmpsv = sv_newmortal();
316 PERL_ARGS_ASSERT_GV_ENAME;
318 gv_efullname3(tmpsv, gv, NULL);
319 return SvPV_nolen_const(tmpsv);
323 S_no_fh_allowed(pTHX_ OP *o)
325 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
327 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
333 S_too_few_arguments(pTHX_ OP *o, const char *name)
335 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
337 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
342 S_too_many_arguments(pTHX_ OP *o, const char *name)
344 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
346 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
351 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
353 PERL_ARGS_ASSERT_BAD_TYPE;
355 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
356 (int)n, name, t, OP_DESC(kid)));
360 S_no_bareword_allowed(pTHX_ const OP *o)
362 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
365 return; /* various ok barewords are hidden in extra OP_NULL */
366 qerror(Perl_mess(aTHX_
367 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
371 /* "register" allocation */
374 Perl_allocmy(pTHX_ const char *const name)
378 const bool is_our = (PL_parser->in_my == KEY_our);
380 PERL_ARGS_ASSERT_ALLOCMY;
382 /* complain about "my $<special_var>" etc etc */
386 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
387 (name[1] == '_' && (*name == '$' || name[2]))))
389 /* name[2] is true if strlen(name) > 2 */
390 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
391 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
392 name[0], toCTRL(name[1]), name + 2,
393 PL_parser->in_my == KEY_state ? "state" : "my"));
395 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
396 PL_parser->in_my == KEY_state ? "state" : "my"));
400 /* check for duplicate declaration */
401 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
403 /* allocate a spare slot and store the name in that slot */
405 off = pad_add_name(name,
406 PL_parser->in_my_stash,
408 /* $_ is always in main::, even with our */
409 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
413 PL_parser->in_my == KEY_state
415 /* anon sub prototypes contains state vars should always be cloned,
416 * otherwise the state var would be shared between anon subs */
418 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
419 CvCLONE_on(PL_compcv);
424 /* free the body of an op without examining its contents.
425 * Always use this rather than FreeOp directly */
428 S_op_destroy(pTHX_ OP *o)
430 if (o->op_latefree) {
438 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
440 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
446 Perl_op_free(pTHX_ OP *o)
453 if (o->op_latefreed) {
460 if (o->op_private & OPpREFCOUNTED) {
471 refcnt = OpREFCNT_dec(o);
474 /* Need to find and remove any pattern match ops from the list
475 we maintain for reset(). */
476 find_and_forget_pmops(o);
486 /* Call the op_free hook if it has been set. Do it now so that it's called
487 * at the right time for refcounted ops, but still before all of the kids
491 if (o->op_flags & OPf_KIDS) {
492 register OP *kid, *nextkid;
493 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
494 nextkid = kid->op_sibling; /* Get before next freeing kid */
499 #ifdef PERL_DEBUG_READONLY_OPS
503 /* COP* is not cleared by op_clear() so that we may track line
504 * numbers etc even after null() */
505 if (type == OP_NEXTSTATE || type == OP_DBSTATE
506 || (type == OP_NULL /* the COP might have been null'ed */
507 && ((OPCODE)o->op_targ == OP_NEXTSTATE
508 || (OPCODE)o->op_targ == OP_DBSTATE))) {
513 type = (OPCODE)o->op_targ;
516 if (o->op_latefree) {
522 #ifdef DEBUG_LEAKING_SCALARS
529 Perl_op_clear(pTHX_ OP *o)
534 PERL_ARGS_ASSERT_OP_CLEAR;
537 /* if (o->op_madprop && o->op_madprop->mad_next)
539 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
540 "modification of a read only value" for a reason I can't fathom why.
541 It's the "" stringification of $_, where $_ was set to '' in a foreach
542 loop, but it defies simplification into a small test case.
543 However, commenting them out has caused ext/List/Util/t/weak.t to fail
546 mad_free(o->op_madprop);
552 switch (o->op_type) {
553 case OP_NULL: /* Was holding old type, if any. */
554 if (PL_madskills && o->op_targ != OP_NULL) {
555 o->op_type = (Optype)o->op_targ;
559 case OP_ENTEREVAL: /* Was holding hints. */
563 if (!(o->op_flags & OPf_REF)
564 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
570 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
571 /* not an OP_PADAV replacement */
573 if (cPADOPo->op_padix > 0) {
574 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
575 * may still exist on the pad */
576 pad_swipe(cPADOPo->op_padix, TRUE);
577 cPADOPo->op_padix = 0;
580 SvREFCNT_dec(cSVOPo->op_sv);
581 cSVOPo->op_sv = NULL;
585 case OP_METHOD_NAMED:
588 SvREFCNT_dec(cSVOPo->op_sv);
589 cSVOPo->op_sv = NULL;
592 Even if op_clear does a pad_free for the target of the op,
593 pad_free doesn't actually remove the sv that exists in the pad;
594 instead it lives on. This results in that it could be reused as
595 a target later on when the pad was reallocated.
598 pad_swipe(o->op_targ,1);
607 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
611 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
613 if (cPADOPo->op_padix > 0) {
614 pad_swipe(cPADOPo->op_padix, TRUE);
615 cPADOPo->op_padix = 0;
618 SvREFCNT_dec(cSVOPo->op_sv);
619 cSVOPo->op_sv = NULL;
623 PerlMemShared_free(cPVOPo->op_pv);
624 cPVOPo->op_pv = NULL;
628 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
632 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
633 /* No GvIN_PAD_off here, because other references may still
634 * exist on the pad */
635 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
638 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
644 forget_pmop(cPMOPo, 1);
645 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
646 /* we use the same protection as the "SAFE" version of the PM_ macros
647 * here since sv_clean_all might release some PMOPs
648 * after PL_regex_padav has been cleared
649 * and the clearing of PL_regex_padav needs to
650 * happen before sv_clean_all
653 if(PL_regex_pad) { /* We could be in destruction */
654 const IV offset = (cPMOPo)->op_pmoffset;
655 ReREFCNT_dec(PM_GETRE(cPMOPo));
656 PL_regex_pad[offset] = &PL_sv_undef;
657 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
661 ReREFCNT_dec(PM_GETRE(cPMOPo));
662 PM_SETRE(cPMOPo, NULL);
668 if (o->op_targ > 0) {
669 pad_free(o->op_targ);
675 S_cop_free(pTHX_ COP* cop)
677 PERL_ARGS_ASSERT_COP_FREE;
681 if (! specialWARN(cop->cop_warnings))
682 PerlMemShared_free(cop->cop_warnings);
683 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
687 S_forget_pmop(pTHX_ PMOP *const o
693 HV * const pmstash = PmopSTASH(o);
695 PERL_ARGS_ASSERT_FORGET_PMOP;
697 if (pmstash && !SvIS_FREED(pmstash)) {
698 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
700 PMOP **const array = (PMOP**) mg->mg_ptr;
701 U32 count = mg->mg_len / sizeof(PMOP**);
706 /* Found it. Move the entry at the end to overwrite it. */
707 array[i] = array[--count];
708 mg->mg_len = count * sizeof(PMOP**);
709 /* Could realloc smaller at this point always, but probably
710 not worth it. Probably worth free()ing if we're the
713 Safefree(mg->mg_ptr);
730 S_find_and_forget_pmops(pTHX_ OP *o)
732 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
734 if (o->op_flags & OPf_KIDS) {
735 OP *kid = cUNOPo->op_first;
737 switch (kid->op_type) {
742 forget_pmop((PMOP*)kid, 0);
744 find_and_forget_pmops(kid);
745 kid = kid->op_sibling;
751 Perl_op_null(pTHX_ OP *o)
755 PERL_ARGS_ASSERT_OP_NULL;
757 if (o->op_type == OP_NULL)
761 o->op_targ = o->op_type;
762 o->op_type = OP_NULL;
763 o->op_ppaddr = PL_ppaddr[OP_NULL];
767 Perl_op_refcnt_lock(pTHX)
775 Perl_op_refcnt_unlock(pTHX)
782 /* Contextualizers */
784 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
787 S_linklist(pTHX_ OP *o)
791 PERL_ARGS_ASSERT_LINKLIST;
796 /* establish postfix order */
797 first = cUNOPo->op_first;
800 o->op_next = LINKLIST(first);
803 if (kid->op_sibling) {
804 kid->op_next = LINKLIST(kid->op_sibling);
805 kid = kid->op_sibling;
819 S_scalarkids(pTHX_ OP *o)
821 if (o && o->op_flags & OPf_KIDS) {
823 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
830 S_scalarboolean(pTHX_ OP *o)
834 PERL_ARGS_ASSERT_SCALARBOOLEAN;
836 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
837 if (ckWARN(WARN_SYNTAX)) {
838 const line_t oldline = CopLINE(PL_curcop);
840 if (PL_parser && PL_parser->copline != NOLINE)
841 CopLINE_set(PL_curcop, PL_parser->copline);
842 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
843 CopLINE_set(PL_curcop, oldline);
850 Perl_scalar(pTHX_ OP *o)
855 /* assumes no premature commitment */
856 if (!o || (PL_parser && PL_parser->error_count)
857 || (o->op_flags & OPf_WANT)
858 || o->op_type == OP_RETURN)
863 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
865 switch (o->op_type) {
867 scalar(cBINOPo->op_first);
872 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
876 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
877 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
878 deprecate_old("implicit split to @_");
886 if (o->op_flags & OPf_KIDS) {
887 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
893 kid = cLISTOPo->op_first;
895 while ((kid = kid->op_sibling)) {
901 PL_curcop = &PL_compiling;
906 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
912 PL_curcop = &PL_compiling;
915 if (ckWARN(WARN_VOID))
916 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
923 Perl_scalarvoid(pTHX_ OP *o)
927 const char* useless = NULL;
931 PERL_ARGS_ASSERT_SCALARVOID;
933 /* trailing mad null ops don't count as "there" for void processing */
935 o->op_type != OP_NULL &&
937 o->op_sibling->op_type == OP_NULL)
940 for (sib = o->op_sibling;
941 sib && sib->op_type == OP_NULL;
942 sib = sib->op_sibling) ;
948 if (o->op_type == OP_NEXTSTATE
949 || o->op_type == OP_DBSTATE
950 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
951 || o->op_targ == OP_DBSTATE)))
952 PL_curcop = (COP*)o; /* for warning below */
954 /* assumes no premature commitment */
955 want = o->op_flags & OPf_WANT;
956 if ((want && want != OPf_WANT_SCALAR)
957 || (PL_parser && PL_parser->error_count)
958 || o->op_type == OP_RETURN)
963 if ((o->op_private & OPpTARGET_MY)
964 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
966 return scalar(o); /* As if inside SASSIGN */
969 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
971 switch (o->op_type) {
973 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
977 if (o->op_flags & OPf_STACKED)
981 if (o->op_private == 4)
1024 case OP_GETSOCKNAME:
1025 case OP_GETPEERNAME:
1030 case OP_GETPRIORITY:
1054 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1055 /* Otherwise it's "Useless use of grep iterator" */
1056 useless = OP_DESC(o);
1060 kid = cUNOPo->op_first;
1061 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1062 kid->op_type != OP_TRANS) {
1065 useless = "negative pattern binding (!~)";
1072 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1073 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1074 useless = "a variable";
1079 if (cSVOPo->op_private & OPpCONST_STRICT)
1080 no_bareword_allowed(o);
1082 if (ckWARN(WARN_VOID)) {
1084 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1085 "a constant (%"SVf")", sv));
1086 useless = SvPV_nolen(msv);
1089 useless = "a constant (undef)";
1090 if (o->op_private & OPpCONST_ARYBASE)
1092 /* don't warn on optimised away booleans, eg
1093 * use constant Foo, 5; Foo || print; */
1094 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1096 /* the constants 0 and 1 are permitted as they are
1097 conventionally used as dummies in constructs like
1098 1 while some_condition_with_side_effects; */
1099 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1101 else if (SvPOK(sv)) {
1102 /* perl4's way of mixing documentation and code
1103 (before the invention of POD) was based on a
1104 trick to mix nroff and perl code. The trick was
1105 built upon these three nroff macros being used in
1106 void context. The pink camel has the details in
1107 the script wrapman near page 319. */
1108 const char * const maybe_macro = SvPVX_const(sv);
1109 if (strnEQ(maybe_macro, "di", 2) ||
1110 strnEQ(maybe_macro, "ds", 2) ||
1111 strnEQ(maybe_macro, "ig", 2))
1116 op_null(o); /* don't execute or even remember it */
1120 o->op_type = OP_PREINC; /* pre-increment is faster */
1121 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1125 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1126 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1130 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1131 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1135 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1136 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1141 kid = cLOGOPo->op_first;
1142 if (kid->op_type == OP_NOT
1143 && (kid->op_flags & OPf_KIDS)
1145 if (o->op_type == OP_AND) {
1147 o->op_ppaddr = PL_ppaddr[OP_OR];
1149 o->op_type = OP_AND;
1150 o->op_ppaddr = PL_ppaddr[OP_AND];
1159 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1164 if (o->op_flags & OPf_STACKED)
1171 if (!(o->op_flags & OPf_KIDS))
1182 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1189 /* all requires must return a boolean value */
1190 o->op_flags &= ~OPf_WANT;
1195 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1196 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1197 deprecate_old("implicit split to @_");
1201 if (useless && ckWARN(WARN_VOID))
1202 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1207 S_listkids(pTHX_ OP *o)
1209 if (o && o->op_flags & OPf_KIDS) {
1211 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1218 Perl_list(pTHX_ OP *o)
1223 /* assumes no premature commitment */
1224 if (!o || (o->op_flags & OPf_WANT)
1225 || (PL_parser && PL_parser->error_count)
1226 || o->op_type == OP_RETURN)
1231 if ((o->op_private & OPpTARGET_MY)
1232 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1234 return o; /* As if inside SASSIGN */
1237 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1239 switch (o->op_type) {
1242 list(cBINOPo->op_first);
1247 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1255 if (!(o->op_flags & OPf_KIDS))
1257 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1258 list(cBINOPo->op_first);
1259 return gen_constant_list(o);
1266 kid = cLISTOPo->op_first;
1268 while ((kid = kid->op_sibling)) {
1269 if (kid->op_sibling)
1274 PL_curcop = &PL_compiling;
1278 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1279 if (kid->op_sibling)
1284 PL_curcop = &PL_compiling;
1287 /* all requires must return a boolean value */
1288 o->op_flags &= ~OPf_WANT;
1295 S_scalarseq(pTHX_ OP *o)
1299 const OPCODE type = o->op_type;
1301 if (type == OP_LINESEQ || type == OP_SCOPE ||
1302 type == OP_LEAVE || type == OP_LEAVETRY)
1305 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1306 if (kid->op_sibling) {
1310 PL_curcop = &PL_compiling;
1312 o->op_flags &= ~OPf_PARENS;
1313 if (PL_hints & HINT_BLOCK_SCOPE)
1314 o->op_flags |= OPf_PARENS;
1317 o = newOP(OP_STUB, 0);
1322 S_modkids(pTHX_ OP *o, I32 type)
1324 if (o && o->op_flags & OPf_KIDS) {
1326 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1332 /* Propagate lvalue ("modifiable") context to an op and its children.
1333 * 'type' represents the context type, roughly based on the type of op that
1334 * would do the modifying, although local() is represented by OP_NULL.
1335 * It's responsible for detecting things that can't be modified, flag
1336 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1337 * might have to vivify a reference in $x), and so on.
1339 * For example, "$a+1 = 2" would cause mod() to be called with o being
1340 * OP_ADD and type being OP_SASSIGN, and would output an error.
1344 Perl_mod(pTHX_ OP *o, I32 type)
1348 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1351 if (!o || (PL_parser && PL_parser->error_count))
1354 if ((o->op_private & OPpTARGET_MY)
1355 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1360 switch (o->op_type) {
1366 if (!(o->op_private & OPpCONST_ARYBASE))
1369 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1370 CopARYBASE_set(&PL_compiling,
1371 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1375 SAVECOPARYBASE(&PL_compiling);
1376 CopARYBASE_set(&PL_compiling, 0);
1378 else if (type == OP_REFGEN)
1381 Perl_croak(aTHX_ "That use of $[ is unsupported");
1384 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1388 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1389 !(o->op_flags & OPf_STACKED)) {
1390 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1391 /* The default is to set op_private to the number of children,
1392 which for a UNOP such as RV2CV is always 1. And w're using
1393 the bit for a flag in RV2CV, so we need it clear. */
1394 o->op_private &= ~1;
1395 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1396 assert(cUNOPo->op_first->op_type == OP_NULL);
1397 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1400 else if (o->op_private & OPpENTERSUB_NOMOD)
1402 else { /* lvalue subroutine call */
1403 o->op_private |= OPpLVAL_INTRO;
1404 PL_modcount = RETURN_UNLIMITED_NUMBER;
1405 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1406 /* Backward compatibility mode: */
1407 o->op_private |= OPpENTERSUB_INARGS;
1410 else { /* Compile-time error message: */
1411 OP *kid = cUNOPo->op_first;
1415 if (kid->op_type != OP_PUSHMARK) {
1416 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1418 "panic: unexpected lvalue entersub "
1419 "args: type/targ %ld:%"UVuf,
1420 (long)kid->op_type, (UV)kid->op_targ);
1421 kid = kLISTOP->op_first;
1423 while (kid->op_sibling)
1424 kid = kid->op_sibling;
1425 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1427 if (kid->op_type == OP_METHOD_NAMED
1428 || kid->op_type == OP_METHOD)
1432 NewOp(1101, newop, 1, UNOP);
1433 newop->op_type = OP_RV2CV;
1434 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1435 newop->op_first = NULL;
1436 newop->op_next = (OP*)newop;
1437 kid->op_sibling = (OP*)newop;
1438 newop->op_private |= OPpLVAL_INTRO;
1439 newop->op_private &= ~1;
1443 if (kid->op_type != OP_RV2CV)
1445 "panic: unexpected lvalue entersub "
1446 "entry via type/targ %ld:%"UVuf,
1447 (long)kid->op_type, (UV)kid->op_targ);
1448 kid->op_private |= OPpLVAL_INTRO;
1449 break; /* Postpone until runtime */
1453 kid = kUNOP->op_first;
1454 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1455 kid = kUNOP->op_first;
1456 if (kid->op_type == OP_NULL)
1458 "Unexpected constant lvalue entersub "
1459 "entry via type/targ %ld:%"UVuf,
1460 (long)kid->op_type, (UV)kid->op_targ);
1461 if (kid->op_type != OP_GV) {
1462 /* Restore RV2CV to check lvalueness */
1464 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1465 okid->op_next = kid->op_next;
1466 kid->op_next = okid;
1469 okid->op_next = NULL;
1470 okid->op_type = OP_RV2CV;
1472 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1473 okid->op_private |= OPpLVAL_INTRO;
1474 okid->op_private &= ~1;
1478 cv = GvCV(kGVOP_gv);
1488 /* grep, foreach, subcalls, refgen */
1489 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1491 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1492 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1494 : (o->op_type == OP_ENTERSUB
1495 ? "non-lvalue subroutine call"
1497 type ? PL_op_desc[type] : "local"));
1511 case OP_RIGHT_SHIFT:
1520 if (!(o->op_flags & OPf_STACKED))
1527 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1533 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1534 PL_modcount = RETURN_UNLIMITED_NUMBER;
1535 return o; /* Treat \(@foo) like ordinary list. */
1539 if (scalar_mod_type(o, type))
1541 ref(cUNOPo->op_first, o->op_type);
1545 if (type == OP_LEAVESUBLV)
1546 o->op_private |= OPpMAYBE_LVSUB;
1552 PL_modcount = RETURN_UNLIMITED_NUMBER;
1555 ref(cUNOPo->op_first, o->op_type);
1560 PL_hints |= HINT_BLOCK_SCOPE;
1575 PL_modcount = RETURN_UNLIMITED_NUMBER;
1576 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1577 return o; /* Treat \(@foo) like ordinary list. */
1578 if (scalar_mod_type(o, type))
1580 if (type == OP_LEAVESUBLV)
1581 o->op_private |= OPpMAYBE_LVSUB;
1585 if (!type) /* local() */
1586 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1587 PAD_COMPNAME_PV(o->op_targ));
1595 if (type != OP_SASSIGN)
1599 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1604 if (type == OP_LEAVESUBLV)
1605 o->op_private |= OPpMAYBE_LVSUB;
1607 pad_free(o->op_targ);
1608 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1609 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1610 if (o->op_flags & OPf_KIDS)
1611 mod(cBINOPo->op_first->op_sibling, type);
1616 ref(cBINOPo->op_first, o->op_type);
1617 if (type == OP_ENTERSUB &&
1618 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1619 o->op_private |= OPpLVAL_DEFER;
1620 if (type == OP_LEAVESUBLV)
1621 o->op_private |= OPpMAYBE_LVSUB;
1631 if (o->op_flags & OPf_KIDS)
1632 mod(cLISTOPo->op_last, type);
1637 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1639 else if (!(o->op_flags & OPf_KIDS))
1641 if (o->op_targ != OP_LIST) {
1642 mod(cBINOPo->op_first, type);
1648 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1653 if (type != OP_LEAVESUBLV)
1655 break; /* mod()ing was handled by ck_return() */
1658 /* [20011101.069] File test operators interpret OPf_REF to mean that
1659 their argument is a filehandle; thus \stat(".") should not set
1661 if (type == OP_REFGEN &&
1662 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1665 if (type != OP_LEAVESUBLV)
1666 o->op_flags |= OPf_MOD;
1668 if (type == OP_AASSIGN || type == OP_SASSIGN)
1669 o->op_flags |= OPf_SPECIAL|OPf_REF;
1670 else if (!type) { /* local() */
1673 o->op_private |= OPpLVAL_INTRO;
1674 o->op_flags &= ~OPf_SPECIAL;
1675 PL_hints |= HINT_BLOCK_SCOPE;
1680 if (ckWARN(WARN_SYNTAX)) {
1681 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1682 "Useless localization of %s", OP_DESC(o));
1686 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1687 && type != OP_LEAVESUBLV)
1688 o->op_flags |= OPf_REF;
1693 S_scalar_mod_type(const OP *o, I32 type)
1695 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1699 if (o->op_type == OP_RV2GV)
1723 case OP_RIGHT_SHIFT:
1743 S_is_handle_constructor(const OP *o, I32 numargs)
1745 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1747 switch (o->op_type) {
1755 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1768 S_refkids(pTHX_ OP *o, I32 type)
1770 if (o && o->op_flags & OPf_KIDS) {
1772 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1779 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1784 PERL_ARGS_ASSERT_DOREF;
1786 if (!o || (PL_parser && PL_parser->error_count))
1789 switch (o->op_type) {
1791 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1792 !(o->op_flags & OPf_STACKED)) {
1793 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1794 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1795 assert(cUNOPo->op_first->op_type == OP_NULL);
1796 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1797 o->op_flags |= OPf_SPECIAL;
1798 o->op_private &= ~1;
1803 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1804 doref(kid, type, set_op_ref);
1807 if (type == OP_DEFINED)
1808 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1809 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1812 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1813 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1814 : type == OP_RV2HV ? OPpDEREF_HV
1816 o->op_flags |= OPf_MOD;
1823 o->op_flags |= OPf_REF;
1826 if (type == OP_DEFINED)
1827 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1828 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1834 o->op_flags |= OPf_REF;
1839 if (!(o->op_flags & OPf_KIDS))
1841 doref(cBINOPo->op_first, type, set_op_ref);
1845 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1846 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1847 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1848 : type == OP_RV2HV ? OPpDEREF_HV
1850 o->op_flags |= OPf_MOD;
1860 if (!(o->op_flags & OPf_KIDS))
1862 doref(cLISTOPo->op_last, type, set_op_ref);
1872 S_dup_attrlist(pTHX_ OP *o)
1877 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1879 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1880 * where the first kid is OP_PUSHMARK and the remaining ones
1881 * are OP_CONST. We need to push the OP_CONST values.
1883 if (o->op_type == OP_CONST)
1884 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1886 else if (o->op_type == OP_NULL)
1890 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1892 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1893 if (o->op_type == OP_CONST)
1894 rop = append_elem(OP_LIST, rop,
1895 newSVOP(OP_CONST, o->op_flags,
1896 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1903 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1908 PERL_ARGS_ASSERT_APPLY_ATTRS;
1910 /* fake up C<use attributes $pkg,$rv,@attrs> */
1911 ENTER; /* need to protect against side-effects of 'use' */
1912 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1914 #define ATTRSMODULE "attributes"
1915 #define ATTRSMODULE_PM "attributes.pm"
1918 /* Don't force the C<use> if we don't need it. */
1919 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1920 if (svp && *svp != &PL_sv_undef)
1921 NOOP; /* already in %INC */
1923 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1924 newSVpvs(ATTRSMODULE), NULL);
1927 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1928 newSVpvs(ATTRSMODULE),
1930 prepend_elem(OP_LIST,
1931 newSVOP(OP_CONST, 0, stashsv),
1932 prepend_elem(OP_LIST,
1933 newSVOP(OP_CONST, 0,
1935 dup_attrlist(attrs))));
1941 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1944 OP *pack, *imop, *arg;
1947 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1952 assert(target->op_type == OP_PADSV ||
1953 target->op_type == OP_PADHV ||
1954 target->op_type == OP_PADAV);
1956 /* Ensure that attributes.pm is loaded. */
1957 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1959 /* Need package name for method call. */
1960 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1962 /* Build up the real arg-list. */
1963 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1965 arg = newOP(OP_PADSV, 0);
1966 arg->op_targ = target->op_targ;
1967 arg = prepend_elem(OP_LIST,
1968 newSVOP(OP_CONST, 0, stashsv),
1969 prepend_elem(OP_LIST,
1970 newUNOP(OP_REFGEN, 0,
1971 mod(arg, OP_REFGEN)),
1972 dup_attrlist(attrs)));
1974 /* Fake up a method call to import */
1975 meth = newSVpvs_share("import");
1976 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1977 append_elem(OP_LIST,
1978 prepend_elem(OP_LIST, pack, list(arg)),
1979 newSVOP(OP_METHOD_NAMED, 0, meth)));
1980 imop->op_private |= OPpENTERSUB_NOMOD;
1982 /* Combine the ops. */
1983 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1987 =notfor apidoc apply_attrs_string
1989 Attempts to apply a list of attributes specified by the C<attrstr> and
1990 C<len> arguments to the subroutine identified by the C<cv> argument which
1991 is expected to be associated with the package identified by the C<stashpv>
1992 argument (see L<attributes>). It gets this wrong, though, in that it
1993 does not correctly identify the boundaries of the individual attribute
1994 specifications within C<attrstr>. This is not really intended for the
1995 public API, but has to be listed here for systems such as AIX which
1996 need an explicit export list for symbols. (It's called from XS code
1997 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1998 to respect attribute syntax properly would be welcome.
2004 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2005 const char *attrstr, STRLEN len)
2009 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2012 len = strlen(attrstr);
2016 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2018 const char * const sstr = attrstr;
2019 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2020 attrs = append_elem(OP_LIST, attrs,
2021 newSVOP(OP_CONST, 0,
2022 newSVpvn(sstr, attrstr-sstr)));
2026 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2027 newSVpvs(ATTRSMODULE),
2028 NULL, prepend_elem(OP_LIST,
2029 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2030 prepend_elem(OP_LIST,
2031 newSVOP(OP_CONST, 0,
2032 newRV(MUTABLE_SV(cv))),
2037 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2042 PERL_ARGS_ASSERT_MY_KID;
2044 if (!o || (PL_parser && PL_parser->error_count))
2048 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2049 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2053 if (type == OP_LIST) {
2055 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2056 my_kid(kid, attrs, imopsp);
2057 } else if (type == OP_UNDEF
2063 } else if (type == OP_RV2SV || /* "our" declaration */
2065 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2066 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2067 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2069 PL_parser->in_my == KEY_our
2071 : PL_parser->in_my == KEY_state ? "state" : "my"));
2073 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2074 PL_parser->in_my = FALSE;
2075 PL_parser->in_my_stash = NULL;
2076 apply_attrs(GvSTASH(gv),
2077 (type == OP_RV2SV ? GvSV(gv) :
2078 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2079 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2082 o->op_private |= OPpOUR_INTRO;
2085 else if (type != OP_PADSV &&
2088 type != OP_PUSHMARK)
2090 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2092 PL_parser->in_my == KEY_our
2094 : PL_parser->in_my == KEY_state ? "state" : "my"));
2097 else if (attrs && type != OP_PUSHMARK) {
2100 PL_parser->in_my = FALSE;
2101 PL_parser->in_my_stash = NULL;
2103 /* check for C<my Dog $spot> when deciding package */
2104 stash = PAD_COMPNAME_TYPE(o->op_targ);
2106 stash = PL_curstash;
2107 apply_attrs_my(stash, o, attrs, imopsp);
2109 o->op_flags |= OPf_MOD;
2110 o->op_private |= OPpLVAL_INTRO;
2111 if (PL_parser->in_my == KEY_state)
2112 o->op_private |= OPpPAD_STATE;
2117 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2121 int maybe_scalar = 0;
2123 PERL_ARGS_ASSERT_MY_ATTRS;
2125 /* [perl #17376]: this appears to be premature, and results in code such as
2126 C< our(%x); > executing in list mode rather than void mode */
2128 if (o->op_flags & OPf_PARENS)
2138 o = my_kid(o, attrs, &rops);
2140 if (maybe_scalar && o->op_type == OP_PADSV) {
2141 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2142 o->op_private |= OPpLVAL_INTRO;
2145 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2147 PL_parser->in_my = FALSE;
2148 PL_parser->in_my_stash = NULL;
2153 Perl_sawparens(pTHX_ OP *o)
2155 PERL_UNUSED_CONTEXT;
2157 o->op_flags |= OPf_PARENS;
2162 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2166 const OPCODE ltype = left->op_type;
2167 const OPCODE rtype = right->op_type;
2169 PERL_ARGS_ASSERT_BIND_MATCH;
2171 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2172 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2174 const char * const desc
2175 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2176 ? (int)rtype : OP_MATCH];
2177 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2178 ? "@array" : "%hash");
2179 Perl_warner(aTHX_ packWARN(WARN_MISC),
2180 "Applying %s to %s will act on scalar(%s)",
2181 desc, sample, sample);
2184 if (rtype == OP_CONST &&
2185 cSVOPx(right)->op_private & OPpCONST_BARE &&
2186 cSVOPx(right)->op_private & OPpCONST_STRICT)
2188 no_bareword_allowed(right);
2191 ismatchop = rtype == OP_MATCH ||
2192 rtype == OP_SUBST ||
2194 if (ismatchop && right->op_private & OPpTARGET_MY) {
2196 right->op_private &= ~OPpTARGET_MY;
2198 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2201 right->op_flags |= OPf_STACKED;
2202 if (rtype != OP_MATCH &&
2203 ! (rtype == OP_TRANS &&
2204 right->op_private & OPpTRANS_IDENTICAL))
2205 newleft = mod(left, rtype);
2208 if (right->op_type == OP_TRANS)
2209 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2211 o = prepend_elem(rtype, scalar(newleft), right);
2213 return newUNOP(OP_NOT, 0, scalar(o));
2217 return bind_match(type, left,
2218 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2222 Perl_invert(pTHX_ OP *o)
2226 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2230 Perl_scope(pTHX_ OP *o)
2234 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2235 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2236 o->op_type = OP_LEAVE;
2237 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2239 else if (o->op_type == OP_LINESEQ) {
2241 o->op_type = OP_SCOPE;
2242 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2243 kid = ((LISTOP*)o)->op_first;
2244 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2247 /* The following deals with things like 'do {1 for 1}' */
2248 kid = kid->op_sibling;
2250 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2255 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2261 Perl_block_start(pTHX_ int full)
2264 const int retval = PL_savestack_ix;
2265 pad_block_start(full);
2267 PL_hints &= ~HINT_BLOCK_SCOPE;
2268 SAVECOMPILEWARNINGS();
2269 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2274 Perl_block_end(pTHX_ I32 floor, OP *seq)
2277 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2278 OP* const retval = scalarseq(seq);
2280 CopHINTS_set(&PL_compiling, PL_hints);
2282 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2291 const PADOFFSET offset = pad_findmy("$_");
2292 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2293 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2296 OP * const o = newOP(OP_PADSV, 0);
2297 o->op_targ = offset;
2303 Perl_newPROG(pTHX_ OP *o)
2307 PERL_ARGS_ASSERT_NEWPROG;
2312 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2313 ((PL_in_eval & EVAL_KEEPERR)
2314 ? OPf_SPECIAL : 0), o);
2315 PL_eval_start = linklist(PL_eval_root);
2316 PL_eval_root->op_private |= OPpREFCOUNTED;
2317 OpREFCNT_set(PL_eval_root, 1);
2318 PL_eval_root->op_next = 0;
2319 CALL_PEEP(PL_eval_start);
2322 if (o->op_type == OP_STUB) {
2323 PL_comppad_name = 0;
2325 S_op_destroy(aTHX_ o);
2328 PL_main_root = scope(sawparens(scalarvoid(o)));
2329 PL_curcop = &PL_compiling;
2330 PL_main_start = LINKLIST(PL_main_root);
2331 PL_main_root->op_private |= OPpREFCOUNTED;
2332 OpREFCNT_set(PL_main_root, 1);
2333 PL_main_root->op_next = 0;
2334 CALL_PEEP(PL_main_start);
2337 /* Register with debugger */
2339 CV * const cv = get_cvs("DB::postponed", 0);
2343 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2345 call_sv(MUTABLE_SV(cv), G_DISCARD);
2352 Perl_localize(pTHX_ OP *o, I32 lex)
2356 PERL_ARGS_ASSERT_LOCALIZE;
2358 if (o->op_flags & OPf_PARENS)
2359 /* [perl #17376]: this appears to be premature, and results in code such as
2360 C< our(%x); > executing in list mode rather than void mode */
2367 if ( PL_parser->bufptr > PL_parser->oldbufptr
2368 && PL_parser->bufptr[-1] == ','
2369 && ckWARN(WARN_PARENTHESIS))
2371 char *s = PL_parser->bufptr;
2374 /* some heuristics to detect a potential error */
2375 while (*s && (strchr(", \t\n", *s)))
2379 if (*s && strchr("@$%*", *s) && *++s
2380 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2383 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2385 while (*s && (strchr(", \t\n", *s)))
2391 if (sigil && (*s == ';' || *s == '=')) {
2392 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2393 "Parentheses missing around \"%s\" list",
2395 ? (PL_parser->in_my == KEY_our
2397 : PL_parser->in_my == KEY_state
2407 o = mod(o, OP_NULL); /* a bit kludgey */
2408 PL_parser->in_my = FALSE;
2409 PL_parser->in_my_stash = NULL;
2414 Perl_jmaybe(pTHX_ OP *o)
2416 PERL_ARGS_ASSERT_JMAYBE;
2418 if (o->op_type == OP_LIST) {
2420 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2421 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2427 S_fold_constants(pTHX_ register OP *o)
2430 register OP * VOL curop;
2432 VOL I32 type = o->op_type;
2437 SV * const oldwarnhook = PL_warnhook;
2438 SV * const olddiehook = PL_diehook;
2442 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2444 if (PL_opargs[type] & OA_RETSCALAR)
2446 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2447 o->op_targ = pad_alloc(type, SVs_PADTMP);
2449 /* integerize op, unless it happens to be C<-foo>.
2450 * XXX should pp_i_negate() do magic string negation instead? */
2451 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2452 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2453 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2455 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2458 if (!(PL_opargs[type] & OA_FOLDCONST))
2463 /* XXX might want a ck_negate() for this */
2464 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2475 /* XXX what about the numeric ops? */
2476 if (PL_hints & HINT_LOCALE)
2481 if (PL_parser && PL_parser->error_count)
2482 goto nope; /* Don't try to run w/ errors */
2484 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2485 const OPCODE type = curop->op_type;
2486 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2488 type != OP_SCALAR &&
2490 type != OP_PUSHMARK)
2496 curop = LINKLIST(o);
2497 old_next = o->op_next;
2501 oldscope = PL_scopestack_ix;
2502 create_eval_scope(G_FAKINGEVAL);
2504 /* Verify that we don't need to save it: */
2505 assert(PL_curcop == &PL_compiling);
2506 StructCopy(&PL_compiling, ¬_compiling, COP);
2507 PL_curcop = ¬_compiling;
2508 /* The above ensures that we run with all the correct hints of the
2509 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2510 assert(IN_PERL_RUNTIME);
2511 PL_warnhook = PERL_WARNHOOK_FATAL;
2518 sv = *(PL_stack_sp--);
2519 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2520 pad_swipe(o->op_targ, FALSE);
2521 else if (SvTEMP(sv)) { /* grab mortal temp? */
2522 SvREFCNT_inc_simple_void(sv);
2527 /* Something tried to die. Abandon constant folding. */
2528 /* Pretend the error never happened. */
2530 o->op_next = old_next;
2534 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2535 PL_warnhook = oldwarnhook;
2536 PL_diehook = olddiehook;
2537 /* XXX note that this croak may fail as we've already blown away
2538 * the stack - eg any nested evals */
2539 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2542 PL_warnhook = oldwarnhook;
2543 PL_diehook = olddiehook;
2544 PL_curcop = &PL_compiling;
2546 if (PL_scopestack_ix > oldscope)
2547 delete_eval_scope();
2556 if (type == OP_RV2GV)
2557 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2559 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2560 op_getmad(o,newop,'f');
2568 S_gen_constant_list(pTHX_ register OP *o)
2572 const I32 oldtmps_floor = PL_tmps_floor;
2575 if (PL_parser && PL_parser->error_count)
2576 return o; /* Don't attempt to run with errors */
2578 PL_op = curop = LINKLIST(o);
2584 assert (!(curop->op_flags & OPf_SPECIAL));
2585 assert(curop->op_type == OP_RANGE);
2587 PL_tmps_floor = oldtmps_floor;
2589 o->op_type = OP_RV2AV;
2590 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2591 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2592 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2593 o->op_opt = 0; /* needs to be revisited in peep() */
2594 curop = ((UNOP*)o)->op_first;
2595 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2597 op_getmad(curop,o,'O');
2606 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2609 if (!o || o->op_type != OP_LIST)
2610 o = newLISTOP(OP_LIST, 0, o, NULL);
2612 o->op_flags &= ~OPf_WANT;
2614 if (!(PL_opargs[type] & OA_MARK))
2615 op_null(cLISTOPo->op_first);
2617 o->op_type = (OPCODE)type;
2618 o->op_ppaddr = PL_ppaddr[type];
2619 o->op_flags |= flags;
2621 o = CHECKOP(type, o);
2622 if (o->op_type != (unsigned)type)
2625 return fold_constants(o);
2628 /* List constructors */
2631 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2639 if (first->op_type != (unsigned)type
2640 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2642 return newLISTOP(type, 0, first, last);
2645 if (first->op_flags & OPf_KIDS)
2646 ((LISTOP*)first)->op_last->op_sibling = last;
2648 first->op_flags |= OPf_KIDS;
2649 ((LISTOP*)first)->op_first = last;
2651 ((LISTOP*)first)->op_last = last;
2656 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2664 if (first->op_type != (unsigned)type)
2665 return prepend_elem(type, (OP*)first, (OP*)last);
2667 if (last->op_type != (unsigned)type)
2668 return append_elem(type, (OP*)first, (OP*)last);
2670 first->op_last->op_sibling = last->op_first;
2671 first->op_last = last->op_last;
2672 first->op_flags |= (last->op_flags & OPf_KIDS);
2675 if (last->op_first && first->op_madprop) {
2676 MADPROP *mp = last->op_first->op_madprop;
2678 while (mp->mad_next)
2680 mp->mad_next = first->op_madprop;
2683 last->op_first->op_madprop = first->op_madprop;
2686 first->op_madprop = last->op_madprop;
2687 last->op_madprop = 0;
2690 S_op_destroy(aTHX_ (OP*)last);
2696 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2704 if (last->op_type == (unsigned)type) {
2705 if (type == OP_LIST) { /* already a PUSHMARK there */
2706 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2707 ((LISTOP*)last)->op_first->op_sibling = first;
2708 if (!(first->op_flags & OPf_PARENS))
2709 last->op_flags &= ~OPf_PARENS;
2712 if (!(last->op_flags & OPf_KIDS)) {
2713 ((LISTOP*)last)->op_last = first;
2714 last->op_flags |= OPf_KIDS;
2716 first->op_sibling = ((LISTOP*)last)->op_first;
2717 ((LISTOP*)last)->op_first = first;
2719 last->op_flags |= OPf_KIDS;
2723 return newLISTOP(type, 0, first, last);
2731 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2734 Newxz(tk, 1, TOKEN);
2735 tk->tk_type = (OPCODE)optype;
2736 tk->tk_type = 12345;
2738 tk->tk_mad = madprop;
2743 Perl_token_free(pTHX_ TOKEN* tk)
2745 PERL_ARGS_ASSERT_TOKEN_FREE;
2747 if (tk->tk_type != 12345)
2749 mad_free(tk->tk_mad);
2754 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2759 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2761 if (tk->tk_type != 12345) {
2762 Perl_warner(aTHX_ packWARN(WARN_MISC),
2763 "Invalid TOKEN object ignored");
2770 /* faked up qw list? */
2772 tm->mad_type == MAD_SV &&
2773 SvPVX((const SV *)tm->mad_val)[0] == 'q')
2780 /* pretend constant fold didn't happen? */
2781 if (mp->mad_key == 'f' &&
2782 (o->op_type == OP_CONST ||
2783 o->op_type == OP_GV) )
2785 token_getmad(tk,(OP*)mp->mad_val,slot);
2799 if (mp->mad_key == 'X')
2800 mp->mad_key = slot; /* just change the first one */
2810 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2819 /* pretend constant fold didn't happen? */
2820 if (mp->mad_key == 'f' &&
2821 (o->op_type == OP_CONST ||
2822 o->op_type == OP_GV) )
2824 op_getmad(from,(OP*)mp->mad_val,slot);
2831 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2834 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2840 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2849 /* pretend constant fold didn't happen? */
2850 if (mp->mad_key == 'f' &&
2851 (o->op_type == OP_CONST ||
2852 o->op_type == OP_GV) )
2854 op_getmad(from,(OP*)mp->mad_val,slot);
2861 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2864 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2868 PerlIO_printf(PerlIO_stderr(),
2869 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2875 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2893 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2897 addmad(tm, &(o->op_madprop), slot);
2901 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2922 Perl_newMADsv(pTHX_ char key, SV* sv)
2924 PERL_ARGS_ASSERT_NEWMADSV;
2926 return newMADPROP(key, MAD_SV, sv, 0);
2930 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2933 Newxz(mp, 1, MADPROP);
2936 mp->mad_vlen = vlen;
2937 mp->mad_type = type;
2939 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2944 Perl_mad_free(pTHX_ MADPROP* mp)
2946 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2950 mad_free(mp->mad_next);
2951 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2952 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2953 switch (mp->mad_type) {
2957 Safefree((char*)mp->mad_val);
2960 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2961 op_free((OP*)mp->mad_val);
2964 sv_free(MUTABLE_SV(mp->mad_val));
2967 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2976 Perl_newNULLLIST(pTHX)
2978 return newOP(OP_STUB, 0);
2982 S_force_list(pTHX_ OP *o)
2984 if (!o || o->op_type != OP_LIST)
2985 o = newLISTOP(OP_LIST, 0, o, NULL);
2991 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2996 NewOp(1101, listop, 1, LISTOP);
2998 listop->op_type = (OPCODE)type;
2999 listop->op_ppaddr = PL_ppaddr[type];
3002 listop->op_flags = (U8)flags;
3006 else if (!first && last)
3009 first->op_sibling = last;
3010 listop->op_first = first;
3011 listop->op_last = last;
3012 if (type == OP_LIST) {
3013 OP* const pushop = newOP(OP_PUSHMARK, 0);
3014 pushop->op_sibling = first;
3015 listop->op_first = pushop;
3016 listop->op_flags |= OPf_KIDS;
3018 listop->op_last = pushop;
3021 return CHECKOP(type, listop);
3025 Perl_newOP(pTHX_ I32 type, I32 flags)
3029 NewOp(1101, o, 1, OP);
3030 o->op_type = (OPCODE)type;
3031 o->op_ppaddr = PL_ppaddr[type];
3032 o->op_flags = (U8)flags;
3034 o->op_latefreed = 0;
3038 o->op_private = (U8)(0 | (flags >> 8));
3039 if (PL_opargs[type] & OA_RETSCALAR)
3041 if (PL_opargs[type] & OA_TARGET)
3042 o->op_targ = pad_alloc(type, SVs_PADTMP);
3043 return CHECKOP(type, o);
3047 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3053 first = newOP(OP_STUB, 0);
3054 if (PL_opargs[type] & OA_MARK)
3055 first = force_list(first);
3057 NewOp(1101, unop, 1, UNOP);
3058 unop->op_type = (OPCODE)type;
3059 unop->op_ppaddr = PL_ppaddr[type];
3060 unop->op_first = first;
3061 unop->op_flags = (U8)(flags | OPf_KIDS);
3062 unop->op_private = (U8)(1 | (flags >> 8));
3063 unop = (UNOP*) CHECKOP(type, unop);
3067 return fold_constants((OP *) unop);
3071 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3075 NewOp(1101, binop, 1, BINOP);
3078 first = newOP(OP_NULL, 0);
3080 binop->op_type = (OPCODE)type;
3081 binop->op_ppaddr = PL_ppaddr[type];
3082 binop->op_first = first;
3083 binop->op_flags = (U8)(flags | OPf_KIDS);
3086 binop->op_private = (U8)(1 | (flags >> 8));
3089 binop->op_private = (U8)(2 | (flags >> 8));
3090 first->op_sibling = last;
3093 binop = (BINOP*)CHECKOP(type, binop);
3094 if (binop->op_next || binop->op_type != (OPCODE)type)
3097 binop->op_last = binop->op_first->op_sibling;
3099 return fold_constants((OP *)binop);
3102 static int uvcompare(const void *a, const void *b)
3103 __attribute__nonnull__(1)
3104 __attribute__nonnull__(2)
3105 __attribute__pure__;
3106 static int uvcompare(const void *a, const void *b)
3108 if (*((const UV *)a) < (*(const UV *)b))
3110 if (*((const UV *)a) > (*(const UV *)b))
3112 if (*((const UV *)a+1) < (*(const UV *)b+1))
3114 if (*((const UV *)a+1) > (*(const UV *)b+1))
3120 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3123 SV * const tstr = ((SVOP*)expr)->op_sv;
3126 (repl->op_type == OP_NULL)
3127 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3129 ((SVOP*)repl)->op_sv;
3132 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3133 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3137 register short *tbl;
3139 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3140 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3141 I32 del = o->op_private & OPpTRANS_DELETE;
3144 PERL_ARGS_ASSERT_PMTRANS;
3146 PL_hints |= HINT_BLOCK_SCOPE;
3149 o->op_private |= OPpTRANS_FROM_UTF;
3152 o->op_private |= OPpTRANS_TO_UTF;
3154 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3155 SV* const listsv = newSVpvs("# comment\n");
3157 const U8* tend = t + tlen;
3158 const U8* rend = r + rlen;
3172 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3173 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3176 const U32 flags = UTF8_ALLOW_DEFAULT;
3180 t = tsave = bytes_to_utf8(t, &len);
3183 if (!to_utf && rlen) {
3185 r = rsave = bytes_to_utf8(r, &len);
3189 /* There are several snags with this code on EBCDIC:
3190 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3191 2. scan_const() in toke.c has encoded chars in native encoding which makes
3192 ranges at least in EBCDIC 0..255 range the bottom odd.
3196 U8 tmpbuf[UTF8_MAXBYTES+1];
3199 Newx(cp, 2*tlen, UV);
3201 transv = newSVpvs("");
3203 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3205 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3207 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3211 cp[2*i+1] = cp[2*i];
3215 qsort(cp, i, 2*sizeof(UV), uvcompare);
3216 for (j = 0; j < i; j++) {
3218 diff = val - nextmin;
3220 t = uvuni_to_utf8(tmpbuf,nextmin);
3221 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3223 U8 range_mark = UTF_TO_NATIVE(0xff);
3224 t = uvuni_to_utf8(tmpbuf, val - 1);
3225 sv_catpvn(transv, (char *)&range_mark, 1);
3226 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3233 t = uvuni_to_utf8(tmpbuf,nextmin);
3234 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3236 U8 range_mark = UTF_TO_NATIVE(0xff);
3237 sv_catpvn(transv, (char *)&range_mark, 1);
3239 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3240 UNICODE_ALLOW_SUPER);
3241 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3242 t = (const U8*)SvPVX_const(transv);
3243 tlen = SvCUR(transv);
3247 else if (!rlen && !del) {
3248 r = t; rlen = tlen; rend = tend;
3251 if ((!rlen && !del) || t == r ||
3252 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3254 o->op_private |= OPpTRANS_IDENTICAL;
3258 while (t < tend || tfirst <= tlast) {
3259 /* see if we need more "t" chars */
3260 if (tfirst > tlast) {
3261 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3263 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3265 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3272 /* now see if we need more "r" chars */
3273 if (rfirst > rlast) {
3275 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3277 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3279 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3288 rfirst = rlast = 0xffffffff;
3292 /* now see which range will peter our first, if either. */
3293 tdiff = tlast - tfirst;
3294 rdiff = rlast - rfirst;
3301 if (rfirst == 0xffffffff) {
3302 diff = tdiff; /* oops, pretend rdiff is infinite */
3304 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3305 (long)tfirst, (long)tlast);
3307 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3311 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3312 (long)tfirst, (long)(tfirst + diff),
3315 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3316 (long)tfirst, (long)rfirst);
3318 if (rfirst + diff > max)
3319 max = rfirst + diff;
3321 grows = (tfirst < rfirst &&
3322 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3334 else if (max > 0xff)
3339 PerlMemShared_free(cPVOPo->op_pv);
3340 cPVOPo->op_pv = NULL;
3342 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3344 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3345 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3346 PAD_SETSV(cPADOPo->op_padix, swash);
3348 SvREADONLY_on(swash);
3350 cSVOPo->op_sv = swash;
3352 SvREFCNT_dec(listsv);
3353 SvREFCNT_dec(transv);
3355 if (!del && havefinal && rlen)
3356 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3357 newSVuv((UV)final), 0);
3360 o->op_private |= OPpTRANS_GROWS;
3366 op_getmad(expr,o,'e');
3367 op_getmad(repl,o,'r');
3375 tbl = (short*)cPVOPo->op_pv;
3377 Zero(tbl, 256, short);
3378 for (i = 0; i < (I32)tlen; i++)
3380 for (i = 0, j = 0; i < 256; i++) {
3382 if (j >= (I32)rlen) {
3391 if (i < 128 && r[j] >= 128)
3401 o->op_private |= OPpTRANS_IDENTICAL;
3403 else if (j >= (I32)rlen)
3408 PerlMemShared_realloc(tbl,
3409 (0x101+rlen-j) * sizeof(short));
3410 cPVOPo->op_pv = (char*)tbl;
3412 tbl[0x100] = (short)(rlen - j);
3413 for (i=0; i < (I32)rlen - j; i++)
3414 tbl[0x101+i] = r[j+i];
3418 if (!rlen && !del) {
3421 o->op_private |= OPpTRANS_IDENTICAL;
3423 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3424 o->op_private |= OPpTRANS_IDENTICAL;
3426 for (i = 0; i < 256; i++)
3428 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3429 if (j >= (I32)rlen) {
3431 if (tbl[t[i]] == -1)
3437 if (tbl[t[i]] == -1) {
3438 if (t[i] < 128 && r[j] >= 128)
3445 if(ckWARN(WARN_MISC)) {
3446 if(del && rlen == tlen) {
3447 Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3448 } else if(rlen > tlen) {
3449 Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3454 o->op_private |= OPpTRANS_GROWS;
3456 op_getmad(expr,o,'e');
3457 op_getmad(repl,o,'r');
3467 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3472 NewOp(1101, pmop, 1, PMOP);
3473 pmop->op_type = (OPCODE)type;
3474 pmop->op_ppaddr = PL_ppaddr[type];
3475 pmop->op_flags = (U8)flags;
3476 pmop->op_private = (U8)(0 | (flags >> 8));
3478 if (PL_hints & HINT_RE_TAINT)
3479 pmop->op_pmflags |= PMf_RETAINT;
3480 if (PL_hints & HINT_LOCALE)
3481 pmop->op_pmflags |= PMf_LOCALE;
3485 assert(SvPOK(PL_regex_pad[0]));
3486 if (SvCUR(PL_regex_pad[0])) {
3487 /* Pop off the "packed" IV from the end. */
3488 SV *const repointer_list = PL_regex_pad[0];
3489 const char *p = SvEND(repointer_list) - sizeof(IV);
3490 const IV offset = *((IV*)p);
3492 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3494 SvEND_set(repointer_list, p);
3496 pmop->op_pmoffset = offset;
3497 /* This slot should be free, so assert this: */
3498 assert(PL_regex_pad[offset] == &PL_sv_undef);
3500 SV * const repointer = &PL_sv_undef;
3501 av_push(PL_regex_padav, repointer);
3502 pmop->op_pmoffset = av_len(PL_regex_padav);
3503 PL_regex_pad = AvARRAY(PL_regex_padav);
3507 return CHECKOP(type, pmop);
3510 /* Given some sort of match op o, and an expression expr containing a
3511 * pattern, either compile expr into a regex and attach it to o (if it's
3512 * constant), or convert expr into a runtime regcomp op sequence (if it's
3515 * isreg indicates that the pattern is part of a regex construct, eg
3516 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3517 * split "pattern", which aren't. In the former case, expr will be a list
3518 * if the pattern contains more than one term (eg /a$b/) or if it contains
3519 * a replacement, ie s/// or tr///.
3523 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3528 I32 repl_has_vars = 0;
3532 PERL_ARGS_ASSERT_PMRUNTIME;
3534 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3535 /* last element in list is the replacement; pop it */
3537 repl = cLISTOPx(expr)->op_last;
3538 kid = cLISTOPx(expr)->op_first;
3539 while (kid->op_sibling != repl)
3540 kid = kid->op_sibling;
3541 kid->op_sibling = NULL;
3542 cLISTOPx(expr)->op_last = kid;
3545 if (isreg && expr->op_type == OP_LIST &&
3546 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3548 /* convert single element list to element */
3549 OP* const oe = expr;
3550 expr = cLISTOPx(oe)->op_first->op_sibling;
3551 cLISTOPx(oe)->op_first->op_sibling = NULL;
3552 cLISTOPx(oe)->op_last = NULL;
3556 if (o->op_type == OP_TRANS) {
3557 return pmtrans(o, expr, repl);
3560 reglist = isreg && expr->op_type == OP_LIST;
3564 PL_hints |= HINT_BLOCK_SCOPE;
3567 if (expr->op_type == OP_CONST) {
3568 SV *pat = ((SVOP*)expr)->op_sv;
3569 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3571 if (o->op_flags & OPf_SPECIAL)
3572 pm_flags |= RXf_SPLIT;
3575 assert (SvUTF8(pat));
3576 } else if (SvUTF8(pat)) {
3577 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3578 trapped in use 'bytes'? */
3579 /* Make a copy of the octet sequence, but without the flag on, as
3580 the compiler now honours the SvUTF8 flag on pat. */
3582 const char *const p = SvPV(pat, len);
3583 pat = newSVpvn_flags(p, len, SVs_TEMP);
3586 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3589 op_getmad(expr,(OP*)pm,'e');
3595 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3596 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3598 : OP_REGCMAYBE),0,expr);
3600 NewOp(1101, rcop, 1, LOGOP);
3601 rcop->op_type = OP_REGCOMP;
3602 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3603 rcop->op_first = scalar(expr);
3604 rcop->op_flags |= OPf_KIDS
3605 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3606 | (reglist ? OPf_STACKED : 0);
3607 rcop->op_private = 1;
3610 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3612 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3615 /* establish postfix order */
3616 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3618 rcop->op_next = expr;
3619 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3622 rcop->op_next = LINKLIST(expr);
3623 expr->op_next = (OP*)rcop;
3626 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3631 if (pm->op_pmflags & PMf_EVAL) {
3633 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3634 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3636 else if (repl->op_type == OP_CONST)
3640 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3641 if (curop->op_type == OP_SCOPE
3642 || curop->op_type == OP_LEAVE
3643 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3644 if (curop->op_type == OP_GV) {
3645 GV * const gv = cGVOPx_gv(curop);
3647 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3650 else if (curop->op_type == OP_RV2CV)
3652 else if (curop->op_type == OP_RV2SV ||
3653 curop->op_type == OP_RV2AV ||
3654 curop->op_type == OP_RV2HV ||
3655 curop->op_type == OP_RV2GV) {
3656 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3659 else if (curop->op_type == OP_PADSV ||
3660 curop->op_type == OP_PADAV ||
3661 curop->op_type == OP_PADHV ||
3662 curop->op_type == OP_PADANY)
3666 else if (curop->op_type == OP_PUSHRE)
3667 NOOP; /* Okay here, dangerous in newASSIGNOP */
3677 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3679 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3680 prepend_elem(o->op_type, scalar(repl), o);
3683 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3684 pm->op_pmflags |= PMf_MAYBE_CONST;
3686 NewOp(1101, rcop, 1, LOGOP);
3687 rcop->op_type = OP_SUBSTCONT;
3688 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3689 rcop->op_first = scalar(repl);
3690 rcop->op_flags |= OPf_KIDS;
3691 rcop->op_private = 1;
3694 /* establish postfix order */
3695 rcop->op_next = LINKLIST(repl);
3696 repl->op_next = (OP*)rcop;
3698 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3699 assert(!(pm->op_pmflags & PMf_ONCE));
3700 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3709 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3714 PERL_ARGS_ASSERT_NEWSVOP;
3716 NewOp(1101, svop, 1, SVOP);
3717 svop->op_type = (OPCODE)type;
3718 svop->op_ppaddr = PL_ppaddr[type];
3720 svop->op_next = (OP*)svop;
3721 svop->op_flags = (U8)flags;
3722 if (PL_opargs[type] & OA_RETSCALAR)
3724 if (PL_opargs[type] & OA_TARGET)
3725 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3726 return CHECKOP(type, svop);
3731 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3736 PERL_ARGS_ASSERT_NEWPADOP;
3738 NewOp(1101, padop, 1, PADOP);
3739 padop->op_type = (OPCODE)type;
3740 padop->op_ppaddr = PL_ppaddr[type];
3741 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3742 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3743 PAD_SETSV(padop->op_padix, sv);
3746 padop->op_next = (OP*)padop;
3747 padop->op_flags = (U8)flags;
3748 if (PL_opargs[type] & OA_RETSCALAR)
3750 if (PL_opargs[type] & OA_TARGET)
3751 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3752 return CHECKOP(type, padop);
3757 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3761 PERL_ARGS_ASSERT_NEWGVOP;
3765 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3767 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3772 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3776 NewOp(1101, pvop, 1, PVOP);
3777 pvop->op_type = (OPCODE)type;
3778 pvop->op_ppaddr = PL_ppaddr[type];
3780 pvop->op_next = (OP*)pvop;
3781 pvop->op_flags = (U8)flags;
3782 if (PL_opargs[type] & OA_RETSCALAR)
3784 if (PL_opargs[type] & OA_TARGET)
3785 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3786 return CHECKOP(type, pvop);
3794 Perl_package(pTHX_ OP *o)
3797 SV *const sv = cSVOPo->op_sv;
3802 PERL_ARGS_ASSERT_PACKAGE;
3804 save_hptr(&PL_curstash);
3805 save_item(PL_curstname);
3807 PL_curstash = gv_stashsv(sv, GV_ADD);
3809 sv_setsv(PL_curstname, sv);
3811 PL_hints |= HINT_BLOCK_SCOPE;
3812 PL_parser->copline = NOLINE;
3813 PL_parser->expect = XSTATE;
3818 if (!PL_madskills) {
3823 pegop = newOP(OP_NULL,0);
3824 op_getmad(o,pegop,'P');
3834 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3841 OP *pegop = newOP(OP_NULL,0);
3844 PERL_ARGS_ASSERT_UTILIZE;
3846 if (idop->op_type != OP_CONST)
3847 Perl_croak(aTHX_ "Module name must be constant");
3850 op_getmad(idop,pegop,'U');
3855 SV * const vesv = ((SVOP*)version)->op_sv;
3858 op_getmad(version,pegop,'V');
3859 if (!arg && !SvNIOKp(vesv)) {
3866 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3867 Perl_croak(aTHX_ "Version number must be a constant number");
3869 /* Make copy of idop so we don't free it twice */
3870 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3872 /* Fake up a method call to VERSION */
3873 meth = newSVpvs_share("VERSION");
3874 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3875 append_elem(OP_LIST,
3876 prepend_elem(OP_LIST, pack, list(version)),
3877 newSVOP(OP_METHOD_NAMED, 0, meth)));
3881 /* Fake up an import/unimport */
3882 if (arg && arg->op_type == OP_STUB) {
3884 op_getmad(arg,pegop,'S');
3885 imop = arg; /* no import on explicit () */
3887 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3888 imop = NULL; /* use 5.0; */
3890 idop->op_private |= OPpCONST_NOVER;
3896 op_getmad(arg,pegop,'A');
3898 /* Make copy of idop so we don't free it twice */
3899 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3901 /* Fake up a method call to import/unimport */
3903 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3904 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3905 append_elem(OP_LIST,
3906 prepend_elem(OP_LIST, pack, list(arg)),
3907 newSVOP(OP_METHOD_NAMED, 0, meth)));
3910 /* Fake up the BEGIN {}, which does its thing immediately. */
3912 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3915 append_elem(OP_LINESEQ,
3916 append_elem(OP_LINESEQ,
3917 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3918 newSTATEOP(0, NULL, veop)),
3919 newSTATEOP(0, NULL, imop) ));
3921 /* The "did you use incorrect case?" warning used to be here.
3922 * The problem is that on case-insensitive filesystems one
3923 * might get false positives for "use" (and "require"):
3924 * "use Strict" or "require CARP" will work. This causes
3925 * portability problems for the script: in case-strict
3926 * filesystems the script will stop working.
3928 * The "incorrect case" warning checked whether "use Foo"
3929 * imported "Foo" to your namespace, but that is wrong, too:
3930 * there is no requirement nor promise in the language that
3931 * a Foo.pm should or would contain anything in package "Foo".
3933 * There is very little Configure-wise that can be done, either:
3934 * the case-sensitivity of the build filesystem of Perl does not
3935 * help in guessing the case-sensitivity of the runtime environment.
3938 PL_hints |= HINT_BLOCK_SCOPE;
3939 PL_parser->copline = NOLINE;
3940 PL_parser->expect = XSTATE;
3941 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3944 if (!PL_madskills) {
3945 /* FIXME - don't allocate pegop if !PL_madskills */
3954 =head1 Embedding Functions
3956 =for apidoc load_module
3958 Loads the module whose name is pointed to by the string part of name.
3959 Note that the actual module name, not its filename, should be given.
3960 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3961 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3962 (or 0 for no flags). ver, if specified, provides version semantics
3963 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3964 arguments can be used to specify arguments to the module's import()
3965 method, similar to C<use Foo::Bar VERSION LIST>. They must be
3966 terminated with a final NULL pointer. Note that this list can only
3967 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
3968 Otherwise at least a single NULL pointer to designate the default
3969 import list is required.
3974 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3978 PERL_ARGS_ASSERT_LOAD_MODULE;
3980 va_start(args, ver);
3981 vload_module(flags, name, ver, &args);
3985 #ifdef PERL_IMPLICIT_CONTEXT
3987 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3991 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3992 va_start(args, ver);
3993 vload_module(flags, name, ver, &args);
3999 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4003 OP * const modname = newSVOP(OP_CONST, 0, name);
4005 PERL_ARGS_ASSERT_VLOAD_MODULE;
4007 modname->op_private |= OPpCONST_BARE;
4009 veop = newSVOP(OP_CONST, 0, ver);
4013 if (flags & PERL_LOADMOD_NOIMPORT) {
4014 imop = sawparens(newNULLLIST());
4016 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4017 imop = va_arg(*args, OP*);
4022 sv = va_arg(*args, SV*);
4024 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4025 sv = va_arg(*args, SV*);
4029 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4030 * that it has a PL_parser to play with while doing that, and also
4031 * that it doesn't mess with any existing parser, by creating a tmp
4032 * new parser with lex_start(). This won't actually be used for much,
4033 * since pp_require() will create another parser for the real work. */
4036 SAVEVPTR(PL_curcop);
4037 lex_start(NULL, NULL, FALSE);
4038 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4039 veop, modname, imop);
4044 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4050 PERL_ARGS_ASSERT_DOFILE;
4052 if (!force_builtin) {
4053 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4054 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4055 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4056 gv = gvp ? *gvp : NULL;
4060 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4061 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4062 append_elem(OP_LIST, term,
4063 scalar(newUNOP(OP_RV2CV, 0,
4064 newGVOP(OP_GV, 0, gv))))));
4067 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4073 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4075 return newBINOP(OP_LSLICE, flags,
4076 list(force_list(subscript)),
4077 list(force_list(listval)) );
4081 S_is_list_assignment(pTHX_ register const OP *o)
4089 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4090 o = cUNOPo->op_first;
4092 flags = o->op_flags;
4094 if (type == OP_COND_EXPR) {
4095 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4096 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4101 yyerror("Assignment to both a list and a scalar");
4105 if (type == OP_LIST &&
4106 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4107 o->op_private & OPpLVAL_INTRO)
4110 if (type == OP_LIST || flags & OPf_PARENS ||
4111 type == OP_RV2AV || type == OP_RV2HV ||
4112 type == OP_ASLICE || type == OP_HSLICE)
4115 if (type == OP_PADAV || type == OP_PADHV)
4118 if (type == OP_RV2SV)
4125 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4131 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4132 return newLOGOP(optype, 0,
4133 mod(scalar(left), optype),
4134 newUNOP(OP_SASSIGN, 0, scalar(right)));
4137 return newBINOP(optype, OPf_STACKED,
4138 mod(scalar(left), optype), scalar(right));
4142 if (is_list_assignment(left)) {
4143 static const char no_list_state[] = "Initialization of state variables"
4144 " in list context currently forbidden";
4146 bool maybe_common_vars = TRUE;
4149 /* Grandfathering $[ assignment here. Bletch.*/
4150 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4151 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4152 left = mod(left, OP_AASSIGN);
4155 else if (left->op_type == OP_CONST) {
4157 /* Result of assignment is always 1 (or we'd be dead already) */
4158 return newSVOP(OP_CONST, 0, newSViv(1));
4160 curop = list(force_list(left));
4161 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4162 o->op_private = (U8)(0 | (flags >> 8));
4164 if ((left->op_type == OP_LIST
4165 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4167 OP* lop = ((LISTOP*)left)->op_first;
4168 maybe_common_vars = FALSE;
4170 if (lop->op_type == OP_PADSV ||
4171 lop->op_type == OP_PADAV ||
4172 lop->op_type == OP_PADHV ||
4173 lop->op_type == OP_PADANY) {
4174 if (!(lop->op_private & OPpLVAL_INTRO))
4175 maybe_common_vars = TRUE;
4177 if (lop->op_private & OPpPAD_STATE) {
4178 if (left->op_private & OPpLVAL_INTRO) {
4179 /* Each variable in state($a, $b, $c) = ... */
4182 /* Each state variable in
4183 (state $a, my $b, our $c, $d, undef) = ... */
4185 yyerror(no_list_state);
4187 /* Each my variable in
4188 (state $a, my $b, our $c, $d, undef) = ... */
4190 } else if (lop->op_type == OP_UNDEF ||
4191 lop->op_type == OP_PUSHMARK) {
4192 /* undef may be interesting in
4193 (state $a, undef, state $c) */
4195 /* Other ops in the list. */
4196 maybe_common_vars = TRUE;
4198 lop = lop->op_sibling;
4201 else if ((left->op_private & OPpLVAL_INTRO)
4202 && ( left->op_type == OP_PADSV
4203 || left->op_type == OP_PADAV
4204 || left->op_type == OP_PADHV
4205 || left->op_type == OP_PADANY))
4207 maybe_common_vars = FALSE;
4208 if (left->op_private & OPpPAD_STATE) {
4209 /* All single variable list context state assignments, hence
4219 yyerror(no_list_state);
4223 /* PL_generation sorcery:
4224 * an assignment like ($a,$b) = ($c,$d) is easier than
4225 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4226 * To detect whether there are common vars, the global var
4227 * PL_generation is incremented for each assign op we compile.
4228 * Then, while compiling the assign op, we run through all the
4229 * variables on both sides of the assignment, setting a spare slot
4230 * in each of them to PL_generation. If any of them already have
4231 * that value, we know we've got commonality. We could use a
4232 * single bit marker, but then we'd have to make 2 passes, first
4233 * to clear the flag, then to test and set it. To find somewhere
4234 * to store these values, evil chicanery is done with SvUVX().
4237 if (maybe_common_vars) {
4240 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4241 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4242 if (curop->op_type == OP_GV) {
4243 GV *gv = cGVOPx_gv(curop);
4245 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4247 GvASSIGN_GENERATION_set(gv, PL_generation);
4249 else if (curop->op_type == OP_PADSV ||
4250 curop->op_type == OP_PADAV ||
4251 curop->op_type == OP_PADHV ||
4252 curop->op_type == OP_PADANY)
4254 if (PAD_COMPNAME_GEN(curop->op_targ)
4255 == (STRLEN)PL_generation)
4257 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4260 else if (curop->op_type == OP_RV2CV)
4262 else if (curop->op_type == OP_RV2SV ||
4263 curop->op_type == OP_RV2AV ||
4264 curop->op_type == OP_RV2HV ||
4265 curop->op_type == OP_RV2GV) {
4266 if (lastop->op_type != OP_GV) /* funny deref? */
4269 else if (curop->op_type == OP_PUSHRE) {
4271 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4272 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4274 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4276 GvASSIGN_GENERATION_set(gv, PL_generation);
4280 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4283 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4285 GvASSIGN_GENERATION_set(gv, PL_generation);
4295 o->op_private |= OPpASSIGN_COMMON;
4298 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4299 OP* tmpop = ((LISTOP*)right)->op_first;
4300 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4301 PMOP * const pm = (PMOP*)tmpop;
4302 if (left->op_type == OP_RV2AV &&
4303 !(left->op_private & OPpLVAL_INTRO) &&
4304 !(o->op_private & OPpASSIGN_COMMON) )
4306 tmpop = ((UNOP*)left)->op_first;
4307 if (tmpop->op_type == OP_GV
4309 && !pm->op_pmreplrootu.op_pmtargetoff
4311 && !pm->op_pmreplrootu.op_pmtargetgv
4315 pm->op_pmreplrootu.op_pmtargetoff
4316 = cPADOPx(tmpop)->op_padix;
4317 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4319 pm->op_pmreplrootu.op_pmtargetgv
4320 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4321 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4323 pm->op_pmflags |= PMf_ONCE;
4324 tmpop = cUNOPo->op_first; /* to list (nulled) */
4325 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4326 tmpop->op_sibling = NULL; /* don't free split */
4327 right->op_next = tmpop->op_next; /* fix starting loc */
4328 op_free(o); /* blow off assign */
4329 right->op_flags &= ~OPf_WANT;
4330 /* "I don't know and I don't care." */
4335 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4336 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4338 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4339 if (SvIOK(sv) && SvIVX(sv) == 0)
4340 sv_setiv(sv, PL_modcount+1);
4348 right = newOP(OP_UNDEF, 0);
4349 if (right->op_type == OP_READLINE) {
4350 right->op_flags |= OPf_STACKED;
4351 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4354 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4355 o = newBINOP(OP_SASSIGN, flags,
4356 scalar(right), mod(scalar(left), OP_SASSIGN) );
4360 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4361 deprecate("assignment to $[");
4363 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4364 o->op_private |= OPpCONST_ARYBASE;
4372 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4375 const U32 seq = intro_my();
4378 NewOp(1101, cop, 1, COP);
4379 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4380 cop->op_type = OP_DBSTATE;
4381 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4384 cop->op_type = OP_NEXTSTATE;
4385 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4387 cop->op_flags = (U8)flags;
4388 CopHINTS_set(cop, PL_hints);
4390 cop->op_private |= NATIVE_HINTS;
4392 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4393 cop->op_next = (OP*)cop;
4396 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4397 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4399 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4400 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4401 if (cop->cop_hints_hash) {
4403 cop->cop_hints_hash->refcounted_he_refcnt++;
4404 HINTS_REFCNT_UNLOCK;
4408 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4410 PL_hints |= HINT_BLOCK_SCOPE;
4411 /* It seems that we need to defer freeing this pointer, as other parts
4412 of the grammar end up wanting to copy it after this op has been
4417 if (PL_parser && PL_parser->copline == NOLINE)
4418 CopLINE_set(cop, CopLINE(PL_curcop));
4420 CopLINE_set(cop, PL_parser->copline);
4422 PL_parser->copline = NOLINE;
4425 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4427 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4429 CopSTASH_set(cop, PL_curstash);
4431 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4432 /* this line can have a breakpoint - store the cop in IV */
4433 AV *av = CopFILEAVx(PL_curcop);
4435 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4436 if (svp && *svp != &PL_sv_undef ) {
4437 (void)SvIOK_on(*svp);
4438 SvIV_set(*svp, PTR2IV(cop));
4443 if (flags & OPf_SPECIAL)
4445 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4450 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4454 PERL_ARGS_ASSERT_NEWLOGOP;
4456 return new_logop(type, flags, &first, &other);
4460 S_search_const(pTHX_ OP *o)
4462 PERL_ARGS_ASSERT_SEARCH_CONST;
4464 switch (o->op_type) {
4468 if (o->op_flags & OPf_KIDS)
4469 return search_const(cUNOPo->op_first);
4476 if (!(o->op_flags & OPf_KIDS))
4478 kid = cLISTOPo->op_first;
4480 switch (kid->op_type) {
4484 kid = kid->op_sibling;
4487 if (kid != cLISTOPo->op_last)
4493 kid = cLISTOPo->op_last;
4495 return search_const(kid);
4503 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4511 int prepend_not = 0;
4513 PERL_ARGS_ASSERT_NEW_LOGOP;
4518 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4519 return newBINOP(type, flags, scalar(first), scalar(other));
4521 scalarboolean(first);
4522 /* optimize AND and OR ops that have NOTs as children */
4523 if (first->op_type == OP_NOT
4524 && (first->op_flags & OPf_KIDS)
4525 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4526 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4528 if (type == OP_AND || type == OP_OR) {
4534 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4536 prepend_not = 1; /* prepend a NOT op later */
4540 /* search for a constant op that could let us fold the test */
4541 if ((cstop = search_const(first))) {
4542 if (cstop->op_private & OPpCONST_STRICT)
4543 no_bareword_allowed(cstop);
4544 else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4545 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4546 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4547 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4548 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4550 if (other->op_type == OP_CONST)
4551 other->op_private |= OPpCONST_SHORTCIRCUIT;
4553 OP *newop = newUNOP(OP_NULL, 0, other);
4554 op_getmad(first, newop, '1');
4555 newop->op_targ = type; /* set "was" field */
4559 if (other->op_type == OP_LEAVE)
4560 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4564 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4565 const OP *o2 = other;
4566 if ( ! (o2->op_type == OP_LIST
4567 && (( o2 = cUNOPx(o2)->op_first))
4568 && o2->op_type == OP_PUSHMARK
4569 && (( o2 = o2->op_sibling)) )
4572 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4573 || o2->op_type == OP_PADHV)
4574 && o2->op_private & OPpLVAL_INTRO
4575 && !(o2->op_private & OPpPAD_STATE)
4576 && ckWARN(WARN_DEPRECATED))
4578 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4579 "Deprecated use of my() in false conditional");
4583 if (first->op_type == OP_CONST)
4584 first->op_private |= OPpCONST_SHORTCIRCUIT;
4586 first = newUNOP(OP_NULL, 0, first);
4587 op_getmad(other, first, '2');
4588 first->op_targ = type; /* set "was" field */
4595 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4596 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4598 const OP * const k1 = ((UNOP*)first)->op_first;
4599 const OP * const k2 = k1->op_sibling;
4601 switch (first->op_type)
4604 if (k2 && k2->op_type == OP_READLINE
4605 && (k2->op_flags & OPf_STACKED)
4606 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4608 warnop = k2->op_type;
4613 if (k1->op_type == OP_READDIR
4614 || k1->op_type == OP_GLOB
4615 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4616 || k1->op_type == OP_EACH)
4618 warnop = ((k1->op_type == OP_NULL)
4619 ? (OPCODE)k1->op_targ : k1->op_type);
4624 const line_t oldline = CopLINE(PL_curcop);
4625 CopLINE_set(PL_curcop, PL_parser->copline);
4626 Perl_warner(aTHX_ packWARN(WARN_MISC),
4627 "Value of %s%s can be \"0\"; test with defined()",
4629 ((warnop == OP_READLINE || warnop == OP_GLOB)
4630 ? " construct" : "() operator"));
4631 CopLINE_set(PL_curcop, oldline);
4638 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4639 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4641 NewOp(1101, logop, 1, LOGOP);
4643 logop->op_type = (OPCODE)type;
4644 logop->op_ppaddr = PL_ppaddr[type];
4645 logop->op_first = first;
4646 logop->op_flags = (U8)(flags | OPf_KIDS);
4647 logop->op_other = LINKLIST(other);
4648 logop->op_private = (U8)(1 | (flags >> 8));
4650 /* establish postfix order */
4651 logop->op_next = LINKLIST(first);
4652 first->op_next = (OP*)logop;
4653 first->op_sibling = other;
4655 CHECKOP(type,logop);
4657 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4664 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4672 PERL_ARGS_ASSERT_NEWCONDOP;
4675 return newLOGOP(OP_AND, 0, first, trueop);
4677 return newLOGOP(OP_OR, 0, first, falseop);
4679 scalarboolean(first);
4680 if ((cstop = search_const(first))) {
4681 /* Left or right arm of the conditional? */
4682 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4683 OP *live = left ? trueop : falseop;
4684 OP *const dead = left ? falseop : trueop;
4685 if (cstop->op_private & OPpCONST_BARE &&
4686 cstop->op_private & OPpCONST_STRICT) {
4687 no_bareword_allowed(cstop);
4690 /* This is all dead code when PERL_MAD is not defined. */
4691 live = newUNOP(OP_NULL, 0, live);
4692 op_getmad(first, live, 'C');
4693 op_getmad(dead, live, left ? 'e' : 't');
4698 if (live->op_type == OP_LEAVE)
4699 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4702 NewOp(1101, logop, 1, LOGOP);
4703 logop->op_type = OP_COND_EXPR;
4704 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4705 logop->op_first = first;
4706 logop->op_flags = (U8)(flags | OPf_KIDS);
4707 logop->op_private = (U8)(1 | (flags >> 8));
4708 logop->op_other = LINKLIST(trueop);
4709 logop->op_next = LINKLIST(falseop);
4711 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4714 /* establish postfix order */
4715 start = LINKLIST(first);
4716 first->op_next = (OP*)logop;
4718 first->op_sibling = trueop;
4719 trueop->op_sibling = falseop;
4720 o = newUNOP(OP_NULL, 0, (OP*)logop);
4722 trueop->op_next = falseop->op_next = o;
4729 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4738 PERL_ARGS_ASSERT_NEWRANGE;
4740 NewOp(1101, range, 1, LOGOP);
4742 range->op_type = OP_RANGE;
4743 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4744 range->op_first = left;
4745 range->op_flags = OPf_KIDS;
4746 leftstart = LINKLIST(left);
4747 range->op_other = LINKLIST(right);
4748 range->op_private = (U8)(1 | (flags >> 8));
4750 left->op_sibling = right;
4752 range->op_next = (OP*)range;
4753 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4754 flop = newUNOP(OP_FLOP, 0, flip);
4755 o = newUNOP(OP_NULL, 0, flop);
4757 range->op_next = leftstart;
4759 left->op_next = flip;
4760 right->op_next = flop;
4762 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4763 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4764 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4765 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4767 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4768 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4771 if (!flip->op_private || !flop->op_private)
4772 linklist(o); /* blow off optimizer unless constant */
4778 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4783 const bool once = block && block->op_flags & OPf_SPECIAL &&
4784 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4786 PERL_UNUSED_ARG(debuggable);
4789 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4790 return block; /* do {} while 0 does once */
4791 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4792 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4793 expr = newUNOP(OP_DEFINED, 0,
4794 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4795 } else if (expr->op_flags & OPf_KIDS) {
4796 const OP * const k1 = ((UNOP*)expr)->op_first;
4797 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4798 switch (expr->op_type) {
4800 if (k2 && k2->op_type == OP_READLINE
4801 && (k2->op_flags & OPf_STACKED)
4802 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4803 expr = newUNOP(OP_DEFINED, 0, expr);
4807 if (k1 && (k1->op_type == OP_READDIR
4808 || k1->op_type == OP_GLOB
4809 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4810 || k1->op_type == OP_EACH))
4811 expr = newUNOP(OP_DEFINED, 0, expr);
4817 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4818 * op, in listop. This is wrong. [perl #27024] */
4820 block = newOP(OP_NULL, 0);
4821 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4822 o = new_logop(OP_AND, 0, &expr, &listop);
4825 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4827 if (once && o != listop)
4828 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4831 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4833 o->op_flags |= flags;
4835 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4840 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4841 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4850 PERL_UNUSED_ARG(debuggable);
4853 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4854 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4855 expr = newUNOP(OP_DEFINED, 0,
4856 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4857 } else if (expr->op_flags & OPf_KIDS) {
4858 const OP * const k1 = ((UNOP*)expr)->op_first;
4859 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4860 switch (expr->op_type) {
4862 if (k2 && k2->op_type == OP_READLINE
4863 && (k2->op_flags & OPf_STACKED)
4864 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4865 expr = newUNOP(OP_DEFINED, 0, expr);
4869 if (k1 && (k1->op_type == OP_READDIR
4870 || k1->op_type == OP_GLOB
4871 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4872 || k1->op_type == OP_EACH))
4873 expr = newUNOP(OP_DEFINED, 0, expr);
4880 block = newOP(OP_NULL, 0);
4881 else if (cont || has_my) {
4882 block = scope(block);
4886 next = LINKLIST(cont);
4889 OP * const unstack = newOP(OP_UNSTACK, 0);
4892 cont = append_elem(OP_LINESEQ, cont, unstack);
4896 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4898 redo = LINKLIST(listop);
4901 PL_parser->copline = (line_t)whileline;
4903 o = new_logop(OP_AND, 0, &expr, &listop);
4904 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4905 op_free(expr); /* oops, it's a while (0) */
4907 return NULL; /* listop already freed by new_logop */
4910 ((LISTOP*)listop)->op_last->op_next =
4911 (o == listop ? redo : LINKLIST(o));
4917 NewOp(1101,loop,1,LOOP);
4918 loop->op_type = OP_ENTERLOOP;
4919 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4920 loop->op_private = 0;
4921 loop->op_next = (OP*)loop;
4924 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4926 loop->op_redoop = redo;
4927 loop->op_lastop = o;
4928 o->op_private |= loopflags;
4931 loop->op_nextop = next;
4933 loop->op_nextop = o;
4935 o->op_flags |= flags;
4936 o->op_private |= (flags >> 8);
4941 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4946 PADOFFSET padoff = 0;
4951 PERL_ARGS_ASSERT_NEWFOROP;
4954 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4955 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4956 sv->op_type = OP_RV2GV;
4957 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4959 /* The op_type check is needed to prevent a possible segfault
4960 * if the loop variable is undeclared and 'strict vars' is in
4961 * effect. This is illegal but is nonetheless parsed, so we
4962 * may reach this point with an OP_CONST where we're expecting
4965 if (cUNOPx(sv)->op_first->op_type == OP_GV
4966 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4967 iterpflags |= OPpITER_DEF;
4969 else if (sv->op_type == OP_PADSV) { /* private variable */
4970 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4971 padoff = sv->op_targ;
4981 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4983 SV *const namesv = PAD_COMPNAME_SV(padoff);
4985 const char *const name = SvPV_const(namesv, len);
4987 if (len == 2 && name[0] == '$' && name[1] == '_')
4988 iterpflags |= OPpITER_DEF;
4992 const PADOFFSET offset = pad_findmy("$_");
4993 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4994 sv = newGVOP(OP_GV, 0, PL_defgv);
4999 iterpflags |= OPpITER_DEF;
5001 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5002 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5003 iterflags |= OPf_STACKED;
5005 else if (expr->op_type == OP_NULL &&
5006 (expr->op_flags & OPf_KIDS) &&
5007 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5009 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5010 * set the STACKED flag to indicate that these values are to be
5011 * treated as min/max values by 'pp_iterinit'.
5013 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5014 LOGOP* const range = (LOGOP*) flip->op_first;
5015 OP* const left = range->op_first;
5016 OP* const right = left->op_sibling;
5019 range->op_flags &= ~OPf_KIDS;
5020 range->op_first = NULL;
5022 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5023 listop->op_first->op_next = range->op_next;
5024 left->op_next = range->op_other;
5025 right->op_next = (OP*)listop;
5026 listop->op_next = listop->op_first;
5029 op_getmad(expr,(OP*)listop,'O');
5033 expr = (OP*)(listop);
5035 iterflags |= OPf_STACKED;
5038 expr = mod(force_list(expr), OP_GREPSTART);
5041 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5042 append_elem(OP_LIST, expr, scalar(sv))));
5043 assert(!loop->op_next);
5044 /* for my $x () sets OPpLVAL_INTRO;
5045 * for our $x () sets OPpOUR_INTRO */
5046 loop->op_private = (U8)iterpflags;
5047 #ifdef PL_OP_SLAB_ALLOC
5050 NewOp(1234,tmp,1,LOOP);
5051 Copy(loop,tmp,1,LISTOP);
5052 S_op_destroy(aTHX_ (OP*)loop);
5056 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5058 loop->op_targ = padoff;
5059 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5061 op_getmad(madsv, (OP*)loop, 'v');
5062 PL_parser->copline = forline;
5063 return newSTATEOP(0, label, wop);
5067 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5072 PERL_ARGS_ASSERT_NEWLOOPEX;
5074 if (type != OP_GOTO || label->op_type == OP_CONST) {
5075 /* "last()" means "last" */
5076 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5077 o = newOP(type, OPf_SPECIAL);
5079 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5080 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5084 op_getmad(label,o,'L');
5090 /* Check whether it's going to be a goto &function */
5091 if (label->op_type == OP_ENTERSUB
5092 && !(label->op_flags & OPf_STACKED))
5093 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5094 o = newUNOP(type, OPf_STACKED, label);
5096 PL_hints |= HINT_BLOCK_SCOPE;
5100 /* if the condition is a literal array or hash
5101 (or @{ ... } etc), make a reference to it.
5104 S_ref_array_or_hash(pTHX_ OP *cond)
5107 && (cond->op_type == OP_RV2AV
5108 || cond->op_type == OP_PADAV
5109 || cond->op_type == OP_RV2HV
5110 || cond->op_type == OP_PADHV))
5112 return newUNOP(OP_REFGEN,
5113 0, mod(cond, OP_REFGEN));
5119 /* These construct the optree fragments representing given()
5122 entergiven and enterwhen are LOGOPs; the op_other pointer
5123 points up to the associated leave op. We need this so we
5124 can put it in the context and make break/continue work.
5125 (Also, of course, pp_enterwhen will jump straight to
5126 op_other if the match fails.)
5130 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5131 I32 enter_opcode, I32 leave_opcode,
5132 PADOFFSET entertarg)
5138 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5140 NewOp(1101, enterop, 1, LOGOP);
5141 enterop->op_type = (Optype)enter_opcode;
5142 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5143 enterop->op_flags = (U8) OPf_KIDS;
5144 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5145 enterop->op_private = 0;
5147 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5150 enterop->op_first = scalar(cond);
5151 cond->op_sibling = block;
5153 o->op_next = LINKLIST(cond);
5154 cond->op_next = (OP *) enterop;
5157 /* This is a default {} block */
5158 enterop->op_first = block;
5159 enterop->op_flags |= OPf_SPECIAL;
5161 o->op_next = (OP *) enterop;
5164 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5165 entergiven and enterwhen both
5168 enterop->op_next = LINKLIST(block);
5169 block->op_next = enterop->op_other = o;
5174 /* Does this look like a boolean operation? For these purposes
5175 a boolean operation is:
5176 - a subroutine call [*]
5177 - a logical connective
5178 - a comparison operator
5179 - a filetest operator, with the exception of -s -M -A -C
5180 - defined(), exists() or eof()
5181 - /$re/ or $foo =~ /$re/
5183 [*] possibly surprising
5186 S_looks_like_bool(pTHX_ const OP *o)
5190 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5192 switch(o->op_type) {
5195 return looks_like_bool(cLOGOPo->op_first);
5199 looks_like_bool(cLOGOPo->op_first)
5200 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5204 o->op_flags & OPf_KIDS
5205 && looks_like_bool(cUNOPo->op_first));
5209 case OP_NOT: case OP_XOR:
5211 case OP_EQ: case OP_NE: case OP_LT:
5212 case OP_GT: case OP_LE: case OP_GE:
5214 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5215 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5217 case OP_SEQ: case OP_SNE: case OP_SLT:
5218 case OP_SGT: case OP_SLE: case OP_SGE:
5222 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5223 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5224 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5225 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5226 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5227 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5228 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5229 case OP_FTTEXT: case OP_FTBINARY:
5231 case OP_DEFINED: case OP_EXISTS:
5232 case OP_MATCH: case OP_EOF:
5239 /* Detect comparisons that have been optimized away */
5240 if (cSVOPo->op_sv == &PL_sv_yes
5241 || cSVOPo->op_sv == &PL_sv_no)
5254 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5257 PERL_ARGS_ASSERT_NEWGIVENOP;
5258 return newGIVWHENOP(
5259 ref_array_or_hash(cond),
5261 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5265 /* If cond is null, this is a default {} block */
5267 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5269 const bool cond_llb = (!cond || looks_like_bool(cond));
5272 PERL_ARGS_ASSERT_NEWWHENOP;
5277 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5279 scalar(ref_array_or_hash(cond)));
5282 return newGIVWHENOP(
5284 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5285 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5289 =for apidoc cv_undef
5291 Clear out all the active components of a CV. This can happen either
5292 by an explicit C<undef &foo>, or by the reference count going to zero.
5293 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5294 children can still follow the full lexical scope chain.
5300 Perl_cv_undef(pTHX_ CV *cv)
5304 PERL_ARGS_ASSERT_CV_UNDEF;
5306 DEBUG_X(PerlIO_printf(Perl_debug_log,
5307 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5308 PTR2UV(cv), PTR2UV(PL_comppad))
5312 if (CvFILE(cv) && !CvISXSUB(cv)) {
5313 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5314 Safefree(CvFILE(cv));
5319 if (!CvISXSUB(cv) && CvROOT(cv)) {
5320 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5321 Perl_croak(aTHX_ "Can't undef active subroutine");
5324 PAD_SAVE_SETNULLPAD();
5326 op_free(CvROOT(cv));
5331 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5336 /* remove CvOUTSIDE unless this is an undef rather than a free */
5337 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5338 if (!CvWEAKOUTSIDE(cv))
5339 SvREFCNT_dec(CvOUTSIDE(cv));
5340 CvOUTSIDE(cv) = NULL;
5343 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5346 if (CvISXSUB(cv) && CvXSUB(cv)) {
5349 /* delete all flags except WEAKOUTSIDE */
5350 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5354 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5357 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5359 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5360 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5361 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5362 || (p && (len != SvCUR(cv) /* Not the same length. */
5363 || memNE(p, SvPVX_const(cv), len))))
5364 && ckWARN_d(WARN_PROTOTYPE)) {
5365 SV* const msg = sv_newmortal();
5369 gv_efullname3(name = sv_newmortal(), gv, NULL);
5370 sv_setpvs(msg, "Prototype mismatch:");
5372 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5374 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5376 sv_catpvs(msg, ": none");
5377 sv_catpvs(msg, " vs ");
5379 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5381 sv_catpvs(msg, "none");
5382 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5386 static void const_sv_xsub(pTHX_ CV* cv);
5390 =head1 Optree Manipulation Functions
5392 =for apidoc cv_const_sv
5394 If C<cv> is a constant sub eligible for inlining. returns the constant
5395 value returned by the sub. Otherwise, returns NULL.
5397 Constant subs can be created with C<newCONSTSUB> or as described in
5398 L<perlsub/"Constant Functions">.
5403 Perl_cv_const_sv(pTHX_ const CV *const cv)
5405 PERL_UNUSED_CONTEXT;
5408 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5410 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5413 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5414 * Can be called in 3 ways:
5417 * look for a single OP_CONST with attached value: return the value
5419 * cv && CvCLONE(cv) && !CvCONST(cv)
5421 * examine the clone prototype, and if contains only a single
5422 * OP_CONST referencing a pad const, or a single PADSV referencing
5423 * an outer lexical, return a non-zero value to indicate the CV is
5424 * a candidate for "constizing" at clone time
5428 * We have just cloned an anon prototype that was marked as a const
5429 * candidiate. Try to grab the current value, and in the case of
5430 * PADSV, ignore it if it has multiple references. Return the value.
5434 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5445 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5446 o = cLISTOPo->op_first->op_sibling;
5448 for (; o; o = o->op_next) {
5449 const OPCODE type = o->op_type;
5451 if (sv && o->op_next == o)
5453 if (o->op_next != o) {
5454 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5456 if (type == OP_DBSTATE)
5459 if (type == OP_LEAVESUB || type == OP_RETURN)
5463 if (type == OP_CONST && cSVOPo->op_sv)
5465 else if (cv && type == OP_CONST) {
5466 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5470 else if (cv && type == OP_PADSV) {
5471 if (CvCONST(cv)) { /* newly cloned anon */
5472 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5473 /* the candidate should have 1 ref from this pad and 1 ref
5474 * from the parent */
5475 if (!sv || SvREFCNT(sv) != 2)
5482 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5483 sv = &PL_sv_undef; /* an arbitrary non-null value */
5498 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5501 /* This would be the return value, but the return cannot be reached. */
5502 OP* pegop = newOP(OP_NULL, 0);
5505 PERL_UNUSED_ARG(floor);
5515 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5517 NORETURN_FUNCTION_END;
5522 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5524 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5528 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5536 register CV *cv = NULL;
5538 /* If the subroutine has no body, no attributes, and no builtin attributes
5539 then it's just a sub declaration, and we may be able to get away with
5540 storing with a placeholder scalar in the symbol table, rather than a
5541 full GV and CV. If anything is present then it will take a full CV to
5543 const I32 gv_fetch_flags
5544 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5546 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5547 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5550 assert(proto->op_type == OP_CONST);
5551 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5556 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5557 SV * const sv = sv_newmortal();
5558 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5559 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5560 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5561 aname = SvPVX_const(sv);
5562 aname_len = SvCUR(sv);
5568 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5570 gv = gv_fetchpvn_flags(aname, aname_len, gv_fetch_flags, SVt_PVCV);
5571 } else if (PL_curstash) {
5572 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5574 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5577 if (!PL_madskills) {
5586 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5587 maximum a prototype before. */
5588 if (SvTYPE(gv) > SVt_NULL) {
5589 if (!SvPOK((const SV *)gv)
5590 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
5591 && ckWARN_d(WARN_PROTOTYPE))
5593 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5595 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5598 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5600 sv_setiv(MUTABLE_SV(gv), -1);
5602 SvREFCNT_dec(PL_compcv);
5603 cv = PL_compcv = NULL;
5607 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5609 if (!block || !ps || *ps || attrs
5610 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5612 || block->op_type == OP_NULL
5617 const_sv = op_const_sv(block, NULL);
5620 const bool exists = CvROOT(cv) || CvXSUB(cv);
5622 /* if the subroutine doesn't exist and wasn't pre-declared
5623 * with a prototype, assume it will be AUTOLOADed,
5624 * skipping the prototype check
5626 if (exists || SvPOK(cv))
5627 cv_ckproto_len(cv, gv, ps, ps_len);
5628 /* already defined (or promised)? */
5629 if (exists || GvASSUMECV(gv)) {
5632 || block->op_type == OP_NULL
5635 if (CvFLAGS(PL_compcv)) {
5636 /* might have had built-in attrs applied */
5637 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5639 /* just a "sub foo;" when &foo is already defined */
5640 SAVEFREESV(PL_compcv);
5645 && block->op_type != OP_NULL
5648 if (ckWARN(WARN_REDEFINE)
5650 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5652 const line_t oldline = CopLINE(PL_curcop);
5653 if (PL_parser && PL_parser->copline != NOLINE)
5654 CopLINE_set(PL_curcop, PL_parser->copline);
5655 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5656 CvCONST(cv) ? "Constant subroutine %s redefined"
5657 : "Subroutine %s redefined", name);
5658 CopLINE_set(PL_curcop, oldline);
5661 if (!PL_minus_c) /* keep old one around for madskills */
5664 /* (PL_madskills unset in used file.) */
5672 SvREFCNT_inc_simple_void_NN(const_sv);
5674 assert(!CvROOT(cv) && !CvCONST(cv));
5675 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5676 CvXSUBANY(cv).any_ptr = const_sv;
5677 CvXSUB(cv) = const_sv_xsub;
5683 cv = newCONSTSUB(NULL, name, const_sv);
5685 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5686 (CvGV(cv) && GvSTASH(CvGV(cv)))
5695 SvREFCNT_dec(PL_compcv);
5703 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5704 * before we clobber PL_compcv.
5708 || block->op_type == OP_NULL
5711 rcv = MUTABLE_SV(cv);
5712 /* Might have had built-in attributes applied -- propagate them. */
5713 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5714 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5715 stash = GvSTASH(CvGV(cv));
5716 else if (CvSTASH(cv))
5717 stash = CvSTASH(cv);
5719 stash = PL_curstash;
5722 /* possibly about to re-define existing subr -- ignore old cv */
5723 rcv = MUTABLE_SV(PL_compcv);
5724 if (name && GvSTASH(gv))
5725 stash = GvSTASH(gv);
5727 stash = PL_curstash;
5729 apply_attrs(stash, rcv, attrs, FALSE);
5731 if (cv) { /* must reuse cv if autoloaded */
5738 || block->op_type == OP_NULL) && !PL_madskills
5741 /* got here with just attrs -- work done, so bug out */
5742 SAVEFREESV(PL_compcv);
5745 /* transfer PL_compcv to cv */
5747 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5748 if (!CvWEAKOUTSIDE(cv))
5749 SvREFCNT_dec(CvOUTSIDE(cv));
5750 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5751 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5752 CvOUTSIDE(PL_compcv) = 0;
5753 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5754 CvPADLIST(PL_compcv) = 0;
5755 /* inner references to PL_compcv must be fixed up ... */
5756 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5757 /* ... before we throw it away */
5758 SvREFCNT_dec(PL_compcv);
5760 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5761 ++PL_sub_generation;
5768 if (strEQ(name, "import")) {
5769 PL_formfeed = MUTABLE_SV(cv);
5770 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5774 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5778 CvFILE_set_from_cop(cv, PL_curcop);
5779 CvSTASH(cv) = PL_curstash;
5782 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5784 if (PL_parser && PL_parser->error_count) {
5788 const char *s = strrchr(name, ':');
5790 if (strEQ(s, "BEGIN")) {
5791 const char not_safe[] =
5792 "BEGIN not safe after errors--compilation aborted";
5793 if (PL_in_eval & EVAL_KEEPERR)
5794 Perl_croak(aTHX_ not_safe);
5796 /* force display of errors found but not reported */
5797 sv_catpv(ERRSV, not_safe);
5798 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5807 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5808 the debugger could be able to set a breakpoint in, so signal to
5809 pp_entereval that it should not throw away any saved lines at scope
5812 PL_breakable_sub_gen++;
5814 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5815 mod(scalarseq(block), OP_LEAVESUBLV));
5816 block->op_attached = 1;
5819 /* This makes sub {}; work as expected. */
5820 if (block->op_type == OP_STUB) {
5821 OP* const newblock = newSTATEOP(0, NULL, 0);
5823 op_getmad(block,newblock,'B');
5830 block->op_attached = 1;
5831 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5833 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5834 OpREFCNT_set(CvROOT(cv), 1);
5835 CvSTART(cv) = LINKLIST(CvROOT(cv));
5836 CvROOT(cv)->op_next = 0;
5837 CALL_PEEP(CvSTART(cv));
5839 /* now that optimizer has done its work, adjust pad values */
5841 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5844 assert(!CvCONST(cv));
5845 if (ps && !*ps && op_const_sv(block, cv))
5849 if (name || aname) {
5850 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5851 SV * const sv = newSV(0);
5852 SV * const tmpstr = sv_newmortal();
5853 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5854 GV_ADDMULTI, SVt_PVHV);
5857 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5859 (long)PL_subline, (long)CopLINE(PL_curcop));
5860 gv_efullname3(tmpstr, gv, NULL);
5861 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5862 SvCUR(tmpstr), sv, 0);
5863 hv = GvHVn(db_postponed);
5864 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5865 CV * const pcv = GvCV(db_postponed);
5871 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5876 if (name && ! (PL_parser && PL_parser->error_count))
5877 process_special_blocks(name, gv, cv);
5882 PL_parser->copline = NOLINE;
5888 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5891 const char *const colon = strrchr(fullname,':');
5892 const char *const name = colon ? colon + 1 : fullname;
5894 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5897 if (strEQ(name, "BEGIN")) {
5898 const I32 oldscope = PL_scopestack_ix;
5900 SAVECOPFILE(&PL_compiling);
5901 SAVECOPLINE(&PL_compiling);
5903 DEBUG_x( dump_sub(gv) );
5904 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5905 GvCV(gv) = 0; /* cv has been hijacked */
5906 call_list(oldscope, PL_beginav);
5908 PL_curcop = &PL_compiling;
5909 CopHINTS_set(&PL_compiling, PL_hints);
5916 if strEQ(name, "END") {
5917 DEBUG_x( dump_sub(gv) );
5918 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5921 } else if (*name == 'U') {
5922 if (strEQ(name, "UNITCHECK")) {
5923 /* It's never too late to run a unitcheck block */
5924 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5928 } else if (*name == 'C') {
5929 if (strEQ(name, "CHECK")) {
5930 if (PL_main_start && ckWARN(WARN_VOID))
5931 Perl_warner(aTHX_ packWARN(WARN_VOID),
5932 "Too late to run CHECK block");
5933 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5937 } else if (*name == 'I') {
5938 if (strEQ(name, "INIT")) {
5939 if (PL_main_start && ckWARN(WARN_VOID))
5940 Perl_warner(aTHX_ packWARN(WARN_VOID),
5941 "Too late to run INIT block");
5942 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5948 DEBUG_x( dump_sub(gv) );
5949 GvCV(gv) = 0; /* cv has been hijacked */
5954 =for apidoc newCONSTSUB
5956 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5957 eligible for inlining at compile-time.
5959 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5960 which won't be called if used as a destructor, but will suppress the overhead
5961 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5968 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5973 const char *const file = CopFILE(PL_curcop);
5975 SV *const temp_sv = CopFILESV(PL_curcop);
5976 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5981 if (IN_PERL_RUNTIME) {
5982 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5983 * an op shared between threads. Use a non-shared COP for our
5985 SAVEVPTR(PL_curcop);
5986 PL_curcop = &PL_compiling;
5988 SAVECOPLINE(PL_curcop);
5989 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5992 PL_hints &= ~HINT_BLOCK_SCOPE;
5995 SAVESPTR(PL_curstash);
5996 SAVECOPSTASH(PL_curcop);
5997 PL_curstash = stash;
5998 CopSTASH_set(PL_curcop,stash);
6001 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6002 and so doesn't get free()d. (It's expected to be from the C pre-
6003 processor __FILE__ directive). But we need a dynamically allocated one,
6004 and we need it to get freed. */
6005 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6006 XS_DYNAMIC_FILENAME);
6007 CvXSUBANY(cv).any_ptr = sv;
6012 CopSTASH_free(PL_curcop);
6020 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6021 const char *const filename, const char *const proto,
6024 CV *cv = newXS(name, subaddr, filename);
6026 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6028 if (flags & XS_DYNAMIC_FILENAME) {
6029 /* We need to "make arrangements" (ie cheat) to ensure that the
6030 filename lasts as long as the PVCV we just created, but also doesn't
6032 STRLEN filename_len = strlen(filename);
6033 STRLEN proto_and_file_len = filename_len;
6034 char *proto_and_file;
6038 proto_len = strlen(proto);
6039 proto_and_file_len += proto_len;
6041 Newx(proto_and_file, proto_and_file_len + 1, char);
6042 Copy(proto, proto_and_file, proto_len, char);
6043 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6046 proto_and_file = savepvn(filename, filename_len);
6049 /* This gets free()d. :-) */
6050 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6051 SV_HAS_TRAILING_NUL);
6053 /* This gives us the correct prototype, rather than one with the
6054 file name appended. */
6055 SvCUR_set(cv, proto_len);
6059 CvFILE(cv) = proto_and_file + proto_len;
6061 sv_setpv(MUTABLE_SV(cv), proto);
6067 =for apidoc U||newXS
6069 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6070 static storage, as it is used directly as CvFILE(), without a copy being made.
6076 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6079 GV * const gv = gv_fetchpv(name ? name :
6080 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6081 GV_ADDMULTI, SVt_PVCV);
6084 PERL_ARGS_ASSERT_NEWXS;
6087 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6089 if ((cv = (name ? GvCV(gv) : NULL))) {
6091 /* just a cached method */
6095 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6096 /* already defined (or promised) */
6097 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6098 if (ckWARN(WARN_REDEFINE)) {
6099 GV * const gvcv = CvGV(cv);
6101 HV * const stash = GvSTASH(gvcv);
6103 const char *redefined_name = HvNAME_get(stash);
6104 if ( strEQ(redefined_name,"autouse") ) {
6105 const line_t oldline = CopLINE(PL_curcop);
6106 if (PL_parser && PL_parser->copline != NOLINE)
6107 CopLINE_set(PL_curcop, PL_parser->copline);
6108 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6109 CvCONST(cv) ? "Constant subroutine %s redefined"
6110 : "Subroutine %s redefined"
6112 CopLINE_set(PL_curcop, oldline);
6122 if (cv) /* must reuse cv if autoloaded */
6125 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6129 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6133 (void)gv_fetchfile(filename);
6134 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6135 an external constant string */
6137 CvXSUB(cv) = subaddr;
6140 process_special_blocks(name, gv, cv);
6152 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6157 OP* pegop = newOP(OP_NULL, 0);
6161 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6162 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6165 if ((cv = GvFORM(gv))) {
6166 if (ckWARN(WARN_REDEFINE)) {
6167 const line_t oldline = CopLINE(PL_curcop);
6168 if (PL_parser && PL_parser->copline != NOLINE)
6169 CopLINE_set(PL_curcop, PL_parser->copline);
6171 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6172 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6174 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6175 "Format STDOUT redefined");
6177 CopLINE_set(PL_curcop, oldline);
6184 CvFILE_set_from_cop(cv, PL_curcop);
6187 pad_tidy(padtidy_FORMAT);
6188 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6189 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6190 OpREFCNT_set(CvROOT(cv), 1);
6191 CvSTART(cv) = LINKLIST(CvROOT(cv));
6192 CvROOT(cv)->op_next = 0;
6193 CALL_PEEP(CvSTART(cv));
6195 op_getmad(o,pegop,'n');
6196 op_getmad_weak(block, pegop, 'b');
6201 PL_parser->copline = NOLINE;
6209 Perl_newANONLIST(pTHX_ OP *o)
6211 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6215 Perl_newANONHASH(pTHX_ OP *o)
6217 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6221 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6223 return newANONATTRSUB(floor, proto, NULL, block);
6227 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6229 return newUNOP(OP_REFGEN, 0,
6230 newSVOP(OP_ANONCODE, 0,
6231 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6235 Perl_oopsAV(pTHX_ OP *o)
6239 PERL_ARGS_ASSERT_OOPSAV;
6241 switch (o->op_type) {
6243 o->op_type = OP_PADAV;
6244 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6245 return ref(o, OP_RV2AV);
6248 o->op_type = OP_RV2AV;
6249 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6254 if (ckWARN_d(WARN_INTERNAL))
6255 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6262 Perl_oopsHV(pTHX_ OP *o)
6266 PERL_ARGS_ASSERT_OOPSHV;
6268 switch (o->op_type) {
6271 o->op_type = OP_PADHV;
6272 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6273 return ref(o, OP_RV2HV);
6277 o->op_type = OP_RV2HV;
6278 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6283 if (ckWARN_d(WARN_INTERNAL))
6284 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6291 Perl_newAVREF(pTHX_ OP *o)
6295 PERL_ARGS_ASSERT_NEWAVREF;
6297 if (o->op_type == OP_PADANY) {
6298 o->op_type = OP_PADAV;
6299 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6302 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6303 && ckWARN(WARN_DEPRECATED)) {
6304 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6305 "Using an array as a reference is deprecated");
6307 return newUNOP(OP_RV2AV, 0, scalar(o));
6311 Perl_newGVREF(pTHX_ I32 type, OP *o)
6313 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6314 return newUNOP(OP_NULL, 0, o);
6315 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6319 Perl_newHVREF(pTHX_ OP *o)
6323 PERL_ARGS_ASSERT_NEWHVREF;
6325 if (o->op_type == OP_PADANY) {
6326 o->op_type = OP_PADHV;
6327 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6330 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6331 && ckWARN(WARN_DEPRECATED)) {
6332 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6333 "Using a hash as a reference is deprecated");
6335 return newUNOP(OP_RV2HV, 0, scalar(o));
6339 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6341 return newUNOP(OP_RV2CV, flags, scalar(o));
6345 Perl_newSVREF(pTHX_ OP *o)
6349 PERL_ARGS_ASSERT_NEWSVREF;
6351 if (o->op_type == OP_PADANY) {
6352 o->op_type = OP_PADSV;
6353 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6356 return newUNOP(OP_RV2SV, 0, scalar(o));
6359 /* Check routines. See the comments at the top of this file for details
6360 * on when these are called */
6363 Perl_ck_anoncode(pTHX_ OP *o)
6365 PERL_ARGS_ASSERT_CK_ANONCODE;
6367 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6369 cSVOPo->op_sv = NULL;
6374 Perl_ck_bitop(pTHX_ OP *o)
6378 PERL_ARGS_ASSERT_CK_BITOP;
6380 #define OP_IS_NUMCOMPARE(op) \
6381 ((op) == OP_LT || (op) == OP_I_LT || \
6382 (op) == OP_GT || (op) == OP_I_GT || \
6383 (op) == OP_LE || (op) == OP_I_LE || \
6384 (op) == OP_GE || (op) == OP_I_GE || \
6385 (op) == OP_EQ || (op) == OP_I_EQ || \
6386 (op) == OP_NE || (op) == OP_I_NE || \
6387 (op) == OP_NCMP || (op) == OP_I_NCMP)
6388 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6389 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6390 && (o->op_type == OP_BIT_OR
6391 || o->op_type == OP_BIT_AND
6392 || o->op_type == OP_BIT_XOR))
6394 const OP * const left = cBINOPo->op_first;
6395 const OP * const right = left->op_sibling;
6396 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6397 (left->op_flags & OPf_PARENS) == 0) ||
6398 (OP_IS_NUMCOMPARE(right->op_type) &&
6399 (right->op_flags & OPf_PARENS) == 0))
6400 if (ckWARN(WARN_PRECEDENCE))
6401 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6402 "Possible precedence problem on bitwise %c operator",
6403 o->op_type == OP_BIT_OR ? '|'
6404 : o->op_type == OP_BIT_AND ? '&' : '^'
6411 Perl_ck_concat(pTHX_ OP *o)
6413 const OP * const kid = cUNOPo->op_first;
6415 PERL_ARGS_ASSERT_CK_CONCAT;
6416 PERL_UNUSED_CONTEXT;
6418 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6419 !(kUNOP->op_first->op_flags & OPf_MOD))
6420 o->op_flags |= OPf_STACKED;
6425 Perl_ck_spair(pTHX_ OP *o)
6429 PERL_ARGS_ASSERT_CK_SPAIR;
6431 if (o->op_flags & OPf_KIDS) {
6434 const OPCODE type = o->op_type;
6435 o = modkids(ck_fun(o), type);
6436 kid = cUNOPo->op_first;
6437 newop = kUNOP->op_first->op_sibling;
6439 const OPCODE type = newop->op_type;
6440 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6441 type == OP_PADAV || type == OP_PADHV ||
6442 type == OP_RV2AV || type == OP_RV2HV)
6446 op_getmad(kUNOP->op_first,newop,'K');
6448 op_free(kUNOP->op_first);
6450 kUNOP->op_first = newop;
6452 o->op_ppaddr = PL_ppaddr[++o->op_type];
6457 Perl_ck_delete(pTHX_ OP *o)
6459 PERL_ARGS_ASSERT_CK_DELETE;
6463 if (o->op_flags & OPf_KIDS) {
6464 OP * const kid = cUNOPo->op_first;
6465 switch (kid->op_type) {
6467 o->op_flags |= OPf_SPECIAL;
6470 o->op_private |= OPpSLICE;
6473 o->op_flags |= OPf_SPECIAL;
6478 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6481 if (kid->op_private & OPpLVAL_INTRO)
6482 o->op_private |= OPpLVAL_INTRO;
6489 Perl_ck_die(pTHX_ OP *o)
6491 PERL_ARGS_ASSERT_CK_DIE;
6494 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6500 Perl_ck_eof(pTHX_ OP *o)
6504 PERL_ARGS_ASSERT_CK_EOF;
6506 if (o->op_flags & OPf_KIDS) {
6507 if (cLISTOPo->op_first->op_type == OP_STUB) {
6509 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6511 op_getmad(o,newop,'O');
6523 Perl_ck_eval(pTHX_ OP *o)
6527 PERL_ARGS_ASSERT_CK_EVAL;
6529 PL_hints |= HINT_BLOCK_SCOPE;
6530 if (o->op_flags & OPf_KIDS) {
6531 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6534 o->op_flags &= ~OPf_KIDS;
6537 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6543 cUNOPo->op_first = 0;
6548 NewOp(1101, enter, 1, LOGOP);
6549 enter->op_type = OP_ENTERTRY;
6550 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6551 enter->op_private = 0;
6553 /* establish postfix order */
6554 enter->op_next = (OP*)enter;
6556 CHECKOP(OP_ENTERTRY, enter);
6558 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6559 o->op_type = OP_LEAVETRY;
6560 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6561 enter->op_other = o;
6562 op_getmad(oldo,o,'O');
6576 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6577 op_getmad(oldo,o,'O');
6579 o->op_targ = (PADOFFSET)PL_hints;
6580 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6581 /* Store a copy of %^H that pp_entereval can pick up. */
6582 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6583 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6584 cUNOPo->op_first->op_sibling = hhop;
6585 o->op_private |= OPpEVAL_HAS_HH;
6591 Perl_ck_exit(pTHX_ OP *o)
6593 PERL_ARGS_ASSERT_CK_EXIT;
6596 HV * const table = GvHV(PL_hintgv);
6598 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6599 if (svp && *svp && SvTRUE(*svp))
6600 o->op_private |= OPpEXIT_VMSISH;
6602 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6608 Perl_ck_exec(pTHX_ OP *o)
6610 PERL_ARGS_ASSERT_CK_EXEC;
6612 if (o->op_flags & OPf_STACKED) {
6615 kid = cUNOPo->op_first->op_sibling;
6616 if (kid->op_type == OP_RV2GV)
6625 Perl_ck_exists(pTHX_ OP *o)
6629 PERL_ARGS_ASSERT_CK_EXISTS;
6632 if (o->op_flags & OPf_KIDS) {
6633 OP * const kid = cUNOPo->op_first;
6634 if (kid->op_type == OP_ENTERSUB) {
6635 (void) ref(kid, o->op_type);
6636 if (kid->op_type != OP_RV2CV
6637 && !(PL_parser && PL_parser->error_count))
6638 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6640 o->op_private |= OPpEXISTS_SUB;
6642 else if (kid->op_type == OP_AELEM)
6643 o->op_flags |= OPf_SPECIAL;
6644 else if (kid->op_type != OP_HELEM)
6645 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6653 Perl_ck_rvconst(pTHX_ register OP *o)
6656 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6658 PERL_ARGS_ASSERT_CK_RVCONST;
6660 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6661 if (o->op_type == OP_RV2CV)
6662 o->op_private &= ~1;
6664 if (kid->op_type == OP_CONST) {
6667 SV * const kidsv = kid->op_sv;
6669 /* Is it a constant from cv_const_sv()? */
6670 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6671 SV * const rsv = SvRV(kidsv);
6672 const svtype type = SvTYPE(rsv);
6673 const char *badtype = NULL;
6675 switch (o->op_type) {
6677 if (type > SVt_PVMG)
6678 badtype = "a SCALAR";
6681 if (type != SVt_PVAV)
6682 badtype = "an ARRAY";
6685 if (type != SVt_PVHV)
6689 if (type != SVt_PVCV)
6694 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6697 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6698 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6699 /* If this is an access to a stash, disable "strict refs", because
6700 * stashes aren't auto-vivified at compile-time (unless we store
6701 * symbols in them), and we don't want to produce a run-time
6702 * stricture error when auto-vivifying the stash. */
6703 const char *s = SvPV_nolen(kidsv);
6704 const STRLEN l = SvCUR(kidsv);
6705 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6706 o->op_private &= ~HINT_STRICT_REFS;
6708 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6709 const char *badthing;
6710 switch (o->op_type) {
6712 badthing = "a SCALAR";
6715 badthing = "an ARRAY";
6718 badthing = "a HASH";
6726 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6727 SVfARG(kidsv), badthing);
6730 * This is a little tricky. We only want to add the symbol if we
6731 * didn't add it in the lexer. Otherwise we get duplicate strict
6732 * warnings. But if we didn't add it in the lexer, we must at
6733 * least pretend like we wanted to add it even if it existed before,
6734 * or we get possible typo warnings. OPpCONST_ENTERED says
6735 * whether the lexer already added THIS instance of this symbol.
6737 iscv = (o->op_type == OP_RV2CV) * 2;
6739 gv = gv_fetchsv(kidsv,
6740 iscv | !(kid->op_private & OPpCONST_ENTERED),
6743 : o->op_type == OP_RV2SV
6745 : o->op_type == OP_RV2AV
6747 : o->op_type == OP_RV2HV
6750 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6752 kid->op_type = OP_GV;
6753 SvREFCNT_dec(kid->op_sv);
6755 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6756 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6757 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6759 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6761 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6763 kid->op_private = 0;
6764 kid->op_ppaddr = PL_ppaddr[OP_GV];
6771 Perl_ck_ftst(pTHX_ OP *o)
6774 const I32 type = o->op_type;
6776 PERL_ARGS_ASSERT_CK_FTST;
6778 if (o->op_flags & OPf_REF) {
6781 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6782 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6783 const OPCODE kidtype = kid->op_type;
6785 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6786 OP * const newop = newGVOP(type, OPf_REF,
6787 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6789 op_getmad(o,newop,'O');
6795 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6796 o->op_private |= OPpFT_ACCESS;
6797 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6798 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6799 o->op_private |= OPpFT_STACKED;
6807 if (type == OP_FTTTY)
6808 o = newGVOP(type, OPf_REF, PL_stdingv);
6810 o = newUNOP(type, 0, newDEFSVOP());
6811 op_getmad(oldo,o,'O');
6817 Perl_ck_fun(pTHX_ OP *o)
6820 const int type = o->op_type;
6821 register I32 oa = PL_opargs[type] >> OASHIFT;
6823 PERL_ARGS_ASSERT_CK_FUN;
6825 if (o->op_flags & OPf_STACKED) {
6826 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6829 return no_fh_allowed(o);
6832 if (o->op_flags & OPf_KIDS) {
6833 OP **tokid = &cLISTOPo->op_first;
6834 register OP *kid = cLISTOPo->op_first;
6838 if (kid->op_type == OP_PUSHMARK ||
6839 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6841 tokid = &kid->op_sibling;
6842 kid = kid->op_sibling;
6844 if (!kid && PL_opargs[type] & OA_DEFGV)
6845 *tokid = kid = newDEFSVOP();
6849 sibl = kid->op_sibling;
6851 if (!sibl && kid->op_type == OP_STUB) {
6858 /* list seen where single (scalar) arg expected? */
6859 if (numargs == 1 && !(oa >> 4)
6860 && kid->op_type == OP_LIST && type != OP_SCALAR)
6862 return too_many_arguments(o,PL_op_desc[type]);
6875 if ((type == OP_PUSH || type == OP_UNSHIFT)
6876 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6877 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6878 "Useless use of %s with no values",
6881 if (kid->op_type == OP_CONST &&
6882 (kid->op_private & OPpCONST_BARE))
6884 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6885 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6886 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6887 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6888 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6889 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6891 op_getmad(kid,newop,'K');
6896 kid->op_sibling = sibl;
6899 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6900 bad_type(numargs, "array", PL_op_desc[type], kid);
6904 if (kid->op_type == OP_CONST &&
6905 (kid->op_private & OPpCONST_BARE))
6907 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6908 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6909 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6910 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6911 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6912 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6914 op_getmad(kid,newop,'K');
6919 kid->op_sibling = sibl;
6922 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6923 bad_type(numargs, "hash", PL_op_desc[type], kid);
6928 OP * const newop = newUNOP(OP_NULL, 0, kid);
6929 kid->op_sibling = 0;
6931 newop->op_next = newop;
6933 kid->op_sibling = sibl;
6938 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6939 if (kid->op_type == OP_CONST &&
6940 (kid->op_private & OPpCONST_BARE))
6942 OP * const newop = newGVOP(OP_GV, 0,
6943 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6944 if (!(o->op_private & 1) && /* if not unop */
6945 kid == cLISTOPo->op_last)
6946 cLISTOPo->op_last = newop;
6948 op_getmad(kid,newop,'K');
6954 else if (kid->op_type == OP_READLINE) {
6955 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6956 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6959 I32 flags = OPf_SPECIAL;
6963 /* is this op a FH constructor? */
6964 if (is_handle_constructor(o,numargs)) {
6965 const char *name = NULL;
6969 /* Set a flag to tell rv2gv to vivify
6970 * need to "prove" flag does not mean something
6971 * else already - NI-S 1999/05/07
6974 if (kid->op_type == OP_PADSV) {
6976 = PAD_COMPNAME_SV(kid->op_targ);
6977 name = SvPV_const(namesv, len);
6979 else if (kid->op_type == OP_RV2SV
6980 && kUNOP->op_first->op_type == OP_GV)
6982 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6984 len = GvNAMELEN(gv);
6986 else if (kid->op_type == OP_AELEM
6987 || kid->op_type == OP_HELEM)
6990 OP *op = ((BINOP*)kid)->op_first;
6994 const char * const a =
6995 kid->op_type == OP_AELEM ?
6997 if (((op->op_type == OP_RV2AV) ||
6998 (op->op_type == OP_RV2HV)) &&
6999 (firstop = ((UNOP*)op)->op_first) &&
7000 (firstop->op_type == OP_GV)) {
7001 /* packagevar $a[] or $h{} */
7002 GV * const gv = cGVOPx_gv(firstop);
7010 else if (op->op_type == OP_PADAV
7011 || op->op_type == OP_PADHV) {
7012 /* lexicalvar $a[] or $h{} */
7013 const char * const padname =
7014 PAD_COMPNAME_PV(op->op_targ);
7023 name = SvPV_const(tmpstr, len);
7028 name = "__ANONIO__";
7035 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7036 namesv = PAD_SVl(targ);
7037 SvUPGRADE(namesv, SVt_PV);
7039 sv_setpvs(namesv, "$");
7040 sv_catpvn(namesv, name, len);
7043 kid->op_sibling = 0;
7044 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7045 kid->op_targ = targ;
7046 kid->op_private |= priv;
7048 kid->op_sibling = sibl;
7054 mod(scalar(kid), type);
7058 tokid = &kid->op_sibling;
7059 kid = kid->op_sibling;
7062 if (kid && kid->op_type != OP_STUB)
7063 return too_many_arguments(o,OP_DESC(o));
7064 o->op_private |= numargs;
7066 /* FIXME - should the numargs move as for the PERL_MAD case? */
7067 o->op_private |= numargs;
7069 return too_many_arguments(o,OP_DESC(o));
7073 else if (PL_opargs[type] & OA_DEFGV) {
7075 OP *newop = newUNOP(type, 0, newDEFSVOP());
7076 op_getmad(o,newop,'O');
7079 /* Ordering of these two is important to keep f_map.t passing. */
7081 return newUNOP(type, 0, newDEFSVOP());
7086 while (oa & OA_OPTIONAL)
7088 if (oa && oa != OA_LIST)
7089 return too_few_arguments(o,OP_DESC(o));
7095 Perl_ck_glob(pTHX_ OP *o)
7100 PERL_ARGS_ASSERT_CK_GLOB;
7103 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7104 append_elem(OP_GLOB, o, newDEFSVOP());
7106 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7107 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7109 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7112 #if !defined(PERL_EXTERNAL_GLOB)
7113 /* XXX this can be tightened up and made more failsafe. */
7114 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7117 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7118 newSVpvs("File::Glob"), NULL, NULL, NULL);
7119 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7120 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7121 GvCV(gv) = GvCV(glob_gv);
7122 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7123 GvIMPORTED_CV_on(gv);
7126 #endif /* PERL_EXTERNAL_GLOB */
7128 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7129 append_elem(OP_GLOB, o,
7130 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7131 o->op_type = OP_LIST;
7132 o->op_ppaddr = PL_ppaddr[OP_LIST];
7133 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7134 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7135 cLISTOPo->op_first->op_targ = 0;
7136 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7137 append_elem(OP_LIST, o,
7138 scalar(newUNOP(OP_RV2CV, 0,
7139 newGVOP(OP_GV, 0, gv)))));
7140 o = newUNOP(OP_NULL, 0, ck_subr(o));
7141 o->op_targ = OP_GLOB; /* hint at what it used to be */
7144 gv = newGVgen("main");
7146 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7152 Perl_ck_grep(pTHX_ OP *o)
7157 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7160 PERL_ARGS_ASSERT_CK_GREP;
7162 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7163 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7165 if (o->op_flags & OPf_STACKED) {
7168 kid = cLISTOPo->op_first->op_sibling;
7169 if (!cUNOPx(kid)->op_next)
7170 Perl_croak(aTHX_ "panic: ck_grep");
7171 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7174 NewOp(1101, gwop, 1, LOGOP);
7175 kid->op_next = (OP*)gwop;
7176 o->op_flags &= ~OPf_STACKED;
7178 kid = cLISTOPo->op_first->op_sibling;
7179 if (type == OP_MAPWHILE)
7184 if (PL_parser && PL_parser->error_count)
7186 kid = cLISTOPo->op_first->op_sibling;
7187 if (kid->op_type != OP_NULL)
7188 Perl_croak(aTHX_ "panic: ck_grep");
7189 kid = kUNOP->op_first;
7192 NewOp(1101, gwop, 1, LOGOP);
7193 gwop->op_type = type;
7194 gwop->op_ppaddr = PL_ppaddr[type];
7195 gwop->op_first = listkids(o);
7196 gwop->op_flags |= OPf_KIDS;
7197 gwop->op_other = LINKLIST(kid);
7198 kid->op_next = (OP*)gwop;
7199 offset = pad_findmy("$_");
7200 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7201 o->op_private = gwop->op_private = 0;
7202 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7205 o->op_private = gwop->op_private = OPpGREP_LEX;
7206 gwop->op_targ = o->op_targ = offset;
7209 kid = cLISTOPo->op_first->op_sibling;
7210 if (!kid || !kid->op_sibling)
7211 return too_few_arguments(o,OP_DESC(o));
7212 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7213 mod(kid, OP_GREPSTART);
7219 Perl_ck_index(pTHX_ OP *o)
7221 PERL_ARGS_ASSERT_CK_INDEX;
7223 if (o->op_flags & OPf_KIDS) {
7224 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7226 kid = kid->op_sibling; /* get past "big" */
7227 if (kid && kid->op_type == OP_CONST)
7228 fbm_compile(((SVOP*)kid)->op_sv, 0);
7234 Perl_ck_lfun(pTHX_ OP *o)
7236 const OPCODE type = o->op_type;
7238 PERL_ARGS_ASSERT_CK_LFUN;
7240 return modkids(ck_fun(o), type);
7244 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7246 PERL_ARGS_ASSERT_CK_DEFINED;
7248 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7249 switch (cUNOPo->op_first->op_type) {
7251 /* This is needed for
7252 if (defined %stash::)
7253 to work. Do not break Tk.
7255 break; /* Globals via GV can be undef */
7257 case OP_AASSIGN: /* Is this a good idea? */
7258 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7259 "defined(@array) is deprecated");
7260 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7261 "\t(Maybe you should just omit the defined()?)\n");
7264 /* This is needed for
7265 if (defined %stash::)
7266 to work. Do not break Tk.
7268 break; /* Globals via GV can be undef */
7270 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7271 "defined(%%hash) is deprecated");
7272 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7273 "\t(Maybe you should just omit the defined()?)\n");
7284 Perl_ck_readline(pTHX_ OP *o)
7286 PERL_ARGS_ASSERT_CK_READLINE;
7288 if (!(o->op_flags & OPf_KIDS)) {
7290 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7292 op_getmad(o,newop,'O');
7302 Perl_ck_rfun(pTHX_ OP *o)
7304 const OPCODE type = o->op_type;
7306 PERL_ARGS_ASSERT_CK_RFUN;
7308 return refkids(ck_fun(o), type);
7312 Perl_ck_listiob(pTHX_ OP *o)
7316 PERL_ARGS_ASSERT_CK_LISTIOB;
7318 kid = cLISTOPo->op_first;
7321 kid = cLISTOPo->op_first;
7323 if (kid->op_type == OP_PUSHMARK)
7324 kid = kid->op_sibling;
7325 if (kid && o->op_flags & OPf_STACKED)
7326 kid = kid->op_sibling;
7327 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7328 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7329 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7330 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7331 cLISTOPo->op_first->op_sibling = kid;
7332 cLISTOPo->op_last = kid;
7333 kid = kid->op_sibling;
7338 append_elem(o->op_type, o, newDEFSVOP());
7344 Perl_ck_smartmatch(pTHX_ OP *o)
7347 if (0 == (o->op_flags & OPf_SPECIAL)) {
7348 OP *first = cBINOPo->op_first;
7349 OP *second = first->op_sibling;
7351 /* Implicitly take a reference to an array or hash */
7352 first->op_sibling = NULL;
7353 first = cBINOPo->op_first = ref_array_or_hash(first);
7354 second = first->op_sibling = ref_array_or_hash(second);
7356 /* Implicitly take a reference to a regular expression */
7357 if (first->op_type == OP_MATCH) {
7358 first->op_type = OP_QR;
7359 first->op_ppaddr = PL_ppaddr[OP_QR];
7361 if (second->op_type == OP_MATCH) {
7362 second->op_type = OP_QR;
7363 second->op_ppaddr = PL_ppaddr[OP_QR];
7372 Perl_ck_sassign(pTHX_ OP *o)
7375 OP * const kid = cLISTOPo->op_first;
7377 PERL_ARGS_ASSERT_CK_SASSIGN;
7379 /* has a disposable target? */
7380 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7381 && !(kid->op_flags & OPf_STACKED)
7382 /* Cannot steal the second time! */
7383 && !(kid->op_private & OPpTARGET_MY)
7384 /* Keep the full thing for madskills */
7388 OP * const kkid = kid->op_sibling;
7390 /* Can just relocate the target. */
7391 if (kkid && kkid->op_type == OP_PADSV
7392 && !(kkid->op_private & OPpLVAL_INTRO))
7394 kid->op_targ = kkid->op_targ;
7396 /* Now we do not need PADSV and SASSIGN. */
7397 kid->op_sibling = o->op_sibling; /* NULL */
7398 cLISTOPo->op_first = NULL;
7401 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7405 if (kid->op_sibling) {
7406 OP *kkid = kid->op_sibling;
7407 if (kkid->op_type == OP_PADSV
7408 && (kkid->op_private & OPpLVAL_INTRO)
7409 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7410 const PADOFFSET target = kkid->op_targ;
7411 OP *const other = newOP(OP_PADSV,
7413 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7414 OP *const first = newOP(OP_NULL, 0);
7415 OP *const nullop = newCONDOP(0, first, o, other);
7416 OP *const condop = first->op_next;
7417 /* hijacking PADSTALE for uninitialized state variables */
7418 SvPADSTALE_on(PAD_SVl(target));
7420 condop->op_type = OP_ONCE;
7421 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7422 condop->op_targ = target;
7423 other->op_targ = target;
7425 /* Because we change the type of the op here, we will skip the
7426 assinment binop->op_last = binop->op_first->op_sibling; at the
7427 end of Perl_newBINOP(). So need to do it here. */
7428 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7437 Perl_ck_match(pTHX_ OP *o)
7441 PERL_ARGS_ASSERT_CK_MATCH;
7443 if (o->op_type != OP_QR && PL_compcv) {
7444 const PADOFFSET offset = pad_findmy("$_");
7445 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7446 o->op_targ = offset;
7447 o->op_private |= OPpTARGET_MY;
7450 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7451 o->op_private |= OPpRUNTIME;
7456 Perl_ck_method(pTHX_ OP *o)
7458 OP * const kid = cUNOPo->op_first;
7460 PERL_ARGS_ASSERT_CK_METHOD;
7462 if (kid->op_type == OP_CONST) {
7463 SV* sv = kSVOP->op_sv;
7464 const char * const method = SvPVX_const(sv);
7465 if (!(strchr(method, ':') || strchr(method, '\''))) {
7467 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7468 sv = newSVpvn_share(method, SvCUR(sv), 0);
7471 kSVOP->op_sv = NULL;
7473 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7475 op_getmad(o,cmop,'O');
7486 Perl_ck_null(pTHX_ OP *o)
7488 PERL_ARGS_ASSERT_CK_NULL;
7489 PERL_UNUSED_CONTEXT;
7494 Perl_ck_open(pTHX_ OP *o)
7497 HV * const table = GvHV(PL_hintgv);
7499 PERL_ARGS_ASSERT_CK_OPEN;
7502 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7505 const char *d = SvPV_const(*svp, len);
7506 const I32 mode = mode_from_discipline(d, len);
7507 if (mode & O_BINARY)
7508 o->op_private |= OPpOPEN_IN_RAW;
7509 else if (mode & O_TEXT)
7510 o->op_private |= OPpOPEN_IN_CRLF;
7513 svp = hv_fetchs(table, "open_OUT", FALSE);
7516 const char *d = SvPV_const(*svp, len);
7517 const I32 mode = mode_from_discipline(d, len);
7518 if (mode & O_BINARY)
7519 o->op_private |= OPpOPEN_OUT_RAW;
7520 else if (mode & O_TEXT)
7521 o->op_private |= OPpOPEN_OUT_CRLF;
7524 if (o->op_type == OP_BACKTICK) {
7525 if (!(o->op_flags & OPf_KIDS)) {
7526 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7528 op_getmad(o,newop,'O');
7537 /* In case of three-arg dup open remove strictness
7538 * from the last arg if it is a bareword. */
7539 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7540 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7544 if ((last->op_type == OP_CONST) && /* The bareword. */
7545 (last->op_private & OPpCONST_BARE) &&
7546 (last->op_private & OPpCONST_STRICT) &&
7547 (oa = first->op_sibling) && /* The fh. */
7548 (oa = oa->op_sibling) && /* The mode. */
7549 (oa->op_type == OP_CONST) &&
7550 SvPOK(((SVOP*)oa)->op_sv) &&
7551 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7552 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7553 (last == oa->op_sibling)) /* The bareword. */
7554 last->op_private &= ~OPpCONST_STRICT;
7560 Perl_ck_repeat(pTHX_ OP *o)
7562 PERL_ARGS_ASSERT_CK_REPEAT;
7564 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7565 o->op_private |= OPpREPEAT_DOLIST;
7566 cBINOPo->op_first = force_list(cBINOPo->op_first);
7574 Perl_ck_require(pTHX_ OP *o)
7579 PERL_ARGS_ASSERT_CK_REQUIRE;
7581 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7582 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7584 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7585 SV * const sv = kid->op_sv;
7586 U32 was_readonly = SvREADONLY(sv);
7593 sv_force_normal_flags(sv, 0);
7594 assert(!SvREADONLY(sv));
7604 for (; s < end; s++) {
7605 if (*s == ':' && s[1] == ':') {
7607 Move(s+2, s+1, end - s - 1, char);
7612 sv_catpvs(sv, ".pm");
7613 SvFLAGS(sv) |= was_readonly;
7617 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7618 /* handle override, if any */
7619 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7620 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7621 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7622 gv = gvp ? *gvp : NULL;
7626 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7627 OP * const kid = cUNOPo->op_first;
7630 cUNOPo->op_first = 0;
7634 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7635 append_elem(OP_LIST, kid,
7636 scalar(newUNOP(OP_RV2CV, 0,
7639 op_getmad(o,newop,'O');
7647 Perl_ck_return(pTHX_ OP *o)
7652 PERL_ARGS_ASSERT_CK_RETURN;
7654 kid = cLISTOPo->op_first->op_sibling;
7655 if (CvLVALUE(PL_compcv)) {
7656 for (; kid; kid = kid->op_sibling)
7657 mod(kid, OP_LEAVESUBLV);
7659 for (; kid; kid = kid->op_sibling)
7660 if ((kid->op_type == OP_NULL)
7661 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7662 /* This is a do block */
7663 OP *op = kUNOP->op_first;
7664 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7665 op = cUNOPx(op)->op_first;
7666 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7667 /* Force the use of the caller's context */
7668 op->op_flags |= OPf_SPECIAL;
7677 Perl_ck_select(pTHX_ OP *o)
7682 PERL_ARGS_ASSERT_CK_SELECT;
7684 if (o->op_flags & OPf_KIDS) {
7685 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7686 if (kid && kid->op_sibling) {
7687 o->op_type = OP_SSELECT;
7688 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7690 return fold_constants(o);
7694 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7695 if (kid && kid->op_type == OP_RV2GV)
7696 kid->op_private &= ~HINT_STRICT_REFS;
7701 Perl_ck_shift(pTHX_ OP *o)
7704 const I32 type = o->op_type;
7706 PERL_ARGS_ASSERT_CK_SHIFT;
7708 if (!(o->op_flags & OPf_KIDS)) {
7710 /* FIXME - this can be refactored to reduce code in #ifdefs */
7712 OP * const oldo = o;
7716 argop = newUNOP(OP_RV2AV, 0,
7717 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7719 o = newUNOP(type, 0, scalar(argop));
7720 op_getmad(oldo,o,'O');
7723 return newUNOP(type, 0, scalar(argop));
7726 return scalar(modkids(ck_fun(o), type));
7730 Perl_ck_sort(pTHX_ OP *o)
7735 PERL_ARGS_ASSERT_CK_SORT;
7737 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7738 HV * const hinthv = GvHV(PL_hintgv);
7740 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7742 const I32 sorthints = (I32)SvIV(*svp);
7743 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7744 o->op_private |= OPpSORT_QSORT;
7745 if ((sorthints & HINT_SORT_STABLE) != 0)
7746 o->op_private |= OPpSORT_STABLE;
7751 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7753 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7754 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7756 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7758 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7760 if (kid->op_type == OP_SCOPE) {
7764 else if (kid->op_type == OP_LEAVE) {
7765 if (o->op_type == OP_SORT) {
7766 op_null(kid); /* wipe out leave */
7769 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7770 if (k->op_next == kid)
7772 /* don't descend into loops */
7773 else if (k->op_type == OP_ENTERLOOP
7774 || k->op_type == OP_ENTERITER)
7776 k = cLOOPx(k)->op_lastop;
7781 kid->op_next = 0; /* just disconnect the leave */
7782 k = kLISTOP->op_first;
7787 if (o->op_type == OP_SORT) {
7788 /* provide scalar context for comparison function/block */
7794 o->op_flags |= OPf_SPECIAL;
7796 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7799 firstkid = firstkid->op_sibling;
7802 /* provide list context for arguments */
7803 if (o->op_type == OP_SORT)
7810 S_simplify_sort(pTHX_ OP *o)
7813 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7819 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7821 if (!(o->op_flags & OPf_STACKED))
7823 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7824 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7825 kid = kUNOP->op_first; /* get past null */
7826 if (kid->op_type != OP_SCOPE)
7828 kid = kLISTOP->op_last; /* get past scope */
7829 switch(kid->op_type) {
7837 k = kid; /* remember this node*/
7838 if (kBINOP->op_first->op_type != OP_RV2SV)
7840 kid = kBINOP->op_first; /* get past cmp */
7841 if (kUNOP->op_first->op_type != OP_GV)
7843 kid = kUNOP->op_first; /* get past rv2sv */
7845 if (GvSTASH(gv) != PL_curstash)
7847 gvname = GvNAME(gv);
7848 if (*gvname == 'a' && gvname[1] == '\0')
7850 else if (*gvname == 'b' && gvname[1] == '\0')
7855 kid = k; /* back to cmp */
7856 if (kBINOP->op_last->op_type != OP_RV2SV)
7858 kid = kBINOP->op_last; /* down to 2nd arg */
7859 if (kUNOP->op_first->op_type != OP_GV)
7861 kid = kUNOP->op_first; /* get past rv2sv */
7863 if (GvSTASH(gv) != PL_curstash)
7865 gvname = GvNAME(gv);
7867 ? !(*gvname == 'a' && gvname[1] == '\0')
7868 : !(*gvname == 'b' && gvname[1] == '\0'))
7870 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7872 o->op_private |= OPpSORT_DESCEND;
7873 if (k->op_type == OP_NCMP)
7874 o->op_private |= OPpSORT_NUMERIC;
7875 if (k->op_type == OP_I_NCMP)
7876 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7877 kid = cLISTOPo->op_first->op_sibling;
7878 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7880 op_getmad(kid,o,'S'); /* then delete it */
7882 op_free(kid); /* then delete it */
7887 Perl_ck_split(pTHX_ OP *o)
7892 PERL_ARGS_ASSERT_CK_SPLIT;
7894 if (o->op_flags & OPf_STACKED)
7895 return no_fh_allowed(o);
7897 kid = cLISTOPo->op_first;
7898 if (kid->op_type != OP_NULL)
7899 Perl_croak(aTHX_ "panic: ck_split");
7900 kid = kid->op_sibling;
7901 op_free(cLISTOPo->op_first);
7902 cLISTOPo->op_first = kid;
7904 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7905 cLISTOPo->op_last = kid; /* There was only one element previously */
7908 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7909 OP * const sibl = kid->op_sibling;
7910 kid->op_sibling = 0;
7911 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7912 if (cLISTOPo->op_first == cLISTOPo->op_last)
7913 cLISTOPo->op_last = kid;
7914 cLISTOPo->op_first = kid;
7915 kid->op_sibling = sibl;
7918 kid->op_type = OP_PUSHRE;
7919 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7921 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7922 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7923 "Use of /g modifier is meaningless in split");
7926 if (!kid->op_sibling)
7927 append_elem(OP_SPLIT, o, newDEFSVOP());
7929 kid = kid->op_sibling;
7932 if (!kid->op_sibling)
7933 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7934 assert(kid->op_sibling);
7936 kid = kid->op_sibling;
7939 if (kid->op_sibling)
7940 return too_many_arguments(o,OP_DESC(o));
7946 Perl_ck_join(pTHX_ OP *o)
7948 const OP * const kid = cLISTOPo->op_first->op_sibling;
7950 PERL_ARGS_ASSERT_CK_JOIN;
7952 if (kid && kid->op_type == OP_MATCH) {
7953 if (ckWARN(WARN_SYNTAX)) {
7954 const REGEXP *re = PM_GETRE(kPMOP);
7955 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7956 const STRLEN len = re ? RX_PRELEN(re) : 6;
7957 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7958 "/%.*s/ should probably be written as \"%.*s\"",
7959 (int)len, pmstr, (int)len, pmstr);
7966 Perl_ck_subr(pTHX_ OP *o)
7969 OP *prev = ((cUNOPo->op_first->op_sibling)
7970 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7971 OP *o2 = prev->op_sibling;
7973 const char *proto = NULL;
7974 const char *proto_end = NULL;
7979 I32 contextclass = 0;
7980 const char *e = NULL;
7983 PERL_ARGS_ASSERT_CK_SUBR;
7985 o->op_private |= OPpENTERSUB_HASTARG;
7986 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7987 if (cvop->op_type == OP_RV2CV) {
7989 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7990 op_null(cvop); /* disable rv2cv */
7991 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7992 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7993 GV *gv = cGVOPx_gv(tmpop);
7996 tmpop->op_private |= OPpEARLY_CV;
8000 namegv = CvANON(cv) ? gv : CvGV(cv);
8001 proto = SvPV(MUTABLE_SV(cv), len);
8002 proto_end = proto + len;
8007 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8008 if (o2->op_type == OP_CONST)
8009 o2->op_private &= ~OPpCONST_STRICT;
8010 else if (o2->op_type == OP_LIST) {
8011 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8012 if (sib && sib->op_type == OP_CONST)
8013 sib->op_private &= ~OPpCONST_STRICT;
8016 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8017 if (PERLDB_SUB && PL_curstash != PL_debstash)
8018 o->op_private |= OPpENTERSUB_DB;
8019 while (o2 != cvop) {
8021 if (PL_madskills && o2->op_type == OP_STUB) {
8022 o2 = o2->op_sibling;
8025 if (PL_madskills && o2->op_type == OP_NULL)
8026 o3 = ((UNOP*)o2)->op_first;
8030 if (proto >= proto_end)
8031 return too_many_arguments(o, gv_ename(namegv));
8039 /* _ must be at the end */
8040 if (proto[1] && proto[1] != ';')
8055 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8057 arg == 1 ? "block or sub {}" : "sub {}",
8058 gv_ename(namegv), o3);
8061 /* '*' allows any scalar type, including bareword */
8064 if (o3->op_type == OP_RV2GV)
8065 goto wrapref; /* autoconvert GLOB -> GLOBref */
8066 else if (o3->op_type == OP_CONST)
8067 o3->op_private &= ~OPpCONST_STRICT;
8068 else if (o3->op_type == OP_ENTERSUB) {
8069 /* accidental subroutine, revert to bareword */
8070 OP *gvop = ((UNOP*)o3)->op_first;
8071 if (gvop && gvop->op_type == OP_NULL) {
8072 gvop = ((UNOP*)gvop)->op_first;
8074 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8077 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8078 (gvop = ((UNOP*)gvop)->op_first) &&
8079 gvop->op_type == OP_GV)
8081 GV * const gv = cGVOPx_gv(gvop);
8082 OP * const sibling = o2->op_sibling;
8083 SV * const n = newSVpvs("");
8085 OP * const oldo2 = o2;
8089 gv_fullname4(n, gv, "", FALSE);
8090 o2 = newSVOP(OP_CONST, 0, n);
8091 op_getmad(oldo2,o2,'O');
8092 prev->op_sibling = o2;
8093 o2->op_sibling = sibling;
8109 if (contextclass++ == 0) {
8110 e = strchr(proto, ']');
8111 if (!e || e == proto)
8120 const char *p = proto;
8121 const char *const end = proto;
8123 while (*--p != '[') {}
8124 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8126 gv_ename(namegv), o3);
8131 if (o3->op_type == OP_RV2GV)
8134 bad_type(arg, "symbol", gv_ename(namegv), o3);
8137 if (o3->op_type == OP_ENTERSUB)
8140 bad_type(arg, "subroutine entry", gv_ename(namegv),
8144 if (o3->op_type == OP_RV2SV ||
8145 o3->op_type == OP_PADSV ||
8146 o3->op_type == OP_HELEM ||
8147 o3->op_type == OP_AELEM)
8150 bad_type(arg, "scalar", gv_ename(namegv), o3);
8153 if (o3->op_type == OP_RV2AV ||
8154 o3->op_type == OP_PADAV)
8157 bad_type(arg, "array", gv_ename(namegv), o3);
8160 if (o3->op_type == OP_RV2HV ||
8161 o3->op_type == OP_PADHV)
8164 bad_type(arg, "hash", gv_ename(namegv), o3);
8169 OP* const sib = kid->op_sibling;
8170 kid->op_sibling = 0;
8171 o2 = newUNOP(OP_REFGEN, 0, kid);
8172 o2->op_sibling = sib;
8173 prev->op_sibling = o2;
8175 if (contextclass && e) {
8190 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8191 gv_ename(namegv), SVfARG(cv));
8196 mod(o2, OP_ENTERSUB);
8198 o2 = o2->op_sibling;
8200 if (o2 == cvop && proto && *proto == '_') {
8201 /* generate an access to $_ */
8203 o2->op_sibling = prev->op_sibling;
8204 prev->op_sibling = o2; /* instead of cvop */
8206 if (proto && !optional && proto_end > proto &&
8207 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8208 return too_few_arguments(o, gv_ename(namegv));
8211 OP * const oldo = o;
8215 o=newSVOP(OP_CONST, 0, newSViv(0));
8216 op_getmad(oldo,o,'O');
8222 Perl_ck_svconst(pTHX_ OP *o)
8224 PERL_ARGS_ASSERT_CK_SVCONST;
8225 PERL_UNUSED_CONTEXT;
8226 SvREADONLY_on(cSVOPo->op_sv);
8231 Perl_ck_chdir(pTHX_ OP *o)
8233 if (o->op_flags & OPf_KIDS) {
8234 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8236 if (kid && kid->op_type == OP_CONST &&
8237 (kid->op_private & OPpCONST_BARE))
8239 o->op_flags |= OPf_SPECIAL;
8240 kid->op_private &= ~OPpCONST_STRICT;
8247 Perl_ck_trunc(pTHX_ OP *o)
8249 PERL_ARGS_ASSERT_CK_TRUNC;
8251 if (o->op_flags & OPf_KIDS) {
8252 SVOP *kid = (SVOP*)cUNOPo->op_first;
8254 if (kid->op_type == OP_NULL)
8255 kid = (SVOP*)kid->op_sibling;
8256 if (kid && kid->op_type == OP_CONST &&
8257 (kid->op_private & OPpCONST_BARE))
8259 o->op_flags |= OPf_SPECIAL;
8260 kid->op_private &= ~OPpCONST_STRICT;
8267 Perl_ck_unpack(pTHX_ OP *o)
8269 OP *kid = cLISTOPo->op_first;
8271 PERL_ARGS_ASSERT_CK_UNPACK;
8273 if (kid->op_sibling) {
8274 kid = kid->op_sibling;
8275 if (!kid->op_sibling)
8276 kid->op_sibling = newDEFSVOP();
8282 Perl_ck_substr(pTHX_ OP *o)
8284 PERL_ARGS_ASSERT_CK_SUBSTR;
8287 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8288 OP *kid = cLISTOPo->op_first;
8290 if (kid->op_type == OP_NULL)
8291 kid = kid->op_sibling;
8293 kid->op_flags |= OPf_MOD;
8300 Perl_ck_each(pTHX_ OP *o)
8303 OP *kid = cLISTOPo->op_first;
8305 PERL_ARGS_ASSERT_CK_EACH;
8307 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8308 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8309 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8310 o->op_type = new_type;
8311 o->op_ppaddr = PL_ppaddr[new_type];
8313 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8314 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8316 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8322 /* A peephole optimizer. We visit the ops in the order they're to execute.
8323 * See the comments at the top of this file for more details about when
8324 * peep() is called */
8327 Perl_peep(pTHX_ register OP *o)
8330 register OP* oldop = NULL;
8332 if (!o || o->op_opt)
8336 SAVEVPTR(PL_curcop);
8337 for (; o; o = o->op_next) {
8340 /* By default, this op has now been optimised. A couple of cases below
8341 clear this again. */
8344 switch (o->op_type) {
8347 PL_curcop = ((COP*)o); /* for warnings */
8351 if (cSVOPo->op_private & OPpCONST_STRICT)
8352 no_bareword_allowed(o);
8355 case OP_METHOD_NAMED:
8356 /* Relocate sv to the pad for thread safety.
8357 * Despite being a "constant", the SV is written to,
8358 * for reference counts, sv_upgrade() etc. */
8360 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8361 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8362 /* If op_sv is already a PADTMP then it is being used by
8363 * some pad, so make a copy. */
8364 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8365 SvREADONLY_on(PAD_SVl(ix));
8366 SvREFCNT_dec(cSVOPo->op_sv);
8368 else if (o->op_type != OP_METHOD_NAMED
8369 && cSVOPo->op_sv == &PL_sv_undef) {
8370 /* PL_sv_undef is hack - it's unsafe to store it in the
8371 AV that is the pad, because av_fetch treats values of
8372 PL_sv_undef as a "free" AV entry and will merrily
8373 replace them with a new SV, causing pad_alloc to think
8374 that this pad slot is free. (When, clearly, it is not)
8376 SvOK_off(PAD_SVl(ix));
8377 SvPADTMP_on(PAD_SVl(ix));
8378 SvREADONLY_on(PAD_SVl(ix));
8381 SvREFCNT_dec(PAD_SVl(ix));
8382 SvPADTMP_on(cSVOPo->op_sv);
8383 PAD_SETSV(ix, cSVOPo->op_sv);
8384 /* XXX I don't know how this isn't readonly already. */
8385 SvREADONLY_on(PAD_SVl(ix));
8387 cSVOPo->op_sv = NULL;
8394 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8395 if (o->op_next->op_private & OPpTARGET_MY) {
8396 if (o->op_flags & OPf_STACKED) /* chained concats */
8397 break; /* ignore_optimization */
8399 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8400 o->op_targ = o->op_next->op_targ;
8401 o->op_next->op_targ = 0;
8402 o->op_private |= OPpTARGET_MY;
8405 op_null(o->op_next);
8409 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8410 break; /* Scalar stub must produce undef. List stub is noop */
8414 if (o->op_targ == OP_NEXTSTATE
8415 || o->op_targ == OP_DBSTATE)
8417 PL_curcop = ((COP*)o);
8419 /* XXX: We avoid setting op_seq here to prevent later calls
8420 to peep() from mistakenly concluding that optimisation
8421 has already occurred. This doesn't fix the real problem,
8422 though (See 20010220.007). AMS 20010719 */
8423 /* op_seq functionality is now replaced by op_opt */
8430 if (oldop && o->op_next) {
8431 oldop->op_next = o->op_next;
8439 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8440 OP* const pop = (o->op_type == OP_PADAV) ?
8441 o->op_next : o->op_next->op_next;
8443 if (pop && pop->op_type == OP_CONST &&
8444 ((PL_op = pop->op_next)) &&
8445 pop->op_next->op_type == OP_AELEM &&
8446 !(pop->op_next->op_private &
8447 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8448 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8453 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8454 no_bareword_allowed(pop);
8455 if (o->op_type == OP_GV)
8456 op_null(o->op_next);
8457 op_null(pop->op_next);
8459 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8460 o->op_next = pop->op_next->op_next;
8461 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8462 o->op_private = (U8)i;
8463 if (o->op_type == OP_GV) {
8468 o->op_flags |= OPf_SPECIAL;
8469 o->op_type = OP_AELEMFAST;
8474 if (o->op_next->op_type == OP_RV2SV) {
8475 if (!(o->op_next->op_private & OPpDEREF)) {
8476 op_null(o->op_next);
8477 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8479 o->op_next = o->op_next->op_next;
8480 o->op_type = OP_GVSV;
8481 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8484 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8485 GV * const gv = cGVOPo_gv;
8486 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8487 /* XXX could check prototype here instead of just carping */
8488 SV * const sv = sv_newmortal();
8489 gv_efullname3(sv, gv, NULL);
8490 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8491 "%"SVf"() called too early to check prototype",
8495 else if (o->op_next->op_type == OP_READLINE
8496 && o->op_next->op_next->op_type == OP_CONCAT
8497 && (o->op_next->op_next->op_flags & OPf_STACKED))
8499 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8500 o->op_type = OP_RCATLINE;
8501 o->op_flags |= OPf_STACKED;
8502 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8503 op_null(o->op_next->op_next);
8504 op_null(o->op_next);
8520 while (cLOGOP->op_other->op_type == OP_NULL)
8521 cLOGOP->op_other = cLOGOP->op_other->op_next;
8522 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8527 while (cLOOP->op_redoop->op_type == OP_NULL)
8528 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8529 peep(cLOOP->op_redoop);
8530 while (cLOOP->op_nextop->op_type == OP_NULL)
8531 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8532 peep(cLOOP->op_nextop);
8533 while (cLOOP->op_lastop->op_type == OP_NULL)
8534 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8535 peep(cLOOP->op_lastop);
8539 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8540 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8541 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8542 cPMOP->op_pmstashstartu.op_pmreplstart
8543 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8544 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8548 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8549 && ckWARN(WARN_SYNTAX))
8551 if (o->op_next->op_sibling) {
8552 const OPCODE type = o->op_next->op_sibling->op_type;
8553 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8554 const line_t oldline = CopLINE(PL_curcop);
8555 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8556 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8557 "Statement unlikely to be reached");
8558 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8559 "\t(Maybe you meant system() when you said exec()?)\n");
8560 CopLINE_set(PL_curcop, oldline);
8571 const char *key = NULL;
8574 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8577 /* Make the CONST have a shared SV */
8578 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8579 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8580 key = SvPV_const(sv, keylen);
8581 lexname = newSVpvn_share(key,
8582 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8588 if ((o->op_private & (OPpLVAL_INTRO)))
8591 rop = (UNOP*)((BINOP*)o)->op_first;
8592 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8594 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8595 if (!SvPAD_TYPED(lexname))
8597 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8598 if (!fields || !GvHV(*fields))
8600 key = SvPV_const(*svp, keylen);
8601 if (!hv_fetch(GvHV(*fields), key,
8602 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8604 Perl_croak(aTHX_ "No such class field \"%s\" "
8605 "in variable %s of type %s",
8606 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8619 SVOP *first_key_op, *key_op;
8621 if ((o->op_private & (OPpLVAL_INTRO))
8622 /* I bet there's always a pushmark... */
8623 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8624 /* hmmm, no optimization if list contains only one key. */
8626 rop = (UNOP*)((LISTOP*)o)->op_last;
8627 if (rop->op_type != OP_RV2HV)
8629 if (rop->op_first->op_type == OP_PADSV)
8630 /* @$hash{qw(keys here)} */
8631 rop = (UNOP*)rop->op_first;
8633 /* @{$hash}{qw(keys here)} */
8634 if (rop->op_first->op_type == OP_SCOPE
8635 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8637 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8643 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8644 if (!SvPAD_TYPED(lexname))
8646 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8647 if (!fields || !GvHV(*fields))
8649 /* Again guessing that the pushmark can be jumped over.... */
8650 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8651 ->op_first->op_sibling;
8652 for (key_op = first_key_op; key_op;
8653 key_op = (SVOP*)key_op->op_sibling) {
8654 if (key_op->op_type != OP_CONST)
8656 svp = cSVOPx_svp(key_op);
8657 key = SvPV_const(*svp, keylen);
8658 if (!hv_fetch(GvHV(*fields), key,
8659 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8661 Perl_croak(aTHX_ "No such class field \"%s\" "
8662 "in variable %s of type %s",
8663 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8670 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8674 /* check that RHS of sort is a single plain array */
8675 OP *oright = cUNOPo->op_first;
8676 if (!oright || oright->op_type != OP_PUSHMARK)
8679 /* reverse sort ... can be optimised. */
8680 if (!cUNOPo->op_sibling) {
8681 /* Nothing follows us on the list. */
8682 OP * const reverse = o->op_next;
8684 if (reverse->op_type == OP_REVERSE &&
8685 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8686 OP * const pushmark = cUNOPx(reverse)->op_first;
8687 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8688 && (cUNOPx(pushmark)->op_sibling == o)) {
8689 /* reverse -> pushmark -> sort */
8690 o->op_private |= OPpSORT_REVERSE;
8692 pushmark->op_next = oright->op_next;
8698 /* make @a = sort @a act in-place */
8700 oright = cUNOPx(oright)->op_sibling;
8703 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8704 oright = cUNOPx(oright)->op_sibling;
8708 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8709 || oright->op_next != o
8710 || (oright->op_private & OPpLVAL_INTRO)
8714 /* o2 follows the chain of op_nexts through the LHS of the
8715 * assign (if any) to the aassign op itself */
8717 if (!o2 || o2->op_type != OP_NULL)
8720 if (!o2 || o2->op_type != OP_PUSHMARK)
8723 if (o2 && o2->op_type == OP_GV)
8726 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8727 || (o2->op_private & OPpLVAL_INTRO)
8732 if (!o2 || o2->op_type != OP_NULL)
8735 if (!o2 || o2->op_type != OP_AASSIGN
8736 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8739 /* check that the sort is the first arg on RHS of assign */
8741 o2 = cUNOPx(o2)->op_first;
8742 if (!o2 || o2->op_type != OP_NULL)
8744 o2 = cUNOPx(o2)->op_first;
8745 if (!o2 || o2->op_type != OP_PUSHMARK)
8747 if (o2->op_sibling != o)
8750 /* check the array is the same on both sides */
8751 if (oleft->op_type == OP_RV2AV) {
8752 if (oright->op_type != OP_RV2AV
8753 || !cUNOPx(oright)->op_first
8754 || cUNOPx(oright)->op_first->op_type != OP_GV
8755 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8756 cGVOPx_gv(cUNOPx(oright)->op_first)
8760 else if (oright->op_type != OP_PADAV
8761 || oright->op_targ != oleft->op_targ
8765 /* transfer MODishness etc from LHS arg to RHS arg */
8766 oright->op_flags = oleft->op_flags;
8767 o->op_private |= OPpSORT_INPLACE;
8769 /* excise push->gv->rv2av->null->aassign */
8770 o2 = o->op_next->op_next;
8771 op_null(o2); /* PUSHMARK */
8773 if (o2->op_type == OP_GV) {
8774 op_null(o2); /* GV */
8777 op_null(o2); /* RV2AV or PADAV */
8778 o2 = o2->op_next->op_next;
8779 op_null(o2); /* AASSIGN */
8781 o->op_next = o2->op_next;
8787 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8789 LISTOP *enter, *exlist;
8791 enter = (LISTOP *) o->op_next;
8794 if (enter->op_type == OP_NULL) {
8795 enter = (LISTOP *) enter->op_next;
8799 /* for $a (...) will have OP_GV then OP_RV2GV here.
8800 for (...) just has an OP_GV. */
8801 if (enter->op_type == OP_GV) {
8802 gvop = (OP *) enter;
8803 enter = (LISTOP *) enter->op_next;
8806 if (enter->op_type == OP_RV2GV) {
8807 enter = (LISTOP *) enter->op_next;
8813 if (enter->op_type != OP_ENTERITER)
8816 iter = enter->op_next;
8817 if (!iter || iter->op_type != OP_ITER)
8820 expushmark = enter->op_first;
8821 if (!expushmark || expushmark->op_type != OP_NULL
8822 || expushmark->op_targ != OP_PUSHMARK)
8825 exlist = (LISTOP *) expushmark->op_sibling;
8826 if (!exlist || exlist->op_type != OP_NULL
8827 || exlist->op_targ != OP_LIST)
8830 if (exlist->op_last != o) {
8831 /* Mmm. Was expecting to point back to this op. */
8834 theirmark = exlist->op_first;
8835 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8838 if (theirmark->op_sibling != o) {
8839 /* There's something between the mark and the reverse, eg
8840 for (1, reverse (...))
8845 ourmark = ((LISTOP *)o)->op_first;
8846 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8849 ourlast = ((LISTOP *)o)->op_last;
8850 if (!ourlast || ourlast->op_next != o)
8853 rv2av = ourmark->op_sibling;
8854 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8855 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8856 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8857 /* We're just reversing a single array. */
8858 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8859 enter->op_flags |= OPf_STACKED;
8862 /* We don't have control over who points to theirmark, so sacrifice
8864 theirmark->op_next = ourmark->op_next;
8865 theirmark->op_flags = ourmark->op_flags;
8866 ourlast->op_next = gvop ? gvop : (OP *) enter;
8869 enter->op_private |= OPpITER_REVERSED;
8870 iter->op_private |= OPpITER_REVERSED;
8877 UNOP *refgen, *rv2cv;
8880 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8883 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8886 rv2gv = ((BINOP *)o)->op_last;
8887 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8890 refgen = (UNOP *)((BINOP *)o)->op_first;
8892 if (!refgen || refgen->op_type != OP_REFGEN)
8895 exlist = (LISTOP *)refgen->op_first;
8896 if (!exlist || exlist->op_type != OP_NULL
8897 || exlist->op_targ != OP_LIST)
8900 if (exlist->op_first->op_type != OP_PUSHMARK)
8903 rv2cv = (UNOP*)exlist->op_last;
8905 if (rv2cv->op_type != OP_RV2CV)
8908 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8909 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8910 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8912 o->op_private |= OPpASSIGN_CV_TO_GV;
8913 rv2gv->op_private |= OPpDONT_INIT_GV;
8914 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8922 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8923 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8933 Perl_custom_op_name(pTHX_ const OP* o)
8936 const IV index = PTR2IV(o->op_ppaddr);
8940 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8942 if (!PL_custom_op_names) /* This probably shouldn't happen */
8943 return (char *)PL_op_name[OP_CUSTOM];
8945 keysv = sv_2mortal(newSViv(index));
8947 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8949 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8951 return SvPV_nolen(HeVAL(he));
8955 Perl_custom_op_desc(pTHX_ const OP* o)
8958 const IV index = PTR2IV(o->op_ppaddr);
8962 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8964 if (!PL_custom_op_descs)
8965 return (char *)PL_op_desc[OP_CUSTOM];
8967 keysv = sv_2mortal(newSViv(index));
8969 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8971 return (char *)PL_op_desc[OP_CUSTOM];
8973 return SvPV_nolen(HeVAL(he));
8978 /* Efficient sub that returns a constant scalar value. */
8980 const_sv_xsub(pTHX_ CV* cv)
8984 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
8988 /* diag_listed_as: SKIPME */
8989 Perl_croak(aTHX_ "usage: %s::%s()",
8990 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9003 * c-indentation-style: bsd
9005 * indent-tabs-mode: t
9008 * ex: set ts=8 sts=4 sw=4 noet: