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)
107 #if defined(PL_OP_SLAB_ALLOC)
109 #ifdef PERL_DEBUG_READONLY_OPS
110 # define PERL_SLAB_SIZE 4096
111 # include <sys/mman.h>
114 #ifndef PERL_SLAB_SIZE
115 #define PERL_SLAB_SIZE 2048
119 Perl_Slab_Alloc(pTHX_ size_t sz)
123 * To make incrementing use count easy PL_OpSlab is an I32 *
124 * To make inserting the link to slab PL_OpPtr is I32 **
125 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
126 * Add an overhead for pointer to slab and round up as a number of pointers
128 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
129 if ((PL_OpSpace -= sz) < 0) {
130 #ifdef PERL_DEBUG_READONLY_OPS
131 /* We need to allocate chunk by chunk so that we can control the VM
133 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
134 MAP_ANON|MAP_PRIVATE, -1, 0);
136 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
137 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
139 if(PL_OpPtr == MAP_FAILED) {
140 perror("mmap failed");
145 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
150 /* We reserve the 0'th I32 sized chunk as a use count */
151 PL_OpSlab = (I32 *) PL_OpPtr;
152 /* Reduce size by the use count word, and by the size we need.
153 * Latter is to mimic the '-=' in the if() above
155 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
156 /* Allocation pointer starts at the top.
157 Theory: because we build leaves before trunk allocating at end
158 means that at run time access is cache friendly upward
160 PL_OpPtr += PERL_SLAB_SIZE;
162 #ifdef PERL_DEBUG_READONLY_OPS
163 /* We remember this slab. */
164 /* This implementation isn't efficient, but it is simple. */
165 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
166 PL_slabs[PL_slab_count++] = PL_OpSlab;
167 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
170 assert( PL_OpSpace >= 0 );
171 /* Move the allocation pointer down */
173 assert( PL_OpPtr > (I32 **) PL_OpSlab );
174 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
175 (*PL_OpSlab)++; /* Increment use count of slab */
176 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
177 assert( *PL_OpSlab > 0 );
178 return (void *)(PL_OpPtr + 1);
181 #ifdef PERL_DEBUG_READONLY_OPS
183 Perl_pending_Slabs_to_ro(pTHX) {
184 /* Turn all the allocated op slabs read only. */
185 U32 count = PL_slab_count;
186 I32 **const slabs = PL_slabs;
188 /* Reset the array of pending OP slabs, as we're about to turn this lot
189 read only. Also, do it ahead of the loop in case the warn triggers,
190 and a warn handler has an eval */
195 /* Force a new slab for any further allocation. */
199 void *const start = slabs[count];
200 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
201 if(mprotect(start, size, PROT_READ)) {
202 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
203 start, (unsigned long) size, errno);
211 S_Slab_to_rw(pTHX_ void *op)
213 I32 * const * const ptr = (I32 **) op;
214 I32 * const slab = ptr[-1];
216 PERL_ARGS_ASSERT_SLAB_TO_RW;
218 assert( ptr-1 > (I32 **) slab );
219 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
221 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
222 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
223 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
228 Perl_op_refcnt_inc(pTHX_ OP *o)
239 Perl_op_refcnt_dec(pTHX_ OP *o)
241 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
246 # define Slab_to_rw(op)
250 Perl_Slab_Free(pTHX_ void *op)
252 I32 * const * const ptr = (I32 **) op;
253 I32 * const slab = ptr[-1];
254 PERL_ARGS_ASSERT_SLAB_FREE;
255 assert( ptr-1 > (I32 **) slab );
256 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
259 if (--(*slab) == 0) {
261 # define PerlMemShared PerlMem
264 #ifdef PERL_DEBUG_READONLY_OPS
265 U32 count = PL_slab_count;
266 /* Need to remove this slab from our list of slabs */
269 if (PL_slabs[count] == slab) {
271 /* Found it. Move the entry at the end to overwrite it. */
272 DEBUG_m(PerlIO_printf(Perl_debug_log,
273 "Deallocate %p by moving %p from %lu to %lu\n",
275 PL_slabs[PL_slab_count - 1],
276 PL_slab_count, count));
277 PL_slabs[count] = PL_slabs[--PL_slab_count];
278 /* Could realloc smaller at this point, but probably not
280 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
281 perror("munmap failed");
289 PerlMemShared_free(slab);
291 if (slab == PL_OpSlab) {
298 * In the following definition, the ", (OP*)0" is just to make the compiler
299 * think the expression is of the right type: croak actually does a Siglongjmp.
301 #define CHECKOP(type,o) \
302 ((PL_op_mask && PL_op_mask[type]) \
303 ? ( op_free((OP*)o), \
304 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
306 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
308 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
311 S_gv_ename(pTHX_ GV *gv)
313 SV* const tmpsv = sv_newmortal();
315 PERL_ARGS_ASSERT_GV_ENAME;
317 gv_efullname3(tmpsv, gv, NULL);
318 return SvPV_nolen_const(tmpsv);
322 S_no_fh_allowed(pTHX_ OP *o)
324 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
326 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
332 S_too_few_arguments(pTHX_ OP *o, const char *name)
334 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
336 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
341 S_too_many_arguments(pTHX_ OP *o, const char *name)
343 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
345 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
350 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
352 PERL_ARGS_ASSERT_BAD_TYPE;
354 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
355 (int)n, name, t, OP_DESC(kid)));
359 S_no_bareword_allowed(pTHX_ const OP *o)
361 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
364 return; /* various ok barewords are hidden in extra OP_NULL */
365 qerror(Perl_mess(aTHX_
366 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
370 /* "register" allocation */
373 Perl_allocmy(pTHX_ const char *const name)
377 const bool is_our = (PL_parser->in_my == KEY_our);
379 PERL_ARGS_ASSERT_ALLOCMY;
381 /* complain about "my $<special_var>" etc etc */
385 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
386 (name[1] == '_' && (*name == '$' || name[2]))))
388 /* name[2] is true if strlen(name) > 2 */
389 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
390 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
391 name[0], toCTRL(name[1]), name + 2,
392 PL_parser->in_my == KEY_state ? "state" : "my"));
394 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
395 PL_parser->in_my == KEY_state ? "state" : "my"));
399 /* check for duplicate declaration */
400 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
402 if (PL_parser->in_my_stash && *name != '$') {
403 yyerror(Perl_form(aTHX_
404 "Can't declare class for non-scalar %s in \"%s\"",
407 : PL_parser->in_my == KEY_state ? "state" : "my"));
410 /* allocate a spare slot and store the name in that slot */
412 off = pad_add_name(name,
413 PL_parser->in_my_stash,
415 /* $_ is always in main::, even with our */
416 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
420 PL_parser->in_my == KEY_state
422 /* anon sub prototypes contains state vars should always be cloned,
423 * otherwise the state var would be shared between anon subs */
425 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
426 CvCLONE_on(PL_compcv);
431 /* free the body of an op without examining its contents.
432 * Always use this rather than FreeOp directly */
435 S_op_destroy(pTHX_ OP *o)
437 if (o->op_latefree) {
445 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
447 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
453 Perl_op_free(pTHX_ OP *o)
460 if (o->op_latefreed) {
467 if (o->op_private & OPpREFCOUNTED) {
478 refcnt = OpREFCNT_dec(o);
481 /* Need to find and remove any pattern match ops from the list
482 we maintain for reset(). */
483 find_and_forget_pmops(o);
493 if (o->op_flags & OPf_KIDS) {
494 register OP *kid, *nextkid;
495 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
496 nextkid = kid->op_sibling; /* Get before next freeing kid */
501 #ifdef PERL_DEBUG_READONLY_OPS
505 /* COP* is not cleared by op_clear() so that we may track line
506 * numbers etc even after null() */
507 if (type == OP_NEXTSTATE || type == OP_DBSTATE
508 || (type == OP_NULL /* the COP might have been null'ed */
509 && ((OPCODE)o->op_targ == OP_NEXTSTATE
510 || (OPCODE)o->op_targ == OP_DBSTATE))) {
515 type = (OPCODE)o->op_targ;
518 if (o->op_latefree) {
524 #ifdef DEBUG_LEAKING_SCALARS
531 Perl_op_clear(pTHX_ OP *o)
536 PERL_ARGS_ASSERT_OP_CLEAR;
539 /* if (o->op_madprop && o->op_madprop->mad_next)
541 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
542 "modification of a read only value" for a reason I can't fathom why.
543 It's the "" stringification of $_, where $_ was set to '' in a foreach
544 loop, but it defies simplification into a small test case.
545 However, commenting them out has caused ext/List/Util/t/weak.t to fail
548 mad_free(o->op_madprop);
554 switch (o->op_type) {
555 case OP_NULL: /* Was holding old type, if any. */
556 if (PL_madskills && o->op_targ != OP_NULL) {
557 o->op_type = (Optype)o->op_targ;
561 case OP_ENTEREVAL: /* Was holding hints. */
565 if (!(o->op_flags & OPf_REF)
566 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
572 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
573 /* not an OP_PADAV replacement */
575 if (cPADOPo->op_padix > 0) {
576 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
577 * may still exist on the pad */
578 pad_swipe(cPADOPo->op_padix, TRUE);
579 cPADOPo->op_padix = 0;
582 SvREFCNT_dec(cSVOPo->op_sv);
583 cSVOPo->op_sv = NULL;
587 case OP_METHOD_NAMED:
590 SvREFCNT_dec(cSVOPo->op_sv);
591 cSVOPo->op_sv = NULL;
594 Even if op_clear does a pad_free for the target of the op,
595 pad_free doesn't actually remove the sv that exists in the pad;
596 instead it lives on. This results in that it could be reused as
597 a target later on when the pad was reallocated.
600 pad_swipe(o->op_targ,1);
609 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
613 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
615 if (cPADOPo->op_padix > 0) {
616 pad_swipe(cPADOPo->op_padix, TRUE);
617 cPADOPo->op_padix = 0;
620 SvREFCNT_dec(cSVOPo->op_sv);
621 cSVOPo->op_sv = NULL;
625 PerlMemShared_free(cPVOPo->op_pv);
626 cPVOPo->op_pv = NULL;
630 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
634 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
635 /* No GvIN_PAD_off here, because other references may still
636 * exist on the pad */
637 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
640 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
646 forget_pmop(cPMOPo, 1);
647 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
648 /* we use the same protection as the "SAFE" version of the PM_ macros
649 * here since sv_clean_all might release some PMOPs
650 * after PL_regex_padav has been cleared
651 * and the clearing of PL_regex_padav needs to
652 * happen before sv_clean_all
655 if(PL_regex_pad) { /* We could be in destruction */
656 const IV offset = (cPMOPo)->op_pmoffset;
657 ReREFCNT_dec(PM_GETRE(cPMOPo));
658 PL_regex_pad[offset] = &PL_sv_undef;
659 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
663 ReREFCNT_dec(PM_GETRE(cPMOPo));
664 PM_SETRE(cPMOPo, NULL);
670 if (o->op_targ > 0) {
671 pad_free(o->op_targ);
677 S_cop_free(pTHX_ COP* cop)
679 PERL_ARGS_ASSERT_COP_FREE;
683 if (! specialWARN(cop->cop_warnings))
684 PerlMemShared_free(cop->cop_warnings);
685 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
689 S_forget_pmop(pTHX_ PMOP *const o
695 HV * const pmstash = PmopSTASH(o);
697 PERL_ARGS_ASSERT_FORGET_PMOP;
699 if (pmstash && !SvIS_FREED(pmstash)) {
700 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
702 PMOP **const array = (PMOP**) mg->mg_ptr;
703 U32 count = mg->mg_len / sizeof(PMOP**);
708 /* Found it. Move the entry at the end to overwrite it. */
709 array[i] = array[--count];
710 mg->mg_len = count * sizeof(PMOP**);
711 /* Could realloc smaller at this point always, but probably
712 not worth it. Probably worth free()ing if we're the
715 Safefree(mg->mg_ptr);
732 S_find_and_forget_pmops(pTHX_ OP *o)
734 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
736 if (o->op_flags & OPf_KIDS) {
737 OP *kid = cUNOPo->op_first;
739 switch (kid->op_type) {
744 forget_pmop((PMOP*)kid, 0);
746 find_and_forget_pmops(kid);
747 kid = kid->op_sibling;
753 Perl_op_null(pTHX_ OP *o)
757 PERL_ARGS_ASSERT_OP_NULL;
759 if (o->op_type == OP_NULL)
763 o->op_targ = o->op_type;
764 o->op_type = OP_NULL;
765 o->op_ppaddr = PL_ppaddr[OP_NULL];
769 Perl_op_refcnt_lock(pTHX)
777 Perl_op_refcnt_unlock(pTHX)
784 /* Contextualizers */
786 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
789 Perl_linklist(pTHX_ OP *o)
793 PERL_ARGS_ASSERT_LINKLIST;
798 /* establish postfix order */
799 first = cUNOPo->op_first;
802 o->op_next = LINKLIST(first);
805 if (kid->op_sibling) {
806 kid->op_next = LINKLIST(kid->op_sibling);
807 kid = kid->op_sibling;
821 Perl_scalarkids(pTHX_ OP *o)
823 if (o && o->op_flags & OPf_KIDS) {
825 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
832 S_scalarboolean(pTHX_ OP *o)
836 PERL_ARGS_ASSERT_SCALARBOOLEAN;
838 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
839 if (ckWARN(WARN_SYNTAX)) {
840 const line_t oldline = CopLINE(PL_curcop);
842 if (PL_parser && PL_parser->copline != NOLINE)
843 CopLINE_set(PL_curcop, PL_parser->copline);
844 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
845 CopLINE_set(PL_curcop, oldline);
852 Perl_scalar(pTHX_ OP *o)
857 /* assumes no premature commitment */
858 if (!o || (PL_parser && PL_parser->error_count)
859 || (o->op_flags & OPf_WANT)
860 || o->op_type == OP_RETURN)
865 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
867 switch (o->op_type) {
869 scalar(cBINOPo->op_first);
874 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
878 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
879 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
880 deprecate_old("implicit split to @_");
888 if (o->op_flags & OPf_KIDS) {
889 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
895 kid = cLISTOPo->op_first;
897 while ((kid = kid->op_sibling)) {
903 PL_curcop = &PL_compiling;
908 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
914 PL_curcop = &PL_compiling;
917 if (ckWARN(WARN_VOID))
918 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
925 Perl_scalarvoid(pTHX_ OP *o)
929 const char* useless = NULL;
933 PERL_ARGS_ASSERT_SCALARVOID;
935 /* trailing mad null ops don't count as "there" for void processing */
937 o->op_type != OP_NULL &&
939 o->op_sibling->op_type == OP_NULL)
942 for (sib = o->op_sibling;
943 sib && sib->op_type == OP_NULL;
944 sib = sib->op_sibling) ;
950 if (o->op_type == OP_NEXTSTATE
951 || o->op_type == OP_DBSTATE
952 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
953 || o->op_targ == OP_DBSTATE)))
954 PL_curcop = (COP*)o; /* for warning below */
956 /* assumes no premature commitment */
957 want = o->op_flags & OPf_WANT;
958 if ((want && want != OPf_WANT_SCALAR)
959 || (PL_parser && PL_parser->error_count)
960 || o->op_type == OP_RETURN)
965 if ((o->op_private & OPpTARGET_MY)
966 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
968 return scalar(o); /* As if inside SASSIGN */
971 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
973 switch (o->op_type) {
975 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
979 if (o->op_flags & OPf_STACKED)
983 if (o->op_private == 4)
1026 case OP_GETSOCKNAME:
1027 case OP_GETPEERNAME:
1032 case OP_GETPRIORITY:
1056 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1057 /* Otherwise it's "Useless use of grep iterator" */
1058 useless = OP_DESC(o);
1062 kid = cUNOPo->op_first;
1063 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1064 kid->op_type != OP_TRANS) {
1067 useless = "negative pattern binding (!~)";
1074 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1075 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1076 useless = "a variable";
1081 if (cSVOPo->op_private & OPpCONST_STRICT)
1082 no_bareword_allowed(o);
1084 if (ckWARN(WARN_VOID)) {
1086 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1087 "a constant (%"SVf")", sv));
1088 useless = SvPV_nolen(msv);
1091 useless = "a constant (undef)";
1092 if (o->op_private & OPpCONST_ARYBASE)
1094 /* don't warn on optimised away booleans, eg
1095 * use constant Foo, 5; Foo || print; */
1096 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1098 /* the constants 0 and 1 are permitted as they are
1099 conventionally used as dummies in constructs like
1100 1 while some_condition_with_side_effects; */
1101 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1103 else if (SvPOK(sv)) {
1104 /* perl4's way of mixing documentation and code
1105 (before the invention of POD) was based on a
1106 trick to mix nroff and perl code. The trick was
1107 built upon these three nroff macros being used in
1108 void context. The pink camel has the details in
1109 the script wrapman near page 319. */
1110 const char * const maybe_macro = SvPVX_const(sv);
1111 if (strnEQ(maybe_macro, "di", 2) ||
1112 strnEQ(maybe_macro, "ds", 2) ||
1113 strnEQ(maybe_macro, "ig", 2))
1118 op_null(o); /* don't execute or even remember it */
1122 o->op_type = OP_PREINC; /* pre-increment is faster */
1123 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1127 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1128 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1132 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1133 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1137 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1138 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1143 kid = cLOGOPo->op_first;
1144 if (kid->op_type == OP_NOT
1145 && (kid->op_flags & OPf_KIDS)
1147 if (o->op_type == OP_AND) {
1149 o->op_ppaddr = PL_ppaddr[OP_OR];
1151 o->op_type = OP_AND;
1152 o->op_ppaddr = PL_ppaddr[OP_AND];
1161 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1166 if (o->op_flags & OPf_STACKED)
1173 if (!(o->op_flags & OPf_KIDS))
1184 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1191 /* all requires must return a boolean value */
1192 o->op_flags &= ~OPf_WANT;
1197 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1198 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1199 deprecate_old("implicit split to @_");
1203 if (useless && ckWARN(WARN_VOID))
1204 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1209 Perl_listkids(pTHX_ OP *o)
1211 if (o && o->op_flags & OPf_KIDS) {
1213 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1220 Perl_list(pTHX_ OP *o)
1225 /* assumes no premature commitment */
1226 if (!o || (o->op_flags & OPf_WANT)
1227 || (PL_parser && PL_parser->error_count)
1228 || o->op_type == OP_RETURN)
1233 if ((o->op_private & OPpTARGET_MY)
1234 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1236 return o; /* As if inside SASSIGN */
1239 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1241 switch (o->op_type) {
1244 list(cBINOPo->op_first);
1249 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1257 if (!(o->op_flags & OPf_KIDS))
1259 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1260 list(cBINOPo->op_first);
1261 return gen_constant_list(o);
1268 kid = cLISTOPo->op_first;
1270 while ((kid = kid->op_sibling)) {
1271 if (kid->op_sibling)
1276 PL_curcop = &PL_compiling;
1280 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1281 if (kid->op_sibling)
1286 PL_curcop = &PL_compiling;
1289 /* all requires must return a boolean value */
1290 o->op_flags &= ~OPf_WANT;
1297 Perl_scalarseq(pTHX_ OP *o)
1301 const OPCODE type = o->op_type;
1303 if (type == OP_LINESEQ || type == OP_SCOPE ||
1304 type == OP_LEAVE || type == OP_LEAVETRY)
1307 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1308 if (kid->op_sibling) {
1312 PL_curcop = &PL_compiling;
1314 o->op_flags &= ~OPf_PARENS;
1315 if (PL_hints & HINT_BLOCK_SCOPE)
1316 o->op_flags |= OPf_PARENS;
1319 o = newOP(OP_STUB, 0);
1324 S_modkids(pTHX_ OP *o, I32 type)
1326 if (o && o->op_flags & OPf_KIDS) {
1328 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1334 /* Propagate lvalue ("modifiable") context to an op and its children.
1335 * 'type' represents the context type, roughly based on the type of op that
1336 * would do the modifying, although local() is represented by OP_NULL.
1337 * It's responsible for detecting things that can't be modified, flag
1338 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1339 * might have to vivify a reference in $x), and so on.
1341 * For example, "$a+1 = 2" would cause mod() to be called with o being
1342 * OP_ADD and type being OP_SASSIGN, and would output an error.
1346 Perl_mod(pTHX_ OP *o, I32 type)
1350 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1353 if (!o || (PL_parser && PL_parser->error_count))
1356 if ((o->op_private & OPpTARGET_MY)
1357 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1362 switch (o->op_type) {
1368 if (!(o->op_private & OPpCONST_ARYBASE))
1371 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1372 CopARYBASE_set(&PL_compiling,
1373 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1377 SAVECOPARYBASE(&PL_compiling);
1378 CopARYBASE_set(&PL_compiling, 0);
1380 else if (type == OP_REFGEN)
1383 Perl_croak(aTHX_ "That use of $[ is unsupported");
1386 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1390 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1391 !(o->op_flags & OPf_STACKED)) {
1392 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1393 /* The default is to set op_private to the number of children,
1394 which for a UNOP such as RV2CV is always 1. And w're using
1395 the bit for a flag in RV2CV, so we need it clear. */
1396 o->op_private &= ~1;
1397 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1398 assert(cUNOPo->op_first->op_type == OP_NULL);
1399 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1402 else if (o->op_private & OPpENTERSUB_NOMOD)
1404 else { /* lvalue subroutine call */
1405 o->op_private |= OPpLVAL_INTRO;
1406 PL_modcount = RETURN_UNLIMITED_NUMBER;
1407 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1408 /* Backward compatibility mode: */
1409 o->op_private |= OPpENTERSUB_INARGS;
1412 else { /* Compile-time error message: */
1413 OP *kid = cUNOPo->op_first;
1417 if (kid->op_type != OP_PUSHMARK) {
1418 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1420 "panic: unexpected lvalue entersub "
1421 "args: type/targ %ld:%"UVuf,
1422 (long)kid->op_type, (UV)kid->op_targ);
1423 kid = kLISTOP->op_first;
1425 while (kid->op_sibling)
1426 kid = kid->op_sibling;
1427 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1429 if (kid->op_type == OP_METHOD_NAMED
1430 || kid->op_type == OP_METHOD)
1434 NewOp(1101, newop, 1, UNOP);
1435 newop->op_type = OP_RV2CV;
1436 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1437 newop->op_first = NULL;
1438 newop->op_next = (OP*)newop;
1439 kid->op_sibling = (OP*)newop;
1440 newop->op_private |= OPpLVAL_INTRO;
1441 newop->op_private &= ~1;
1445 if (kid->op_type != OP_RV2CV)
1447 "panic: unexpected lvalue entersub "
1448 "entry via type/targ %ld:%"UVuf,
1449 (long)kid->op_type, (UV)kid->op_targ);
1450 kid->op_private |= OPpLVAL_INTRO;
1451 break; /* Postpone until runtime */
1455 kid = kUNOP->op_first;
1456 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1457 kid = kUNOP->op_first;
1458 if (kid->op_type == OP_NULL)
1460 "Unexpected constant lvalue entersub "
1461 "entry via type/targ %ld:%"UVuf,
1462 (long)kid->op_type, (UV)kid->op_targ);
1463 if (kid->op_type != OP_GV) {
1464 /* Restore RV2CV to check lvalueness */
1466 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1467 okid->op_next = kid->op_next;
1468 kid->op_next = okid;
1471 okid->op_next = NULL;
1472 okid->op_type = OP_RV2CV;
1474 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1475 okid->op_private |= OPpLVAL_INTRO;
1476 okid->op_private &= ~1;
1480 cv = GvCV(kGVOP_gv);
1490 /* grep, foreach, subcalls, refgen */
1491 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1493 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1494 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1496 : (o->op_type == OP_ENTERSUB
1497 ? "non-lvalue subroutine call"
1499 type ? PL_op_desc[type] : "local"));
1513 case OP_RIGHT_SHIFT:
1522 if (!(o->op_flags & OPf_STACKED))
1529 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1535 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1536 PL_modcount = RETURN_UNLIMITED_NUMBER;
1537 return o; /* Treat \(@foo) like ordinary list. */
1541 if (scalar_mod_type(o, type))
1543 ref(cUNOPo->op_first, o->op_type);
1547 if (type == OP_LEAVESUBLV)
1548 o->op_private |= OPpMAYBE_LVSUB;
1554 PL_modcount = RETURN_UNLIMITED_NUMBER;
1557 ref(cUNOPo->op_first, o->op_type);
1562 PL_hints |= HINT_BLOCK_SCOPE;
1577 PL_modcount = RETURN_UNLIMITED_NUMBER;
1578 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1579 return o; /* Treat \(@foo) like ordinary list. */
1580 if (scalar_mod_type(o, type))
1582 if (type == OP_LEAVESUBLV)
1583 o->op_private |= OPpMAYBE_LVSUB;
1587 if (!type) /* local() */
1588 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1589 PAD_COMPNAME_PV(o->op_targ));
1597 if (type != OP_SASSIGN)
1601 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1606 if (type == OP_LEAVESUBLV)
1607 o->op_private |= OPpMAYBE_LVSUB;
1609 pad_free(o->op_targ);
1610 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1611 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1612 if (o->op_flags & OPf_KIDS)
1613 mod(cBINOPo->op_first->op_sibling, type);
1618 ref(cBINOPo->op_first, o->op_type);
1619 if (type == OP_ENTERSUB &&
1620 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1621 o->op_private |= OPpLVAL_DEFER;
1622 if (type == OP_LEAVESUBLV)
1623 o->op_private |= OPpMAYBE_LVSUB;
1633 if (o->op_flags & OPf_KIDS)
1634 mod(cLISTOPo->op_last, type);
1639 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1641 else if (!(o->op_flags & OPf_KIDS))
1643 if (o->op_targ != OP_LIST) {
1644 mod(cBINOPo->op_first, type);
1650 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1655 if (type != OP_LEAVESUBLV)
1657 break; /* mod()ing was handled by ck_return() */
1660 /* [20011101.069] File test operators interpret OPf_REF to mean that
1661 their argument is a filehandle; thus \stat(".") should not set
1663 if (type == OP_REFGEN &&
1664 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1667 if (type != OP_LEAVESUBLV)
1668 o->op_flags |= OPf_MOD;
1670 if (type == OP_AASSIGN || type == OP_SASSIGN)
1671 o->op_flags |= OPf_SPECIAL|OPf_REF;
1672 else if (!type) { /* local() */
1675 o->op_private |= OPpLVAL_INTRO;
1676 o->op_flags &= ~OPf_SPECIAL;
1677 PL_hints |= HINT_BLOCK_SCOPE;
1682 if (ckWARN(WARN_SYNTAX)) {
1683 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1684 "Useless localization of %s", OP_DESC(o));
1688 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1689 && type != OP_LEAVESUBLV)
1690 o->op_flags |= OPf_REF;
1695 S_scalar_mod_type(const OP *o, I32 type)
1697 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1701 if (o->op_type == OP_RV2GV)
1725 case OP_RIGHT_SHIFT:
1745 S_is_handle_constructor(const OP *o, I32 numargs)
1747 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1749 switch (o->op_type) {
1757 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1770 Perl_refkids(pTHX_ OP *o, I32 type)
1772 if (o && o->op_flags & OPf_KIDS) {
1774 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1781 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1786 PERL_ARGS_ASSERT_DOREF;
1788 if (!o || (PL_parser && PL_parser->error_count))
1791 switch (o->op_type) {
1793 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1794 !(o->op_flags & OPf_STACKED)) {
1795 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1796 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1797 assert(cUNOPo->op_first->op_type == OP_NULL);
1798 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1799 o->op_flags |= OPf_SPECIAL;
1800 o->op_private &= ~1;
1805 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1806 doref(kid, type, set_op_ref);
1809 if (type == OP_DEFINED)
1810 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1811 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1814 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1815 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1816 : type == OP_RV2HV ? OPpDEREF_HV
1818 o->op_flags |= OPf_MOD;
1825 o->op_flags |= OPf_REF;
1828 if (type == OP_DEFINED)
1829 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1830 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1836 o->op_flags |= OPf_REF;
1841 if (!(o->op_flags & OPf_KIDS))
1843 doref(cBINOPo->op_first, type, set_op_ref);
1847 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1848 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1849 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1850 : type == OP_RV2HV ? OPpDEREF_HV
1852 o->op_flags |= OPf_MOD;
1862 if (!(o->op_flags & OPf_KIDS))
1864 doref(cLISTOPo->op_last, type, set_op_ref);
1874 S_dup_attrlist(pTHX_ OP *o)
1879 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1881 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1882 * where the first kid is OP_PUSHMARK and the remaining ones
1883 * are OP_CONST. We need to push the OP_CONST values.
1885 if (o->op_type == OP_CONST)
1886 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1888 else if (o->op_type == OP_NULL)
1892 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1894 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1895 if (o->op_type == OP_CONST)
1896 rop = append_elem(OP_LIST, rop,
1897 newSVOP(OP_CONST, o->op_flags,
1898 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1905 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1910 PERL_ARGS_ASSERT_APPLY_ATTRS;
1912 /* fake up C<use attributes $pkg,$rv,@attrs> */
1913 ENTER; /* need to protect against side-effects of 'use' */
1914 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1916 #define ATTRSMODULE "attributes"
1917 #define ATTRSMODULE_PM "attributes.pm"
1920 /* Don't force the C<use> if we don't need it. */
1921 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1922 if (svp && *svp != &PL_sv_undef)
1923 NOOP; /* already in %INC */
1925 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1926 newSVpvs(ATTRSMODULE), NULL);
1929 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1930 newSVpvs(ATTRSMODULE),
1932 prepend_elem(OP_LIST,
1933 newSVOP(OP_CONST, 0, stashsv),
1934 prepend_elem(OP_LIST,
1935 newSVOP(OP_CONST, 0,
1937 dup_attrlist(attrs))));
1943 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1946 OP *pack, *imop, *arg;
1949 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1954 assert(target->op_type == OP_PADSV ||
1955 target->op_type == OP_PADHV ||
1956 target->op_type == OP_PADAV);
1958 /* Ensure that attributes.pm is loaded. */
1959 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1961 /* Need package name for method call. */
1962 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1964 /* Build up the real arg-list. */
1965 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1967 arg = newOP(OP_PADSV, 0);
1968 arg->op_targ = target->op_targ;
1969 arg = prepend_elem(OP_LIST,
1970 newSVOP(OP_CONST, 0, stashsv),
1971 prepend_elem(OP_LIST,
1972 newUNOP(OP_REFGEN, 0,
1973 mod(arg, OP_REFGEN)),
1974 dup_attrlist(attrs)));
1976 /* Fake up a method call to import */
1977 meth = newSVpvs_share("import");
1978 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1979 append_elem(OP_LIST,
1980 prepend_elem(OP_LIST, pack, list(arg)),
1981 newSVOP(OP_METHOD_NAMED, 0, meth)));
1982 imop->op_private |= OPpENTERSUB_NOMOD;
1984 /* Combine the ops. */
1985 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1989 =notfor apidoc apply_attrs_string
1991 Attempts to apply a list of attributes specified by the C<attrstr> and
1992 C<len> arguments to the subroutine identified by the C<cv> argument which
1993 is expected to be associated with the package identified by the C<stashpv>
1994 argument (see L<attributes>). It gets this wrong, though, in that it
1995 does not correctly identify the boundaries of the individual attribute
1996 specifications within C<attrstr>. This is not really intended for the
1997 public API, but has to be listed here for systems such as AIX which
1998 need an explicit export list for symbols. (It's called from XS code
1999 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2000 to respect attribute syntax properly would be welcome.
2006 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2007 const char *attrstr, STRLEN len)
2011 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2014 len = strlen(attrstr);
2018 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2020 const char * const sstr = attrstr;
2021 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2022 attrs = append_elem(OP_LIST, attrs,
2023 newSVOP(OP_CONST, 0,
2024 newSVpvn(sstr, attrstr-sstr)));
2028 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2029 newSVpvs(ATTRSMODULE),
2030 NULL, prepend_elem(OP_LIST,
2031 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2032 prepend_elem(OP_LIST,
2033 newSVOP(OP_CONST, 0,
2034 newRV(MUTABLE_SV(cv))),
2039 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2044 PERL_ARGS_ASSERT_MY_KID;
2046 if (!o || (PL_parser && PL_parser->error_count))
2050 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2051 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2055 if (type == OP_LIST) {
2057 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2058 my_kid(kid, attrs, imopsp);
2059 } else if (type == OP_UNDEF
2065 } else if (type == OP_RV2SV || /* "our" declaration */
2067 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2068 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2069 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2071 PL_parser->in_my == KEY_our
2073 : PL_parser->in_my == KEY_state ? "state" : "my"));
2075 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2076 PL_parser->in_my = FALSE;
2077 PL_parser->in_my_stash = NULL;
2078 apply_attrs(GvSTASH(gv),
2079 (type == OP_RV2SV ? GvSV(gv) :
2080 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2081 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2084 o->op_private |= OPpOUR_INTRO;
2087 else if (type != OP_PADSV &&
2090 type != OP_PUSHMARK)
2092 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2094 PL_parser->in_my == KEY_our
2096 : PL_parser->in_my == KEY_state ? "state" : "my"));
2099 else if (attrs && type != OP_PUSHMARK) {
2102 PL_parser->in_my = FALSE;
2103 PL_parser->in_my_stash = NULL;
2105 /* check for C<my Dog $spot> when deciding package */
2106 stash = PAD_COMPNAME_TYPE(o->op_targ);
2108 stash = PL_curstash;
2109 apply_attrs_my(stash, o, attrs, imopsp);
2111 o->op_flags |= OPf_MOD;
2112 o->op_private |= OPpLVAL_INTRO;
2113 if (PL_parser->in_my == KEY_state)
2114 o->op_private |= OPpPAD_STATE;
2119 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2123 int maybe_scalar = 0;
2125 PERL_ARGS_ASSERT_MY_ATTRS;
2127 /* [perl #17376]: this appears to be premature, and results in code such as
2128 C< our(%x); > executing in list mode rather than void mode */
2130 if (o->op_flags & OPf_PARENS)
2140 o = my_kid(o, attrs, &rops);
2142 if (maybe_scalar && o->op_type == OP_PADSV) {
2143 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2144 o->op_private |= OPpLVAL_INTRO;
2147 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2149 PL_parser->in_my = FALSE;
2150 PL_parser->in_my_stash = NULL;
2155 Perl_my(pTHX_ OP *o)
2157 PERL_ARGS_ASSERT_MY;
2159 return my_attrs(o, NULL);
2163 Perl_sawparens(pTHX_ OP *o)
2165 PERL_UNUSED_CONTEXT;
2167 o->op_flags |= OPf_PARENS;
2172 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2176 const OPCODE ltype = left->op_type;
2177 const OPCODE rtype = right->op_type;
2179 PERL_ARGS_ASSERT_BIND_MATCH;
2181 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2182 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2184 const char * const desc
2185 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2186 ? (int)rtype : OP_MATCH];
2187 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2188 ? "@array" : "%hash");
2189 Perl_warner(aTHX_ packWARN(WARN_MISC),
2190 "Applying %s to %s will act on scalar(%s)",
2191 desc, sample, sample);
2194 if (rtype == OP_CONST &&
2195 cSVOPx(right)->op_private & OPpCONST_BARE &&
2196 cSVOPx(right)->op_private & OPpCONST_STRICT)
2198 no_bareword_allowed(right);
2201 ismatchop = rtype == OP_MATCH ||
2202 rtype == OP_SUBST ||
2204 if (ismatchop && right->op_private & OPpTARGET_MY) {
2206 right->op_private &= ~OPpTARGET_MY;
2208 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2211 right->op_flags |= OPf_STACKED;
2212 if (rtype != OP_MATCH &&
2213 ! (rtype == OP_TRANS &&
2214 right->op_private & OPpTRANS_IDENTICAL))
2215 newleft = mod(left, rtype);
2218 if (right->op_type == OP_TRANS)
2219 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2221 o = prepend_elem(rtype, scalar(newleft), right);
2223 return newUNOP(OP_NOT, 0, scalar(o));
2227 return bind_match(type, left,
2228 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2232 Perl_invert(pTHX_ OP *o)
2236 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2240 Perl_scope(pTHX_ OP *o)
2244 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2245 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2246 o->op_type = OP_LEAVE;
2247 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2249 else if (o->op_type == OP_LINESEQ) {
2251 o->op_type = OP_SCOPE;
2252 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2253 kid = ((LISTOP*)o)->op_first;
2254 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2257 /* The following deals with things like 'do {1 for 1}' */
2258 kid = kid->op_sibling;
2260 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2265 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2271 Perl_block_start(pTHX_ int full)
2274 const int retval = PL_savestack_ix;
2275 pad_block_start(full);
2277 PL_hints &= ~HINT_BLOCK_SCOPE;
2278 SAVECOMPILEWARNINGS();
2279 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2284 Perl_block_end(pTHX_ I32 floor, OP *seq)
2287 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2288 OP* const retval = scalarseq(seq);
2290 CopHINTS_set(&PL_compiling, PL_hints);
2292 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2301 const PADOFFSET offset = pad_findmy("$_");
2302 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2303 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2306 OP * const o = newOP(OP_PADSV, 0);
2307 o->op_targ = offset;
2313 Perl_newPROG(pTHX_ OP *o)
2317 PERL_ARGS_ASSERT_NEWPROG;
2322 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2323 ((PL_in_eval & EVAL_KEEPERR)
2324 ? OPf_SPECIAL : 0), o);
2325 PL_eval_start = linklist(PL_eval_root);
2326 PL_eval_root->op_private |= OPpREFCOUNTED;
2327 OpREFCNT_set(PL_eval_root, 1);
2328 PL_eval_root->op_next = 0;
2329 CALL_PEEP(PL_eval_start);
2332 if (o->op_type == OP_STUB) {
2333 PL_comppad_name = 0;
2335 S_op_destroy(aTHX_ o);
2338 PL_main_root = scope(sawparens(scalarvoid(o)));
2339 PL_curcop = &PL_compiling;
2340 PL_main_start = LINKLIST(PL_main_root);
2341 PL_main_root->op_private |= OPpREFCOUNTED;
2342 OpREFCNT_set(PL_main_root, 1);
2343 PL_main_root->op_next = 0;
2344 CALL_PEEP(PL_main_start);
2347 /* Register with debugger */
2350 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2354 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2356 call_sv(MUTABLE_SV(cv), G_DISCARD);
2363 Perl_localize(pTHX_ OP *o, I32 lex)
2367 PERL_ARGS_ASSERT_LOCALIZE;
2369 if (o->op_flags & OPf_PARENS)
2370 /* [perl #17376]: this appears to be premature, and results in code such as
2371 C< our(%x); > executing in list mode rather than void mode */
2378 if ( PL_parser->bufptr > PL_parser->oldbufptr
2379 && PL_parser->bufptr[-1] == ','
2380 && ckWARN(WARN_PARENTHESIS))
2382 char *s = PL_parser->bufptr;
2385 /* some heuristics to detect a potential error */
2386 while (*s && (strchr(", \t\n", *s)))
2390 if (*s && strchr("@$%*", *s) && *++s
2391 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2394 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2396 while (*s && (strchr(", \t\n", *s)))
2402 if (sigil && (*s == ';' || *s == '=')) {
2403 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2404 "Parentheses missing around \"%s\" list",
2406 ? (PL_parser->in_my == KEY_our
2408 : PL_parser->in_my == KEY_state
2418 o = mod(o, OP_NULL); /* a bit kludgey */
2419 PL_parser->in_my = FALSE;
2420 PL_parser->in_my_stash = NULL;
2425 Perl_jmaybe(pTHX_ OP *o)
2427 PERL_ARGS_ASSERT_JMAYBE;
2429 if (o->op_type == OP_LIST) {
2431 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2432 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2438 Perl_fold_constants(pTHX_ register OP *o)
2441 register OP * VOL curop;
2443 VOL I32 type = o->op_type;
2448 SV * const oldwarnhook = PL_warnhook;
2449 SV * const olddiehook = PL_diehook;
2453 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2455 if (PL_opargs[type] & OA_RETSCALAR)
2457 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2458 o->op_targ = pad_alloc(type, SVs_PADTMP);
2460 /* integerize op, unless it happens to be C<-foo>.
2461 * XXX should pp_i_negate() do magic string negation instead? */
2462 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2463 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2464 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2466 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2469 if (!(PL_opargs[type] & OA_FOLDCONST))
2474 /* XXX might want a ck_negate() for this */
2475 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2486 /* XXX what about the numeric ops? */
2487 if (PL_hints & HINT_LOCALE)
2492 if (PL_parser && PL_parser->error_count)
2493 goto nope; /* Don't try to run w/ errors */
2495 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2496 const OPCODE type = curop->op_type;
2497 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2499 type != OP_SCALAR &&
2501 type != OP_PUSHMARK)
2507 curop = LINKLIST(o);
2508 old_next = o->op_next;
2512 oldscope = PL_scopestack_ix;
2513 create_eval_scope(G_FAKINGEVAL);
2515 /* Verify that we don't need to save it: */
2516 assert(PL_curcop == &PL_compiling);
2517 StructCopy(&PL_compiling, ¬_compiling, COP);
2518 PL_curcop = ¬_compiling;
2519 /* The above ensures that we run with all the correct hints of the
2520 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2521 assert(IN_PERL_RUNTIME);
2522 PL_warnhook = PERL_WARNHOOK_FATAL;
2529 sv = *(PL_stack_sp--);
2530 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2531 pad_swipe(o->op_targ, FALSE);
2532 else if (SvTEMP(sv)) { /* grab mortal temp? */
2533 SvREFCNT_inc_simple_void(sv);
2538 /* Something tried to die. Abandon constant folding. */
2539 /* Pretend the error never happened. */
2541 o->op_next = old_next;
2545 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2546 PL_warnhook = oldwarnhook;
2547 PL_diehook = olddiehook;
2548 /* XXX note that this croak may fail as we've already blown away
2549 * the stack - eg any nested evals */
2550 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2553 PL_warnhook = oldwarnhook;
2554 PL_diehook = olddiehook;
2555 PL_curcop = &PL_compiling;
2557 if (PL_scopestack_ix > oldscope)
2558 delete_eval_scope();
2567 if (type == OP_RV2GV)
2568 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2570 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2571 op_getmad(o,newop,'f');
2579 Perl_gen_constant_list(pTHX_ register OP *o)
2583 const I32 oldtmps_floor = PL_tmps_floor;
2586 if (PL_parser && PL_parser->error_count)
2587 return o; /* Don't attempt to run with errors */
2589 PL_op = curop = LINKLIST(o);
2595 assert (!(curop->op_flags & OPf_SPECIAL));
2596 assert(curop->op_type == OP_RANGE);
2598 PL_tmps_floor = oldtmps_floor;
2600 o->op_type = OP_RV2AV;
2601 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2602 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2603 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2604 o->op_opt = 0; /* needs to be revisited in peep() */
2605 curop = ((UNOP*)o)->op_first;
2606 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2608 op_getmad(curop,o,'O');
2617 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2620 if (!o || o->op_type != OP_LIST)
2621 o = newLISTOP(OP_LIST, 0, o, NULL);
2623 o->op_flags &= ~OPf_WANT;
2625 if (!(PL_opargs[type] & OA_MARK))
2626 op_null(cLISTOPo->op_first);
2628 o->op_type = (OPCODE)type;
2629 o->op_ppaddr = PL_ppaddr[type];
2630 o->op_flags |= flags;
2632 o = CHECKOP(type, o);
2633 if (o->op_type != (unsigned)type)
2636 return fold_constants(o);
2639 /* List constructors */
2642 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2650 if (first->op_type != (unsigned)type
2651 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2653 return newLISTOP(type, 0, first, last);
2656 if (first->op_flags & OPf_KIDS)
2657 ((LISTOP*)first)->op_last->op_sibling = last;
2659 first->op_flags |= OPf_KIDS;
2660 ((LISTOP*)first)->op_first = last;
2662 ((LISTOP*)first)->op_last = last;
2667 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2675 if (first->op_type != (unsigned)type)
2676 return prepend_elem(type, (OP*)first, (OP*)last);
2678 if (last->op_type != (unsigned)type)
2679 return append_elem(type, (OP*)first, (OP*)last);
2681 first->op_last->op_sibling = last->op_first;
2682 first->op_last = last->op_last;
2683 first->op_flags |= (last->op_flags & OPf_KIDS);
2686 if (last->op_first && first->op_madprop) {
2687 MADPROP *mp = last->op_first->op_madprop;
2689 while (mp->mad_next)
2691 mp->mad_next = first->op_madprop;
2694 last->op_first->op_madprop = first->op_madprop;
2697 first->op_madprop = last->op_madprop;
2698 last->op_madprop = 0;
2701 S_op_destroy(aTHX_ (OP*)last);
2707 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2715 if (last->op_type == (unsigned)type) {
2716 if (type == OP_LIST) { /* already a PUSHMARK there */
2717 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2718 ((LISTOP*)last)->op_first->op_sibling = first;
2719 if (!(first->op_flags & OPf_PARENS))
2720 last->op_flags &= ~OPf_PARENS;
2723 if (!(last->op_flags & OPf_KIDS)) {
2724 ((LISTOP*)last)->op_last = first;
2725 last->op_flags |= OPf_KIDS;
2727 first->op_sibling = ((LISTOP*)last)->op_first;
2728 ((LISTOP*)last)->op_first = first;
2730 last->op_flags |= OPf_KIDS;
2734 return newLISTOP(type, 0, first, last);
2742 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2745 Newxz(tk, 1, TOKEN);
2746 tk->tk_type = (OPCODE)optype;
2747 tk->tk_type = 12345;
2749 tk->tk_mad = madprop;
2754 Perl_token_free(pTHX_ TOKEN* tk)
2756 PERL_ARGS_ASSERT_TOKEN_FREE;
2758 if (tk->tk_type != 12345)
2760 mad_free(tk->tk_mad);
2765 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2770 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2772 if (tk->tk_type != 12345) {
2773 Perl_warner(aTHX_ packWARN(WARN_MISC),
2774 "Invalid TOKEN object ignored");
2781 /* faked up qw list? */
2783 tm->mad_type == MAD_SV &&
2784 SvPVX((const SV *)tm->mad_val)[0] == 'q')
2791 /* pretend constant fold didn't happen? */
2792 if (mp->mad_key == 'f' &&
2793 (o->op_type == OP_CONST ||
2794 o->op_type == OP_GV) )
2796 token_getmad(tk,(OP*)mp->mad_val,slot);
2810 if (mp->mad_key == 'X')
2811 mp->mad_key = slot; /* just change the first one */
2821 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2830 /* pretend constant fold didn't happen? */
2831 if (mp->mad_key == 'f' &&
2832 (o->op_type == OP_CONST ||
2833 o->op_type == OP_GV) )
2835 op_getmad(from,(OP*)mp->mad_val,slot);
2842 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2845 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2851 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2860 /* pretend constant fold didn't happen? */
2861 if (mp->mad_key == 'f' &&
2862 (o->op_type == OP_CONST ||
2863 o->op_type == OP_GV) )
2865 op_getmad(from,(OP*)mp->mad_val,slot);
2872 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2875 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2879 PerlIO_printf(PerlIO_stderr(),
2880 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2886 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2904 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2908 addmad(tm, &(o->op_madprop), slot);
2912 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2933 Perl_newMADsv(pTHX_ char key, SV* sv)
2935 PERL_ARGS_ASSERT_NEWMADSV;
2937 return newMADPROP(key, MAD_SV, sv, 0);
2941 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2944 Newxz(mp, 1, MADPROP);
2947 mp->mad_vlen = vlen;
2948 mp->mad_type = type;
2950 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2955 Perl_mad_free(pTHX_ MADPROP* mp)
2957 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2961 mad_free(mp->mad_next);
2962 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2963 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2964 switch (mp->mad_type) {
2968 Safefree((char*)mp->mad_val);
2971 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2972 op_free((OP*)mp->mad_val);
2975 sv_free(MUTABLE_SV(mp->mad_val));
2978 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2987 Perl_newNULLLIST(pTHX)
2989 return newOP(OP_STUB, 0);
2993 Perl_force_list(pTHX_ OP *o)
2995 if (!o || o->op_type != OP_LIST)
2996 o = newLISTOP(OP_LIST, 0, o, NULL);
3002 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3007 NewOp(1101, listop, 1, LISTOP);
3009 listop->op_type = (OPCODE)type;
3010 listop->op_ppaddr = PL_ppaddr[type];
3013 listop->op_flags = (U8)flags;
3017 else if (!first && last)
3020 first->op_sibling = last;
3021 listop->op_first = first;
3022 listop->op_last = last;
3023 if (type == OP_LIST) {
3024 OP* const pushop = newOP(OP_PUSHMARK, 0);
3025 pushop->op_sibling = first;
3026 listop->op_first = pushop;
3027 listop->op_flags |= OPf_KIDS;
3029 listop->op_last = pushop;
3032 return CHECKOP(type, listop);
3036 Perl_newOP(pTHX_ I32 type, I32 flags)
3040 NewOp(1101, o, 1, OP);
3041 o->op_type = (OPCODE)type;
3042 o->op_ppaddr = PL_ppaddr[type];
3043 o->op_flags = (U8)flags;
3045 o->op_latefreed = 0;
3049 o->op_private = (U8)(0 | (flags >> 8));
3050 if (PL_opargs[type] & OA_RETSCALAR)
3052 if (PL_opargs[type] & OA_TARGET)
3053 o->op_targ = pad_alloc(type, SVs_PADTMP);
3054 return CHECKOP(type, o);
3058 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3064 first = newOP(OP_STUB, 0);
3065 if (PL_opargs[type] & OA_MARK)
3066 first = force_list(first);
3068 NewOp(1101, unop, 1, UNOP);
3069 unop->op_type = (OPCODE)type;
3070 unop->op_ppaddr = PL_ppaddr[type];
3071 unop->op_first = first;
3072 unop->op_flags = (U8)(flags | OPf_KIDS);
3073 unop->op_private = (U8)(1 | (flags >> 8));
3074 unop = (UNOP*) CHECKOP(type, unop);
3078 return fold_constants((OP *) unop);
3082 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3086 NewOp(1101, binop, 1, BINOP);
3089 first = newOP(OP_NULL, 0);
3091 binop->op_type = (OPCODE)type;
3092 binop->op_ppaddr = PL_ppaddr[type];
3093 binop->op_first = first;
3094 binop->op_flags = (U8)(flags | OPf_KIDS);
3097 binop->op_private = (U8)(1 | (flags >> 8));
3100 binop->op_private = (U8)(2 | (flags >> 8));
3101 first->op_sibling = last;
3104 binop = (BINOP*)CHECKOP(type, binop);
3105 if (binop->op_next || binop->op_type != (OPCODE)type)
3108 binop->op_last = binop->op_first->op_sibling;
3110 return fold_constants((OP *)binop);
3113 static int uvcompare(const void *a, const void *b)
3114 __attribute__nonnull__(1)
3115 __attribute__nonnull__(2)
3116 __attribute__pure__;
3117 static int uvcompare(const void *a, const void *b)
3119 if (*((const UV *)a) < (*(const UV *)b))
3121 if (*((const UV *)a) > (*(const UV *)b))
3123 if (*((const UV *)a+1) < (*(const UV *)b+1))
3125 if (*((const UV *)a+1) > (*(const UV *)b+1))
3131 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3134 SV * const tstr = ((SVOP*)expr)->op_sv;
3137 (repl->op_type == OP_NULL)
3138 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3140 ((SVOP*)repl)->op_sv;
3143 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3144 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3148 register short *tbl;
3150 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3151 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3152 I32 del = o->op_private & OPpTRANS_DELETE;
3155 PERL_ARGS_ASSERT_PMTRANS;
3157 PL_hints |= HINT_BLOCK_SCOPE;
3160 o->op_private |= OPpTRANS_FROM_UTF;
3163 o->op_private |= OPpTRANS_TO_UTF;
3165 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3166 SV* const listsv = newSVpvs("# comment\n");
3168 const U8* tend = t + tlen;
3169 const U8* rend = r + rlen;
3183 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3184 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3187 const U32 flags = UTF8_ALLOW_DEFAULT;
3191 t = tsave = bytes_to_utf8(t, &len);
3194 if (!to_utf && rlen) {
3196 r = rsave = bytes_to_utf8(r, &len);
3200 /* There are several snags with this code on EBCDIC:
3201 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3202 2. scan_const() in toke.c has encoded chars in native encoding which makes
3203 ranges at least in EBCDIC 0..255 range the bottom odd.
3207 U8 tmpbuf[UTF8_MAXBYTES+1];
3210 Newx(cp, 2*tlen, UV);
3212 transv = newSVpvs("");
3214 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3216 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3218 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3222 cp[2*i+1] = cp[2*i];
3226 qsort(cp, i, 2*sizeof(UV), uvcompare);
3227 for (j = 0; j < i; j++) {
3229 diff = val - nextmin;
3231 t = uvuni_to_utf8(tmpbuf,nextmin);
3232 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3234 U8 range_mark = UTF_TO_NATIVE(0xff);
3235 t = uvuni_to_utf8(tmpbuf, val - 1);
3236 sv_catpvn(transv, (char *)&range_mark, 1);
3237 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3244 t = uvuni_to_utf8(tmpbuf,nextmin);
3245 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3247 U8 range_mark = UTF_TO_NATIVE(0xff);
3248 sv_catpvn(transv, (char *)&range_mark, 1);
3250 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3251 UNICODE_ALLOW_SUPER);
3252 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3253 t = (const U8*)SvPVX_const(transv);
3254 tlen = SvCUR(transv);
3258 else if (!rlen && !del) {
3259 r = t; rlen = tlen; rend = tend;
3262 if ((!rlen && !del) || t == r ||
3263 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3265 o->op_private |= OPpTRANS_IDENTICAL;
3269 while (t < tend || tfirst <= tlast) {
3270 /* see if we need more "t" chars */
3271 if (tfirst > tlast) {
3272 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3274 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3276 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3283 /* now see if we need more "r" chars */
3284 if (rfirst > rlast) {
3286 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3288 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3290 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3299 rfirst = rlast = 0xffffffff;
3303 /* now see which range will peter our first, if either. */
3304 tdiff = tlast - tfirst;
3305 rdiff = rlast - rfirst;
3312 if (rfirst == 0xffffffff) {
3313 diff = tdiff; /* oops, pretend rdiff is infinite */
3315 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3316 (long)tfirst, (long)tlast);
3318 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3322 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3323 (long)tfirst, (long)(tfirst + diff),
3326 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3327 (long)tfirst, (long)rfirst);
3329 if (rfirst + diff > max)
3330 max = rfirst + diff;
3332 grows = (tfirst < rfirst &&
3333 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3345 else if (max > 0xff)
3350 PerlMemShared_free(cPVOPo->op_pv);
3351 cPVOPo->op_pv = NULL;
3353 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3355 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3356 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3357 PAD_SETSV(cPADOPo->op_padix, swash);
3360 cSVOPo->op_sv = swash;
3362 SvREFCNT_dec(listsv);
3363 SvREFCNT_dec(transv);
3365 if (!del && havefinal && rlen)
3366 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3367 newSVuv((UV)final), 0);
3370 o->op_private |= OPpTRANS_GROWS;
3376 op_getmad(expr,o,'e');
3377 op_getmad(repl,o,'r');
3385 tbl = (short*)cPVOPo->op_pv;
3387 Zero(tbl, 256, short);
3388 for (i = 0; i < (I32)tlen; i++)
3390 for (i = 0, j = 0; i < 256; i++) {
3392 if (j >= (I32)rlen) {
3401 if (i < 128 && r[j] >= 128)
3411 o->op_private |= OPpTRANS_IDENTICAL;
3413 else if (j >= (I32)rlen)
3418 PerlMemShared_realloc(tbl,
3419 (0x101+rlen-j) * sizeof(short));
3420 cPVOPo->op_pv = (char*)tbl;
3422 tbl[0x100] = (short)(rlen - j);
3423 for (i=0; i < (I32)rlen - j; i++)
3424 tbl[0x101+i] = r[j+i];
3428 if (!rlen && !del) {
3431 o->op_private |= OPpTRANS_IDENTICAL;
3433 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3434 o->op_private |= OPpTRANS_IDENTICAL;
3436 for (i = 0; i < 256; i++)
3438 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3439 if (j >= (I32)rlen) {
3441 if (tbl[t[i]] == -1)
3447 if (tbl[t[i]] == -1) {
3448 if (t[i] < 128 && r[j] >= 128)
3455 o->op_private |= OPpTRANS_GROWS;
3457 op_getmad(expr,o,'e');
3458 op_getmad(repl,o,'r');
3468 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3473 NewOp(1101, pmop, 1, PMOP);
3474 pmop->op_type = (OPCODE)type;
3475 pmop->op_ppaddr = PL_ppaddr[type];
3476 pmop->op_flags = (U8)flags;
3477 pmop->op_private = (U8)(0 | (flags >> 8));
3479 if (PL_hints & HINT_RE_TAINT)
3480 pmop->op_pmflags |= PMf_RETAINT;
3481 if (PL_hints & HINT_LOCALE)
3482 pmop->op_pmflags |= PMf_LOCALE;
3486 assert(SvPOK(PL_regex_pad[0]));
3487 if (SvCUR(PL_regex_pad[0])) {
3488 /* Pop off the "packed" IV from the end. */
3489 SV *const repointer_list = PL_regex_pad[0];
3490 const char *p = SvEND(repointer_list) - sizeof(IV);
3491 const IV offset = *((IV*)p);
3493 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3495 SvEND_set(repointer_list, p);
3497 pmop->op_pmoffset = offset;
3498 /* This slot should be free, so assert this: */
3499 assert(PL_regex_pad[offset] == &PL_sv_undef);
3501 SV * const repointer = &PL_sv_undef;
3502 av_push(PL_regex_padav, repointer);
3503 pmop->op_pmoffset = av_len(PL_regex_padav);
3504 PL_regex_pad = AvARRAY(PL_regex_padav);
3508 return CHECKOP(type, pmop);
3511 /* Given some sort of match op o, and an expression expr containing a
3512 * pattern, either compile expr into a regex and attach it to o (if it's
3513 * constant), or convert expr into a runtime regcomp op sequence (if it's
3516 * isreg indicates that the pattern is part of a regex construct, eg
3517 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3518 * split "pattern", which aren't. In the former case, expr will be a list
3519 * if the pattern contains more than one term (eg /a$b/) or if it contains
3520 * a replacement, ie s/// or tr///.
3524 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3529 I32 repl_has_vars = 0;
3533 PERL_ARGS_ASSERT_PMRUNTIME;
3535 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3536 /* last element in list is the replacement; pop it */
3538 repl = cLISTOPx(expr)->op_last;
3539 kid = cLISTOPx(expr)->op_first;
3540 while (kid->op_sibling != repl)
3541 kid = kid->op_sibling;
3542 kid->op_sibling = NULL;
3543 cLISTOPx(expr)->op_last = kid;
3546 if (isreg && expr->op_type == OP_LIST &&
3547 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3549 /* convert single element list to element */
3550 OP* const oe = expr;
3551 expr = cLISTOPx(oe)->op_first->op_sibling;
3552 cLISTOPx(oe)->op_first->op_sibling = NULL;
3553 cLISTOPx(oe)->op_last = NULL;
3557 if (o->op_type == OP_TRANS) {
3558 return pmtrans(o, expr, repl);
3561 reglist = isreg && expr->op_type == OP_LIST;
3565 PL_hints |= HINT_BLOCK_SCOPE;
3568 if (expr->op_type == OP_CONST) {
3569 SV *pat = ((SVOP*)expr)->op_sv;
3570 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3572 if (o->op_flags & OPf_SPECIAL)
3573 pm_flags |= RXf_SPLIT;
3576 assert (SvUTF8(pat));
3577 } else if (SvUTF8(pat)) {
3578 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3579 trapped in use 'bytes'? */
3580 /* Make a copy of the octet sequence, but without the flag on, as
3581 the compiler now honours the SvUTF8 flag on pat. */
3583 const char *const p = SvPV(pat, len);
3584 pat = newSVpvn_flags(p, len, SVs_TEMP);
3587 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3590 op_getmad(expr,(OP*)pm,'e');
3596 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3597 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3599 : OP_REGCMAYBE),0,expr);
3601 NewOp(1101, rcop, 1, LOGOP);
3602 rcop->op_type = OP_REGCOMP;
3603 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3604 rcop->op_first = scalar(expr);
3605 rcop->op_flags |= OPf_KIDS
3606 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3607 | (reglist ? OPf_STACKED : 0);
3608 rcop->op_private = 1;
3611 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3613 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3616 /* establish postfix order */
3617 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3619 rcop->op_next = expr;
3620 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3623 rcop->op_next = LINKLIST(expr);
3624 expr->op_next = (OP*)rcop;
3627 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3632 if (pm->op_pmflags & PMf_EVAL) {
3634 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3635 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3637 else if (repl->op_type == OP_CONST)
3641 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3642 if (curop->op_type == OP_SCOPE
3643 || curop->op_type == OP_LEAVE
3644 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3645 if (curop->op_type == OP_GV) {
3646 GV * const gv = cGVOPx_gv(curop);
3648 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3651 else if (curop->op_type == OP_RV2CV)
3653 else if (curop->op_type == OP_RV2SV ||
3654 curop->op_type == OP_RV2AV ||
3655 curop->op_type == OP_RV2HV ||
3656 curop->op_type == OP_RV2GV) {
3657 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3660 else if (curop->op_type == OP_PADSV ||
3661 curop->op_type == OP_PADAV ||
3662 curop->op_type == OP_PADHV ||
3663 curop->op_type == OP_PADANY)
3667 else if (curop->op_type == OP_PUSHRE)
3668 NOOP; /* Okay here, dangerous in newASSIGNOP */
3678 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3680 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3681 prepend_elem(o->op_type, scalar(repl), o);
3684 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3685 pm->op_pmflags |= PMf_MAYBE_CONST;
3687 NewOp(1101, rcop, 1, LOGOP);
3688 rcop->op_type = OP_SUBSTCONT;
3689 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3690 rcop->op_first = scalar(repl);
3691 rcop->op_flags |= OPf_KIDS;
3692 rcop->op_private = 1;
3695 /* establish postfix order */
3696 rcop->op_next = LINKLIST(repl);
3697 repl->op_next = (OP*)rcop;
3699 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3700 assert(!(pm->op_pmflags & PMf_ONCE));
3701 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3710 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3715 PERL_ARGS_ASSERT_NEWSVOP;
3717 NewOp(1101, svop, 1, SVOP);
3718 svop->op_type = (OPCODE)type;
3719 svop->op_ppaddr = PL_ppaddr[type];
3721 svop->op_next = (OP*)svop;
3722 svop->op_flags = (U8)flags;
3723 if (PL_opargs[type] & OA_RETSCALAR)
3725 if (PL_opargs[type] & OA_TARGET)
3726 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3727 return CHECKOP(type, svop);
3732 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3737 PERL_ARGS_ASSERT_NEWPADOP;
3739 NewOp(1101, padop, 1, PADOP);
3740 padop->op_type = (OPCODE)type;
3741 padop->op_ppaddr = PL_ppaddr[type];
3742 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3743 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3744 PAD_SETSV(padop->op_padix, sv);
3747 padop->op_next = (OP*)padop;
3748 padop->op_flags = (U8)flags;
3749 if (PL_opargs[type] & OA_RETSCALAR)
3751 if (PL_opargs[type] & OA_TARGET)
3752 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3753 return CHECKOP(type, padop);
3758 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3762 PERL_ARGS_ASSERT_NEWGVOP;
3766 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3768 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3773 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3777 NewOp(1101, pvop, 1, PVOP);
3778 pvop->op_type = (OPCODE)type;
3779 pvop->op_ppaddr = PL_ppaddr[type];
3781 pvop->op_next = (OP*)pvop;
3782 pvop->op_flags = (U8)flags;
3783 if (PL_opargs[type] & OA_RETSCALAR)
3785 if (PL_opargs[type] & OA_TARGET)
3786 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3787 return CHECKOP(type, pvop);
3795 Perl_package(pTHX_ OP *o)
3798 SV *const sv = cSVOPo->op_sv;
3803 PERL_ARGS_ASSERT_PACKAGE;
3805 save_hptr(&PL_curstash);
3806 save_item(PL_curstname);
3808 PL_curstash = gv_stashsv(sv, GV_ADD);
3810 sv_setsv(PL_curstname, sv);
3812 PL_hints |= HINT_BLOCK_SCOPE;
3813 PL_parser->copline = NOLINE;
3814 PL_parser->expect = XSTATE;
3819 if (!PL_madskills) {
3824 pegop = newOP(OP_NULL,0);
3825 op_getmad(o,pegop,'P');
3835 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3842 OP *pegop = newOP(OP_NULL,0);
3845 PERL_ARGS_ASSERT_UTILIZE;
3847 if (idop->op_type != OP_CONST)
3848 Perl_croak(aTHX_ "Module name must be constant");
3851 op_getmad(idop,pegop,'U');
3856 SV * const vesv = ((SVOP*)version)->op_sv;
3859 op_getmad(version,pegop,'V');
3860 if (!arg && !SvNIOKp(vesv)) {
3867 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3868 Perl_croak(aTHX_ "Version number must be constant number");
3870 /* Make copy of idop so we don't free it twice */
3871 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3873 /* Fake up a method call to VERSION */
3874 meth = newSVpvs_share("VERSION");
3875 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3876 append_elem(OP_LIST,
3877 prepend_elem(OP_LIST, pack, list(version)),
3878 newSVOP(OP_METHOD_NAMED, 0, meth)));
3882 /* Fake up an import/unimport */
3883 if (arg && arg->op_type == OP_STUB) {
3885 op_getmad(arg,pegop,'S');
3886 imop = arg; /* no import on explicit () */
3888 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3889 imop = NULL; /* use 5.0; */
3891 idop->op_private |= OPpCONST_NOVER;
3897 op_getmad(arg,pegop,'A');
3899 /* Make copy of idop so we don't free it twice */
3900 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3902 /* Fake up a method call to import/unimport */
3904 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3905 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3906 append_elem(OP_LIST,
3907 prepend_elem(OP_LIST, pack, list(arg)),
3908 newSVOP(OP_METHOD_NAMED, 0, meth)));
3911 /* Fake up the BEGIN {}, which does its thing immediately. */
3913 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3916 append_elem(OP_LINESEQ,
3917 append_elem(OP_LINESEQ,
3918 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3919 newSTATEOP(0, NULL, veop)),
3920 newSTATEOP(0, NULL, imop) ));
3922 /* The "did you use incorrect case?" warning used to be here.
3923 * The problem is that on case-insensitive filesystems one
3924 * might get false positives for "use" (and "require"):
3925 * "use Strict" or "require CARP" will work. This causes
3926 * portability problems for the script: in case-strict
3927 * filesystems the script will stop working.
3929 * The "incorrect case" warning checked whether "use Foo"
3930 * imported "Foo" to your namespace, but that is wrong, too:
3931 * there is no requirement nor promise in the language that
3932 * a Foo.pm should or would contain anything in package "Foo".
3934 * There is very little Configure-wise that can be done, either:
3935 * the case-sensitivity of the build filesystem of Perl does not
3936 * help in guessing the case-sensitivity of the runtime environment.
3939 PL_hints |= HINT_BLOCK_SCOPE;
3940 PL_parser->copline = NOLINE;
3941 PL_parser->expect = XSTATE;
3942 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3945 if (!PL_madskills) {
3946 /* FIXME - don't allocate pegop if !PL_madskills */
3955 =head1 Embedding Functions
3957 =for apidoc load_module
3959 Loads the module whose name is pointed to by the string part of name.
3960 Note that the actual module name, not its filename, should be given.
3961 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3962 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3963 (or 0 for no flags). ver, if specified, provides version semantics
3964 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3965 arguments can be used to specify arguments to the module's import()
3966 method, similar to C<use Foo::Bar VERSION LIST>.
3971 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3975 PERL_ARGS_ASSERT_LOAD_MODULE;
3977 va_start(args, ver);
3978 vload_module(flags, name, ver, &args);
3982 #ifdef PERL_IMPLICIT_CONTEXT
3984 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3988 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3989 va_start(args, ver);
3990 vload_module(flags, name, ver, &args);
3996 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4000 OP * const modname = newSVOP(OP_CONST, 0, name);
4002 PERL_ARGS_ASSERT_VLOAD_MODULE;
4004 modname->op_private |= OPpCONST_BARE;
4006 veop = newSVOP(OP_CONST, 0, ver);
4010 if (flags & PERL_LOADMOD_NOIMPORT) {
4011 imop = sawparens(newNULLLIST());
4013 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4014 imop = va_arg(*args, OP*);
4019 sv = va_arg(*args, SV*);
4021 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4022 sv = va_arg(*args, SV*);
4026 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4027 * that it has a PL_parser to play with while doing that, and also
4028 * that it doesn't mess with any existing parser, by creating a tmp
4029 * new parser with lex_start(). This won't actually be used for much,
4030 * since pp_require() will create another parser for the real work. */
4033 SAVEVPTR(PL_curcop);
4034 lex_start(NULL, NULL, FALSE);
4035 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4036 veop, modname, imop);
4041 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4047 PERL_ARGS_ASSERT_DOFILE;
4049 if (!force_builtin) {
4050 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4051 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4052 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4053 gv = gvp ? *gvp : NULL;
4057 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4058 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4059 append_elem(OP_LIST, term,
4060 scalar(newUNOP(OP_RV2CV, 0,
4061 newGVOP(OP_GV, 0, gv))))));
4064 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4070 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4072 return newBINOP(OP_LSLICE, flags,
4073 list(force_list(subscript)),
4074 list(force_list(listval)) );
4078 S_is_list_assignment(pTHX_ register const OP *o)
4086 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4087 o = cUNOPo->op_first;
4089 flags = o->op_flags;
4091 if (type == OP_COND_EXPR) {
4092 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4093 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4098 yyerror("Assignment to both a list and a scalar");
4102 if (type == OP_LIST &&
4103 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4104 o->op_private & OPpLVAL_INTRO)
4107 if (type == OP_LIST || flags & OPf_PARENS ||
4108 type == OP_RV2AV || type == OP_RV2HV ||
4109 type == OP_ASLICE || type == OP_HSLICE)
4112 if (type == OP_PADAV || type == OP_PADHV)
4115 if (type == OP_RV2SV)
4122 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4128 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4129 return newLOGOP(optype, 0,
4130 mod(scalar(left), optype),
4131 newUNOP(OP_SASSIGN, 0, scalar(right)));
4134 return newBINOP(optype, OPf_STACKED,
4135 mod(scalar(left), optype), scalar(right));
4139 if (is_list_assignment(left)) {
4140 static const char no_list_state[] = "Initialization of state variables"
4141 " in list context currently forbidden";
4143 bool maybe_common_vars = TRUE;
4146 /* Grandfathering $[ assignment here. Bletch.*/
4147 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4148 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4149 left = mod(left, OP_AASSIGN);
4152 else if (left->op_type == OP_CONST) {
4154 /* Result of assignment is always 1 (or we'd be dead already) */
4155 return newSVOP(OP_CONST, 0, newSViv(1));
4157 curop = list(force_list(left));
4158 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4159 o->op_private = (U8)(0 | (flags >> 8));
4161 if ((left->op_type == OP_LIST
4162 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4164 OP* lop = ((LISTOP*)left)->op_first;
4165 maybe_common_vars = FALSE;
4167 if (lop->op_type == OP_PADSV ||
4168 lop->op_type == OP_PADAV ||
4169 lop->op_type == OP_PADHV ||
4170 lop->op_type == OP_PADANY) {
4171 if (!(lop->op_private & OPpLVAL_INTRO))
4172 maybe_common_vars = TRUE;
4174 if (lop->op_private & OPpPAD_STATE) {
4175 if (left->op_private & OPpLVAL_INTRO) {
4176 /* Each variable in state($a, $b, $c) = ... */
4179 /* Each state variable in
4180 (state $a, my $b, our $c, $d, undef) = ... */
4182 yyerror(no_list_state);
4184 /* Each my variable in
4185 (state $a, my $b, our $c, $d, undef) = ... */
4187 } else if (lop->op_type == OP_UNDEF ||
4188 lop->op_type == OP_PUSHMARK) {
4189 /* undef may be interesting in
4190 (state $a, undef, state $c) */
4192 /* Other ops in the list. */
4193 maybe_common_vars = TRUE;
4195 lop = lop->op_sibling;
4198 else if ((left->op_private & OPpLVAL_INTRO)
4199 && ( left->op_type == OP_PADSV
4200 || left->op_type == OP_PADAV
4201 || left->op_type == OP_PADHV
4202 || left->op_type == OP_PADANY))
4204 maybe_common_vars = FALSE;
4205 if (left->op_private & OPpPAD_STATE) {
4206 /* All single variable list context state assignments, hence
4216 yyerror(no_list_state);
4220 /* PL_generation sorcery:
4221 * an assignment like ($a,$b) = ($c,$d) is easier than
4222 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4223 * To detect whether there are common vars, the global var
4224 * PL_generation is incremented for each assign op we compile.
4225 * Then, while compiling the assign op, we run through all the
4226 * variables on both sides of the assignment, setting a spare slot
4227 * in each of them to PL_generation. If any of them already have
4228 * that value, we know we've got commonality. We could use a
4229 * single bit marker, but then we'd have to make 2 passes, first
4230 * to clear the flag, then to test and set it. To find somewhere
4231 * to store these values, evil chicanery is done with SvUVX().
4234 if (maybe_common_vars) {
4237 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4238 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4239 if (curop->op_type == OP_GV) {
4240 GV *gv = cGVOPx_gv(curop);
4242 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4244 GvASSIGN_GENERATION_set(gv, PL_generation);
4246 else if (curop->op_type == OP_PADSV ||
4247 curop->op_type == OP_PADAV ||
4248 curop->op_type == OP_PADHV ||
4249 curop->op_type == OP_PADANY)
4251 if (PAD_COMPNAME_GEN(curop->op_targ)
4252 == (STRLEN)PL_generation)
4254 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4257 else if (curop->op_type == OP_RV2CV)
4259 else if (curop->op_type == OP_RV2SV ||
4260 curop->op_type == OP_RV2AV ||
4261 curop->op_type == OP_RV2HV ||
4262 curop->op_type == OP_RV2GV) {
4263 if (lastop->op_type != OP_GV) /* funny deref? */
4266 else if (curop->op_type == OP_PUSHRE) {
4268 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4269 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4271 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4273 GvASSIGN_GENERATION_set(gv, PL_generation);
4277 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4280 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4282 GvASSIGN_GENERATION_set(gv, PL_generation);
4292 o->op_private |= OPpASSIGN_COMMON;
4295 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4296 OP* tmpop = ((LISTOP*)right)->op_first;
4297 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4298 PMOP * const pm = (PMOP*)tmpop;
4299 if (left->op_type == OP_RV2AV &&
4300 !(left->op_private & OPpLVAL_INTRO) &&
4301 !(o->op_private & OPpASSIGN_COMMON) )
4303 tmpop = ((UNOP*)left)->op_first;
4304 if (tmpop->op_type == OP_GV
4306 && !pm->op_pmreplrootu.op_pmtargetoff
4308 && !pm->op_pmreplrootu.op_pmtargetgv
4312 pm->op_pmreplrootu.op_pmtargetoff
4313 = cPADOPx(tmpop)->op_padix;
4314 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4316 pm->op_pmreplrootu.op_pmtargetgv
4317 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4318 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4320 pm->op_pmflags |= PMf_ONCE;
4321 tmpop = cUNOPo->op_first; /* to list (nulled) */
4322 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4323 tmpop->op_sibling = NULL; /* don't free split */
4324 right->op_next = tmpop->op_next; /* fix starting loc */
4325 op_free(o); /* blow off assign */
4326 right->op_flags &= ~OPf_WANT;
4327 /* "I don't know and I don't care." */
4332 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4333 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4335 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4337 sv_setiv(sv, PL_modcount+1);
4345 right = newOP(OP_UNDEF, 0);
4346 if (right->op_type == OP_READLINE) {
4347 right->op_flags |= OPf_STACKED;
4348 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4351 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4352 o = newBINOP(OP_SASSIGN, flags,
4353 scalar(right), mod(scalar(left), OP_SASSIGN) );
4357 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4359 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4360 o->op_private |= OPpCONST_ARYBASE;
4368 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4371 const U32 seq = intro_my();
4374 NewOp(1101, cop, 1, COP);
4375 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4376 cop->op_type = OP_DBSTATE;
4377 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4380 cop->op_type = OP_NEXTSTATE;
4381 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4383 cop->op_flags = (U8)flags;
4384 CopHINTS_set(cop, PL_hints);
4386 cop->op_private |= NATIVE_HINTS;
4388 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4389 cop->op_next = (OP*)cop;
4392 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4393 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4395 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4396 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4397 if (cop->cop_hints_hash) {
4399 cop->cop_hints_hash->refcounted_he_refcnt++;
4400 HINTS_REFCNT_UNLOCK;
4404 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4406 PL_hints |= HINT_BLOCK_SCOPE;
4407 /* It seems that we need to defer freeing this pointer, as other parts
4408 of the grammar end up wanting to copy it after this op has been
4413 if (PL_parser && PL_parser->copline == NOLINE)
4414 CopLINE_set(cop, CopLINE(PL_curcop));
4416 CopLINE_set(cop, PL_parser->copline);
4418 PL_parser->copline = NOLINE;
4421 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4423 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4425 CopSTASH_set(cop, PL_curstash);
4427 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4428 /* this line can have a breakpoint - store the cop in IV */
4429 AV *av = CopFILEAVx(PL_curcop);
4431 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4432 if (svp && *svp != &PL_sv_undef ) {
4433 (void)SvIOK_on(*svp);
4434 SvIV_set(*svp, PTR2IV(cop));
4439 if (flags & OPf_SPECIAL)
4441 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4446 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4450 PERL_ARGS_ASSERT_NEWLOGOP;
4452 return new_logop(type, flags, &first, &other);
4456 S_search_const(pTHX_ OP *o)
4458 PERL_ARGS_ASSERT_SEARCH_CONST;
4460 switch (o->op_type) {
4464 if (o->op_flags & OPf_KIDS)
4465 return search_const(cUNOPo->op_first);
4472 if (!(o->op_flags & OPf_KIDS))
4474 kid = cLISTOPo->op_first;
4476 switch (kid->op_type) {
4480 kid = kid->op_sibling;
4483 if (kid != cLISTOPo->op_last)
4489 kid = cLISTOPo->op_last;
4491 return search_const(kid);
4499 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4507 int prepend_not = 0;
4509 PERL_ARGS_ASSERT_NEW_LOGOP;
4514 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4515 return newBINOP(type, flags, scalar(first), scalar(other));
4517 scalarboolean(first);
4518 /* optimize AND and OR ops that have NOTs as children */
4519 if (first->op_type == OP_NOT
4520 && (first->op_flags & OPf_KIDS)
4521 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4522 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4524 if (type == OP_AND || type == OP_OR) {
4530 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4532 prepend_not = 1; /* prepend a NOT op later */
4536 /* search for a constant op that could let us fold the test */
4537 if ((cstop = search_const(first))) {
4538 if (cstop->op_private & OPpCONST_STRICT)
4539 no_bareword_allowed(cstop);
4540 else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4541 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4542 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4543 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4544 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4546 if (other->op_type == OP_CONST)
4547 other->op_private |= OPpCONST_SHORTCIRCUIT;
4549 OP *newop = newUNOP(OP_NULL, 0, other);
4550 op_getmad(first, newop, '1');
4551 newop->op_targ = type; /* set "was" field */
4558 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4559 const OP *o2 = other;
4560 if ( ! (o2->op_type == OP_LIST
4561 && (( o2 = cUNOPx(o2)->op_first))
4562 && o2->op_type == OP_PUSHMARK
4563 && (( o2 = o2->op_sibling)) )
4566 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4567 || o2->op_type == OP_PADHV)
4568 && o2->op_private & OPpLVAL_INTRO
4569 && !(o2->op_private & OPpPAD_STATE)
4570 && ckWARN(WARN_DEPRECATED))
4572 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4573 "Deprecated use of my() in false conditional");
4577 if (first->op_type == OP_CONST)
4578 first->op_private |= OPpCONST_SHORTCIRCUIT;
4580 first = newUNOP(OP_NULL, 0, first);
4581 op_getmad(other, first, '2');
4582 first->op_targ = type; /* set "was" field */
4589 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4590 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4592 const OP * const k1 = ((UNOP*)first)->op_first;
4593 const OP * const k2 = k1->op_sibling;
4595 switch (first->op_type)
4598 if (k2 && k2->op_type == OP_READLINE
4599 && (k2->op_flags & OPf_STACKED)
4600 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4602 warnop = k2->op_type;
4607 if (k1->op_type == OP_READDIR
4608 || k1->op_type == OP_GLOB
4609 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4610 || k1->op_type == OP_EACH)
4612 warnop = ((k1->op_type == OP_NULL)
4613 ? (OPCODE)k1->op_targ : k1->op_type);
4618 const line_t oldline = CopLINE(PL_curcop);
4619 CopLINE_set(PL_curcop, PL_parser->copline);
4620 Perl_warner(aTHX_ packWARN(WARN_MISC),
4621 "Value of %s%s can be \"0\"; test with defined()",
4623 ((warnop == OP_READLINE || warnop == OP_GLOB)
4624 ? " construct" : "() operator"));
4625 CopLINE_set(PL_curcop, oldline);
4632 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4633 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4635 NewOp(1101, logop, 1, LOGOP);
4637 logop->op_type = (OPCODE)type;
4638 logop->op_ppaddr = PL_ppaddr[type];
4639 logop->op_first = first;
4640 logop->op_flags = (U8)(flags | OPf_KIDS);
4641 logop->op_other = LINKLIST(other);
4642 logop->op_private = (U8)(1 | (flags >> 8));
4644 /* establish postfix order */
4645 logop->op_next = LINKLIST(first);
4646 first->op_next = (OP*)logop;
4647 first->op_sibling = other;
4649 CHECKOP(type,logop);
4651 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4658 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4666 PERL_ARGS_ASSERT_NEWCONDOP;
4669 return newLOGOP(OP_AND, 0, first, trueop);
4671 return newLOGOP(OP_OR, 0, first, falseop);
4673 scalarboolean(first);
4674 if ((cstop = search_const(first))) {
4675 /* Left or right arm of the conditional? */
4676 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4677 OP *live = left ? trueop : falseop;
4678 OP *const dead = left ? falseop : trueop;
4679 if (cstop->op_private & OPpCONST_BARE &&
4680 cstop->op_private & OPpCONST_STRICT) {
4681 no_bareword_allowed(cstop);
4684 /* This is all dead code when PERL_MAD is not defined. */
4685 live = newUNOP(OP_NULL, 0, live);
4686 op_getmad(first, live, 'C');
4687 op_getmad(dead, live, left ? 'e' : 't');
4694 NewOp(1101, logop, 1, LOGOP);
4695 logop->op_type = OP_COND_EXPR;
4696 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4697 logop->op_first = first;
4698 logop->op_flags = (U8)(flags | OPf_KIDS);
4699 logop->op_private = (U8)(1 | (flags >> 8));
4700 logop->op_other = LINKLIST(trueop);
4701 logop->op_next = LINKLIST(falseop);
4703 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4706 /* establish postfix order */
4707 start = LINKLIST(first);
4708 first->op_next = (OP*)logop;
4710 first->op_sibling = trueop;
4711 trueop->op_sibling = falseop;
4712 o = newUNOP(OP_NULL, 0, (OP*)logop);
4714 trueop->op_next = falseop->op_next = o;
4721 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4730 PERL_ARGS_ASSERT_NEWRANGE;
4732 NewOp(1101, range, 1, LOGOP);
4734 range->op_type = OP_RANGE;
4735 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4736 range->op_first = left;
4737 range->op_flags = OPf_KIDS;
4738 leftstart = LINKLIST(left);
4739 range->op_other = LINKLIST(right);
4740 range->op_private = (U8)(1 | (flags >> 8));
4742 left->op_sibling = right;
4744 range->op_next = (OP*)range;
4745 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4746 flop = newUNOP(OP_FLOP, 0, flip);
4747 o = newUNOP(OP_NULL, 0, flop);
4749 range->op_next = leftstart;
4751 left->op_next = flip;
4752 right->op_next = flop;
4754 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4755 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4756 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4757 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4759 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4760 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4763 if (!flip->op_private || !flop->op_private)
4764 linklist(o); /* blow off optimizer unless constant */
4770 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4775 const bool once = block && block->op_flags & OPf_SPECIAL &&
4776 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4778 PERL_UNUSED_ARG(debuggable);
4781 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4782 return block; /* do {} while 0 does once */
4783 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4784 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4785 expr = newUNOP(OP_DEFINED, 0,
4786 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4787 } else if (expr->op_flags & OPf_KIDS) {
4788 const OP * const k1 = ((UNOP*)expr)->op_first;
4789 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4790 switch (expr->op_type) {
4792 if (k2 && k2->op_type == OP_READLINE
4793 && (k2->op_flags & OPf_STACKED)
4794 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4795 expr = newUNOP(OP_DEFINED, 0, expr);
4799 if (k1 && (k1->op_type == OP_READDIR
4800 || k1->op_type == OP_GLOB
4801 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4802 || k1->op_type == OP_EACH))
4803 expr = newUNOP(OP_DEFINED, 0, expr);
4809 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4810 * op, in listop. This is wrong. [perl #27024] */
4812 block = newOP(OP_NULL, 0);
4813 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4814 o = new_logop(OP_AND, 0, &expr, &listop);
4817 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4819 if (once && o != listop)
4820 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4823 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4825 o->op_flags |= flags;
4827 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4832 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4833 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4842 PERL_UNUSED_ARG(debuggable);
4845 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4846 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4847 expr = newUNOP(OP_DEFINED, 0,
4848 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4849 } else if (expr->op_flags & OPf_KIDS) {
4850 const OP * const k1 = ((UNOP*)expr)->op_first;
4851 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4852 switch (expr->op_type) {
4854 if (k2 && k2->op_type == OP_READLINE
4855 && (k2->op_flags & OPf_STACKED)
4856 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4857 expr = newUNOP(OP_DEFINED, 0, expr);
4861 if (k1 && (k1->op_type == OP_READDIR
4862 || k1->op_type == OP_GLOB
4863 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4864 || k1->op_type == OP_EACH))
4865 expr = newUNOP(OP_DEFINED, 0, expr);
4872 block = newOP(OP_NULL, 0);
4873 else if (cont || has_my) {
4874 block = scope(block);
4878 next = LINKLIST(cont);
4881 OP * const unstack = newOP(OP_UNSTACK, 0);
4884 cont = append_elem(OP_LINESEQ, cont, unstack);
4888 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4890 redo = LINKLIST(listop);
4893 PL_parser->copline = (line_t)whileline;
4895 o = new_logop(OP_AND, 0, &expr, &listop);
4896 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4897 op_free(expr); /* oops, it's a while (0) */
4899 return NULL; /* listop already freed by new_logop */
4902 ((LISTOP*)listop)->op_last->op_next =
4903 (o == listop ? redo : LINKLIST(o));
4909 NewOp(1101,loop,1,LOOP);
4910 loop->op_type = OP_ENTERLOOP;
4911 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4912 loop->op_private = 0;
4913 loop->op_next = (OP*)loop;
4916 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4918 loop->op_redoop = redo;
4919 loop->op_lastop = o;
4920 o->op_private |= loopflags;
4923 loop->op_nextop = next;
4925 loop->op_nextop = o;
4927 o->op_flags |= flags;
4928 o->op_private |= (flags >> 8);
4933 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4938 PADOFFSET padoff = 0;
4943 PERL_ARGS_ASSERT_NEWFOROP;
4946 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4947 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4948 sv->op_type = OP_RV2GV;
4949 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4951 /* The op_type check is needed to prevent a possible segfault
4952 * if the loop variable is undeclared and 'strict vars' is in
4953 * effect. This is illegal but is nonetheless parsed, so we
4954 * may reach this point with an OP_CONST where we're expecting
4957 if (cUNOPx(sv)->op_first->op_type == OP_GV
4958 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4959 iterpflags |= OPpITER_DEF;
4961 else if (sv->op_type == OP_PADSV) { /* private variable */
4962 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4963 padoff = sv->op_targ;
4973 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4975 SV *const namesv = PAD_COMPNAME_SV(padoff);
4977 const char *const name = SvPV_const(namesv, len);
4979 if (len == 2 && name[0] == '$' && name[1] == '_')
4980 iterpflags |= OPpITER_DEF;
4984 const PADOFFSET offset = pad_findmy("$_");
4985 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4986 sv = newGVOP(OP_GV, 0, PL_defgv);
4991 iterpflags |= OPpITER_DEF;
4993 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4994 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4995 iterflags |= OPf_STACKED;
4997 else if (expr->op_type == OP_NULL &&
4998 (expr->op_flags & OPf_KIDS) &&
4999 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5001 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5002 * set the STACKED flag to indicate that these values are to be
5003 * treated as min/max values by 'pp_iterinit'.
5005 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5006 LOGOP* const range = (LOGOP*) flip->op_first;
5007 OP* const left = range->op_first;
5008 OP* const right = left->op_sibling;
5011 range->op_flags &= ~OPf_KIDS;
5012 range->op_first = NULL;
5014 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5015 listop->op_first->op_next = range->op_next;
5016 left->op_next = range->op_other;
5017 right->op_next = (OP*)listop;
5018 listop->op_next = listop->op_first;
5021 op_getmad(expr,(OP*)listop,'O');
5025 expr = (OP*)(listop);
5027 iterflags |= OPf_STACKED;
5030 expr = mod(force_list(expr), OP_GREPSTART);
5033 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5034 append_elem(OP_LIST, expr, scalar(sv))));
5035 assert(!loop->op_next);
5036 /* for my $x () sets OPpLVAL_INTRO;
5037 * for our $x () sets OPpOUR_INTRO */
5038 loop->op_private = (U8)iterpflags;
5039 #ifdef PL_OP_SLAB_ALLOC
5042 NewOp(1234,tmp,1,LOOP);
5043 Copy(loop,tmp,1,LISTOP);
5044 S_op_destroy(aTHX_ (OP*)loop);
5048 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5050 loop->op_targ = padoff;
5051 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5053 op_getmad(madsv, (OP*)loop, 'v');
5054 PL_parser->copline = forline;
5055 return newSTATEOP(0, label, wop);
5059 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5064 PERL_ARGS_ASSERT_NEWLOOPEX;
5066 if (type != OP_GOTO || label->op_type == OP_CONST) {
5067 /* "last()" means "last" */
5068 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5069 o = newOP(type, OPf_SPECIAL);
5071 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5072 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5076 op_getmad(label,o,'L');
5082 /* Check whether it's going to be a goto &function */
5083 if (label->op_type == OP_ENTERSUB
5084 && !(label->op_flags & OPf_STACKED))
5085 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5086 o = newUNOP(type, OPf_STACKED, label);
5088 PL_hints |= HINT_BLOCK_SCOPE;
5092 /* if the condition is a literal array or hash
5093 (or @{ ... } etc), make a reference to it.
5096 S_ref_array_or_hash(pTHX_ OP *cond)
5099 && (cond->op_type == OP_RV2AV
5100 || cond->op_type == OP_PADAV
5101 || cond->op_type == OP_RV2HV
5102 || cond->op_type == OP_PADHV))
5104 return newUNOP(OP_REFGEN,
5105 0, mod(cond, OP_REFGEN));
5111 /* These construct the optree fragments representing given()
5114 entergiven and enterwhen are LOGOPs; the op_other pointer
5115 points up to the associated leave op. We need this so we
5116 can put it in the context and make break/continue work.
5117 (Also, of course, pp_enterwhen will jump straight to
5118 op_other if the match fails.)
5122 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5123 I32 enter_opcode, I32 leave_opcode,
5124 PADOFFSET entertarg)
5130 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5132 NewOp(1101, enterop, 1, LOGOP);
5133 enterop->op_type = (Optype)enter_opcode;
5134 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5135 enterop->op_flags = (U8) OPf_KIDS;
5136 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5137 enterop->op_private = 0;
5139 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5142 enterop->op_first = scalar(cond);
5143 cond->op_sibling = block;
5145 o->op_next = LINKLIST(cond);
5146 cond->op_next = (OP *) enterop;
5149 /* This is a default {} block */
5150 enterop->op_first = block;
5151 enterop->op_flags |= OPf_SPECIAL;
5153 o->op_next = (OP *) enterop;
5156 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5157 entergiven and enterwhen both
5160 enterop->op_next = LINKLIST(block);
5161 block->op_next = enterop->op_other = o;
5166 /* Does this look like a boolean operation? For these purposes
5167 a boolean operation is:
5168 - a subroutine call [*]
5169 - a logical connective
5170 - a comparison operator
5171 - a filetest operator, with the exception of -s -M -A -C
5172 - defined(), exists() or eof()
5173 - /$re/ or $foo =~ /$re/
5175 [*] possibly surprising
5178 S_looks_like_bool(pTHX_ const OP *o)
5182 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5184 switch(o->op_type) {
5186 return looks_like_bool(cLOGOPo->op_first);
5190 looks_like_bool(cLOGOPo->op_first)
5191 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5195 o->op_flags & OPf_KIDS
5196 && looks_like_bool(cUNOPo->op_first));
5200 case OP_NOT: case OP_XOR:
5201 /* Note that OP_DOR is not here */
5203 case OP_EQ: case OP_NE: case OP_LT:
5204 case OP_GT: case OP_LE: case OP_GE:
5206 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5207 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5209 case OP_SEQ: case OP_SNE: case OP_SLT:
5210 case OP_SGT: case OP_SLE: case OP_SGE:
5214 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5215 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5216 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5217 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5218 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5219 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5220 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5221 case OP_FTTEXT: case OP_FTBINARY:
5223 case OP_DEFINED: case OP_EXISTS:
5224 case OP_MATCH: case OP_EOF:
5229 /* Detect comparisons that have been optimized away */
5230 if (cSVOPo->op_sv == &PL_sv_yes
5231 || cSVOPo->op_sv == &PL_sv_no)
5242 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5245 PERL_ARGS_ASSERT_NEWGIVENOP;
5246 return newGIVWHENOP(
5247 ref_array_or_hash(cond),
5249 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5253 /* If cond is null, this is a default {} block */
5255 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5257 const bool cond_llb = (!cond || looks_like_bool(cond));
5260 PERL_ARGS_ASSERT_NEWWHENOP;
5265 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5267 scalar(ref_array_or_hash(cond)));
5270 return newGIVWHENOP(
5272 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5273 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5277 =for apidoc cv_undef
5279 Clear out all the active components of a CV. This can happen either
5280 by an explicit C<undef &foo>, or by the reference count going to zero.
5281 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5282 children can still follow the full lexical scope chain.
5288 Perl_cv_undef(pTHX_ CV *cv)
5292 PERL_ARGS_ASSERT_CV_UNDEF;
5294 DEBUG_X(PerlIO_printf(Perl_debug_log,
5295 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5296 PTR2UV(cv), PTR2UV(PL_comppad))
5300 if (CvFILE(cv) && !CvISXSUB(cv)) {
5301 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5302 Safefree(CvFILE(cv));
5307 if (!CvISXSUB(cv) && CvROOT(cv)) {
5308 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5309 Perl_croak(aTHX_ "Can't undef active subroutine");
5312 PAD_SAVE_SETNULLPAD();
5314 op_free(CvROOT(cv));
5319 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5324 /* remove CvOUTSIDE unless this is an undef rather than a free */
5325 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5326 if (!CvWEAKOUTSIDE(cv))
5327 SvREFCNT_dec(CvOUTSIDE(cv));
5328 CvOUTSIDE(cv) = NULL;
5331 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5334 if (CvISXSUB(cv) && CvXSUB(cv)) {
5337 /* delete all flags except WEAKOUTSIDE */
5338 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5342 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5345 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5347 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5348 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5349 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5350 || (p && (len != SvCUR(cv) /* Not the same length. */
5351 || memNE(p, SvPVX_const(cv), len))))
5352 && ckWARN_d(WARN_PROTOTYPE)) {
5353 SV* const msg = sv_newmortal();
5357 gv_efullname3(name = sv_newmortal(), gv, NULL);
5358 sv_setpvs(msg, "Prototype mismatch:");
5360 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5362 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5364 sv_catpvs(msg, ": none");
5365 sv_catpvs(msg, " vs ");
5367 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5369 sv_catpvs(msg, "none");
5370 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5374 static void const_sv_xsub(pTHX_ CV* cv);
5378 =head1 Optree Manipulation Functions
5380 =for apidoc cv_const_sv
5382 If C<cv> is a constant sub eligible for inlining. returns the constant
5383 value returned by the sub. Otherwise, returns NULL.
5385 Constant subs can be created with C<newCONSTSUB> or as described in
5386 L<perlsub/"Constant Functions">.
5391 Perl_cv_const_sv(pTHX_ const CV *const cv)
5393 PERL_UNUSED_CONTEXT;
5396 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5398 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5401 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5402 * Can be called in 3 ways:
5405 * look for a single OP_CONST with attached value: return the value
5407 * cv && CvCLONE(cv) && !CvCONST(cv)
5409 * examine the clone prototype, and if contains only a single
5410 * OP_CONST referencing a pad const, or a single PADSV referencing
5411 * an outer lexical, return a non-zero value to indicate the CV is
5412 * a candidate for "constizing" at clone time
5416 * We have just cloned an anon prototype that was marked as a const
5417 * candidiate. Try to grab the current value, and in the case of
5418 * PADSV, ignore it if it has multiple references. Return the value.
5422 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5433 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5434 o = cLISTOPo->op_first->op_sibling;
5436 for (; o; o = o->op_next) {
5437 const OPCODE type = o->op_type;
5439 if (sv && o->op_next == o)
5441 if (o->op_next != o) {
5442 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5444 if (type == OP_DBSTATE)
5447 if (type == OP_LEAVESUB || type == OP_RETURN)
5451 if (type == OP_CONST && cSVOPo->op_sv)
5453 else if (cv && type == OP_CONST) {
5454 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5458 else if (cv && type == OP_PADSV) {
5459 if (CvCONST(cv)) { /* newly cloned anon */
5460 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5461 /* the candidate should have 1 ref from this pad and 1 ref
5462 * from the parent */
5463 if (!sv || SvREFCNT(sv) != 2)
5470 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5471 sv = &PL_sv_undef; /* an arbitrary non-null value */
5486 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5489 /* This would be the return value, but the return cannot be reached. */
5490 OP* pegop = newOP(OP_NULL, 0);
5493 PERL_UNUSED_ARG(floor);
5503 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5505 NORETURN_FUNCTION_END;
5510 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5512 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5516 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5523 register CV *cv = NULL;
5525 /* If the subroutine has no body, no attributes, and no builtin attributes
5526 then it's just a sub declaration, and we may be able to get away with
5527 storing with a placeholder scalar in the symbol table, rather than a
5528 full GV and CV. If anything is present then it will take a full CV to
5530 const I32 gv_fetch_flags
5531 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5533 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5534 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5537 assert(proto->op_type == OP_CONST);
5538 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5543 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5544 SV * const sv = sv_newmortal();
5545 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5546 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5547 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5548 aname = SvPVX_const(sv);
5553 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5554 : gv_fetchpv(aname ? aname
5555 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5556 gv_fetch_flags, SVt_PVCV);
5558 if (!PL_madskills) {
5567 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5568 maximum a prototype before. */
5569 if (SvTYPE(gv) > SVt_NULL) {
5570 if (!SvPOK((const SV *)gv)
5571 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
5572 && ckWARN_d(WARN_PROTOTYPE))
5574 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5576 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5579 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5581 sv_setiv(MUTABLE_SV(gv), -1);
5583 SvREFCNT_dec(PL_compcv);
5584 cv = PL_compcv = NULL;
5588 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5590 #ifdef GV_UNIQUE_CHECK
5591 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5592 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5596 if (!block || !ps || *ps || attrs
5597 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5599 || block->op_type == OP_NULL
5604 const_sv = op_const_sv(block, NULL);
5607 const bool exists = CvROOT(cv) || CvXSUB(cv);
5609 #ifdef GV_UNIQUE_CHECK
5610 if (exists && GvUNIQUE(gv)) {
5611 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5615 /* if the subroutine doesn't exist and wasn't pre-declared
5616 * with a prototype, assume it will be AUTOLOADed,
5617 * skipping the prototype check
5619 if (exists || SvPOK(cv))
5620 cv_ckproto_len(cv, gv, ps, ps_len);
5621 /* already defined (or promised)? */
5622 if (exists || GvASSUMECV(gv)) {
5625 || block->op_type == OP_NULL
5628 if (CvFLAGS(PL_compcv)) {
5629 /* might have had built-in attrs applied */
5630 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5632 /* just a "sub foo;" when &foo is already defined */
5633 SAVEFREESV(PL_compcv);
5638 && block->op_type != OP_NULL
5641 if (ckWARN(WARN_REDEFINE)
5643 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5645 const line_t oldline = CopLINE(PL_curcop);
5646 if (PL_parser && PL_parser->copline != NOLINE)
5647 CopLINE_set(PL_curcop, PL_parser->copline);
5648 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5649 CvCONST(cv) ? "Constant subroutine %s redefined"
5650 : "Subroutine %s redefined", name);
5651 CopLINE_set(PL_curcop, oldline);
5654 if (!PL_minus_c) /* keep old one around for madskills */
5657 /* (PL_madskills unset in used file.) */
5665 SvREFCNT_inc_simple_void_NN(const_sv);
5667 assert(!CvROOT(cv) && !CvCONST(cv));
5668 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5669 CvXSUBANY(cv).any_ptr = const_sv;
5670 CvXSUB(cv) = const_sv_xsub;
5676 cv = newCONSTSUB(NULL, name, const_sv);
5678 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5679 (CvGV(cv) && GvSTASH(CvGV(cv)))
5688 SvREFCNT_dec(PL_compcv);
5696 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5697 * before we clobber PL_compcv.
5701 || block->op_type == OP_NULL
5704 rcv = MUTABLE_SV(cv);
5705 /* Might have had built-in attributes applied -- propagate them. */
5706 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5707 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5708 stash = GvSTASH(CvGV(cv));
5709 else if (CvSTASH(cv))
5710 stash = CvSTASH(cv);
5712 stash = PL_curstash;
5715 /* possibly about to re-define existing subr -- ignore old cv */
5716 rcv = MUTABLE_SV(PL_compcv);
5717 if (name && GvSTASH(gv))
5718 stash = GvSTASH(gv);
5720 stash = PL_curstash;
5722 apply_attrs(stash, rcv, attrs, FALSE);
5724 if (cv) { /* must reuse cv if autoloaded */
5731 || block->op_type == OP_NULL) && !PL_madskills
5734 /* got here with just attrs -- work done, so bug out */
5735 SAVEFREESV(PL_compcv);
5738 /* transfer PL_compcv to cv */
5740 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5741 if (!CvWEAKOUTSIDE(cv))
5742 SvREFCNT_dec(CvOUTSIDE(cv));
5743 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5744 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5745 CvOUTSIDE(PL_compcv) = 0;
5746 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5747 CvPADLIST(PL_compcv) = 0;
5748 /* inner references to PL_compcv must be fixed up ... */
5749 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5750 /* ... before we throw it away */
5751 SvREFCNT_dec(PL_compcv);
5753 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5754 ++PL_sub_generation;
5761 if (strEQ(name, "import")) {
5762 PL_formfeed = MUTABLE_SV(cv);
5763 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5767 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5771 CvFILE_set_from_cop(cv, PL_curcop);
5772 CvSTASH(cv) = PL_curstash;
5775 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5777 if (PL_parser && PL_parser->error_count) {
5781 const char *s = strrchr(name, ':');
5783 if (strEQ(s, "BEGIN")) {
5784 const char not_safe[] =
5785 "BEGIN not safe after errors--compilation aborted";
5786 if (PL_in_eval & EVAL_KEEPERR)
5787 Perl_croak(aTHX_ not_safe);
5789 /* force display of errors found but not reported */
5790 sv_catpv(ERRSV, not_safe);
5791 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5801 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5802 mod(scalarseq(block), OP_LEAVESUBLV));
5803 block->op_attached = 1;
5806 /* This makes sub {}; work as expected. */
5807 if (block->op_type == OP_STUB) {
5808 OP* const newblock = newSTATEOP(0, NULL, 0);
5810 op_getmad(block,newblock,'B');
5817 block->op_attached = 1;
5818 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5820 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5821 OpREFCNT_set(CvROOT(cv), 1);
5822 CvSTART(cv) = LINKLIST(CvROOT(cv));
5823 CvROOT(cv)->op_next = 0;
5824 CALL_PEEP(CvSTART(cv));
5826 /* now that optimizer has done its work, adjust pad values */
5828 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5831 assert(!CvCONST(cv));
5832 if (ps && !*ps && op_const_sv(block, cv))
5836 if (name || aname) {
5837 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5838 SV * const sv = newSV(0);
5839 SV * const tmpstr = sv_newmortal();
5840 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5841 GV_ADDMULTI, SVt_PVHV);
5844 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5846 (long)PL_subline, (long)CopLINE(PL_curcop));
5847 gv_efullname3(tmpstr, gv, NULL);
5848 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5849 SvCUR(tmpstr), sv, 0);
5850 hv = GvHVn(db_postponed);
5851 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5852 CV * const pcv = GvCV(db_postponed);
5858 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5863 if (name && ! (PL_parser && PL_parser->error_count))
5864 process_special_blocks(name, gv, cv);
5869 PL_parser->copline = NOLINE;
5875 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5878 const char *const colon = strrchr(fullname,':');
5879 const char *const name = colon ? colon + 1 : fullname;
5881 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5884 if (strEQ(name, "BEGIN")) {
5885 const I32 oldscope = PL_scopestack_ix;
5887 SAVECOPFILE(&PL_compiling);
5888 SAVECOPLINE(&PL_compiling);
5890 DEBUG_x( dump_sub(gv) );
5891 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5892 GvCV(gv) = 0; /* cv has been hijacked */
5893 call_list(oldscope, PL_beginav);
5895 PL_curcop = &PL_compiling;
5896 CopHINTS_set(&PL_compiling, PL_hints);
5903 if strEQ(name, "END") {
5904 DEBUG_x( dump_sub(gv) );
5905 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5908 } else if (*name == 'U') {
5909 if (strEQ(name, "UNITCHECK")) {
5910 /* It's never too late to run a unitcheck block */
5911 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5915 } else if (*name == 'C') {
5916 if (strEQ(name, "CHECK")) {
5917 if (PL_main_start && ckWARN(WARN_VOID))
5918 Perl_warner(aTHX_ packWARN(WARN_VOID),
5919 "Too late to run CHECK block");
5920 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5924 } else if (*name == 'I') {
5925 if (strEQ(name, "INIT")) {
5926 if (PL_main_start && ckWARN(WARN_VOID))
5927 Perl_warner(aTHX_ packWARN(WARN_VOID),
5928 "Too late to run INIT block");
5929 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5935 DEBUG_x( dump_sub(gv) );
5936 GvCV(gv) = 0; /* cv has been hijacked */
5941 =for apidoc newCONSTSUB
5943 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5944 eligible for inlining at compile-time.
5950 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5955 const char *const temp_p = CopFILE(PL_curcop);
5956 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5958 SV *const temp_sv = CopFILESV(PL_curcop);
5960 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5962 char *const file = savepvn(temp_p, temp_p ? len : 0);
5966 if (IN_PERL_RUNTIME) {
5967 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5968 * an op shared between threads. Use a non-shared COP for our
5970 SAVEVPTR(PL_curcop);
5971 PL_curcop = &PL_compiling;
5973 SAVECOPLINE(PL_curcop);
5974 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5977 PL_hints &= ~HINT_BLOCK_SCOPE;
5980 SAVESPTR(PL_curstash);
5981 SAVECOPSTASH(PL_curcop);
5982 PL_curstash = stash;
5983 CopSTASH_set(PL_curcop,stash);
5986 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5987 and so doesn't get free()d. (It's expected to be from the C pre-
5988 processor __FILE__ directive). But we need a dynamically allocated one,
5989 and we need it to get freed. */
5990 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5991 CvXSUBANY(cv).any_ptr = sv;
5997 CopSTASH_free(PL_curcop);
6005 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6006 const char *const filename, const char *const proto,
6009 CV *cv = newXS(name, subaddr, filename);
6011 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6013 if (flags & XS_DYNAMIC_FILENAME) {
6014 /* We need to "make arrangements" (ie cheat) to ensure that the
6015 filename lasts as long as the PVCV we just created, but also doesn't
6017 STRLEN filename_len = strlen(filename);
6018 STRLEN proto_and_file_len = filename_len;
6019 char *proto_and_file;
6023 proto_len = strlen(proto);
6024 proto_and_file_len += proto_len;
6026 Newx(proto_and_file, proto_and_file_len + 1, char);
6027 Copy(proto, proto_and_file, proto_len, char);
6028 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6031 proto_and_file = savepvn(filename, filename_len);
6034 /* This gets free()d. :-) */
6035 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6036 SV_HAS_TRAILING_NUL);
6038 /* This gives us the correct prototype, rather than one with the
6039 file name appended. */
6040 SvCUR_set(cv, proto_len);
6044 CvFILE(cv) = proto_and_file + proto_len;
6046 sv_setpv(MUTABLE_SV(cv), proto);
6052 =for apidoc U||newXS
6054 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6055 static storage, as it is used directly as CvFILE(), without a copy being made.
6061 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6064 GV * const gv = gv_fetchpv(name ? name :
6065 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6066 GV_ADDMULTI, SVt_PVCV);
6069 PERL_ARGS_ASSERT_NEWXS;
6072 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6074 if ((cv = (name ? GvCV(gv) : NULL))) {
6076 /* just a cached method */
6080 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6081 /* already defined (or promised) */
6082 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6083 if (ckWARN(WARN_REDEFINE)) {
6084 GV * const gvcv = CvGV(cv);
6086 HV * const stash = GvSTASH(gvcv);
6088 const char *redefined_name = HvNAME_get(stash);
6089 if ( strEQ(redefined_name,"autouse") ) {
6090 const line_t oldline = CopLINE(PL_curcop);
6091 if (PL_parser && PL_parser->copline != NOLINE)
6092 CopLINE_set(PL_curcop, PL_parser->copline);
6093 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6094 CvCONST(cv) ? "Constant subroutine %s redefined"
6095 : "Subroutine %s redefined"
6097 CopLINE_set(PL_curcop, oldline);
6107 if (cv) /* must reuse cv if autoloaded */
6110 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6114 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6118 (void)gv_fetchfile(filename);
6119 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6120 an external constant string */
6122 CvXSUB(cv) = subaddr;
6125 process_special_blocks(name, gv, cv);
6137 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6142 OP* pegop = newOP(OP_NULL, 0);
6146 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6147 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6149 #ifdef GV_UNIQUE_CHECK
6151 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6155 if ((cv = GvFORM(gv))) {
6156 if (ckWARN(WARN_REDEFINE)) {
6157 const line_t oldline = CopLINE(PL_curcop);
6158 if (PL_parser && PL_parser->copline != NOLINE)
6159 CopLINE_set(PL_curcop, PL_parser->copline);
6160 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6161 o ? "Format %"SVf" redefined"
6162 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6163 CopLINE_set(PL_curcop, oldline);
6170 CvFILE_set_from_cop(cv, PL_curcop);
6173 pad_tidy(padtidy_FORMAT);
6174 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6175 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6176 OpREFCNT_set(CvROOT(cv), 1);
6177 CvSTART(cv) = LINKLIST(CvROOT(cv));
6178 CvROOT(cv)->op_next = 0;
6179 CALL_PEEP(CvSTART(cv));
6181 op_getmad(o,pegop,'n');
6182 op_getmad_weak(block, pegop, 'b');
6187 PL_parser->copline = NOLINE;
6195 Perl_newANONLIST(pTHX_ OP *o)
6197 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6201 Perl_newANONHASH(pTHX_ OP *o)
6203 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6207 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6209 return newANONATTRSUB(floor, proto, NULL, block);
6213 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6215 return newUNOP(OP_REFGEN, 0,
6216 newSVOP(OP_ANONCODE, 0,
6217 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6221 Perl_oopsAV(pTHX_ OP *o)
6225 PERL_ARGS_ASSERT_OOPSAV;
6227 switch (o->op_type) {
6229 o->op_type = OP_PADAV;
6230 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6231 return ref(o, OP_RV2AV);
6234 o->op_type = OP_RV2AV;
6235 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6240 if (ckWARN_d(WARN_INTERNAL))
6241 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6248 Perl_oopsHV(pTHX_ OP *o)
6252 PERL_ARGS_ASSERT_OOPSHV;
6254 switch (o->op_type) {
6257 o->op_type = OP_PADHV;
6258 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6259 return ref(o, OP_RV2HV);
6263 o->op_type = OP_RV2HV;
6264 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6269 if (ckWARN_d(WARN_INTERNAL))
6270 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6277 Perl_newAVREF(pTHX_ OP *o)
6281 PERL_ARGS_ASSERT_NEWAVREF;
6283 if (o->op_type == OP_PADANY) {
6284 o->op_type = OP_PADAV;
6285 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6288 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6289 && ckWARN(WARN_DEPRECATED)) {
6290 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6291 "Using an array as a reference is deprecated");
6293 return newUNOP(OP_RV2AV, 0, scalar(o));
6297 Perl_newGVREF(pTHX_ I32 type, OP *o)
6299 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6300 return newUNOP(OP_NULL, 0, o);
6301 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6305 Perl_newHVREF(pTHX_ OP *o)
6309 PERL_ARGS_ASSERT_NEWHVREF;
6311 if (o->op_type == OP_PADANY) {
6312 o->op_type = OP_PADHV;
6313 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6316 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6317 && ckWARN(WARN_DEPRECATED)) {
6318 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6319 "Using a hash as a reference is deprecated");
6321 return newUNOP(OP_RV2HV, 0, scalar(o));
6325 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6327 return newUNOP(OP_RV2CV, flags, scalar(o));
6331 Perl_newSVREF(pTHX_ OP *o)
6335 PERL_ARGS_ASSERT_NEWSVREF;
6337 if (o->op_type == OP_PADANY) {
6338 o->op_type = OP_PADSV;
6339 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6342 return newUNOP(OP_RV2SV, 0, scalar(o));
6345 /* Check routines. See the comments at the top of this file for details
6346 * on when these are called */
6349 Perl_ck_anoncode(pTHX_ OP *o)
6351 PERL_ARGS_ASSERT_CK_ANONCODE;
6353 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6355 cSVOPo->op_sv = NULL;
6360 Perl_ck_bitop(pTHX_ OP *o)
6364 PERL_ARGS_ASSERT_CK_BITOP;
6366 #define OP_IS_NUMCOMPARE(op) \
6367 ((op) == OP_LT || (op) == OP_I_LT || \
6368 (op) == OP_GT || (op) == OP_I_GT || \
6369 (op) == OP_LE || (op) == OP_I_LE || \
6370 (op) == OP_GE || (op) == OP_I_GE || \
6371 (op) == OP_EQ || (op) == OP_I_EQ || \
6372 (op) == OP_NE || (op) == OP_I_NE || \
6373 (op) == OP_NCMP || (op) == OP_I_NCMP)
6374 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6375 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6376 && (o->op_type == OP_BIT_OR
6377 || o->op_type == OP_BIT_AND
6378 || o->op_type == OP_BIT_XOR))
6380 const OP * const left = cBINOPo->op_first;
6381 const OP * const right = left->op_sibling;
6382 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6383 (left->op_flags & OPf_PARENS) == 0) ||
6384 (OP_IS_NUMCOMPARE(right->op_type) &&
6385 (right->op_flags & OPf_PARENS) == 0))
6386 if (ckWARN(WARN_PRECEDENCE))
6387 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6388 "Possible precedence problem on bitwise %c operator",
6389 o->op_type == OP_BIT_OR ? '|'
6390 : o->op_type == OP_BIT_AND ? '&' : '^'
6397 Perl_ck_concat(pTHX_ OP *o)
6399 const OP * const kid = cUNOPo->op_first;
6401 PERL_ARGS_ASSERT_CK_CONCAT;
6402 PERL_UNUSED_CONTEXT;
6404 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6405 !(kUNOP->op_first->op_flags & OPf_MOD))
6406 o->op_flags |= OPf_STACKED;
6411 Perl_ck_spair(pTHX_ OP *o)
6415 PERL_ARGS_ASSERT_CK_SPAIR;
6417 if (o->op_flags & OPf_KIDS) {
6420 const OPCODE type = o->op_type;
6421 o = modkids(ck_fun(o), type);
6422 kid = cUNOPo->op_first;
6423 newop = kUNOP->op_first->op_sibling;
6425 const OPCODE type = newop->op_type;
6426 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6427 type == OP_PADAV || type == OP_PADHV ||
6428 type == OP_RV2AV || type == OP_RV2HV)
6432 op_getmad(kUNOP->op_first,newop,'K');
6434 op_free(kUNOP->op_first);
6436 kUNOP->op_first = newop;
6438 o->op_ppaddr = PL_ppaddr[++o->op_type];
6443 Perl_ck_delete(pTHX_ OP *o)
6445 PERL_ARGS_ASSERT_CK_DELETE;
6449 if (o->op_flags & OPf_KIDS) {
6450 OP * const kid = cUNOPo->op_first;
6451 switch (kid->op_type) {
6453 o->op_flags |= OPf_SPECIAL;
6456 o->op_private |= OPpSLICE;
6459 o->op_flags |= OPf_SPECIAL;
6464 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6473 Perl_ck_die(pTHX_ OP *o)
6475 PERL_ARGS_ASSERT_CK_DIE;
6478 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6484 Perl_ck_eof(pTHX_ OP *o)
6488 PERL_ARGS_ASSERT_CK_EOF;
6490 if (o->op_flags & OPf_KIDS) {
6491 if (cLISTOPo->op_first->op_type == OP_STUB) {
6493 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6495 op_getmad(o,newop,'O');
6507 Perl_ck_eval(pTHX_ OP *o)
6511 PERL_ARGS_ASSERT_CK_EVAL;
6513 PL_hints |= HINT_BLOCK_SCOPE;
6514 if (o->op_flags & OPf_KIDS) {
6515 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6518 o->op_flags &= ~OPf_KIDS;
6521 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6527 cUNOPo->op_first = 0;
6532 NewOp(1101, enter, 1, LOGOP);
6533 enter->op_type = OP_ENTERTRY;
6534 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6535 enter->op_private = 0;
6537 /* establish postfix order */
6538 enter->op_next = (OP*)enter;
6540 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6541 o->op_type = OP_LEAVETRY;
6542 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6543 enter->op_other = o;
6544 op_getmad(oldo,o,'O');
6558 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6559 op_getmad(oldo,o,'O');
6561 o->op_targ = (PADOFFSET)PL_hints;
6562 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6563 /* Store a copy of %^H that pp_entereval can pick up. */
6564 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6565 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6566 cUNOPo->op_first->op_sibling = hhop;
6567 o->op_private |= OPpEVAL_HAS_HH;
6573 Perl_ck_exit(pTHX_ OP *o)
6575 PERL_ARGS_ASSERT_CK_EXIT;
6578 HV * const table = GvHV(PL_hintgv);
6580 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6581 if (svp && *svp && SvTRUE(*svp))
6582 o->op_private |= OPpEXIT_VMSISH;
6584 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6590 Perl_ck_exec(pTHX_ OP *o)
6592 PERL_ARGS_ASSERT_CK_EXEC;
6594 if (o->op_flags & OPf_STACKED) {
6597 kid = cUNOPo->op_first->op_sibling;
6598 if (kid->op_type == OP_RV2GV)
6607 Perl_ck_exists(pTHX_ OP *o)
6611 PERL_ARGS_ASSERT_CK_EXISTS;
6614 if (o->op_flags & OPf_KIDS) {
6615 OP * const kid = cUNOPo->op_first;
6616 if (kid->op_type == OP_ENTERSUB) {
6617 (void) ref(kid, o->op_type);
6618 if (kid->op_type != OP_RV2CV
6619 && !(PL_parser && PL_parser->error_count))
6620 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6622 o->op_private |= OPpEXISTS_SUB;
6624 else if (kid->op_type == OP_AELEM)
6625 o->op_flags |= OPf_SPECIAL;
6626 else if (kid->op_type != OP_HELEM)
6627 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6635 Perl_ck_rvconst(pTHX_ register OP *o)
6638 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6640 PERL_ARGS_ASSERT_CK_RVCONST;
6642 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6643 if (o->op_type == OP_RV2CV)
6644 o->op_private &= ~1;
6646 if (kid->op_type == OP_CONST) {
6649 SV * const kidsv = kid->op_sv;
6651 /* Is it a constant from cv_const_sv()? */
6652 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6653 SV * const rsv = SvRV(kidsv);
6654 const svtype type = SvTYPE(rsv);
6655 const char *badtype = NULL;
6657 switch (o->op_type) {
6659 if (type > SVt_PVMG)
6660 badtype = "a SCALAR";
6663 if (type != SVt_PVAV)
6664 badtype = "an ARRAY";
6667 if (type != SVt_PVHV)
6671 if (type != SVt_PVCV)
6676 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6679 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6680 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6681 /* If this is an access to a stash, disable "strict refs", because
6682 * stashes aren't auto-vivified at compile-time (unless we store
6683 * symbols in them), and we don't want to produce a run-time
6684 * stricture error when auto-vivifying the stash. */
6685 const char *s = SvPV_nolen(kidsv);
6686 const STRLEN l = SvCUR(kidsv);
6687 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6688 o->op_private &= ~HINT_STRICT_REFS;
6690 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6691 const char *badthing;
6692 switch (o->op_type) {
6694 badthing = "a SCALAR";
6697 badthing = "an ARRAY";
6700 badthing = "a HASH";
6708 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6709 SVfARG(kidsv), badthing);
6712 * This is a little tricky. We only want to add the symbol if we
6713 * didn't add it in the lexer. Otherwise we get duplicate strict
6714 * warnings. But if we didn't add it in the lexer, we must at
6715 * least pretend like we wanted to add it even if it existed before,
6716 * or we get possible typo warnings. OPpCONST_ENTERED says
6717 * whether the lexer already added THIS instance of this symbol.
6719 iscv = (o->op_type == OP_RV2CV) * 2;
6721 gv = gv_fetchsv(kidsv,
6722 iscv | !(kid->op_private & OPpCONST_ENTERED),
6725 : o->op_type == OP_RV2SV
6727 : o->op_type == OP_RV2AV
6729 : o->op_type == OP_RV2HV
6732 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6734 kid->op_type = OP_GV;
6735 SvREFCNT_dec(kid->op_sv);
6737 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6738 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6739 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6741 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6743 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6745 kid->op_private = 0;
6746 kid->op_ppaddr = PL_ppaddr[OP_GV];
6753 Perl_ck_ftst(pTHX_ OP *o)
6756 const I32 type = o->op_type;
6758 PERL_ARGS_ASSERT_CK_FTST;
6760 if (o->op_flags & OPf_REF) {
6763 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6764 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6765 const OPCODE kidtype = kid->op_type;
6767 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6768 OP * const newop = newGVOP(type, OPf_REF,
6769 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6771 op_getmad(o,newop,'O');
6777 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6778 o->op_private |= OPpFT_ACCESS;
6779 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6780 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6781 o->op_private |= OPpFT_STACKED;
6789 if (type == OP_FTTTY)
6790 o = newGVOP(type, OPf_REF, PL_stdingv);
6792 o = newUNOP(type, 0, newDEFSVOP());
6793 op_getmad(oldo,o,'O');
6799 Perl_ck_fun(pTHX_ OP *o)
6802 const int type = o->op_type;
6803 register I32 oa = PL_opargs[type] >> OASHIFT;
6805 PERL_ARGS_ASSERT_CK_FUN;
6807 if (o->op_flags & OPf_STACKED) {
6808 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6811 return no_fh_allowed(o);
6814 if (o->op_flags & OPf_KIDS) {
6815 OP **tokid = &cLISTOPo->op_first;
6816 register OP *kid = cLISTOPo->op_first;
6820 if (kid->op_type == OP_PUSHMARK ||
6821 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6823 tokid = &kid->op_sibling;
6824 kid = kid->op_sibling;
6826 if (!kid && PL_opargs[type] & OA_DEFGV)
6827 *tokid = kid = newDEFSVOP();
6831 sibl = kid->op_sibling;
6833 if (!sibl && kid->op_type == OP_STUB) {
6840 /* list seen where single (scalar) arg expected? */
6841 if (numargs == 1 && !(oa >> 4)
6842 && kid->op_type == OP_LIST && type != OP_SCALAR)
6844 return too_many_arguments(o,PL_op_desc[type]);
6857 if ((type == OP_PUSH || type == OP_UNSHIFT)
6858 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6859 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6860 "Useless use of %s with no values",
6863 if (kid->op_type == OP_CONST &&
6864 (kid->op_private & OPpCONST_BARE))
6866 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6867 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6868 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6869 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6870 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6871 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6873 op_getmad(kid,newop,'K');
6878 kid->op_sibling = sibl;
6881 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6882 bad_type(numargs, "array", PL_op_desc[type], kid);
6886 if (kid->op_type == OP_CONST &&
6887 (kid->op_private & OPpCONST_BARE))
6889 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6890 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6891 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6892 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6893 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6894 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6896 op_getmad(kid,newop,'K');
6901 kid->op_sibling = sibl;
6904 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6905 bad_type(numargs, "hash", PL_op_desc[type], kid);
6910 OP * const newop = newUNOP(OP_NULL, 0, kid);
6911 kid->op_sibling = 0;
6913 newop->op_next = newop;
6915 kid->op_sibling = sibl;
6920 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6921 if (kid->op_type == OP_CONST &&
6922 (kid->op_private & OPpCONST_BARE))
6924 OP * const newop = newGVOP(OP_GV, 0,
6925 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6926 if (!(o->op_private & 1) && /* if not unop */
6927 kid == cLISTOPo->op_last)
6928 cLISTOPo->op_last = newop;
6930 op_getmad(kid,newop,'K');
6936 else if (kid->op_type == OP_READLINE) {
6937 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6938 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6941 I32 flags = OPf_SPECIAL;
6945 /* is this op a FH constructor? */
6946 if (is_handle_constructor(o,numargs)) {
6947 const char *name = NULL;
6951 /* Set a flag to tell rv2gv to vivify
6952 * need to "prove" flag does not mean something
6953 * else already - NI-S 1999/05/07
6956 if (kid->op_type == OP_PADSV) {
6958 = PAD_COMPNAME_SV(kid->op_targ);
6959 name = SvPV_const(namesv, len);
6961 else if (kid->op_type == OP_RV2SV
6962 && kUNOP->op_first->op_type == OP_GV)
6964 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6966 len = GvNAMELEN(gv);
6968 else if (kid->op_type == OP_AELEM
6969 || kid->op_type == OP_HELEM)
6972 OP *op = ((BINOP*)kid)->op_first;
6976 const char * const a =
6977 kid->op_type == OP_AELEM ?
6979 if (((op->op_type == OP_RV2AV) ||
6980 (op->op_type == OP_RV2HV)) &&
6981 (firstop = ((UNOP*)op)->op_first) &&
6982 (firstop->op_type == OP_GV)) {
6983 /* packagevar $a[] or $h{} */
6984 GV * const gv = cGVOPx_gv(firstop);
6992 else if (op->op_type == OP_PADAV
6993 || op->op_type == OP_PADHV) {
6994 /* lexicalvar $a[] or $h{} */
6995 const char * const padname =
6996 PAD_COMPNAME_PV(op->op_targ);
7005 name = SvPV_const(tmpstr, len);
7010 name = "__ANONIO__";
7017 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7018 namesv = PAD_SVl(targ);
7019 SvUPGRADE(namesv, SVt_PV);
7021 sv_setpvs(namesv, "$");
7022 sv_catpvn(namesv, name, len);
7025 kid->op_sibling = 0;
7026 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7027 kid->op_targ = targ;
7028 kid->op_private |= priv;
7030 kid->op_sibling = sibl;
7036 mod(scalar(kid), type);
7040 tokid = &kid->op_sibling;
7041 kid = kid->op_sibling;
7044 if (kid && kid->op_type != OP_STUB)
7045 return too_many_arguments(o,OP_DESC(o));
7046 o->op_private |= numargs;
7048 /* FIXME - should the numargs move as for the PERL_MAD case? */
7049 o->op_private |= numargs;
7051 return too_many_arguments(o,OP_DESC(o));
7055 else if (PL_opargs[type] & OA_DEFGV) {
7057 OP *newop = newUNOP(type, 0, newDEFSVOP());
7058 op_getmad(o,newop,'O');
7061 /* Ordering of these two is important to keep f_map.t passing. */
7063 return newUNOP(type, 0, newDEFSVOP());
7068 while (oa & OA_OPTIONAL)
7070 if (oa && oa != OA_LIST)
7071 return too_few_arguments(o,OP_DESC(o));
7077 Perl_ck_glob(pTHX_ OP *o)
7082 PERL_ARGS_ASSERT_CK_GLOB;
7085 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7086 append_elem(OP_GLOB, o, newDEFSVOP());
7088 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7089 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7091 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7094 #if !defined(PERL_EXTERNAL_GLOB)
7095 /* XXX this can be tightened up and made more failsafe. */
7096 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7099 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7100 newSVpvs("File::Glob"), NULL, NULL, NULL);
7101 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7102 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7103 GvCV(gv) = GvCV(glob_gv);
7104 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7105 GvIMPORTED_CV_on(gv);
7108 #endif /* PERL_EXTERNAL_GLOB */
7110 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7111 append_elem(OP_GLOB, o,
7112 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7113 o->op_type = OP_LIST;
7114 o->op_ppaddr = PL_ppaddr[OP_LIST];
7115 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7116 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7117 cLISTOPo->op_first->op_targ = 0;
7118 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7119 append_elem(OP_LIST, o,
7120 scalar(newUNOP(OP_RV2CV, 0,
7121 newGVOP(OP_GV, 0, gv)))));
7122 o = newUNOP(OP_NULL, 0, ck_subr(o));
7123 o->op_targ = OP_GLOB; /* hint at what it used to be */
7126 gv = newGVgen("main");
7128 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7134 Perl_ck_grep(pTHX_ OP *o)
7139 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7142 PERL_ARGS_ASSERT_CK_GREP;
7144 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7145 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7147 if (o->op_flags & OPf_STACKED) {
7150 kid = cLISTOPo->op_first->op_sibling;
7151 if (!cUNOPx(kid)->op_next)
7152 Perl_croak(aTHX_ "panic: ck_grep");
7153 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7156 NewOp(1101, gwop, 1, LOGOP);
7157 kid->op_next = (OP*)gwop;
7158 o->op_flags &= ~OPf_STACKED;
7160 kid = cLISTOPo->op_first->op_sibling;
7161 if (type == OP_MAPWHILE)
7166 if (PL_parser && PL_parser->error_count)
7168 kid = cLISTOPo->op_first->op_sibling;
7169 if (kid->op_type != OP_NULL)
7170 Perl_croak(aTHX_ "panic: ck_grep");
7171 kid = kUNOP->op_first;
7174 NewOp(1101, gwop, 1, LOGOP);
7175 gwop->op_type = type;
7176 gwop->op_ppaddr = PL_ppaddr[type];
7177 gwop->op_first = listkids(o);
7178 gwop->op_flags |= OPf_KIDS;
7179 gwop->op_other = LINKLIST(kid);
7180 kid->op_next = (OP*)gwop;
7181 offset = pad_findmy("$_");
7182 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7183 o->op_private = gwop->op_private = 0;
7184 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7187 o->op_private = gwop->op_private = OPpGREP_LEX;
7188 gwop->op_targ = o->op_targ = offset;
7191 kid = cLISTOPo->op_first->op_sibling;
7192 if (!kid || !kid->op_sibling)
7193 return too_few_arguments(o,OP_DESC(o));
7194 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7195 mod(kid, OP_GREPSTART);
7201 Perl_ck_index(pTHX_ OP *o)
7203 PERL_ARGS_ASSERT_CK_INDEX;
7205 if (o->op_flags & OPf_KIDS) {
7206 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7208 kid = kid->op_sibling; /* get past "big" */
7209 if (kid && kid->op_type == OP_CONST)
7210 fbm_compile(((SVOP*)kid)->op_sv, 0);
7216 Perl_ck_lfun(pTHX_ OP *o)
7218 const OPCODE type = o->op_type;
7220 PERL_ARGS_ASSERT_CK_LFUN;
7222 return modkids(ck_fun(o), type);
7226 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7228 PERL_ARGS_ASSERT_CK_DEFINED;
7230 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7231 switch (cUNOPo->op_first->op_type) {
7233 /* This is needed for
7234 if (defined %stash::)
7235 to work. Do not break Tk.
7237 break; /* Globals via GV can be undef */
7239 case OP_AASSIGN: /* Is this a good idea? */
7240 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7241 "defined(@array) is deprecated");
7242 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7243 "\t(Maybe you should just omit the defined()?)\n");
7246 /* This is needed for
7247 if (defined %stash::)
7248 to work. Do not break Tk.
7250 break; /* Globals via GV can be undef */
7252 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7253 "defined(%%hash) is deprecated");
7254 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7255 "\t(Maybe you should just omit the defined()?)\n");
7266 Perl_ck_readline(pTHX_ OP *o)
7268 PERL_ARGS_ASSERT_CK_READLINE;
7270 if (!(o->op_flags & OPf_KIDS)) {
7272 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7274 op_getmad(o,newop,'O');
7284 Perl_ck_rfun(pTHX_ OP *o)
7286 const OPCODE type = o->op_type;
7288 PERL_ARGS_ASSERT_CK_RFUN;
7290 return refkids(ck_fun(o), type);
7294 Perl_ck_listiob(pTHX_ OP *o)
7298 PERL_ARGS_ASSERT_CK_LISTIOB;
7300 kid = cLISTOPo->op_first;
7303 kid = cLISTOPo->op_first;
7305 if (kid->op_type == OP_PUSHMARK)
7306 kid = kid->op_sibling;
7307 if (kid && o->op_flags & OPf_STACKED)
7308 kid = kid->op_sibling;
7309 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7310 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7311 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7312 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7313 cLISTOPo->op_first->op_sibling = kid;
7314 cLISTOPo->op_last = kid;
7315 kid = kid->op_sibling;
7320 append_elem(o->op_type, o, newDEFSVOP());
7326 Perl_ck_smartmatch(pTHX_ OP *o)
7329 if (0 == (o->op_flags & OPf_SPECIAL)) {
7330 OP *first = cBINOPo->op_first;
7331 OP *second = first->op_sibling;
7333 /* Implicitly take a reference to an array or hash */
7334 first->op_sibling = NULL;
7335 first = cBINOPo->op_first = ref_array_or_hash(first);
7336 second = first->op_sibling = ref_array_or_hash(second);
7338 /* Implicitly take a reference to a regular expression */
7339 if (first->op_type == OP_MATCH) {
7340 first->op_type = OP_QR;
7341 first->op_ppaddr = PL_ppaddr[OP_QR];
7343 if (second->op_type == OP_MATCH) {
7344 second->op_type = OP_QR;
7345 second->op_ppaddr = PL_ppaddr[OP_QR];
7354 Perl_ck_sassign(pTHX_ OP *o)
7357 OP * const kid = cLISTOPo->op_first;
7359 PERL_ARGS_ASSERT_CK_SASSIGN;
7361 /* has a disposable target? */
7362 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7363 && !(kid->op_flags & OPf_STACKED)
7364 /* Cannot steal the second time! */
7365 && !(kid->op_private & OPpTARGET_MY)
7366 /* Keep the full thing for madskills */
7370 OP * const kkid = kid->op_sibling;
7372 /* Can just relocate the target. */
7373 if (kkid && kkid->op_type == OP_PADSV
7374 && !(kkid->op_private & OPpLVAL_INTRO))
7376 kid->op_targ = kkid->op_targ;
7378 /* Now we do not need PADSV and SASSIGN. */
7379 kid->op_sibling = o->op_sibling; /* NULL */
7380 cLISTOPo->op_first = NULL;
7383 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7387 if (kid->op_sibling) {
7388 OP *kkid = kid->op_sibling;
7389 if (kkid->op_type == OP_PADSV
7390 && (kkid->op_private & OPpLVAL_INTRO)
7391 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7392 const PADOFFSET target = kkid->op_targ;
7393 OP *const other = newOP(OP_PADSV,
7395 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7396 OP *const first = newOP(OP_NULL, 0);
7397 OP *const nullop = newCONDOP(0, first, o, other);
7398 OP *const condop = first->op_next;
7399 /* hijacking PADSTALE for uninitialized state variables */
7400 SvPADSTALE_on(PAD_SVl(target));
7402 condop->op_type = OP_ONCE;
7403 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7404 condop->op_targ = target;
7405 other->op_targ = target;
7407 /* Because we change the type of the op here, we will skip the
7408 assinment binop->op_last = binop->op_first->op_sibling; at the
7409 end of Perl_newBINOP(). So need to do it here. */
7410 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7419 Perl_ck_match(pTHX_ OP *o)
7423 PERL_ARGS_ASSERT_CK_MATCH;
7425 if (o->op_type != OP_QR && PL_compcv) {
7426 const PADOFFSET offset = pad_findmy("$_");
7427 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7428 o->op_targ = offset;
7429 o->op_private |= OPpTARGET_MY;
7432 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7433 o->op_private |= OPpRUNTIME;
7438 Perl_ck_method(pTHX_ OP *o)
7440 OP * const kid = cUNOPo->op_first;
7442 PERL_ARGS_ASSERT_CK_METHOD;
7444 if (kid->op_type == OP_CONST) {
7445 SV* sv = kSVOP->op_sv;
7446 const char * const method = SvPVX_const(sv);
7447 if (!(strchr(method, ':') || strchr(method, '\''))) {
7449 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7450 sv = newSVpvn_share(method, SvCUR(sv), 0);
7453 kSVOP->op_sv = NULL;
7455 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7457 op_getmad(o,cmop,'O');
7468 Perl_ck_null(pTHX_ OP *o)
7470 PERL_ARGS_ASSERT_CK_NULL;
7471 PERL_UNUSED_CONTEXT;
7476 Perl_ck_open(pTHX_ OP *o)
7479 HV * const table = GvHV(PL_hintgv);
7481 PERL_ARGS_ASSERT_CK_OPEN;
7484 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7487 const char *d = SvPV_const(*svp, len);
7488 const I32 mode = mode_from_discipline(d, len);
7489 if (mode & O_BINARY)
7490 o->op_private |= OPpOPEN_IN_RAW;
7491 else if (mode & O_TEXT)
7492 o->op_private |= OPpOPEN_IN_CRLF;
7495 svp = hv_fetchs(table, "open_OUT", FALSE);
7498 const char *d = SvPV_const(*svp, len);
7499 const I32 mode = mode_from_discipline(d, len);
7500 if (mode & O_BINARY)
7501 o->op_private |= OPpOPEN_OUT_RAW;
7502 else if (mode & O_TEXT)
7503 o->op_private |= OPpOPEN_OUT_CRLF;
7506 if (o->op_type == OP_BACKTICK) {
7507 if (!(o->op_flags & OPf_KIDS)) {
7508 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7510 op_getmad(o,newop,'O');
7519 /* In case of three-arg dup open remove strictness
7520 * from the last arg if it is a bareword. */
7521 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7522 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7526 if ((last->op_type == OP_CONST) && /* The bareword. */
7527 (last->op_private & OPpCONST_BARE) &&
7528 (last->op_private & OPpCONST_STRICT) &&
7529 (oa = first->op_sibling) && /* The fh. */
7530 (oa = oa->op_sibling) && /* The mode. */
7531 (oa->op_type == OP_CONST) &&
7532 SvPOK(((SVOP*)oa)->op_sv) &&
7533 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7534 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7535 (last == oa->op_sibling)) /* The bareword. */
7536 last->op_private &= ~OPpCONST_STRICT;
7542 Perl_ck_repeat(pTHX_ OP *o)
7544 PERL_ARGS_ASSERT_CK_REPEAT;
7546 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7547 o->op_private |= OPpREPEAT_DOLIST;
7548 cBINOPo->op_first = force_list(cBINOPo->op_first);
7556 Perl_ck_require(pTHX_ OP *o)
7561 PERL_ARGS_ASSERT_CK_REQUIRE;
7563 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7564 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7566 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7567 SV * const sv = kid->op_sv;
7568 U32 was_readonly = SvREADONLY(sv);
7575 sv_force_normal_flags(sv, 0);
7576 assert(!SvREADONLY(sv));
7586 for (; s < end; s++) {
7587 if (*s == ':' && s[1] == ':') {
7589 Move(s+2, s+1, end - s - 1, char);
7594 sv_catpvs(sv, ".pm");
7595 SvFLAGS(sv) |= was_readonly;
7599 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7600 /* handle override, if any */
7601 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7602 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7603 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7604 gv = gvp ? *gvp : NULL;
7608 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7609 OP * const kid = cUNOPo->op_first;
7612 cUNOPo->op_first = 0;
7616 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7617 append_elem(OP_LIST, kid,
7618 scalar(newUNOP(OP_RV2CV, 0,
7621 op_getmad(o,newop,'O');
7629 Perl_ck_return(pTHX_ OP *o)
7633 PERL_ARGS_ASSERT_CK_RETURN;
7635 if (CvLVALUE(PL_compcv)) {
7637 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7638 mod(kid, OP_LEAVESUBLV);
7644 Perl_ck_select(pTHX_ OP *o)
7649 PERL_ARGS_ASSERT_CK_SELECT;
7651 if (o->op_flags & OPf_KIDS) {
7652 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7653 if (kid && kid->op_sibling) {
7654 o->op_type = OP_SSELECT;
7655 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7657 return fold_constants(o);
7661 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7662 if (kid && kid->op_type == OP_RV2GV)
7663 kid->op_private &= ~HINT_STRICT_REFS;
7668 Perl_ck_shift(pTHX_ OP *o)
7671 const I32 type = o->op_type;
7673 PERL_ARGS_ASSERT_CK_SHIFT;
7675 if (!(o->op_flags & OPf_KIDS)) {
7677 /* FIXME - this can be refactored to reduce code in #ifdefs */
7679 OP * const oldo = o;
7683 argop = newUNOP(OP_RV2AV, 0,
7684 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7686 o = newUNOP(type, 0, scalar(argop));
7687 op_getmad(oldo,o,'O');
7690 return newUNOP(type, 0, scalar(argop));
7693 return scalar(modkids(ck_fun(o), type));
7697 Perl_ck_sort(pTHX_ OP *o)
7702 PERL_ARGS_ASSERT_CK_SORT;
7704 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7705 HV * const hinthv = GvHV(PL_hintgv);
7707 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7709 const I32 sorthints = (I32)SvIV(*svp);
7710 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7711 o->op_private |= OPpSORT_QSORT;
7712 if ((sorthints & HINT_SORT_STABLE) != 0)
7713 o->op_private |= OPpSORT_STABLE;
7718 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7720 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7721 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7723 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7725 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7727 if (kid->op_type == OP_SCOPE) {
7731 else if (kid->op_type == OP_LEAVE) {
7732 if (o->op_type == OP_SORT) {
7733 op_null(kid); /* wipe out leave */
7736 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7737 if (k->op_next == kid)
7739 /* don't descend into loops */
7740 else if (k->op_type == OP_ENTERLOOP
7741 || k->op_type == OP_ENTERITER)
7743 k = cLOOPx(k)->op_lastop;
7748 kid->op_next = 0; /* just disconnect the leave */
7749 k = kLISTOP->op_first;
7754 if (o->op_type == OP_SORT) {
7755 /* provide scalar context for comparison function/block */
7761 o->op_flags |= OPf_SPECIAL;
7763 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7766 firstkid = firstkid->op_sibling;
7769 /* provide list context for arguments */
7770 if (o->op_type == OP_SORT)
7777 S_simplify_sort(pTHX_ OP *o)
7780 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7786 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7788 if (!(o->op_flags & OPf_STACKED))
7790 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7791 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7792 kid = kUNOP->op_first; /* get past null */
7793 if (kid->op_type != OP_SCOPE)
7795 kid = kLISTOP->op_last; /* get past scope */
7796 switch(kid->op_type) {
7804 k = kid; /* remember this node*/
7805 if (kBINOP->op_first->op_type != OP_RV2SV)
7807 kid = kBINOP->op_first; /* get past cmp */
7808 if (kUNOP->op_first->op_type != OP_GV)
7810 kid = kUNOP->op_first; /* get past rv2sv */
7812 if (GvSTASH(gv) != PL_curstash)
7814 gvname = GvNAME(gv);
7815 if (*gvname == 'a' && gvname[1] == '\0')
7817 else if (*gvname == 'b' && gvname[1] == '\0')
7822 kid = k; /* back to cmp */
7823 if (kBINOP->op_last->op_type != OP_RV2SV)
7825 kid = kBINOP->op_last; /* down to 2nd arg */
7826 if (kUNOP->op_first->op_type != OP_GV)
7828 kid = kUNOP->op_first; /* get past rv2sv */
7830 if (GvSTASH(gv) != PL_curstash)
7832 gvname = GvNAME(gv);
7834 ? !(*gvname == 'a' && gvname[1] == '\0')
7835 : !(*gvname == 'b' && gvname[1] == '\0'))
7837 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7839 o->op_private |= OPpSORT_DESCEND;
7840 if (k->op_type == OP_NCMP)
7841 o->op_private |= OPpSORT_NUMERIC;
7842 if (k->op_type == OP_I_NCMP)
7843 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7844 kid = cLISTOPo->op_first->op_sibling;
7845 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7847 op_getmad(kid,o,'S'); /* then delete it */
7849 op_free(kid); /* then delete it */
7854 Perl_ck_split(pTHX_ OP *o)
7859 PERL_ARGS_ASSERT_CK_SPLIT;
7861 if (o->op_flags & OPf_STACKED)
7862 return no_fh_allowed(o);
7864 kid = cLISTOPo->op_first;
7865 if (kid->op_type != OP_NULL)
7866 Perl_croak(aTHX_ "panic: ck_split");
7867 kid = kid->op_sibling;
7868 op_free(cLISTOPo->op_first);
7869 cLISTOPo->op_first = kid;
7871 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7872 cLISTOPo->op_last = kid; /* There was only one element previously */
7875 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7876 OP * const sibl = kid->op_sibling;
7877 kid->op_sibling = 0;
7878 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7879 if (cLISTOPo->op_first == cLISTOPo->op_last)
7880 cLISTOPo->op_last = kid;
7881 cLISTOPo->op_first = kid;
7882 kid->op_sibling = sibl;
7885 kid->op_type = OP_PUSHRE;
7886 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7888 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7889 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7890 "Use of /g modifier is meaningless in split");
7893 if (!kid->op_sibling)
7894 append_elem(OP_SPLIT, o, newDEFSVOP());
7896 kid = kid->op_sibling;
7899 if (!kid->op_sibling)
7900 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7901 assert(kid->op_sibling);
7903 kid = kid->op_sibling;
7906 if (kid->op_sibling)
7907 return too_many_arguments(o,OP_DESC(o));
7913 Perl_ck_join(pTHX_ OP *o)
7915 const OP * const kid = cLISTOPo->op_first->op_sibling;
7917 PERL_ARGS_ASSERT_CK_JOIN;
7919 if (kid && kid->op_type == OP_MATCH) {
7920 if (ckWARN(WARN_SYNTAX)) {
7921 const REGEXP *re = PM_GETRE(kPMOP);
7922 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7923 const STRLEN len = re ? RX_PRELEN(re) : 6;
7924 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7925 "/%.*s/ should probably be written as \"%.*s\"",
7926 (int)len, pmstr, (int)len, pmstr);
7933 Perl_ck_subr(pTHX_ OP *o)
7936 OP *prev = ((cUNOPo->op_first->op_sibling)
7937 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7938 OP *o2 = prev->op_sibling;
7940 const char *proto = NULL;
7941 const char *proto_end = NULL;
7946 I32 contextclass = 0;
7947 const char *e = NULL;
7950 PERL_ARGS_ASSERT_CK_SUBR;
7952 o->op_private |= OPpENTERSUB_HASTARG;
7953 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7954 if (cvop->op_type == OP_RV2CV) {
7956 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7957 op_null(cvop); /* disable rv2cv */
7958 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7959 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7960 GV *gv = cGVOPx_gv(tmpop);
7963 tmpop->op_private |= OPpEARLY_CV;
7967 namegv = CvANON(cv) ? gv : CvGV(cv);
7968 proto = SvPV(MUTABLE_SV(cv), len);
7969 proto_end = proto + len;
7974 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7975 if (o2->op_type == OP_CONST)
7976 o2->op_private &= ~OPpCONST_STRICT;
7977 else if (o2->op_type == OP_LIST) {
7978 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7979 if (sib && sib->op_type == OP_CONST)
7980 sib->op_private &= ~OPpCONST_STRICT;
7983 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7984 if (PERLDB_SUB && PL_curstash != PL_debstash)
7985 o->op_private |= OPpENTERSUB_DB;
7986 while (o2 != cvop) {
7988 if (PL_madskills && o2->op_type == OP_STUB) {
7989 o2 = o2->op_sibling;
7992 if (PL_madskills && o2->op_type == OP_NULL)
7993 o3 = ((UNOP*)o2)->op_first;
7997 if (proto >= proto_end)
7998 return too_many_arguments(o, gv_ename(namegv));
8006 /* _ must be at the end */
8007 if (proto[1] && proto[1] != ';')
8022 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8024 arg == 1 ? "block or sub {}" : "sub {}",
8025 gv_ename(namegv), o3);
8028 /* '*' allows any scalar type, including bareword */
8031 if (o3->op_type == OP_RV2GV)
8032 goto wrapref; /* autoconvert GLOB -> GLOBref */
8033 else if (o3->op_type == OP_CONST)
8034 o3->op_private &= ~OPpCONST_STRICT;
8035 else if (o3->op_type == OP_ENTERSUB) {
8036 /* accidental subroutine, revert to bareword */
8037 OP *gvop = ((UNOP*)o3)->op_first;
8038 if (gvop && gvop->op_type == OP_NULL) {
8039 gvop = ((UNOP*)gvop)->op_first;
8041 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8044 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8045 (gvop = ((UNOP*)gvop)->op_first) &&
8046 gvop->op_type == OP_GV)
8048 GV * const gv = cGVOPx_gv(gvop);
8049 OP * const sibling = o2->op_sibling;
8050 SV * const n = newSVpvs("");
8052 OP * const oldo2 = o2;
8056 gv_fullname4(n, gv, "", FALSE);
8057 o2 = newSVOP(OP_CONST, 0, n);
8058 op_getmad(oldo2,o2,'O');
8059 prev->op_sibling = o2;
8060 o2->op_sibling = sibling;
8076 if (contextclass++ == 0) {
8077 e = strchr(proto, ']');
8078 if (!e || e == proto)
8087 const char *p = proto;
8088 const char *const end = proto;
8090 while (*--p != '[') {}
8091 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8093 gv_ename(namegv), o3);
8098 if (o3->op_type == OP_RV2GV)
8101 bad_type(arg, "symbol", gv_ename(namegv), o3);
8104 if (o3->op_type == OP_ENTERSUB)
8107 bad_type(arg, "subroutine entry", gv_ename(namegv),
8111 if (o3->op_type == OP_RV2SV ||
8112 o3->op_type == OP_PADSV ||
8113 o3->op_type == OP_HELEM ||
8114 o3->op_type == OP_AELEM)
8117 bad_type(arg, "scalar", gv_ename(namegv), o3);
8120 if (o3->op_type == OP_RV2AV ||
8121 o3->op_type == OP_PADAV)
8124 bad_type(arg, "array", gv_ename(namegv), o3);
8127 if (o3->op_type == OP_RV2HV ||
8128 o3->op_type == OP_PADHV)
8131 bad_type(arg, "hash", gv_ename(namegv), o3);
8136 OP* const sib = kid->op_sibling;
8137 kid->op_sibling = 0;
8138 o2 = newUNOP(OP_REFGEN, 0, kid);
8139 o2->op_sibling = sib;
8140 prev->op_sibling = o2;
8142 if (contextclass && e) {
8157 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8158 gv_ename(namegv), SVfARG(cv));
8163 mod(o2, OP_ENTERSUB);
8165 o2 = o2->op_sibling;
8167 if (o2 == cvop && proto && *proto == '_') {
8168 /* generate an access to $_ */
8170 o2->op_sibling = prev->op_sibling;
8171 prev->op_sibling = o2; /* instead of cvop */
8173 if (proto && !optional && proto_end > proto &&
8174 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8175 return too_few_arguments(o, gv_ename(namegv));
8178 OP * const oldo = o;
8182 o=newSVOP(OP_CONST, 0, newSViv(0));
8183 op_getmad(oldo,o,'O');
8189 Perl_ck_svconst(pTHX_ OP *o)
8191 PERL_ARGS_ASSERT_CK_SVCONST;
8192 PERL_UNUSED_CONTEXT;
8193 SvREADONLY_on(cSVOPo->op_sv);
8198 Perl_ck_chdir(pTHX_ OP *o)
8200 if (o->op_flags & OPf_KIDS) {
8201 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8203 if (kid && kid->op_type == OP_CONST &&
8204 (kid->op_private & OPpCONST_BARE))
8206 o->op_flags |= OPf_SPECIAL;
8207 kid->op_private &= ~OPpCONST_STRICT;
8214 Perl_ck_trunc(pTHX_ OP *o)
8216 PERL_ARGS_ASSERT_CK_TRUNC;
8218 if (o->op_flags & OPf_KIDS) {
8219 SVOP *kid = (SVOP*)cUNOPo->op_first;
8221 if (kid->op_type == OP_NULL)
8222 kid = (SVOP*)kid->op_sibling;
8223 if (kid && kid->op_type == OP_CONST &&
8224 (kid->op_private & OPpCONST_BARE))
8226 o->op_flags |= OPf_SPECIAL;
8227 kid->op_private &= ~OPpCONST_STRICT;
8234 Perl_ck_unpack(pTHX_ OP *o)
8236 OP *kid = cLISTOPo->op_first;
8238 PERL_ARGS_ASSERT_CK_UNPACK;
8240 if (kid->op_sibling) {
8241 kid = kid->op_sibling;
8242 if (!kid->op_sibling)
8243 kid->op_sibling = newDEFSVOP();
8249 Perl_ck_substr(pTHX_ OP *o)
8251 PERL_ARGS_ASSERT_CK_SUBSTR;
8254 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8255 OP *kid = cLISTOPo->op_first;
8257 if (kid->op_type == OP_NULL)
8258 kid = kid->op_sibling;
8260 kid->op_flags |= OPf_MOD;
8267 Perl_ck_each(pTHX_ OP *o)
8270 OP *kid = cLISTOPo->op_first;
8272 PERL_ARGS_ASSERT_CK_EACH;
8274 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8275 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8276 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8277 o->op_type = new_type;
8278 o->op_ppaddr = PL_ppaddr[new_type];
8280 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8281 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8283 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8289 /* A peephole optimizer. We visit the ops in the order they're to execute.
8290 * See the comments at the top of this file for more details about when
8291 * peep() is called */
8294 Perl_peep(pTHX_ register OP *o)
8297 register OP* oldop = NULL;
8299 if (!o || o->op_opt)
8303 SAVEVPTR(PL_curcop);
8304 for (; o; o = o->op_next) {
8307 /* By default, this op has now been optimised. A couple of cases below
8308 clear this again. */
8311 switch (o->op_type) {
8314 PL_curcop = ((COP*)o); /* for warnings */
8318 if (cSVOPo->op_private & OPpCONST_STRICT)
8319 no_bareword_allowed(o);
8322 case OP_METHOD_NAMED:
8323 /* Relocate sv to the pad for thread safety.
8324 * Despite being a "constant", the SV is written to,
8325 * for reference counts, sv_upgrade() etc. */
8327 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8328 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8329 /* If op_sv is already a PADTMP then it is being used by
8330 * some pad, so make a copy. */
8331 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8332 SvREADONLY_on(PAD_SVl(ix));
8333 SvREFCNT_dec(cSVOPo->op_sv);
8335 else if (o->op_type != OP_METHOD_NAMED
8336 && cSVOPo->op_sv == &PL_sv_undef) {
8337 /* PL_sv_undef is hack - it's unsafe to store it in the
8338 AV that is the pad, because av_fetch treats values of
8339 PL_sv_undef as a "free" AV entry and will merrily
8340 replace them with a new SV, causing pad_alloc to think
8341 that this pad slot is free. (When, clearly, it is not)
8343 SvOK_off(PAD_SVl(ix));
8344 SvPADTMP_on(PAD_SVl(ix));
8345 SvREADONLY_on(PAD_SVl(ix));
8348 SvREFCNT_dec(PAD_SVl(ix));
8349 SvPADTMP_on(cSVOPo->op_sv);
8350 PAD_SETSV(ix, cSVOPo->op_sv);
8351 /* XXX I don't know how this isn't readonly already. */
8352 SvREADONLY_on(PAD_SVl(ix));
8354 cSVOPo->op_sv = NULL;
8361 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8362 if (o->op_next->op_private & OPpTARGET_MY) {
8363 if (o->op_flags & OPf_STACKED) /* chained concats */
8364 break; /* ignore_optimization */
8366 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8367 o->op_targ = o->op_next->op_targ;
8368 o->op_next->op_targ = 0;
8369 o->op_private |= OPpTARGET_MY;
8372 op_null(o->op_next);
8376 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8377 break; /* Scalar stub must produce undef. List stub is noop */
8381 if (o->op_targ == OP_NEXTSTATE
8382 || o->op_targ == OP_DBSTATE)
8384 PL_curcop = ((COP*)o);
8386 /* XXX: We avoid setting op_seq here to prevent later calls
8387 to peep() from mistakenly concluding that optimisation
8388 has already occurred. This doesn't fix the real problem,
8389 though (See 20010220.007). AMS 20010719 */
8390 /* op_seq functionality is now replaced by op_opt */
8397 if (oldop && o->op_next) {
8398 oldop->op_next = o->op_next;
8406 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8407 OP* const pop = (o->op_type == OP_PADAV) ?
8408 o->op_next : o->op_next->op_next;
8410 if (pop && pop->op_type == OP_CONST &&
8411 ((PL_op = pop->op_next)) &&
8412 pop->op_next->op_type == OP_AELEM &&
8413 !(pop->op_next->op_private &
8414 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8415 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8420 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8421 no_bareword_allowed(pop);
8422 if (o->op_type == OP_GV)
8423 op_null(o->op_next);
8424 op_null(pop->op_next);
8426 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8427 o->op_next = pop->op_next->op_next;
8428 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8429 o->op_private = (U8)i;
8430 if (o->op_type == OP_GV) {
8435 o->op_flags |= OPf_SPECIAL;
8436 o->op_type = OP_AELEMFAST;
8441 if (o->op_next->op_type == OP_RV2SV) {
8442 if (!(o->op_next->op_private & OPpDEREF)) {
8443 op_null(o->op_next);
8444 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8446 o->op_next = o->op_next->op_next;
8447 o->op_type = OP_GVSV;
8448 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8451 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8452 GV * const gv = cGVOPo_gv;
8453 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8454 /* XXX could check prototype here instead of just carping */
8455 SV * const sv = sv_newmortal();
8456 gv_efullname3(sv, gv, NULL);
8457 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8458 "%"SVf"() called too early to check prototype",
8462 else if (o->op_next->op_type == OP_READLINE
8463 && o->op_next->op_next->op_type == OP_CONCAT
8464 && (o->op_next->op_next->op_flags & OPf_STACKED))
8466 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8467 o->op_type = OP_RCATLINE;
8468 o->op_flags |= OPf_STACKED;
8469 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8470 op_null(o->op_next->op_next);
8471 op_null(o->op_next);
8487 while (cLOGOP->op_other->op_type == OP_NULL)
8488 cLOGOP->op_other = cLOGOP->op_other->op_next;
8489 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8494 while (cLOOP->op_redoop->op_type == OP_NULL)
8495 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8496 peep(cLOOP->op_redoop);
8497 while (cLOOP->op_nextop->op_type == OP_NULL)
8498 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8499 peep(cLOOP->op_nextop);
8500 while (cLOOP->op_lastop->op_type == OP_NULL)
8501 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8502 peep(cLOOP->op_lastop);
8506 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8507 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8508 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8509 cPMOP->op_pmstashstartu.op_pmreplstart
8510 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8511 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8515 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8516 && ckWARN(WARN_SYNTAX))
8518 if (o->op_next->op_sibling) {
8519 const OPCODE type = o->op_next->op_sibling->op_type;
8520 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8521 const line_t oldline = CopLINE(PL_curcop);
8522 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8523 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8524 "Statement unlikely to be reached");
8525 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8526 "\t(Maybe you meant system() when you said exec()?)\n");
8527 CopLINE_set(PL_curcop, oldline);
8538 const char *key = NULL;
8541 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8544 /* Make the CONST have a shared SV */
8545 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8546 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8547 key = SvPV_const(sv, keylen);
8548 lexname = newSVpvn_share(key,
8549 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8555 if ((o->op_private & (OPpLVAL_INTRO)))
8558 rop = (UNOP*)((BINOP*)o)->op_first;
8559 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8561 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8562 if (!SvPAD_TYPED(lexname))
8564 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8565 if (!fields || !GvHV(*fields))
8567 key = SvPV_const(*svp, keylen);
8568 if (!hv_fetch(GvHV(*fields), key,
8569 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8571 Perl_croak(aTHX_ "No such class field \"%s\" "
8572 "in variable %s of type %s",
8573 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8586 SVOP *first_key_op, *key_op;
8588 if ((o->op_private & (OPpLVAL_INTRO))
8589 /* I bet there's always a pushmark... */
8590 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8591 /* hmmm, no optimization if list contains only one key. */
8593 rop = (UNOP*)((LISTOP*)o)->op_last;
8594 if (rop->op_type != OP_RV2HV)
8596 if (rop->op_first->op_type == OP_PADSV)
8597 /* @$hash{qw(keys here)} */
8598 rop = (UNOP*)rop->op_first;
8600 /* @{$hash}{qw(keys here)} */
8601 if (rop->op_first->op_type == OP_SCOPE
8602 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8604 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8610 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8611 if (!SvPAD_TYPED(lexname))
8613 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8614 if (!fields || !GvHV(*fields))
8616 /* Again guessing that the pushmark can be jumped over.... */
8617 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8618 ->op_first->op_sibling;
8619 for (key_op = first_key_op; key_op;
8620 key_op = (SVOP*)key_op->op_sibling) {
8621 if (key_op->op_type != OP_CONST)
8623 svp = cSVOPx_svp(key_op);
8624 key = SvPV_const(*svp, keylen);
8625 if (!hv_fetch(GvHV(*fields), key,
8626 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8628 Perl_croak(aTHX_ "No such class field \"%s\" "
8629 "in variable %s of type %s",
8630 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8637 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8641 /* check that RHS of sort is a single plain array */
8642 OP *oright = cUNOPo->op_first;
8643 if (!oright || oright->op_type != OP_PUSHMARK)
8646 /* reverse sort ... can be optimised. */
8647 if (!cUNOPo->op_sibling) {
8648 /* Nothing follows us on the list. */
8649 OP * const reverse = o->op_next;
8651 if (reverse->op_type == OP_REVERSE &&
8652 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8653 OP * const pushmark = cUNOPx(reverse)->op_first;
8654 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8655 && (cUNOPx(pushmark)->op_sibling == o)) {
8656 /* reverse -> pushmark -> sort */
8657 o->op_private |= OPpSORT_REVERSE;
8659 pushmark->op_next = oright->op_next;
8665 /* make @a = sort @a act in-place */
8667 oright = cUNOPx(oright)->op_sibling;
8670 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8671 oright = cUNOPx(oright)->op_sibling;
8675 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8676 || oright->op_next != o
8677 || (oright->op_private & OPpLVAL_INTRO)
8681 /* o2 follows the chain of op_nexts through the LHS of the
8682 * assign (if any) to the aassign op itself */
8684 if (!o2 || o2->op_type != OP_NULL)
8687 if (!o2 || o2->op_type != OP_PUSHMARK)
8690 if (o2 && o2->op_type == OP_GV)
8693 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8694 || (o2->op_private & OPpLVAL_INTRO)
8699 if (!o2 || o2->op_type != OP_NULL)
8702 if (!o2 || o2->op_type != OP_AASSIGN
8703 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8706 /* check that the sort is the first arg on RHS of assign */
8708 o2 = cUNOPx(o2)->op_first;
8709 if (!o2 || o2->op_type != OP_NULL)
8711 o2 = cUNOPx(o2)->op_first;
8712 if (!o2 || o2->op_type != OP_PUSHMARK)
8714 if (o2->op_sibling != o)
8717 /* check the array is the same on both sides */
8718 if (oleft->op_type == OP_RV2AV) {
8719 if (oright->op_type != OP_RV2AV
8720 || !cUNOPx(oright)->op_first
8721 || cUNOPx(oright)->op_first->op_type != OP_GV
8722 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8723 cGVOPx_gv(cUNOPx(oright)->op_first)
8727 else if (oright->op_type != OP_PADAV
8728 || oright->op_targ != oleft->op_targ
8732 /* transfer MODishness etc from LHS arg to RHS arg */
8733 oright->op_flags = oleft->op_flags;
8734 o->op_private |= OPpSORT_INPLACE;
8736 /* excise push->gv->rv2av->null->aassign */
8737 o2 = o->op_next->op_next;
8738 op_null(o2); /* PUSHMARK */
8740 if (o2->op_type == OP_GV) {
8741 op_null(o2); /* GV */
8744 op_null(o2); /* RV2AV or PADAV */
8745 o2 = o2->op_next->op_next;
8746 op_null(o2); /* AASSIGN */
8748 o->op_next = o2->op_next;
8754 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8756 LISTOP *enter, *exlist;
8758 enter = (LISTOP *) o->op_next;
8761 if (enter->op_type == OP_NULL) {
8762 enter = (LISTOP *) enter->op_next;
8766 /* for $a (...) will have OP_GV then OP_RV2GV here.
8767 for (...) just has an OP_GV. */
8768 if (enter->op_type == OP_GV) {
8769 gvop = (OP *) enter;
8770 enter = (LISTOP *) enter->op_next;
8773 if (enter->op_type == OP_RV2GV) {
8774 enter = (LISTOP *) enter->op_next;
8780 if (enter->op_type != OP_ENTERITER)
8783 iter = enter->op_next;
8784 if (!iter || iter->op_type != OP_ITER)
8787 expushmark = enter->op_first;
8788 if (!expushmark || expushmark->op_type != OP_NULL
8789 || expushmark->op_targ != OP_PUSHMARK)
8792 exlist = (LISTOP *) expushmark->op_sibling;
8793 if (!exlist || exlist->op_type != OP_NULL
8794 || exlist->op_targ != OP_LIST)
8797 if (exlist->op_last != o) {
8798 /* Mmm. Was expecting to point back to this op. */
8801 theirmark = exlist->op_first;
8802 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8805 if (theirmark->op_sibling != o) {
8806 /* There's something between the mark and the reverse, eg
8807 for (1, reverse (...))
8812 ourmark = ((LISTOP *)o)->op_first;
8813 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8816 ourlast = ((LISTOP *)o)->op_last;
8817 if (!ourlast || ourlast->op_next != o)
8820 rv2av = ourmark->op_sibling;
8821 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8822 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8823 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8824 /* We're just reversing a single array. */
8825 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8826 enter->op_flags |= OPf_STACKED;
8829 /* We don't have control over who points to theirmark, so sacrifice
8831 theirmark->op_next = ourmark->op_next;
8832 theirmark->op_flags = ourmark->op_flags;
8833 ourlast->op_next = gvop ? gvop : (OP *) enter;
8836 enter->op_private |= OPpITER_REVERSED;
8837 iter->op_private |= OPpITER_REVERSED;
8844 UNOP *refgen, *rv2cv;
8847 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8850 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8853 rv2gv = ((BINOP *)o)->op_last;
8854 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8857 refgen = (UNOP *)((BINOP *)o)->op_first;
8859 if (!refgen || refgen->op_type != OP_REFGEN)
8862 exlist = (LISTOP *)refgen->op_first;
8863 if (!exlist || exlist->op_type != OP_NULL
8864 || exlist->op_targ != OP_LIST)
8867 if (exlist->op_first->op_type != OP_PUSHMARK)
8870 rv2cv = (UNOP*)exlist->op_last;
8872 if (rv2cv->op_type != OP_RV2CV)
8875 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8876 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8877 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8879 o->op_private |= OPpASSIGN_CV_TO_GV;
8880 rv2gv->op_private |= OPpDONT_INIT_GV;
8881 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8889 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8890 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8900 Perl_custom_op_name(pTHX_ const OP* o)
8903 const IV index = PTR2IV(o->op_ppaddr);
8907 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8909 if (!PL_custom_op_names) /* This probably shouldn't happen */
8910 return (char *)PL_op_name[OP_CUSTOM];
8912 keysv = sv_2mortal(newSViv(index));
8914 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8916 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8918 return SvPV_nolen(HeVAL(he));
8922 Perl_custom_op_desc(pTHX_ const OP* o)
8925 const IV index = PTR2IV(o->op_ppaddr);
8929 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8931 if (!PL_custom_op_descs)
8932 return (char *)PL_op_desc[OP_CUSTOM];
8934 keysv = sv_2mortal(newSViv(index));
8936 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8938 return (char *)PL_op_desc[OP_CUSTOM];
8940 return SvPV_nolen(HeVAL(he));
8945 /* Efficient sub that returns a constant scalar value. */
8947 const_sv_xsub(pTHX_ CV* cv)
8954 Perl_croak(aTHX_ "usage: %s::%s()",
8955 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8959 ST(0) = MUTABLE_SV(XSANY.any_ptr);
8965 * c-indentation-style: bsd
8967 * indent-tabs-mode: t
8970 * ex: set ts=8 sts=4 sw=4 noet: