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)
882 if (o->op_flags & OPf_KIDS) {
883 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
889 kid = cLISTOPo->op_first;
891 while ((kid = kid->op_sibling)) {
897 PL_curcop = &PL_compiling;
902 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
908 PL_curcop = &PL_compiling;
911 if (ckWARN(WARN_VOID))
912 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
919 Perl_scalarvoid(pTHX_ OP *o)
923 const char* useless = NULL;
927 PERL_ARGS_ASSERT_SCALARVOID;
929 /* trailing mad null ops don't count as "there" for void processing */
931 o->op_type != OP_NULL &&
933 o->op_sibling->op_type == OP_NULL)
936 for (sib = o->op_sibling;
937 sib && sib->op_type == OP_NULL;
938 sib = sib->op_sibling) ;
944 if (o->op_type == OP_NEXTSTATE
945 || o->op_type == OP_DBSTATE
946 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
947 || o->op_targ == OP_DBSTATE)))
948 PL_curcop = (COP*)o; /* for warning below */
950 /* assumes no premature commitment */
951 want = o->op_flags & OPf_WANT;
952 if ((want && want != OPf_WANT_SCALAR)
953 || (PL_parser && PL_parser->error_count)
954 || o->op_type == OP_RETURN)
959 if ((o->op_private & OPpTARGET_MY)
960 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
962 return scalar(o); /* As if inside SASSIGN */
965 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
967 switch (o->op_type) {
969 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
973 if (o->op_flags & OPf_STACKED)
977 if (o->op_private == 4)
1020 case OP_GETSOCKNAME:
1021 case OP_GETPEERNAME:
1026 case OP_GETPRIORITY:
1050 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1051 /* Otherwise it's "Useless use of grep iterator" */
1052 useless = OP_DESC(o);
1056 kid = cUNOPo->op_first;
1057 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1058 kid->op_type != OP_TRANS) {
1061 useless = "negative pattern binding (!~)";
1068 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1069 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1070 useless = "a variable";
1075 if (cSVOPo->op_private & OPpCONST_STRICT)
1076 no_bareword_allowed(o);
1078 if (ckWARN(WARN_VOID)) {
1080 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1081 "a constant (%"SVf")", sv));
1082 useless = SvPV_nolen(msv);
1085 useless = "a constant (undef)";
1086 if (o->op_private & OPpCONST_ARYBASE)
1088 /* don't warn on optimised away booleans, eg
1089 * use constant Foo, 5; Foo || print; */
1090 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1092 /* the constants 0 and 1 are permitted as they are
1093 conventionally used as dummies in constructs like
1094 1 while some_condition_with_side_effects; */
1095 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1097 else if (SvPOK(sv)) {
1098 /* perl4's way of mixing documentation and code
1099 (before the invention of POD) was based on a
1100 trick to mix nroff and perl code. The trick was
1101 built upon these three nroff macros being used in
1102 void context. The pink camel has the details in
1103 the script wrapman near page 319. */
1104 const char * const maybe_macro = SvPVX_const(sv);
1105 if (strnEQ(maybe_macro, "di", 2) ||
1106 strnEQ(maybe_macro, "ds", 2) ||
1107 strnEQ(maybe_macro, "ig", 2))
1112 op_null(o); /* don't execute or even remember it */
1116 o->op_type = OP_PREINC; /* pre-increment is faster */
1117 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1121 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1122 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1126 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1127 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1131 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1132 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1137 kid = cLOGOPo->op_first;
1138 if (kid->op_type == OP_NOT
1139 && (kid->op_flags & OPf_KIDS)
1141 if (o->op_type == OP_AND) {
1143 o->op_ppaddr = PL_ppaddr[OP_OR];
1145 o->op_type = OP_AND;
1146 o->op_ppaddr = PL_ppaddr[OP_AND];
1155 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1160 if (o->op_flags & OPf_STACKED)
1167 if (!(o->op_flags & OPf_KIDS))
1178 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1185 /* all requires must return a boolean value */
1186 o->op_flags &= ~OPf_WANT;
1191 if (useless && ckWARN(WARN_VOID))
1192 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1197 S_listkids(pTHX_ OP *o)
1199 if (o && o->op_flags & OPf_KIDS) {
1201 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1208 Perl_list(pTHX_ OP *o)
1213 /* assumes no premature commitment */
1214 if (!o || (o->op_flags & OPf_WANT)
1215 || (PL_parser && PL_parser->error_count)
1216 || o->op_type == OP_RETURN)
1221 if ((o->op_private & OPpTARGET_MY)
1222 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1224 return o; /* As if inside SASSIGN */
1227 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1229 switch (o->op_type) {
1232 list(cBINOPo->op_first);
1237 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1245 if (!(o->op_flags & OPf_KIDS))
1247 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1248 list(cBINOPo->op_first);
1249 return gen_constant_list(o);
1256 kid = cLISTOPo->op_first;
1258 while ((kid = kid->op_sibling)) {
1259 if (kid->op_sibling)
1264 PL_curcop = &PL_compiling;
1268 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1269 if (kid->op_sibling)
1274 PL_curcop = &PL_compiling;
1277 /* all requires must return a boolean value */
1278 o->op_flags &= ~OPf_WANT;
1285 S_scalarseq(pTHX_ OP *o)
1289 const OPCODE type = o->op_type;
1291 if (type == OP_LINESEQ || type == OP_SCOPE ||
1292 type == OP_LEAVE || type == OP_LEAVETRY)
1295 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1296 if (kid->op_sibling) {
1300 PL_curcop = &PL_compiling;
1302 o->op_flags &= ~OPf_PARENS;
1303 if (PL_hints & HINT_BLOCK_SCOPE)
1304 o->op_flags |= OPf_PARENS;
1307 o = newOP(OP_STUB, 0);
1312 S_modkids(pTHX_ OP *o, I32 type)
1314 if (o && o->op_flags & OPf_KIDS) {
1316 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1322 /* Propagate lvalue ("modifiable") context to an op and its children.
1323 * 'type' represents the context type, roughly based on the type of op that
1324 * would do the modifying, although local() is represented by OP_NULL.
1325 * It's responsible for detecting things that can't be modified, flag
1326 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1327 * might have to vivify a reference in $x), and so on.
1329 * For example, "$a+1 = 2" would cause mod() to be called with o being
1330 * OP_ADD and type being OP_SASSIGN, and would output an error.
1334 Perl_mod(pTHX_ OP *o, I32 type)
1338 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1341 if (!o || (PL_parser && PL_parser->error_count))
1344 if ((o->op_private & OPpTARGET_MY)
1345 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1350 switch (o->op_type) {
1356 if (!(o->op_private & OPpCONST_ARYBASE))
1359 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1360 CopARYBASE_set(&PL_compiling,
1361 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1365 SAVECOPARYBASE(&PL_compiling);
1366 CopARYBASE_set(&PL_compiling, 0);
1368 else if (type == OP_REFGEN)
1371 Perl_croak(aTHX_ "That use of $[ is unsupported");
1374 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1378 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1379 !(o->op_flags & OPf_STACKED)) {
1380 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1381 /* The default is to set op_private to the number of children,
1382 which for a UNOP such as RV2CV is always 1. And w're using
1383 the bit for a flag in RV2CV, so we need it clear. */
1384 o->op_private &= ~1;
1385 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1386 assert(cUNOPo->op_first->op_type == OP_NULL);
1387 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1390 else if (o->op_private & OPpENTERSUB_NOMOD)
1392 else { /* lvalue subroutine call */
1393 o->op_private |= OPpLVAL_INTRO;
1394 PL_modcount = RETURN_UNLIMITED_NUMBER;
1395 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1396 /* Backward compatibility mode: */
1397 o->op_private |= OPpENTERSUB_INARGS;
1400 else { /* Compile-time error message: */
1401 OP *kid = cUNOPo->op_first;
1405 if (kid->op_type != OP_PUSHMARK) {
1406 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1408 "panic: unexpected lvalue entersub "
1409 "args: type/targ %ld:%"UVuf,
1410 (long)kid->op_type, (UV)kid->op_targ);
1411 kid = kLISTOP->op_first;
1413 while (kid->op_sibling)
1414 kid = kid->op_sibling;
1415 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1417 if (kid->op_type == OP_METHOD_NAMED
1418 || kid->op_type == OP_METHOD)
1422 NewOp(1101, newop, 1, UNOP);
1423 newop->op_type = OP_RV2CV;
1424 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1425 newop->op_first = NULL;
1426 newop->op_next = (OP*)newop;
1427 kid->op_sibling = (OP*)newop;
1428 newop->op_private |= OPpLVAL_INTRO;
1429 newop->op_private &= ~1;
1433 if (kid->op_type != OP_RV2CV)
1435 "panic: unexpected lvalue entersub "
1436 "entry via type/targ %ld:%"UVuf,
1437 (long)kid->op_type, (UV)kid->op_targ);
1438 kid->op_private |= OPpLVAL_INTRO;
1439 break; /* Postpone until runtime */
1443 kid = kUNOP->op_first;
1444 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1445 kid = kUNOP->op_first;
1446 if (kid->op_type == OP_NULL)
1448 "Unexpected constant lvalue entersub "
1449 "entry via type/targ %ld:%"UVuf,
1450 (long)kid->op_type, (UV)kid->op_targ);
1451 if (kid->op_type != OP_GV) {
1452 /* Restore RV2CV to check lvalueness */
1454 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1455 okid->op_next = kid->op_next;
1456 kid->op_next = okid;
1459 okid->op_next = NULL;
1460 okid->op_type = OP_RV2CV;
1462 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1463 okid->op_private |= OPpLVAL_INTRO;
1464 okid->op_private &= ~1;
1468 cv = GvCV(kGVOP_gv);
1478 /* grep, foreach, subcalls, refgen */
1479 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1481 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1482 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1484 : (o->op_type == OP_ENTERSUB
1485 ? "non-lvalue subroutine call"
1487 type ? PL_op_desc[type] : "local"));
1501 case OP_RIGHT_SHIFT:
1510 if (!(o->op_flags & OPf_STACKED))
1517 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1523 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1524 PL_modcount = RETURN_UNLIMITED_NUMBER;
1525 return o; /* Treat \(@foo) like ordinary list. */
1529 if (scalar_mod_type(o, type))
1531 ref(cUNOPo->op_first, o->op_type);
1535 if (type == OP_LEAVESUBLV)
1536 o->op_private |= OPpMAYBE_LVSUB;
1542 PL_modcount = RETURN_UNLIMITED_NUMBER;
1545 ref(cUNOPo->op_first, o->op_type);
1550 PL_hints |= HINT_BLOCK_SCOPE;
1565 PL_modcount = RETURN_UNLIMITED_NUMBER;
1566 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1567 return o; /* Treat \(@foo) like ordinary list. */
1568 if (scalar_mod_type(o, type))
1570 if (type == OP_LEAVESUBLV)
1571 o->op_private |= OPpMAYBE_LVSUB;
1575 if (!type) /* local() */
1576 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1577 PAD_COMPNAME_PV(o->op_targ));
1585 if (type != OP_SASSIGN)
1589 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1594 if (type == OP_LEAVESUBLV)
1595 o->op_private |= OPpMAYBE_LVSUB;
1597 pad_free(o->op_targ);
1598 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1599 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1600 if (o->op_flags & OPf_KIDS)
1601 mod(cBINOPo->op_first->op_sibling, type);
1606 ref(cBINOPo->op_first, o->op_type);
1607 if (type == OP_ENTERSUB &&
1608 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1609 o->op_private |= OPpLVAL_DEFER;
1610 if (type == OP_LEAVESUBLV)
1611 o->op_private |= OPpMAYBE_LVSUB;
1621 if (o->op_flags & OPf_KIDS)
1622 mod(cLISTOPo->op_last, type);
1627 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1629 else if (!(o->op_flags & OPf_KIDS))
1631 if (o->op_targ != OP_LIST) {
1632 mod(cBINOPo->op_first, type);
1638 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1643 if (type != OP_LEAVESUBLV)
1645 break; /* mod()ing was handled by ck_return() */
1648 /* [20011101.069] File test operators interpret OPf_REF to mean that
1649 their argument is a filehandle; thus \stat(".") should not set
1651 if (type == OP_REFGEN &&
1652 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1655 if (type != OP_LEAVESUBLV)
1656 o->op_flags |= OPf_MOD;
1658 if (type == OP_AASSIGN || type == OP_SASSIGN)
1659 o->op_flags |= OPf_SPECIAL|OPf_REF;
1660 else if (!type) { /* local() */
1663 o->op_private |= OPpLVAL_INTRO;
1664 o->op_flags &= ~OPf_SPECIAL;
1665 PL_hints |= HINT_BLOCK_SCOPE;
1670 if (ckWARN(WARN_SYNTAX)) {
1671 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1672 "Useless localization of %s", OP_DESC(o));
1676 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1677 && type != OP_LEAVESUBLV)
1678 o->op_flags |= OPf_REF;
1683 S_scalar_mod_type(const OP *o, I32 type)
1685 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1689 if (o->op_type == OP_RV2GV)
1713 case OP_RIGHT_SHIFT:
1733 S_is_handle_constructor(const OP *o, I32 numargs)
1735 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1737 switch (o->op_type) {
1745 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1758 S_refkids(pTHX_ OP *o, I32 type)
1760 if (o && o->op_flags & OPf_KIDS) {
1762 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1769 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1774 PERL_ARGS_ASSERT_DOREF;
1776 if (!o || (PL_parser && PL_parser->error_count))
1779 switch (o->op_type) {
1781 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1782 !(o->op_flags & OPf_STACKED)) {
1783 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1784 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1785 assert(cUNOPo->op_first->op_type == OP_NULL);
1786 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1787 o->op_flags |= OPf_SPECIAL;
1788 o->op_private &= ~1;
1793 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1794 doref(kid, type, set_op_ref);
1797 if (type == OP_DEFINED)
1798 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1799 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1802 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1803 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1804 : type == OP_RV2HV ? OPpDEREF_HV
1806 o->op_flags |= OPf_MOD;
1813 o->op_flags |= OPf_REF;
1816 if (type == OP_DEFINED)
1817 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1818 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1824 o->op_flags |= OPf_REF;
1829 if (!(o->op_flags & OPf_KIDS))
1831 doref(cBINOPo->op_first, type, set_op_ref);
1835 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1836 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1837 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1838 : type == OP_RV2HV ? OPpDEREF_HV
1840 o->op_flags |= OPf_MOD;
1850 if (!(o->op_flags & OPf_KIDS))
1852 doref(cLISTOPo->op_last, type, set_op_ref);
1862 S_dup_attrlist(pTHX_ OP *o)
1867 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1869 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1870 * where the first kid is OP_PUSHMARK and the remaining ones
1871 * are OP_CONST. We need to push the OP_CONST values.
1873 if (o->op_type == OP_CONST)
1874 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1876 else if (o->op_type == OP_NULL)
1880 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1882 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1883 if (o->op_type == OP_CONST)
1884 rop = append_elem(OP_LIST, rop,
1885 newSVOP(OP_CONST, o->op_flags,
1886 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1893 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1898 PERL_ARGS_ASSERT_APPLY_ATTRS;
1900 /* fake up C<use attributes $pkg,$rv,@attrs> */
1901 ENTER; /* need to protect against side-effects of 'use' */
1902 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1904 #define ATTRSMODULE "attributes"
1905 #define ATTRSMODULE_PM "attributes.pm"
1908 /* Don't force the C<use> if we don't need it. */
1909 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1910 if (svp && *svp != &PL_sv_undef)
1911 NOOP; /* already in %INC */
1913 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1914 newSVpvs(ATTRSMODULE), NULL);
1917 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1918 newSVpvs(ATTRSMODULE),
1920 prepend_elem(OP_LIST,
1921 newSVOP(OP_CONST, 0, stashsv),
1922 prepend_elem(OP_LIST,
1923 newSVOP(OP_CONST, 0,
1925 dup_attrlist(attrs))));
1931 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1934 OP *pack, *imop, *arg;
1937 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1942 assert(target->op_type == OP_PADSV ||
1943 target->op_type == OP_PADHV ||
1944 target->op_type == OP_PADAV);
1946 /* Ensure that attributes.pm is loaded. */
1947 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1949 /* Need package name for method call. */
1950 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1952 /* Build up the real arg-list. */
1953 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1955 arg = newOP(OP_PADSV, 0);
1956 arg->op_targ = target->op_targ;
1957 arg = prepend_elem(OP_LIST,
1958 newSVOP(OP_CONST, 0, stashsv),
1959 prepend_elem(OP_LIST,
1960 newUNOP(OP_REFGEN, 0,
1961 mod(arg, OP_REFGEN)),
1962 dup_attrlist(attrs)));
1964 /* Fake up a method call to import */
1965 meth = newSVpvs_share("import");
1966 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1967 append_elem(OP_LIST,
1968 prepend_elem(OP_LIST, pack, list(arg)),
1969 newSVOP(OP_METHOD_NAMED, 0, meth)));
1970 imop->op_private |= OPpENTERSUB_NOMOD;
1972 /* Combine the ops. */
1973 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1977 =notfor apidoc apply_attrs_string
1979 Attempts to apply a list of attributes specified by the C<attrstr> and
1980 C<len> arguments to the subroutine identified by the C<cv> argument which
1981 is expected to be associated with the package identified by the C<stashpv>
1982 argument (see L<attributes>). It gets this wrong, though, in that it
1983 does not correctly identify the boundaries of the individual attribute
1984 specifications within C<attrstr>. This is not really intended for the
1985 public API, but has to be listed here for systems such as AIX which
1986 need an explicit export list for symbols. (It's called from XS code
1987 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1988 to respect attribute syntax properly would be welcome.
1994 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1995 const char *attrstr, STRLEN len)
1999 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2002 len = strlen(attrstr);
2006 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2008 const char * const sstr = attrstr;
2009 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2010 attrs = append_elem(OP_LIST, attrs,
2011 newSVOP(OP_CONST, 0,
2012 newSVpvn(sstr, attrstr-sstr)));
2016 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2017 newSVpvs(ATTRSMODULE),
2018 NULL, prepend_elem(OP_LIST,
2019 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2020 prepend_elem(OP_LIST,
2021 newSVOP(OP_CONST, 0,
2022 newRV(MUTABLE_SV(cv))),
2027 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2032 PERL_ARGS_ASSERT_MY_KID;
2034 if (!o || (PL_parser && PL_parser->error_count))
2038 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2039 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2043 if (type == OP_LIST) {
2045 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2046 my_kid(kid, attrs, imopsp);
2047 } else if (type == OP_UNDEF
2053 } else if (type == OP_RV2SV || /* "our" declaration */
2055 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2056 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2057 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2059 PL_parser->in_my == KEY_our
2061 : PL_parser->in_my == KEY_state ? "state" : "my"));
2063 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2064 PL_parser->in_my = FALSE;
2065 PL_parser->in_my_stash = NULL;
2066 apply_attrs(GvSTASH(gv),
2067 (type == OP_RV2SV ? GvSV(gv) :
2068 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2069 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2072 o->op_private |= OPpOUR_INTRO;
2075 else if (type != OP_PADSV &&
2078 type != OP_PUSHMARK)
2080 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2082 PL_parser->in_my == KEY_our
2084 : PL_parser->in_my == KEY_state ? "state" : "my"));
2087 else if (attrs && type != OP_PUSHMARK) {
2090 PL_parser->in_my = FALSE;
2091 PL_parser->in_my_stash = NULL;
2093 /* check for C<my Dog $spot> when deciding package */
2094 stash = PAD_COMPNAME_TYPE(o->op_targ);
2096 stash = PL_curstash;
2097 apply_attrs_my(stash, o, attrs, imopsp);
2099 o->op_flags |= OPf_MOD;
2100 o->op_private |= OPpLVAL_INTRO;
2101 if (PL_parser->in_my == KEY_state)
2102 o->op_private |= OPpPAD_STATE;
2107 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2111 int maybe_scalar = 0;
2113 PERL_ARGS_ASSERT_MY_ATTRS;
2115 /* [perl #17376]: this appears to be premature, and results in code such as
2116 C< our(%x); > executing in list mode rather than void mode */
2118 if (o->op_flags & OPf_PARENS)
2128 o = my_kid(o, attrs, &rops);
2130 if (maybe_scalar && o->op_type == OP_PADSV) {
2131 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2132 o->op_private |= OPpLVAL_INTRO;
2135 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2137 PL_parser->in_my = FALSE;
2138 PL_parser->in_my_stash = NULL;
2143 Perl_sawparens(pTHX_ OP *o)
2145 PERL_UNUSED_CONTEXT;
2147 o->op_flags |= OPf_PARENS;
2152 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2156 const OPCODE ltype = left->op_type;
2157 const OPCODE rtype = right->op_type;
2159 PERL_ARGS_ASSERT_BIND_MATCH;
2161 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2162 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2164 const char * const desc
2165 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2166 ? (int)rtype : OP_MATCH];
2167 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2168 ? "@array" : "%hash");
2169 Perl_warner(aTHX_ packWARN(WARN_MISC),
2170 "Applying %s to %s will act on scalar(%s)",
2171 desc, sample, sample);
2174 if (rtype == OP_CONST &&
2175 cSVOPx(right)->op_private & OPpCONST_BARE &&
2176 cSVOPx(right)->op_private & OPpCONST_STRICT)
2178 no_bareword_allowed(right);
2181 ismatchop = rtype == OP_MATCH ||
2182 rtype == OP_SUBST ||
2184 if (ismatchop && right->op_private & OPpTARGET_MY) {
2186 right->op_private &= ~OPpTARGET_MY;
2188 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2191 right->op_flags |= OPf_STACKED;
2192 if (rtype != OP_MATCH &&
2193 ! (rtype == OP_TRANS &&
2194 right->op_private & OPpTRANS_IDENTICAL))
2195 newleft = mod(left, rtype);
2198 if (right->op_type == OP_TRANS)
2199 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2201 o = prepend_elem(rtype, scalar(newleft), right);
2203 return newUNOP(OP_NOT, 0, scalar(o));
2207 return bind_match(type, left,
2208 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2212 Perl_invert(pTHX_ OP *o)
2216 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2220 Perl_scope(pTHX_ OP *o)
2224 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2225 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2226 o->op_type = OP_LEAVE;
2227 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2229 else if (o->op_type == OP_LINESEQ) {
2231 o->op_type = OP_SCOPE;
2232 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2233 kid = ((LISTOP*)o)->op_first;
2234 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2237 /* The following deals with things like 'do {1 for 1}' */
2238 kid = kid->op_sibling;
2240 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2245 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2251 Perl_block_start(pTHX_ int full)
2254 const int retval = PL_savestack_ix;
2255 pad_block_start(full);
2257 PL_hints &= ~HINT_BLOCK_SCOPE;
2258 SAVECOMPILEWARNINGS();
2259 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2264 Perl_block_end(pTHX_ I32 floor, OP *seq)
2267 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2268 OP* const retval = scalarseq(seq);
2270 CopHINTS_set(&PL_compiling, PL_hints);
2272 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2281 const PADOFFSET offset = pad_findmy("$_");
2282 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2283 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2286 OP * const o = newOP(OP_PADSV, 0);
2287 o->op_targ = offset;
2293 Perl_newPROG(pTHX_ OP *o)
2297 PERL_ARGS_ASSERT_NEWPROG;
2302 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2303 ((PL_in_eval & EVAL_KEEPERR)
2304 ? OPf_SPECIAL : 0), o);
2305 PL_eval_start = linklist(PL_eval_root);
2306 PL_eval_root->op_private |= OPpREFCOUNTED;
2307 OpREFCNT_set(PL_eval_root, 1);
2308 PL_eval_root->op_next = 0;
2309 CALL_PEEP(PL_eval_start);
2312 if (o->op_type == OP_STUB) {
2313 PL_comppad_name = 0;
2315 S_op_destroy(aTHX_ o);
2318 PL_main_root = scope(sawparens(scalarvoid(o)));
2319 PL_curcop = &PL_compiling;
2320 PL_main_start = LINKLIST(PL_main_root);
2321 PL_main_root->op_private |= OPpREFCOUNTED;
2322 OpREFCNT_set(PL_main_root, 1);
2323 PL_main_root->op_next = 0;
2324 CALL_PEEP(PL_main_start);
2327 /* Register with debugger */
2329 CV * const cv = get_cvs("DB::postponed", 0);
2333 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2335 call_sv(MUTABLE_SV(cv), G_DISCARD);
2342 Perl_localize(pTHX_ OP *o, I32 lex)
2346 PERL_ARGS_ASSERT_LOCALIZE;
2348 if (o->op_flags & OPf_PARENS)
2349 /* [perl #17376]: this appears to be premature, and results in code such as
2350 C< our(%x); > executing in list mode rather than void mode */
2357 if ( PL_parser->bufptr > PL_parser->oldbufptr
2358 && PL_parser->bufptr[-1] == ','
2359 && ckWARN(WARN_PARENTHESIS))
2361 char *s = PL_parser->bufptr;
2364 /* some heuristics to detect a potential error */
2365 while (*s && (strchr(", \t\n", *s)))
2369 if (*s && strchr("@$%*", *s) && *++s
2370 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2373 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2375 while (*s && (strchr(", \t\n", *s)))
2381 if (sigil && (*s == ';' || *s == '=')) {
2382 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2383 "Parentheses missing around \"%s\" list",
2385 ? (PL_parser->in_my == KEY_our
2387 : PL_parser->in_my == KEY_state
2397 o = mod(o, OP_NULL); /* a bit kludgey */
2398 PL_parser->in_my = FALSE;
2399 PL_parser->in_my_stash = NULL;
2404 Perl_jmaybe(pTHX_ OP *o)
2406 PERL_ARGS_ASSERT_JMAYBE;
2408 if (o->op_type == OP_LIST) {
2410 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2411 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2417 S_fold_constants(pTHX_ register OP *o)
2420 register OP * VOL curop;
2422 VOL I32 type = o->op_type;
2427 SV * const oldwarnhook = PL_warnhook;
2428 SV * const olddiehook = PL_diehook;
2432 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2434 if (PL_opargs[type] & OA_RETSCALAR)
2436 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2437 o->op_targ = pad_alloc(type, SVs_PADTMP);
2439 /* integerize op, unless it happens to be C<-foo>.
2440 * XXX should pp_i_negate() do magic string negation instead? */
2441 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2442 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2443 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2445 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2448 if (!(PL_opargs[type] & OA_FOLDCONST))
2453 /* XXX might want a ck_negate() for this */
2454 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2465 /* XXX what about the numeric ops? */
2466 if (PL_hints & HINT_LOCALE)
2471 if (PL_parser && PL_parser->error_count)
2472 goto nope; /* Don't try to run w/ errors */
2474 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2475 const OPCODE type = curop->op_type;
2476 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2478 type != OP_SCALAR &&
2480 type != OP_PUSHMARK)
2486 curop = LINKLIST(o);
2487 old_next = o->op_next;
2491 oldscope = PL_scopestack_ix;
2492 create_eval_scope(G_FAKINGEVAL);
2494 /* Verify that we don't need to save it: */
2495 assert(PL_curcop == &PL_compiling);
2496 StructCopy(&PL_compiling, ¬_compiling, COP);
2497 PL_curcop = ¬_compiling;
2498 /* The above ensures that we run with all the correct hints of the
2499 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2500 assert(IN_PERL_RUNTIME);
2501 PL_warnhook = PERL_WARNHOOK_FATAL;
2508 sv = *(PL_stack_sp--);
2509 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2510 pad_swipe(o->op_targ, FALSE);
2511 else if (SvTEMP(sv)) { /* grab mortal temp? */
2512 SvREFCNT_inc_simple_void(sv);
2517 /* Something tried to die. Abandon constant folding. */
2518 /* Pretend the error never happened. */
2520 o->op_next = old_next;
2524 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2525 PL_warnhook = oldwarnhook;
2526 PL_diehook = olddiehook;
2527 /* XXX note that this croak may fail as we've already blown away
2528 * the stack - eg any nested evals */
2529 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2532 PL_warnhook = oldwarnhook;
2533 PL_diehook = olddiehook;
2534 PL_curcop = &PL_compiling;
2536 if (PL_scopestack_ix > oldscope)
2537 delete_eval_scope();
2546 if (type == OP_RV2GV)
2547 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2549 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2550 op_getmad(o,newop,'f');
2558 S_gen_constant_list(pTHX_ register OP *o)
2562 const I32 oldtmps_floor = PL_tmps_floor;
2565 if (PL_parser && PL_parser->error_count)
2566 return o; /* Don't attempt to run with errors */
2568 PL_op = curop = LINKLIST(o);
2574 assert (!(curop->op_flags & OPf_SPECIAL));
2575 assert(curop->op_type == OP_RANGE);
2577 PL_tmps_floor = oldtmps_floor;
2579 o->op_type = OP_RV2AV;
2580 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2581 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2582 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2583 o->op_opt = 0; /* needs to be revisited in peep() */
2584 curop = ((UNOP*)o)->op_first;
2585 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2587 op_getmad(curop,o,'O');
2596 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2599 if (!o || o->op_type != OP_LIST)
2600 o = newLISTOP(OP_LIST, 0, o, NULL);
2602 o->op_flags &= ~OPf_WANT;
2604 if (!(PL_opargs[type] & OA_MARK))
2605 op_null(cLISTOPo->op_first);
2607 o->op_type = (OPCODE)type;
2608 o->op_ppaddr = PL_ppaddr[type];
2609 o->op_flags |= flags;
2611 o = CHECKOP(type, o);
2612 if (o->op_type != (unsigned)type)
2615 return fold_constants(o);
2618 /* List constructors */
2621 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2629 if (first->op_type != (unsigned)type
2630 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2632 return newLISTOP(type, 0, first, last);
2635 if (first->op_flags & OPf_KIDS)
2636 ((LISTOP*)first)->op_last->op_sibling = last;
2638 first->op_flags |= OPf_KIDS;
2639 ((LISTOP*)first)->op_first = last;
2641 ((LISTOP*)first)->op_last = last;
2646 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2654 if (first->op_type != (unsigned)type)
2655 return prepend_elem(type, (OP*)first, (OP*)last);
2657 if (last->op_type != (unsigned)type)
2658 return append_elem(type, (OP*)first, (OP*)last);
2660 first->op_last->op_sibling = last->op_first;
2661 first->op_last = last->op_last;
2662 first->op_flags |= (last->op_flags & OPf_KIDS);
2665 if (last->op_first && first->op_madprop) {
2666 MADPROP *mp = last->op_first->op_madprop;
2668 while (mp->mad_next)
2670 mp->mad_next = first->op_madprop;
2673 last->op_first->op_madprop = first->op_madprop;
2676 first->op_madprop = last->op_madprop;
2677 last->op_madprop = 0;
2680 S_op_destroy(aTHX_ (OP*)last);
2686 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2694 if (last->op_type == (unsigned)type) {
2695 if (type == OP_LIST) { /* already a PUSHMARK there */
2696 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2697 ((LISTOP*)last)->op_first->op_sibling = first;
2698 if (!(first->op_flags & OPf_PARENS))
2699 last->op_flags &= ~OPf_PARENS;
2702 if (!(last->op_flags & OPf_KIDS)) {
2703 ((LISTOP*)last)->op_last = first;
2704 last->op_flags |= OPf_KIDS;
2706 first->op_sibling = ((LISTOP*)last)->op_first;
2707 ((LISTOP*)last)->op_first = first;
2709 last->op_flags |= OPf_KIDS;
2713 return newLISTOP(type, 0, first, last);
2721 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2724 Newxz(tk, 1, TOKEN);
2725 tk->tk_type = (OPCODE)optype;
2726 tk->tk_type = 12345;
2728 tk->tk_mad = madprop;
2733 Perl_token_free(pTHX_ TOKEN* tk)
2735 PERL_ARGS_ASSERT_TOKEN_FREE;
2737 if (tk->tk_type != 12345)
2739 mad_free(tk->tk_mad);
2744 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2749 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2751 if (tk->tk_type != 12345) {
2752 Perl_warner(aTHX_ packWARN(WARN_MISC),
2753 "Invalid TOKEN object ignored");
2760 /* faked up qw list? */
2762 tm->mad_type == MAD_SV &&
2763 SvPVX((SV *)tm->mad_val)[0] == 'q')
2770 /* pretend constant fold didn't happen? */
2771 if (mp->mad_key == 'f' &&
2772 (o->op_type == OP_CONST ||
2773 o->op_type == OP_GV) )
2775 token_getmad(tk,(OP*)mp->mad_val,slot);
2789 if (mp->mad_key == 'X')
2790 mp->mad_key = slot; /* just change the first one */
2800 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2809 /* pretend constant fold didn't happen? */
2810 if (mp->mad_key == 'f' &&
2811 (o->op_type == OP_CONST ||
2812 o->op_type == OP_GV) )
2814 op_getmad(from,(OP*)mp->mad_val,slot);
2821 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2824 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2830 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2839 /* pretend constant fold didn't happen? */
2840 if (mp->mad_key == 'f' &&
2841 (o->op_type == OP_CONST ||
2842 o->op_type == OP_GV) )
2844 op_getmad(from,(OP*)mp->mad_val,slot);
2851 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2854 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2858 PerlIO_printf(PerlIO_stderr(),
2859 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2865 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2883 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2887 addmad(tm, &(o->op_madprop), slot);
2891 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2912 Perl_newMADsv(pTHX_ char key, SV* sv)
2914 PERL_ARGS_ASSERT_NEWMADSV;
2916 return newMADPROP(key, MAD_SV, sv, 0);
2920 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2923 Newxz(mp, 1, MADPROP);
2926 mp->mad_vlen = vlen;
2927 mp->mad_type = type;
2929 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2934 Perl_mad_free(pTHX_ MADPROP* mp)
2936 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2940 mad_free(mp->mad_next);
2941 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2942 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2943 switch (mp->mad_type) {
2947 Safefree((char*)mp->mad_val);
2950 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2951 op_free((OP*)mp->mad_val);
2954 sv_free(MUTABLE_SV(mp->mad_val));
2957 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2966 Perl_newNULLLIST(pTHX)
2968 return newOP(OP_STUB, 0);
2972 S_force_list(pTHX_ OP *o)
2974 if (!o || o->op_type != OP_LIST)
2975 o = newLISTOP(OP_LIST, 0, o, NULL);
2981 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2986 NewOp(1101, listop, 1, LISTOP);
2988 listop->op_type = (OPCODE)type;
2989 listop->op_ppaddr = PL_ppaddr[type];
2992 listop->op_flags = (U8)flags;
2996 else if (!first && last)
2999 first->op_sibling = last;
3000 listop->op_first = first;
3001 listop->op_last = last;
3002 if (type == OP_LIST) {
3003 OP* const pushop = newOP(OP_PUSHMARK, 0);
3004 pushop->op_sibling = first;
3005 listop->op_first = pushop;
3006 listop->op_flags |= OPf_KIDS;
3008 listop->op_last = pushop;
3011 return CHECKOP(type, listop);
3015 Perl_newOP(pTHX_ I32 type, I32 flags)
3019 NewOp(1101, o, 1, OP);
3020 o->op_type = (OPCODE)type;
3021 o->op_ppaddr = PL_ppaddr[type];
3022 o->op_flags = (U8)flags;
3024 o->op_latefreed = 0;
3028 o->op_private = (U8)(0 | (flags >> 8));
3029 if (PL_opargs[type] & OA_RETSCALAR)
3031 if (PL_opargs[type] & OA_TARGET)
3032 o->op_targ = pad_alloc(type, SVs_PADTMP);
3033 return CHECKOP(type, o);
3037 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3043 first = newOP(OP_STUB, 0);
3044 if (PL_opargs[type] & OA_MARK)
3045 first = force_list(first);
3047 NewOp(1101, unop, 1, UNOP);
3048 unop->op_type = (OPCODE)type;
3049 unop->op_ppaddr = PL_ppaddr[type];
3050 unop->op_first = first;
3051 unop->op_flags = (U8)(flags | OPf_KIDS);
3052 unop->op_private = (U8)(1 | (flags >> 8));
3053 unop = (UNOP*) CHECKOP(type, unop);
3057 return fold_constants((OP *) unop);
3061 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3065 NewOp(1101, binop, 1, BINOP);
3068 first = newOP(OP_NULL, 0);
3070 binop->op_type = (OPCODE)type;
3071 binop->op_ppaddr = PL_ppaddr[type];
3072 binop->op_first = first;
3073 binop->op_flags = (U8)(flags | OPf_KIDS);
3076 binop->op_private = (U8)(1 | (flags >> 8));
3079 binop->op_private = (U8)(2 | (flags >> 8));
3080 first->op_sibling = last;
3083 binop = (BINOP*)CHECKOP(type, binop);
3084 if (binop->op_next || binop->op_type != (OPCODE)type)
3087 binop->op_last = binop->op_first->op_sibling;
3089 return fold_constants((OP *)binop);
3092 static int uvcompare(const void *a, const void *b)
3093 __attribute__nonnull__(1)
3094 __attribute__nonnull__(2)
3095 __attribute__pure__;
3096 static int uvcompare(const void *a, const void *b)
3098 if (*((const UV *)a) < (*(const UV *)b))
3100 if (*((const UV *)a) > (*(const UV *)b))
3102 if (*((const UV *)a+1) < (*(const UV *)b+1))
3104 if (*((const UV *)a+1) > (*(const UV *)b+1))
3110 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3113 SV * const tstr = ((SVOP*)expr)->op_sv;
3116 (repl->op_type == OP_NULL)
3117 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3119 ((SVOP*)repl)->op_sv;
3122 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3123 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3127 register short *tbl;
3129 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3130 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3131 I32 del = o->op_private & OPpTRANS_DELETE;
3134 PERL_ARGS_ASSERT_PMTRANS;
3136 PL_hints |= HINT_BLOCK_SCOPE;
3139 o->op_private |= OPpTRANS_FROM_UTF;
3142 o->op_private |= OPpTRANS_TO_UTF;
3144 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3145 SV* const listsv = newSVpvs("# comment\n");
3147 const U8* tend = t + tlen;
3148 const U8* rend = r + rlen;
3162 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3163 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3166 const U32 flags = UTF8_ALLOW_DEFAULT;
3170 t = tsave = bytes_to_utf8(t, &len);
3173 if (!to_utf && rlen) {
3175 r = rsave = bytes_to_utf8(r, &len);
3179 /* There are several snags with this code on EBCDIC:
3180 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3181 2. scan_const() in toke.c has encoded chars in native encoding which makes
3182 ranges at least in EBCDIC 0..255 range the bottom odd.
3186 U8 tmpbuf[UTF8_MAXBYTES+1];
3189 Newx(cp, 2*tlen, UV);
3191 transv = newSVpvs("");
3193 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3195 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3197 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3201 cp[2*i+1] = cp[2*i];
3205 qsort(cp, i, 2*sizeof(UV), uvcompare);
3206 for (j = 0; j < i; j++) {
3208 diff = val - nextmin;
3210 t = uvuni_to_utf8(tmpbuf,nextmin);
3211 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3213 U8 range_mark = UTF_TO_NATIVE(0xff);
3214 t = uvuni_to_utf8(tmpbuf, val - 1);
3215 sv_catpvn(transv, (char *)&range_mark, 1);
3216 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3223 t = uvuni_to_utf8(tmpbuf,nextmin);
3224 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3226 U8 range_mark = UTF_TO_NATIVE(0xff);
3227 sv_catpvn(transv, (char *)&range_mark, 1);
3229 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3230 UNICODE_ALLOW_SUPER);
3231 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3232 t = (const U8*)SvPVX_const(transv);
3233 tlen = SvCUR(transv);
3237 else if (!rlen && !del) {
3238 r = t; rlen = tlen; rend = tend;
3241 if ((!rlen && !del) || t == r ||
3242 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3244 o->op_private |= OPpTRANS_IDENTICAL;
3248 while (t < tend || tfirst <= tlast) {
3249 /* see if we need more "t" chars */
3250 if (tfirst > tlast) {
3251 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3253 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3255 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3262 /* now see if we need more "r" chars */
3263 if (rfirst > rlast) {
3265 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3267 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3269 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3278 rfirst = rlast = 0xffffffff;
3282 /* now see which range will peter our first, if either. */
3283 tdiff = tlast - tfirst;
3284 rdiff = rlast - rfirst;
3291 if (rfirst == 0xffffffff) {
3292 diff = tdiff; /* oops, pretend rdiff is infinite */
3294 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3295 (long)tfirst, (long)tlast);
3297 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3301 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3302 (long)tfirst, (long)(tfirst + diff),
3305 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3306 (long)tfirst, (long)rfirst);
3308 if (rfirst + diff > max)
3309 max = rfirst + diff;
3311 grows = (tfirst < rfirst &&
3312 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3324 else if (max > 0xff)
3329 PerlMemShared_free(cPVOPo->op_pv);
3330 cPVOPo->op_pv = NULL;
3332 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3334 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3335 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3336 PAD_SETSV(cPADOPo->op_padix, swash);
3338 SvREADONLY_on(swash);
3340 cSVOPo->op_sv = swash;
3342 SvREFCNT_dec(listsv);
3343 SvREFCNT_dec(transv);
3345 if (!del && havefinal && rlen)
3346 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3347 newSVuv((UV)final), 0);
3350 o->op_private |= OPpTRANS_GROWS;
3356 op_getmad(expr,o,'e');
3357 op_getmad(repl,o,'r');
3365 tbl = (short*)cPVOPo->op_pv;
3367 Zero(tbl, 256, short);
3368 for (i = 0; i < (I32)tlen; i++)
3370 for (i = 0, j = 0; i < 256; i++) {
3372 if (j >= (I32)rlen) {
3381 if (i < 128 && r[j] >= 128)
3391 o->op_private |= OPpTRANS_IDENTICAL;
3393 else if (j >= (I32)rlen)
3398 PerlMemShared_realloc(tbl,
3399 (0x101+rlen-j) * sizeof(short));
3400 cPVOPo->op_pv = (char*)tbl;
3402 tbl[0x100] = (short)(rlen - j);
3403 for (i=0; i < (I32)rlen - j; i++)
3404 tbl[0x101+i] = r[j+i];
3408 if (!rlen && !del) {
3411 o->op_private |= OPpTRANS_IDENTICAL;
3413 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3414 o->op_private |= OPpTRANS_IDENTICAL;
3416 for (i = 0; i < 256; i++)
3418 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3419 if (j >= (I32)rlen) {
3421 if (tbl[t[i]] == -1)
3427 if (tbl[t[i]] == -1) {
3428 if (t[i] < 128 && r[j] >= 128)
3435 if(ckWARN(WARN_MISC)) {
3436 if(del && rlen == tlen) {
3437 Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3438 } else if(rlen > tlen) {
3439 Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3444 o->op_private |= OPpTRANS_GROWS;
3446 op_getmad(expr,o,'e');
3447 op_getmad(repl,o,'r');
3457 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3462 NewOp(1101, pmop, 1, PMOP);
3463 pmop->op_type = (OPCODE)type;
3464 pmop->op_ppaddr = PL_ppaddr[type];
3465 pmop->op_flags = (U8)flags;
3466 pmop->op_private = (U8)(0 | (flags >> 8));
3468 if (PL_hints & HINT_RE_TAINT)
3469 pmop->op_pmflags |= PMf_RETAINT;
3470 if (PL_hints & HINT_LOCALE)
3471 pmop->op_pmflags |= PMf_LOCALE;
3475 assert(SvPOK(PL_regex_pad[0]));
3476 if (SvCUR(PL_regex_pad[0])) {
3477 /* Pop off the "packed" IV from the end. */
3478 SV *const repointer_list = PL_regex_pad[0];
3479 const char *p = SvEND(repointer_list) - sizeof(IV);
3480 const IV offset = *((IV*)p);
3482 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3484 SvEND_set(repointer_list, p);
3486 pmop->op_pmoffset = offset;
3487 /* This slot should be free, so assert this: */
3488 assert(PL_regex_pad[offset] == &PL_sv_undef);
3490 SV * const repointer = &PL_sv_undef;
3491 av_push(PL_regex_padav, repointer);
3492 pmop->op_pmoffset = av_len(PL_regex_padav);
3493 PL_regex_pad = AvARRAY(PL_regex_padav);
3497 return CHECKOP(type, pmop);
3500 /* Given some sort of match op o, and an expression expr containing a
3501 * pattern, either compile expr into a regex and attach it to o (if it's
3502 * constant), or convert expr into a runtime regcomp op sequence (if it's
3505 * isreg indicates that the pattern is part of a regex construct, eg
3506 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3507 * split "pattern", which aren't. In the former case, expr will be a list
3508 * if the pattern contains more than one term (eg /a$b/) or if it contains
3509 * a replacement, ie s/// or tr///.
3513 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3518 I32 repl_has_vars = 0;
3522 PERL_ARGS_ASSERT_PMRUNTIME;
3524 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3525 /* last element in list is the replacement; pop it */
3527 repl = cLISTOPx(expr)->op_last;
3528 kid = cLISTOPx(expr)->op_first;
3529 while (kid->op_sibling != repl)
3530 kid = kid->op_sibling;
3531 kid->op_sibling = NULL;
3532 cLISTOPx(expr)->op_last = kid;
3535 if (isreg && expr->op_type == OP_LIST &&
3536 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3538 /* convert single element list to element */
3539 OP* const oe = expr;
3540 expr = cLISTOPx(oe)->op_first->op_sibling;
3541 cLISTOPx(oe)->op_first->op_sibling = NULL;
3542 cLISTOPx(oe)->op_last = NULL;
3546 if (o->op_type == OP_TRANS) {
3547 return pmtrans(o, expr, repl);
3550 reglist = isreg && expr->op_type == OP_LIST;
3554 PL_hints |= HINT_BLOCK_SCOPE;
3557 if (expr->op_type == OP_CONST) {
3558 SV *pat = ((SVOP*)expr)->op_sv;
3559 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3561 if (o->op_flags & OPf_SPECIAL)
3562 pm_flags |= RXf_SPLIT;
3565 assert (SvUTF8(pat));
3566 } else if (SvUTF8(pat)) {
3567 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3568 trapped in use 'bytes'? */
3569 /* Make a copy of the octet sequence, but without the flag on, as
3570 the compiler now honours the SvUTF8 flag on pat. */
3572 const char *const p = SvPV(pat, len);
3573 pat = newSVpvn_flags(p, len, SVs_TEMP);
3576 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3579 op_getmad(expr,(OP*)pm,'e');
3585 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3586 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3588 : OP_REGCMAYBE),0,expr);
3590 NewOp(1101, rcop, 1, LOGOP);
3591 rcop->op_type = OP_REGCOMP;
3592 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3593 rcop->op_first = scalar(expr);
3594 rcop->op_flags |= OPf_KIDS
3595 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3596 | (reglist ? OPf_STACKED : 0);
3597 rcop->op_private = 1;
3600 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3602 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3605 /* establish postfix order */
3606 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3608 rcop->op_next = expr;
3609 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3612 rcop->op_next = LINKLIST(expr);
3613 expr->op_next = (OP*)rcop;
3616 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3621 if (pm->op_pmflags & PMf_EVAL) {
3623 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3624 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3626 else if (repl->op_type == OP_CONST)
3630 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3631 if (curop->op_type == OP_SCOPE
3632 || curop->op_type == OP_LEAVE
3633 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3634 if (curop->op_type == OP_GV) {
3635 GV * const gv = cGVOPx_gv(curop);
3637 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3640 else if (curop->op_type == OP_RV2CV)
3642 else if (curop->op_type == OP_RV2SV ||
3643 curop->op_type == OP_RV2AV ||
3644 curop->op_type == OP_RV2HV ||
3645 curop->op_type == OP_RV2GV) {
3646 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3649 else if (curop->op_type == OP_PADSV ||
3650 curop->op_type == OP_PADAV ||
3651 curop->op_type == OP_PADHV ||
3652 curop->op_type == OP_PADANY)
3656 else if (curop->op_type == OP_PUSHRE)
3657 NOOP; /* Okay here, dangerous in newASSIGNOP */
3667 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3669 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3670 prepend_elem(o->op_type, scalar(repl), o);
3673 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3674 pm->op_pmflags |= PMf_MAYBE_CONST;
3676 NewOp(1101, rcop, 1, LOGOP);
3677 rcop->op_type = OP_SUBSTCONT;
3678 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3679 rcop->op_first = scalar(repl);
3680 rcop->op_flags |= OPf_KIDS;
3681 rcop->op_private = 1;
3684 /* establish postfix order */
3685 rcop->op_next = LINKLIST(repl);
3686 repl->op_next = (OP*)rcop;
3688 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3689 assert(!(pm->op_pmflags & PMf_ONCE));
3690 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3699 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3704 PERL_ARGS_ASSERT_NEWSVOP;
3706 NewOp(1101, svop, 1, SVOP);
3707 svop->op_type = (OPCODE)type;
3708 svop->op_ppaddr = PL_ppaddr[type];
3710 svop->op_next = (OP*)svop;
3711 svop->op_flags = (U8)flags;
3712 if (PL_opargs[type] & OA_RETSCALAR)
3714 if (PL_opargs[type] & OA_TARGET)
3715 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3716 return CHECKOP(type, svop);
3721 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3726 PERL_ARGS_ASSERT_NEWPADOP;
3728 NewOp(1101, padop, 1, PADOP);
3729 padop->op_type = (OPCODE)type;
3730 padop->op_ppaddr = PL_ppaddr[type];
3731 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3732 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3733 PAD_SETSV(padop->op_padix, sv);
3736 padop->op_next = (OP*)padop;
3737 padop->op_flags = (U8)flags;
3738 if (PL_opargs[type] & OA_RETSCALAR)
3740 if (PL_opargs[type] & OA_TARGET)
3741 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3742 return CHECKOP(type, padop);
3747 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3751 PERL_ARGS_ASSERT_NEWGVOP;
3755 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3757 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3762 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3766 NewOp(1101, pvop, 1, PVOP);
3767 pvop->op_type = (OPCODE)type;
3768 pvop->op_ppaddr = PL_ppaddr[type];
3770 pvop->op_next = (OP*)pvop;
3771 pvop->op_flags = (U8)flags;
3772 if (PL_opargs[type] & OA_RETSCALAR)
3774 if (PL_opargs[type] & OA_TARGET)
3775 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3776 return CHECKOP(type, pvop);
3784 Perl_package(pTHX_ OP *o)
3787 SV *const sv = cSVOPo->op_sv;
3792 PERL_ARGS_ASSERT_PACKAGE;
3794 save_hptr(&PL_curstash);
3795 save_item(PL_curstname);
3797 PL_curstash = gv_stashsv(sv, GV_ADD);
3799 sv_setsv(PL_curstname, sv);
3801 PL_hints |= HINT_BLOCK_SCOPE;
3802 PL_parser->copline = NOLINE;
3803 PL_parser->expect = XSTATE;
3808 if (!PL_madskills) {
3813 pegop = newOP(OP_NULL,0);
3814 op_getmad(o,pegop,'P');
3820 Perl_package_version( pTHX_ OP *v )
3823 U32 savehints = PL_hints;
3824 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3825 PL_hints &= ~HINT_STRICT_VARS;
3826 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3827 PL_hints = savehints;
3836 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3843 OP *pegop = newOP(OP_NULL,0);
3846 PERL_ARGS_ASSERT_UTILIZE;
3848 if (idop->op_type != OP_CONST)
3849 Perl_croak(aTHX_ "Module name must be constant");
3852 op_getmad(idop,pegop,'U');
3857 SV * const vesv = ((SVOP*)version)->op_sv;
3860 op_getmad(version,pegop,'V');
3861 if (!arg && !SvNIOKp(vesv)) {
3868 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3869 Perl_croak(aTHX_ "Version number must be a constant number");
3871 /* Make copy of idop so we don't free it twice */
3872 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3874 /* Fake up a method call to VERSION */
3875 meth = newSVpvs_share("VERSION");
3876 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3877 append_elem(OP_LIST,
3878 prepend_elem(OP_LIST, pack, list(version)),
3879 newSVOP(OP_METHOD_NAMED, 0, meth)));
3883 /* Fake up an import/unimport */
3884 if (arg && arg->op_type == OP_STUB) {
3886 op_getmad(arg,pegop,'S');
3887 imop = arg; /* no import on explicit () */
3889 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3890 imop = NULL; /* use 5.0; */
3892 idop->op_private |= OPpCONST_NOVER;
3898 op_getmad(arg,pegop,'A');
3900 /* Make copy of idop so we don't free it twice */
3901 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3903 /* Fake up a method call to import/unimport */
3905 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3906 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3907 append_elem(OP_LIST,
3908 prepend_elem(OP_LIST, pack, list(arg)),
3909 newSVOP(OP_METHOD_NAMED, 0, meth)));
3912 /* Fake up the BEGIN {}, which does its thing immediately. */
3914 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3917 append_elem(OP_LINESEQ,
3918 append_elem(OP_LINESEQ,
3919 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3920 newSTATEOP(0, NULL, veop)),
3921 newSTATEOP(0, NULL, imop) ));
3923 /* The "did you use incorrect case?" warning used to be here.
3924 * The problem is that on case-insensitive filesystems one
3925 * might get false positives for "use" (and "require"):
3926 * "use Strict" or "require CARP" will work. This causes
3927 * portability problems for the script: in case-strict
3928 * filesystems the script will stop working.
3930 * The "incorrect case" warning checked whether "use Foo"
3931 * imported "Foo" to your namespace, but that is wrong, too:
3932 * there is no requirement nor promise in the language that
3933 * a Foo.pm should or would contain anything in package "Foo".
3935 * There is very little Configure-wise that can be done, either:
3936 * the case-sensitivity of the build filesystem of Perl does not
3937 * help in guessing the case-sensitivity of the runtime environment.
3940 PL_hints |= HINT_BLOCK_SCOPE;
3941 PL_parser->copline = NOLINE;
3942 PL_parser->expect = XSTATE;
3943 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3946 if (!PL_madskills) {
3947 /* FIXME - don't allocate pegop if !PL_madskills */
3956 =head1 Embedding Functions
3958 =for apidoc load_module
3960 Loads the module whose name is pointed to by the string part of name.
3961 Note that the actual module name, not its filename, should be given.
3962 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3963 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3964 (or 0 for no flags). ver, if specified, provides version semantics
3965 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3966 arguments can be used to specify arguments to the module's import()
3967 method, similar to C<use Foo::Bar VERSION LIST>. They must be
3968 terminated with a final NULL pointer. Note that this list can only
3969 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
3970 Otherwise at least a single NULL pointer to designate the default
3971 import list is required.
3976 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3980 PERL_ARGS_ASSERT_LOAD_MODULE;
3982 va_start(args, ver);
3983 vload_module(flags, name, ver, &args);
3987 #ifdef PERL_IMPLICIT_CONTEXT
3989 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3993 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3994 va_start(args, ver);
3995 vload_module(flags, name, ver, &args);
4001 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4005 OP * const modname = newSVOP(OP_CONST, 0, name);
4007 PERL_ARGS_ASSERT_VLOAD_MODULE;
4009 modname->op_private |= OPpCONST_BARE;
4011 veop = newSVOP(OP_CONST, 0, ver);
4015 if (flags & PERL_LOADMOD_NOIMPORT) {
4016 imop = sawparens(newNULLLIST());
4018 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4019 imop = va_arg(*args, OP*);
4024 sv = va_arg(*args, SV*);
4026 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4027 sv = va_arg(*args, SV*);
4031 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4032 * that it has a PL_parser to play with while doing that, and also
4033 * that it doesn't mess with any existing parser, by creating a tmp
4034 * new parser with lex_start(). This won't actually be used for much,
4035 * since pp_require() will create another parser for the real work. */
4038 SAVEVPTR(PL_curcop);
4039 lex_start(NULL, NULL, FALSE);
4040 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4041 veop, modname, imop);
4046 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4052 PERL_ARGS_ASSERT_DOFILE;
4054 if (!force_builtin) {
4055 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4056 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4057 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4058 gv = gvp ? *gvp : NULL;
4062 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4063 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4064 append_elem(OP_LIST, term,
4065 scalar(newUNOP(OP_RV2CV, 0,
4066 newGVOP(OP_GV, 0, gv))))));
4069 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4075 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4077 return newBINOP(OP_LSLICE, flags,
4078 list(force_list(subscript)),
4079 list(force_list(listval)) );
4083 S_is_list_assignment(pTHX_ register const OP *o)
4091 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4092 o = cUNOPo->op_first;
4094 flags = o->op_flags;
4096 if (type == OP_COND_EXPR) {
4097 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4098 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4103 yyerror("Assignment to both a list and a scalar");
4107 if (type == OP_LIST &&
4108 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4109 o->op_private & OPpLVAL_INTRO)
4112 if (type == OP_LIST || flags & OPf_PARENS ||
4113 type == OP_RV2AV || type == OP_RV2HV ||
4114 type == OP_ASLICE || type == OP_HSLICE)
4117 if (type == OP_PADAV || type == OP_PADHV)
4120 if (type == OP_RV2SV)
4127 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4133 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4134 return newLOGOP(optype, 0,
4135 mod(scalar(left), optype),
4136 newUNOP(OP_SASSIGN, 0, scalar(right)));
4139 return newBINOP(optype, OPf_STACKED,
4140 mod(scalar(left), optype), scalar(right));
4144 if (is_list_assignment(left)) {
4145 static const char no_list_state[] = "Initialization of state variables"
4146 " in list context currently forbidden";
4148 bool maybe_common_vars = TRUE;
4151 /* Grandfathering $[ assignment here. Bletch.*/
4152 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4153 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4154 left = mod(left, OP_AASSIGN);
4157 else if (left->op_type == OP_CONST) {
4159 /* Result of assignment is always 1 (or we'd be dead already) */
4160 return newSVOP(OP_CONST, 0, newSViv(1));
4162 curop = list(force_list(left));
4163 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4164 o->op_private = (U8)(0 | (flags >> 8));
4166 if ((left->op_type == OP_LIST
4167 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4169 OP* lop = ((LISTOP*)left)->op_first;
4170 maybe_common_vars = FALSE;
4172 if (lop->op_type == OP_PADSV ||
4173 lop->op_type == OP_PADAV ||
4174 lop->op_type == OP_PADHV ||
4175 lop->op_type == OP_PADANY) {
4176 if (!(lop->op_private & OPpLVAL_INTRO))
4177 maybe_common_vars = TRUE;
4179 if (lop->op_private & OPpPAD_STATE) {
4180 if (left->op_private & OPpLVAL_INTRO) {
4181 /* Each variable in state($a, $b, $c) = ... */
4184 /* Each state variable in
4185 (state $a, my $b, our $c, $d, undef) = ... */
4187 yyerror(no_list_state);
4189 /* Each my variable in
4190 (state $a, my $b, our $c, $d, undef) = ... */
4192 } else if (lop->op_type == OP_UNDEF ||
4193 lop->op_type == OP_PUSHMARK) {
4194 /* undef may be interesting in
4195 (state $a, undef, state $c) */
4197 /* Other ops in the list. */
4198 maybe_common_vars = TRUE;
4200 lop = lop->op_sibling;
4203 else if ((left->op_private & OPpLVAL_INTRO)
4204 && ( left->op_type == OP_PADSV
4205 || left->op_type == OP_PADAV
4206 || left->op_type == OP_PADHV
4207 || left->op_type == OP_PADANY))
4209 maybe_common_vars = FALSE;
4210 if (left->op_private & OPpPAD_STATE) {
4211 /* All single variable list context state assignments, hence
4221 yyerror(no_list_state);
4225 /* PL_generation sorcery:
4226 * an assignment like ($a,$b) = ($c,$d) is easier than
4227 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4228 * To detect whether there are common vars, the global var
4229 * PL_generation is incremented for each assign op we compile.
4230 * Then, while compiling the assign op, we run through all the
4231 * variables on both sides of the assignment, setting a spare slot
4232 * in each of them to PL_generation. If any of them already have
4233 * that value, we know we've got commonality. We could use a
4234 * single bit marker, but then we'd have to make 2 passes, first
4235 * to clear the flag, then to test and set it. To find somewhere
4236 * to store these values, evil chicanery is done with SvUVX().
4239 if (maybe_common_vars) {
4242 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4243 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4244 if (curop->op_type == OP_GV) {
4245 GV *gv = cGVOPx_gv(curop);
4247 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4249 GvASSIGN_GENERATION_set(gv, PL_generation);
4251 else if (curop->op_type == OP_PADSV ||
4252 curop->op_type == OP_PADAV ||
4253 curop->op_type == OP_PADHV ||
4254 curop->op_type == OP_PADANY)
4256 if (PAD_COMPNAME_GEN(curop->op_targ)
4257 == (STRLEN)PL_generation)
4259 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4262 else if (curop->op_type == OP_RV2CV)
4264 else if (curop->op_type == OP_RV2SV ||
4265 curop->op_type == OP_RV2AV ||
4266 curop->op_type == OP_RV2HV ||
4267 curop->op_type == OP_RV2GV) {
4268 if (lastop->op_type != OP_GV) /* funny deref? */
4271 else if (curop->op_type == OP_PUSHRE) {
4273 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4274 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4276 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4278 GvASSIGN_GENERATION_set(gv, PL_generation);
4282 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4285 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4287 GvASSIGN_GENERATION_set(gv, PL_generation);
4297 o->op_private |= OPpASSIGN_COMMON;
4300 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4301 OP* tmpop = ((LISTOP*)right)->op_first;
4302 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4303 PMOP * const pm = (PMOP*)tmpop;
4304 if (left->op_type == OP_RV2AV &&
4305 !(left->op_private & OPpLVAL_INTRO) &&
4306 !(o->op_private & OPpASSIGN_COMMON) )
4308 tmpop = ((UNOP*)left)->op_first;
4309 if (tmpop->op_type == OP_GV
4311 && !pm->op_pmreplrootu.op_pmtargetoff
4313 && !pm->op_pmreplrootu.op_pmtargetgv
4317 pm->op_pmreplrootu.op_pmtargetoff
4318 = cPADOPx(tmpop)->op_padix;
4319 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4321 pm->op_pmreplrootu.op_pmtargetgv
4322 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4323 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4325 pm->op_pmflags |= PMf_ONCE;
4326 tmpop = cUNOPo->op_first; /* to list (nulled) */
4327 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4328 tmpop->op_sibling = NULL; /* don't free split */
4329 right->op_next = tmpop->op_next; /* fix starting loc */
4330 op_free(o); /* blow off assign */
4331 right->op_flags &= ~OPf_WANT;
4332 /* "I don't know and I don't care." */
4337 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4338 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4340 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4341 if (SvIOK(sv) && SvIVX(sv) == 0)
4342 sv_setiv(sv, PL_modcount+1);
4350 right = newOP(OP_UNDEF, 0);
4351 if (right->op_type == OP_READLINE) {
4352 right->op_flags |= OPf_STACKED;
4353 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4356 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4357 o = newBINOP(OP_SASSIGN, flags,
4358 scalar(right), mod(scalar(left), OP_SASSIGN) );
4362 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4363 deprecate("assignment to $[");
4365 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4366 o->op_private |= OPpCONST_ARYBASE;
4374 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4377 const U32 seq = intro_my();
4380 NewOp(1101, cop, 1, COP);
4381 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4382 cop->op_type = OP_DBSTATE;
4383 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4386 cop->op_type = OP_NEXTSTATE;
4387 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4389 cop->op_flags = (U8)flags;
4390 CopHINTS_set(cop, PL_hints);
4392 cop->op_private |= NATIVE_HINTS;
4394 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4395 cop->op_next = (OP*)cop;
4398 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4399 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4401 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4402 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4403 if (cop->cop_hints_hash) {
4405 cop->cop_hints_hash->refcounted_he_refcnt++;
4406 HINTS_REFCNT_UNLOCK;
4410 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4412 PL_hints |= HINT_BLOCK_SCOPE;
4413 /* It seems that we need to defer freeing this pointer, as other parts
4414 of the grammar end up wanting to copy it after this op has been
4419 if (PL_parser && PL_parser->copline == NOLINE)
4420 CopLINE_set(cop, CopLINE(PL_curcop));
4422 CopLINE_set(cop, PL_parser->copline);
4424 PL_parser->copline = NOLINE;
4427 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4429 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4431 CopSTASH_set(cop, PL_curstash);
4433 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4434 /* this line can have a breakpoint - store the cop in IV */
4435 AV *av = CopFILEAVx(PL_curcop);
4437 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4438 if (svp && *svp != &PL_sv_undef ) {
4439 (void)SvIOK_on(*svp);
4440 SvIV_set(*svp, PTR2IV(cop));
4445 if (flags & OPf_SPECIAL)
4447 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4452 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4456 PERL_ARGS_ASSERT_NEWLOGOP;
4458 return new_logop(type, flags, &first, &other);
4462 S_search_const(pTHX_ OP *o)
4464 PERL_ARGS_ASSERT_SEARCH_CONST;
4466 switch (o->op_type) {
4470 if (o->op_flags & OPf_KIDS)
4471 return search_const(cUNOPo->op_first);
4478 if (!(o->op_flags & OPf_KIDS))
4480 kid = cLISTOPo->op_first;
4482 switch (kid->op_type) {
4486 kid = kid->op_sibling;
4489 if (kid != cLISTOPo->op_last)
4495 kid = cLISTOPo->op_last;
4497 return search_const(kid);
4505 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4513 int prepend_not = 0;
4515 PERL_ARGS_ASSERT_NEW_LOGOP;
4520 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4521 return newBINOP(type, flags, scalar(first), scalar(other));
4523 scalarboolean(first);
4524 /* optimize AND and OR ops that have NOTs as children */
4525 if (first->op_type == OP_NOT
4526 && (first->op_flags & OPf_KIDS)
4527 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4528 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4530 if (type == OP_AND || type == OP_OR) {
4536 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4538 prepend_not = 1; /* prepend a NOT op later */
4542 /* search for a constant op that could let us fold the test */
4543 if ((cstop = search_const(first))) {
4544 if (cstop->op_private & OPpCONST_STRICT)
4545 no_bareword_allowed(cstop);
4546 else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4547 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4548 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4549 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4550 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4552 if (other->op_type == OP_CONST)
4553 other->op_private |= OPpCONST_SHORTCIRCUIT;
4555 OP *newop = newUNOP(OP_NULL, 0, other);
4556 op_getmad(first, newop, '1');
4557 newop->op_targ = type; /* set "was" field */
4561 if (other->op_type == OP_LEAVE)
4562 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4566 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4567 const OP *o2 = other;
4568 if ( ! (o2->op_type == OP_LIST
4569 && (( o2 = cUNOPx(o2)->op_first))
4570 && o2->op_type == OP_PUSHMARK
4571 && (( o2 = o2->op_sibling)) )
4574 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4575 || o2->op_type == OP_PADHV)
4576 && o2->op_private & OPpLVAL_INTRO
4577 && !(o2->op_private & OPpPAD_STATE)
4578 && ckWARN(WARN_DEPRECATED))
4580 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4581 "Deprecated use of my() in false conditional");
4585 if (first->op_type == OP_CONST)
4586 first->op_private |= OPpCONST_SHORTCIRCUIT;
4588 first = newUNOP(OP_NULL, 0, first);
4589 op_getmad(other, first, '2');
4590 first->op_targ = type; /* set "was" field */
4597 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4598 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4600 const OP * const k1 = ((UNOP*)first)->op_first;
4601 const OP * const k2 = k1->op_sibling;
4603 switch (first->op_type)
4606 if (k2 && k2->op_type == OP_READLINE
4607 && (k2->op_flags & OPf_STACKED)
4608 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4610 warnop = k2->op_type;
4615 if (k1->op_type == OP_READDIR
4616 || k1->op_type == OP_GLOB
4617 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4618 || k1->op_type == OP_EACH)
4620 warnop = ((k1->op_type == OP_NULL)
4621 ? (OPCODE)k1->op_targ : k1->op_type);
4626 const line_t oldline = CopLINE(PL_curcop);
4627 CopLINE_set(PL_curcop, PL_parser->copline);
4628 Perl_warner(aTHX_ packWARN(WARN_MISC),
4629 "Value of %s%s can be \"0\"; test with defined()",
4631 ((warnop == OP_READLINE || warnop == OP_GLOB)
4632 ? " construct" : "() operator"));
4633 CopLINE_set(PL_curcop, oldline);
4640 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4641 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4643 NewOp(1101, logop, 1, LOGOP);
4645 logop->op_type = (OPCODE)type;
4646 logop->op_ppaddr = PL_ppaddr[type];
4647 logop->op_first = first;
4648 logop->op_flags = (U8)(flags | OPf_KIDS);
4649 logop->op_other = LINKLIST(other);
4650 logop->op_private = (U8)(1 | (flags >> 8));
4652 /* establish postfix order */
4653 logop->op_next = LINKLIST(first);
4654 first->op_next = (OP*)logop;
4655 first->op_sibling = other;
4657 CHECKOP(type,logop);
4659 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4666 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4674 PERL_ARGS_ASSERT_NEWCONDOP;
4677 return newLOGOP(OP_AND, 0, first, trueop);
4679 return newLOGOP(OP_OR, 0, first, falseop);
4681 scalarboolean(first);
4682 if ((cstop = search_const(first))) {
4683 /* Left or right arm of the conditional? */
4684 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4685 OP *live = left ? trueop : falseop;
4686 OP *const dead = left ? falseop : trueop;
4687 if (cstop->op_private & OPpCONST_BARE &&
4688 cstop->op_private & OPpCONST_STRICT) {
4689 no_bareword_allowed(cstop);
4692 /* This is all dead code when PERL_MAD is not defined. */
4693 live = newUNOP(OP_NULL, 0, live);
4694 op_getmad(first, live, 'C');
4695 op_getmad(dead, live, left ? 'e' : 't');
4700 if (live->op_type == OP_LEAVE)
4701 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4704 NewOp(1101, logop, 1, LOGOP);
4705 logop->op_type = OP_COND_EXPR;
4706 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4707 logop->op_first = first;
4708 logop->op_flags = (U8)(flags | OPf_KIDS);
4709 logop->op_private = (U8)(1 | (flags >> 8));
4710 logop->op_other = LINKLIST(trueop);
4711 logop->op_next = LINKLIST(falseop);
4713 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4716 /* establish postfix order */
4717 start = LINKLIST(first);
4718 first->op_next = (OP*)logop;
4720 first->op_sibling = trueop;
4721 trueop->op_sibling = falseop;
4722 o = newUNOP(OP_NULL, 0, (OP*)logop);
4724 trueop->op_next = falseop->op_next = o;
4731 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4740 PERL_ARGS_ASSERT_NEWRANGE;
4742 NewOp(1101, range, 1, LOGOP);
4744 range->op_type = OP_RANGE;
4745 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4746 range->op_first = left;
4747 range->op_flags = OPf_KIDS;
4748 leftstart = LINKLIST(left);
4749 range->op_other = LINKLIST(right);
4750 range->op_private = (U8)(1 | (flags >> 8));
4752 left->op_sibling = right;
4754 range->op_next = (OP*)range;
4755 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4756 flop = newUNOP(OP_FLOP, 0, flip);
4757 o = newUNOP(OP_NULL, 0, flop);
4759 range->op_next = leftstart;
4761 left->op_next = flip;
4762 right->op_next = flop;
4764 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4765 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4766 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4767 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4769 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4770 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4773 if (!flip->op_private || !flop->op_private)
4774 linklist(o); /* blow off optimizer unless constant */
4780 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4785 const bool once = block && block->op_flags & OPf_SPECIAL &&
4786 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4788 PERL_UNUSED_ARG(debuggable);
4791 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4792 return block; /* do {} while 0 does once */
4793 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4794 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4795 expr = newUNOP(OP_DEFINED, 0,
4796 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4797 } else if (expr->op_flags & OPf_KIDS) {
4798 const OP * const k1 = ((UNOP*)expr)->op_first;
4799 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4800 switch (expr->op_type) {
4802 if (k2 && k2->op_type == OP_READLINE
4803 && (k2->op_flags & OPf_STACKED)
4804 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4805 expr = newUNOP(OP_DEFINED, 0, expr);
4809 if (k1 && (k1->op_type == OP_READDIR
4810 || k1->op_type == OP_GLOB
4811 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4812 || k1->op_type == OP_EACH))
4813 expr = newUNOP(OP_DEFINED, 0, expr);
4819 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4820 * op, in listop. This is wrong. [perl #27024] */
4822 block = newOP(OP_NULL, 0);
4823 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4824 o = new_logop(OP_AND, 0, &expr, &listop);
4827 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4829 if (once && o != listop)
4830 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4833 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4835 o->op_flags |= flags;
4837 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4842 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4843 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4852 PERL_UNUSED_ARG(debuggable);
4855 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4856 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4857 expr = newUNOP(OP_DEFINED, 0,
4858 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4859 } else if (expr->op_flags & OPf_KIDS) {
4860 const OP * const k1 = ((UNOP*)expr)->op_first;
4861 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4862 switch (expr->op_type) {
4864 if (k2 && k2->op_type == OP_READLINE
4865 && (k2->op_flags & OPf_STACKED)
4866 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4867 expr = newUNOP(OP_DEFINED, 0, expr);
4871 if (k1 && (k1->op_type == OP_READDIR
4872 || k1->op_type == OP_GLOB
4873 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4874 || k1->op_type == OP_EACH))
4875 expr = newUNOP(OP_DEFINED, 0, expr);
4882 block = newOP(OP_NULL, 0);
4883 else if (cont || has_my) {
4884 block = scope(block);
4888 next = LINKLIST(cont);
4891 OP * const unstack = newOP(OP_UNSTACK, 0);
4894 cont = append_elem(OP_LINESEQ, cont, unstack);
4898 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4900 redo = LINKLIST(listop);
4903 PL_parser->copline = (line_t)whileline;
4905 o = new_logop(OP_AND, 0, &expr, &listop);
4906 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4907 op_free(expr); /* oops, it's a while (0) */
4909 return NULL; /* listop already freed by new_logop */
4912 ((LISTOP*)listop)->op_last->op_next =
4913 (o == listop ? redo : LINKLIST(o));
4919 NewOp(1101,loop,1,LOOP);
4920 loop->op_type = OP_ENTERLOOP;
4921 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4922 loop->op_private = 0;
4923 loop->op_next = (OP*)loop;
4926 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4928 loop->op_redoop = redo;
4929 loop->op_lastop = o;
4930 o->op_private |= loopflags;
4933 loop->op_nextop = next;
4935 loop->op_nextop = o;
4937 o->op_flags |= flags;
4938 o->op_private |= (flags >> 8);
4943 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4948 PADOFFSET padoff = 0;
4953 PERL_ARGS_ASSERT_NEWFOROP;
4956 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4957 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4958 sv->op_type = OP_RV2GV;
4959 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4961 /* The op_type check is needed to prevent a possible segfault
4962 * if the loop variable is undeclared and 'strict vars' is in
4963 * effect. This is illegal but is nonetheless parsed, so we
4964 * may reach this point with an OP_CONST where we're expecting
4967 if (cUNOPx(sv)->op_first->op_type == OP_GV
4968 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4969 iterpflags |= OPpITER_DEF;
4971 else if (sv->op_type == OP_PADSV) { /* private variable */
4972 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4973 padoff = sv->op_targ;
4983 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4985 SV *const namesv = PAD_COMPNAME_SV(padoff);
4987 const char *const name = SvPV_const(namesv, len);
4989 if (len == 2 && name[0] == '$' && name[1] == '_')
4990 iterpflags |= OPpITER_DEF;
4994 const PADOFFSET offset = pad_findmy("$_");
4995 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4996 sv = newGVOP(OP_GV, 0, PL_defgv);
5001 iterpflags |= OPpITER_DEF;
5003 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5004 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5005 iterflags |= OPf_STACKED;
5007 else if (expr->op_type == OP_NULL &&
5008 (expr->op_flags & OPf_KIDS) &&
5009 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5011 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5012 * set the STACKED flag to indicate that these values are to be
5013 * treated as min/max values by 'pp_iterinit'.
5015 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5016 LOGOP* const range = (LOGOP*) flip->op_first;
5017 OP* const left = range->op_first;
5018 OP* const right = left->op_sibling;
5021 range->op_flags &= ~OPf_KIDS;
5022 range->op_first = NULL;
5024 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5025 listop->op_first->op_next = range->op_next;
5026 left->op_next = range->op_other;
5027 right->op_next = (OP*)listop;
5028 listop->op_next = listop->op_first;
5031 op_getmad(expr,(OP*)listop,'O');
5035 expr = (OP*)(listop);
5037 iterflags |= OPf_STACKED;
5040 expr = mod(force_list(expr), OP_GREPSTART);
5043 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5044 append_elem(OP_LIST, expr, scalar(sv))));
5045 assert(!loop->op_next);
5046 /* for my $x () sets OPpLVAL_INTRO;
5047 * for our $x () sets OPpOUR_INTRO */
5048 loop->op_private = (U8)iterpflags;
5049 #ifdef PL_OP_SLAB_ALLOC
5052 NewOp(1234,tmp,1,LOOP);
5053 Copy(loop,tmp,1,LISTOP);
5054 S_op_destroy(aTHX_ (OP*)loop);
5058 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5060 loop->op_targ = padoff;
5061 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5063 op_getmad(madsv, (OP*)loop, 'v');
5064 PL_parser->copline = forline;
5065 return newSTATEOP(0, label, wop);
5069 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5074 PERL_ARGS_ASSERT_NEWLOOPEX;
5076 if (type != OP_GOTO || label->op_type == OP_CONST) {
5077 /* "last()" means "last" */
5078 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5079 o = newOP(type, OPf_SPECIAL);
5081 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5082 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5086 op_getmad(label,o,'L');
5092 /* Check whether it's going to be a goto &function */
5093 if (label->op_type == OP_ENTERSUB
5094 && !(label->op_flags & OPf_STACKED))
5095 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5096 o = newUNOP(type, OPf_STACKED, label);
5098 PL_hints |= HINT_BLOCK_SCOPE;
5102 /* if the condition is a literal array or hash
5103 (or @{ ... } etc), make a reference to it.
5106 S_ref_array_or_hash(pTHX_ OP *cond)
5109 && (cond->op_type == OP_RV2AV
5110 || cond->op_type == OP_PADAV
5111 || cond->op_type == OP_RV2HV
5112 || cond->op_type == OP_PADHV))
5114 return newUNOP(OP_REFGEN,
5115 0, mod(cond, OP_REFGEN));
5121 /* These construct the optree fragments representing given()
5124 entergiven and enterwhen are LOGOPs; the op_other pointer
5125 points up to the associated leave op. We need this so we
5126 can put it in the context and make break/continue work.
5127 (Also, of course, pp_enterwhen will jump straight to
5128 op_other if the match fails.)
5132 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5133 I32 enter_opcode, I32 leave_opcode,
5134 PADOFFSET entertarg)
5140 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5142 NewOp(1101, enterop, 1, LOGOP);
5143 enterop->op_type = (Optype)enter_opcode;
5144 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5145 enterop->op_flags = (U8) OPf_KIDS;
5146 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5147 enterop->op_private = 0;
5149 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5152 enterop->op_first = scalar(cond);
5153 cond->op_sibling = block;
5155 o->op_next = LINKLIST(cond);
5156 cond->op_next = (OP *) enterop;
5159 /* This is a default {} block */
5160 enterop->op_first = block;
5161 enterop->op_flags |= OPf_SPECIAL;
5163 o->op_next = (OP *) enterop;
5166 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5167 entergiven and enterwhen both
5170 enterop->op_next = LINKLIST(block);
5171 block->op_next = enterop->op_other = o;
5176 /* Does this look like a boolean operation? For these purposes
5177 a boolean operation is:
5178 - a subroutine call [*]
5179 - a logical connective
5180 - a comparison operator
5181 - a filetest operator, with the exception of -s -M -A -C
5182 - defined(), exists() or eof()
5183 - /$re/ or $foo =~ /$re/
5185 [*] possibly surprising
5188 S_looks_like_bool(pTHX_ const OP *o)
5192 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5194 switch(o->op_type) {
5197 return looks_like_bool(cLOGOPo->op_first);
5201 looks_like_bool(cLOGOPo->op_first)
5202 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5206 o->op_flags & OPf_KIDS
5207 && looks_like_bool(cUNOPo->op_first));
5210 return looks_like_bool(cUNOPo->op_first);
5215 case OP_NOT: case OP_XOR:
5217 case OP_EQ: case OP_NE: case OP_LT:
5218 case OP_GT: case OP_LE: case OP_GE:
5220 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5221 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5223 case OP_SEQ: case OP_SNE: case OP_SLT:
5224 case OP_SGT: case OP_SLE: case OP_SGE:
5228 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5229 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5230 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5231 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5232 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5233 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5234 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5235 case OP_FTTEXT: case OP_FTBINARY:
5237 case OP_DEFINED: case OP_EXISTS:
5238 case OP_MATCH: case OP_EOF:
5245 /* Detect comparisons that have been optimized away */
5246 if (cSVOPo->op_sv == &PL_sv_yes
5247 || cSVOPo->op_sv == &PL_sv_no)
5260 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5263 PERL_ARGS_ASSERT_NEWGIVENOP;
5264 return newGIVWHENOP(
5265 ref_array_or_hash(cond),
5267 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5271 /* If cond is null, this is a default {} block */
5273 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5275 const bool cond_llb = (!cond || looks_like_bool(cond));
5278 PERL_ARGS_ASSERT_NEWWHENOP;
5283 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5285 scalar(ref_array_or_hash(cond)));
5288 return newGIVWHENOP(
5290 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5291 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5295 =for apidoc cv_undef
5297 Clear out all the active components of a CV. This can happen either
5298 by an explicit C<undef &foo>, or by the reference count going to zero.
5299 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5300 children can still follow the full lexical scope chain.
5306 Perl_cv_undef(pTHX_ CV *cv)
5310 PERL_ARGS_ASSERT_CV_UNDEF;
5312 DEBUG_X(PerlIO_printf(Perl_debug_log,
5313 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5314 PTR2UV(cv), PTR2UV(PL_comppad))
5318 if (CvFILE(cv) && !CvISXSUB(cv)) {
5319 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5320 Safefree(CvFILE(cv));
5325 if (!CvISXSUB(cv) && CvROOT(cv)) {
5326 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5327 Perl_croak(aTHX_ "Can't undef active subroutine");
5330 PAD_SAVE_SETNULLPAD();
5332 op_free(CvROOT(cv));
5337 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5342 /* remove CvOUTSIDE unless this is an undef rather than a free */
5343 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5344 if (!CvWEAKOUTSIDE(cv))
5345 SvREFCNT_dec(CvOUTSIDE(cv));
5346 CvOUTSIDE(cv) = NULL;
5349 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5352 if (CvISXSUB(cv) && CvXSUB(cv)) {
5355 /* delete all flags except WEAKOUTSIDE */
5356 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5360 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5363 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5365 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5366 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5367 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5368 || (p && (len != SvCUR(cv) /* Not the same length. */
5369 || memNE(p, SvPVX_const(cv), len))))
5370 && ckWARN_d(WARN_PROTOTYPE)) {
5371 SV* const msg = sv_newmortal();
5375 gv_efullname3(name = sv_newmortal(), gv, NULL);
5376 sv_setpvs(msg, "Prototype mismatch:");
5378 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5380 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5382 sv_catpvs(msg, ": none");
5383 sv_catpvs(msg, " vs ");
5385 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5387 sv_catpvs(msg, "none");
5388 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5392 static void const_sv_xsub(pTHX_ CV* cv);
5396 =head1 Optree Manipulation Functions
5398 =for apidoc cv_const_sv
5400 If C<cv> is a constant sub eligible for inlining. returns the constant
5401 value returned by the sub. Otherwise, returns NULL.
5403 Constant subs can be created with C<newCONSTSUB> or as described in
5404 L<perlsub/"Constant Functions">.
5409 Perl_cv_const_sv(pTHX_ const CV *const cv)
5411 PERL_UNUSED_CONTEXT;
5414 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5416 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5419 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5420 * Can be called in 3 ways:
5423 * look for a single OP_CONST with attached value: return the value
5425 * cv && CvCLONE(cv) && !CvCONST(cv)
5427 * examine the clone prototype, and if contains only a single
5428 * OP_CONST referencing a pad const, or a single PADSV referencing
5429 * an outer lexical, return a non-zero value to indicate the CV is
5430 * a candidate for "constizing" at clone time
5434 * We have just cloned an anon prototype that was marked as a const
5435 * candidiate. Try to grab the current value, and in the case of
5436 * PADSV, ignore it if it has multiple references. Return the value.
5440 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5451 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5452 o = cLISTOPo->op_first->op_sibling;
5454 for (; o; o = o->op_next) {
5455 const OPCODE type = o->op_type;
5457 if (sv && o->op_next == o)
5459 if (o->op_next != o) {
5460 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5462 if (type == OP_DBSTATE)
5465 if (type == OP_LEAVESUB || type == OP_RETURN)
5469 if (type == OP_CONST && cSVOPo->op_sv)
5471 else if (cv && type == OP_CONST) {
5472 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5476 else if (cv && type == OP_PADSV) {
5477 if (CvCONST(cv)) { /* newly cloned anon */
5478 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5479 /* the candidate should have 1 ref from this pad and 1 ref
5480 * from the parent */
5481 if (!sv || SvREFCNT(sv) != 2)
5488 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5489 sv = &PL_sv_undef; /* an arbitrary non-null value */
5504 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5507 /* This would be the return value, but the return cannot be reached. */
5508 OP* pegop = newOP(OP_NULL, 0);
5511 PERL_UNUSED_ARG(floor);
5521 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5523 NORETURN_FUNCTION_END;
5528 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5530 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5534 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5540 register CV *cv = NULL;
5542 /* If the subroutine has no body, no attributes, and no builtin attributes
5543 then it's just a sub declaration, and we may be able to get away with
5544 storing with a placeholder scalar in the symbol table, rather than a
5545 full GV and CV. If anything is present then it will take a full CV to
5547 const I32 gv_fetch_flags
5548 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5550 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5551 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5555 assert(proto->op_type == OP_CONST);
5556 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5562 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5564 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5565 SV * const sv = sv_newmortal();
5566 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5567 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5568 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5569 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5571 } else if (PL_curstash) {
5572 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5575 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5579 if (!PL_madskills) {
5588 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5589 maximum a prototype before. */
5590 if (SvTYPE(gv) > SVt_NULL) {
5591 if (!SvPOK((const SV *)gv)
5592 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
5593 && ckWARN_d(WARN_PROTOTYPE))
5595 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5597 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5600 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5602 sv_setiv(MUTABLE_SV(gv), -1);
5604 SvREFCNT_dec(PL_compcv);
5605 cv = PL_compcv = NULL;
5609 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5611 if (!block || !ps || *ps || attrs
5612 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5614 || block->op_type == OP_NULL
5619 const_sv = op_const_sv(block, NULL);
5622 const bool exists = CvROOT(cv) || CvXSUB(cv);
5624 /* if the subroutine doesn't exist and wasn't pre-declared
5625 * with a prototype, assume it will be AUTOLOADed,
5626 * skipping the prototype check
5628 if (exists || SvPOK(cv))
5629 cv_ckproto_len(cv, gv, ps, ps_len);
5630 /* already defined (or promised)? */
5631 if (exists || GvASSUMECV(gv)) {
5634 || block->op_type == OP_NULL
5637 if (CvFLAGS(PL_compcv)) {
5638 /* might have had built-in attrs applied */
5639 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5641 /* just a "sub foo;" when &foo is already defined */
5642 SAVEFREESV(PL_compcv);
5647 && block->op_type != OP_NULL
5650 if (ckWARN(WARN_REDEFINE)
5652 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5654 const line_t oldline = CopLINE(PL_curcop);
5655 if (PL_parser && PL_parser->copline != NOLINE)
5656 CopLINE_set(PL_curcop, PL_parser->copline);
5657 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5658 CvCONST(cv) ? "Constant subroutine %s redefined"
5659 : "Subroutine %s redefined", name);
5660 CopLINE_set(PL_curcop, oldline);
5663 if (!PL_minus_c) /* keep old one around for madskills */
5666 /* (PL_madskills unset in used file.) */
5674 SvREFCNT_inc_simple_void_NN(const_sv);
5676 assert(!CvROOT(cv) && !CvCONST(cv));
5677 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5678 CvXSUBANY(cv).any_ptr = const_sv;
5679 CvXSUB(cv) = const_sv_xsub;
5685 cv = newCONSTSUB(NULL, name, const_sv);
5687 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5688 (CvGV(cv) && GvSTASH(CvGV(cv)))
5697 SvREFCNT_dec(PL_compcv);
5701 if (cv) { /* must reuse cv if autoloaded */
5702 /* transfer PL_compcv to cv */
5705 && block->op_type != OP_NULL
5709 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5710 if (!CvWEAKOUTSIDE(cv))
5711 SvREFCNT_dec(CvOUTSIDE(cv));
5712 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5713 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5714 CvOUTSIDE(PL_compcv) = 0;
5715 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5716 CvPADLIST(PL_compcv) = 0;
5717 /* inner references to PL_compcv must be fixed up ... */
5718 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5719 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5720 ++PL_sub_generation;
5723 /* Might have had built-in attributes applied -- propagate them. */
5724 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5726 /* ... before we throw it away */
5727 SvREFCNT_dec(PL_compcv);
5735 if (strEQ(name, "import")) {
5736 PL_formfeed = MUTABLE_SV(cv);
5737 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5741 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5746 CvFILE_set_from_cop(cv, PL_curcop);
5747 CvSTASH(cv) = PL_curstash;
5750 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5751 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5752 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5756 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5758 if (PL_parser && PL_parser->error_count) {
5762 const char *s = strrchr(name, ':');
5764 if (strEQ(s, "BEGIN")) {
5765 const char not_safe[] =
5766 "BEGIN not safe after errors--compilation aborted";
5767 if (PL_in_eval & EVAL_KEEPERR)
5768 Perl_croak(aTHX_ not_safe);
5770 /* force display of errors found but not reported */
5771 sv_catpv(ERRSV, not_safe);
5772 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5781 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5782 the debugger could be able to set a breakpoint in, so signal to
5783 pp_entereval that it should not throw away any saved lines at scope
5786 PL_breakable_sub_gen++;
5788 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5789 mod(scalarseq(block), OP_LEAVESUBLV));
5790 block->op_attached = 1;
5793 /* This makes sub {}; work as expected. */
5794 if (block->op_type == OP_STUB) {
5795 OP* const newblock = newSTATEOP(0, NULL, 0);
5797 op_getmad(block,newblock,'B');
5804 block->op_attached = 1;
5805 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5807 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5808 OpREFCNT_set(CvROOT(cv), 1);
5809 CvSTART(cv) = LINKLIST(CvROOT(cv));
5810 CvROOT(cv)->op_next = 0;
5811 CALL_PEEP(CvSTART(cv));
5813 /* now that optimizer has done its work, adjust pad values */
5815 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5818 assert(!CvCONST(cv));
5819 if (ps && !*ps && op_const_sv(block, cv))
5824 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5825 SV * const sv = newSV(0);
5826 SV * const tmpstr = sv_newmortal();
5827 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5828 GV_ADDMULTI, SVt_PVHV);
5831 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5833 (long)PL_subline, (long)CopLINE(PL_curcop));
5834 gv_efullname3(tmpstr, gv, NULL);
5835 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5836 SvCUR(tmpstr), sv, 0);
5837 hv = GvHVn(db_postponed);
5838 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5839 CV * const pcv = GvCV(db_postponed);
5845 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5850 if (name && ! (PL_parser && PL_parser->error_count))
5851 process_special_blocks(name, gv, cv);
5856 PL_parser->copline = NOLINE;
5862 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5865 const char *const colon = strrchr(fullname,':');
5866 const char *const name = colon ? colon + 1 : fullname;
5868 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5871 if (strEQ(name, "BEGIN")) {
5872 const I32 oldscope = PL_scopestack_ix;
5874 SAVECOPFILE(&PL_compiling);
5875 SAVECOPLINE(&PL_compiling);
5877 DEBUG_x( dump_sub(gv) );
5878 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5879 GvCV(gv) = 0; /* cv has been hijacked */
5880 call_list(oldscope, PL_beginav);
5882 PL_curcop = &PL_compiling;
5883 CopHINTS_set(&PL_compiling, PL_hints);
5890 if strEQ(name, "END") {
5891 DEBUG_x( dump_sub(gv) );
5892 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5895 } else if (*name == 'U') {
5896 if (strEQ(name, "UNITCHECK")) {
5897 /* It's never too late to run a unitcheck block */
5898 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5902 } else if (*name == 'C') {
5903 if (strEQ(name, "CHECK")) {
5904 if (PL_main_start && ckWARN(WARN_VOID))
5905 Perl_warner(aTHX_ packWARN(WARN_VOID),
5906 "Too late to run CHECK block");
5907 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5911 } else if (*name == 'I') {
5912 if (strEQ(name, "INIT")) {
5913 if (PL_main_start && ckWARN(WARN_VOID))
5914 Perl_warner(aTHX_ packWARN(WARN_VOID),
5915 "Too late to run INIT block");
5916 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5922 DEBUG_x( dump_sub(gv) );
5923 GvCV(gv) = 0; /* cv has been hijacked */
5928 =for apidoc newCONSTSUB
5930 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5931 eligible for inlining at compile-time.
5933 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5934 which won't be called if used as a destructor, but will suppress the overhead
5935 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5942 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5947 const char *const file = CopFILE(PL_curcop);
5949 SV *const temp_sv = CopFILESV(PL_curcop);
5950 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5955 if (IN_PERL_RUNTIME) {
5956 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5957 * an op shared between threads. Use a non-shared COP for our
5959 SAVEVPTR(PL_curcop);
5960 PL_curcop = &PL_compiling;
5962 SAVECOPLINE(PL_curcop);
5963 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5966 PL_hints &= ~HINT_BLOCK_SCOPE;
5969 SAVESPTR(PL_curstash);
5970 SAVECOPSTASH(PL_curcop);
5971 PL_curstash = stash;
5972 CopSTASH_set(PL_curcop,stash);
5975 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5976 and so doesn't get free()d. (It's expected to be from the C pre-
5977 processor __FILE__ directive). But we need a dynamically allocated one,
5978 and we need it to get freed. */
5979 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
5980 XS_DYNAMIC_FILENAME);
5981 CvXSUBANY(cv).any_ptr = sv;
5986 CopSTASH_free(PL_curcop);
5994 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5995 const char *const filename, const char *const proto,
5998 CV *cv = newXS(name, subaddr, filename);
6000 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6002 if (flags & XS_DYNAMIC_FILENAME) {
6003 /* We need to "make arrangements" (ie cheat) to ensure that the
6004 filename lasts as long as the PVCV we just created, but also doesn't
6006 STRLEN filename_len = strlen(filename);
6007 STRLEN proto_and_file_len = filename_len;
6008 char *proto_and_file;
6012 proto_len = strlen(proto);
6013 proto_and_file_len += proto_len;
6015 Newx(proto_and_file, proto_and_file_len + 1, char);
6016 Copy(proto, proto_and_file, proto_len, char);
6017 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6020 proto_and_file = savepvn(filename, filename_len);
6023 /* This gets free()d. :-) */
6024 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6025 SV_HAS_TRAILING_NUL);
6027 /* This gives us the correct prototype, rather than one with the
6028 file name appended. */
6029 SvCUR_set(cv, proto_len);
6033 CvFILE(cv) = proto_and_file + proto_len;
6035 sv_setpv(MUTABLE_SV(cv), proto);
6041 =for apidoc U||newXS
6043 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6044 static storage, as it is used directly as CvFILE(), without a copy being made.
6050 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6053 GV * const gv = gv_fetchpv(name ? name :
6054 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6055 GV_ADDMULTI, SVt_PVCV);
6058 PERL_ARGS_ASSERT_NEWXS;
6061 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6063 if ((cv = (name ? GvCV(gv) : NULL))) {
6065 /* just a cached method */
6069 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6070 /* already defined (or promised) */
6071 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6072 if (ckWARN(WARN_REDEFINE)) {
6073 GV * const gvcv = CvGV(cv);
6075 HV * const stash = GvSTASH(gvcv);
6077 const char *redefined_name = HvNAME_get(stash);
6078 if ( strEQ(redefined_name,"autouse") ) {
6079 const line_t oldline = CopLINE(PL_curcop);
6080 if (PL_parser && PL_parser->copline != NOLINE)
6081 CopLINE_set(PL_curcop, PL_parser->copline);
6082 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6083 CvCONST(cv) ? "Constant subroutine %s redefined"
6084 : "Subroutine %s redefined"
6086 CopLINE_set(PL_curcop, oldline);
6096 if (cv) /* must reuse cv if autoloaded */
6099 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6103 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6107 (void)gv_fetchfile(filename);
6108 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6109 an external constant string */
6111 CvXSUB(cv) = subaddr;
6114 process_special_blocks(name, gv, cv);
6126 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6131 OP* pegop = newOP(OP_NULL, 0);
6135 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6136 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6139 if ((cv = GvFORM(gv))) {
6140 if (ckWARN(WARN_REDEFINE)) {
6141 const line_t oldline = CopLINE(PL_curcop);
6142 if (PL_parser && PL_parser->copline != NOLINE)
6143 CopLINE_set(PL_curcop, PL_parser->copline);
6145 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6146 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6148 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6149 "Format STDOUT redefined");
6151 CopLINE_set(PL_curcop, oldline);
6158 CvFILE_set_from_cop(cv, PL_curcop);
6161 pad_tidy(padtidy_FORMAT);
6162 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6163 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6164 OpREFCNT_set(CvROOT(cv), 1);
6165 CvSTART(cv) = LINKLIST(CvROOT(cv));
6166 CvROOT(cv)->op_next = 0;
6167 CALL_PEEP(CvSTART(cv));
6169 op_getmad(o,pegop,'n');
6170 op_getmad_weak(block, pegop, 'b');
6175 PL_parser->copline = NOLINE;
6183 Perl_newANONLIST(pTHX_ OP *o)
6185 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6189 Perl_newANONHASH(pTHX_ OP *o)
6191 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6195 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6197 return newANONATTRSUB(floor, proto, NULL, block);
6201 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6203 return newUNOP(OP_REFGEN, 0,
6204 newSVOP(OP_ANONCODE, 0,
6205 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6209 Perl_oopsAV(pTHX_ OP *o)
6213 PERL_ARGS_ASSERT_OOPSAV;
6215 switch (o->op_type) {
6217 o->op_type = OP_PADAV;
6218 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6219 return ref(o, OP_RV2AV);
6222 o->op_type = OP_RV2AV;
6223 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6228 if (ckWARN_d(WARN_INTERNAL))
6229 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6236 Perl_oopsHV(pTHX_ OP *o)
6240 PERL_ARGS_ASSERT_OOPSHV;
6242 switch (o->op_type) {
6245 o->op_type = OP_PADHV;
6246 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6247 return ref(o, OP_RV2HV);
6251 o->op_type = OP_RV2HV;
6252 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6257 if (ckWARN_d(WARN_INTERNAL))
6258 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6265 Perl_newAVREF(pTHX_ OP *o)
6269 PERL_ARGS_ASSERT_NEWAVREF;
6271 if (o->op_type == OP_PADANY) {
6272 o->op_type = OP_PADAV;
6273 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6276 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6277 && ckWARN(WARN_DEPRECATED)) {
6278 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6279 "Using an array as a reference is deprecated");
6281 return newUNOP(OP_RV2AV, 0, scalar(o));
6285 Perl_newGVREF(pTHX_ I32 type, OP *o)
6287 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6288 return newUNOP(OP_NULL, 0, o);
6289 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6293 Perl_newHVREF(pTHX_ OP *o)
6297 PERL_ARGS_ASSERT_NEWHVREF;
6299 if (o->op_type == OP_PADANY) {
6300 o->op_type = OP_PADHV;
6301 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6304 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6305 && ckWARN(WARN_DEPRECATED)) {
6306 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6307 "Using a hash as a reference is deprecated");
6309 return newUNOP(OP_RV2HV, 0, scalar(o));
6313 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6315 return newUNOP(OP_RV2CV, flags, scalar(o));
6319 Perl_newSVREF(pTHX_ OP *o)
6323 PERL_ARGS_ASSERT_NEWSVREF;
6325 if (o->op_type == OP_PADANY) {
6326 o->op_type = OP_PADSV;
6327 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6330 return newUNOP(OP_RV2SV, 0, scalar(o));
6333 /* Check routines. See the comments at the top of this file for details
6334 * on when these are called */
6337 Perl_ck_anoncode(pTHX_ OP *o)
6339 PERL_ARGS_ASSERT_CK_ANONCODE;
6341 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6343 cSVOPo->op_sv = NULL;
6348 Perl_ck_bitop(pTHX_ OP *o)
6352 PERL_ARGS_ASSERT_CK_BITOP;
6354 #define OP_IS_NUMCOMPARE(op) \
6355 ((op) == OP_LT || (op) == OP_I_LT || \
6356 (op) == OP_GT || (op) == OP_I_GT || \
6357 (op) == OP_LE || (op) == OP_I_LE || \
6358 (op) == OP_GE || (op) == OP_I_GE || \
6359 (op) == OP_EQ || (op) == OP_I_EQ || \
6360 (op) == OP_NE || (op) == OP_I_NE || \
6361 (op) == OP_NCMP || (op) == OP_I_NCMP)
6362 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6363 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6364 && (o->op_type == OP_BIT_OR
6365 || o->op_type == OP_BIT_AND
6366 || o->op_type == OP_BIT_XOR))
6368 const OP * const left = cBINOPo->op_first;
6369 const OP * const right = left->op_sibling;
6370 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6371 (left->op_flags & OPf_PARENS) == 0) ||
6372 (OP_IS_NUMCOMPARE(right->op_type) &&
6373 (right->op_flags & OPf_PARENS) == 0))
6374 if (ckWARN(WARN_PRECEDENCE))
6375 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6376 "Possible precedence problem on bitwise %c operator",
6377 o->op_type == OP_BIT_OR ? '|'
6378 : o->op_type == OP_BIT_AND ? '&' : '^'
6385 Perl_ck_concat(pTHX_ OP *o)
6387 const OP * const kid = cUNOPo->op_first;
6389 PERL_ARGS_ASSERT_CK_CONCAT;
6390 PERL_UNUSED_CONTEXT;
6392 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6393 !(kUNOP->op_first->op_flags & OPf_MOD))
6394 o->op_flags |= OPf_STACKED;
6399 Perl_ck_spair(pTHX_ OP *o)
6403 PERL_ARGS_ASSERT_CK_SPAIR;
6405 if (o->op_flags & OPf_KIDS) {
6408 const OPCODE type = o->op_type;
6409 o = modkids(ck_fun(o), type);
6410 kid = cUNOPo->op_first;
6411 newop = kUNOP->op_first->op_sibling;
6413 const OPCODE type = newop->op_type;
6414 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6415 type == OP_PADAV || type == OP_PADHV ||
6416 type == OP_RV2AV || type == OP_RV2HV)
6420 op_getmad(kUNOP->op_first,newop,'K');
6422 op_free(kUNOP->op_first);
6424 kUNOP->op_first = newop;
6426 o->op_ppaddr = PL_ppaddr[++o->op_type];
6431 Perl_ck_delete(pTHX_ OP *o)
6433 PERL_ARGS_ASSERT_CK_DELETE;
6437 if (o->op_flags & OPf_KIDS) {
6438 OP * const kid = cUNOPo->op_first;
6439 switch (kid->op_type) {
6441 o->op_flags |= OPf_SPECIAL;
6444 o->op_private |= OPpSLICE;
6447 o->op_flags |= OPf_SPECIAL;
6452 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6455 if (kid->op_private & OPpLVAL_INTRO)
6456 o->op_private |= OPpLVAL_INTRO;
6463 Perl_ck_die(pTHX_ OP *o)
6465 PERL_ARGS_ASSERT_CK_DIE;
6468 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6474 Perl_ck_eof(pTHX_ OP *o)
6478 PERL_ARGS_ASSERT_CK_EOF;
6480 if (o->op_flags & OPf_KIDS) {
6481 if (cLISTOPo->op_first->op_type == OP_STUB) {
6483 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6485 op_getmad(o,newop,'O');
6497 Perl_ck_eval(pTHX_ OP *o)
6501 PERL_ARGS_ASSERT_CK_EVAL;
6503 PL_hints |= HINT_BLOCK_SCOPE;
6504 if (o->op_flags & OPf_KIDS) {
6505 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6508 o->op_flags &= ~OPf_KIDS;
6511 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6517 cUNOPo->op_first = 0;
6522 NewOp(1101, enter, 1, LOGOP);
6523 enter->op_type = OP_ENTERTRY;
6524 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6525 enter->op_private = 0;
6527 /* establish postfix order */
6528 enter->op_next = (OP*)enter;
6530 CHECKOP(OP_ENTERTRY, enter);
6532 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6533 o->op_type = OP_LEAVETRY;
6534 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6535 enter->op_other = o;
6536 op_getmad(oldo,o,'O');
6550 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6551 op_getmad(oldo,o,'O');
6553 o->op_targ = (PADOFFSET)PL_hints;
6554 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6555 /* Store a copy of %^H that pp_entereval can pick up. */
6556 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6557 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6558 cUNOPo->op_first->op_sibling = hhop;
6559 o->op_private |= OPpEVAL_HAS_HH;
6565 Perl_ck_exit(pTHX_ OP *o)
6567 PERL_ARGS_ASSERT_CK_EXIT;
6570 HV * const table = GvHV(PL_hintgv);
6572 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6573 if (svp && *svp && SvTRUE(*svp))
6574 o->op_private |= OPpEXIT_VMSISH;
6576 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6582 Perl_ck_exec(pTHX_ OP *o)
6584 PERL_ARGS_ASSERT_CK_EXEC;
6586 if (o->op_flags & OPf_STACKED) {
6589 kid = cUNOPo->op_first->op_sibling;
6590 if (kid->op_type == OP_RV2GV)
6599 Perl_ck_exists(pTHX_ OP *o)
6603 PERL_ARGS_ASSERT_CK_EXISTS;
6606 if (o->op_flags & OPf_KIDS) {
6607 OP * const kid = cUNOPo->op_first;
6608 if (kid->op_type == OP_ENTERSUB) {
6609 (void) ref(kid, o->op_type);
6610 if (kid->op_type != OP_RV2CV
6611 && !(PL_parser && PL_parser->error_count))
6612 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6614 o->op_private |= OPpEXISTS_SUB;
6616 else if (kid->op_type == OP_AELEM)
6617 o->op_flags |= OPf_SPECIAL;
6618 else if (kid->op_type != OP_HELEM)
6619 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6627 Perl_ck_rvconst(pTHX_ register OP *o)
6630 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6632 PERL_ARGS_ASSERT_CK_RVCONST;
6634 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6635 if (o->op_type == OP_RV2CV)
6636 o->op_private &= ~1;
6638 if (kid->op_type == OP_CONST) {
6641 SV * const kidsv = kid->op_sv;
6643 /* Is it a constant from cv_const_sv()? */
6644 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6645 SV * const rsv = SvRV(kidsv);
6646 const svtype type = SvTYPE(rsv);
6647 const char *badtype = NULL;
6649 switch (o->op_type) {
6651 if (type > SVt_PVMG)
6652 badtype = "a SCALAR";
6655 if (type != SVt_PVAV)
6656 badtype = "an ARRAY";
6659 if (type != SVt_PVHV)
6663 if (type != SVt_PVCV)
6668 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6671 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6672 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6673 /* If this is an access to a stash, disable "strict refs", because
6674 * stashes aren't auto-vivified at compile-time (unless we store
6675 * symbols in them), and we don't want to produce a run-time
6676 * stricture error when auto-vivifying the stash. */
6677 const char *s = SvPV_nolen(kidsv);
6678 const STRLEN l = SvCUR(kidsv);
6679 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6680 o->op_private &= ~HINT_STRICT_REFS;
6682 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6683 const char *badthing;
6684 switch (o->op_type) {
6686 badthing = "a SCALAR";
6689 badthing = "an ARRAY";
6692 badthing = "a HASH";
6700 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6701 SVfARG(kidsv), badthing);
6704 * This is a little tricky. We only want to add the symbol if we
6705 * didn't add it in the lexer. Otherwise we get duplicate strict
6706 * warnings. But if we didn't add it in the lexer, we must at
6707 * least pretend like we wanted to add it even if it existed before,
6708 * or we get possible typo warnings. OPpCONST_ENTERED says
6709 * whether the lexer already added THIS instance of this symbol.
6711 iscv = (o->op_type == OP_RV2CV) * 2;
6713 gv = gv_fetchsv(kidsv,
6714 iscv | !(kid->op_private & OPpCONST_ENTERED),
6717 : o->op_type == OP_RV2SV
6719 : o->op_type == OP_RV2AV
6721 : o->op_type == OP_RV2HV
6724 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6726 kid->op_type = OP_GV;
6727 SvREFCNT_dec(kid->op_sv);
6729 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6730 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6731 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6733 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6735 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6737 kid->op_private = 0;
6738 kid->op_ppaddr = PL_ppaddr[OP_GV];
6745 Perl_ck_ftst(pTHX_ OP *o)
6748 const I32 type = o->op_type;
6750 PERL_ARGS_ASSERT_CK_FTST;
6752 if (o->op_flags & OPf_REF) {
6755 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6756 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6757 const OPCODE kidtype = kid->op_type;
6759 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6760 OP * const newop = newGVOP(type, OPf_REF,
6761 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6763 op_getmad(o,newop,'O');
6769 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6770 o->op_private |= OPpFT_ACCESS;
6771 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6772 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6773 o->op_private |= OPpFT_STACKED;
6781 if (type == OP_FTTTY)
6782 o = newGVOP(type, OPf_REF, PL_stdingv);
6784 o = newUNOP(type, 0, newDEFSVOP());
6785 op_getmad(oldo,o,'O');
6791 Perl_ck_fun(pTHX_ OP *o)
6794 const int type = o->op_type;
6795 register I32 oa = PL_opargs[type] >> OASHIFT;
6797 PERL_ARGS_ASSERT_CK_FUN;
6799 if (o->op_flags & OPf_STACKED) {
6800 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6803 return no_fh_allowed(o);
6806 if (o->op_flags & OPf_KIDS) {
6807 OP **tokid = &cLISTOPo->op_first;
6808 register OP *kid = cLISTOPo->op_first;
6812 if (kid->op_type == OP_PUSHMARK ||
6813 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6815 tokid = &kid->op_sibling;
6816 kid = kid->op_sibling;
6818 if (!kid && PL_opargs[type] & OA_DEFGV)
6819 *tokid = kid = newDEFSVOP();
6823 sibl = kid->op_sibling;
6825 if (!sibl && kid->op_type == OP_STUB) {
6832 /* list seen where single (scalar) arg expected? */
6833 if (numargs == 1 && !(oa >> 4)
6834 && kid->op_type == OP_LIST && type != OP_SCALAR)
6836 return too_many_arguments(o,PL_op_desc[type]);
6849 if ((type == OP_PUSH || type == OP_UNSHIFT)
6850 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6851 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6852 "Useless use of %s with no values",
6855 if (kid->op_type == OP_CONST &&
6856 (kid->op_private & OPpCONST_BARE))
6858 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6859 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6860 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6861 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6862 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6863 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6865 op_getmad(kid,newop,'K');
6870 kid->op_sibling = sibl;
6873 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6874 bad_type(numargs, "array", PL_op_desc[type], kid);
6878 if (kid->op_type == OP_CONST &&
6879 (kid->op_private & OPpCONST_BARE))
6881 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6882 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6883 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6884 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6885 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6886 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6888 op_getmad(kid,newop,'K');
6893 kid->op_sibling = sibl;
6896 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6897 bad_type(numargs, "hash", PL_op_desc[type], kid);
6902 OP * const newop = newUNOP(OP_NULL, 0, kid);
6903 kid->op_sibling = 0;
6905 newop->op_next = newop;
6907 kid->op_sibling = sibl;
6912 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6913 if (kid->op_type == OP_CONST &&
6914 (kid->op_private & OPpCONST_BARE))
6916 OP * const newop = newGVOP(OP_GV, 0,
6917 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6918 if (!(o->op_private & 1) && /* if not unop */
6919 kid == cLISTOPo->op_last)
6920 cLISTOPo->op_last = newop;
6922 op_getmad(kid,newop,'K');
6928 else if (kid->op_type == OP_READLINE) {
6929 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6930 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6933 I32 flags = OPf_SPECIAL;
6937 /* is this op a FH constructor? */
6938 if (is_handle_constructor(o,numargs)) {
6939 const char *name = NULL;
6943 /* Set a flag to tell rv2gv to vivify
6944 * need to "prove" flag does not mean something
6945 * else already - NI-S 1999/05/07
6948 if (kid->op_type == OP_PADSV) {
6950 = PAD_COMPNAME_SV(kid->op_targ);
6951 name = SvPV_const(namesv, len);
6953 else if (kid->op_type == OP_RV2SV
6954 && kUNOP->op_first->op_type == OP_GV)
6956 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6958 len = GvNAMELEN(gv);
6960 else if (kid->op_type == OP_AELEM
6961 || kid->op_type == OP_HELEM)
6964 OP *op = ((BINOP*)kid)->op_first;
6968 const char * const a =
6969 kid->op_type == OP_AELEM ?
6971 if (((op->op_type == OP_RV2AV) ||
6972 (op->op_type == OP_RV2HV)) &&
6973 (firstop = ((UNOP*)op)->op_first) &&
6974 (firstop->op_type == OP_GV)) {
6975 /* packagevar $a[] or $h{} */
6976 GV * const gv = cGVOPx_gv(firstop);
6984 else if (op->op_type == OP_PADAV
6985 || op->op_type == OP_PADHV) {
6986 /* lexicalvar $a[] or $h{} */
6987 const char * const padname =
6988 PAD_COMPNAME_PV(op->op_targ);
6997 name = SvPV_const(tmpstr, len);
7002 name = "__ANONIO__";
7009 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7010 namesv = PAD_SVl(targ);
7011 SvUPGRADE(namesv, SVt_PV);
7013 sv_setpvs(namesv, "$");
7014 sv_catpvn(namesv, name, len);
7017 kid->op_sibling = 0;
7018 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7019 kid->op_targ = targ;
7020 kid->op_private |= priv;
7022 kid->op_sibling = sibl;
7028 mod(scalar(kid), type);
7032 tokid = &kid->op_sibling;
7033 kid = kid->op_sibling;
7036 if (kid && kid->op_type != OP_STUB)
7037 return too_many_arguments(o,OP_DESC(o));
7038 o->op_private |= numargs;
7040 /* FIXME - should the numargs move as for the PERL_MAD case? */
7041 o->op_private |= numargs;
7043 return too_many_arguments(o,OP_DESC(o));
7047 else if (PL_opargs[type] & OA_DEFGV) {
7049 OP *newop = newUNOP(type, 0, newDEFSVOP());
7050 op_getmad(o,newop,'O');
7053 /* Ordering of these two is important to keep f_map.t passing. */
7055 return newUNOP(type, 0, newDEFSVOP());
7060 while (oa & OA_OPTIONAL)
7062 if (oa && oa != OA_LIST)
7063 return too_few_arguments(o,OP_DESC(o));
7069 Perl_ck_glob(pTHX_ OP *o)
7074 PERL_ARGS_ASSERT_CK_GLOB;
7077 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7078 append_elem(OP_GLOB, o, newDEFSVOP());
7080 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7081 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7083 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7086 #if !defined(PERL_EXTERNAL_GLOB)
7087 /* XXX this can be tightened up and made more failsafe. */
7088 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7091 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7092 newSVpvs("File::Glob"), NULL, NULL, NULL);
7093 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7094 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7095 GvCV(gv) = GvCV(glob_gv);
7096 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7097 GvIMPORTED_CV_on(gv);
7100 #endif /* PERL_EXTERNAL_GLOB */
7102 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7103 append_elem(OP_GLOB, o,
7104 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7105 o->op_type = OP_LIST;
7106 o->op_ppaddr = PL_ppaddr[OP_LIST];
7107 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7108 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7109 cLISTOPo->op_first->op_targ = 0;
7110 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7111 append_elem(OP_LIST, o,
7112 scalar(newUNOP(OP_RV2CV, 0,
7113 newGVOP(OP_GV, 0, gv)))));
7114 o = newUNOP(OP_NULL, 0, ck_subr(o));
7115 o->op_targ = OP_GLOB; /* hint at what it used to be */
7118 gv = newGVgen("main");
7120 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7126 Perl_ck_grep(pTHX_ OP *o)
7131 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7134 PERL_ARGS_ASSERT_CK_GREP;
7136 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7137 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7139 if (o->op_flags & OPf_STACKED) {
7142 kid = cLISTOPo->op_first->op_sibling;
7143 if (!cUNOPx(kid)->op_next)
7144 Perl_croak(aTHX_ "panic: ck_grep");
7145 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7148 NewOp(1101, gwop, 1, LOGOP);
7149 kid->op_next = (OP*)gwop;
7150 o->op_flags &= ~OPf_STACKED;
7152 kid = cLISTOPo->op_first->op_sibling;
7153 if (type == OP_MAPWHILE)
7158 if (PL_parser && PL_parser->error_count)
7160 kid = cLISTOPo->op_first->op_sibling;
7161 if (kid->op_type != OP_NULL)
7162 Perl_croak(aTHX_ "panic: ck_grep");
7163 kid = kUNOP->op_first;
7166 NewOp(1101, gwop, 1, LOGOP);
7167 gwop->op_type = type;
7168 gwop->op_ppaddr = PL_ppaddr[type];
7169 gwop->op_first = listkids(o);
7170 gwop->op_flags |= OPf_KIDS;
7171 gwop->op_other = LINKLIST(kid);
7172 kid->op_next = (OP*)gwop;
7173 offset = pad_findmy("$_");
7174 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7175 o->op_private = gwop->op_private = 0;
7176 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7179 o->op_private = gwop->op_private = OPpGREP_LEX;
7180 gwop->op_targ = o->op_targ = offset;
7183 kid = cLISTOPo->op_first->op_sibling;
7184 if (!kid || !kid->op_sibling)
7185 return too_few_arguments(o,OP_DESC(o));
7186 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7187 mod(kid, OP_GREPSTART);
7193 Perl_ck_index(pTHX_ OP *o)
7195 PERL_ARGS_ASSERT_CK_INDEX;
7197 if (o->op_flags & OPf_KIDS) {
7198 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7200 kid = kid->op_sibling; /* get past "big" */
7201 if (kid && kid->op_type == OP_CONST)
7202 fbm_compile(((SVOP*)kid)->op_sv, 0);
7208 Perl_ck_lfun(pTHX_ OP *o)
7210 const OPCODE type = o->op_type;
7212 PERL_ARGS_ASSERT_CK_LFUN;
7214 return modkids(ck_fun(o), type);
7218 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7220 PERL_ARGS_ASSERT_CK_DEFINED;
7222 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7223 switch (cUNOPo->op_first->op_type) {
7225 /* This is needed for
7226 if (defined %stash::)
7227 to work. Do not break Tk.
7229 break; /* Globals via GV can be undef */
7231 case OP_AASSIGN: /* Is this a good idea? */
7232 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7233 "defined(@array) is deprecated");
7234 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7235 "\t(Maybe you should just omit the defined()?)\n");
7238 /* This is needed for
7239 if (defined %stash::)
7240 to work. Do not break Tk.
7242 break; /* Globals via GV can be undef */
7244 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7245 "defined(%%hash) is deprecated");
7246 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7247 "\t(Maybe you should just omit the defined()?)\n");
7258 Perl_ck_readline(pTHX_ OP *o)
7260 PERL_ARGS_ASSERT_CK_READLINE;
7262 if (!(o->op_flags & OPf_KIDS)) {
7264 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7266 op_getmad(o,newop,'O');
7276 Perl_ck_rfun(pTHX_ OP *o)
7278 const OPCODE type = o->op_type;
7280 PERL_ARGS_ASSERT_CK_RFUN;
7282 return refkids(ck_fun(o), type);
7286 Perl_ck_listiob(pTHX_ OP *o)
7290 PERL_ARGS_ASSERT_CK_LISTIOB;
7292 kid = cLISTOPo->op_first;
7295 kid = cLISTOPo->op_first;
7297 if (kid->op_type == OP_PUSHMARK)
7298 kid = kid->op_sibling;
7299 if (kid && o->op_flags & OPf_STACKED)
7300 kid = kid->op_sibling;
7301 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7302 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7303 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7304 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7305 cLISTOPo->op_first->op_sibling = kid;
7306 cLISTOPo->op_last = kid;
7307 kid = kid->op_sibling;
7312 append_elem(o->op_type, o, newDEFSVOP());
7318 Perl_ck_smartmatch(pTHX_ OP *o)
7321 if (0 == (o->op_flags & OPf_SPECIAL)) {
7322 OP *first = cBINOPo->op_first;
7323 OP *second = first->op_sibling;
7325 /* Implicitly take a reference to an array or hash */
7326 first->op_sibling = NULL;
7327 first = cBINOPo->op_first = ref_array_or_hash(first);
7328 second = first->op_sibling = ref_array_or_hash(second);
7330 /* Implicitly take a reference to a regular expression */
7331 if (first->op_type == OP_MATCH) {
7332 first->op_type = OP_QR;
7333 first->op_ppaddr = PL_ppaddr[OP_QR];
7335 if (second->op_type == OP_MATCH) {
7336 second->op_type = OP_QR;
7337 second->op_ppaddr = PL_ppaddr[OP_QR];
7346 Perl_ck_sassign(pTHX_ OP *o)
7349 OP * const kid = cLISTOPo->op_first;
7351 PERL_ARGS_ASSERT_CK_SASSIGN;
7353 /* has a disposable target? */
7354 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7355 && !(kid->op_flags & OPf_STACKED)
7356 /* Cannot steal the second time! */
7357 && !(kid->op_private & OPpTARGET_MY)
7358 /* Keep the full thing for madskills */
7362 OP * const kkid = kid->op_sibling;
7364 /* Can just relocate the target. */
7365 if (kkid && kkid->op_type == OP_PADSV
7366 && !(kkid->op_private & OPpLVAL_INTRO))
7368 kid->op_targ = kkid->op_targ;
7370 /* Now we do not need PADSV and SASSIGN. */
7371 kid->op_sibling = o->op_sibling; /* NULL */
7372 cLISTOPo->op_first = NULL;
7375 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7379 if (kid->op_sibling) {
7380 OP *kkid = kid->op_sibling;
7381 if (kkid->op_type == OP_PADSV
7382 && (kkid->op_private & OPpLVAL_INTRO)
7383 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7384 const PADOFFSET target = kkid->op_targ;
7385 OP *const other = newOP(OP_PADSV,
7387 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7388 OP *const first = newOP(OP_NULL, 0);
7389 OP *const nullop = newCONDOP(0, first, o, other);
7390 OP *const condop = first->op_next;
7391 /* hijacking PADSTALE for uninitialized state variables */
7392 SvPADSTALE_on(PAD_SVl(target));
7394 condop->op_type = OP_ONCE;
7395 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7396 condop->op_targ = target;
7397 other->op_targ = target;
7399 /* Because we change the type of the op here, we will skip the
7400 assinment binop->op_last = binop->op_first->op_sibling; at the
7401 end of Perl_newBINOP(). So need to do it here. */
7402 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7411 Perl_ck_match(pTHX_ OP *o)
7415 PERL_ARGS_ASSERT_CK_MATCH;
7417 if (o->op_type != OP_QR && PL_compcv) {
7418 const PADOFFSET offset = pad_findmy("$_");
7419 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7420 o->op_targ = offset;
7421 o->op_private |= OPpTARGET_MY;
7424 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7425 o->op_private |= OPpRUNTIME;
7430 Perl_ck_method(pTHX_ OP *o)
7432 OP * const kid = cUNOPo->op_first;
7434 PERL_ARGS_ASSERT_CK_METHOD;
7436 if (kid->op_type == OP_CONST) {
7437 SV* sv = kSVOP->op_sv;
7438 const char * const method = SvPVX_const(sv);
7439 if (!(strchr(method, ':') || strchr(method, '\''))) {
7441 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7442 sv = newSVpvn_share(method, SvCUR(sv), 0);
7445 kSVOP->op_sv = NULL;
7447 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7449 op_getmad(o,cmop,'O');
7460 Perl_ck_null(pTHX_ OP *o)
7462 PERL_ARGS_ASSERT_CK_NULL;
7463 PERL_UNUSED_CONTEXT;
7468 Perl_ck_open(pTHX_ OP *o)
7471 HV * const table = GvHV(PL_hintgv);
7473 PERL_ARGS_ASSERT_CK_OPEN;
7476 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7479 const char *d = SvPV_const(*svp, len);
7480 const I32 mode = mode_from_discipline(d, len);
7481 if (mode & O_BINARY)
7482 o->op_private |= OPpOPEN_IN_RAW;
7483 else if (mode & O_TEXT)
7484 o->op_private |= OPpOPEN_IN_CRLF;
7487 svp = hv_fetchs(table, "open_OUT", FALSE);
7490 const char *d = SvPV_const(*svp, len);
7491 const I32 mode = mode_from_discipline(d, len);
7492 if (mode & O_BINARY)
7493 o->op_private |= OPpOPEN_OUT_RAW;
7494 else if (mode & O_TEXT)
7495 o->op_private |= OPpOPEN_OUT_CRLF;
7498 if (o->op_type == OP_BACKTICK) {
7499 if (!(o->op_flags & OPf_KIDS)) {
7500 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7502 op_getmad(o,newop,'O');
7511 /* In case of three-arg dup open remove strictness
7512 * from the last arg if it is a bareword. */
7513 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7514 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7518 if ((last->op_type == OP_CONST) && /* The bareword. */
7519 (last->op_private & OPpCONST_BARE) &&
7520 (last->op_private & OPpCONST_STRICT) &&
7521 (oa = first->op_sibling) && /* The fh. */
7522 (oa = oa->op_sibling) && /* The mode. */
7523 (oa->op_type == OP_CONST) &&
7524 SvPOK(((SVOP*)oa)->op_sv) &&
7525 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7526 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7527 (last == oa->op_sibling)) /* The bareword. */
7528 last->op_private &= ~OPpCONST_STRICT;
7534 Perl_ck_repeat(pTHX_ OP *o)
7536 PERL_ARGS_ASSERT_CK_REPEAT;
7538 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7539 o->op_private |= OPpREPEAT_DOLIST;
7540 cBINOPo->op_first = force_list(cBINOPo->op_first);
7548 Perl_ck_require(pTHX_ OP *o)
7553 PERL_ARGS_ASSERT_CK_REQUIRE;
7555 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7556 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7558 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7559 SV * const sv = kid->op_sv;
7560 U32 was_readonly = SvREADONLY(sv);
7567 sv_force_normal_flags(sv, 0);
7568 assert(!SvREADONLY(sv));
7578 for (; s < end; s++) {
7579 if (*s == ':' && s[1] == ':') {
7581 Move(s+2, s+1, end - s - 1, char);
7586 sv_catpvs(sv, ".pm");
7587 SvFLAGS(sv) |= was_readonly;
7591 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7592 /* handle override, if any */
7593 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7594 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7595 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7596 gv = gvp ? *gvp : NULL;
7600 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7601 OP * const kid = cUNOPo->op_first;
7604 cUNOPo->op_first = 0;
7608 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7609 append_elem(OP_LIST, kid,
7610 scalar(newUNOP(OP_RV2CV, 0,
7613 op_getmad(o,newop,'O');
7621 Perl_ck_return(pTHX_ OP *o)
7626 PERL_ARGS_ASSERT_CK_RETURN;
7628 kid = cLISTOPo->op_first->op_sibling;
7629 if (CvLVALUE(PL_compcv)) {
7630 for (; kid; kid = kid->op_sibling)
7631 mod(kid, OP_LEAVESUBLV);
7633 for (; kid; kid = kid->op_sibling)
7634 if ((kid->op_type == OP_NULL)
7635 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7636 /* This is a do block */
7637 OP *op = kUNOP->op_first;
7638 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7639 op = cUNOPx(op)->op_first;
7640 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7641 /* Force the use of the caller's context */
7642 op->op_flags |= OPf_SPECIAL;
7651 Perl_ck_select(pTHX_ OP *o)
7656 PERL_ARGS_ASSERT_CK_SELECT;
7658 if (o->op_flags & OPf_KIDS) {
7659 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7660 if (kid && kid->op_sibling) {
7661 o->op_type = OP_SSELECT;
7662 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7664 return fold_constants(o);
7668 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7669 if (kid && kid->op_type == OP_RV2GV)
7670 kid->op_private &= ~HINT_STRICT_REFS;
7675 Perl_ck_shift(pTHX_ OP *o)
7678 const I32 type = o->op_type;
7680 PERL_ARGS_ASSERT_CK_SHIFT;
7682 if (!(o->op_flags & OPf_KIDS)) {
7683 OP *argop = newUNOP(OP_RV2AV, 0,
7684 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7686 OP * const oldo = o;
7687 o = newUNOP(type, 0, scalar(argop));
7688 op_getmad(oldo,o,'O');
7692 return newUNOP(type, 0, scalar(argop));
7695 return scalar(modkids(ck_fun(o), type));
7699 Perl_ck_sort(pTHX_ OP *o)
7704 PERL_ARGS_ASSERT_CK_SORT;
7706 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7707 HV * const hinthv = GvHV(PL_hintgv);
7709 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7711 const I32 sorthints = (I32)SvIV(*svp);
7712 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7713 o->op_private |= OPpSORT_QSORT;
7714 if ((sorthints & HINT_SORT_STABLE) != 0)
7715 o->op_private |= OPpSORT_STABLE;
7720 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7722 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7723 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7725 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7727 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7729 if (kid->op_type == OP_SCOPE) {
7733 else if (kid->op_type == OP_LEAVE) {
7734 if (o->op_type == OP_SORT) {
7735 op_null(kid); /* wipe out leave */
7738 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7739 if (k->op_next == kid)
7741 /* don't descend into loops */
7742 else if (k->op_type == OP_ENTERLOOP
7743 || k->op_type == OP_ENTERITER)
7745 k = cLOOPx(k)->op_lastop;
7750 kid->op_next = 0; /* just disconnect the leave */
7751 k = kLISTOP->op_first;
7756 if (o->op_type == OP_SORT) {
7757 /* provide scalar context for comparison function/block */
7763 o->op_flags |= OPf_SPECIAL;
7765 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7768 firstkid = firstkid->op_sibling;
7771 /* provide list context for arguments */
7772 if (o->op_type == OP_SORT)
7779 S_simplify_sort(pTHX_ OP *o)
7782 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7788 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7790 if (!(o->op_flags & OPf_STACKED))
7792 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7793 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7794 kid = kUNOP->op_first; /* get past null */
7795 if (kid->op_type != OP_SCOPE)
7797 kid = kLISTOP->op_last; /* get past scope */
7798 switch(kid->op_type) {
7806 k = kid; /* remember this node*/
7807 if (kBINOP->op_first->op_type != OP_RV2SV)
7809 kid = kBINOP->op_first; /* get past cmp */
7810 if (kUNOP->op_first->op_type != OP_GV)
7812 kid = kUNOP->op_first; /* get past rv2sv */
7814 if (GvSTASH(gv) != PL_curstash)
7816 gvname = GvNAME(gv);
7817 if (*gvname == 'a' && gvname[1] == '\0')
7819 else if (*gvname == 'b' && gvname[1] == '\0')
7824 kid = k; /* back to cmp */
7825 if (kBINOP->op_last->op_type != OP_RV2SV)
7827 kid = kBINOP->op_last; /* down to 2nd arg */
7828 if (kUNOP->op_first->op_type != OP_GV)
7830 kid = kUNOP->op_first; /* get past rv2sv */
7832 if (GvSTASH(gv) != PL_curstash)
7834 gvname = GvNAME(gv);
7836 ? !(*gvname == 'a' && gvname[1] == '\0')
7837 : !(*gvname == 'b' && gvname[1] == '\0'))
7839 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7841 o->op_private |= OPpSORT_DESCEND;
7842 if (k->op_type == OP_NCMP)
7843 o->op_private |= OPpSORT_NUMERIC;
7844 if (k->op_type == OP_I_NCMP)
7845 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7846 kid = cLISTOPo->op_first->op_sibling;
7847 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7849 op_getmad(kid,o,'S'); /* then delete it */
7851 op_free(kid); /* then delete it */
7856 Perl_ck_split(pTHX_ OP *o)
7861 PERL_ARGS_ASSERT_CK_SPLIT;
7863 if (o->op_flags & OPf_STACKED)
7864 return no_fh_allowed(o);
7866 kid = cLISTOPo->op_first;
7867 if (kid->op_type != OP_NULL)
7868 Perl_croak(aTHX_ "panic: ck_split");
7869 kid = kid->op_sibling;
7870 op_free(cLISTOPo->op_first);
7871 cLISTOPo->op_first = kid;
7873 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7874 cLISTOPo->op_last = kid; /* There was only one element previously */
7877 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7878 OP * const sibl = kid->op_sibling;
7879 kid->op_sibling = 0;
7880 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7881 if (cLISTOPo->op_first == cLISTOPo->op_last)
7882 cLISTOPo->op_last = kid;
7883 cLISTOPo->op_first = kid;
7884 kid->op_sibling = sibl;
7887 kid->op_type = OP_PUSHRE;
7888 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7890 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7891 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7892 "Use of /g modifier is meaningless in split");
7895 if (!kid->op_sibling)
7896 append_elem(OP_SPLIT, o, newDEFSVOP());
7898 kid = kid->op_sibling;
7901 if (!kid->op_sibling)
7902 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7903 assert(kid->op_sibling);
7905 kid = kid->op_sibling;
7908 if (kid->op_sibling)
7909 return too_many_arguments(o,OP_DESC(o));
7915 Perl_ck_join(pTHX_ OP *o)
7917 const OP * const kid = cLISTOPo->op_first->op_sibling;
7919 PERL_ARGS_ASSERT_CK_JOIN;
7921 if (kid && kid->op_type == OP_MATCH) {
7922 if (ckWARN(WARN_SYNTAX)) {
7923 const REGEXP *re = PM_GETRE(kPMOP);
7924 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7925 const STRLEN len = re ? RX_PRELEN(re) : 6;
7926 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7927 "/%.*s/ should probably be written as \"%.*s\"",
7928 (int)len, pmstr, (int)len, pmstr);
7935 Perl_ck_subr(pTHX_ OP *o)
7938 OP *prev = ((cUNOPo->op_first->op_sibling)
7939 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7940 OP *o2 = prev->op_sibling;
7942 const char *proto = NULL;
7943 const char *proto_end = NULL;
7948 I32 contextclass = 0;
7949 const char *e = NULL;
7952 PERL_ARGS_ASSERT_CK_SUBR;
7954 o->op_private |= OPpENTERSUB_HASTARG;
7955 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7956 if (cvop->op_type == OP_RV2CV) {
7958 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7959 op_null(cvop); /* disable rv2cv */
7960 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7961 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7962 GV *gv = cGVOPx_gv(tmpop);
7965 tmpop->op_private |= OPpEARLY_CV;
7969 namegv = CvANON(cv) ? gv : CvGV(cv);
7970 proto = SvPV(MUTABLE_SV(cv), len);
7971 proto_end = proto + len;
7976 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7977 if (o2->op_type == OP_CONST)
7978 o2->op_private &= ~OPpCONST_STRICT;
7979 else if (o2->op_type == OP_LIST) {
7980 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7981 if (sib && sib->op_type == OP_CONST)
7982 sib->op_private &= ~OPpCONST_STRICT;
7985 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7986 if (PERLDB_SUB && PL_curstash != PL_debstash)
7987 o->op_private |= OPpENTERSUB_DB;
7988 while (o2 != cvop) {
7990 if (PL_madskills && o2->op_type == OP_STUB) {
7991 o2 = o2->op_sibling;
7994 if (PL_madskills && o2->op_type == OP_NULL)
7995 o3 = ((UNOP*)o2)->op_first;
7999 if (proto >= proto_end)
8000 return too_many_arguments(o, gv_ename(namegv));
8008 /* _ must be at the end */
8009 if (proto[1] && proto[1] != ';')
8024 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8026 arg == 1 ? "block or sub {}" : "sub {}",
8027 gv_ename(namegv), o3);
8030 /* '*' allows any scalar type, including bareword */
8033 if (o3->op_type == OP_RV2GV)
8034 goto wrapref; /* autoconvert GLOB -> GLOBref */
8035 else if (o3->op_type == OP_CONST)
8036 o3->op_private &= ~OPpCONST_STRICT;
8037 else if (o3->op_type == OP_ENTERSUB) {
8038 /* accidental subroutine, revert to bareword */
8039 OP *gvop = ((UNOP*)o3)->op_first;
8040 if (gvop && gvop->op_type == OP_NULL) {
8041 gvop = ((UNOP*)gvop)->op_first;
8043 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8046 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8047 (gvop = ((UNOP*)gvop)->op_first) &&
8048 gvop->op_type == OP_GV)
8050 GV * const gv = cGVOPx_gv(gvop);
8051 OP * const sibling = o2->op_sibling;
8052 SV * const n = newSVpvs("");
8054 OP * const oldo2 = o2;
8058 gv_fullname4(n, gv, "", FALSE);
8059 o2 = newSVOP(OP_CONST, 0, n);
8060 op_getmad(oldo2,o2,'O');
8061 prev->op_sibling = o2;
8062 o2->op_sibling = sibling;
8078 if (contextclass++ == 0) {
8079 e = strchr(proto, ']');
8080 if (!e || e == proto)
8089 const char *p = proto;
8090 const char *const end = proto;
8092 while (*--p != '[') {}
8093 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8095 gv_ename(namegv), o3);
8100 if (o3->op_type == OP_RV2GV)
8103 bad_type(arg, "symbol", gv_ename(namegv), o3);
8106 if (o3->op_type == OP_ENTERSUB)
8109 bad_type(arg, "subroutine entry", gv_ename(namegv),
8113 if (o3->op_type == OP_RV2SV ||
8114 o3->op_type == OP_PADSV ||
8115 o3->op_type == OP_HELEM ||
8116 o3->op_type == OP_AELEM)
8119 bad_type(arg, "scalar", gv_ename(namegv), o3);
8122 if (o3->op_type == OP_RV2AV ||
8123 o3->op_type == OP_PADAV)
8126 bad_type(arg, "array", gv_ename(namegv), o3);
8129 if (o3->op_type == OP_RV2HV ||
8130 o3->op_type == OP_PADHV)
8133 bad_type(arg, "hash", gv_ename(namegv), o3);
8138 OP* const sib = kid->op_sibling;
8139 kid->op_sibling = 0;
8140 o2 = newUNOP(OP_REFGEN, 0, kid);
8141 o2->op_sibling = sib;
8142 prev->op_sibling = o2;
8144 if (contextclass && e) {
8159 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8160 gv_ename(namegv), SVfARG(cv));
8165 mod(o2, OP_ENTERSUB);
8167 o2 = o2->op_sibling;
8169 if (o2 == cvop && proto && *proto == '_') {
8170 /* generate an access to $_ */
8172 o2->op_sibling = prev->op_sibling;
8173 prev->op_sibling = o2; /* instead of cvop */
8175 if (proto && !optional && proto_end > proto &&
8176 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8177 return too_few_arguments(o, gv_ename(namegv));
8180 OP * const oldo = o;
8184 o=newSVOP(OP_CONST, 0, newSViv(0));
8185 op_getmad(oldo,o,'O');
8191 Perl_ck_svconst(pTHX_ OP *o)
8193 PERL_ARGS_ASSERT_CK_SVCONST;
8194 PERL_UNUSED_CONTEXT;
8195 SvREADONLY_on(cSVOPo->op_sv);
8200 Perl_ck_chdir(pTHX_ OP *o)
8202 if (o->op_flags & OPf_KIDS) {
8203 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8205 if (kid && kid->op_type == OP_CONST &&
8206 (kid->op_private & OPpCONST_BARE))
8208 o->op_flags |= OPf_SPECIAL;
8209 kid->op_private &= ~OPpCONST_STRICT;
8216 Perl_ck_trunc(pTHX_ OP *o)
8218 PERL_ARGS_ASSERT_CK_TRUNC;
8220 if (o->op_flags & OPf_KIDS) {
8221 SVOP *kid = (SVOP*)cUNOPo->op_first;
8223 if (kid->op_type == OP_NULL)
8224 kid = (SVOP*)kid->op_sibling;
8225 if (kid && kid->op_type == OP_CONST &&
8226 (kid->op_private & OPpCONST_BARE))
8228 o->op_flags |= OPf_SPECIAL;
8229 kid->op_private &= ~OPpCONST_STRICT;
8236 Perl_ck_unpack(pTHX_ OP *o)
8238 OP *kid = cLISTOPo->op_first;
8240 PERL_ARGS_ASSERT_CK_UNPACK;
8242 if (kid->op_sibling) {
8243 kid = kid->op_sibling;
8244 if (!kid->op_sibling)
8245 kid->op_sibling = newDEFSVOP();
8251 Perl_ck_substr(pTHX_ OP *o)
8253 PERL_ARGS_ASSERT_CK_SUBSTR;
8256 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8257 OP *kid = cLISTOPo->op_first;
8259 if (kid->op_type == OP_NULL)
8260 kid = kid->op_sibling;
8262 kid->op_flags |= OPf_MOD;
8269 Perl_ck_each(pTHX_ OP *o)
8272 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8274 PERL_ARGS_ASSERT_CK_EACH;
8277 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8278 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8279 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8280 o->op_type = new_type;
8281 o->op_ppaddr = PL_ppaddr[new_type];
8283 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8284 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8286 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8293 /* A peephole optimizer. We visit the ops in the order they're to execute.
8294 * See the comments at the top of this file for more details about when
8295 * peep() is called */
8298 Perl_peep(pTHX_ register OP *o)
8301 register OP* oldop = NULL;
8303 if (!o || o->op_opt)
8307 SAVEVPTR(PL_curcop);
8308 for (; o; o = o->op_next) {
8311 /* By default, this op has now been optimised. A couple of cases below
8312 clear this again. */
8315 switch (o->op_type) {
8318 PL_curcop = ((COP*)o); /* for warnings */
8322 if (cSVOPo->op_private & OPpCONST_STRICT)
8323 no_bareword_allowed(o);
8326 case OP_METHOD_NAMED:
8327 /* Relocate sv to the pad for thread safety.
8328 * Despite being a "constant", the SV is written to,
8329 * for reference counts, sv_upgrade() etc. */
8331 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8332 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8333 /* If op_sv is already a PADTMP then it is being used by
8334 * some pad, so make a copy. */
8335 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8336 SvREADONLY_on(PAD_SVl(ix));
8337 SvREFCNT_dec(cSVOPo->op_sv);
8339 else if (o->op_type != OP_METHOD_NAMED
8340 && cSVOPo->op_sv == &PL_sv_undef) {
8341 /* PL_sv_undef is hack - it's unsafe to store it in the
8342 AV that is the pad, because av_fetch treats values of
8343 PL_sv_undef as a "free" AV entry and will merrily
8344 replace them with a new SV, causing pad_alloc to think
8345 that this pad slot is free. (When, clearly, it is not)
8347 SvOK_off(PAD_SVl(ix));
8348 SvPADTMP_on(PAD_SVl(ix));
8349 SvREADONLY_on(PAD_SVl(ix));
8352 SvREFCNT_dec(PAD_SVl(ix));
8353 SvPADTMP_on(cSVOPo->op_sv);
8354 PAD_SETSV(ix, cSVOPo->op_sv);
8355 /* XXX I don't know how this isn't readonly already. */
8356 SvREADONLY_on(PAD_SVl(ix));
8358 cSVOPo->op_sv = NULL;
8365 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8366 if (o->op_next->op_private & OPpTARGET_MY) {
8367 if (o->op_flags & OPf_STACKED) /* chained concats */
8368 break; /* ignore_optimization */
8370 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8371 o->op_targ = o->op_next->op_targ;
8372 o->op_next->op_targ = 0;
8373 o->op_private |= OPpTARGET_MY;
8376 op_null(o->op_next);
8380 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8381 break; /* Scalar stub must produce undef. List stub is noop */
8385 if (o->op_targ == OP_NEXTSTATE
8386 || o->op_targ == OP_DBSTATE)
8388 PL_curcop = ((COP*)o);
8390 /* XXX: We avoid setting op_seq here to prevent later calls
8391 to peep() from mistakenly concluding that optimisation
8392 has already occurred. This doesn't fix the real problem,
8393 though (See 20010220.007). AMS 20010719 */
8394 /* op_seq functionality is now replaced by op_opt */
8401 if (oldop && o->op_next) {
8402 oldop->op_next = o->op_next;
8410 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8411 OP* const pop = (o->op_type == OP_PADAV) ?
8412 o->op_next : o->op_next->op_next;
8414 if (pop && pop->op_type == OP_CONST &&
8415 ((PL_op = pop->op_next)) &&
8416 pop->op_next->op_type == OP_AELEM &&
8417 !(pop->op_next->op_private &
8418 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8419 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8424 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8425 no_bareword_allowed(pop);
8426 if (o->op_type == OP_GV)
8427 op_null(o->op_next);
8428 op_null(pop->op_next);
8430 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8431 o->op_next = pop->op_next->op_next;
8432 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8433 o->op_private = (U8)i;
8434 if (o->op_type == OP_GV) {
8439 o->op_flags |= OPf_SPECIAL;
8440 o->op_type = OP_AELEMFAST;
8445 if (o->op_next->op_type == OP_RV2SV) {
8446 if (!(o->op_next->op_private & OPpDEREF)) {
8447 op_null(o->op_next);
8448 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8450 o->op_next = o->op_next->op_next;
8451 o->op_type = OP_GVSV;
8452 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8455 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8456 GV * const gv = cGVOPo_gv;
8457 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8458 /* XXX could check prototype here instead of just carping */
8459 SV * const sv = sv_newmortal();
8460 gv_efullname3(sv, gv, NULL);
8461 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8462 "%"SVf"() called too early to check prototype",
8466 else if (o->op_next->op_type == OP_READLINE
8467 && o->op_next->op_next->op_type == OP_CONCAT
8468 && (o->op_next->op_next->op_flags & OPf_STACKED))
8470 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8471 o->op_type = OP_RCATLINE;
8472 o->op_flags |= OPf_STACKED;
8473 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8474 op_null(o->op_next->op_next);
8475 op_null(o->op_next);
8491 while (cLOGOP->op_other->op_type == OP_NULL)
8492 cLOGOP->op_other = cLOGOP->op_other->op_next;
8493 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8498 while (cLOOP->op_redoop->op_type == OP_NULL)
8499 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8500 peep(cLOOP->op_redoop);
8501 while (cLOOP->op_nextop->op_type == OP_NULL)
8502 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8503 peep(cLOOP->op_nextop);
8504 while (cLOOP->op_lastop->op_type == OP_NULL)
8505 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8506 peep(cLOOP->op_lastop);
8510 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8511 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8512 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8513 cPMOP->op_pmstashstartu.op_pmreplstart
8514 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8515 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8519 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8520 && ckWARN(WARN_SYNTAX))
8522 if (o->op_next->op_sibling) {
8523 const OPCODE type = o->op_next->op_sibling->op_type;
8524 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8525 const line_t oldline = CopLINE(PL_curcop);
8526 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8527 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8528 "Statement unlikely to be reached");
8529 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8530 "\t(Maybe you meant system() when you said exec()?)\n");
8531 CopLINE_set(PL_curcop, oldline);
8542 const char *key = NULL;
8545 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8548 /* Make the CONST have a shared SV */
8549 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8550 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8551 key = SvPV_const(sv, keylen);
8552 lexname = newSVpvn_share(key,
8553 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8559 if ((o->op_private & (OPpLVAL_INTRO)))
8562 rop = (UNOP*)((BINOP*)o)->op_first;
8563 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8565 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8566 if (!SvPAD_TYPED(lexname))
8568 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8569 if (!fields || !GvHV(*fields))
8571 key = SvPV_const(*svp, keylen);
8572 if (!hv_fetch(GvHV(*fields), key,
8573 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8575 Perl_croak(aTHX_ "No such class field \"%s\" "
8576 "in variable %s of type %s",
8577 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8590 SVOP *first_key_op, *key_op;
8592 if ((o->op_private & (OPpLVAL_INTRO))
8593 /* I bet there's always a pushmark... */
8594 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8595 /* hmmm, no optimization if list contains only one key. */
8597 rop = (UNOP*)((LISTOP*)o)->op_last;
8598 if (rop->op_type != OP_RV2HV)
8600 if (rop->op_first->op_type == OP_PADSV)
8601 /* @$hash{qw(keys here)} */
8602 rop = (UNOP*)rop->op_first;
8604 /* @{$hash}{qw(keys here)} */
8605 if (rop->op_first->op_type == OP_SCOPE
8606 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8608 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8614 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8615 if (!SvPAD_TYPED(lexname))
8617 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8618 if (!fields || !GvHV(*fields))
8620 /* Again guessing that the pushmark can be jumped over.... */
8621 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8622 ->op_first->op_sibling;
8623 for (key_op = first_key_op; key_op;
8624 key_op = (SVOP*)key_op->op_sibling) {
8625 if (key_op->op_type != OP_CONST)
8627 svp = cSVOPx_svp(key_op);
8628 key = SvPV_const(*svp, keylen);
8629 if (!hv_fetch(GvHV(*fields), key,
8630 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8632 Perl_croak(aTHX_ "No such class field \"%s\" "
8633 "in variable %s of type %s",
8634 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8641 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8645 /* check that RHS of sort is a single plain array */
8646 OP *oright = cUNOPo->op_first;
8647 if (!oright || oright->op_type != OP_PUSHMARK)
8650 /* reverse sort ... can be optimised. */
8651 if (!cUNOPo->op_sibling) {
8652 /* Nothing follows us on the list. */
8653 OP * const reverse = o->op_next;
8655 if (reverse->op_type == OP_REVERSE &&
8656 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8657 OP * const pushmark = cUNOPx(reverse)->op_first;
8658 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8659 && (cUNOPx(pushmark)->op_sibling == o)) {
8660 /* reverse -> pushmark -> sort */
8661 o->op_private |= OPpSORT_REVERSE;
8663 pushmark->op_next = oright->op_next;
8669 /* make @a = sort @a act in-place */
8671 oright = cUNOPx(oright)->op_sibling;
8674 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8675 oright = cUNOPx(oright)->op_sibling;
8679 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8680 || oright->op_next != o
8681 || (oright->op_private & OPpLVAL_INTRO)
8685 /* o2 follows the chain of op_nexts through the LHS of the
8686 * assign (if any) to the aassign op itself */
8688 if (!o2 || o2->op_type != OP_NULL)
8691 if (!o2 || o2->op_type != OP_PUSHMARK)
8694 if (o2 && o2->op_type == OP_GV)
8697 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8698 || (o2->op_private & OPpLVAL_INTRO)
8703 if (!o2 || o2->op_type != OP_NULL)
8706 if (!o2 || o2->op_type != OP_AASSIGN
8707 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8710 /* check that the sort is the first arg on RHS of assign */
8712 o2 = cUNOPx(o2)->op_first;
8713 if (!o2 || o2->op_type != OP_NULL)
8715 o2 = cUNOPx(o2)->op_first;
8716 if (!o2 || o2->op_type != OP_PUSHMARK)
8718 if (o2->op_sibling != o)
8721 /* check the array is the same on both sides */
8722 if (oleft->op_type == OP_RV2AV) {
8723 if (oright->op_type != OP_RV2AV
8724 || !cUNOPx(oright)->op_first
8725 || cUNOPx(oright)->op_first->op_type != OP_GV
8726 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8727 cGVOPx_gv(cUNOPx(oright)->op_first)
8731 else if (oright->op_type != OP_PADAV
8732 || oright->op_targ != oleft->op_targ
8736 /* transfer MODishness etc from LHS arg to RHS arg */
8737 oright->op_flags = oleft->op_flags;
8738 o->op_private |= OPpSORT_INPLACE;
8740 /* excise push->gv->rv2av->null->aassign */
8741 o2 = o->op_next->op_next;
8742 op_null(o2); /* PUSHMARK */
8744 if (o2->op_type == OP_GV) {
8745 op_null(o2); /* GV */
8748 op_null(o2); /* RV2AV or PADAV */
8749 o2 = o2->op_next->op_next;
8750 op_null(o2); /* AASSIGN */
8752 o->op_next = o2->op_next;
8758 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8760 LISTOP *enter, *exlist;
8762 enter = (LISTOP *) o->op_next;
8765 if (enter->op_type == OP_NULL) {
8766 enter = (LISTOP *) enter->op_next;
8770 /* for $a (...) will have OP_GV then OP_RV2GV here.
8771 for (...) just has an OP_GV. */
8772 if (enter->op_type == OP_GV) {
8773 gvop = (OP *) enter;
8774 enter = (LISTOP *) enter->op_next;
8777 if (enter->op_type == OP_RV2GV) {
8778 enter = (LISTOP *) enter->op_next;
8784 if (enter->op_type != OP_ENTERITER)
8787 iter = enter->op_next;
8788 if (!iter || iter->op_type != OP_ITER)
8791 expushmark = enter->op_first;
8792 if (!expushmark || expushmark->op_type != OP_NULL
8793 || expushmark->op_targ != OP_PUSHMARK)
8796 exlist = (LISTOP *) expushmark->op_sibling;
8797 if (!exlist || exlist->op_type != OP_NULL
8798 || exlist->op_targ != OP_LIST)
8801 if (exlist->op_last != o) {
8802 /* Mmm. Was expecting to point back to this op. */
8805 theirmark = exlist->op_first;
8806 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8809 if (theirmark->op_sibling != o) {
8810 /* There's something between the mark and the reverse, eg
8811 for (1, reverse (...))
8816 ourmark = ((LISTOP *)o)->op_first;
8817 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8820 ourlast = ((LISTOP *)o)->op_last;
8821 if (!ourlast || ourlast->op_next != o)
8824 rv2av = ourmark->op_sibling;
8825 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8826 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8827 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8828 /* We're just reversing a single array. */
8829 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8830 enter->op_flags |= OPf_STACKED;
8833 /* We don't have control over who points to theirmark, so sacrifice
8835 theirmark->op_next = ourmark->op_next;
8836 theirmark->op_flags = ourmark->op_flags;
8837 ourlast->op_next = gvop ? gvop : (OP *) enter;
8840 enter->op_private |= OPpITER_REVERSED;
8841 iter->op_private |= OPpITER_REVERSED;
8848 UNOP *refgen, *rv2cv;
8851 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8854 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8857 rv2gv = ((BINOP *)o)->op_last;
8858 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8861 refgen = (UNOP *)((BINOP *)o)->op_first;
8863 if (!refgen || refgen->op_type != OP_REFGEN)
8866 exlist = (LISTOP *)refgen->op_first;
8867 if (!exlist || exlist->op_type != OP_NULL
8868 || exlist->op_targ != OP_LIST)
8871 if (exlist->op_first->op_type != OP_PUSHMARK)
8874 rv2cv = (UNOP*)exlist->op_last;
8876 if (rv2cv->op_type != OP_RV2CV)
8879 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8880 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8881 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8883 o->op_private |= OPpASSIGN_CV_TO_GV;
8884 rv2gv->op_private |= OPpDONT_INIT_GV;
8885 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8893 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8894 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8904 Perl_custom_op_name(pTHX_ const OP* o)
8907 const IV index = PTR2IV(o->op_ppaddr);
8911 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8913 if (!PL_custom_op_names) /* This probably shouldn't happen */
8914 return (char *)PL_op_name[OP_CUSTOM];
8916 keysv = sv_2mortal(newSViv(index));
8918 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8920 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8922 return SvPV_nolen(HeVAL(he));
8926 Perl_custom_op_desc(pTHX_ const OP* o)
8929 const IV index = PTR2IV(o->op_ppaddr);
8933 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8935 if (!PL_custom_op_descs)
8936 return (char *)PL_op_desc[OP_CUSTOM];
8938 keysv = sv_2mortal(newSViv(index));
8940 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8942 return (char *)PL_op_desc[OP_CUSTOM];
8944 return SvPV_nolen(HeVAL(he));
8949 /* Efficient sub that returns a constant scalar value. */
8951 const_sv_xsub(pTHX_ CV* cv)
8955 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
8959 /* diag_listed_as: SKIPME */
8960 Perl_croak(aTHX_ "usage: %s::%s()",
8961 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8974 * c-indentation-style: bsd
8976 * indent-tabs-mode: t
8979 * ex: set ts=8 sts=4 sw=4 noet: