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 */
2342 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2346 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2348 call_sv(MUTABLE_SV(cv), G_DISCARD);
2355 Perl_localize(pTHX_ OP *o, I32 lex)
2359 PERL_ARGS_ASSERT_LOCALIZE;
2361 if (o->op_flags & OPf_PARENS)
2362 /* [perl #17376]: this appears to be premature, and results in code such as
2363 C< our(%x); > executing in list mode rather than void mode */
2370 if ( PL_parser->bufptr > PL_parser->oldbufptr
2371 && PL_parser->bufptr[-1] == ','
2372 && ckWARN(WARN_PARENTHESIS))
2374 char *s = PL_parser->bufptr;
2377 /* some heuristics to detect a potential error */
2378 while (*s && (strchr(", \t\n", *s)))
2382 if (*s && strchr("@$%*", *s) && *++s
2383 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2386 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2388 while (*s && (strchr(", \t\n", *s)))
2394 if (sigil && (*s == ';' || *s == '=')) {
2395 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2396 "Parentheses missing around \"%s\" list",
2398 ? (PL_parser->in_my == KEY_our
2400 : PL_parser->in_my == KEY_state
2410 o = mod(o, OP_NULL); /* a bit kludgey */
2411 PL_parser->in_my = FALSE;
2412 PL_parser->in_my_stash = NULL;
2417 Perl_jmaybe(pTHX_ OP *o)
2419 PERL_ARGS_ASSERT_JMAYBE;
2421 if (o->op_type == OP_LIST) {
2423 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2424 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2430 S_fold_constants(pTHX_ register OP *o)
2433 register OP * VOL curop;
2435 VOL I32 type = o->op_type;
2440 SV * const oldwarnhook = PL_warnhook;
2441 SV * const olddiehook = PL_diehook;
2445 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2447 if (PL_opargs[type] & OA_RETSCALAR)
2449 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2450 o->op_targ = pad_alloc(type, SVs_PADTMP);
2452 /* integerize op, unless it happens to be C<-foo>.
2453 * XXX should pp_i_negate() do magic string negation instead? */
2454 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2455 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2456 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2458 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2461 if (!(PL_opargs[type] & OA_FOLDCONST))
2466 /* XXX might want a ck_negate() for this */
2467 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2478 /* XXX what about the numeric ops? */
2479 if (PL_hints & HINT_LOCALE)
2484 if (PL_parser && PL_parser->error_count)
2485 goto nope; /* Don't try to run w/ errors */
2487 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2488 const OPCODE type = curop->op_type;
2489 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2491 type != OP_SCALAR &&
2493 type != OP_PUSHMARK)
2499 curop = LINKLIST(o);
2500 old_next = o->op_next;
2504 oldscope = PL_scopestack_ix;
2505 create_eval_scope(G_FAKINGEVAL);
2507 /* Verify that we don't need to save it: */
2508 assert(PL_curcop == &PL_compiling);
2509 StructCopy(&PL_compiling, ¬_compiling, COP);
2510 PL_curcop = ¬_compiling;
2511 /* The above ensures that we run with all the correct hints of the
2512 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2513 assert(IN_PERL_RUNTIME);
2514 PL_warnhook = PERL_WARNHOOK_FATAL;
2521 sv = *(PL_stack_sp--);
2522 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2523 pad_swipe(o->op_targ, FALSE);
2524 else if (SvTEMP(sv)) { /* grab mortal temp? */
2525 SvREFCNT_inc_simple_void(sv);
2530 /* Something tried to die. Abandon constant folding. */
2531 /* Pretend the error never happened. */
2533 o->op_next = old_next;
2537 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2538 PL_warnhook = oldwarnhook;
2539 PL_diehook = olddiehook;
2540 /* XXX note that this croak may fail as we've already blown away
2541 * the stack - eg any nested evals */
2542 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2545 PL_warnhook = oldwarnhook;
2546 PL_diehook = olddiehook;
2547 PL_curcop = &PL_compiling;
2549 if (PL_scopestack_ix > oldscope)
2550 delete_eval_scope();
2559 if (type == OP_RV2GV)
2560 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2562 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2563 op_getmad(o,newop,'f');
2571 S_gen_constant_list(pTHX_ register OP *o)
2575 const I32 oldtmps_floor = PL_tmps_floor;
2578 if (PL_parser && PL_parser->error_count)
2579 return o; /* Don't attempt to run with errors */
2581 PL_op = curop = LINKLIST(o);
2587 assert (!(curop->op_flags & OPf_SPECIAL));
2588 assert(curop->op_type == OP_RANGE);
2590 PL_tmps_floor = oldtmps_floor;
2592 o->op_type = OP_RV2AV;
2593 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2594 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2595 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2596 o->op_opt = 0; /* needs to be revisited in peep() */
2597 curop = ((UNOP*)o)->op_first;
2598 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2600 op_getmad(curop,o,'O');
2609 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2612 if (!o || o->op_type != OP_LIST)
2613 o = newLISTOP(OP_LIST, 0, o, NULL);
2615 o->op_flags &= ~OPf_WANT;
2617 if (!(PL_opargs[type] & OA_MARK))
2618 op_null(cLISTOPo->op_first);
2620 o->op_type = (OPCODE)type;
2621 o->op_ppaddr = PL_ppaddr[type];
2622 o->op_flags |= flags;
2624 o = CHECKOP(type, o);
2625 if (o->op_type != (unsigned)type)
2628 return fold_constants(o);
2631 /* List constructors */
2634 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2642 if (first->op_type != (unsigned)type
2643 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2645 return newLISTOP(type, 0, first, last);
2648 if (first->op_flags & OPf_KIDS)
2649 ((LISTOP*)first)->op_last->op_sibling = last;
2651 first->op_flags |= OPf_KIDS;
2652 ((LISTOP*)first)->op_first = last;
2654 ((LISTOP*)first)->op_last = last;
2659 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2667 if (first->op_type != (unsigned)type)
2668 return prepend_elem(type, (OP*)first, (OP*)last);
2670 if (last->op_type != (unsigned)type)
2671 return append_elem(type, (OP*)first, (OP*)last);
2673 first->op_last->op_sibling = last->op_first;
2674 first->op_last = last->op_last;
2675 first->op_flags |= (last->op_flags & OPf_KIDS);
2678 if (last->op_first && first->op_madprop) {
2679 MADPROP *mp = last->op_first->op_madprop;
2681 while (mp->mad_next)
2683 mp->mad_next = first->op_madprop;
2686 last->op_first->op_madprop = first->op_madprop;
2689 first->op_madprop = last->op_madprop;
2690 last->op_madprop = 0;
2693 S_op_destroy(aTHX_ (OP*)last);
2699 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2707 if (last->op_type == (unsigned)type) {
2708 if (type == OP_LIST) { /* already a PUSHMARK there */
2709 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2710 ((LISTOP*)last)->op_first->op_sibling = first;
2711 if (!(first->op_flags & OPf_PARENS))
2712 last->op_flags &= ~OPf_PARENS;
2715 if (!(last->op_flags & OPf_KIDS)) {
2716 ((LISTOP*)last)->op_last = first;
2717 last->op_flags |= OPf_KIDS;
2719 first->op_sibling = ((LISTOP*)last)->op_first;
2720 ((LISTOP*)last)->op_first = first;
2722 last->op_flags |= OPf_KIDS;
2726 return newLISTOP(type, 0, first, last);
2734 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2737 Newxz(tk, 1, TOKEN);
2738 tk->tk_type = (OPCODE)optype;
2739 tk->tk_type = 12345;
2741 tk->tk_mad = madprop;
2746 Perl_token_free(pTHX_ TOKEN* tk)
2748 PERL_ARGS_ASSERT_TOKEN_FREE;
2750 if (tk->tk_type != 12345)
2752 mad_free(tk->tk_mad);
2757 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2762 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2764 if (tk->tk_type != 12345) {
2765 Perl_warner(aTHX_ packWARN(WARN_MISC),
2766 "Invalid TOKEN object ignored");
2773 /* faked up qw list? */
2775 tm->mad_type == MAD_SV &&
2776 SvPVX((const SV *)tm->mad_val)[0] == 'q')
2783 /* pretend constant fold didn't happen? */
2784 if (mp->mad_key == 'f' &&
2785 (o->op_type == OP_CONST ||
2786 o->op_type == OP_GV) )
2788 token_getmad(tk,(OP*)mp->mad_val,slot);
2802 if (mp->mad_key == 'X')
2803 mp->mad_key = slot; /* just change the first one */
2813 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2822 /* pretend constant fold didn't happen? */
2823 if (mp->mad_key == 'f' &&
2824 (o->op_type == OP_CONST ||
2825 o->op_type == OP_GV) )
2827 op_getmad(from,(OP*)mp->mad_val,slot);
2834 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2837 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2843 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2852 /* pretend constant fold didn't happen? */
2853 if (mp->mad_key == 'f' &&
2854 (o->op_type == OP_CONST ||
2855 o->op_type == OP_GV) )
2857 op_getmad(from,(OP*)mp->mad_val,slot);
2864 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2867 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2871 PerlIO_printf(PerlIO_stderr(),
2872 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2878 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2896 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2900 addmad(tm, &(o->op_madprop), slot);
2904 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2925 Perl_newMADsv(pTHX_ char key, SV* sv)
2927 PERL_ARGS_ASSERT_NEWMADSV;
2929 return newMADPROP(key, MAD_SV, sv, 0);
2933 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2936 Newxz(mp, 1, MADPROP);
2939 mp->mad_vlen = vlen;
2940 mp->mad_type = type;
2942 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2947 Perl_mad_free(pTHX_ MADPROP* mp)
2949 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2953 mad_free(mp->mad_next);
2954 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2955 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2956 switch (mp->mad_type) {
2960 Safefree((char*)mp->mad_val);
2963 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2964 op_free((OP*)mp->mad_val);
2967 sv_free(MUTABLE_SV(mp->mad_val));
2970 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2979 Perl_newNULLLIST(pTHX)
2981 return newOP(OP_STUB, 0);
2985 S_force_list(pTHX_ OP *o)
2987 if (!o || o->op_type != OP_LIST)
2988 o = newLISTOP(OP_LIST, 0, o, NULL);
2994 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2999 NewOp(1101, listop, 1, LISTOP);
3001 listop->op_type = (OPCODE)type;
3002 listop->op_ppaddr = PL_ppaddr[type];
3005 listop->op_flags = (U8)flags;
3009 else if (!first && last)
3012 first->op_sibling = last;
3013 listop->op_first = first;
3014 listop->op_last = last;
3015 if (type == OP_LIST) {
3016 OP* const pushop = newOP(OP_PUSHMARK, 0);
3017 pushop->op_sibling = first;
3018 listop->op_first = pushop;
3019 listop->op_flags |= OPf_KIDS;
3021 listop->op_last = pushop;
3024 return CHECKOP(type, listop);
3028 Perl_newOP(pTHX_ I32 type, I32 flags)
3032 NewOp(1101, o, 1, OP);
3033 o->op_type = (OPCODE)type;
3034 o->op_ppaddr = PL_ppaddr[type];
3035 o->op_flags = (U8)flags;
3037 o->op_latefreed = 0;
3041 o->op_private = (U8)(0 | (flags >> 8));
3042 if (PL_opargs[type] & OA_RETSCALAR)
3044 if (PL_opargs[type] & OA_TARGET)
3045 o->op_targ = pad_alloc(type, SVs_PADTMP);
3046 return CHECKOP(type, o);
3050 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3056 first = newOP(OP_STUB, 0);
3057 if (PL_opargs[type] & OA_MARK)
3058 first = force_list(first);
3060 NewOp(1101, unop, 1, UNOP);
3061 unop->op_type = (OPCODE)type;
3062 unop->op_ppaddr = PL_ppaddr[type];
3063 unop->op_first = first;
3064 unop->op_flags = (U8)(flags | OPf_KIDS);
3065 unop->op_private = (U8)(1 | (flags >> 8));
3066 unop = (UNOP*) CHECKOP(type, unop);
3070 return fold_constants((OP *) unop);
3074 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3078 NewOp(1101, binop, 1, BINOP);
3081 first = newOP(OP_NULL, 0);
3083 binop->op_type = (OPCODE)type;
3084 binop->op_ppaddr = PL_ppaddr[type];
3085 binop->op_first = first;
3086 binop->op_flags = (U8)(flags | OPf_KIDS);
3089 binop->op_private = (U8)(1 | (flags >> 8));
3092 binop->op_private = (U8)(2 | (flags >> 8));
3093 first->op_sibling = last;
3096 binop = (BINOP*)CHECKOP(type, binop);
3097 if (binop->op_next || binop->op_type != (OPCODE)type)
3100 binop->op_last = binop->op_first->op_sibling;
3102 return fold_constants((OP *)binop);
3105 static int uvcompare(const void *a, const void *b)
3106 __attribute__nonnull__(1)
3107 __attribute__nonnull__(2)
3108 __attribute__pure__;
3109 static int uvcompare(const void *a, const void *b)
3111 if (*((const UV *)a) < (*(const UV *)b))
3113 if (*((const UV *)a) > (*(const UV *)b))
3115 if (*((const UV *)a+1) < (*(const UV *)b+1))
3117 if (*((const UV *)a+1) > (*(const UV *)b+1))
3123 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3126 SV * const tstr = ((SVOP*)expr)->op_sv;
3129 (repl->op_type == OP_NULL)
3130 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3132 ((SVOP*)repl)->op_sv;
3135 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3136 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3140 register short *tbl;
3142 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3143 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3144 I32 del = o->op_private & OPpTRANS_DELETE;
3147 PERL_ARGS_ASSERT_PMTRANS;
3149 PL_hints |= HINT_BLOCK_SCOPE;
3152 o->op_private |= OPpTRANS_FROM_UTF;
3155 o->op_private |= OPpTRANS_TO_UTF;
3157 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3158 SV* const listsv = newSVpvs("# comment\n");
3160 const U8* tend = t + tlen;
3161 const U8* rend = r + rlen;
3175 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3176 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3179 const U32 flags = UTF8_ALLOW_DEFAULT;
3183 t = tsave = bytes_to_utf8(t, &len);
3186 if (!to_utf && rlen) {
3188 r = rsave = bytes_to_utf8(r, &len);
3192 /* There are several snags with this code on EBCDIC:
3193 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3194 2. scan_const() in toke.c has encoded chars in native encoding which makes
3195 ranges at least in EBCDIC 0..255 range the bottom odd.
3199 U8 tmpbuf[UTF8_MAXBYTES+1];
3202 Newx(cp, 2*tlen, UV);
3204 transv = newSVpvs("");
3206 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3208 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3210 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3214 cp[2*i+1] = cp[2*i];
3218 qsort(cp, i, 2*sizeof(UV), uvcompare);
3219 for (j = 0; j < i; j++) {
3221 diff = val - nextmin;
3223 t = uvuni_to_utf8(tmpbuf,nextmin);
3224 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3226 U8 range_mark = UTF_TO_NATIVE(0xff);
3227 t = uvuni_to_utf8(tmpbuf, val - 1);
3228 sv_catpvn(transv, (char *)&range_mark, 1);
3229 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3236 t = uvuni_to_utf8(tmpbuf,nextmin);
3237 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3239 U8 range_mark = UTF_TO_NATIVE(0xff);
3240 sv_catpvn(transv, (char *)&range_mark, 1);
3242 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3243 UNICODE_ALLOW_SUPER);
3244 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3245 t = (const U8*)SvPVX_const(transv);
3246 tlen = SvCUR(transv);
3250 else if (!rlen && !del) {
3251 r = t; rlen = tlen; rend = tend;
3254 if ((!rlen && !del) || t == r ||
3255 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3257 o->op_private |= OPpTRANS_IDENTICAL;
3261 while (t < tend || tfirst <= tlast) {
3262 /* see if we need more "t" chars */
3263 if (tfirst > tlast) {
3264 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3266 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3268 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3275 /* now see if we need more "r" chars */
3276 if (rfirst > rlast) {
3278 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3280 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3282 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3291 rfirst = rlast = 0xffffffff;
3295 /* now see which range will peter our first, if either. */
3296 tdiff = tlast - tfirst;
3297 rdiff = rlast - rfirst;
3304 if (rfirst == 0xffffffff) {
3305 diff = tdiff; /* oops, pretend rdiff is infinite */
3307 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3308 (long)tfirst, (long)tlast);
3310 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3314 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3315 (long)tfirst, (long)(tfirst + diff),
3318 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3319 (long)tfirst, (long)rfirst);
3321 if (rfirst + diff > max)
3322 max = rfirst + diff;
3324 grows = (tfirst < rfirst &&
3325 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3337 else if (max > 0xff)
3342 PerlMemShared_free(cPVOPo->op_pv);
3343 cPVOPo->op_pv = NULL;
3345 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3347 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3348 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3349 PAD_SETSV(cPADOPo->op_padix, swash);
3352 cSVOPo->op_sv = swash;
3354 SvREFCNT_dec(listsv);
3355 SvREFCNT_dec(transv);
3357 if (!del && havefinal && rlen)
3358 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3359 newSVuv((UV)final), 0);
3362 o->op_private |= OPpTRANS_GROWS;
3368 op_getmad(expr,o,'e');
3369 op_getmad(repl,o,'r');
3377 tbl = (short*)cPVOPo->op_pv;
3379 Zero(tbl, 256, short);
3380 for (i = 0; i < (I32)tlen; i++)
3382 for (i = 0, j = 0; i < 256; i++) {
3384 if (j >= (I32)rlen) {
3393 if (i < 128 && r[j] >= 128)
3403 o->op_private |= OPpTRANS_IDENTICAL;
3405 else if (j >= (I32)rlen)
3410 PerlMemShared_realloc(tbl,
3411 (0x101+rlen-j) * sizeof(short));
3412 cPVOPo->op_pv = (char*)tbl;
3414 tbl[0x100] = (short)(rlen - j);
3415 for (i=0; i < (I32)rlen - j; i++)
3416 tbl[0x101+i] = r[j+i];
3420 if (!rlen && !del) {
3423 o->op_private |= OPpTRANS_IDENTICAL;
3425 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3426 o->op_private |= OPpTRANS_IDENTICAL;
3428 for (i = 0; i < 256; i++)
3430 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3431 if (j >= (I32)rlen) {
3433 if (tbl[t[i]] == -1)
3439 if (tbl[t[i]] == -1) {
3440 if (t[i] < 128 && r[j] >= 128)
3447 if(ckWARN(WARN_MISC)) {
3448 if(del && rlen == tlen) {
3449 Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3450 } else if(rlen > tlen) {
3451 Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3456 o->op_private |= OPpTRANS_GROWS;
3458 op_getmad(expr,o,'e');
3459 op_getmad(repl,o,'r');
3469 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3474 NewOp(1101, pmop, 1, PMOP);
3475 pmop->op_type = (OPCODE)type;
3476 pmop->op_ppaddr = PL_ppaddr[type];
3477 pmop->op_flags = (U8)flags;
3478 pmop->op_private = (U8)(0 | (flags >> 8));
3480 if (PL_hints & HINT_RE_TAINT)
3481 pmop->op_pmflags |= PMf_RETAINT;
3482 if (PL_hints & HINT_LOCALE)
3483 pmop->op_pmflags |= PMf_LOCALE;
3487 assert(SvPOK(PL_regex_pad[0]));
3488 if (SvCUR(PL_regex_pad[0])) {
3489 /* Pop off the "packed" IV from the end. */
3490 SV *const repointer_list = PL_regex_pad[0];
3491 const char *p = SvEND(repointer_list) - sizeof(IV);
3492 const IV offset = *((IV*)p);
3494 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3496 SvEND_set(repointer_list, p);
3498 pmop->op_pmoffset = offset;
3499 /* This slot should be free, so assert this: */
3500 assert(PL_regex_pad[offset] == &PL_sv_undef);
3502 SV * const repointer = &PL_sv_undef;
3503 av_push(PL_regex_padav, repointer);
3504 pmop->op_pmoffset = av_len(PL_regex_padav);
3505 PL_regex_pad = AvARRAY(PL_regex_padav);
3509 return CHECKOP(type, pmop);
3512 /* Given some sort of match op o, and an expression expr containing a
3513 * pattern, either compile expr into a regex and attach it to o (if it's
3514 * constant), or convert expr into a runtime regcomp op sequence (if it's
3517 * isreg indicates that the pattern is part of a regex construct, eg
3518 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3519 * split "pattern", which aren't. In the former case, expr will be a list
3520 * if the pattern contains more than one term (eg /a$b/) or if it contains
3521 * a replacement, ie s/// or tr///.
3525 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3530 I32 repl_has_vars = 0;
3534 PERL_ARGS_ASSERT_PMRUNTIME;
3536 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3537 /* last element in list is the replacement; pop it */
3539 repl = cLISTOPx(expr)->op_last;
3540 kid = cLISTOPx(expr)->op_first;
3541 while (kid->op_sibling != repl)
3542 kid = kid->op_sibling;
3543 kid->op_sibling = NULL;
3544 cLISTOPx(expr)->op_last = kid;
3547 if (isreg && expr->op_type == OP_LIST &&
3548 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3550 /* convert single element list to element */
3551 OP* const oe = expr;
3552 expr = cLISTOPx(oe)->op_first->op_sibling;
3553 cLISTOPx(oe)->op_first->op_sibling = NULL;
3554 cLISTOPx(oe)->op_last = NULL;
3558 if (o->op_type == OP_TRANS) {
3559 return pmtrans(o, expr, repl);
3562 reglist = isreg && expr->op_type == OP_LIST;
3566 PL_hints |= HINT_BLOCK_SCOPE;
3569 if (expr->op_type == OP_CONST) {
3570 SV *pat = ((SVOP*)expr)->op_sv;
3571 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3573 if (o->op_flags & OPf_SPECIAL)
3574 pm_flags |= RXf_SPLIT;
3577 assert (SvUTF8(pat));
3578 } else if (SvUTF8(pat)) {
3579 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3580 trapped in use 'bytes'? */
3581 /* Make a copy of the octet sequence, but without the flag on, as
3582 the compiler now honours the SvUTF8 flag on pat. */
3584 const char *const p = SvPV(pat, len);
3585 pat = newSVpvn_flags(p, len, SVs_TEMP);
3588 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3591 op_getmad(expr,(OP*)pm,'e');
3597 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3598 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3600 : OP_REGCMAYBE),0,expr);
3602 NewOp(1101, rcop, 1, LOGOP);
3603 rcop->op_type = OP_REGCOMP;
3604 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3605 rcop->op_first = scalar(expr);
3606 rcop->op_flags |= OPf_KIDS
3607 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3608 | (reglist ? OPf_STACKED : 0);
3609 rcop->op_private = 1;
3612 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3614 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3617 /* establish postfix order */
3618 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3620 rcop->op_next = expr;
3621 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3624 rcop->op_next = LINKLIST(expr);
3625 expr->op_next = (OP*)rcop;
3628 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3633 if (pm->op_pmflags & PMf_EVAL) {
3635 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3636 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3638 else if (repl->op_type == OP_CONST)
3642 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3643 if (curop->op_type == OP_SCOPE
3644 || curop->op_type == OP_LEAVE
3645 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3646 if (curop->op_type == OP_GV) {
3647 GV * const gv = cGVOPx_gv(curop);
3649 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3652 else if (curop->op_type == OP_RV2CV)
3654 else if (curop->op_type == OP_RV2SV ||
3655 curop->op_type == OP_RV2AV ||
3656 curop->op_type == OP_RV2HV ||
3657 curop->op_type == OP_RV2GV) {
3658 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3661 else if (curop->op_type == OP_PADSV ||
3662 curop->op_type == OP_PADAV ||
3663 curop->op_type == OP_PADHV ||
3664 curop->op_type == OP_PADANY)
3668 else if (curop->op_type == OP_PUSHRE)
3669 NOOP; /* Okay here, dangerous in newASSIGNOP */
3679 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3681 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3682 prepend_elem(o->op_type, scalar(repl), o);
3685 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3686 pm->op_pmflags |= PMf_MAYBE_CONST;
3688 NewOp(1101, rcop, 1, LOGOP);
3689 rcop->op_type = OP_SUBSTCONT;
3690 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3691 rcop->op_first = scalar(repl);
3692 rcop->op_flags |= OPf_KIDS;
3693 rcop->op_private = 1;
3696 /* establish postfix order */
3697 rcop->op_next = LINKLIST(repl);
3698 repl->op_next = (OP*)rcop;
3700 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3701 assert(!(pm->op_pmflags & PMf_ONCE));
3702 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3711 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3716 PERL_ARGS_ASSERT_NEWSVOP;
3718 NewOp(1101, svop, 1, SVOP);
3719 svop->op_type = (OPCODE)type;
3720 svop->op_ppaddr = PL_ppaddr[type];
3722 svop->op_next = (OP*)svop;
3723 svop->op_flags = (U8)flags;
3724 if (PL_opargs[type] & OA_RETSCALAR)
3726 if (PL_opargs[type] & OA_TARGET)
3727 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3728 return CHECKOP(type, svop);
3733 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3738 PERL_ARGS_ASSERT_NEWPADOP;
3740 NewOp(1101, padop, 1, PADOP);
3741 padop->op_type = (OPCODE)type;
3742 padop->op_ppaddr = PL_ppaddr[type];
3743 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3744 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3745 PAD_SETSV(padop->op_padix, sv);
3748 padop->op_next = (OP*)padop;
3749 padop->op_flags = (U8)flags;
3750 if (PL_opargs[type] & OA_RETSCALAR)
3752 if (PL_opargs[type] & OA_TARGET)
3753 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3754 return CHECKOP(type, padop);
3759 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3763 PERL_ARGS_ASSERT_NEWGVOP;
3767 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3769 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3774 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3778 NewOp(1101, pvop, 1, PVOP);
3779 pvop->op_type = (OPCODE)type;
3780 pvop->op_ppaddr = PL_ppaddr[type];
3782 pvop->op_next = (OP*)pvop;
3783 pvop->op_flags = (U8)flags;
3784 if (PL_opargs[type] & OA_RETSCALAR)
3786 if (PL_opargs[type] & OA_TARGET)
3787 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3788 return CHECKOP(type, pvop);
3796 Perl_package(pTHX_ OP *o)
3799 SV *const sv = cSVOPo->op_sv;
3804 PERL_ARGS_ASSERT_PACKAGE;
3806 save_hptr(&PL_curstash);
3807 save_item(PL_curstname);
3809 PL_curstash = gv_stashsv(sv, GV_ADD);
3811 sv_setsv(PL_curstname, sv);
3813 PL_hints |= HINT_BLOCK_SCOPE;
3814 PL_parser->copline = NOLINE;
3815 PL_parser->expect = XSTATE;
3820 if (!PL_madskills) {
3825 pegop = newOP(OP_NULL,0);
3826 op_getmad(o,pegop,'P');
3836 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3843 OP *pegop = newOP(OP_NULL,0);
3846 PERL_ARGS_ASSERT_UTILIZE;
3848 if (idop->op_type != OP_CONST)
3849 Perl_croak(aTHX_ "Module name must be constant");
3852 op_getmad(idop,pegop,'U');
3857 SV * const vesv = ((SVOP*)version)->op_sv;
3860 op_getmad(version,pegop,'V');
3861 if (!arg && !SvNIOKp(vesv)) {
3868 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3869 Perl_croak(aTHX_ "Version number must be constant number");
3871 /* Make copy of idop so we don't free it twice */
3872 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3874 /* Fake up a method call to VERSION */
3875 meth = newSVpvs_share("VERSION");
3876 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3877 append_elem(OP_LIST,
3878 prepend_elem(OP_LIST, pack, list(version)),
3879 newSVOP(OP_METHOD_NAMED, 0, meth)));
3883 /* Fake up an import/unimport */
3884 if (arg && arg->op_type == OP_STUB) {
3886 op_getmad(arg,pegop,'S');
3887 imop = arg; /* no import on explicit () */
3889 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3890 imop = NULL; /* use 5.0; */
3892 idop->op_private |= OPpCONST_NOVER;
3898 op_getmad(arg,pegop,'A');
3900 /* Make copy of idop so we don't free it twice */
3901 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3903 /* Fake up a method call to import/unimport */
3905 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3906 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3907 append_elem(OP_LIST,
3908 prepend_elem(OP_LIST, pack, list(arg)),
3909 newSVOP(OP_METHOD_NAMED, 0, meth)));
3912 /* Fake up the BEGIN {}, which does its thing immediately. */
3914 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3917 append_elem(OP_LINESEQ,
3918 append_elem(OP_LINESEQ,
3919 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3920 newSTATEOP(0, NULL, veop)),
3921 newSTATEOP(0, NULL, imop) ));
3923 /* The "did you use incorrect case?" warning used to be here.
3924 * The problem is that on case-insensitive filesystems one
3925 * might get false positives for "use" (and "require"):
3926 * "use Strict" or "require CARP" will work. This causes
3927 * portability problems for the script: in case-strict
3928 * filesystems the script will stop working.
3930 * The "incorrect case" warning checked whether "use Foo"
3931 * imported "Foo" to your namespace, but that is wrong, too:
3932 * there is no requirement nor promise in the language that
3933 * a Foo.pm should or would contain anything in package "Foo".
3935 * There is very little Configure-wise that can be done, either:
3936 * the case-sensitivity of the build filesystem of Perl does not
3937 * help in guessing the case-sensitivity of the runtime environment.
3940 PL_hints |= HINT_BLOCK_SCOPE;
3941 PL_parser->copline = NOLINE;
3942 PL_parser->expect = XSTATE;
3943 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3946 if (!PL_madskills) {
3947 /* FIXME - don't allocate pegop if !PL_madskills */
3956 =head1 Embedding Functions
3958 =for apidoc load_module
3960 Loads the module whose name is pointed to by the string part of name.
3961 Note that the actual module name, not its filename, should be given.
3962 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3963 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3964 (or 0 for no flags). ver, if specified, provides version semantics
3965 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3966 arguments can be used to specify arguments to the module's import()
3967 method, similar to C<use Foo::Bar VERSION LIST>.
3972 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3976 PERL_ARGS_ASSERT_LOAD_MODULE;
3978 va_start(args, ver);
3979 vload_module(flags, name, ver, &args);
3983 #ifdef PERL_IMPLICIT_CONTEXT
3985 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3989 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3990 va_start(args, ver);
3991 vload_module(flags, name, ver, &args);
3997 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4001 OP * const modname = newSVOP(OP_CONST, 0, name);
4003 PERL_ARGS_ASSERT_VLOAD_MODULE;
4005 modname->op_private |= OPpCONST_BARE;
4007 veop = newSVOP(OP_CONST, 0, ver);
4011 if (flags & PERL_LOADMOD_NOIMPORT) {
4012 imop = sawparens(newNULLLIST());
4014 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4015 imop = va_arg(*args, OP*);
4020 sv = va_arg(*args, SV*);
4022 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4023 sv = va_arg(*args, SV*);
4027 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4028 * that it has a PL_parser to play with while doing that, and also
4029 * that it doesn't mess with any existing parser, by creating a tmp
4030 * new parser with lex_start(). This won't actually be used for much,
4031 * since pp_require() will create another parser for the real work. */
4034 SAVEVPTR(PL_curcop);
4035 lex_start(NULL, NULL, FALSE);
4036 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4037 veop, modname, imop);
4042 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4048 PERL_ARGS_ASSERT_DOFILE;
4050 if (!force_builtin) {
4051 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4052 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4053 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4054 gv = gvp ? *gvp : NULL;
4058 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4059 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4060 append_elem(OP_LIST, term,
4061 scalar(newUNOP(OP_RV2CV, 0,
4062 newGVOP(OP_GV, 0, gv))))));
4065 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4071 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4073 return newBINOP(OP_LSLICE, flags,
4074 list(force_list(subscript)),
4075 list(force_list(listval)) );
4079 S_is_list_assignment(pTHX_ register const OP *o)
4087 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4088 o = cUNOPo->op_first;
4090 flags = o->op_flags;
4092 if (type == OP_COND_EXPR) {
4093 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4094 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4099 yyerror("Assignment to both a list and a scalar");
4103 if (type == OP_LIST &&
4104 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4105 o->op_private & OPpLVAL_INTRO)
4108 if (type == OP_LIST || flags & OPf_PARENS ||
4109 type == OP_RV2AV || type == OP_RV2HV ||
4110 type == OP_ASLICE || type == OP_HSLICE)
4113 if (type == OP_PADAV || type == OP_PADHV)
4116 if (type == OP_RV2SV)
4123 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4129 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4130 return newLOGOP(optype, 0,
4131 mod(scalar(left), optype),
4132 newUNOP(OP_SASSIGN, 0, scalar(right)));
4135 return newBINOP(optype, OPf_STACKED,
4136 mod(scalar(left), optype), scalar(right));
4140 if (is_list_assignment(left)) {
4141 static const char no_list_state[] = "Initialization of state variables"
4142 " in list context currently forbidden";
4144 bool maybe_common_vars = TRUE;
4147 /* Grandfathering $[ assignment here. Bletch.*/
4148 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4149 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4150 left = mod(left, OP_AASSIGN);
4153 else if (left->op_type == OP_CONST) {
4155 /* Result of assignment is always 1 (or we'd be dead already) */
4156 return newSVOP(OP_CONST, 0, newSViv(1));
4158 curop = list(force_list(left));
4159 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4160 o->op_private = (U8)(0 | (flags >> 8));
4162 if ((left->op_type == OP_LIST
4163 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4165 OP* lop = ((LISTOP*)left)->op_first;
4166 maybe_common_vars = FALSE;
4168 if (lop->op_type == OP_PADSV ||
4169 lop->op_type == OP_PADAV ||
4170 lop->op_type == OP_PADHV ||
4171 lop->op_type == OP_PADANY) {
4172 if (!(lop->op_private & OPpLVAL_INTRO))
4173 maybe_common_vars = TRUE;
4175 if (lop->op_private & OPpPAD_STATE) {
4176 if (left->op_private & OPpLVAL_INTRO) {
4177 /* Each variable in state($a, $b, $c) = ... */
4180 /* Each state variable in
4181 (state $a, my $b, our $c, $d, undef) = ... */
4183 yyerror(no_list_state);
4185 /* Each my variable in
4186 (state $a, my $b, our $c, $d, undef) = ... */
4188 } else if (lop->op_type == OP_UNDEF ||
4189 lop->op_type == OP_PUSHMARK) {
4190 /* undef may be interesting in
4191 (state $a, undef, state $c) */
4193 /* Other ops in the list. */
4194 maybe_common_vars = TRUE;
4196 lop = lop->op_sibling;
4199 else if ((left->op_private & OPpLVAL_INTRO)
4200 && ( left->op_type == OP_PADSV
4201 || left->op_type == OP_PADAV
4202 || left->op_type == OP_PADHV
4203 || left->op_type == OP_PADANY))
4205 maybe_common_vars = FALSE;
4206 if (left->op_private & OPpPAD_STATE) {
4207 /* All single variable list context state assignments, hence
4217 yyerror(no_list_state);
4221 /* PL_generation sorcery:
4222 * an assignment like ($a,$b) = ($c,$d) is easier than
4223 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4224 * To detect whether there are common vars, the global var
4225 * PL_generation is incremented for each assign op we compile.
4226 * Then, while compiling the assign op, we run through all the
4227 * variables on both sides of the assignment, setting a spare slot
4228 * in each of them to PL_generation. If any of them already have
4229 * that value, we know we've got commonality. We could use a
4230 * single bit marker, but then we'd have to make 2 passes, first
4231 * to clear the flag, then to test and set it. To find somewhere
4232 * to store these values, evil chicanery is done with SvUVX().
4235 if (maybe_common_vars) {
4238 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4239 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4240 if (curop->op_type == OP_GV) {
4241 GV *gv = cGVOPx_gv(curop);
4243 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4245 GvASSIGN_GENERATION_set(gv, PL_generation);
4247 else if (curop->op_type == OP_PADSV ||
4248 curop->op_type == OP_PADAV ||
4249 curop->op_type == OP_PADHV ||
4250 curop->op_type == OP_PADANY)
4252 if (PAD_COMPNAME_GEN(curop->op_targ)
4253 == (STRLEN)PL_generation)
4255 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4258 else if (curop->op_type == OP_RV2CV)
4260 else if (curop->op_type == OP_RV2SV ||
4261 curop->op_type == OP_RV2AV ||
4262 curop->op_type == OP_RV2HV ||
4263 curop->op_type == OP_RV2GV) {
4264 if (lastop->op_type != OP_GV) /* funny deref? */
4267 else if (curop->op_type == OP_PUSHRE) {
4269 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4270 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4272 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4274 GvASSIGN_GENERATION_set(gv, PL_generation);
4278 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4281 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4283 GvASSIGN_GENERATION_set(gv, PL_generation);
4293 o->op_private |= OPpASSIGN_COMMON;
4296 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4297 OP* tmpop = ((LISTOP*)right)->op_first;
4298 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4299 PMOP * const pm = (PMOP*)tmpop;
4300 if (left->op_type == OP_RV2AV &&
4301 !(left->op_private & OPpLVAL_INTRO) &&
4302 !(o->op_private & OPpASSIGN_COMMON) )
4304 tmpop = ((UNOP*)left)->op_first;
4305 if (tmpop->op_type == OP_GV
4307 && !pm->op_pmreplrootu.op_pmtargetoff
4309 && !pm->op_pmreplrootu.op_pmtargetgv
4313 pm->op_pmreplrootu.op_pmtargetoff
4314 = cPADOPx(tmpop)->op_padix;
4315 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4317 pm->op_pmreplrootu.op_pmtargetgv
4318 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4319 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4321 pm->op_pmflags |= PMf_ONCE;
4322 tmpop = cUNOPo->op_first; /* to list (nulled) */
4323 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4324 tmpop->op_sibling = NULL; /* don't free split */
4325 right->op_next = tmpop->op_next; /* fix starting loc */
4326 op_free(o); /* blow off assign */
4327 right->op_flags &= ~OPf_WANT;
4328 /* "I don't know and I don't care." */
4333 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4334 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4336 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4338 sv_setiv(sv, PL_modcount+1);
4346 right = newOP(OP_UNDEF, 0);
4347 if (right->op_type == OP_READLINE) {
4348 right->op_flags |= OPf_STACKED;
4349 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4352 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4353 o = newBINOP(OP_SASSIGN, flags,
4354 scalar(right), mod(scalar(left), OP_SASSIGN) );
4358 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
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.
5957 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5962 const char *const file = CopFILE(PL_curcop);
5964 SV *const temp_sv = CopFILESV(PL_curcop);
5965 const char *const file = temp_sv ? SvPV_const_nolen(temp_sv) : NULL;
5970 if (IN_PERL_RUNTIME) {
5971 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5972 * an op shared between threads. Use a non-shared COP for our
5974 SAVEVPTR(PL_curcop);
5975 PL_curcop = &PL_compiling;
5977 SAVECOPLINE(PL_curcop);
5978 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5981 PL_hints &= ~HINT_BLOCK_SCOPE;
5984 SAVESPTR(PL_curstash);
5985 SAVECOPSTASH(PL_curcop);
5986 PL_curstash = stash;
5987 CopSTASH_set(PL_curcop,stash);
5990 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5991 and so doesn't get free()d. (It's expected to be from the C pre-
5992 processor __FILE__ directive). But we need a dynamically allocated one,
5993 and we need it to get freed. */
5994 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
5995 XS_DYNAMIC_FILENAME);
5996 CvXSUBANY(cv).any_ptr = sv;
6001 CopSTASH_free(PL_curcop);
6009 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6010 const char *const filename, const char *const proto,
6013 CV *cv = newXS(name, subaddr, filename);
6015 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6017 if (flags & XS_DYNAMIC_FILENAME) {
6018 /* We need to "make arrangements" (ie cheat) to ensure that the
6019 filename lasts as long as the PVCV we just created, but also doesn't
6021 STRLEN filename_len = strlen(filename);
6022 STRLEN proto_and_file_len = filename_len;
6023 char *proto_and_file;
6027 proto_len = strlen(proto);
6028 proto_and_file_len += proto_len;
6030 Newx(proto_and_file, proto_and_file_len + 1, char);
6031 Copy(proto, proto_and_file, proto_len, char);
6032 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6035 proto_and_file = savepvn(filename, filename_len);
6038 /* This gets free()d. :-) */
6039 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6040 SV_HAS_TRAILING_NUL);
6042 /* This gives us the correct prototype, rather than one with the
6043 file name appended. */
6044 SvCUR_set(cv, proto_len);
6048 CvFILE(cv) = proto_and_file + proto_len;
6050 sv_setpv(MUTABLE_SV(cv), proto);
6056 =for apidoc U||newXS
6058 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6059 static storage, as it is used directly as CvFILE(), without a copy being made.
6065 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6068 GV * const gv = gv_fetchpv(name ? name :
6069 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6070 GV_ADDMULTI, SVt_PVCV);
6073 PERL_ARGS_ASSERT_NEWXS;
6076 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6078 if ((cv = (name ? GvCV(gv) : NULL))) {
6080 /* just a cached method */
6084 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6085 /* already defined (or promised) */
6086 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6087 if (ckWARN(WARN_REDEFINE)) {
6088 GV * const gvcv = CvGV(cv);
6090 HV * const stash = GvSTASH(gvcv);
6092 const char *redefined_name = HvNAME_get(stash);
6093 if ( strEQ(redefined_name,"autouse") ) {
6094 const line_t oldline = CopLINE(PL_curcop);
6095 if (PL_parser && PL_parser->copline != NOLINE)
6096 CopLINE_set(PL_curcop, PL_parser->copline);
6097 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6098 CvCONST(cv) ? "Constant subroutine %s redefined"
6099 : "Subroutine %s redefined"
6101 CopLINE_set(PL_curcop, oldline);
6111 if (cv) /* must reuse cv if autoloaded */
6114 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6118 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6122 (void)gv_fetchfile(filename);
6123 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6124 an external constant string */
6126 CvXSUB(cv) = subaddr;
6129 process_special_blocks(name, gv, cv);
6141 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6146 OP* pegop = newOP(OP_NULL, 0);
6150 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6151 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6153 #ifdef GV_UNIQUE_CHECK
6155 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6159 if ((cv = GvFORM(gv))) {
6160 if (ckWARN(WARN_REDEFINE)) {
6161 const line_t oldline = CopLINE(PL_curcop);
6162 if (PL_parser && PL_parser->copline != NOLINE)
6163 CopLINE_set(PL_curcop, PL_parser->copline);
6164 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6165 o ? "Format %"SVf" redefined"
6166 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6167 CopLINE_set(PL_curcop, oldline);
6174 CvFILE_set_from_cop(cv, PL_curcop);
6177 pad_tidy(padtidy_FORMAT);
6178 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6179 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6180 OpREFCNT_set(CvROOT(cv), 1);
6181 CvSTART(cv) = LINKLIST(CvROOT(cv));
6182 CvROOT(cv)->op_next = 0;
6183 CALL_PEEP(CvSTART(cv));
6185 op_getmad(o,pegop,'n');
6186 op_getmad_weak(block, pegop, 'b');
6191 PL_parser->copline = NOLINE;
6199 Perl_newANONLIST(pTHX_ OP *o)
6201 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6205 Perl_newANONHASH(pTHX_ OP *o)
6207 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6211 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6213 return newANONATTRSUB(floor, proto, NULL, block);
6217 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6219 return newUNOP(OP_REFGEN, 0,
6220 newSVOP(OP_ANONCODE, 0,
6221 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6225 Perl_oopsAV(pTHX_ OP *o)
6229 PERL_ARGS_ASSERT_OOPSAV;
6231 switch (o->op_type) {
6233 o->op_type = OP_PADAV;
6234 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6235 return ref(o, OP_RV2AV);
6238 o->op_type = OP_RV2AV;
6239 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6244 if (ckWARN_d(WARN_INTERNAL))
6245 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6252 Perl_oopsHV(pTHX_ OP *o)
6256 PERL_ARGS_ASSERT_OOPSHV;
6258 switch (o->op_type) {
6261 o->op_type = OP_PADHV;
6262 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6263 return ref(o, OP_RV2HV);
6267 o->op_type = OP_RV2HV;
6268 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6273 if (ckWARN_d(WARN_INTERNAL))
6274 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6281 Perl_newAVREF(pTHX_ OP *o)
6285 PERL_ARGS_ASSERT_NEWAVREF;
6287 if (o->op_type == OP_PADANY) {
6288 o->op_type = OP_PADAV;
6289 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6292 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6293 && ckWARN(WARN_DEPRECATED)) {
6294 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6295 "Using an array as a reference is deprecated");
6297 return newUNOP(OP_RV2AV, 0, scalar(o));
6301 Perl_newGVREF(pTHX_ I32 type, OP *o)
6303 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6304 return newUNOP(OP_NULL, 0, o);
6305 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6309 Perl_newHVREF(pTHX_ OP *o)
6313 PERL_ARGS_ASSERT_NEWHVREF;
6315 if (o->op_type == OP_PADANY) {
6316 o->op_type = OP_PADHV;
6317 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6320 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6321 && ckWARN(WARN_DEPRECATED)) {
6322 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6323 "Using a hash as a reference is deprecated");
6325 return newUNOP(OP_RV2HV, 0, scalar(o));
6329 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6331 return newUNOP(OP_RV2CV, flags, scalar(o));
6335 Perl_newSVREF(pTHX_ OP *o)
6339 PERL_ARGS_ASSERT_NEWSVREF;
6341 if (o->op_type == OP_PADANY) {
6342 o->op_type = OP_PADSV;
6343 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6346 return newUNOP(OP_RV2SV, 0, scalar(o));
6349 /* Check routines. See the comments at the top of this file for details
6350 * on when these are called */
6353 Perl_ck_anoncode(pTHX_ OP *o)
6355 PERL_ARGS_ASSERT_CK_ANONCODE;
6357 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6359 cSVOPo->op_sv = NULL;
6364 Perl_ck_bitop(pTHX_ OP *o)
6368 PERL_ARGS_ASSERT_CK_BITOP;
6370 #define OP_IS_NUMCOMPARE(op) \
6371 ((op) == OP_LT || (op) == OP_I_LT || \
6372 (op) == OP_GT || (op) == OP_I_GT || \
6373 (op) == OP_LE || (op) == OP_I_LE || \
6374 (op) == OP_GE || (op) == OP_I_GE || \
6375 (op) == OP_EQ || (op) == OP_I_EQ || \
6376 (op) == OP_NE || (op) == OP_I_NE || \
6377 (op) == OP_NCMP || (op) == OP_I_NCMP)
6378 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6379 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6380 && (o->op_type == OP_BIT_OR
6381 || o->op_type == OP_BIT_AND
6382 || o->op_type == OP_BIT_XOR))
6384 const OP * const left = cBINOPo->op_first;
6385 const OP * const right = left->op_sibling;
6386 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6387 (left->op_flags & OPf_PARENS) == 0) ||
6388 (OP_IS_NUMCOMPARE(right->op_type) &&
6389 (right->op_flags & OPf_PARENS) == 0))
6390 if (ckWARN(WARN_PRECEDENCE))
6391 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6392 "Possible precedence problem on bitwise %c operator",
6393 o->op_type == OP_BIT_OR ? '|'
6394 : o->op_type == OP_BIT_AND ? '&' : '^'
6401 Perl_ck_concat(pTHX_ OP *o)
6403 const OP * const kid = cUNOPo->op_first;
6405 PERL_ARGS_ASSERT_CK_CONCAT;
6406 PERL_UNUSED_CONTEXT;
6408 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6409 !(kUNOP->op_first->op_flags & OPf_MOD))
6410 o->op_flags |= OPf_STACKED;
6415 Perl_ck_spair(pTHX_ OP *o)
6419 PERL_ARGS_ASSERT_CK_SPAIR;
6421 if (o->op_flags & OPf_KIDS) {
6424 const OPCODE type = o->op_type;
6425 o = modkids(ck_fun(o), type);
6426 kid = cUNOPo->op_first;
6427 newop = kUNOP->op_first->op_sibling;
6429 const OPCODE type = newop->op_type;
6430 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6431 type == OP_PADAV || type == OP_PADHV ||
6432 type == OP_RV2AV || type == OP_RV2HV)
6436 op_getmad(kUNOP->op_first,newop,'K');
6438 op_free(kUNOP->op_first);
6440 kUNOP->op_first = newop;
6442 o->op_ppaddr = PL_ppaddr[++o->op_type];
6447 Perl_ck_delete(pTHX_ OP *o)
6449 PERL_ARGS_ASSERT_CK_DELETE;
6453 if (o->op_flags & OPf_KIDS) {
6454 OP * const kid = cUNOPo->op_first;
6455 switch (kid->op_type) {
6457 o->op_flags |= OPf_SPECIAL;
6460 o->op_private |= OPpSLICE;
6463 o->op_flags |= OPf_SPECIAL;
6468 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6477 Perl_ck_die(pTHX_ OP *o)
6479 PERL_ARGS_ASSERT_CK_DIE;
6482 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6488 Perl_ck_eof(pTHX_ OP *o)
6492 PERL_ARGS_ASSERT_CK_EOF;
6494 if (o->op_flags & OPf_KIDS) {
6495 if (cLISTOPo->op_first->op_type == OP_STUB) {
6497 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6499 op_getmad(o,newop,'O');
6511 Perl_ck_eval(pTHX_ OP *o)
6515 PERL_ARGS_ASSERT_CK_EVAL;
6517 PL_hints |= HINT_BLOCK_SCOPE;
6518 if (o->op_flags & OPf_KIDS) {
6519 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6522 o->op_flags &= ~OPf_KIDS;
6525 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6531 cUNOPo->op_first = 0;
6536 NewOp(1101, enter, 1, LOGOP);
6537 enter->op_type = OP_ENTERTRY;
6538 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6539 enter->op_private = 0;
6541 /* establish postfix order */
6542 enter->op_next = (OP*)enter;
6544 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6545 o->op_type = OP_LEAVETRY;
6546 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6547 enter->op_other = o;
6548 op_getmad(oldo,o,'O');
6562 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6563 op_getmad(oldo,o,'O');
6565 o->op_targ = (PADOFFSET)PL_hints;
6566 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6567 /* Store a copy of %^H that pp_entereval can pick up. */
6568 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6569 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6570 cUNOPo->op_first->op_sibling = hhop;
6571 o->op_private |= OPpEVAL_HAS_HH;
6577 Perl_ck_exit(pTHX_ OP *o)
6579 PERL_ARGS_ASSERT_CK_EXIT;
6582 HV * const table = GvHV(PL_hintgv);
6584 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6585 if (svp && *svp && SvTRUE(*svp))
6586 o->op_private |= OPpEXIT_VMSISH;
6588 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6594 Perl_ck_exec(pTHX_ OP *o)
6596 PERL_ARGS_ASSERT_CK_EXEC;
6598 if (o->op_flags & OPf_STACKED) {
6601 kid = cUNOPo->op_first->op_sibling;
6602 if (kid->op_type == OP_RV2GV)
6611 Perl_ck_exists(pTHX_ OP *o)
6615 PERL_ARGS_ASSERT_CK_EXISTS;
6618 if (o->op_flags & OPf_KIDS) {
6619 OP * const kid = cUNOPo->op_first;
6620 if (kid->op_type == OP_ENTERSUB) {
6621 (void) ref(kid, o->op_type);
6622 if (kid->op_type != OP_RV2CV
6623 && !(PL_parser && PL_parser->error_count))
6624 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6626 o->op_private |= OPpEXISTS_SUB;
6628 else if (kid->op_type == OP_AELEM)
6629 o->op_flags |= OPf_SPECIAL;
6630 else if (kid->op_type != OP_HELEM)
6631 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6639 Perl_ck_rvconst(pTHX_ register OP *o)
6642 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6644 PERL_ARGS_ASSERT_CK_RVCONST;
6646 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6647 if (o->op_type == OP_RV2CV)
6648 o->op_private &= ~1;
6650 if (kid->op_type == OP_CONST) {
6653 SV * const kidsv = kid->op_sv;
6655 /* Is it a constant from cv_const_sv()? */
6656 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6657 SV * const rsv = SvRV(kidsv);
6658 const svtype type = SvTYPE(rsv);
6659 const char *badtype = NULL;
6661 switch (o->op_type) {
6663 if (type > SVt_PVMG)
6664 badtype = "a SCALAR";
6667 if (type != SVt_PVAV)
6668 badtype = "an ARRAY";
6671 if (type != SVt_PVHV)
6675 if (type != SVt_PVCV)
6680 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6683 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6684 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6685 /* If this is an access to a stash, disable "strict refs", because
6686 * stashes aren't auto-vivified at compile-time (unless we store
6687 * symbols in them), and we don't want to produce a run-time
6688 * stricture error when auto-vivifying the stash. */
6689 const char *s = SvPV_nolen(kidsv);
6690 const STRLEN l = SvCUR(kidsv);
6691 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6692 o->op_private &= ~HINT_STRICT_REFS;
6694 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6695 const char *badthing;
6696 switch (o->op_type) {
6698 badthing = "a SCALAR";
6701 badthing = "an ARRAY";
6704 badthing = "a HASH";
6712 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6713 SVfARG(kidsv), badthing);
6716 * This is a little tricky. We only want to add the symbol if we
6717 * didn't add it in the lexer. Otherwise we get duplicate strict
6718 * warnings. But if we didn't add it in the lexer, we must at
6719 * least pretend like we wanted to add it even if it existed before,
6720 * or we get possible typo warnings. OPpCONST_ENTERED says
6721 * whether the lexer already added THIS instance of this symbol.
6723 iscv = (o->op_type == OP_RV2CV) * 2;
6725 gv = gv_fetchsv(kidsv,
6726 iscv | !(kid->op_private & OPpCONST_ENTERED),
6729 : o->op_type == OP_RV2SV
6731 : o->op_type == OP_RV2AV
6733 : o->op_type == OP_RV2HV
6736 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6738 kid->op_type = OP_GV;
6739 SvREFCNT_dec(kid->op_sv);
6741 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6742 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6743 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6745 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6747 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6749 kid->op_private = 0;
6750 kid->op_ppaddr = PL_ppaddr[OP_GV];
6757 Perl_ck_ftst(pTHX_ OP *o)
6760 const I32 type = o->op_type;
6762 PERL_ARGS_ASSERT_CK_FTST;
6764 if (o->op_flags & OPf_REF) {
6767 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6768 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6769 const OPCODE kidtype = kid->op_type;
6771 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6772 OP * const newop = newGVOP(type, OPf_REF,
6773 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6775 op_getmad(o,newop,'O');
6781 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6782 o->op_private |= OPpFT_ACCESS;
6783 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6784 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6785 o->op_private |= OPpFT_STACKED;
6793 if (type == OP_FTTTY)
6794 o = newGVOP(type, OPf_REF, PL_stdingv);
6796 o = newUNOP(type, 0, newDEFSVOP());
6797 op_getmad(oldo,o,'O');
6803 Perl_ck_fun(pTHX_ OP *o)
6806 const int type = o->op_type;
6807 register I32 oa = PL_opargs[type] >> OASHIFT;
6809 PERL_ARGS_ASSERT_CK_FUN;
6811 if (o->op_flags & OPf_STACKED) {
6812 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6815 return no_fh_allowed(o);
6818 if (o->op_flags & OPf_KIDS) {
6819 OP **tokid = &cLISTOPo->op_first;
6820 register OP *kid = cLISTOPo->op_first;
6824 if (kid->op_type == OP_PUSHMARK ||
6825 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6827 tokid = &kid->op_sibling;
6828 kid = kid->op_sibling;
6830 if (!kid && PL_opargs[type] & OA_DEFGV)
6831 *tokid = kid = newDEFSVOP();
6835 sibl = kid->op_sibling;
6837 if (!sibl && kid->op_type == OP_STUB) {
6844 /* list seen where single (scalar) arg expected? */
6845 if (numargs == 1 && !(oa >> 4)
6846 && kid->op_type == OP_LIST && type != OP_SCALAR)
6848 return too_many_arguments(o,PL_op_desc[type]);
6861 if ((type == OP_PUSH || type == OP_UNSHIFT)
6862 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6863 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6864 "Useless use of %s with no values",
6867 if (kid->op_type == OP_CONST &&
6868 (kid->op_private & OPpCONST_BARE))
6870 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6871 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6872 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6873 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6874 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6875 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6877 op_getmad(kid,newop,'K');
6882 kid->op_sibling = sibl;
6885 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6886 bad_type(numargs, "array", PL_op_desc[type], kid);
6890 if (kid->op_type == OP_CONST &&
6891 (kid->op_private & OPpCONST_BARE))
6893 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6894 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6895 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6896 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6897 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6898 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6900 op_getmad(kid,newop,'K');
6905 kid->op_sibling = sibl;
6908 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6909 bad_type(numargs, "hash", PL_op_desc[type], kid);
6914 OP * const newop = newUNOP(OP_NULL, 0, kid);
6915 kid->op_sibling = 0;
6917 newop->op_next = newop;
6919 kid->op_sibling = sibl;
6924 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6925 if (kid->op_type == OP_CONST &&
6926 (kid->op_private & OPpCONST_BARE))
6928 OP * const newop = newGVOP(OP_GV, 0,
6929 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6930 if (!(o->op_private & 1) && /* if not unop */
6931 kid == cLISTOPo->op_last)
6932 cLISTOPo->op_last = newop;
6934 op_getmad(kid,newop,'K');
6940 else if (kid->op_type == OP_READLINE) {
6941 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6942 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6945 I32 flags = OPf_SPECIAL;
6949 /* is this op a FH constructor? */
6950 if (is_handle_constructor(o,numargs)) {
6951 const char *name = NULL;
6955 /* Set a flag to tell rv2gv to vivify
6956 * need to "prove" flag does not mean something
6957 * else already - NI-S 1999/05/07
6960 if (kid->op_type == OP_PADSV) {
6962 = PAD_COMPNAME_SV(kid->op_targ);
6963 name = SvPV_const(namesv, len);
6965 else if (kid->op_type == OP_RV2SV
6966 && kUNOP->op_first->op_type == OP_GV)
6968 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6970 len = GvNAMELEN(gv);
6972 else if (kid->op_type == OP_AELEM
6973 || kid->op_type == OP_HELEM)
6976 OP *op = ((BINOP*)kid)->op_first;
6980 const char * const a =
6981 kid->op_type == OP_AELEM ?
6983 if (((op->op_type == OP_RV2AV) ||
6984 (op->op_type == OP_RV2HV)) &&
6985 (firstop = ((UNOP*)op)->op_first) &&
6986 (firstop->op_type == OP_GV)) {
6987 /* packagevar $a[] or $h{} */
6988 GV * const gv = cGVOPx_gv(firstop);
6996 else if (op->op_type == OP_PADAV
6997 || op->op_type == OP_PADHV) {
6998 /* lexicalvar $a[] or $h{} */
6999 const char * const padname =
7000 PAD_COMPNAME_PV(op->op_targ);
7009 name = SvPV_const(tmpstr, len);
7014 name = "__ANONIO__";
7021 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7022 namesv = PAD_SVl(targ);
7023 SvUPGRADE(namesv, SVt_PV);
7025 sv_setpvs(namesv, "$");
7026 sv_catpvn(namesv, name, len);
7029 kid->op_sibling = 0;
7030 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7031 kid->op_targ = targ;
7032 kid->op_private |= priv;
7034 kid->op_sibling = sibl;
7040 mod(scalar(kid), type);
7044 tokid = &kid->op_sibling;
7045 kid = kid->op_sibling;
7048 if (kid && kid->op_type != OP_STUB)
7049 return too_many_arguments(o,OP_DESC(o));
7050 o->op_private |= numargs;
7052 /* FIXME - should the numargs move as for the PERL_MAD case? */
7053 o->op_private |= numargs;
7055 return too_many_arguments(o,OP_DESC(o));
7059 else if (PL_opargs[type] & OA_DEFGV) {
7061 OP *newop = newUNOP(type, 0, newDEFSVOP());
7062 op_getmad(o,newop,'O');
7065 /* Ordering of these two is important to keep f_map.t passing. */
7067 return newUNOP(type, 0, newDEFSVOP());
7072 while (oa & OA_OPTIONAL)
7074 if (oa && oa != OA_LIST)
7075 return too_few_arguments(o,OP_DESC(o));
7081 Perl_ck_glob(pTHX_ OP *o)
7086 PERL_ARGS_ASSERT_CK_GLOB;
7089 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7090 append_elem(OP_GLOB, o, newDEFSVOP());
7092 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7093 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7095 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7098 #if !defined(PERL_EXTERNAL_GLOB)
7099 /* XXX this can be tightened up and made more failsafe. */
7100 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7103 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7104 newSVpvs("File::Glob"), NULL, NULL, NULL);
7105 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7106 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7107 GvCV(gv) = GvCV(glob_gv);
7108 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7109 GvIMPORTED_CV_on(gv);
7112 #endif /* PERL_EXTERNAL_GLOB */
7114 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7115 append_elem(OP_GLOB, o,
7116 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7117 o->op_type = OP_LIST;
7118 o->op_ppaddr = PL_ppaddr[OP_LIST];
7119 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7120 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7121 cLISTOPo->op_first->op_targ = 0;
7122 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7123 append_elem(OP_LIST, o,
7124 scalar(newUNOP(OP_RV2CV, 0,
7125 newGVOP(OP_GV, 0, gv)))));
7126 o = newUNOP(OP_NULL, 0, ck_subr(o));
7127 o->op_targ = OP_GLOB; /* hint at what it used to be */
7130 gv = newGVgen("main");
7132 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7138 Perl_ck_grep(pTHX_ OP *o)
7143 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7146 PERL_ARGS_ASSERT_CK_GREP;
7148 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7149 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7151 if (o->op_flags & OPf_STACKED) {
7154 kid = cLISTOPo->op_first->op_sibling;
7155 if (!cUNOPx(kid)->op_next)
7156 Perl_croak(aTHX_ "panic: ck_grep");
7157 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7160 NewOp(1101, gwop, 1, LOGOP);
7161 kid->op_next = (OP*)gwop;
7162 o->op_flags &= ~OPf_STACKED;
7164 kid = cLISTOPo->op_first->op_sibling;
7165 if (type == OP_MAPWHILE)
7170 if (PL_parser && PL_parser->error_count)
7172 kid = cLISTOPo->op_first->op_sibling;
7173 if (kid->op_type != OP_NULL)
7174 Perl_croak(aTHX_ "panic: ck_grep");
7175 kid = kUNOP->op_first;
7178 NewOp(1101, gwop, 1, LOGOP);
7179 gwop->op_type = type;
7180 gwop->op_ppaddr = PL_ppaddr[type];
7181 gwop->op_first = listkids(o);
7182 gwop->op_flags |= OPf_KIDS;
7183 gwop->op_other = LINKLIST(kid);
7184 kid->op_next = (OP*)gwop;
7185 offset = pad_findmy("$_");
7186 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7187 o->op_private = gwop->op_private = 0;
7188 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7191 o->op_private = gwop->op_private = OPpGREP_LEX;
7192 gwop->op_targ = o->op_targ = offset;
7195 kid = cLISTOPo->op_first->op_sibling;
7196 if (!kid || !kid->op_sibling)
7197 return too_few_arguments(o,OP_DESC(o));
7198 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7199 mod(kid, OP_GREPSTART);
7205 Perl_ck_index(pTHX_ OP *o)
7207 PERL_ARGS_ASSERT_CK_INDEX;
7209 if (o->op_flags & OPf_KIDS) {
7210 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7212 kid = kid->op_sibling; /* get past "big" */
7213 if (kid && kid->op_type == OP_CONST)
7214 fbm_compile(((SVOP*)kid)->op_sv, 0);
7220 Perl_ck_lfun(pTHX_ OP *o)
7222 const OPCODE type = o->op_type;
7224 PERL_ARGS_ASSERT_CK_LFUN;
7226 return modkids(ck_fun(o), type);
7230 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7232 PERL_ARGS_ASSERT_CK_DEFINED;
7234 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7235 switch (cUNOPo->op_first->op_type) {
7237 /* This is needed for
7238 if (defined %stash::)
7239 to work. Do not break Tk.
7241 break; /* Globals via GV can be undef */
7243 case OP_AASSIGN: /* Is this a good idea? */
7244 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7245 "defined(@array) is deprecated");
7246 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7247 "\t(Maybe you should just omit the defined()?)\n");
7250 /* This is needed for
7251 if (defined %stash::)
7252 to work. Do not break Tk.
7254 break; /* Globals via GV can be undef */
7256 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7257 "defined(%%hash) is deprecated");
7258 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7259 "\t(Maybe you should just omit the defined()?)\n");
7270 Perl_ck_readline(pTHX_ OP *o)
7272 PERL_ARGS_ASSERT_CK_READLINE;
7274 if (!(o->op_flags & OPf_KIDS)) {
7276 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7278 op_getmad(o,newop,'O');
7288 Perl_ck_rfun(pTHX_ OP *o)
7290 const OPCODE type = o->op_type;
7292 PERL_ARGS_ASSERT_CK_RFUN;
7294 return refkids(ck_fun(o), type);
7298 Perl_ck_listiob(pTHX_ OP *o)
7302 PERL_ARGS_ASSERT_CK_LISTIOB;
7304 kid = cLISTOPo->op_first;
7307 kid = cLISTOPo->op_first;
7309 if (kid->op_type == OP_PUSHMARK)
7310 kid = kid->op_sibling;
7311 if (kid && o->op_flags & OPf_STACKED)
7312 kid = kid->op_sibling;
7313 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7314 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7315 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7316 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7317 cLISTOPo->op_first->op_sibling = kid;
7318 cLISTOPo->op_last = kid;
7319 kid = kid->op_sibling;
7324 append_elem(o->op_type, o, newDEFSVOP());
7330 Perl_ck_smartmatch(pTHX_ OP *o)
7333 if (0 == (o->op_flags & OPf_SPECIAL)) {
7334 OP *first = cBINOPo->op_first;
7335 OP *second = first->op_sibling;
7337 /* Implicitly take a reference to an array or hash */
7338 first->op_sibling = NULL;
7339 first = cBINOPo->op_first = ref_array_or_hash(first);
7340 second = first->op_sibling = ref_array_or_hash(second);
7342 /* Implicitly take a reference to a regular expression */
7343 if (first->op_type == OP_MATCH) {
7344 first->op_type = OP_QR;
7345 first->op_ppaddr = PL_ppaddr[OP_QR];
7347 if (second->op_type == OP_MATCH) {
7348 second->op_type = OP_QR;
7349 second->op_ppaddr = PL_ppaddr[OP_QR];
7358 Perl_ck_sassign(pTHX_ OP *o)
7361 OP * const kid = cLISTOPo->op_first;
7363 PERL_ARGS_ASSERT_CK_SASSIGN;
7365 /* has a disposable target? */
7366 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7367 && !(kid->op_flags & OPf_STACKED)
7368 /* Cannot steal the second time! */
7369 && !(kid->op_private & OPpTARGET_MY)
7370 /* Keep the full thing for madskills */
7374 OP * const kkid = kid->op_sibling;
7376 /* Can just relocate the target. */
7377 if (kkid && kkid->op_type == OP_PADSV
7378 && !(kkid->op_private & OPpLVAL_INTRO))
7380 kid->op_targ = kkid->op_targ;
7382 /* Now we do not need PADSV and SASSIGN. */
7383 kid->op_sibling = o->op_sibling; /* NULL */
7384 cLISTOPo->op_first = NULL;
7387 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7391 if (kid->op_sibling) {
7392 OP *kkid = kid->op_sibling;
7393 if (kkid->op_type == OP_PADSV
7394 && (kkid->op_private & OPpLVAL_INTRO)
7395 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7396 const PADOFFSET target = kkid->op_targ;
7397 OP *const other = newOP(OP_PADSV,
7399 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7400 OP *const first = newOP(OP_NULL, 0);
7401 OP *const nullop = newCONDOP(0, first, o, other);
7402 OP *const condop = first->op_next;
7403 /* hijacking PADSTALE for uninitialized state variables */
7404 SvPADSTALE_on(PAD_SVl(target));
7406 condop->op_type = OP_ONCE;
7407 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7408 condop->op_targ = target;
7409 other->op_targ = target;
7411 /* Because we change the type of the op here, we will skip the
7412 assinment binop->op_last = binop->op_first->op_sibling; at the
7413 end of Perl_newBINOP(). So need to do it here. */
7414 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7423 Perl_ck_match(pTHX_ OP *o)
7427 PERL_ARGS_ASSERT_CK_MATCH;
7429 if (o->op_type != OP_QR && PL_compcv) {
7430 const PADOFFSET offset = pad_findmy("$_");
7431 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7432 o->op_targ = offset;
7433 o->op_private |= OPpTARGET_MY;
7436 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7437 o->op_private |= OPpRUNTIME;
7442 Perl_ck_method(pTHX_ OP *o)
7444 OP * const kid = cUNOPo->op_first;
7446 PERL_ARGS_ASSERT_CK_METHOD;
7448 if (kid->op_type == OP_CONST) {
7449 SV* sv = kSVOP->op_sv;
7450 const char * const method = SvPVX_const(sv);
7451 if (!(strchr(method, ':') || strchr(method, '\''))) {
7453 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7454 sv = newSVpvn_share(method, SvCUR(sv), 0);
7457 kSVOP->op_sv = NULL;
7459 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7461 op_getmad(o,cmop,'O');
7472 Perl_ck_null(pTHX_ OP *o)
7474 PERL_ARGS_ASSERT_CK_NULL;
7475 PERL_UNUSED_CONTEXT;
7480 Perl_ck_open(pTHX_ OP *o)
7483 HV * const table = GvHV(PL_hintgv);
7485 PERL_ARGS_ASSERT_CK_OPEN;
7488 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7491 const char *d = SvPV_const(*svp, len);
7492 const I32 mode = mode_from_discipline(d, len);
7493 if (mode & O_BINARY)
7494 o->op_private |= OPpOPEN_IN_RAW;
7495 else if (mode & O_TEXT)
7496 o->op_private |= OPpOPEN_IN_CRLF;
7499 svp = hv_fetchs(table, "open_OUT", 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_OUT_RAW;
7506 else if (mode & O_TEXT)
7507 o->op_private |= OPpOPEN_OUT_CRLF;
7510 if (o->op_type == OP_BACKTICK) {
7511 if (!(o->op_flags & OPf_KIDS)) {
7512 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7514 op_getmad(o,newop,'O');
7523 /* In case of three-arg dup open remove strictness
7524 * from the last arg if it is a bareword. */
7525 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7526 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7530 if ((last->op_type == OP_CONST) && /* The bareword. */
7531 (last->op_private & OPpCONST_BARE) &&
7532 (last->op_private & OPpCONST_STRICT) &&
7533 (oa = first->op_sibling) && /* The fh. */
7534 (oa = oa->op_sibling) && /* The mode. */
7535 (oa->op_type == OP_CONST) &&
7536 SvPOK(((SVOP*)oa)->op_sv) &&
7537 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7538 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7539 (last == oa->op_sibling)) /* The bareword. */
7540 last->op_private &= ~OPpCONST_STRICT;
7546 Perl_ck_repeat(pTHX_ OP *o)
7548 PERL_ARGS_ASSERT_CK_REPEAT;
7550 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7551 o->op_private |= OPpREPEAT_DOLIST;
7552 cBINOPo->op_first = force_list(cBINOPo->op_first);
7560 Perl_ck_require(pTHX_ OP *o)
7565 PERL_ARGS_ASSERT_CK_REQUIRE;
7567 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7568 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7570 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7571 SV * const sv = kid->op_sv;
7572 U32 was_readonly = SvREADONLY(sv);
7579 sv_force_normal_flags(sv, 0);
7580 assert(!SvREADONLY(sv));
7590 for (; s < end; s++) {
7591 if (*s == ':' && s[1] == ':') {
7593 Move(s+2, s+1, end - s - 1, char);
7598 sv_catpvs(sv, ".pm");
7599 SvFLAGS(sv) |= was_readonly;
7603 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7604 /* handle override, if any */
7605 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7606 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7607 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7608 gv = gvp ? *gvp : NULL;
7612 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7613 OP * const kid = cUNOPo->op_first;
7616 cUNOPo->op_first = 0;
7620 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7621 append_elem(OP_LIST, kid,
7622 scalar(newUNOP(OP_RV2CV, 0,
7625 op_getmad(o,newop,'O');
7633 Perl_ck_return(pTHX_ OP *o)
7638 PERL_ARGS_ASSERT_CK_RETURN;
7640 kid = cLISTOPo->op_first->op_sibling;
7641 if (CvLVALUE(PL_compcv)) {
7642 for (; kid; kid = kid->op_sibling)
7643 mod(kid, OP_LEAVESUBLV);
7645 for (; kid; kid = kid->op_sibling)
7646 if ((kid->op_type == OP_NULL)
7647 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7648 /* This is a do block */
7649 OP *op = kUNOP->op_first;
7650 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7651 op = cUNOPx(op)->op_first;
7652 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7653 /* Force the use of the caller's context */
7654 op->op_flags |= OPf_SPECIAL;
7663 Perl_ck_select(pTHX_ OP *o)
7668 PERL_ARGS_ASSERT_CK_SELECT;
7670 if (o->op_flags & OPf_KIDS) {
7671 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7672 if (kid && kid->op_sibling) {
7673 o->op_type = OP_SSELECT;
7674 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7676 return fold_constants(o);
7680 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7681 if (kid && kid->op_type == OP_RV2GV)
7682 kid->op_private &= ~HINT_STRICT_REFS;
7687 Perl_ck_shift(pTHX_ OP *o)
7690 const I32 type = o->op_type;
7692 PERL_ARGS_ASSERT_CK_SHIFT;
7694 if (!(o->op_flags & OPf_KIDS)) {
7696 /* FIXME - this can be refactored to reduce code in #ifdefs */
7698 OP * const oldo = o;
7702 argop = newUNOP(OP_RV2AV, 0,
7703 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7705 o = newUNOP(type, 0, scalar(argop));
7706 op_getmad(oldo,o,'O');
7709 return newUNOP(type, 0, scalar(argop));
7712 return scalar(modkids(ck_fun(o), type));
7716 Perl_ck_sort(pTHX_ OP *o)
7721 PERL_ARGS_ASSERT_CK_SORT;
7723 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7724 HV * const hinthv = GvHV(PL_hintgv);
7726 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7728 const I32 sorthints = (I32)SvIV(*svp);
7729 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7730 o->op_private |= OPpSORT_QSORT;
7731 if ((sorthints & HINT_SORT_STABLE) != 0)
7732 o->op_private |= OPpSORT_STABLE;
7737 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7739 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7740 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7742 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7744 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7746 if (kid->op_type == OP_SCOPE) {
7750 else if (kid->op_type == OP_LEAVE) {
7751 if (o->op_type == OP_SORT) {
7752 op_null(kid); /* wipe out leave */
7755 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7756 if (k->op_next == kid)
7758 /* don't descend into loops */
7759 else if (k->op_type == OP_ENTERLOOP
7760 || k->op_type == OP_ENTERITER)
7762 k = cLOOPx(k)->op_lastop;
7767 kid->op_next = 0; /* just disconnect the leave */
7768 k = kLISTOP->op_first;
7773 if (o->op_type == OP_SORT) {
7774 /* provide scalar context for comparison function/block */
7780 o->op_flags |= OPf_SPECIAL;
7782 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7785 firstkid = firstkid->op_sibling;
7788 /* provide list context for arguments */
7789 if (o->op_type == OP_SORT)
7796 S_simplify_sort(pTHX_ OP *o)
7799 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7805 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7807 if (!(o->op_flags & OPf_STACKED))
7809 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7810 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7811 kid = kUNOP->op_first; /* get past null */
7812 if (kid->op_type != OP_SCOPE)
7814 kid = kLISTOP->op_last; /* get past scope */
7815 switch(kid->op_type) {
7823 k = kid; /* remember this node*/
7824 if (kBINOP->op_first->op_type != OP_RV2SV)
7826 kid = kBINOP->op_first; /* get past cmp */
7827 if (kUNOP->op_first->op_type != OP_GV)
7829 kid = kUNOP->op_first; /* get past rv2sv */
7831 if (GvSTASH(gv) != PL_curstash)
7833 gvname = GvNAME(gv);
7834 if (*gvname == 'a' && gvname[1] == '\0')
7836 else if (*gvname == 'b' && gvname[1] == '\0')
7841 kid = k; /* back to cmp */
7842 if (kBINOP->op_last->op_type != OP_RV2SV)
7844 kid = kBINOP->op_last; /* down to 2nd arg */
7845 if (kUNOP->op_first->op_type != OP_GV)
7847 kid = kUNOP->op_first; /* get past rv2sv */
7849 if (GvSTASH(gv) != PL_curstash)
7851 gvname = GvNAME(gv);
7853 ? !(*gvname == 'a' && gvname[1] == '\0')
7854 : !(*gvname == 'b' && gvname[1] == '\0'))
7856 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7858 o->op_private |= OPpSORT_DESCEND;
7859 if (k->op_type == OP_NCMP)
7860 o->op_private |= OPpSORT_NUMERIC;
7861 if (k->op_type == OP_I_NCMP)
7862 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7863 kid = cLISTOPo->op_first->op_sibling;
7864 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7866 op_getmad(kid,o,'S'); /* then delete it */
7868 op_free(kid); /* then delete it */
7873 Perl_ck_split(pTHX_ OP *o)
7878 PERL_ARGS_ASSERT_CK_SPLIT;
7880 if (o->op_flags & OPf_STACKED)
7881 return no_fh_allowed(o);
7883 kid = cLISTOPo->op_first;
7884 if (kid->op_type != OP_NULL)
7885 Perl_croak(aTHX_ "panic: ck_split");
7886 kid = kid->op_sibling;
7887 op_free(cLISTOPo->op_first);
7888 cLISTOPo->op_first = kid;
7890 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7891 cLISTOPo->op_last = kid; /* There was only one element previously */
7894 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7895 OP * const sibl = kid->op_sibling;
7896 kid->op_sibling = 0;
7897 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7898 if (cLISTOPo->op_first == cLISTOPo->op_last)
7899 cLISTOPo->op_last = kid;
7900 cLISTOPo->op_first = kid;
7901 kid->op_sibling = sibl;
7904 kid->op_type = OP_PUSHRE;
7905 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7907 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7908 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7909 "Use of /g modifier is meaningless in split");
7912 if (!kid->op_sibling)
7913 append_elem(OP_SPLIT, o, newDEFSVOP());
7915 kid = kid->op_sibling;
7918 if (!kid->op_sibling)
7919 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7920 assert(kid->op_sibling);
7922 kid = kid->op_sibling;
7925 if (kid->op_sibling)
7926 return too_many_arguments(o,OP_DESC(o));
7932 Perl_ck_join(pTHX_ OP *o)
7934 const OP * const kid = cLISTOPo->op_first->op_sibling;
7936 PERL_ARGS_ASSERT_CK_JOIN;
7938 if (kid && kid->op_type == OP_MATCH) {
7939 if (ckWARN(WARN_SYNTAX)) {
7940 const REGEXP *re = PM_GETRE(kPMOP);
7941 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7942 const STRLEN len = re ? RX_PRELEN(re) : 6;
7943 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7944 "/%.*s/ should probably be written as \"%.*s\"",
7945 (int)len, pmstr, (int)len, pmstr);
7952 Perl_ck_subr(pTHX_ OP *o)
7955 OP *prev = ((cUNOPo->op_first->op_sibling)
7956 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7957 OP *o2 = prev->op_sibling;
7959 const char *proto = NULL;
7960 const char *proto_end = NULL;
7965 I32 contextclass = 0;
7966 const char *e = NULL;
7969 PERL_ARGS_ASSERT_CK_SUBR;
7971 o->op_private |= OPpENTERSUB_HASTARG;
7972 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7973 if (cvop->op_type == OP_RV2CV) {
7975 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7976 op_null(cvop); /* disable rv2cv */
7977 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7978 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7979 GV *gv = cGVOPx_gv(tmpop);
7982 tmpop->op_private |= OPpEARLY_CV;
7986 namegv = CvANON(cv) ? gv : CvGV(cv);
7987 proto = SvPV(MUTABLE_SV(cv), len);
7988 proto_end = proto + len;
7993 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7994 if (o2->op_type == OP_CONST)
7995 o2->op_private &= ~OPpCONST_STRICT;
7996 else if (o2->op_type == OP_LIST) {
7997 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7998 if (sib && sib->op_type == OP_CONST)
7999 sib->op_private &= ~OPpCONST_STRICT;
8002 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8003 if (PERLDB_SUB && PL_curstash != PL_debstash)
8004 o->op_private |= OPpENTERSUB_DB;
8005 while (o2 != cvop) {
8007 if (PL_madskills && o2->op_type == OP_STUB) {
8008 o2 = o2->op_sibling;
8011 if (PL_madskills && o2->op_type == OP_NULL)
8012 o3 = ((UNOP*)o2)->op_first;
8016 if (proto >= proto_end)
8017 return too_many_arguments(o, gv_ename(namegv));
8025 /* _ must be at the end */
8026 if (proto[1] && proto[1] != ';')
8041 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8043 arg == 1 ? "block or sub {}" : "sub {}",
8044 gv_ename(namegv), o3);
8047 /* '*' allows any scalar type, including bareword */
8050 if (o3->op_type == OP_RV2GV)
8051 goto wrapref; /* autoconvert GLOB -> GLOBref */
8052 else if (o3->op_type == OP_CONST)
8053 o3->op_private &= ~OPpCONST_STRICT;
8054 else if (o3->op_type == OP_ENTERSUB) {
8055 /* accidental subroutine, revert to bareword */
8056 OP *gvop = ((UNOP*)o3)->op_first;
8057 if (gvop && gvop->op_type == OP_NULL) {
8058 gvop = ((UNOP*)gvop)->op_first;
8060 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8063 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8064 (gvop = ((UNOP*)gvop)->op_first) &&
8065 gvop->op_type == OP_GV)
8067 GV * const gv = cGVOPx_gv(gvop);
8068 OP * const sibling = o2->op_sibling;
8069 SV * const n = newSVpvs("");
8071 OP * const oldo2 = o2;
8075 gv_fullname4(n, gv, "", FALSE);
8076 o2 = newSVOP(OP_CONST, 0, n);
8077 op_getmad(oldo2,o2,'O');
8078 prev->op_sibling = o2;
8079 o2->op_sibling = sibling;
8095 if (contextclass++ == 0) {
8096 e = strchr(proto, ']');
8097 if (!e || e == proto)
8106 const char *p = proto;
8107 const char *const end = proto;
8109 while (*--p != '[') {}
8110 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8112 gv_ename(namegv), o3);
8117 if (o3->op_type == OP_RV2GV)
8120 bad_type(arg, "symbol", gv_ename(namegv), o3);
8123 if (o3->op_type == OP_ENTERSUB)
8126 bad_type(arg, "subroutine entry", gv_ename(namegv),
8130 if (o3->op_type == OP_RV2SV ||
8131 o3->op_type == OP_PADSV ||
8132 o3->op_type == OP_HELEM ||
8133 o3->op_type == OP_AELEM)
8136 bad_type(arg, "scalar", gv_ename(namegv), o3);
8139 if (o3->op_type == OP_RV2AV ||
8140 o3->op_type == OP_PADAV)
8143 bad_type(arg, "array", gv_ename(namegv), o3);
8146 if (o3->op_type == OP_RV2HV ||
8147 o3->op_type == OP_PADHV)
8150 bad_type(arg, "hash", gv_ename(namegv), o3);
8155 OP* const sib = kid->op_sibling;
8156 kid->op_sibling = 0;
8157 o2 = newUNOP(OP_REFGEN, 0, kid);
8158 o2->op_sibling = sib;
8159 prev->op_sibling = o2;
8161 if (contextclass && e) {
8176 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8177 gv_ename(namegv), SVfARG(cv));
8182 mod(o2, OP_ENTERSUB);
8184 o2 = o2->op_sibling;
8186 if (o2 == cvop && proto && *proto == '_') {
8187 /* generate an access to $_ */
8189 o2->op_sibling = prev->op_sibling;
8190 prev->op_sibling = o2; /* instead of cvop */
8192 if (proto && !optional && proto_end > proto &&
8193 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8194 return too_few_arguments(o, gv_ename(namegv));
8197 OP * const oldo = o;
8201 o=newSVOP(OP_CONST, 0, newSViv(0));
8202 op_getmad(oldo,o,'O');
8208 Perl_ck_svconst(pTHX_ OP *o)
8210 PERL_ARGS_ASSERT_CK_SVCONST;
8211 PERL_UNUSED_CONTEXT;
8212 SvREADONLY_on(cSVOPo->op_sv);
8217 Perl_ck_chdir(pTHX_ OP *o)
8219 if (o->op_flags & OPf_KIDS) {
8220 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8222 if (kid && kid->op_type == OP_CONST &&
8223 (kid->op_private & OPpCONST_BARE))
8225 o->op_flags |= OPf_SPECIAL;
8226 kid->op_private &= ~OPpCONST_STRICT;
8233 Perl_ck_trunc(pTHX_ OP *o)
8235 PERL_ARGS_ASSERT_CK_TRUNC;
8237 if (o->op_flags & OPf_KIDS) {
8238 SVOP *kid = (SVOP*)cUNOPo->op_first;
8240 if (kid->op_type == OP_NULL)
8241 kid = (SVOP*)kid->op_sibling;
8242 if (kid && kid->op_type == OP_CONST &&
8243 (kid->op_private & OPpCONST_BARE))
8245 o->op_flags |= OPf_SPECIAL;
8246 kid->op_private &= ~OPpCONST_STRICT;
8253 Perl_ck_unpack(pTHX_ OP *o)
8255 OP *kid = cLISTOPo->op_first;
8257 PERL_ARGS_ASSERT_CK_UNPACK;
8259 if (kid->op_sibling) {
8260 kid = kid->op_sibling;
8261 if (!kid->op_sibling)
8262 kid->op_sibling = newDEFSVOP();
8268 Perl_ck_substr(pTHX_ OP *o)
8270 PERL_ARGS_ASSERT_CK_SUBSTR;
8273 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8274 OP *kid = cLISTOPo->op_first;
8276 if (kid->op_type == OP_NULL)
8277 kid = kid->op_sibling;
8279 kid->op_flags |= OPf_MOD;
8286 Perl_ck_each(pTHX_ OP *o)
8289 OP *kid = cLISTOPo->op_first;
8291 PERL_ARGS_ASSERT_CK_EACH;
8293 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8294 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8295 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8296 o->op_type = new_type;
8297 o->op_ppaddr = PL_ppaddr[new_type];
8299 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8300 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8302 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8308 /* A peephole optimizer. We visit the ops in the order they're to execute.
8309 * See the comments at the top of this file for more details about when
8310 * peep() is called */
8313 Perl_peep(pTHX_ register OP *o)
8316 register OP* oldop = NULL;
8318 if (!o || o->op_opt)
8322 SAVEVPTR(PL_curcop);
8323 for (; o; o = o->op_next) {
8326 /* By default, this op has now been optimised. A couple of cases below
8327 clear this again. */
8330 switch (o->op_type) {
8333 PL_curcop = ((COP*)o); /* for warnings */
8337 if (cSVOPo->op_private & OPpCONST_STRICT)
8338 no_bareword_allowed(o);
8341 case OP_METHOD_NAMED:
8342 /* Relocate sv to the pad for thread safety.
8343 * Despite being a "constant", the SV is written to,
8344 * for reference counts, sv_upgrade() etc. */
8346 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8347 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8348 /* If op_sv is already a PADTMP then it is being used by
8349 * some pad, so make a copy. */
8350 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8351 SvREADONLY_on(PAD_SVl(ix));
8352 SvREFCNT_dec(cSVOPo->op_sv);
8354 else if (o->op_type != OP_METHOD_NAMED
8355 && cSVOPo->op_sv == &PL_sv_undef) {
8356 /* PL_sv_undef is hack - it's unsafe to store it in the
8357 AV that is the pad, because av_fetch treats values of
8358 PL_sv_undef as a "free" AV entry and will merrily
8359 replace them with a new SV, causing pad_alloc to think
8360 that this pad slot is free. (When, clearly, it is not)
8362 SvOK_off(PAD_SVl(ix));
8363 SvPADTMP_on(PAD_SVl(ix));
8364 SvREADONLY_on(PAD_SVl(ix));
8367 SvREFCNT_dec(PAD_SVl(ix));
8368 SvPADTMP_on(cSVOPo->op_sv);
8369 PAD_SETSV(ix, cSVOPo->op_sv);
8370 /* XXX I don't know how this isn't readonly already. */
8371 SvREADONLY_on(PAD_SVl(ix));
8373 cSVOPo->op_sv = NULL;
8380 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8381 if (o->op_next->op_private & OPpTARGET_MY) {
8382 if (o->op_flags & OPf_STACKED) /* chained concats */
8383 break; /* ignore_optimization */
8385 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8386 o->op_targ = o->op_next->op_targ;
8387 o->op_next->op_targ = 0;
8388 o->op_private |= OPpTARGET_MY;
8391 op_null(o->op_next);
8395 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8396 break; /* Scalar stub must produce undef. List stub is noop */
8400 if (o->op_targ == OP_NEXTSTATE
8401 || o->op_targ == OP_DBSTATE)
8403 PL_curcop = ((COP*)o);
8405 /* XXX: We avoid setting op_seq here to prevent later calls
8406 to peep() from mistakenly concluding that optimisation
8407 has already occurred. This doesn't fix the real problem,
8408 though (See 20010220.007). AMS 20010719 */
8409 /* op_seq functionality is now replaced by op_opt */
8416 if (oldop && o->op_next) {
8417 oldop->op_next = o->op_next;
8425 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8426 OP* const pop = (o->op_type == OP_PADAV) ?
8427 o->op_next : o->op_next->op_next;
8429 if (pop && pop->op_type == OP_CONST &&
8430 ((PL_op = pop->op_next)) &&
8431 pop->op_next->op_type == OP_AELEM &&
8432 !(pop->op_next->op_private &
8433 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8434 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8439 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8440 no_bareword_allowed(pop);
8441 if (o->op_type == OP_GV)
8442 op_null(o->op_next);
8443 op_null(pop->op_next);
8445 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8446 o->op_next = pop->op_next->op_next;
8447 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8448 o->op_private = (U8)i;
8449 if (o->op_type == OP_GV) {
8454 o->op_flags |= OPf_SPECIAL;
8455 o->op_type = OP_AELEMFAST;
8460 if (o->op_next->op_type == OP_RV2SV) {
8461 if (!(o->op_next->op_private & OPpDEREF)) {
8462 op_null(o->op_next);
8463 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8465 o->op_next = o->op_next->op_next;
8466 o->op_type = OP_GVSV;
8467 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8470 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8471 GV * const gv = cGVOPo_gv;
8472 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8473 /* XXX could check prototype here instead of just carping */
8474 SV * const sv = sv_newmortal();
8475 gv_efullname3(sv, gv, NULL);
8476 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8477 "%"SVf"() called too early to check prototype",
8481 else if (o->op_next->op_type == OP_READLINE
8482 && o->op_next->op_next->op_type == OP_CONCAT
8483 && (o->op_next->op_next->op_flags & OPf_STACKED))
8485 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8486 o->op_type = OP_RCATLINE;
8487 o->op_flags |= OPf_STACKED;
8488 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8489 op_null(o->op_next->op_next);
8490 op_null(o->op_next);
8506 while (cLOGOP->op_other->op_type == OP_NULL)
8507 cLOGOP->op_other = cLOGOP->op_other->op_next;
8508 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8513 while (cLOOP->op_redoop->op_type == OP_NULL)
8514 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8515 peep(cLOOP->op_redoop);
8516 while (cLOOP->op_nextop->op_type == OP_NULL)
8517 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8518 peep(cLOOP->op_nextop);
8519 while (cLOOP->op_lastop->op_type == OP_NULL)
8520 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8521 peep(cLOOP->op_lastop);
8525 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8526 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8527 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8528 cPMOP->op_pmstashstartu.op_pmreplstart
8529 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8530 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8534 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8535 && ckWARN(WARN_SYNTAX))
8537 if (o->op_next->op_sibling) {
8538 const OPCODE type = o->op_next->op_sibling->op_type;
8539 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8540 const line_t oldline = CopLINE(PL_curcop);
8541 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8542 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8543 "Statement unlikely to be reached");
8544 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8545 "\t(Maybe you meant system() when you said exec()?)\n");
8546 CopLINE_set(PL_curcop, oldline);
8557 const char *key = NULL;
8560 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8563 /* Make the CONST have a shared SV */
8564 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8565 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8566 key = SvPV_const(sv, keylen);
8567 lexname = newSVpvn_share(key,
8568 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8574 if ((o->op_private & (OPpLVAL_INTRO)))
8577 rop = (UNOP*)((BINOP*)o)->op_first;
8578 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8580 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8581 if (!SvPAD_TYPED(lexname))
8583 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8584 if (!fields || !GvHV(*fields))
8586 key = SvPV_const(*svp, keylen);
8587 if (!hv_fetch(GvHV(*fields), key,
8588 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8590 Perl_croak(aTHX_ "No such class field \"%s\" "
8591 "in variable %s of type %s",
8592 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8605 SVOP *first_key_op, *key_op;
8607 if ((o->op_private & (OPpLVAL_INTRO))
8608 /* I bet there's always a pushmark... */
8609 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8610 /* hmmm, no optimization if list contains only one key. */
8612 rop = (UNOP*)((LISTOP*)o)->op_last;
8613 if (rop->op_type != OP_RV2HV)
8615 if (rop->op_first->op_type == OP_PADSV)
8616 /* @$hash{qw(keys here)} */
8617 rop = (UNOP*)rop->op_first;
8619 /* @{$hash}{qw(keys here)} */
8620 if (rop->op_first->op_type == OP_SCOPE
8621 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8623 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8629 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8630 if (!SvPAD_TYPED(lexname))
8632 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8633 if (!fields || !GvHV(*fields))
8635 /* Again guessing that the pushmark can be jumped over.... */
8636 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8637 ->op_first->op_sibling;
8638 for (key_op = first_key_op; key_op;
8639 key_op = (SVOP*)key_op->op_sibling) {
8640 if (key_op->op_type != OP_CONST)
8642 svp = cSVOPx_svp(key_op);
8643 key = SvPV_const(*svp, keylen);
8644 if (!hv_fetch(GvHV(*fields), key,
8645 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8647 Perl_croak(aTHX_ "No such class field \"%s\" "
8648 "in variable %s of type %s",
8649 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8656 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8660 /* check that RHS of sort is a single plain array */
8661 OP *oright = cUNOPo->op_first;
8662 if (!oright || oright->op_type != OP_PUSHMARK)
8665 /* reverse sort ... can be optimised. */
8666 if (!cUNOPo->op_sibling) {
8667 /* Nothing follows us on the list. */
8668 OP * const reverse = o->op_next;
8670 if (reverse->op_type == OP_REVERSE &&
8671 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8672 OP * const pushmark = cUNOPx(reverse)->op_first;
8673 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8674 && (cUNOPx(pushmark)->op_sibling == o)) {
8675 /* reverse -> pushmark -> sort */
8676 o->op_private |= OPpSORT_REVERSE;
8678 pushmark->op_next = oright->op_next;
8684 /* make @a = sort @a act in-place */
8686 oright = cUNOPx(oright)->op_sibling;
8689 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8690 oright = cUNOPx(oright)->op_sibling;
8694 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8695 || oright->op_next != o
8696 || (oright->op_private & OPpLVAL_INTRO)
8700 /* o2 follows the chain of op_nexts through the LHS of the
8701 * assign (if any) to the aassign op itself */
8703 if (!o2 || o2->op_type != OP_NULL)
8706 if (!o2 || o2->op_type != OP_PUSHMARK)
8709 if (o2 && o2->op_type == OP_GV)
8712 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8713 || (o2->op_private & OPpLVAL_INTRO)
8718 if (!o2 || o2->op_type != OP_NULL)
8721 if (!o2 || o2->op_type != OP_AASSIGN
8722 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8725 /* check that the sort is the first arg on RHS of assign */
8727 o2 = cUNOPx(o2)->op_first;
8728 if (!o2 || o2->op_type != OP_NULL)
8730 o2 = cUNOPx(o2)->op_first;
8731 if (!o2 || o2->op_type != OP_PUSHMARK)
8733 if (o2->op_sibling != o)
8736 /* check the array is the same on both sides */
8737 if (oleft->op_type == OP_RV2AV) {
8738 if (oright->op_type != OP_RV2AV
8739 || !cUNOPx(oright)->op_first
8740 || cUNOPx(oright)->op_first->op_type != OP_GV
8741 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8742 cGVOPx_gv(cUNOPx(oright)->op_first)
8746 else if (oright->op_type != OP_PADAV
8747 || oright->op_targ != oleft->op_targ
8751 /* transfer MODishness etc from LHS arg to RHS arg */
8752 oright->op_flags = oleft->op_flags;
8753 o->op_private |= OPpSORT_INPLACE;
8755 /* excise push->gv->rv2av->null->aassign */
8756 o2 = o->op_next->op_next;
8757 op_null(o2); /* PUSHMARK */
8759 if (o2->op_type == OP_GV) {
8760 op_null(o2); /* GV */
8763 op_null(o2); /* RV2AV or PADAV */
8764 o2 = o2->op_next->op_next;
8765 op_null(o2); /* AASSIGN */
8767 o->op_next = o2->op_next;
8773 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8775 LISTOP *enter, *exlist;
8777 enter = (LISTOP *) o->op_next;
8780 if (enter->op_type == OP_NULL) {
8781 enter = (LISTOP *) enter->op_next;
8785 /* for $a (...) will have OP_GV then OP_RV2GV here.
8786 for (...) just has an OP_GV. */
8787 if (enter->op_type == OP_GV) {
8788 gvop = (OP *) enter;
8789 enter = (LISTOP *) enter->op_next;
8792 if (enter->op_type == OP_RV2GV) {
8793 enter = (LISTOP *) enter->op_next;
8799 if (enter->op_type != OP_ENTERITER)
8802 iter = enter->op_next;
8803 if (!iter || iter->op_type != OP_ITER)
8806 expushmark = enter->op_first;
8807 if (!expushmark || expushmark->op_type != OP_NULL
8808 || expushmark->op_targ != OP_PUSHMARK)
8811 exlist = (LISTOP *) expushmark->op_sibling;
8812 if (!exlist || exlist->op_type != OP_NULL
8813 || exlist->op_targ != OP_LIST)
8816 if (exlist->op_last != o) {
8817 /* Mmm. Was expecting to point back to this op. */
8820 theirmark = exlist->op_first;
8821 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8824 if (theirmark->op_sibling != o) {
8825 /* There's something between the mark and the reverse, eg
8826 for (1, reverse (...))
8831 ourmark = ((LISTOP *)o)->op_first;
8832 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8835 ourlast = ((LISTOP *)o)->op_last;
8836 if (!ourlast || ourlast->op_next != o)
8839 rv2av = ourmark->op_sibling;
8840 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8841 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8842 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8843 /* We're just reversing a single array. */
8844 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8845 enter->op_flags |= OPf_STACKED;
8848 /* We don't have control over who points to theirmark, so sacrifice
8850 theirmark->op_next = ourmark->op_next;
8851 theirmark->op_flags = ourmark->op_flags;
8852 ourlast->op_next = gvop ? gvop : (OP *) enter;
8855 enter->op_private |= OPpITER_REVERSED;
8856 iter->op_private |= OPpITER_REVERSED;
8863 UNOP *refgen, *rv2cv;
8866 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8869 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8872 rv2gv = ((BINOP *)o)->op_last;
8873 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8876 refgen = (UNOP *)((BINOP *)o)->op_first;
8878 if (!refgen || refgen->op_type != OP_REFGEN)
8881 exlist = (LISTOP *)refgen->op_first;
8882 if (!exlist || exlist->op_type != OP_NULL
8883 || exlist->op_targ != OP_LIST)
8886 if (exlist->op_first->op_type != OP_PUSHMARK)
8889 rv2cv = (UNOP*)exlist->op_last;
8891 if (rv2cv->op_type != OP_RV2CV)
8894 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8895 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8896 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8898 o->op_private |= OPpASSIGN_CV_TO_GV;
8899 rv2gv->op_private |= OPpDONT_INIT_GV;
8900 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8908 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8909 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8919 Perl_custom_op_name(pTHX_ const OP* o)
8922 const IV index = PTR2IV(o->op_ppaddr);
8926 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8928 if (!PL_custom_op_names) /* This probably shouldn't happen */
8929 return (char *)PL_op_name[OP_CUSTOM];
8931 keysv = sv_2mortal(newSViv(index));
8933 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8935 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8937 return SvPV_nolen(HeVAL(he));
8941 Perl_custom_op_desc(pTHX_ const OP* o)
8944 const IV index = PTR2IV(o->op_ppaddr);
8948 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8950 if (!PL_custom_op_descs)
8951 return (char *)PL_op_desc[OP_CUSTOM];
8953 keysv = sv_2mortal(newSViv(index));
8955 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8957 return (char *)PL_op_desc[OP_CUSTOM];
8959 return SvPV_nolen(HeVAL(he));
8964 /* Efficient sub that returns a constant scalar value. */
8966 const_sv_xsub(pTHX_ CV* cv)
8973 Perl_croak(aTHX_ "usage: %s::%s()",
8974 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8978 ST(0) = MUTABLE_SV(XSANY.any_ptr);
8984 * c-indentation-style: bsd
8986 * indent-tabs-mode: t
8989 * ex: set ts=8 sts=4 sw=4 noet: