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 S_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 S_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 S_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 S_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 S_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_sawparens(pTHX_ OP *o)
2157 PERL_UNUSED_CONTEXT;
2159 o->op_flags |= OPf_PARENS;
2164 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2168 const OPCODE ltype = left->op_type;
2169 const OPCODE rtype = right->op_type;
2171 PERL_ARGS_ASSERT_BIND_MATCH;
2173 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2174 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2176 const char * const desc
2177 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2178 ? (int)rtype : OP_MATCH];
2179 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2180 ? "@array" : "%hash");
2181 Perl_warner(aTHX_ packWARN(WARN_MISC),
2182 "Applying %s to %s will act on scalar(%s)",
2183 desc, sample, sample);
2186 if (rtype == OP_CONST &&
2187 cSVOPx(right)->op_private & OPpCONST_BARE &&
2188 cSVOPx(right)->op_private & OPpCONST_STRICT)
2190 no_bareword_allowed(right);
2193 ismatchop = rtype == OP_MATCH ||
2194 rtype == OP_SUBST ||
2196 if (ismatchop && right->op_private & OPpTARGET_MY) {
2198 right->op_private &= ~OPpTARGET_MY;
2200 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2203 right->op_flags |= OPf_STACKED;
2204 if (rtype != OP_MATCH &&
2205 ! (rtype == OP_TRANS &&
2206 right->op_private & OPpTRANS_IDENTICAL))
2207 newleft = mod(left, rtype);
2210 if (right->op_type == OP_TRANS)
2211 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2213 o = prepend_elem(rtype, scalar(newleft), right);
2215 return newUNOP(OP_NOT, 0, scalar(o));
2219 return bind_match(type, left,
2220 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2224 Perl_invert(pTHX_ OP *o)
2228 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2232 Perl_scope(pTHX_ OP *o)
2236 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2237 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2238 o->op_type = OP_LEAVE;
2239 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2241 else if (o->op_type == OP_LINESEQ) {
2243 o->op_type = OP_SCOPE;
2244 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2245 kid = ((LISTOP*)o)->op_first;
2246 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2249 /* The following deals with things like 'do {1 for 1}' */
2250 kid = kid->op_sibling;
2252 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2257 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2263 Perl_block_start(pTHX_ int full)
2266 const int retval = PL_savestack_ix;
2267 pad_block_start(full);
2269 PL_hints &= ~HINT_BLOCK_SCOPE;
2270 SAVECOMPILEWARNINGS();
2271 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2276 Perl_block_end(pTHX_ I32 floor, OP *seq)
2279 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2280 OP* const retval = scalarseq(seq);
2282 CopHINTS_set(&PL_compiling, PL_hints);
2284 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2293 const PADOFFSET offset = pad_findmy("$_");
2294 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2295 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2298 OP * const o = newOP(OP_PADSV, 0);
2299 o->op_targ = offset;
2305 Perl_newPROG(pTHX_ OP *o)
2309 PERL_ARGS_ASSERT_NEWPROG;
2314 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2315 ((PL_in_eval & EVAL_KEEPERR)
2316 ? OPf_SPECIAL : 0), o);
2317 PL_eval_start = linklist(PL_eval_root);
2318 PL_eval_root->op_private |= OPpREFCOUNTED;
2319 OpREFCNT_set(PL_eval_root, 1);
2320 PL_eval_root->op_next = 0;
2321 CALL_PEEP(PL_eval_start);
2324 if (o->op_type == OP_STUB) {
2325 PL_comppad_name = 0;
2327 S_op_destroy(aTHX_ o);
2330 PL_main_root = scope(sawparens(scalarvoid(o)));
2331 PL_curcop = &PL_compiling;
2332 PL_main_start = LINKLIST(PL_main_root);
2333 PL_main_root->op_private |= OPpREFCOUNTED;
2334 OpREFCNT_set(PL_main_root, 1);
2335 PL_main_root->op_next = 0;
2336 CALL_PEEP(PL_main_start);
2339 /* Register with debugger */
2341 CV * const cv = get_cvs("DB::postponed", 0);
2345 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2347 call_sv(MUTABLE_SV(cv), G_DISCARD);
2354 Perl_localize(pTHX_ OP *o, I32 lex)
2358 PERL_ARGS_ASSERT_LOCALIZE;
2360 if (o->op_flags & OPf_PARENS)
2361 /* [perl #17376]: this appears to be premature, and results in code such as
2362 C< our(%x); > executing in list mode rather than void mode */
2369 if ( PL_parser->bufptr > PL_parser->oldbufptr
2370 && PL_parser->bufptr[-1] == ','
2371 && ckWARN(WARN_PARENTHESIS))
2373 char *s = PL_parser->bufptr;
2376 /* some heuristics to detect a potential error */
2377 while (*s && (strchr(", \t\n", *s)))
2381 if (*s && strchr("@$%*", *s) && *++s
2382 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2385 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2387 while (*s && (strchr(", \t\n", *s)))
2393 if (sigil && (*s == ';' || *s == '=')) {
2394 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2395 "Parentheses missing around \"%s\" list",
2397 ? (PL_parser->in_my == KEY_our
2399 : PL_parser->in_my == KEY_state
2409 o = mod(o, OP_NULL); /* a bit kludgey */
2410 PL_parser->in_my = FALSE;
2411 PL_parser->in_my_stash = NULL;
2416 Perl_jmaybe(pTHX_ OP *o)
2418 PERL_ARGS_ASSERT_JMAYBE;
2420 if (o->op_type == OP_LIST) {
2422 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2423 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2429 S_fold_constants(pTHX_ register OP *o)
2432 register OP * VOL curop;
2434 VOL I32 type = o->op_type;
2439 SV * const oldwarnhook = PL_warnhook;
2440 SV * const olddiehook = PL_diehook;
2444 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2446 if (PL_opargs[type] & OA_RETSCALAR)
2448 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2449 o->op_targ = pad_alloc(type, SVs_PADTMP);
2451 /* integerize op, unless it happens to be C<-foo>.
2452 * XXX should pp_i_negate() do magic string negation instead? */
2453 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2454 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2455 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2457 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2460 if (!(PL_opargs[type] & OA_FOLDCONST))
2465 /* XXX might want a ck_negate() for this */
2466 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2477 /* XXX what about the numeric ops? */
2478 if (PL_hints & HINT_LOCALE)
2483 if (PL_parser && PL_parser->error_count)
2484 goto nope; /* Don't try to run w/ errors */
2486 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2487 const OPCODE type = curop->op_type;
2488 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2490 type != OP_SCALAR &&
2492 type != OP_PUSHMARK)
2498 curop = LINKLIST(o);
2499 old_next = o->op_next;
2503 oldscope = PL_scopestack_ix;
2504 create_eval_scope(G_FAKINGEVAL);
2506 /* Verify that we don't need to save it: */
2507 assert(PL_curcop == &PL_compiling);
2508 StructCopy(&PL_compiling, ¬_compiling, COP);
2509 PL_curcop = ¬_compiling;
2510 /* The above ensures that we run with all the correct hints of the
2511 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2512 assert(IN_PERL_RUNTIME);
2513 PL_warnhook = PERL_WARNHOOK_FATAL;
2520 sv = *(PL_stack_sp--);
2521 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2522 pad_swipe(o->op_targ, FALSE);
2523 else if (SvTEMP(sv)) { /* grab mortal temp? */
2524 SvREFCNT_inc_simple_void(sv);
2529 /* Something tried to die. Abandon constant folding. */
2530 /* Pretend the error never happened. */
2532 o->op_next = old_next;
2536 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2537 PL_warnhook = oldwarnhook;
2538 PL_diehook = olddiehook;
2539 /* XXX note that this croak may fail as we've already blown away
2540 * the stack - eg any nested evals */
2541 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2544 PL_warnhook = oldwarnhook;
2545 PL_diehook = olddiehook;
2546 PL_curcop = &PL_compiling;
2548 if (PL_scopestack_ix > oldscope)
2549 delete_eval_scope();
2558 if (type == OP_RV2GV)
2559 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2561 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2562 op_getmad(o,newop,'f');
2570 S_gen_constant_list(pTHX_ register OP *o)
2574 const I32 oldtmps_floor = PL_tmps_floor;
2577 if (PL_parser && PL_parser->error_count)
2578 return o; /* Don't attempt to run with errors */
2580 PL_op = curop = LINKLIST(o);
2586 assert (!(curop->op_flags & OPf_SPECIAL));
2587 assert(curop->op_type == OP_RANGE);
2589 PL_tmps_floor = oldtmps_floor;
2591 o->op_type = OP_RV2AV;
2592 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2593 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2594 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2595 o->op_opt = 0; /* needs to be revisited in peep() */
2596 curop = ((UNOP*)o)->op_first;
2597 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2599 op_getmad(curop,o,'O');
2608 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2611 if (!o || o->op_type != OP_LIST)
2612 o = newLISTOP(OP_LIST, 0, o, NULL);
2614 o->op_flags &= ~OPf_WANT;
2616 if (!(PL_opargs[type] & OA_MARK))
2617 op_null(cLISTOPo->op_first);
2619 o->op_type = (OPCODE)type;
2620 o->op_ppaddr = PL_ppaddr[type];
2621 o->op_flags |= flags;
2623 o = CHECKOP(type, o);
2624 if (o->op_type != (unsigned)type)
2627 return fold_constants(o);
2630 /* List constructors */
2633 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2641 if (first->op_type != (unsigned)type
2642 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2644 return newLISTOP(type, 0, first, last);
2647 if (first->op_flags & OPf_KIDS)
2648 ((LISTOP*)first)->op_last->op_sibling = last;
2650 first->op_flags |= OPf_KIDS;
2651 ((LISTOP*)first)->op_first = last;
2653 ((LISTOP*)first)->op_last = last;
2658 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2666 if (first->op_type != (unsigned)type)
2667 return prepend_elem(type, (OP*)first, (OP*)last);
2669 if (last->op_type != (unsigned)type)
2670 return append_elem(type, (OP*)first, (OP*)last);
2672 first->op_last->op_sibling = last->op_first;
2673 first->op_last = last->op_last;
2674 first->op_flags |= (last->op_flags & OPf_KIDS);
2677 if (last->op_first && first->op_madprop) {
2678 MADPROP *mp = last->op_first->op_madprop;
2680 while (mp->mad_next)
2682 mp->mad_next = first->op_madprop;
2685 last->op_first->op_madprop = first->op_madprop;
2688 first->op_madprop = last->op_madprop;
2689 last->op_madprop = 0;
2692 S_op_destroy(aTHX_ (OP*)last);
2698 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2706 if (last->op_type == (unsigned)type) {
2707 if (type == OP_LIST) { /* already a PUSHMARK there */
2708 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2709 ((LISTOP*)last)->op_first->op_sibling = first;
2710 if (!(first->op_flags & OPf_PARENS))
2711 last->op_flags &= ~OPf_PARENS;
2714 if (!(last->op_flags & OPf_KIDS)) {
2715 ((LISTOP*)last)->op_last = first;
2716 last->op_flags |= OPf_KIDS;
2718 first->op_sibling = ((LISTOP*)last)->op_first;
2719 ((LISTOP*)last)->op_first = first;
2721 last->op_flags |= OPf_KIDS;
2725 return newLISTOP(type, 0, first, last);
2733 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2736 Newxz(tk, 1, TOKEN);
2737 tk->tk_type = (OPCODE)optype;
2738 tk->tk_type = 12345;
2740 tk->tk_mad = madprop;
2745 Perl_token_free(pTHX_ TOKEN* tk)
2747 PERL_ARGS_ASSERT_TOKEN_FREE;
2749 if (tk->tk_type != 12345)
2751 mad_free(tk->tk_mad);
2756 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2761 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2763 if (tk->tk_type != 12345) {
2764 Perl_warner(aTHX_ packWARN(WARN_MISC),
2765 "Invalid TOKEN object ignored");
2772 /* faked up qw list? */
2774 tm->mad_type == MAD_SV &&
2775 SvPVX((const SV *)tm->mad_val)[0] == 'q')
2782 /* pretend constant fold didn't happen? */
2783 if (mp->mad_key == 'f' &&
2784 (o->op_type == OP_CONST ||
2785 o->op_type == OP_GV) )
2787 token_getmad(tk,(OP*)mp->mad_val,slot);
2801 if (mp->mad_key == 'X')
2802 mp->mad_key = slot; /* just change the first one */
2812 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2821 /* pretend constant fold didn't happen? */
2822 if (mp->mad_key == 'f' &&
2823 (o->op_type == OP_CONST ||
2824 o->op_type == OP_GV) )
2826 op_getmad(from,(OP*)mp->mad_val,slot);
2833 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2836 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2842 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2851 /* pretend constant fold didn't happen? */
2852 if (mp->mad_key == 'f' &&
2853 (o->op_type == OP_CONST ||
2854 o->op_type == OP_GV) )
2856 op_getmad(from,(OP*)mp->mad_val,slot);
2863 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2866 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2870 PerlIO_printf(PerlIO_stderr(),
2871 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2877 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2895 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2899 addmad(tm, &(o->op_madprop), slot);
2903 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2924 Perl_newMADsv(pTHX_ char key, SV* sv)
2926 PERL_ARGS_ASSERT_NEWMADSV;
2928 return newMADPROP(key, MAD_SV, sv, 0);
2932 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2935 Newxz(mp, 1, MADPROP);
2938 mp->mad_vlen = vlen;
2939 mp->mad_type = type;
2941 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2946 Perl_mad_free(pTHX_ MADPROP* mp)
2948 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2952 mad_free(mp->mad_next);
2953 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2954 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2955 switch (mp->mad_type) {
2959 Safefree((char*)mp->mad_val);
2962 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2963 op_free((OP*)mp->mad_val);
2966 sv_free(MUTABLE_SV(mp->mad_val));
2969 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2978 Perl_newNULLLIST(pTHX)
2980 return newOP(OP_STUB, 0);
2984 S_force_list(pTHX_ OP *o)
2986 if (!o || o->op_type != OP_LIST)
2987 o = newLISTOP(OP_LIST, 0, o, NULL);
2993 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2998 NewOp(1101, listop, 1, LISTOP);
3000 listop->op_type = (OPCODE)type;
3001 listop->op_ppaddr = PL_ppaddr[type];
3004 listop->op_flags = (U8)flags;
3008 else if (!first && last)
3011 first->op_sibling = last;
3012 listop->op_first = first;
3013 listop->op_last = last;
3014 if (type == OP_LIST) {
3015 OP* const pushop = newOP(OP_PUSHMARK, 0);
3016 pushop->op_sibling = first;
3017 listop->op_first = pushop;
3018 listop->op_flags |= OPf_KIDS;
3020 listop->op_last = pushop;
3023 return CHECKOP(type, listop);
3027 Perl_newOP(pTHX_ I32 type, I32 flags)
3031 NewOp(1101, o, 1, OP);
3032 o->op_type = (OPCODE)type;
3033 o->op_ppaddr = PL_ppaddr[type];
3034 o->op_flags = (U8)flags;
3036 o->op_latefreed = 0;
3040 o->op_private = (U8)(0 | (flags >> 8));
3041 if (PL_opargs[type] & OA_RETSCALAR)
3043 if (PL_opargs[type] & OA_TARGET)
3044 o->op_targ = pad_alloc(type, SVs_PADTMP);
3045 return CHECKOP(type, o);
3049 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3055 first = newOP(OP_STUB, 0);
3056 if (PL_opargs[type] & OA_MARK)
3057 first = force_list(first);
3059 NewOp(1101, unop, 1, UNOP);
3060 unop->op_type = (OPCODE)type;
3061 unop->op_ppaddr = PL_ppaddr[type];
3062 unop->op_first = first;
3063 unop->op_flags = (U8)(flags | OPf_KIDS);
3064 unop->op_private = (U8)(1 | (flags >> 8));
3065 unop = (UNOP*) CHECKOP(type, unop);
3069 return fold_constants((OP *) unop);
3073 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3077 NewOp(1101, binop, 1, BINOP);
3080 first = newOP(OP_NULL, 0);
3082 binop->op_type = (OPCODE)type;
3083 binop->op_ppaddr = PL_ppaddr[type];
3084 binop->op_first = first;
3085 binop->op_flags = (U8)(flags | OPf_KIDS);
3088 binop->op_private = (U8)(1 | (flags >> 8));
3091 binop->op_private = (U8)(2 | (flags >> 8));
3092 first->op_sibling = last;
3095 binop = (BINOP*)CHECKOP(type, binop);
3096 if (binop->op_next || binop->op_type != (OPCODE)type)
3099 binop->op_last = binop->op_first->op_sibling;
3101 return fold_constants((OP *)binop);
3104 static int uvcompare(const void *a, const void *b)
3105 __attribute__nonnull__(1)
3106 __attribute__nonnull__(2)
3107 __attribute__pure__;
3108 static int uvcompare(const void *a, const void *b)
3110 if (*((const UV *)a) < (*(const UV *)b))
3112 if (*((const UV *)a) > (*(const UV *)b))
3114 if (*((const UV *)a+1) < (*(const UV *)b+1))
3116 if (*((const UV *)a+1) > (*(const UV *)b+1))
3122 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3125 SV * const tstr = ((SVOP*)expr)->op_sv;
3128 (repl->op_type == OP_NULL)
3129 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3131 ((SVOP*)repl)->op_sv;
3134 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3135 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3139 register short *tbl;
3141 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3142 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3143 I32 del = o->op_private & OPpTRANS_DELETE;
3146 PERL_ARGS_ASSERT_PMTRANS;
3148 PL_hints |= HINT_BLOCK_SCOPE;
3151 o->op_private |= OPpTRANS_FROM_UTF;
3154 o->op_private |= OPpTRANS_TO_UTF;
3156 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3157 SV* const listsv = newSVpvs("# comment\n");
3159 const U8* tend = t + tlen;
3160 const U8* rend = r + rlen;
3174 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3175 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3178 const U32 flags = UTF8_ALLOW_DEFAULT;
3182 t = tsave = bytes_to_utf8(t, &len);
3185 if (!to_utf && rlen) {
3187 r = rsave = bytes_to_utf8(r, &len);
3191 /* There are several snags with this code on EBCDIC:
3192 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3193 2. scan_const() in toke.c has encoded chars in native encoding which makes
3194 ranges at least in EBCDIC 0..255 range the bottom odd.
3198 U8 tmpbuf[UTF8_MAXBYTES+1];
3201 Newx(cp, 2*tlen, UV);
3203 transv = newSVpvs("");
3205 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3207 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3209 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3213 cp[2*i+1] = cp[2*i];
3217 qsort(cp, i, 2*sizeof(UV), uvcompare);
3218 for (j = 0; j < i; j++) {
3220 diff = val - nextmin;
3222 t = uvuni_to_utf8(tmpbuf,nextmin);
3223 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3225 U8 range_mark = UTF_TO_NATIVE(0xff);
3226 t = uvuni_to_utf8(tmpbuf, val - 1);
3227 sv_catpvn(transv, (char *)&range_mark, 1);
3228 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3235 t = uvuni_to_utf8(tmpbuf,nextmin);
3236 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3238 U8 range_mark = UTF_TO_NATIVE(0xff);
3239 sv_catpvn(transv, (char *)&range_mark, 1);
3241 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3242 UNICODE_ALLOW_SUPER);
3243 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3244 t = (const U8*)SvPVX_const(transv);
3245 tlen = SvCUR(transv);
3249 else if (!rlen && !del) {
3250 r = t; rlen = tlen; rend = tend;
3253 if ((!rlen && !del) || t == r ||
3254 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3256 o->op_private |= OPpTRANS_IDENTICAL;
3260 while (t < tend || tfirst <= tlast) {
3261 /* see if we need more "t" chars */
3262 if (tfirst > tlast) {
3263 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3265 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3267 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3274 /* now see if we need more "r" chars */
3275 if (rfirst > rlast) {
3277 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3279 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3281 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3290 rfirst = rlast = 0xffffffff;
3294 /* now see which range will peter our first, if either. */
3295 tdiff = tlast - tfirst;
3296 rdiff = rlast - rfirst;
3303 if (rfirst == 0xffffffff) {
3304 diff = tdiff; /* oops, pretend rdiff is infinite */
3306 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3307 (long)tfirst, (long)tlast);
3309 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3313 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3314 (long)tfirst, (long)(tfirst + diff),
3317 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3318 (long)tfirst, (long)rfirst);
3320 if (rfirst + diff > max)
3321 max = rfirst + diff;
3323 grows = (tfirst < rfirst &&
3324 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3336 else if (max > 0xff)
3341 PerlMemShared_free(cPVOPo->op_pv);
3342 cPVOPo->op_pv = NULL;
3344 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3346 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3347 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3348 PAD_SETSV(cPADOPo->op_padix, swash);
3351 cSVOPo->op_sv = swash;
3353 SvREFCNT_dec(listsv);
3354 SvREFCNT_dec(transv);
3356 if (!del && havefinal && rlen)
3357 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3358 newSVuv((UV)final), 0);
3361 o->op_private |= OPpTRANS_GROWS;
3367 op_getmad(expr,o,'e');
3368 op_getmad(repl,o,'r');
3376 tbl = (short*)cPVOPo->op_pv;
3378 Zero(tbl, 256, short);
3379 for (i = 0; i < (I32)tlen; i++)
3381 for (i = 0, j = 0; i < 256; i++) {
3383 if (j >= (I32)rlen) {
3392 if (i < 128 && r[j] >= 128)
3402 o->op_private |= OPpTRANS_IDENTICAL;
3404 else if (j >= (I32)rlen)
3409 PerlMemShared_realloc(tbl,
3410 (0x101+rlen-j) * sizeof(short));
3411 cPVOPo->op_pv = (char*)tbl;
3413 tbl[0x100] = (short)(rlen - j);
3414 for (i=0; i < (I32)rlen - j; i++)
3415 tbl[0x101+i] = r[j+i];
3419 if (!rlen && !del) {
3422 o->op_private |= OPpTRANS_IDENTICAL;
3424 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3425 o->op_private |= OPpTRANS_IDENTICAL;
3427 for (i = 0; i < 256; i++)
3429 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3430 if (j >= (I32)rlen) {
3432 if (tbl[t[i]] == -1)
3438 if (tbl[t[i]] == -1) {
3439 if (t[i] < 128 && r[j] >= 128)
3446 if(ckWARN(WARN_MISC)) {
3447 if(del && rlen == tlen) {
3448 Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3449 } else if(rlen > tlen) {
3450 Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
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 */
4358 deprecate("assignment to $[");
4360 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4361 o->op_private |= OPpCONST_ARYBASE;
4369 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4372 const U32 seq = intro_my();
4375 NewOp(1101, cop, 1, COP);
4376 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4377 cop->op_type = OP_DBSTATE;
4378 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4381 cop->op_type = OP_NEXTSTATE;
4382 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4384 cop->op_flags = (U8)flags;
4385 CopHINTS_set(cop, PL_hints);
4387 cop->op_private |= NATIVE_HINTS;
4389 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4390 cop->op_next = (OP*)cop;
4393 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4394 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4396 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4397 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4398 if (cop->cop_hints_hash) {
4400 cop->cop_hints_hash->refcounted_he_refcnt++;
4401 HINTS_REFCNT_UNLOCK;
4405 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4407 PL_hints |= HINT_BLOCK_SCOPE;
4408 /* It seems that we need to defer freeing this pointer, as other parts
4409 of the grammar end up wanting to copy it after this op has been
4414 if (PL_parser && PL_parser->copline == NOLINE)
4415 CopLINE_set(cop, CopLINE(PL_curcop));
4417 CopLINE_set(cop, PL_parser->copline);
4419 PL_parser->copline = NOLINE;
4422 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4424 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4426 CopSTASH_set(cop, PL_curstash);
4428 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4429 /* this line can have a breakpoint - store the cop in IV */
4430 AV *av = CopFILEAVx(PL_curcop);
4432 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4433 if (svp && *svp != &PL_sv_undef ) {
4434 (void)SvIOK_on(*svp);
4435 SvIV_set(*svp, PTR2IV(cop));
4440 if (flags & OPf_SPECIAL)
4442 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4447 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4451 PERL_ARGS_ASSERT_NEWLOGOP;
4453 return new_logop(type, flags, &first, &other);
4457 S_search_const(pTHX_ OP *o)
4459 PERL_ARGS_ASSERT_SEARCH_CONST;
4461 switch (o->op_type) {
4465 if (o->op_flags & OPf_KIDS)
4466 return search_const(cUNOPo->op_first);
4473 if (!(o->op_flags & OPf_KIDS))
4475 kid = cLISTOPo->op_first;
4477 switch (kid->op_type) {
4481 kid = kid->op_sibling;
4484 if (kid != cLISTOPo->op_last)
4490 kid = cLISTOPo->op_last;
4492 return search_const(kid);
4500 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4508 int prepend_not = 0;
4510 PERL_ARGS_ASSERT_NEW_LOGOP;
4515 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4516 return newBINOP(type, flags, scalar(first), scalar(other));
4518 scalarboolean(first);
4519 /* optimize AND and OR ops that have NOTs as children */
4520 if (first->op_type == OP_NOT
4521 && (first->op_flags & OPf_KIDS)
4522 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4523 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4525 if (type == OP_AND || type == OP_OR) {
4531 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4533 prepend_not = 1; /* prepend a NOT op later */
4537 /* search for a constant op that could let us fold the test */
4538 if ((cstop = search_const(first))) {
4539 if (cstop->op_private & OPpCONST_STRICT)
4540 no_bareword_allowed(cstop);
4541 else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4542 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4543 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4544 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4545 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4547 if (other->op_type == OP_CONST)
4548 other->op_private |= OPpCONST_SHORTCIRCUIT;
4550 OP *newop = newUNOP(OP_NULL, 0, other);
4551 op_getmad(first, newop, '1');
4552 newop->op_targ = type; /* set "was" field */
4559 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4560 const OP *o2 = other;
4561 if ( ! (o2->op_type == OP_LIST
4562 && (( o2 = cUNOPx(o2)->op_first))
4563 && o2->op_type == OP_PUSHMARK
4564 && (( o2 = o2->op_sibling)) )
4567 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4568 || o2->op_type == OP_PADHV)
4569 && o2->op_private & OPpLVAL_INTRO
4570 && !(o2->op_private & OPpPAD_STATE)
4571 && ckWARN(WARN_DEPRECATED))
4573 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4574 "Deprecated use of my() in false conditional");
4578 if (first->op_type == OP_CONST)
4579 first->op_private |= OPpCONST_SHORTCIRCUIT;
4581 first = newUNOP(OP_NULL, 0, first);
4582 op_getmad(other, first, '2');
4583 first->op_targ = type; /* set "was" field */
4590 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4591 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4593 const OP * const k1 = ((UNOP*)first)->op_first;
4594 const OP * const k2 = k1->op_sibling;
4596 switch (first->op_type)
4599 if (k2 && k2->op_type == OP_READLINE
4600 && (k2->op_flags & OPf_STACKED)
4601 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4603 warnop = k2->op_type;
4608 if (k1->op_type == OP_READDIR
4609 || k1->op_type == OP_GLOB
4610 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4611 || k1->op_type == OP_EACH)
4613 warnop = ((k1->op_type == OP_NULL)
4614 ? (OPCODE)k1->op_targ : k1->op_type);
4619 const line_t oldline = CopLINE(PL_curcop);
4620 CopLINE_set(PL_curcop, PL_parser->copline);
4621 Perl_warner(aTHX_ packWARN(WARN_MISC),
4622 "Value of %s%s can be \"0\"; test with defined()",
4624 ((warnop == OP_READLINE || warnop == OP_GLOB)
4625 ? " construct" : "() operator"));
4626 CopLINE_set(PL_curcop, oldline);
4633 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4634 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4636 NewOp(1101, logop, 1, LOGOP);
4638 logop->op_type = (OPCODE)type;
4639 logop->op_ppaddr = PL_ppaddr[type];
4640 logop->op_first = first;
4641 logop->op_flags = (U8)(flags | OPf_KIDS);
4642 logop->op_other = LINKLIST(other);
4643 logop->op_private = (U8)(1 | (flags >> 8));
4645 /* establish postfix order */
4646 logop->op_next = LINKLIST(first);
4647 first->op_next = (OP*)logop;
4648 first->op_sibling = other;
4650 CHECKOP(type,logop);
4652 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4659 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4667 PERL_ARGS_ASSERT_NEWCONDOP;
4670 return newLOGOP(OP_AND, 0, first, trueop);
4672 return newLOGOP(OP_OR, 0, first, falseop);
4674 scalarboolean(first);
4675 if ((cstop = search_const(first))) {
4676 /* Left or right arm of the conditional? */
4677 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4678 OP *live = left ? trueop : falseop;
4679 OP *const dead = left ? falseop : trueop;
4680 if (cstop->op_private & OPpCONST_BARE &&
4681 cstop->op_private & OPpCONST_STRICT) {
4682 no_bareword_allowed(cstop);
4685 /* This is all dead code when PERL_MAD is not defined. */
4686 live = newUNOP(OP_NULL, 0, live);
4687 op_getmad(first, live, 'C');
4688 op_getmad(dead, live, left ? 'e' : 't');
4695 NewOp(1101, logop, 1, LOGOP);
4696 logop->op_type = OP_COND_EXPR;
4697 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4698 logop->op_first = first;
4699 logop->op_flags = (U8)(flags | OPf_KIDS);
4700 logop->op_private = (U8)(1 | (flags >> 8));
4701 logop->op_other = LINKLIST(trueop);
4702 logop->op_next = LINKLIST(falseop);
4704 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4707 /* establish postfix order */
4708 start = LINKLIST(first);
4709 first->op_next = (OP*)logop;
4711 first->op_sibling = trueop;
4712 trueop->op_sibling = falseop;
4713 o = newUNOP(OP_NULL, 0, (OP*)logop);
4715 trueop->op_next = falseop->op_next = o;
4722 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4731 PERL_ARGS_ASSERT_NEWRANGE;
4733 NewOp(1101, range, 1, LOGOP);
4735 range->op_type = OP_RANGE;
4736 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4737 range->op_first = left;
4738 range->op_flags = OPf_KIDS;
4739 leftstart = LINKLIST(left);
4740 range->op_other = LINKLIST(right);
4741 range->op_private = (U8)(1 | (flags >> 8));
4743 left->op_sibling = right;
4745 range->op_next = (OP*)range;
4746 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4747 flop = newUNOP(OP_FLOP, 0, flip);
4748 o = newUNOP(OP_NULL, 0, flop);
4750 range->op_next = leftstart;
4752 left->op_next = flip;
4753 right->op_next = flop;
4755 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4756 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4757 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4758 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4760 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4761 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4764 if (!flip->op_private || !flop->op_private)
4765 linklist(o); /* blow off optimizer unless constant */
4771 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4776 const bool once = block && block->op_flags & OPf_SPECIAL &&
4777 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4779 PERL_UNUSED_ARG(debuggable);
4782 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4783 return block; /* do {} while 0 does once */
4784 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4785 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4786 expr = newUNOP(OP_DEFINED, 0,
4787 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4788 } else if (expr->op_flags & OPf_KIDS) {
4789 const OP * const k1 = ((UNOP*)expr)->op_first;
4790 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4791 switch (expr->op_type) {
4793 if (k2 && k2->op_type == OP_READLINE
4794 && (k2->op_flags & OPf_STACKED)
4795 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4796 expr = newUNOP(OP_DEFINED, 0, expr);
4800 if (k1 && (k1->op_type == OP_READDIR
4801 || k1->op_type == OP_GLOB
4802 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4803 || k1->op_type == OP_EACH))
4804 expr = newUNOP(OP_DEFINED, 0, expr);
4810 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4811 * op, in listop. This is wrong. [perl #27024] */
4813 block = newOP(OP_NULL, 0);
4814 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4815 o = new_logop(OP_AND, 0, &expr, &listop);
4818 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4820 if (once && o != listop)
4821 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4824 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4826 o->op_flags |= flags;
4828 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4833 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4834 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4843 PERL_UNUSED_ARG(debuggable);
4846 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4847 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4848 expr = newUNOP(OP_DEFINED, 0,
4849 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4850 } else if (expr->op_flags & OPf_KIDS) {
4851 const OP * const k1 = ((UNOP*)expr)->op_first;
4852 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4853 switch (expr->op_type) {
4855 if (k2 && k2->op_type == OP_READLINE
4856 && (k2->op_flags & OPf_STACKED)
4857 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4858 expr = newUNOP(OP_DEFINED, 0, expr);
4862 if (k1 && (k1->op_type == OP_READDIR
4863 || k1->op_type == OP_GLOB
4864 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4865 || k1->op_type == OP_EACH))
4866 expr = newUNOP(OP_DEFINED, 0, expr);
4873 block = newOP(OP_NULL, 0);
4874 else if (cont || has_my) {
4875 block = scope(block);
4879 next = LINKLIST(cont);
4882 OP * const unstack = newOP(OP_UNSTACK, 0);
4885 cont = append_elem(OP_LINESEQ, cont, unstack);
4889 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4891 redo = LINKLIST(listop);
4894 PL_parser->copline = (line_t)whileline;
4896 o = new_logop(OP_AND, 0, &expr, &listop);
4897 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4898 op_free(expr); /* oops, it's a while (0) */
4900 return NULL; /* listop already freed by new_logop */
4903 ((LISTOP*)listop)->op_last->op_next =
4904 (o == listop ? redo : LINKLIST(o));
4910 NewOp(1101,loop,1,LOOP);
4911 loop->op_type = OP_ENTERLOOP;
4912 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4913 loop->op_private = 0;
4914 loop->op_next = (OP*)loop;
4917 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4919 loop->op_redoop = redo;
4920 loop->op_lastop = o;
4921 o->op_private |= loopflags;
4924 loop->op_nextop = next;
4926 loop->op_nextop = o;
4928 o->op_flags |= flags;
4929 o->op_private |= (flags >> 8);
4934 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4939 PADOFFSET padoff = 0;
4944 PERL_ARGS_ASSERT_NEWFOROP;
4947 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4948 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4949 sv->op_type = OP_RV2GV;
4950 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4952 /* The op_type check is needed to prevent a possible segfault
4953 * if the loop variable is undeclared and 'strict vars' is in
4954 * effect. This is illegal but is nonetheless parsed, so we
4955 * may reach this point with an OP_CONST where we're expecting
4958 if (cUNOPx(sv)->op_first->op_type == OP_GV
4959 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4960 iterpflags |= OPpITER_DEF;
4962 else if (sv->op_type == OP_PADSV) { /* private variable */
4963 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4964 padoff = sv->op_targ;
4974 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4976 SV *const namesv = PAD_COMPNAME_SV(padoff);
4978 const char *const name = SvPV_const(namesv, len);
4980 if (len == 2 && name[0] == '$' && name[1] == '_')
4981 iterpflags |= OPpITER_DEF;
4985 const PADOFFSET offset = pad_findmy("$_");
4986 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4987 sv = newGVOP(OP_GV, 0, PL_defgv);
4992 iterpflags |= OPpITER_DEF;
4994 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4995 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4996 iterflags |= OPf_STACKED;
4998 else if (expr->op_type == OP_NULL &&
4999 (expr->op_flags & OPf_KIDS) &&
5000 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5002 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5003 * set the STACKED flag to indicate that these values are to be
5004 * treated as min/max values by 'pp_iterinit'.
5006 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5007 LOGOP* const range = (LOGOP*) flip->op_first;
5008 OP* const left = range->op_first;
5009 OP* const right = left->op_sibling;
5012 range->op_flags &= ~OPf_KIDS;
5013 range->op_first = NULL;
5015 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5016 listop->op_first->op_next = range->op_next;
5017 left->op_next = range->op_other;
5018 right->op_next = (OP*)listop;
5019 listop->op_next = listop->op_first;
5022 op_getmad(expr,(OP*)listop,'O');
5026 expr = (OP*)(listop);
5028 iterflags |= OPf_STACKED;
5031 expr = mod(force_list(expr), OP_GREPSTART);
5034 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5035 append_elem(OP_LIST, expr, scalar(sv))));
5036 assert(!loop->op_next);
5037 /* for my $x () sets OPpLVAL_INTRO;
5038 * for our $x () sets OPpOUR_INTRO */
5039 loop->op_private = (U8)iterpflags;
5040 #ifdef PL_OP_SLAB_ALLOC
5043 NewOp(1234,tmp,1,LOOP);
5044 Copy(loop,tmp,1,LISTOP);
5045 S_op_destroy(aTHX_ (OP*)loop);
5049 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5051 loop->op_targ = padoff;
5052 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5054 op_getmad(madsv, (OP*)loop, 'v');
5055 PL_parser->copline = forline;
5056 return newSTATEOP(0, label, wop);
5060 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5065 PERL_ARGS_ASSERT_NEWLOOPEX;
5067 if (type != OP_GOTO || label->op_type == OP_CONST) {
5068 /* "last()" means "last" */
5069 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5070 o = newOP(type, OPf_SPECIAL);
5072 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5073 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5077 op_getmad(label,o,'L');
5083 /* Check whether it's going to be a goto &function */
5084 if (label->op_type == OP_ENTERSUB
5085 && !(label->op_flags & OPf_STACKED))
5086 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5087 o = newUNOP(type, OPf_STACKED, label);
5089 PL_hints |= HINT_BLOCK_SCOPE;
5093 /* if the condition is a literal array or hash
5094 (or @{ ... } etc), make a reference to it.
5097 S_ref_array_or_hash(pTHX_ OP *cond)
5100 && (cond->op_type == OP_RV2AV
5101 || cond->op_type == OP_PADAV
5102 || cond->op_type == OP_RV2HV
5103 || cond->op_type == OP_PADHV))
5105 return newUNOP(OP_REFGEN,
5106 0, mod(cond, OP_REFGEN));
5112 /* These construct the optree fragments representing given()
5115 entergiven and enterwhen are LOGOPs; the op_other pointer
5116 points up to the associated leave op. We need this so we
5117 can put it in the context and make break/continue work.
5118 (Also, of course, pp_enterwhen will jump straight to
5119 op_other if the match fails.)
5123 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5124 I32 enter_opcode, I32 leave_opcode,
5125 PADOFFSET entertarg)
5131 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5133 NewOp(1101, enterop, 1, LOGOP);
5134 enterop->op_type = (Optype)enter_opcode;
5135 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5136 enterop->op_flags = (U8) OPf_KIDS;
5137 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5138 enterop->op_private = 0;
5140 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5143 enterop->op_first = scalar(cond);
5144 cond->op_sibling = block;
5146 o->op_next = LINKLIST(cond);
5147 cond->op_next = (OP *) enterop;
5150 /* This is a default {} block */
5151 enterop->op_first = block;
5152 enterop->op_flags |= OPf_SPECIAL;
5154 o->op_next = (OP *) enterop;
5157 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5158 entergiven and enterwhen both
5161 enterop->op_next = LINKLIST(block);
5162 block->op_next = enterop->op_other = o;
5167 /* Does this look like a boolean operation? For these purposes
5168 a boolean operation is:
5169 - a subroutine call [*]
5170 - a logical connective
5171 - a comparison operator
5172 - a filetest operator, with the exception of -s -M -A -C
5173 - defined(), exists() or eof()
5174 - /$re/ or $foo =~ /$re/
5176 [*] possibly surprising
5179 S_looks_like_bool(pTHX_ const OP *o)
5183 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5185 switch(o->op_type) {
5187 return looks_like_bool(cLOGOPo->op_first);
5191 looks_like_bool(cLOGOPo->op_first)
5192 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5196 o->op_flags & OPf_KIDS
5197 && looks_like_bool(cUNOPo->op_first));
5201 case OP_NOT: case OP_XOR:
5202 /* Note that OP_DOR is not here */
5204 case OP_EQ: case OP_NE: case OP_LT:
5205 case OP_GT: case OP_LE: case OP_GE:
5207 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5208 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5210 case OP_SEQ: case OP_SNE: case OP_SLT:
5211 case OP_SGT: case OP_SLE: case OP_SGE:
5215 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5216 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5217 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5218 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5219 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5220 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5221 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5222 case OP_FTTEXT: case OP_FTBINARY:
5224 case OP_DEFINED: case OP_EXISTS:
5225 case OP_MATCH: case OP_EOF:
5230 /* Detect comparisons that have been optimized away */
5231 if (cSVOPo->op_sv == &PL_sv_yes
5232 || cSVOPo->op_sv == &PL_sv_no)
5243 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5246 PERL_ARGS_ASSERT_NEWGIVENOP;
5247 return newGIVWHENOP(
5248 ref_array_or_hash(cond),
5250 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5254 /* If cond is null, this is a default {} block */
5256 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5258 const bool cond_llb = (!cond || looks_like_bool(cond));
5261 PERL_ARGS_ASSERT_NEWWHENOP;
5266 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5268 scalar(ref_array_or_hash(cond)));
5271 return newGIVWHENOP(
5273 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5274 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5278 =for apidoc cv_undef
5280 Clear out all the active components of a CV. This can happen either
5281 by an explicit C<undef &foo>, or by the reference count going to zero.
5282 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5283 children can still follow the full lexical scope chain.
5289 Perl_cv_undef(pTHX_ CV *cv)
5293 PERL_ARGS_ASSERT_CV_UNDEF;
5295 DEBUG_X(PerlIO_printf(Perl_debug_log,
5296 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5297 PTR2UV(cv), PTR2UV(PL_comppad))
5301 if (CvFILE(cv) && !CvISXSUB(cv)) {
5302 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5303 Safefree(CvFILE(cv));
5308 if (!CvISXSUB(cv) && CvROOT(cv)) {
5309 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5310 Perl_croak(aTHX_ "Can't undef active subroutine");
5313 PAD_SAVE_SETNULLPAD();
5315 op_free(CvROOT(cv));
5320 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5325 /* remove CvOUTSIDE unless this is an undef rather than a free */
5326 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5327 if (!CvWEAKOUTSIDE(cv))
5328 SvREFCNT_dec(CvOUTSIDE(cv));
5329 CvOUTSIDE(cv) = NULL;
5332 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5335 if (CvISXSUB(cv) && CvXSUB(cv)) {
5338 /* delete all flags except WEAKOUTSIDE */
5339 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5343 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5346 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5348 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5349 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5350 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5351 || (p && (len != SvCUR(cv) /* Not the same length. */
5352 || memNE(p, SvPVX_const(cv), len))))
5353 && ckWARN_d(WARN_PROTOTYPE)) {
5354 SV* const msg = sv_newmortal();
5358 gv_efullname3(name = sv_newmortal(), gv, NULL);
5359 sv_setpvs(msg, "Prototype mismatch:");
5361 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5363 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5365 sv_catpvs(msg, ": none");
5366 sv_catpvs(msg, " vs ");
5368 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5370 sv_catpvs(msg, "none");
5371 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5375 static void const_sv_xsub(pTHX_ CV* cv);
5379 =head1 Optree Manipulation Functions
5381 =for apidoc cv_const_sv
5383 If C<cv> is a constant sub eligible for inlining. returns the constant
5384 value returned by the sub. Otherwise, returns NULL.
5386 Constant subs can be created with C<newCONSTSUB> or as described in
5387 L<perlsub/"Constant Functions">.
5392 Perl_cv_const_sv(pTHX_ const CV *const cv)
5394 PERL_UNUSED_CONTEXT;
5397 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5399 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5402 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5403 * Can be called in 3 ways:
5406 * look for a single OP_CONST with attached value: return the value
5408 * cv && CvCLONE(cv) && !CvCONST(cv)
5410 * examine the clone prototype, and if contains only a single
5411 * OP_CONST referencing a pad const, or a single PADSV referencing
5412 * an outer lexical, return a non-zero value to indicate the CV is
5413 * a candidate for "constizing" at clone time
5417 * We have just cloned an anon prototype that was marked as a const
5418 * candidiate. Try to grab the current value, and in the case of
5419 * PADSV, ignore it if it has multiple references. Return the value.
5423 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5434 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5435 o = cLISTOPo->op_first->op_sibling;
5437 for (; o; o = o->op_next) {
5438 const OPCODE type = o->op_type;
5440 if (sv && o->op_next == o)
5442 if (o->op_next != o) {
5443 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5445 if (type == OP_DBSTATE)
5448 if (type == OP_LEAVESUB || type == OP_RETURN)
5452 if (type == OP_CONST && cSVOPo->op_sv)
5454 else if (cv && type == OP_CONST) {
5455 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5459 else if (cv && type == OP_PADSV) {
5460 if (CvCONST(cv)) { /* newly cloned anon */
5461 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5462 /* the candidate should have 1 ref from this pad and 1 ref
5463 * from the parent */
5464 if (!sv || SvREFCNT(sv) != 2)
5471 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5472 sv = &PL_sv_undef; /* an arbitrary non-null value */
5487 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5490 /* This would be the return value, but the return cannot be reached. */
5491 OP* pegop = newOP(OP_NULL, 0);
5494 PERL_UNUSED_ARG(floor);
5504 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5506 NORETURN_FUNCTION_END;
5511 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5513 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5517 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5524 register CV *cv = NULL;
5526 /* If the subroutine has no body, no attributes, and no builtin attributes
5527 then it's just a sub declaration, and we may be able to get away with
5528 storing with a placeholder scalar in the symbol table, rather than a
5529 full GV and CV. If anything is present then it will take a full CV to
5531 const I32 gv_fetch_flags
5532 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5534 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5535 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5538 assert(proto->op_type == OP_CONST);
5539 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5544 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5545 SV * const sv = sv_newmortal();
5546 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5547 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5548 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5549 aname = SvPVX_const(sv);
5554 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5555 : gv_fetchpv(aname ? aname
5556 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5557 gv_fetch_flags, SVt_PVCV);
5559 if (!PL_madskills) {
5568 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5569 maximum a prototype before. */
5570 if (SvTYPE(gv) > SVt_NULL) {
5571 if (!SvPOK((const SV *)gv)
5572 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
5573 && ckWARN_d(WARN_PROTOTYPE))
5575 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5577 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5580 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5582 sv_setiv(MUTABLE_SV(gv), -1);
5584 SvREFCNT_dec(PL_compcv);
5585 cv = PL_compcv = NULL;
5589 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5591 #ifdef GV_UNIQUE_CHECK
5592 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5593 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5597 if (!block || !ps || *ps || attrs
5598 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5600 || block->op_type == OP_NULL
5605 const_sv = op_const_sv(block, NULL);
5608 const bool exists = CvROOT(cv) || CvXSUB(cv);
5610 #ifdef GV_UNIQUE_CHECK
5611 if (exists && GvUNIQUE(gv)) {
5612 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5616 /* if the subroutine doesn't exist and wasn't pre-declared
5617 * with a prototype, assume it will be AUTOLOADed,
5618 * skipping the prototype check
5620 if (exists || SvPOK(cv))
5621 cv_ckproto_len(cv, gv, ps, ps_len);
5622 /* already defined (or promised)? */
5623 if (exists || GvASSUMECV(gv)) {
5626 || block->op_type == OP_NULL
5629 if (CvFLAGS(PL_compcv)) {
5630 /* might have had built-in attrs applied */
5631 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5633 /* just a "sub foo;" when &foo is already defined */
5634 SAVEFREESV(PL_compcv);
5639 && block->op_type != OP_NULL
5642 if (ckWARN(WARN_REDEFINE)
5644 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5646 const line_t oldline = CopLINE(PL_curcop);
5647 if (PL_parser && PL_parser->copline != NOLINE)
5648 CopLINE_set(PL_curcop, PL_parser->copline);
5649 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5650 CvCONST(cv) ? "Constant subroutine %s redefined"
5651 : "Subroutine %s redefined", name);
5652 CopLINE_set(PL_curcop, oldline);
5655 if (!PL_minus_c) /* keep old one around for madskills */
5658 /* (PL_madskills unset in used file.) */
5666 SvREFCNT_inc_simple_void_NN(const_sv);
5668 assert(!CvROOT(cv) && !CvCONST(cv));
5669 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5670 CvXSUBANY(cv).any_ptr = const_sv;
5671 CvXSUB(cv) = const_sv_xsub;
5677 cv = newCONSTSUB(NULL, name, const_sv);
5679 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5680 (CvGV(cv) && GvSTASH(CvGV(cv)))
5689 SvREFCNT_dec(PL_compcv);
5697 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5698 * before we clobber PL_compcv.
5702 || block->op_type == OP_NULL
5705 rcv = MUTABLE_SV(cv);
5706 /* Might have had built-in attributes applied -- propagate them. */
5707 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5708 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5709 stash = GvSTASH(CvGV(cv));
5710 else if (CvSTASH(cv))
5711 stash = CvSTASH(cv);
5713 stash = PL_curstash;
5716 /* possibly about to re-define existing subr -- ignore old cv */
5717 rcv = MUTABLE_SV(PL_compcv);
5718 if (name && GvSTASH(gv))
5719 stash = GvSTASH(gv);
5721 stash = PL_curstash;
5723 apply_attrs(stash, rcv, attrs, FALSE);
5725 if (cv) { /* must reuse cv if autoloaded */
5732 || block->op_type == OP_NULL) && !PL_madskills
5735 /* got here with just attrs -- work done, so bug out */
5736 SAVEFREESV(PL_compcv);
5739 /* transfer PL_compcv to cv */
5741 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5742 if (!CvWEAKOUTSIDE(cv))
5743 SvREFCNT_dec(CvOUTSIDE(cv));
5744 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5745 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5746 CvOUTSIDE(PL_compcv) = 0;
5747 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5748 CvPADLIST(PL_compcv) = 0;
5749 /* inner references to PL_compcv must be fixed up ... */
5750 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5751 /* ... before we throw it away */
5752 SvREFCNT_dec(PL_compcv);
5754 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5755 ++PL_sub_generation;
5762 if (strEQ(name, "import")) {
5763 PL_formfeed = MUTABLE_SV(cv);
5764 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5768 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5772 CvFILE_set_from_cop(cv, PL_curcop);
5773 CvSTASH(cv) = PL_curstash;
5776 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5778 if (PL_parser && PL_parser->error_count) {
5782 const char *s = strrchr(name, ':');
5784 if (strEQ(s, "BEGIN")) {
5785 const char not_safe[] =
5786 "BEGIN not safe after errors--compilation aborted";
5787 if (PL_in_eval & EVAL_KEEPERR)
5788 Perl_croak(aTHX_ not_safe);
5790 /* force display of errors found but not reported */
5791 sv_catpv(ERRSV, not_safe);
5792 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5801 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5802 the debugger could be able to set a breakpoint in, so signal to
5803 pp_entereval that it should not throw away any saved lines at scope
5806 PL_breakable_sub_gen++;
5808 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5809 mod(scalarseq(block), OP_LEAVESUBLV));
5810 block->op_attached = 1;
5813 /* This makes sub {}; work as expected. */
5814 if (block->op_type == OP_STUB) {
5815 OP* const newblock = newSTATEOP(0, NULL, 0);
5817 op_getmad(block,newblock,'B');
5824 block->op_attached = 1;
5825 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5827 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5828 OpREFCNT_set(CvROOT(cv), 1);
5829 CvSTART(cv) = LINKLIST(CvROOT(cv));
5830 CvROOT(cv)->op_next = 0;
5831 CALL_PEEP(CvSTART(cv));
5833 /* now that optimizer has done its work, adjust pad values */
5835 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5838 assert(!CvCONST(cv));
5839 if (ps && !*ps && op_const_sv(block, cv))
5843 if (name || aname) {
5844 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5845 SV * const sv = newSV(0);
5846 SV * const tmpstr = sv_newmortal();
5847 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5848 GV_ADDMULTI, SVt_PVHV);
5851 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5853 (long)PL_subline, (long)CopLINE(PL_curcop));
5854 gv_efullname3(tmpstr, gv, NULL);
5855 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5856 SvCUR(tmpstr), sv, 0);
5857 hv = GvHVn(db_postponed);
5858 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5859 CV * const pcv = GvCV(db_postponed);
5865 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5870 if (name && ! (PL_parser && PL_parser->error_count))
5871 process_special_blocks(name, gv, cv);
5876 PL_parser->copline = NOLINE;
5882 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5885 const char *const colon = strrchr(fullname,':');
5886 const char *const name = colon ? colon + 1 : fullname;
5888 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5891 if (strEQ(name, "BEGIN")) {
5892 const I32 oldscope = PL_scopestack_ix;
5894 SAVECOPFILE(&PL_compiling);
5895 SAVECOPLINE(&PL_compiling);
5897 DEBUG_x( dump_sub(gv) );
5898 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5899 GvCV(gv) = 0; /* cv has been hijacked */
5900 call_list(oldscope, PL_beginav);
5902 PL_curcop = &PL_compiling;
5903 CopHINTS_set(&PL_compiling, PL_hints);
5910 if strEQ(name, "END") {
5911 DEBUG_x( dump_sub(gv) );
5912 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5915 } else if (*name == 'U') {
5916 if (strEQ(name, "UNITCHECK")) {
5917 /* It's never too late to run a unitcheck block */
5918 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5922 } else if (*name == 'C') {
5923 if (strEQ(name, "CHECK")) {
5924 if (PL_main_start && ckWARN(WARN_VOID))
5925 Perl_warner(aTHX_ packWARN(WARN_VOID),
5926 "Too late to run CHECK block");
5927 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5931 } else if (*name == 'I') {
5932 if (strEQ(name, "INIT")) {
5933 if (PL_main_start && ckWARN(WARN_VOID))
5934 Perl_warner(aTHX_ packWARN(WARN_VOID),
5935 "Too late to run INIT block");
5936 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5942 DEBUG_x( dump_sub(gv) );
5943 GvCV(gv) = 0; /* cv has been hijacked */
5948 =for apidoc newCONSTSUB
5950 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5951 eligible for inlining at compile-time.
5953 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5954 which won't be called if used as a destructor, but will suppress the overhead
5955 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5962 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5967 const char *const file = CopFILE(PL_curcop);
5969 SV *const temp_sv = CopFILESV(PL_curcop);
5970 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5975 if (IN_PERL_RUNTIME) {
5976 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5977 * an op shared between threads. Use a non-shared COP for our
5979 SAVEVPTR(PL_curcop);
5980 PL_curcop = &PL_compiling;
5982 SAVECOPLINE(PL_curcop);
5983 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5986 PL_hints &= ~HINT_BLOCK_SCOPE;
5989 SAVESPTR(PL_curstash);
5990 SAVECOPSTASH(PL_curcop);
5991 PL_curstash = stash;
5992 CopSTASH_set(PL_curcop,stash);
5995 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5996 and so doesn't get free()d. (It's expected to be from the C pre-
5997 processor __FILE__ directive). But we need a dynamically allocated one,
5998 and we need it to get freed. */
5999 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6000 XS_DYNAMIC_FILENAME);
6001 CvXSUBANY(cv).any_ptr = sv;
6006 CopSTASH_free(PL_curcop);
6014 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6015 const char *const filename, const char *const proto,
6018 CV *cv = newXS(name, subaddr, filename);
6020 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6022 if (flags & XS_DYNAMIC_FILENAME) {
6023 /* We need to "make arrangements" (ie cheat) to ensure that the
6024 filename lasts as long as the PVCV we just created, but also doesn't
6026 STRLEN filename_len = strlen(filename);
6027 STRLEN proto_and_file_len = filename_len;
6028 char *proto_and_file;
6032 proto_len = strlen(proto);
6033 proto_and_file_len += proto_len;
6035 Newx(proto_and_file, proto_and_file_len + 1, char);
6036 Copy(proto, proto_and_file, proto_len, char);
6037 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6040 proto_and_file = savepvn(filename, filename_len);
6043 /* This gets free()d. :-) */
6044 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6045 SV_HAS_TRAILING_NUL);
6047 /* This gives us the correct prototype, rather than one with the
6048 file name appended. */
6049 SvCUR_set(cv, proto_len);
6053 CvFILE(cv) = proto_and_file + proto_len;
6055 sv_setpv(MUTABLE_SV(cv), proto);
6061 =for apidoc U||newXS
6063 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6064 static storage, as it is used directly as CvFILE(), without a copy being made.
6070 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6073 GV * const gv = gv_fetchpv(name ? name :
6074 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6075 GV_ADDMULTI, SVt_PVCV);
6078 PERL_ARGS_ASSERT_NEWXS;
6081 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6083 if ((cv = (name ? GvCV(gv) : NULL))) {
6085 /* just a cached method */
6089 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6090 /* already defined (or promised) */
6091 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6092 if (ckWARN(WARN_REDEFINE)) {
6093 GV * const gvcv = CvGV(cv);
6095 HV * const stash = GvSTASH(gvcv);
6097 const char *redefined_name = HvNAME_get(stash);
6098 if ( strEQ(redefined_name,"autouse") ) {
6099 const line_t oldline = CopLINE(PL_curcop);
6100 if (PL_parser && PL_parser->copline != NOLINE)
6101 CopLINE_set(PL_curcop, PL_parser->copline);
6102 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6103 CvCONST(cv) ? "Constant subroutine %s redefined"
6104 : "Subroutine %s redefined"
6106 CopLINE_set(PL_curcop, oldline);
6116 if (cv) /* must reuse cv if autoloaded */
6119 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6123 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6127 (void)gv_fetchfile(filename);
6128 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6129 an external constant string */
6131 CvXSUB(cv) = subaddr;
6134 process_special_blocks(name, gv, cv);
6146 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6151 OP* pegop = newOP(OP_NULL, 0);
6155 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6156 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6158 #ifdef GV_UNIQUE_CHECK
6160 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6164 if ((cv = GvFORM(gv))) {
6165 if (ckWARN(WARN_REDEFINE)) {
6166 const line_t oldline = CopLINE(PL_curcop);
6167 if (PL_parser && PL_parser->copline != NOLINE)
6168 CopLINE_set(PL_curcop, PL_parser->copline);
6170 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6171 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6173 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6174 "Format STDOUT redefined");
6176 CopLINE_set(PL_curcop, oldline);
6183 CvFILE_set_from_cop(cv, PL_curcop);
6186 pad_tidy(padtidy_FORMAT);
6187 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6188 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6189 OpREFCNT_set(CvROOT(cv), 1);
6190 CvSTART(cv) = LINKLIST(CvROOT(cv));
6191 CvROOT(cv)->op_next = 0;
6192 CALL_PEEP(CvSTART(cv));
6194 op_getmad(o,pegop,'n');
6195 op_getmad_weak(block, pegop, 'b');
6200 PL_parser->copline = NOLINE;
6208 Perl_newANONLIST(pTHX_ OP *o)
6210 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6214 Perl_newANONHASH(pTHX_ OP *o)
6216 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6220 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6222 return newANONATTRSUB(floor, proto, NULL, block);
6226 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6228 return newUNOP(OP_REFGEN, 0,
6229 newSVOP(OP_ANONCODE, 0,
6230 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6234 Perl_oopsAV(pTHX_ OP *o)
6238 PERL_ARGS_ASSERT_OOPSAV;
6240 switch (o->op_type) {
6242 o->op_type = OP_PADAV;
6243 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6244 return ref(o, OP_RV2AV);
6247 o->op_type = OP_RV2AV;
6248 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6253 if (ckWARN_d(WARN_INTERNAL))
6254 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6261 Perl_oopsHV(pTHX_ OP *o)
6265 PERL_ARGS_ASSERT_OOPSHV;
6267 switch (o->op_type) {
6270 o->op_type = OP_PADHV;
6271 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6272 return ref(o, OP_RV2HV);
6276 o->op_type = OP_RV2HV;
6277 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6282 if (ckWARN_d(WARN_INTERNAL))
6283 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6290 Perl_newAVREF(pTHX_ OP *o)
6294 PERL_ARGS_ASSERT_NEWAVREF;
6296 if (o->op_type == OP_PADANY) {
6297 o->op_type = OP_PADAV;
6298 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6301 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6302 && ckWARN(WARN_DEPRECATED)) {
6303 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6304 "Using an array as a reference is deprecated");
6306 return newUNOP(OP_RV2AV, 0, scalar(o));
6310 Perl_newGVREF(pTHX_ I32 type, OP *o)
6312 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6313 return newUNOP(OP_NULL, 0, o);
6314 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6318 Perl_newHVREF(pTHX_ OP *o)
6322 PERL_ARGS_ASSERT_NEWHVREF;
6324 if (o->op_type == OP_PADANY) {
6325 o->op_type = OP_PADHV;
6326 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6329 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6330 && ckWARN(WARN_DEPRECATED)) {
6331 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6332 "Using a hash as a reference is deprecated");
6334 return newUNOP(OP_RV2HV, 0, scalar(o));
6338 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6340 return newUNOP(OP_RV2CV, flags, scalar(o));
6344 Perl_newSVREF(pTHX_ OP *o)
6348 PERL_ARGS_ASSERT_NEWSVREF;
6350 if (o->op_type == OP_PADANY) {
6351 o->op_type = OP_PADSV;
6352 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6355 return newUNOP(OP_RV2SV, 0, scalar(o));
6358 /* Check routines. See the comments at the top of this file for details
6359 * on when these are called */
6362 Perl_ck_anoncode(pTHX_ OP *o)
6364 PERL_ARGS_ASSERT_CK_ANONCODE;
6366 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6368 cSVOPo->op_sv = NULL;
6373 Perl_ck_bitop(pTHX_ OP *o)
6377 PERL_ARGS_ASSERT_CK_BITOP;
6379 #define OP_IS_NUMCOMPARE(op) \
6380 ((op) == OP_LT || (op) == OP_I_LT || \
6381 (op) == OP_GT || (op) == OP_I_GT || \
6382 (op) == OP_LE || (op) == OP_I_LE || \
6383 (op) == OP_GE || (op) == OP_I_GE || \
6384 (op) == OP_EQ || (op) == OP_I_EQ || \
6385 (op) == OP_NE || (op) == OP_I_NE || \
6386 (op) == OP_NCMP || (op) == OP_I_NCMP)
6387 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6388 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6389 && (o->op_type == OP_BIT_OR
6390 || o->op_type == OP_BIT_AND
6391 || o->op_type == OP_BIT_XOR))
6393 const OP * const left = cBINOPo->op_first;
6394 const OP * const right = left->op_sibling;
6395 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6396 (left->op_flags & OPf_PARENS) == 0) ||
6397 (OP_IS_NUMCOMPARE(right->op_type) &&
6398 (right->op_flags & OPf_PARENS) == 0))
6399 if (ckWARN(WARN_PRECEDENCE))
6400 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6401 "Possible precedence problem on bitwise %c operator",
6402 o->op_type == OP_BIT_OR ? '|'
6403 : o->op_type == OP_BIT_AND ? '&' : '^'
6410 Perl_ck_concat(pTHX_ OP *o)
6412 const OP * const kid = cUNOPo->op_first;
6414 PERL_ARGS_ASSERT_CK_CONCAT;
6415 PERL_UNUSED_CONTEXT;
6417 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6418 !(kUNOP->op_first->op_flags & OPf_MOD))
6419 o->op_flags |= OPf_STACKED;
6424 Perl_ck_spair(pTHX_ OP *o)
6428 PERL_ARGS_ASSERT_CK_SPAIR;
6430 if (o->op_flags & OPf_KIDS) {
6433 const OPCODE type = o->op_type;
6434 o = modkids(ck_fun(o), type);
6435 kid = cUNOPo->op_first;
6436 newop = kUNOP->op_first->op_sibling;
6438 const OPCODE type = newop->op_type;
6439 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6440 type == OP_PADAV || type == OP_PADHV ||
6441 type == OP_RV2AV || type == OP_RV2HV)
6445 op_getmad(kUNOP->op_first,newop,'K');
6447 op_free(kUNOP->op_first);
6449 kUNOP->op_first = newop;
6451 o->op_ppaddr = PL_ppaddr[++o->op_type];
6456 Perl_ck_delete(pTHX_ OP *o)
6458 PERL_ARGS_ASSERT_CK_DELETE;
6462 if (o->op_flags & OPf_KIDS) {
6463 OP * const kid = cUNOPo->op_first;
6464 switch (kid->op_type) {
6466 o->op_flags |= OPf_SPECIAL;
6469 o->op_private |= OPpSLICE;
6472 o->op_flags |= OPf_SPECIAL;
6477 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6486 Perl_ck_die(pTHX_ OP *o)
6488 PERL_ARGS_ASSERT_CK_DIE;
6491 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6497 Perl_ck_eof(pTHX_ OP *o)
6501 PERL_ARGS_ASSERT_CK_EOF;
6503 if (o->op_flags & OPf_KIDS) {
6504 if (cLISTOPo->op_first->op_type == OP_STUB) {
6506 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6508 op_getmad(o,newop,'O');
6520 Perl_ck_eval(pTHX_ OP *o)
6524 PERL_ARGS_ASSERT_CK_EVAL;
6526 PL_hints |= HINT_BLOCK_SCOPE;
6527 if (o->op_flags & OPf_KIDS) {
6528 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6531 o->op_flags &= ~OPf_KIDS;
6534 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6540 cUNOPo->op_first = 0;
6545 NewOp(1101, enter, 1, LOGOP);
6546 enter->op_type = OP_ENTERTRY;
6547 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6548 enter->op_private = 0;
6550 /* establish postfix order */
6551 enter->op_next = (OP*)enter;
6553 CHECKOP(OP_ENTERTRY, enter);
6555 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6556 o->op_type = OP_LEAVETRY;
6557 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6558 enter->op_other = o;
6559 op_getmad(oldo,o,'O');
6573 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6574 op_getmad(oldo,o,'O');
6576 o->op_targ = (PADOFFSET)PL_hints;
6577 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6578 /* Store a copy of %^H that pp_entereval can pick up. */
6579 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6580 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6581 cUNOPo->op_first->op_sibling = hhop;
6582 o->op_private |= OPpEVAL_HAS_HH;
6588 Perl_ck_exit(pTHX_ OP *o)
6590 PERL_ARGS_ASSERT_CK_EXIT;
6593 HV * const table = GvHV(PL_hintgv);
6595 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6596 if (svp && *svp && SvTRUE(*svp))
6597 o->op_private |= OPpEXIT_VMSISH;
6599 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6605 Perl_ck_exec(pTHX_ OP *o)
6607 PERL_ARGS_ASSERT_CK_EXEC;
6609 if (o->op_flags & OPf_STACKED) {
6612 kid = cUNOPo->op_first->op_sibling;
6613 if (kid->op_type == OP_RV2GV)
6622 Perl_ck_exists(pTHX_ OP *o)
6626 PERL_ARGS_ASSERT_CK_EXISTS;
6629 if (o->op_flags & OPf_KIDS) {
6630 OP * const kid = cUNOPo->op_first;
6631 if (kid->op_type == OP_ENTERSUB) {
6632 (void) ref(kid, o->op_type);
6633 if (kid->op_type != OP_RV2CV
6634 && !(PL_parser && PL_parser->error_count))
6635 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6637 o->op_private |= OPpEXISTS_SUB;
6639 else if (kid->op_type == OP_AELEM)
6640 o->op_flags |= OPf_SPECIAL;
6641 else if (kid->op_type != OP_HELEM)
6642 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6650 Perl_ck_rvconst(pTHX_ register OP *o)
6653 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6655 PERL_ARGS_ASSERT_CK_RVCONST;
6657 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6658 if (o->op_type == OP_RV2CV)
6659 o->op_private &= ~1;
6661 if (kid->op_type == OP_CONST) {
6664 SV * const kidsv = kid->op_sv;
6666 /* Is it a constant from cv_const_sv()? */
6667 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6668 SV * const rsv = SvRV(kidsv);
6669 const svtype type = SvTYPE(rsv);
6670 const char *badtype = NULL;
6672 switch (o->op_type) {
6674 if (type > SVt_PVMG)
6675 badtype = "a SCALAR";
6678 if (type != SVt_PVAV)
6679 badtype = "an ARRAY";
6682 if (type != SVt_PVHV)
6686 if (type != SVt_PVCV)
6691 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6694 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6695 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6696 /* If this is an access to a stash, disable "strict refs", because
6697 * stashes aren't auto-vivified at compile-time (unless we store
6698 * symbols in them), and we don't want to produce a run-time
6699 * stricture error when auto-vivifying the stash. */
6700 const char *s = SvPV_nolen(kidsv);
6701 const STRLEN l = SvCUR(kidsv);
6702 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6703 o->op_private &= ~HINT_STRICT_REFS;
6705 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6706 const char *badthing;
6707 switch (o->op_type) {
6709 badthing = "a SCALAR";
6712 badthing = "an ARRAY";
6715 badthing = "a HASH";
6723 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6724 SVfARG(kidsv), badthing);
6727 * This is a little tricky. We only want to add the symbol if we
6728 * didn't add it in the lexer. Otherwise we get duplicate strict
6729 * warnings. But if we didn't add it in the lexer, we must at
6730 * least pretend like we wanted to add it even if it existed before,
6731 * or we get possible typo warnings. OPpCONST_ENTERED says
6732 * whether the lexer already added THIS instance of this symbol.
6734 iscv = (o->op_type == OP_RV2CV) * 2;
6736 gv = gv_fetchsv(kidsv,
6737 iscv | !(kid->op_private & OPpCONST_ENTERED),
6740 : o->op_type == OP_RV2SV
6742 : o->op_type == OP_RV2AV
6744 : o->op_type == OP_RV2HV
6747 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6749 kid->op_type = OP_GV;
6750 SvREFCNT_dec(kid->op_sv);
6752 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6753 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6754 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6756 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6758 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6760 kid->op_private = 0;
6761 kid->op_ppaddr = PL_ppaddr[OP_GV];
6768 Perl_ck_ftst(pTHX_ OP *o)
6771 const I32 type = o->op_type;
6773 PERL_ARGS_ASSERT_CK_FTST;
6775 if (o->op_flags & OPf_REF) {
6778 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6779 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6780 const OPCODE kidtype = kid->op_type;
6782 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6783 OP * const newop = newGVOP(type, OPf_REF,
6784 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6786 op_getmad(o,newop,'O');
6792 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6793 o->op_private |= OPpFT_ACCESS;
6794 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6795 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6796 o->op_private |= OPpFT_STACKED;
6804 if (type == OP_FTTTY)
6805 o = newGVOP(type, OPf_REF, PL_stdingv);
6807 o = newUNOP(type, 0, newDEFSVOP());
6808 op_getmad(oldo,o,'O');
6814 Perl_ck_fun(pTHX_ OP *o)
6817 const int type = o->op_type;
6818 register I32 oa = PL_opargs[type] >> OASHIFT;
6820 PERL_ARGS_ASSERT_CK_FUN;
6822 if (o->op_flags & OPf_STACKED) {
6823 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6826 return no_fh_allowed(o);
6829 if (o->op_flags & OPf_KIDS) {
6830 OP **tokid = &cLISTOPo->op_first;
6831 register OP *kid = cLISTOPo->op_first;
6835 if (kid->op_type == OP_PUSHMARK ||
6836 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6838 tokid = &kid->op_sibling;
6839 kid = kid->op_sibling;
6841 if (!kid && PL_opargs[type] & OA_DEFGV)
6842 *tokid = kid = newDEFSVOP();
6846 sibl = kid->op_sibling;
6848 if (!sibl && kid->op_type == OP_STUB) {
6855 /* list seen where single (scalar) arg expected? */
6856 if (numargs == 1 && !(oa >> 4)
6857 && kid->op_type == OP_LIST && type != OP_SCALAR)
6859 return too_many_arguments(o,PL_op_desc[type]);
6872 if ((type == OP_PUSH || type == OP_UNSHIFT)
6873 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6874 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6875 "Useless use of %s with no values",
6878 if (kid->op_type == OP_CONST &&
6879 (kid->op_private & OPpCONST_BARE))
6881 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6882 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6883 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6884 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6885 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6886 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6888 op_getmad(kid,newop,'K');
6893 kid->op_sibling = sibl;
6896 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6897 bad_type(numargs, "array", PL_op_desc[type], kid);
6901 if (kid->op_type == OP_CONST &&
6902 (kid->op_private & OPpCONST_BARE))
6904 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6905 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6906 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6907 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6908 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6909 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6911 op_getmad(kid,newop,'K');
6916 kid->op_sibling = sibl;
6919 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6920 bad_type(numargs, "hash", PL_op_desc[type], kid);
6925 OP * const newop = newUNOP(OP_NULL, 0, kid);
6926 kid->op_sibling = 0;
6928 newop->op_next = newop;
6930 kid->op_sibling = sibl;
6935 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6936 if (kid->op_type == OP_CONST &&
6937 (kid->op_private & OPpCONST_BARE))
6939 OP * const newop = newGVOP(OP_GV, 0,
6940 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6941 if (!(o->op_private & 1) && /* if not unop */
6942 kid == cLISTOPo->op_last)
6943 cLISTOPo->op_last = newop;
6945 op_getmad(kid,newop,'K');
6951 else if (kid->op_type == OP_READLINE) {
6952 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6953 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6956 I32 flags = OPf_SPECIAL;
6960 /* is this op a FH constructor? */
6961 if (is_handle_constructor(o,numargs)) {
6962 const char *name = NULL;
6966 /* Set a flag to tell rv2gv to vivify
6967 * need to "prove" flag does not mean something
6968 * else already - NI-S 1999/05/07
6971 if (kid->op_type == OP_PADSV) {
6973 = PAD_COMPNAME_SV(kid->op_targ);
6974 name = SvPV_const(namesv, len);
6976 else if (kid->op_type == OP_RV2SV
6977 && kUNOP->op_first->op_type == OP_GV)
6979 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6981 len = GvNAMELEN(gv);
6983 else if (kid->op_type == OP_AELEM
6984 || kid->op_type == OP_HELEM)
6987 OP *op = ((BINOP*)kid)->op_first;
6991 const char * const a =
6992 kid->op_type == OP_AELEM ?
6994 if (((op->op_type == OP_RV2AV) ||
6995 (op->op_type == OP_RV2HV)) &&
6996 (firstop = ((UNOP*)op)->op_first) &&
6997 (firstop->op_type == OP_GV)) {
6998 /* packagevar $a[] or $h{} */
6999 GV * const gv = cGVOPx_gv(firstop);
7007 else if (op->op_type == OP_PADAV
7008 || op->op_type == OP_PADHV) {
7009 /* lexicalvar $a[] or $h{} */
7010 const char * const padname =
7011 PAD_COMPNAME_PV(op->op_targ);
7020 name = SvPV_const(tmpstr, len);
7025 name = "__ANONIO__";
7032 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7033 namesv = PAD_SVl(targ);
7034 SvUPGRADE(namesv, SVt_PV);
7036 sv_setpvs(namesv, "$");
7037 sv_catpvn(namesv, name, len);
7040 kid->op_sibling = 0;
7041 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7042 kid->op_targ = targ;
7043 kid->op_private |= priv;
7045 kid->op_sibling = sibl;
7051 mod(scalar(kid), type);
7055 tokid = &kid->op_sibling;
7056 kid = kid->op_sibling;
7059 if (kid && kid->op_type != OP_STUB)
7060 return too_many_arguments(o,OP_DESC(o));
7061 o->op_private |= numargs;
7063 /* FIXME - should the numargs move as for the PERL_MAD case? */
7064 o->op_private |= numargs;
7066 return too_many_arguments(o,OP_DESC(o));
7070 else if (PL_opargs[type] & OA_DEFGV) {
7072 OP *newop = newUNOP(type, 0, newDEFSVOP());
7073 op_getmad(o,newop,'O');
7076 /* Ordering of these two is important to keep f_map.t passing. */
7078 return newUNOP(type, 0, newDEFSVOP());
7083 while (oa & OA_OPTIONAL)
7085 if (oa && oa != OA_LIST)
7086 return too_few_arguments(o,OP_DESC(o));
7092 Perl_ck_glob(pTHX_ OP *o)
7097 PERL_ARGS_ASSERT_CK_GLOB;
7100 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7101 append_elem(OP_GLOB, o, newDEFSVOP());
7103 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7104 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7106 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7109 #if !defined(PERL_EXTERNAL_GLOB)
7110 /* XXX this can be tightened up and made more failsafe. */
7111 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7114 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7115 newSVpvs("File::Glob"), NULL, NULL, NULL);
7116 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7117 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7118 GvCV(gv) = GvCV(glob_gv);
7119 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7120 GvIMPORTED_CV_on(gv);
7123 #endif /* PERL_EXTERNAL_GLOB */
7125 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7126 append_elem(OP_GLOB, o,
7127 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7128 o->op_type = OP_LIST;
7129 o->op_ppaddr = PL_ppaddr[OP_LIST];
7130 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7131 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7132 cLISTOPo->op_first->op_targ = 0;
7133 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7134 append_elem(OP_LIST, o,
7135 scalar(newUNOP(OP_RV2CV, 0,
7136 newGVOP(OP_GV, 0, gv)))));
7137 o = newUNOP(OP_NULL, 0, ck_subr(o));
7138 o->op_targ = OP_GLOB; /* hint at what it used to be */
7141 gv = newGVgen("main");
7143 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7149 Perl_ck_grep(pTHX_ OP *o)
7154 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7157 PERL_ARGS_ASSERT_CK_GREP;
7159 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7160 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7162 if (o->op_flags & OPf_STACKED) {
7165 kid = cLISTOPo->op_first->op_sibling;
7166 if (!cUNOPx(kid)->op_next)
7167 Perl_croak(aTHX_ "panic: ck_grep");
7168 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7171 NewOp(1101, gwop, 1, LOGOP);
7172 kid->op_next = (OP*)gwop;
7173 o->op_flags &= ~OPf_STACKED;
7175 kid = cLISTOPo->op_first->op_sibling;
7176 if (type == OP_MAPWHILE)
7181 if (PL_parser && PL_parser->error_count)
7183 kid = cLISTOPo->op_first->op_sibling;
7184 if (kid->op_type != OP_NULL)
7185 Perl_croak(aTHX_ "panic: ck_grep");
7186 kid = kUNOP->op_first;
7189 NewOp(1101, gwop, 1, LOGOP);
7190 gwop->op_type = type;
7191 gwop->op_ppaddr = PL_ppaddr[type];
7192 gwop->op_first = listkids(o);
7193 gwop->op_flags |= OPf_KIDS;
7194 gwop->op_other = LINKLIST(kid);
7195 kid->op_next = (OP*)gwop;
7196 offset = pad_findmy("$_");
7197 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7198 o->op_private = gwop->op_private = 0;
7199 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7202 o->op_private = gwop->op_private = OPpGREP_LEX;
7203 gwop->op_targ = o->op_targ = offset;
7206 kid = cLISTOPo->op_first->op_sibling;
7207 if (!kid || !kid->op_sibling)
7208 return too_few_arguments(o,OP_DESC(o));
7209 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7210 mod(kid, OP_GREPSTART);
7216 Perl_ck_index(pTHX_ OP *o)
7218 PERL_ARGS_ASSERT_CK_INDEX;
7220 if (o->op_flags & OPf_KIDS) {
7221 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7223 kid = kid->op_sibling; /* get past "big" */
7224 if (kid && kid->op_type == OP_CONST)
7225 fbm_compile(((SVOP*)kid)->op_sv, 0);
7231 Perl_ck_lfun(pTHX_ OP *o)
7233 const OPCODE type = o->op_type;
7235 PERL_ARGS_ASSERT_CK_LFUN;
7237 return modkids(ck_fun(o), type);
7241 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7243 PERL_ARGS_ASSERT_CK_DEFINED;
7245 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7246 switch (cUNOPo->op_first->op_type) {
7248 /* This is needed for
7249 if (defined %stash::)
7250 to work. Do not break Tk.
7252 break; /* Globals via GV can be undef */
7254 case OP_AASSIGN: /* Is this a good idea? */
7255 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7256 "defined(@array) is deprecated");
7257 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7258 "\t(Maybe you should just omit the defined()?)\n");
7261 /* This is needed for
7262 if (defined %stash::)
7263 to work. Do not break Tk.
7265 break; /* Globals via GV can be undef */
7267 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7268 "defined(%%hash) is deprecated");
7269 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7270 "\t(Maybe you should just omit the defined()?)\n");
7281 Perl_ck_readline(pTHX_ OP *o)
7283 PERL_ARGS_ASSERT_CK_READLINE;
7285 if (!(o->op_flags & OPf_KIDS)) {
7287 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7289 op_getmad(o,newop,'O');
7299 Perl_ck_rfun(pTHX_ OP *o)
7301 const OPCODE type = o->op_type;
7303 PERL_ARGS_ASSERT_CK_RFUN;
7305 return refkids(ck_fun(o), type);
7309 Perl_ck_listiob(pTHX_ OP *o)
7313 PERL_ARGS_ASSERT_CK_LISTIOB;
7315 kid = cLISTOPo->op_first;
7318 kid = cLISTOPo->op_first;
7320 if (kid->op_type == OP_PUSHMARK)
7321 kid = kid->op_sibling;
7322 if (kid && o->op_flags & OPf_STACKED)
7323 kid = kid->op_sibling;
7324 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7325 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7326 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7327 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7328 cLISTOPo->op_first->op_sibling = kid;
7329 cLISTOPo->op_last = kid;
7330 kid = kid->op_sibling;
7335 append_elem(o->op_type, o, newDEFSVOP());
7341 Perl_ck_smartmatch(pTHX_ OP *o)
7344 if (0 == (o->op_flags & OPf_SPECIAL)) {
7345 OP *first = cBINOPo->op_first;
7346 OP *second = first->op_sibling;
7348 /* Implicitly take a reference to an array or hash */
7349 first->op_sibling = NULL;
7350 first = cBINOPo->op_first = ref_array_or_hash(first);
7351 second = first->op_sibling = ref_array_or_hash(second);
7353 /* Implicitly take a reference to a regular expression */
7354 if (first->op_type == OP_MATCH) {
7355 first->op_type = OP_QR;
7356 first->op_ppaddr = PL_ppaddr[OP_QR];
7358 if (second->op_type == OP_MATCH) {
7359 second->op_type = OP_QR;
7360 second->op_ppaddr = PL_ppaddr[OP_QR];
7369 Perl_ck_sassign(pTHX_ OP *o)
7372 OP * const kid = cLISTOPo->op_first;
7374 PERL_ARGS_ASSERT_CK_SASSIGN;
7376 /* has a disposable target? */
7377 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7378 && !(kid->op_flags & OPf_STACKED)
7379 /* Cannot steal the second time! */
7380 && !(kid->op_private & OPpTARGET_MY)
7381 /* Keep the full thing for madskills */
7385 OP * const kkid = kid->op_sibling;
7387 /* Can just relocate the target. */
7388 if (kkid && kkid->op_type == OP_PADSV
7389 && !(kkid->op_private & OPpLVAL_INTRO))
7391 kid->op_targ = kkid->op_targ;
7393 /* Now we do not need PADSV and SASSIGN. */
7394 kid->op_sibling = o->op_sibling; /* NULL */
7395 cLISTOPo->op_first = NULL;
7398 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7402 if (kid->op_sibling) {
7403 OP *kkid = kid->op_sibling;
7404 if (kkid->op_type == OP_PADSV
7405 && (kkid->op_private & OPpLVAL_INTRO)
7406 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7407 const PADOFFSET target = kkid->op_targ;
7408 OP *const other = newOP(OP_PADSV,
7410 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7411 OP *const first = newOP(OP_NULL, 0);
7412 OP *const nullop = newCONDOP(0, first, o, other);
7413 OP *const condop = first->op_next;
7414 /* hijacking PADSTALE for uninitialized state variables */
7415 SvPADSTALE_on(PAD_SVl(target));
7417 condop->op_type = OP_ONCE;
7418 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7419 condop->op_targ = target;
7420 other->op_targ = target;
7422 /* Because we change the type of the op here, we will skip the
7423 assinment binop->op_last = binop->op_first->op_sibling; at the
7424 end of Perl_newBINOP(). So need to do it here. */
7425 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7434 Perl_ck_match(pTHX_ OP *o)
7438 PERL_ARGS_ASSERT_CK_MATCH;
7440 if (o->op_type != OP_QR && PL_compcv) {
7441 const PADOFFSET offset = pad_findmy("$_");
7442 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7443 o->op_targ = offset;
7444 o->op_private |= OPpTARGET_MY;
7447 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7448 o->op_private |= OPpRUNTIME;
7453 Perl_ck_method(pTHX_ OP *o)
7455 OP * const kid = cUNOPo->op_first;
7457 PERL_ARGS_ASSERT_CK_METHOD;
7459 if (kid->op_type == OP_CONST) {
7460 SV* sv = kSVOP->op_sv;
7461 const char * const method = SvPVX_const(sv);
7462 if (!(strchr(method, ':') || strchr(method, '\''))) {
7464 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7465 sv = newSVpvn_share(method, SvCUR(sv), 0);
7468 kSVOP->op_sv = NULL;
7470 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7472 op_getmad(o,cmop,'O');
7483 Perl_ck_null(pTHX_ OP *o)
7485 PERL_ARGS_ASSERT_CK_NULL;
7486 PERL_UNUSED_CONTEXT;
7491 Perl_ck_open(pTHX_ OP *o)
7494 HV * const table = GvHV(PL_hintgv);
7496 PERL_ARGS_ASSERT_CK_OPEN;
7499 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7502 const char *d = SvPV_const(*svp, len);
7503 const I32 mode = mode_from_discipline(d, len);
7504 if (mode & O_BINARY)
7505 o->op_private |= OPpOPEN_IN_RAW;
7506 else if (mode & O_TEXT)
7507 o->op_private |= OPpOPEN_IN_CRLF;
7510 svp = hv_fetchs(table, "open_OUT", FALSE);
7513 const char *d = SvPV_const(*svp, len);
7514 const I32 mode = mode_from_discipline(d, len);
7515 if (mode & O_BINARY)
7516 o->op_private |= OPpOPEN_OUT_RAW;
7517 else if (mode & O_TEXT)
7518 o->op_private |= OPpOPEN_OUT_CRLF;
7521 if (o->op_type == OP_BACKTICK) {
7522 if (!(o->op_flags & OPf_KIDS)) {
7523 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7525 op_getmad(o,newop,'O');
7534 /* In case of three-arg dup open remove strictness
7535 * from the last arg if it is a bareword. */
7536 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7537 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7541 if ((last->op_type == OP_CONST) && /* The bareword. */
7542 (last->op_private & OPpCONST_BARE) &&
7543 (last->op_private & OPpCONST_STRICT) &&
7544 (oa = first->op_sibling) && /* The fh. */
7545 (oa = oa->op_sibling) && /* The mode. */
7546 (oa->op_type == OP_CONST) &&
7547 SvPOK(((SVOP*)oa)->op_sv) &&
7548 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7549 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7550 (last == oa->op_sibling)) /* The bareword. */
7551 last->op_private &= ~OPpCONST_STRICT;
7557 Perl_ck_repeat(pTHX_ OP *o)
7559 PERL_ARGS_ASSERT_CK_REPEAT;
7561 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7562 o->op_private |= OPpREPEAT_DOLIST;
7563 cBINOPo->op_first = force_list(cBINOPo->op_first);
7571 Perl_ck_require(pTHX_ OP *o)
7576 PERL_ARGS_ASSERT_CK_REQUIRE;
7578 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7579 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7581 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7582 SV * const sv = kid->op_sv;
7583 U32 was_readonly = SvREADONLY(sv);
7590 sv_force_normal_flags(sv, 0);
7591 assert(!SvREADONLY(sv));
7601 for (; s < end; s++) {
7602 if (*s == ':' && s[1] == ':') {
7604 Move(s+2, s+1, end - s - 1, char);
7609 sv_catpvs(sv, ".pm");
7610 SvFLAGS(sv) |= was_readonly;
7614 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7615 /* handle override, if any */
7616 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7617 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7618 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7619 gv = gvp ? *gvp : NULL;
7623 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7624 OP * const kid = cUNOPo->op_first;
7627 cUNOPo->op_first = 0;
7631 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7632 append_elem(OP_LIST, kid,
7633 scalar(newUNOP(OP_RV2CV, 0,
7636 op_getmad(o,newop,'O');
7644 Perl_ck_return(pTHX_ OP *o)
7649 PERL_ARGS_ASSERT_CK_RETURN;
7651 kid = cLISTOPo->op_first->op_sibling;
7652 if (CvLVALUE(PL_compcv)) {
7653 for (; kid; kid = kid->op_sibling)
7654 mod(kid, OP_LEAVESUBLV);
7656 for (; kid; kid = kid->op_sibling)
7657 if ((kid->op_type == OP_NULL)
7658 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7659 /* This is a do block */
7660 OP *op = kUNOP->op_first;
7661 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7662 op = cUNOPx(op)->op_first;
7663 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7664 /* Force the use of the caller's context */
7665 op->op_flags |= OPf_SPECIAL;
7674 Perl_ck_select(pTHX_ OP *o)
7679 PERL_ARGS_ASSERT_CK_SELECT;
7681 if (o->op_flags & OPf_KIDS) {
7682 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7683 if (kid && kid->op_sibling) {
7684 o->op_type = OP_SSELECT;
7685 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7687 return fold_constants(o);
7691 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7692 if (kid && kid->op_type == OP_RV2GV)
7693 kid->op_private &= ~HINT_STRICT_REFS;
7698 Perl_ck_shift(pTHX_ OP *o)
7701 const I32 type = o->op_type;
7703 PERL_ARGS_ASSERT_CK_SHIFT;
7705 if (!(o->op_flags & OPf_KIDS)) {
7707 /* FIXME - this can be refactored to reduce code in #ifdefs */
7709 OP * const oldo = o;
7713 argop = newUNOP(OP_RV2AV, 0,
7714 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7716 o = newUNOP(type, 0, scalar(argop));
7717 op_getmad(oldo,o,'O');
7720 return newUNOP(type, 0, scalar(argop));
7723 return scalar(modkids(ck_fun(o), type));
7727 Perl_ck_sort(pTHX_ OP *o)
7732 PERL_ARGS_ASSERT_CK_SORT;
7734 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7735 HV * const hinthv = GvHV(PL_hintgv);
7737 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7739 const I32 sorthints = (I32)SvIV(*svp);
7740 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7741 o->op_private |= OPpSORT_QSORT;
7742 if ((sorthints & HINT_SORT_STABLE) != 0)
7743 o->op_private |= OPpSORT_STABLE;
7748 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7750 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7751 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7753 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7755 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7757 if (kid->op_type == OP_SCOPE) {
7761 else if (kid->op_type == OP_LEAVE) {
7762 if (o->op_type == OP_SORT) {
7763 op_null(kid); /* wipe out leave */
7766 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7767 if (k->op_next == kid)
7769 /* don't descend into loops */
7770 else if (k->op_type == OP_ENTERLOOP
7771 || k->op_type == OP_ENTERITER)
7773 k = cLOOPx(k)->op_lastop;
7778 kid->op_next = 0; /* just disconnect the leave */
7779 k = kLISTOP->op_first;
7784 if (o->op_type == OP_SORT) {
7785 /* provide scalar context for comparison function/block */
7791 o->op_flags |= OPf_SPECIAL;
7793 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7796 firstkid = firstkid->op_sibling;
7799 /* provide list context for arguments */
7800 if (o->op_type == OP_SORT)
7807 S_simplify_sort(pTHX_ OP *o)
7810 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7816 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7818 if (!(o->op_flags & OPf_STACKED))
7820 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7821 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7822 kid = kUNOP->op_first; /* get past null */
7823 if (kid->op_type != OP_SCOPE)
7825 kid = kLISTOP->op_last; /* get past scope */
7826 switch(kid->op_type) {
7834 k = kid; /* remember this node*/
7835 if (kBINOP->op_first->op_type != OP_RV2SV)
7837 kid = kBINOP->op_first; /* get past cmp */
7838 if (kUNOP->op_first->op_type != OP_GV)
7840 kid = kUNOP->op_first; /* get past rv2sv */
7842 if (GvSTASH(gv) != PL_curstash)
7844 gvname = GvNAME(gv);
7845 if (*gvname == 'a' && gvname[1] == '\0')
7847 else if (*gvname == 'b' && gvname[1] == '\0')
7852 kid = k; /* back to cmp */
7853 if (kBINOP->op_last->op_type != OP_RV2SV)
7855 kid = kBINOP->op_last; /* down to 2nd arg */
7856 if (kUNOP->op_first->op_type != OP_GV)
7858 kid = kUNOP->op_first; /* get past rv2sv */
7860 if (GvSTASH(gv) != PL_curstash)
7862 gvname = GvNAME(gv);
7864 ? !(*gvname == 'a' && gvname[1] == '\0')
7865 : !(*gvname == 'b' && gvname[1] == '\0'))
7867 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7869 o->op_private |= OPpSORT_DESCEND;
7870 if (k->op_type == OP_NCMP)
7871 o->op_private |= OPpSORT_NUMERIC;
7872 if (k->op_type == OP_I_NCMP)
7873 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7874 kid = cLISTOPo->op_first->op_sibling;
7875 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7877 op_getmad(kid,o,'S'); /* then delete it */
7879 op_free(kid); /* then delete it */
7884 Perl_ck_split(pTHX_ OP *o)
7889 PERL_ARGS_ASSERT_CK_SPLIT;
7891 if (o->op_flags & OPf_STACKED)
7892 return no_fh_allowed(o);
7894 kid = cLISTOPo->op_first;
7895 if (kid->op_type != OP_NULL)
7896 Perl_croak(aTHX_ "panic: ck_split");
7897 kid = kid->op_sibling;
7898 op_free(cLISTOPo->op_first);
7899 cLISTOPo->op_first = kid;
7901 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7902 cLISTOPo->op_last = kid; /* There was only one element previously */
7905 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7906 OP * const sibl = kid->op_sibling;
7907 kid->op_sibling = 0;
7908 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7909 if (cLISTOPo->op_first == cLISTOPo->op_last)
7910 cLISTOPo->op_last = kid;
7911 cLISTOPo->op_first = kid;
7912 kid->op_sibling = sibl;
7915 kid->op_type = OP_PUSHRE;
7916 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7918 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7919 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7920 "Use of /g modifier is meaningless in split");
7923 if (!kid->op_sibling)
7924 append_elem(OP_SPLIT, o, newDEFSVOP());
7926 kid = kid->op_sibling;
7929 if (!kid->op_sibling)
7930 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7931 assert(kid->op_sibling);
7933 kid = kid->op_sibling;
7936 if (kid->op_sibling)
7937 return too_many_arguments(o,OP_DESC(o));
7943 Perl_ck_join(pTHX_ OP *o)
7945 const OP * const kid = cLISTOPo->op_first->op_sibling;
7947 PERL_ARGS_ASSERT_CK_JOIN;
7949 if (kid && kid->op_type == OP_MATCH) {
7950 if (ckWARN(WARN_SYNTAX)) {
7951 const REGEXP *re = PM_GETRE(kPMOP);
7952 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7953 const STRLEN len = re ? RX_PRELEN(re) : 6;
7954 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7955 "/%.*s/ should probably be written as \"%.*s\"",
7956 (int)len, pmstr, (int)len, pmstr);
7963 Perl_ck_subr(pTHX_ OP *o)
7966 OP *prev = ((cUNOPo->op_first->op_sibling)
7967 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7968 OP *o2 = prev->op_sibling;
7970 const char *proto = NULL;
7971 const char *proto_end = NULL;
7976 I32 contextclass = 0;
7977 const char *e = NULL;
7980 PERL_ARGS_ASSERT_CK_SUBR;
7982 o->op_private |= OPpENTERSUB_HASTARG;
7983 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7984 if (cvop->op_type == OP_RV2CV) {
7986 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7987 op_null(cvop); /* disable rv2cv */
7988 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7989 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7990 GV *gv = cGVOPx_gv(tmpop);
7993 tmpop->op_private |= OPpEARLY_CV;
7997 namegv = CvANON(cv) ? gv : CvGV(cv);
7998 proto = SvPV(MUTABLE_SV(cv), len);
7999 proto_end = proto + len;
8004 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8005 if (o2->op_type == OP_CONST)
8006 o2->op_private &= ~OPpCONST_STRICT;
8007 else if (o2->op_type == OP_LIST) {
8008 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8009 if (sib && sib->op_type == OP_CONST)
8010 sib->op_private &= ~OPpCONST_STRICT;
8013 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8014 if (PERLDB_SUB && PL_curstash != PL_debstash)
8015 o->op_private |= OPpENTERSUB_DB;
8016 while (o2 != cvop) {
8018 if (PL_madskills && o2->op_type == OP_STUB) {
8019 o2 = o2->op_sibling;
8022 if (PL_madskills && o2->op_type == OP_NULL)
8023 o3 = ((UNOP*)o2)->op_first;
8027 if (proto >= proto_end)
8028 return too_many_arguments(o, gv_ename(namegv));
8036 /* _ must be at the end */
8037 if (proto[1] && proto[1] != ';')
8052 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8054 arg == 1 ? "block or sub {}" : "sub {}",
8055 gv_ename(namegv), o3);
8058 /* '*' allows any scalar type, including bareword */
8061 if (o3->op_type == OP_RV2GV)
8062 goto wrapref; /* autoconvert GLOB -> GLOBref */
8063 else if (o3->op_type == OP_CONST)
8064 o3->op_private &= ~OPpCONST_STRICT;
8065 else if (o3->op_type == OP_ENTERSUB) {
8066 /* accidental subroutine, revert to bareword */
8067 OP *gvop = ((UNOP*)o3)->op_first;
8068 if (gvop && gvop->op_type == OP_NULL) {
8069 gvop = ((UNOP*)gvop)->op_first;
8071 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8074 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8075 (gvop = ((UNOP*)gvop)->op_first) &&
8076 gvop->op_type == OP_GV)
8078 GV * const gv = cGVOPx_gv(gvop);
8079 OP * const sibling = o2->op_sibling;
8080 SV * const n = newSVpvs("");
8082 OP * const oldo2 = o2;
8086 gv_fullname4(n, gv, "", FALSE);
8087 o2 = newSVOP(OP_CONST, 0, n);
8088 op_getmad(oldo2,o2,'O');
8089 prev->op_sibling = o2;
8090 o2->op_sibling = sibling;
8106 if (contextclass++ == 0) {
8107 e = strchr(proto, ']');
8108 if (!e || e == proto)
8117 const char *p = proto;
8118 const char *const end = proto;
8120 while (*--p != '[') {}
8121 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8123 gv_ename(namegv), o3);
8128 if (o3->op_type == OP_RV2GV)
8131 bad_type(arg, "symbol", gv_ename(namegv), o3);
8134 if (o3->op_type == OP_ENTERSUB)
8137 bad_type(arg, "subroutine entry", gv_ename(namegv),
8141 if (o3->op_type == OP_RV2SV ||
8142 o3->op_type == OP_PADSV ||
8143 o3->op_type == OP_HELEM ||
8144 o3->op_type == OP_AELEM)
8147 bad_type(arg, "scalar", gv_ename(namegv), o3);
8150 if (o3->op_type == OP_RV2AV ||
8151 o3->op_type == OP_PADAV)
8154 bad_type(arg, "array", gv_ename(namegv), o3);
8157 if (o3->op_type == OP_RV2HV ||
8158 o3->op_type == OP_PADHV)
8161 bad_type(arg, "hash", gv_ename(namegv), o3);
8166 OP* const sib = kid->op_sibling;
8167 kid->op_sibling = 0;
8168 o2 = newUNOP(OP_REFGEN, 0, kid);
8169 o2->op_sibling = sib;
8170 prev->op_sibling = o2;
8172 if (contextclass && e) {
8187 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8188 gv_ename(namegv), SVfARG(cv));
8193 mod(o2, OP_ENTERSUB);
8195 o2 = o2->op_sibling;
8197 if (o2 == cvop && proto && *proto == '_') {
8198 /* generate an access to $_ */
8200 o2->op_sibling = prev->op_sibling;
8201 prev->op_sibling = o2; /* instead of cvop */
8203 if (proto && !optional && proto_end > proto &&
8204 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8205 return too_few_arguments(o, gv_ename(namegv));
8208 OP * const oldo = o;
8212 o=newSVOP(OP_CONST, 0, newSViv(0));
8213 op_getmad(oldo,o,'O');
8219 Perl_ck_svconst(pTHX_ OP *o)
8221 PERL_ARGS_ASSERT_CK_SVCONST;
8222 PERL_UNUSED_CONTEXT;
8223 SvREADONLY_on(cSVOPo->op_sv);
8228 Perl_ck_chdir(pTHX_ OP *o)
8230 if (o->op_flags & OPf_KIDS) {
8231 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8233 if (kid && kid->op_type == OP_CONST &&
8234 (kid->op_private & OPpCONST_BARE))
8236 o->op_flags |= OPf_SPECIAL;
8237 kid->op_private &= ~OPpCONST_STRICT;
8244 Perl_ck_trunc(pTHX_ OP *o)
8246 PERL_ARGS_ASSERT_CK_TRUNC;
8248 if (o->op_flags & OPf_KIDS) {
8249 SVOP *kid = (SVOP*)cUNOPo->op_first;
8251 if (kid->op_type == OP_NULL)
8252 kid = (SVOP*)kid->op_sibling;
8253 if (kid && kid->op_type == OP_CONST &&
8254 (kid->op_private & OPpCONST_BARE))
8256 o->op_flags |= OPf_SPECIAL;
8257 kid->op_private &= ~OPpCONST_STRICT;
8264 Perl_ck_unpack(pTHX_ OP *o)
8266 OP *kid = cLISTOPo->op_first;
8268 PERL_ARGS_ASSERT_CK_UNPACK;
8270 if (kid->op_sibling) {
8271 kid = kid->op_sibling;
8272 if (!kid->op_sibling)
8273 kid->op_sibling = newDEFSVOP();
8279 Perl_ck_substr(pTHX_ OP *o)
8281 PERL_ARGS_ASSERT_CK_SUBSTR;
8284 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8285 OP *kid = cLISTOPo->op_first;
8287 if (kid->op_type == OP_NULL)
8288 kid = kid->op_sibling;
8290 kid->op_flags |= OPf_MOD;
8297 Perl_ck_each(pTHX_ OP *o)
8300 OP *kid = cLISTOPo->op_first;
8302 PERL_ARGS_ASSERT_CK_EACH;
8304 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8305 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8306 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8307 o->op_type = new_type;
8308 o->op_ppaddr = PL_ppaddr[new_type];
8310 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8311 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8313 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8319 /* A peephole optimizer. We visit the ops in the order they're to execute.
8320 * See the comments at the top of this file for more details about when
8321 * peep() is called */
8324 Perl_peep(pTHX_ register OP *o)
8327 register OP* oldop = NULL;
8329 if (!o || o->op_opt)
8333 SAVEVPTR(PL_curcop);
8334 for (; o; o = o->op_next) {
8337 /* By default, this op has now been optimised. A couple of cases below
8338 clear this again. */
8341 switch (o->op_type) {
8344 PL_curcop = ((COP*)o); /* for warnings */
8348 if (cSVOPo->op_private & OPpCONST_STRICT)
8349 no_bareword_allowed(o);
8352 case OP_METHOD_NAMED:
8353 /* Relocate sv to the pad for thread safety.
8354 * Despite being a "constant", the SV is written to,
8355 * for reference counts, sv_upgrade() etc. */
8357 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8358 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8359 /* If op_sv is already a PADTMP then it is being used by
8360 * some pad, so make a copy. */
8361 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8362 SvREADONLY_on(PAD_SVl(ix));
8363 SvREFCNT_dec(cSVOPo->op_sv);
8365 else if (o->op_type != OP_METHOD_NAMED
8366 && cSVOPo->op_sv == &PL_sv_undef) {
8367 /* PL_sv_undef is hack - it's unsafe to store it in the
8368 AV that is the pad, because av_fetch treats values of
8369 PL_sv_undef as a "free" AV entry and will merrily
8370 replace them with a new SV, causing pad_alloc to think
8371 that this pad slot is free. (When, clearly, it is not)
8373 SvOK_off(PAD_SVl(ix));
8374 SvPADTMP_on(PAD_SVl(ix));
8375 SvREADONLY_on(PAD_SVl(ix));
8378 SvREFCNT_dec(PAD_SVl(ix));
8379 SvPADTMP_on(cSVOPo->op_sv);
8380 PAD_SETSV(ix, cSVOPo->op_sv);
8381 /* XXX I don't know how this isn't readonly already. */
8382 SvREADONLY_on(PAD_SVl(ix));
8384 cSVOPo->op_sv = NULL;
8391 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8392 if (o->op_next->op_private & OPpTARGET_MY) {
8393 if (o->op_flags & OPf_STACKED) /* chained concats */
8394 break; /* ignore_optimization */
8396 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8397 o->op_targ = o->op_next->op_targ;
8398 o->op_next->op_targ = 0;
8399 o->op_private |= OPpTARGET_MY;
8402 op_null(o->op_next);
8406 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8407 break; /* Scalar stub must produce undef. List stub is noop */
8411 if (o->op_targ == OP_NEXTSTATE
8412 || o->op_targ == OP_DBSTATE)
8414 PL_curcop = ((COP*)o);
8416 /* XXX: We avoid setting op_seq here to prevent later calls
8417 to peep() from mistakenly concluding that optimisation
8418 has already occurred. This doesn't fix the real problem,
8419 though (See 20010220.007). AMS 20010719 */
8420 /* op_seq functionality is now replaced by op_opt */
8427 if (oldop && o->op_next) {
8428 oldop->op_next = o->op_next;
8436 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8437 OP* const pop = (o->op_type == OP_PADAV) ?
8438 o->op_next : o->op_next->op_next;
8440 if (pop && pop->op_type == OP_CONST &&
8441 ((PL_op = pop->op_next)) &&
8442 pop->op_next->op_type == OP_AELEM &&
8443 !(pop->op_next->op_private &
8444 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8445 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8450 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8451 no_bareword_allowed(pop);
8452 if (o->op_type == OP_GV)
8453 op_null(o->op_next);
8454 op_null(pop->op_next);
8456 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8457 o->op_next = pop->op_next->op_next;
8458 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8459 o->op_private = (U8)i;
8460 if (o->op_type == OP_GV) {
8465 o->op_flags |= OPf_SPECIAL;
8466 o->op_type = OP_AELEMFAST;
8471 if (o->op_next->op_type == OP_RV2SV) {
8472 if (!(o->op_next->op_private & OPpDEREF)) {
8473 op_null(o->op_next);
8474 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8476 o->op_next = o->op_next->op_next;
8477 o->op_type = OP_GVSV;
8478 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8481 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8482 GV * const gv = cGVOPo_gv;
8483 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8484 /* XXX could check prototype here instead of just carping */
8485 SV * const sv = sv_newmortal();
8486 gv_efullname3(sv, gv, NULL);
8487 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8488 "%"SVf"() called too early to check prototype",
8492 else if (o->op_next->op_type == OP_READLINE
8493 && o->op_next->op_next->op_type == OP_CONCAT
8494 && (o->op_next->op_next->op_flags & OPf_STACKED))
8496 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8497 o->op_type = OP_RCATLINE;
8498 o->op_flags |= OPf_STACKED;
8499 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8500 op_null(o->op_next->op_next);
8501 op_null(o->op_next);
8517 while (cLOGOP->op_other->op_type == OP_NULL)
8518 cLOGOP->op_other = cLOGOP->op_other->op_next;
8519 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8524 while (cLOOP->op_redoop->op_type == OP_NULL)
8525 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8526 peep(cLOOP->op_redoop);
8527 while (cLOOP->op_nextop->op_type == OP_NULL)
8528 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8529 peep(cLOOP->op_nextop);
8530 while (cLOOP->op_lastop->op_type == OP_NULL)
8531 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8532 peep(cLOOP->op_lastop);
8536 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8537 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8538 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8539 cPMOP->op_pmstashstartu.op_pmreplstart
8540 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8541 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8545 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8546 && ckWARN(WARN_SYNTAX))
8548 if (o->op_next->op_sibling) {
8549 const OPCODE type = o->op_next->op_sibling->op_type;
8550 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8551 const line_t oldline = CopLINE(PL_curcop);
8552 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8553 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8554 "Statement unlikely to be reached");
8555 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8556 "\t(Maybe you meant system() when you said exec()?)\n");
8557 CopLINE_set(PL_curcop, oldline);
8568 const char *key = NULL;
8571 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8574 /* Make the CONST have a shared SV */
8575 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8576 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8577 key = SvPV_const(sv, keylen);
8578 lexname = newSVpvn_share(key,
8579 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8585 if ((o->op_private & (OPpLVAL_INTRO)))
8588 rop = (UNOP*)((BINOP*)o)->op_first;
8589 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8591 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8592 if (!SvPAD_TYPED(lexname))
8594 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8595 if (!fields || !GvHV(*fields))
8597 key = SvPV_const(*svp, keylen);
8598 if (!hv_fetch(GvHV(*fields), key,
8599 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8601 Perl_croak(aTHX_ "No such class field \"%s\" "
8602 "in variable %s of type %s",
8603 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8616 SVOP *first_key_op, *key_op;
8618 if ((o->op_private & (OPpLVAL_INTRO))
8619 /* I bet there's always a pushmark... */
8620 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8621 /* hmmm, no optimization if list contains only one key. */
8623 rop = (UNOP*)((LISTOP*)o)->op_last;
8624 if (rop->op_type != OP_RV2HV)
8626 if (rop->op_first->op_type == OP_PADSV)
8627 /* @$hash{qw(keys here)} */
8628 rop = (UNOP*)rop->op_first;
8630 /* @{$hash}{qw(keys here)} */
8631 if (rop->op_first->op_type == OP_SCOPE
8632 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8634 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8640 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8641 if (!SvPAD_TYPED(lexname))
8643 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8644 if (!fields || !GvHV(*fields))
8646 /* Again guessing that the pushmark can be jumped over.... */
8647 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8648 ->op_first->op_sibling;
8649 for (key_op = first_key_op; key_op;
8650 key_op = (SVOP*)key_op->op_sibling) {
8651 if (key_op->op_type != OP_CONST)
8653 svp = cSVOPx_svp(key_op);
8654 key = SvPV_const(*svp, keylen);
8655 if (!hv_fetch(GvHV(*fields), key,
8656 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8658 Perl_croak(aTHX_ "No such class field \"%s\" "
8659 "in variable %s of type %s",
8660 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8667 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8671 /* check that RHS of sort is a single plain array */
8672 OP *oright = cUNOPo->op_first;
8673 if (!oright || oright->op_type != OP_PUSHMARK)
8676 /* reverse sort ... can be optimised. */
8677 if (!cUNOPo->op_sibling) {
8678 /* Nothing follows us on the list. */
8679 OP * const reverse = o->op_next;
8681 if (reverse->op_type == OP_REVERSE &&
8682 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8683 OP * const pushmark = cUNOPx(reverse)->op_first;
8684 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8685 && (cUNOPx(pushmark)->op_sibling == o)) {
8686 /* reverse -> pushmark -> sort */
8687 o->op_private |= OPpSORT_REVERSE;
8689 pushmark->op_next = oright->op_next;
8695 /* make @a = sort @a act in-place */
8697 oright = cUNOPx(oright)->op_sibling;
8700 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8701 oright = cUNOPx(oright)->op_sibling;
8705 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8706 || oright->op_next != o
8707 || (oright->op_private & OPpLVAL_INTRO)
8711 /* o2 follows the chain of op_nexts through the LHS of the
8712 * assign (if any) to the aassign op itself */
8714 if (!o2 || o2->op_type != OP_NULL)
8717 if (!o2 || o2->op_type != OP_PUSHMARK)
8720 if (o2 && o2->op_type == OP_GV)
8723 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8724 || (o2->op_private & OPpLVAL_INTRO)
8729 if (!o2 || o2->op_type != OP_NULL)
8732 if (!o2 || o2->op_type != OP_AASSIGN
8733 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8736 /* check that the sort is the first arg on RHS of assign */
8738 o2 = cUNOPx(o2)->op_first;
8739 if (!o2 || o2->op_type != OP_NULL)
8741 o2 = cUNOPx(o2)->op_first;
8742 if (!o2 || o2->op_type != OP_PUSHMARK)
8744 if (o2->op_sibling != o)
8747 /* check the array is the same on both sides */
8748 if (oleft->op_type == OP_RV2AV) {
8749 if (oright->op_type != OP_RV2AV
8750 || !cUNOPx(oright)->op_first
8751 || cUNOPx(oright)->op_first->op_type != OP_GV
8752 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8753 cGVOPx_gv(cUNOPx(oright)->op_first)
8757 else if (oright->op_type != OP_PADAV
8758 || oright->op_targ != oleft->op_targ
8762 /* transfer MODishness etc from LHS arg to RHS arg */
8763 oright->op_flags = oleft->op_flags;
8764 o->op_private |= OPpSORT_INPLACE;
8766 /* excise push->gv->rv2av->null->aassign */
8767 o2 = o->op_next->op_next;
8768 op_null(o2); /* PUSHMARK */
8770 if (o2->op_type == OP_GV) {
8771 op_null(o2); /* GV */
8774 op_null(o2); /* RV2AV or PADAV */
8775 o2 = o2->op_next->op_next;
8776 op_null(o2); /* AASSIGN */
8778 o->op_next = o2->op_next;
8784 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8786 LISTOP *enter, *exlist;
8788 enter = (LISTOP *) o->op_next;
8791 if (enter->op_type == OP_NULL) {
8792 enter = (LISTOP *) enter->op_next;
8796 /* for $a (...) will have OP_GV then OP_RV2GV here.
8797 for (...) just has an OP_GV. */
8798 if (enter->op_type == OP_GV) {
8799 gvop = (OP *) enter;
8800 enter = (LISTOP *) enter->op_next;
8803 if (enter->op_type == OP_RV2GV) {
8804 enter = (LISTOP *) enter->op_next;
8810 if (enter->op_type != OP_ENTERITER)
8813 iter = enter->op_next;
8814 if (!iter || iter->op_type != OP_ITER)
8817 expushmark = enter->op_first;
8818 if (!expushmark || expushmark->op_type != OP_NULL
8819 || expushmark->op_targ != OP_PUSHMARK)
8822 exlist = (LISTOP *) expushmark->op_sibling;
8823 if (!exlist || exlist->op_type != OP_NULL
8824 || exlist->op_targ != OP_LIST)
8827 if (exlist->op_last != o) {
8828 /* Mmm. Was expecting to point back to this op. */
8831 theirmark = exlist->op_first;
8832 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8835 if (theirmark->op_sibling != o) {
8836 /* There's something between the mark and the reverse, eg
8837 for (1, reverse (...))
8842 ourmark = ((LISTOP *)o)->op_first;
8843 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8846 ourlast = ((LISTOP *)o)->op_last;
8847 if (!ourlast || ourlast->op_next != o)
8850 rv2av = ourmark->op_sibling;
8851 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8852 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8853 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8854 /* We're just reversing a single array. */
8855 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8856 enter->op_flags |= OPf_STACKED;
8859 /* We don't have control over who points to theirmark, so sacrifice
8861 theirmark->op_next = ourmark->op_next;
8862 theirmark->op_flags = ourmark->op_flags;
8863 ourlast->op_next = gvop ? gvop : (OP *) enter;
8866 enter->op_private |= OPpITER_REVERSED;
8867 iter->op_private |= OPpITER_REVERSED;
8874 UNOP *refgen, *rv2cv;
8877 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8880 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8883 rv2gv = ((BINOP *)o)->op_last;
8884 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8887 refgen = (UNOP *)((BINOP *)o)->op_first;
8889 if (!refgen || refgen->op_type != OP_REFGEN)
8892 exlist = (LISTOP *)refgen->op_first;
8893 if (!exlist || exlist->op_type != OP_NULL
8894 || exlist->op_targ != OP_LIST)
8897 if (exlist->op_first->op_type != OP_PUSHMARK)
8900 rv2cv = (UNOP*)exlist->op_last;
8902 if (rv2cv->op_type != OP_RV2CV)
8905 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8906 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8907 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8909 o->op_private |= OPpASSIGN_CV_TO_GV;
8910 rv2gv->op_private |= OPpDONT_INIT_GV;
8911 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8919 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8920 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8930 Perl_custom_op_name(pTHX_ const OP* o)
8933 const IV index = PTR2IV(o->op_ppaddr);
8937 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8939 if (!PL_custom_op_names) /* This probably shouldn't happen */
8940 return (char *)PL_op_name[OP_CUSTOM];
8942 keysv = sv_2mortal(newSViv(index));
8944 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8946 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8948 return SvPV_nolen(HeVAL(he));
8952 Perl_custom_op_desc(pTHX_ const OP* o)
8955 const IV index = PTR2IV(o->op_ppaddr);
8959 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8961 if (!PL_custom_op_descs)
8962 return (char *)PL_op_desc[OP_CUSTOM];
8964 keysv = sv_2mortal(newSViv(index));
8966 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8968 return (char *)PL_op_desc[OP_CUSTOM];
8970 return SvPV_nolen(HeVAL(he));
8975 /* Efficient sub that returns a constant scalar value. */
8977 const_sv_xsub(pTHX_ CV* cv)
8981 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
8985 Perl_croak(aTHX_ "usage: %s::%s()",
8986 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8999 * c-indentation-style: bsd
9001 * indent-tabs-mode: t
9004 * ex: set ts=8 sts=4 sw=4 noet: