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);
851 /* This is used in S_doeval in pp_ctl.c */
853 Perl_scalar(pTHX_ OP *o)
858 /* assumes no premature commitment */
859 if (!o || (PL_parser && PL_parser->error_count)
860 || (o->op_flags & OPf_WANT)
861 || o->op_type == OP_RETURN)
866 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
868 switch (o->op_type) {
870 scalar(cBINOPo->op_first);
875 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
879 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
880 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
881 deprecate_old("implicit split to @_");
889 if (o->op_flags & OPf_KIDS) {
890 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
896 kid = cLISTOPo->op_first;
898 while ((kid = kid->op_sibling)) {
904 PL_curcop = &PL_compiling;
909 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
915 PL_curcop = &PL_compiling;
918 if (ckWARN(WARN_VOID))
919 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
925 /* This is used in S_doeval in pp_ctl.c */
927 Perl_scalarvoid(pTHX_ OP *o)
931 const char* useless = NULL;
935 PERL_ARGS_ASSERT_SCALARVOID;
937 /* trailing mad null ops don't count as "there" for void processing */
939 o->op_type != OP_NULL &&
941 o->op_sibling->op_type == OP_NULL)
944 for (sib = o->op_sibling;
945 sib && sib->op_type == OP_NULL;
946 sib = sib->op_sibling) ;
952 if (o->op_type == OP_NEXTSTATE
953 || o->op_type == OP_DBSTATE
954 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
955 || o->op_targ == OP_DBSTATE)))
956 PL_curcop = (COP*)o; /* for warning below */
958 /* assumes no premature commitment */
959 want = o->op_flags & OPf_WANT;
960 if ((want && want != OPf_WANT_SCALAR)
961 || (PL_parser && PL_parser->error_count)
962 || o->op_type == OP_RETURN)
967 if ((o->op_private & OPpTARGET_MY)
968 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
970 return scalar(o); /* As if inside SASSIGN */
973 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
975 switch (o->op_type) {
977 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
981 if (o->op_flags & OPf_STACKED)
985 if (o->op_private == 4)
1028 case OP_GETSOCKNAME:
1029 case OP_GETPEERNAME:
1034 case OP_GETPRIORITY:
1058 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1059 /* Otherwise it's "Useless use of grep iterator" */
1060 useless = OP_DESC(o);
1064 kid = cUNOPo->op_first;
1065 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1066 kid->op_type != OP_TRANS) {
1069 useless = "negative pattern binding (!~)";
1076 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1077 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1078 useless = "a variable";
1083 if (cSVOPo->op_private & OPpCONST_STRICT)
1084 no_bareword_allowed(o);
1086 if (ckWARN(WARN_VOID)) {
1088 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1089 "a constant (%"SVf")", sv));
1090 useless = SvPV_nolen(msv);
1093 useless = "a constant (undef)";
1094 if (o->op_private & OPpCONST_ARYBASE)
1096 /* don't warn on optimised away booleans, eg
1097 * use constant Foo, 5; Foo || print; */
1098 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1100 /* the constants 0 and 1 are permitted as they are
1101 conventionally used as dummies in constructs like
1102 1 while some_condition_with_side_effects; */
1103 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1105 else if (SvPOK(sv)) {
1106 /* perl4's way of mixing documentation and code
1107 (before the invention of POD) was based on a
1108 trick to mix nroff and perl code. The trick was
1109 built upon these three nroff macros being used in
1110 void context. The pink camel has the details in
1111 the script wrapman near page 319. */
1112 const char * const maybe_macro = SvPVX_const(sv);
1113 if (strnEQ(maybe_macro, "di", 2) ||
1114 strnEQ(maybe_macro, "ds", 2) ||
1115 strnEQ(maybe_macro, "ig", 2))
1120 op_null(o); /* don't execute or even remember it */
1124 o->op_type = OP_PREINC; /* pre-increment is faster */
1125 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1129 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1130 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1134 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1135 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1139 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1140 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1145 kid = cLOGOPo->op_first;
1146 if (kid->op_type == OP_NOT
1147 && (kid->op_flags & OPf_KIDS)
1149 if (o->op_type == OP_AND) {
1151 o->op_ppaddr = PL_ppaddr[OP_OR];
1153 o->op_type = OP_AND;
1154 o->op_ppaddr = PL_ppaddr[OP_AND];
1163 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1168 if (o->op_flags & OPf_STACKED)
1175 if (!(o->op_flags & OPf_KIDS))
1186 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1193 /* all requires must return a boolean value */
1194 o->op_flags &= ~OPf_WANT;
1199 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1200 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1201 deprecate_old("implicit split to @_");
1205 if (useless && ckWARN(WARN_VOID))
1206 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1211 S_listkids(pTHX_ OP *o)
1213 if (o && o->op_flags & OPf_KIDS) {
1215 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1221 /* This is used in S_doeval in pp_ctl.c */
1223 Perl_list(pTHX_ OP *o)
1228 /* assumes no premature commitment */
1229 if (!o || (o->op_flags & OPf_WANT)
1230 || (PL_parser && PL_parser->error_count)
1231 || o->op_type == OP_RETURN)
1236 if ((o->op_private & OPpTARGET_MY)
1237 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1239 return o; /* As if inside SASSIGN */
1242 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1244 switch (o->op_type) {
1247 list(cBINOPo->op_first);
1252 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1260 if (!(o->op_flags & OPf_KIDS))
1262 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1263 list(cBINOPo->op_first);
1264 return gen_constant_list(o);
1271 kid = cLISTOPo->op_first;
1273 while ((kid = kid->op_sibling)) {
1274 if (kid->op_sibling)
1279 PL_curcop = &PL_compiling;
1283 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1284 if (kid->op_sibling)
1289 PL_curcop = &PL_compiling;
1292 /* all requires must return a boolean value */
1293 o->op_flags &= ~OPf_WANT;
1300 S_scalarseq(pTHX_ OP *o)
1304 const OPCODE type = o->op_type;
1306 if (type == OP_LINESEQ || type == OP_SCOPE ||
1307 type == OP_LEAVE || type == OP_LEAVETRY)
1310 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1311 if (kid->op_sibling) {
1315 PL_curcop = &PL_compiling;
1317 o->op_flags &= ~OPf_PARENS;
1318 if (PL_hints & HINT_BLOCK_SCOPE)
1319 o->op_flags |= OPf_PARENS;
1322 o = newOP(OP_STUB, 0);
1327 S_modkids(pTHX_ OP *o, I32 type)
1329 if (o && o->op_flags & OPf_KIDS) {
1331 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1337 /* Propagate lvalue ("modifiable") context to an op and its children.
1338 * 'type' represents the context type, roughly based on the type of op that
1339 * would do the modifying, although local() is represented by OP_NULL.
1340 * It's responsible for detecting things that can't be modified, flag
1341 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1342 * might have to vivify a reference in $x), and so on.
1344 * For example, "$a+1 = 2" would cause mod() to be called with o being
1345 * OP_ADD and type being OP_SASSIGN, and would output an error.
1349 Perl_mod(pTHX_ OP *o, I32 type)
1353 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1356 if (!o || (PL_parser && PL_parser->error_count))
1359 if ((o->op_private & OPpTARGET_MY)
1360 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1365 switch (o->op_type) {
1371 if (!(o->op_private & OPpCONST_ARYBASE))
1374 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1375 CopARYBASE_set(&PL_compiling,
1376 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1380 SAVECOPARYBASE(&PL_compiling);
1381 CopARYBASE_set(&PL_compiling, 0);
1383 else if (type == OP_REFGEN)
1386 Perl_croak(aTHX_ "That use of $[ is unsupported");
1389 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1393 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1394 !(o->op_flags & OPf_STACKED)) {
1395 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1396 /* The default is to set op_private to the number of children,
1397 which for a UNOP such as RV2CV is always 1. And w're using
1398 the bit for a flag in RV2CV, so we need it clear. */
1399 o->op_private &= ~1;
1400 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1401 assert(cUNOPo->op_first->op_type == OP_NULL);
1402 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1405 else if (o->op_private & OPpENTERSUB_NOMOD)
1407 else { /* lvalue subroutine call */
1408 o->op_private |= OPpLVAL_INTRO;
1409 PL_modcount = RETURN_UNLIMITED_NUMBER;
1410 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1411 /* Backward compatibility mode: */
1412 o->op_private |= OPpENTERSUB_INARGS;
1415 else { /* Compile-time error message: */
1416 OP *kid = cUNOPo->op_first;
1420 if (kid->op_type != OP_PUSHMARK) {
1421 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1423 "panic: unexpected lvalue entersub "
1424 "args: type/targ %ld:%"UVuf,
1425 (long)kid->op_type, (UV)kid->op_targ);
1426 kid = kLISTOP->op_first;
1428 while (kid->op_sibling)
1429 kid = kid->op_sibling;
1430 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1432 if (kid->op_type == OP_METHOD_NAMED
1433 || kid->op_type == OP_METHOD)
1437 NewOp(1101, newop, 1, UNOP);
1438 newop->op_type = OP_RV2CV;
1439 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1440 newop->op_first = NULL;
1441 newop->op_next = (OP*)newop;
1442 kid->op_sibling = (OP*)newop;
1443 newop->op_private |= OPpLVAL_INTRO;
1444 newop->op_private &= ~1;
1448 if (kid->op_type != OP_RV2CV)
1450 "panic: unexpected lvalue entersub "
1451 "entry via type/targ %ld:%"UVuf,
1452 (long)kid->op_type, (UV)kid->op_targ);
1453 kid->op_private |= OPpLVAL_INTRO;
1454 break; /* Postpone until runtime */
1458 kid = kUNOP->op_first;
1459 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1460 kid = kUNOP->op_first;
1461 if (kid->op_type == OP_NULL)
1463 "Unexpected constant lvalue entersub "
1464 "entry via type/targ %ld:%"UVuf,
1465 (long)kid->op_type, (UV)kid->op_targ);
1466 if (kid->op_type != OP_GV) {
1467 /* Restore RV2CV to check lvalueness */
1469 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1470 okid->op_next = kid->op_next;
1471 kid->op_next = okid;
1474 okid->op_next = NULL;
1475 okid->op_type = OP_RV2CV;
1477 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1478 okid->op_private |= OPpLVAL_INTRO;
1479 okid->op_private &= ~1;
1483 cv = GvCV(kGVOP_gv);
1493 /* grep, foreach, subcalls, refgen */
1494 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1496 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1497 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1499 : (o->op_type == OP_ENTERSUB
1500 ? "non-lvalue subroutine call"
1502 type ? PL_op_desc[type] : "local"));
1516 case OP_RIGHT_SHIFT:
1525 if (!(o->op_flags & OPf_STACKED))
1532 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1538 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1539 PL_modcount = RETURN_UNLIMITED_NUMBER;
1540 return o; /* Treat \(@foo) like ordinary list. */
1544 if (scalar_mod_type(o, type))
1546 ref(cUNOPo->op_first, o->op_type);
1550 if (type == OP_LEAVESUBLV)
1551 o->op_private |= OPpMAYBE_LVSUB;
1557 PL_modcount = RETURN_UNLIMITED_NUMBER;
1560 ref(cUNOPo->op_first, o->op_type);
1565 PL_hints |= HINT_BLOCK_SCOPE;
1580 PL_modcount = RETURN_UNLIMITED_NUMBER;
1581 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1582 return o; /* Treat \(@foo) like ordinary list. */
1583 if (scalar_mod_type(o, type))
1585 if (type == OP_LEAVESUBLV)
1586 o->op_private |= OPpMAYBE_LVSUB;
1590 if (!type) /* local() */
1591 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1592 PAD_COMPNAME_PV(o->op_targ));
1600 if (type != OP_SASSIGN)
1604 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1609 if (type == OP_LEAVESUBLV)
1610 o->op_private |= OPpMAYBE_LVSUB;
1612 pad_free(o->op_targ);
1613 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1614 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1615 if (o->op_flags & OPf_KIDS)
1616 mod(cBINOPo->op_first->op_sibling, type);
1621 ref(cBINOPo->op_first, o->op_type);
1622 if (type == OP_ENTERSUB &&
1623 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1624 o->op_private |= OPpLVAL_DEFER;
1625 if (type == OP_LEAVESUBLV)
1626 o->op_private |= OPpMAYBE_LVSUB;
1636 if (o->op_flags & OPf_KIDS)
1637 mod(cLISTOPo->op_last, type);
1642 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1644 else if (!(o->op_flags & OPf_KIDS))
1646 if (o->op_targ != OP_LIST) {
1647 mod(cBINOPo->op_first, type);
1653 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1658 if (type != OP_LEAVESUBLV)
1660 break; /* mod()ing was handled by ck_return() */
1663 /* [20011101.069] File test operators interpret OPf_REF to mean that
1664 their argument is a filehandle; thus \stat(".") should not set
1666 if (type == OP_REFGEN &&
1667 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1670 if (type != OP_LEAVESUBLV)
1671 o->op_flags |= OPf_MOD;
1673 if (type == OP_AASSIGN || type == OP_SASSIGN)
1674 o->op_flags |= OPf_SPECIAL|OPf_REF;
1675 else if (!type) { /* local() */
1678 o->op_private |= OPpLVAL_INTRO;
1679 o->op_flags &= ~OPf_SPECIAL;
1680 PL_hints |= HINT_BLOCK_SCOPE;
1685 if (ckWARN(WARN_SYNTAX)) {
1686 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1687 "Useless localization of %s", OP_DESC(o));
1691 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1692 && type != OP_LEAVESUBLV)
1693 o->op_flags |= OPf_REF;
1698 S_scalar_mod_type(const OP *o, I32 type)
1700 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1704 if (o->op_type == OP_RV2GV)
1728 case OP_RIGHT_SHIFT:
1748 S_is_handle_constructor(const OP *o, I32 numargs)
1750 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1752 switch (o->op_type) {
1760 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1773 S_refkids(pTHX_ OP *o, I32 type)
1775 if (o && o->op_flags & OPf_KIDS) {
1777 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1784 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1789 PERL_ARGS_ASSERT_DOREF;
1791 if (!o || (PL_parser && PL_parser->error_count))
1794 switch (o->op_type) {
1796 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1797 !(o->op_flags & OPf_STACKED)) {
1798 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1799 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1800 assert(cUNOPo->op_first->op_type == OP_NULL);
1801 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1802 o->op_flags |= OPf_SPECIAL;
1803 o->op_private &= ~1;
1808 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1809 doref(kid, type, set_op_ref);
1812 if (type == OP_DEFINED)
1813 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1814 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1817 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1818 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1819 : type == OP_RV2HV ? OPpDEREF_HV
1821 o->op_flags |= OPf_MOD;
1828 o->op_flags |= OPf_REF;
1831 if (type == OP_DEFINED)
1832 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1833 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1839 o->op_flags |= OPf_REF;
1844 if (!(o->op_flags & OPf_KIDS))
1846 doref(cBINOPo->op_first, type, set_op_ref);
1850 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1851 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1852 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1853 : type == OP_RV2HV ? OPpDEREF_HV
1855 o->op_flags |= OPf_MOD;
1865 if (!(o->op_flags & OPf_KIDS))
1867 doref(cLISTOPo->op_last, type, set_op_ref);
1877 S_dup_attrlist(pTHX_ OP *o)
1882 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1884 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1885 * where the first kid is OP_PUSHMARK and the remaining ones
1886 * are OP_CONST. We need to push the OP_CONST values.
1888 if (o->op_type == OP_CONST)
1889 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1891 else if (o->op_type == OP_NULL)
1895 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1897 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1898 if (o->op_type == OP_CONST)
1899 rop = append_elem(OP_LIST, rop,
1900 newSVOP(OP_CONST, o->op_flags,
1901 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1908 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1913 PERL_ARGS_ASSERT_APPLY_ATTRS;
1915 /* fake up C<use attributes $pkg,$rv,@attrs> */
1916 ENTER; /* need to protect against side-effects of 'use' */
1917 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1919 #define ATTRSMODULE "attributes"
1920 #define ATTRSMODULE_PM "attributes.pm"
1923 /* Don't force the C<use> if we don't need it. */
1924 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1925 if (svp && *svp != &PL_sv_undef)
1926 NOOP; /* already in %INC */
1928 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1929 newSVpvs(ATTRSMODULE), NULL);
1932 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1933 newSVpvs(ATTRSMODULE),
1935 prepend_elem(OP_LIST,
1936 newSVOP(OP_CONST, 0, stashsv),
1937 prepend_elem(OP_LIST,
1938 newSVOP(OP_CONST, 0,
1940 dup_attrlist(attrs))));
1946 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1949 OP *pack, *imop, *arg;
1952 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1957 assert(target->op_type == OP_PADSV ||
1958 target->op_type == OP_PADHV ||
1959 target->op_type == OP_PADAV);
1961 /* Ensure that attributes.pm is loaded. */
1962 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1964 /* Need package name for method call. */
1965 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1967 /* Build up the real arg-list. */
1968 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1970 arg = newOP(OP_PADSV, 0);
1971 arg->op_targ = target->op_targ;
1972 arg = prepend_elem(OP_LIST,
1973 newSVOP(OP_CONST, 0, stashsv),
1974 prepend_elem(OP_LIST,
1975 newUNOP(OP_REFGEN, 0,
1976 mod(arg, OP_REFGEN)),
1977 dup_attrlist(attrs)));
1979 /* Fake up a method call to import */
1980 meth = newSVpvs_share("import");
1981 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1982 append_elem(OP_LIST,
1983 prepend_elem(OP_LIST, pack, list(arg)),
1984 newSVOP(OP_METHOD_NAMED, 0, meth)));
1985 imop->op_private |= OPpENTERSUB_NOMOD;
1987 /* Combine the ops. */
1988 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1992 =notfor apidoc apply_attrs_string
1994 Attempts to apply a list of attributes specified by the C<attrstr> and
1995 C<len> arguments to the subroutine identified by the C<cv> argument which
1996 is expected to be associated with the package identified by the C<stashpv>
1997 argument (see L<attributes>). It gets this wrong, though, in that it
1998 does not correctly identify the boundaries of the individual attribute
1999 specifications within C<attrstr>. This is not really intended for the
2000 public API, but has to be listed here for systems such as AIX which
2001 need an explicit export list for symbols. (It's called from XS code
2002 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2003 to respect attribute syntax properly would be welcome.
2009 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2010 const char *attrstr, STRLEN len)
2014 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2017 len = strlen(attrstr);
2021 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2023 const char * const sstr = attrstr;
2024 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2025 attrs = append_elem(OP_LIST, attrs,
2026 newSVOP(OP_CONST, 0,
2027 newSVpvn(sstr, attrstr-sstr)));
2031 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2032 newSVpvs(ATTRSMODULE),
2033 NULL, prepend_elem(OP_LIST,
2034 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2035 prepend_elem(OP_LIST,
2036 newSVOP(OP_CONST, 0,
2037 newRV(MUTABLE_SV(cv))),
2042 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2047 PERL_ARGS_ASSERT_MY_KID;
2049 if (!o || (PL_parser && PL_parser->error_count))
2053 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2054 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2058 if (type == OP_LIST) {
2060 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2061 my_kid(kid, attrs, imopsp);
2062 } else if (type == OP_UNDEF
2068 } else if (type == OP_RV2SV || /* "our" declaration */
2070 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2071 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2072 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2074 PL_parser->in_my == KEY_our
2076 : PL_parser->in_my == KEY_state ? "state" : "my"));
2078 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2079 PL_parser->in_my = FALSE;
2080 PL_parser->in_my_stash = NULL;
2081 apply_attrs(GvSTASH(gv),
2082 (type == OP_RV2SV ? GvSV(gv) :
2083 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2084 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2087 o->op_private |= OPpOUR_INTRO;
2090 else if (type != OP_PADSV &&
2093 type != OP_PUSHMARK)
2095 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2097 PL_parser->in_my == KEY_our
2099 : PL_parser->in_my == KEY_state ? "state" : "my"));
2102 else if (attrs && type != OP_PUSHMARK) {
2105 PL_parser->in_my = FALSE;
2106 PL_parser->in_my_stash = NULL;
2108 /* check for C<my Dog $spot> when deciding package */
2109 stash = PAD_COMPNAME_TYPE(o->op_targ);
2111 stash = PL_curstash;
2112 apply_attrs_my(stash, o, attrs, imopsp);
2114 o->op_flags |= OPf_MOD;
2115 o->op_private |= OPpLVAL_INTRO;
2116 if (PL_parser->in_my == KEY_state)
2117 o->op_private |= OPpPAD_STATE;
2122 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2126 int maybe_scalar = 0;
2128 PERL_ARGS_ASSERT_MY_ATTRS;
2130 /* [perl #17376]: this appears to be premature, and results in code such as
2131 C< our(%x); > executing in list mode rather than void mode */
2133 if (o->op_flags & OPf_PARENS)
2143 o = my_kid(o, attrs, &rops);
2145 if (maybe_scalar && o->op_type == OP_PADSV) {
2146 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2147 o->op_private |= OPpLVAL_INTRO;
2150 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2152 PL_parser->in_my = FALSE;
2153 PL_parser->in_my_stash = NULL;
2157 /* This is used in perly.y */
2159 Perl_sawparens(pTHX_ OP *o)
2161 PERL_UNUSED_CONTEXT;
2163 o->op_flags |= OPf_PARENS;
2168 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2172 const OPCODE ltype = left->op_type;
2173 const OPCODE rtype = right->op_type;
2175 PERL_ARGS_ASSERT_BIND_MATCH;
2177 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2178 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2180 const char * const desc
2181 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2182 ? (int)rtype : OP_MATCH];
2183 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2184 ? "@array" : "%hash");
2185 Perl_warner(aTHX_ packWARN(WARN_MISC),
2186 "Applying %s to %s will act on scalar(%s)",
2187 desc, sample, sample);
2190 if (rtype == OP_CONST &&
2191 cSVOPx(right)->op_private & OPpCONST_BARE &&
2192 cSVOPx(right)->op_private & OPpCONST_STRICT)
2194 no_bareword_allowed(right);
2197 ismatchop = rtype == OP_MATCH ||
2198 rtype == OP_SUBST ||
2200 if (ismatchop && right->op_private & OPpTARGET_MY) {
2202 right->op_private &= ~OPpTARGET_MY;
2204 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2207 right->op_flags |= OPf_STACKED;
2208 if (rtype != OP_MATCH &&
2209 ! (rtype == OP_TRANS &&
2210 right->op_private & OPpTRANS_IDENTICAL))
2211 newleft = mod(left, rtype);
2214 if (right->op_type == OP_TRANS)
2215 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2217 o = prepend_elem(rtype, scalar(newleft), right);
2219 return newUNOP(OP_NOT, 0, scalar(o));
2223 return bind_match(type, left,
2224 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2228 Perl_invert(pTHX_ OP *o)
2232 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2236 Perl_scope(pTHX_ OP *o)
2240 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2241 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2242 o->op_type = OP_LEAVE;
2243 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2245 else if (o->op_type == OP_LINESEQ) {
2247 o->op_type = OP_SCOPE;
2248 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2249 kid = ((LISTOP*)o)->op_first;
2250 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2253 /* The following deals with things like 'do {1 for 1}' */
2254 kid = kid->op_sibling;
2256 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2261 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2267 Perl_block_start(pTHX_ int full)
2270 const int retval = PL_savestack_ix;
2271 pad_block_start(full);
2273 PL_hints &= ~HINT_BLOCK_SCOPE;
2274 SAVECOMPILEWARNINGS();
2275 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2280 Perl_block_end(pTHX_ I32 floor, OP *seq)
2283 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2284 OP* const retval = scalarseq(seq);
2286 CopHINTS_set(&PL_compiling, PL_hints);
2288 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2297 const PADOFFSET offset = pad_findmy("$_");
2298 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2299 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2302 OP * const o = newOP(OP_PADSV, 0);
2303 o->op_targ = offset;
2309 Perl_newPROG(pTHX_ OP *o)
2313 PERL_ARGS_ASSERT_NEWPROG;
2318 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2319 ((PL_in_eval & EVAL_KEEPERR)
2320 ? OPf_SPECIAL : 0), o);
2321 PL_eval_start = linklist(PL_eval_root);
2322 PL_eval_root->op_private |= OPpREFCOUNTED;
2323 OpREFCNT_set(PL_eval_root, 1);
2324 PL_eval_root->op_next = 0;
2325 CALL_PEEP(PL_eval_start);
2328 if (o->op_type == OP_STUB) {
2329 PL_comppad_name = 0;
2331 S_op_destroy(aTHX_ o);
2334 PL_main_root = scope(sawparens(scalarvoid(o)));
2335 PL_curcop = &PL_compiling;
2336 PL_main_start = LINKLIST(PL_main_root);
2337 PL_main_root->op_private |= OPpREFCOUNTED;
2338 OpREFCNT_set(PL_main_root, 1);
2339 PL_main_root->op_next = 0;
2340 CALL_PEEP(PL_main_start);
2343 /* Register with debugger */
2346 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2350 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2352 call_sv(MUTABLE_SV(cv), G_DISCARD);
2359 Perl_localize(pTHX_ OP *o, I32 lex)
2363 PERL_ARGS_ASSERT_LOCALIZE;
2365 if (o->op_flags & OPf_PARENS)
2366 /* [perl #17376]: this appears to be premature, and results in code such as
2367 C< our(%x); > executing in list mode rather than void mode */
2374 if ( PL_parser->bufptr > PL_parser->oldbufptr
2375 && PL_parser->bufptr[-1] == ','
2376 && ckWARN(WARN_PARENTHESIS))
2378 char *s = PL_parser->bufptr;
2381 /* some heuristics to detect a potential error */
2382 while (*s && (strchr(", \t\n", *s)))
2386 if (*s && strchr("@$%*", *s) && *++s
2387 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2390 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2392 while (*s && (strchr(", \t\n", *s)))
2398 if (sigil && (*s == ';' || *s == '=')) {
2399 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2400 "Parentheses missing around \"%s\" list",
2402 ? (PL_parser->in_my == KEY_our
2404 : PL_parser->in_my == KEY_state
2414 o = mod(o, OP_NULL); /* a bit kludgey */
2415 PL_parser->in_my = FALSE;
2416 PL_parser->in_my_stash = NULL;
2421 Perl_jmaybe(pTHX_ OP *o)
2423 PERL_ARGS_ASSERT_JMAYBE;
2425 if (o->op_type == OP_LIST) {
2427 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2428 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2434 S_fold_constants(pTHX_ register OP *o)
2437 register OP * VOL curop;
2439 VOL I32 type = o->op_type;
2444 SV * const oldwarnhook = PL_warnhook;
2445 SV * const olddiehook = PL_diehook;
2449 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2451 if (PL_opargs[type] & OA_RETSCALAR)
2453 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2454 o->op_targ = pad_alloc(type, SVs_PADTMP);
2456 /* integerize op, unless it happens to be C<-foo>.
2457 * XXX should pp_i_negate() do magic string negation instead? */
2458 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2459 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2460 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2462 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2465 if (!(PL_opargs[type] & OA_FOLDCONST))
2470 /* XXX might want a ck_negate() for this */
2471 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2482 /* XXX what about the numeric ops? */
2483 if (PL_hints & HINT_LOCALE)
2488 if (PL_parser && PL_parser->error_count)
2489 goto nope; /* Don't try to run w/ errors */
2491 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2492 const OPCODE type = curop->op_type;
2493 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2495 type != OP_SCALAR &&
2497 type != OP_PUSHMARK)
2503 curop = LINKLIST(o);
2504 old_next = o->op_next;
2508 oldscope = PL_scopestack_ix;
2509 create_eval_scope(G_FAKINGEVAL);
2511 /* Verify that we don't need to save it: */
2512 assert(PL_curcop == &PL_compiling);
2513 StructCopy(&PL_compiling, ¬_compiling, COP);
2514 PL_curcop = ¬_compiling;
2515 /* The above ensures that we run with all the correct hints of the
2516 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2517 assert(IN_PERL_RUNTIME);
2518 PL_warnhook = PERL_WARNHOOK_FATAL;
2525 sv = *(PL_stack_sp--);
2526 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2527 pad_swipe(o->op_targ, FALSE);
2528 else if (SvTEMP(sv)) { /* grab mortal temp? */
2529 SvREFCNT_inc_simple_void(sv);
2534 /* Something tried to die. Abandon constant folding. */
2535 /* Pretend the error never happened. */
2537 o->op_next = old_next;
2541 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2542 PL_warnhook = oldwarnhook;
2543 PL_diehook = olddiehook;
2544 /* XXX note that this croak may fail as we've already blown away
2545 * the stack - eg any nested evals */
2546 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2549 PL_warnhook = oldwarnhook;
2550 PL_diehook = olddiehook;
2551 PL_curcop = &PL_compiling;
2553 if (PL_scopestack_ix > oldscope)
2554 delete_eval_scope();
2563 if (type == OP_RV2GV)
2564 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2566 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2567 op_getmad(o,newop,'f');
2575 S_gen_constant_list(pTHX_ register OP *o)
2579 const I32 oldtmps_floor = PL_tmps_floor;
2582 if (PL_parser && PL_parser->error_count)
2583 return o; /* Don't attempt to run with errors */
2585 PL_op = curop = LINKLIST(o);
2591 assert (!(curop->op_flags & OPf_SPECIAL));
2592 assert(curop->op_type == OP_RANGE);
2594 PL_tmps_floor = oldtmps_floor;
2596 o->op_type = OP_RV2AV;
2597 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2598 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2599 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2600 o->op_opt = 0; /* needs to be revisited in peep() */
2601 curop = ((UNOP*)o)->op_first;
2602 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2604 op_getmad(curop,o,'O');
2613 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2616 if (!o || o->op_type != OP_LIST)
2617 o = newLISTOP(OP_LIST, 0, o, NULL);
2619 o->op_flags &= ~OPf_WANT;
2621 if (!(PL_opargs[type] & OA_MARK))
2622 op_null(cLISTOPo->op_first);
2624 o->op_type = (OPCODE)type;
2625 o->op_ppaddr = PL_ppaddr[type];
2626 o->op_flags |= flags;
2628 o = CHECKOP(type, o);
2629 if (o->op_type != (unsigned)type)
2632 return fold_constants(o);
2635 /* List constructors */
2638 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2646 if (first->op_type != (unsigned)type
2647 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2649 return newLISTOP(type, 0, first, last);
2652 if (first->op_flags & OPf_KIDS)
2653 ((LISTOP*)first)->op_last->op_sibling = last;
2655 first->op_flags |= OPf_KIDS;
2656 ((LISTOP*)first)->op_first = last;
2658 ((LISTOP*)first)->op_last = last;
2663 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2671 if (first->op_type != (unsigned)type)
2672 return prepend_elem(type, (OP*)first, (OP*)last);
2674 if (last->op_type != (unsigned)type)
2675 return append_elem(type, (OP*)first, (OP*)last);
2677 first->op_last->op_sibling = last->op_first;
2678 first->op_last = last->op_last;
2679 first->op_flags |= (last->op_flags & OPf_KIDS);
2682 if (last->op_first && first->op_madprop) {
2683 MADPROP *mp = last->op_first->op_madprop;
2685 while (mp->mad_next)
2687 mp->mad_next = first->op_madprop;
2690 last->op_first->op_madprop = first->op_madprop;
2693 first->op_madprop = last->op_madprop;
2694 last->op_madprop = 0;
2697 S_op_destroy(aTHX_ (OP*)last);
2703 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2711 if (last->op_type == (unsigned)type) {
2712 if (type == OP_LIST) { /* already a PUSHMARK there */
2713 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2714 ((LISTOP*)last)->op_first->op_sibling = first;
2715 if (!(first->op_flags & OPf_PARENS))
2716 last->op_flags &= ~OPf_PARENS;
2719 if (!(last->op_flags & OPf_KIDS)) {
2720 ((LISTOP*)last)->op_last = first;
2721 last->op_flags |= OPf_KIDS;
2723 first->op_sibling = ((LISTOP*)last)->op_first;
2724 ((LISTOP*)last)->op_first = first;
2726 last->op_flags |= OPf_KIDS;
2730 return newLISTOP(type, 0, first, last);
2738 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2741 Newxz(tk, 1, TOKEN);
2742 tk->tk_type = (OPCODE)optype;
2743 tk->tk_type = 12345;
2745 tk->tk_mad = madprop;
2750 Perl_token_free(pTHX_ TOKEN* tk)
2752 PERL_ARGS_ASSERT_TOKEN_FREE;
2754 if (tk->tk_type != 12345)
2756 mad_free(tk->tk_mad);
2761 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2766 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2768 if (tk->tk_type != 12345) {
2769 Perl_warner(aTHX_ packWARN(WARN_MISC),
2770 "Invalid TOKEN object ignored");
2777 /* faked up qw list? */
2779 tm->mad_type == MAD_SV &&
2780 SvPVX((const SV *)tm->mad_val)[0] == 'q')
2787 /* pretend constant fold didn't happen? */
2788 if (mp->mad_key == 'f' &&
2789 (o->op_type == OP_CONST ||
2790 o->op_type == OP_GV) )
2792 token_getmad(tk,(OP*)mp->mad_val,slot);
2806 if (mp->mad_key == 'X')
2807 mp->mad_key = slot; /* just change the first one */
2817 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2826 /* pretend constant fold didn't happen? */
2827 if (mp->mad_key == 'f' &&
2828 (o->op_type == OP_CONST ||
2829 o->op_type == OP_GV) )
2831 op_getmad(from,(OP*)mp->mad_val,slot);
2838 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2841 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2847 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2856 /* pretend constant fold didn't happen? */
2857 if (mp->mad_key == 'f' &&
2858 (o->op_type == OP_CONST ||
2859 o->op_type == OP_GV) )
2861 op_getmad(from,(OP*)mp->mad_val,slot);
2868 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2871 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2875 PerlIO_printf(PerlIO_stderr(),
2876 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2882 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2900 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2904 addmad(tm, &(o->op_madprop), slot);
2908 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2929 Perl_newMADsv(pTHX_ char key, SV* sv)
2931 PERL_ARGS_ASSERT_NEWMADSV;
2933 return newMADPROP(key, MAD_SV, sv, 0);
2937 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2940 Newxz(mp, 1, MADPROP);
2943 mp->mad_vlen = vlen;
2944 mp->mad_type = type;
2946 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2951 Perl_mad_free(pTHX_ MADPROP* mp)
2953 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2957 mad_free(mp->mad_next);
2958 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2959 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2960 switch (mp->mad_type) {
2964 Safefree((char*)mp->mad_val);
2967 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2968 op_free((OP*)mp->mad_val);
2971 sv_free(MUTABLE_SV(mp->mad_val));
2974 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2983 Perl_newNULLLIST(pTHX)
2985 return newOP(OP_STUB, 0);
2989 S_force_list(pTHX_ OP *o)
2991 if (!o || o->op_type != OP_LIST)
2992 o = newLISTOP(OP_LIST, 0, o, NULL);
2998 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3003 NewOp(1101, listop, 1, LISTOP);
3005 listop->op_type = (OPCODE)type;
3006 listop->op_ppaddr = PL_ppaddr[type];
3009 listop->op_flags = (U8)flags;
3013 else if (!first && last)
3016 first->op_sibling = last;
3017 listop->op_first = first;
3018 listop->op_last = last;
3019 if (type == OP_LIST) {
3020 OP* const pushop = newOP(OP_PUSHMARK, 0);
3021 pushop->op_sibling = first;
3022 listop->op_first = pushop;
3023 listop->op_flags |= OPf_KIDS;
3025 listop->op_last = pushop;
3028 return CHECKOP(type, listop);
3032 Perl_newOP(pTHX_ I32 type, I32 flags)
3036 NewOp(1101, o, 1, OP);
3037 o->op_type = (OPCODE)type;
3038 o->op_ppaddr = PL_ppaddr[type];
3039 o->op_flags = (U8)flags;
3041 o->op_latefreed = 0;
3045 o->op_private = (U8)(0 | (flags >> 8));
3046 if (PL_opargs[type] & OA_RETSCALAR)
3048 if (PL_opargs[type] & OA_TARGET)
3049 o->op_targ = pad_alloc(type, SVs_PADTMP);
3050 return CHECKOP(type, o);
3054 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3060 first = newOP(OP_STUB, 0);
3061 if (PL_opargs[type] & OA_MARK)
3062 first = force_list(first);
3064 NewOp(1101, unop, 1, UNOP);
3065 unop->op_type = (OPCODE)type;
3066 unop->op_ppaddr = PL_ppaddr[type];
3067 unop->op_first = first;
3068 unop->op_flags = (U8)(flags | OPf_KIDS);
3069 unop->op_private = (U8)(1 | (flags >> 8));
3070 unop = (UNOP*) CHECKOP(type, unop);
3074 return fold_constants((OP *) unop);
3078 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3082 NewOp(1101, binop, 1, BINOP);
3085 first = newOP(OP_NULL, 0);
3087 binop->op_type = (OPCODE)type;
3088 binop->op_ppaddr = PL_ppaddr[type];
3089 binop->op_first = first;
3090 binop->op_flags = (U8)(flags | OPf_KIDS);
3093 binop->op_private = (U8)(1 | (flags >> 8));
3096 binop->op_private = (U8)(2 | (flags >> 8));
3097 first->op_sibling = last;
3100 binop = (BINOP*)CHECKOP(type, binop);
3101 if (binop->op_next || binop->op_type != (OPCODE)type)
3104 binop->op_last = binop->op_first->op_sibling;
3106 return fold_constants((OP *)binop);
3109 static int uvcompare(const void *a, const void *b)
3110 __attribute__nonnull__(1)
3111 __attribute__nonnull__(2)
3112 __attribute__pure__;
3113 static int uvcompare(const void *a, const void *b)
3115 if (*((const UV *)a) < (*(const UV *)b))
3117 if (*((const UV *)a) > (*(const UV *)b))
3119 if (*((const UV *)a+1) < (*(const UV *)b+1))
3121 if (*((const UV *)a+1) > (*(const UV *)b+1))
3127 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3130 SV * const tstr = ((SVOP*)expr)->op_sv;
3133 (repl->op_type == OP_NULL)
3134 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3136 ((SVOP*)repl)->op_sv;
3139 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3140 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3144 register short *tbl;
3146 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3147 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3148 I32 del = o->op_private & OPpTRANS_DELETE;
3151 PERL_ARGS_ASSERT_PMTRANS;
3153 PL_hints |= HINT_BLOCK_SCOPE;
3156 o->op_private |= OPpTRANS_FROM_UTF;
3159 o->op_private |= OPpTRANS_TO_UTF;
3161 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3162 SV* const listsv = newSVpvs("# comment\n");
3164 const U8* tend = t + tlen;
3165 const U8* rend = r + rlen;
3179 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3180 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3183 const U32 flags = UTF8_ALLOW_DEFAULT;
3187 t = tsave = bytes_to_utf8(t, &len);
3190 if (!to_utf && rlen) {
3192 r = rsave = bytes_to_utf8(r, &len);
3196 /* There are several snags with this code on EBCDIC:
3197 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3198 2. scan_const() in toke.c has encoded chars in native encoding which makes
3199 ranges at least in EBCDIC 0..255 range the bottom odd.
3203 U8 tmpbuf[UTF8_MAXBYTES+1];
3206 Newx(cp, 2*tlen, UV);
3208 transv = newSVpvs("");
3210 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3212 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3214 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3218 cp[2*i+1] = cp[2*i];
3222 qsort(cp, i, 2*sizeof(UV), uvcompare);
3223 for (j = 0; j < i; j++) {
3225 diff = val - nextmin;
3227 t = uvuni_to_utf8(tmpbuf,nextmin);
3228 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3230 U8 range_mark = UTF_TO_NATIVE(0xff);
3231 t = uvuni_to_utf8(tmpbuf, val - 1);
3232 sv_catpvn(transv, (char *)&range_mark, 1);
3233 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3240 t = uvuni_to_utf8(tmpbuf,nextmin);
3241 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3243 U8 range_mark = UTF_TO_NATIVE(0xff);
3244 sv_catpvn(transv, (char *)&range_mark, 1);
3246 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3247 UNICODE_ALLOW_SUPER);
3248 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3249 t = (const U8*)SvPVX_const(transv);
3250 tlen = SvCUR(transv);
3254 else if (!rlen && !del) {
3255 r = t; rlen = tlen; rend = tend;
3258 if ((!rlen && !del) || t == r ||
3259 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3261 o->op_private |= OPpTRANS_IDENTICAL;
3265 while (t < tend || tfirst <= tlast) {
3266 /* see if we need more "t" chars */
3267 if (tfirst > tlast) {
3268 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3270 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3272 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3279 /* now see if we need more "r" chars */
3280 if (rfirst > rlast) {
3282 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3284 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3286 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3295 rfirst = rlast = 0xffffffff;
3299 /* now see which range will peter our first, if either. */
3300 tdiff = tlast - tfirst;
3301 rdiff = rlast - rfirst;
3308 if (rfirst == 0xffffffff) {
3309 diff = tdiff; /* oops, pretend rdiff is infinite */
3311 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3312 (long)tfirst, (long)tlast);
3314 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3318 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3319 (long)tfirst, (long)(tfirst + diff),
3322 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3323 (long)tfirst, (long)rfirst);
3325 if (rfirst + diff > max)
3326 max = rfirst + diff;
3328 grows = (tfirst < rfirst &&
3329 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3341 else if (max > 0xff)
3346 PerlMemShared_free(cPVOPo->op_pv);
3347 cPVOPo->op_pv = NULL;
3349 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3351 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3352 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3353 PAD_SETSV(cPADOPo->op_padix, swash);
3356 cSVOPo->op_sv = swash;
3358 SvREFCNT_dec(listsv);
3359 SvREFCNT_dec(transv);
3361 if (!del && havefinal && rlen)
3362 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3363 newSVuv((UV)final), 0);
3366 o->op_private |= OPpTRANS_GROWS;
3372 op_getmad(expr,o,'e');
3373 op_getmad(repl,o,'r');
3381 tbl = (short*)cPVOPo->op_pv;
3383 Zero(tbl, 256, short);
3384 for (i = 0; i < (I32)tlen; i++)
3386 for (i = 0, j = 0; i < 256; i++) {
3388 if (j >= (I32)rlen) {
3397 if (i < 128 && r[j] >= 128)
3407 o->op_private |= OPpTRANS_IDENTICAL;
3409 else if (j >= (I32)rlen)
3414 PerlMemShared_realloc(tbl,
3415 (0x101+rlen-j) * sizeof(short));
3416 cPVOPo->op_pv = (char*)tbl;
3418 tbl[0x100] = (short)(rlen - j);
3419 for (i=0; i < (I32)rlen - j; i++)
3420 tbl[0x101+i] = r[j+i];
3424 if (!rlen && !del) {
3427 o->op_private |= OPpTRANS_IDENTICAL;
3429 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3430 o->op_private |= OPpTRANS_IDENTICAL;
3432 for (i = 0; i < 256; i++)
3434 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3435 if (j >= (I32)rlen) {
3437 if (tbl[t[i]] == -1)
3443 if (tbl[t[i]] == -1) {
3444 if (t[i] < 128 && r[j] >= 128)
3451 if(ckWARN(WARN_MISC)) {
3452 if(del && rlen == tlen) {
3453 Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3454 } else if(rlen > tlen) {
3455 Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3460 o->op_private |= OPpTRANS_GROWS;
3462 op_getmad(expr,o,'e');
3463 op_getmad(repl,o,'r');
3473 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3478 NewOp(1101, pmop, 1, PMOP);
3479 pmop->op_type = (OPCODE)type;
3480 pmop->op_ppaddr = PL_ppaddr[type];
3481 pmop->op_flags = (U8)flags;
3482 pmop->op_private = (U8)(0 | (flags >> 8));
3484 if (PL_hints & HINT_RE_TAINT)
3485 pmop->op_pmflags |= PMf_RETAINT;
3486 if (PL_hints & HINT_LOCALE)
3487 pmop->op_pmflags |= PMf_LOCALE;
3491 assert(SvPOK(PL_regex_pad[0]));
3492 if (SvCUR(PL_regex_pad[0])) {
3493 /* Pop off the "packed" IV from the end. */
3494 SV *const repointer_list = PL_regex_pad[0];
3495 const char *p = SvEND(repointer_list) - sizeof(IV);
3496 const IV offset = *((IV*)p);
3498 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3500 SvEND_set(repointer_list, p);
3502 pmop->op_pmoffset = offset;
3503 /* This slot should be free, so assert this: */
3504 assert(PL_regex_pad[offset] == &PL_sv_undef);
3506 SV * const repointer = &PL_sv_undef;
3507 av_push(PL_regex_padav, repointer);
3508 pmop->op_pmoffset = av_len(PL_regex_padav);
3509 PL_regex_pad = AvARRAY(PL_regex_padav);
3513 return CHECKOP(type, pmop);
3516 /* Given some sort of match op o, and an expression expr containing a
3517 * pattern, either compile expr into a regex and attach it to o (if it's
3518 * constant), or convert expr into a runtime regcomp op sequence (if it's
3521 * isreg indicates that the pattern is part of a regex construct, eg
3522 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3523 * split "pattern", which aren't. In the former case, expr will be a list
3524 * if the pattern contains more than one term (eg /a$b/) or if it contains
3525 * a replacement, ie s/// or tr///.
3529 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3534 I32 repl_has_vars = 0;
3538 PERL_ARGS_ASSERT_PMRUNTIME;
3540 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3541 /* last element in list is the replacement; pop it */
3543 repl = cLISTOPx(expr)->op_last;
3544 kid = cLISTOPx(expr)->op_first;
3545 while (kid->op_sibling != repl)
3546 kid = kid->op_sibling;
3547 kid->op_sibling = NULL;
3548 cLISTOPx(expr)->op_last = kid;
3551 if (isreg && expr->op_type == OP_LIST &&
3552 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3554 /* convert single element list to element */
3555 OP* const oe = expr;
3556 expr = cLISTOPx(oe)->op_first->op_sibling;
3557 cLISTOPx(oe)->op_first->op_sibling = NULL;
3558 cLISTOPx(oe)->op_last = NULL;
3562 if (o->op_type == OP_TRANS) {
3563 return pmtrans(o, expr, repl);
3566 reglist = isreg && expr->op_type == OP_LIST;
3570 PL_hints |= HINT_BLOCK_SCOPE;
3573 if (expr->op_type == OP_CONST) {
3574 SV *pat = ((SVOP*)expr)->op_sv;
3575 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3577 if (o->op_flags & OPf_SPECIAL)
3578 pm_flags |= RXf_SPLIT;
3581 assert (SvUTF8(pat));
3582 } else if (SvUTF8(pat)) {
3583 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3584 trapped in use 'bytes'? */
3585 /* Make a copy of the octet sequence, but without the flag on, as
3586 the compiler now honours the SvUTF8 flag on pat. */
3588 const char *const p = SvPV(pat, len);
3589 pat = newSVpvn_flags(p, len, SVs_TEMP);
3592 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3595 op_getmad(expr,(OP*)pm,'e');
3601 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3602 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3604 : OP_REGCMAYBE),0,expr);
3606 NewOp(1101, rcop, 1, LOGOP);
3607 rcop->op_type = OP_REGCOMP;
3608 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3609 rcop->op_first = scalar(expr);
3610 rcop->op_flags |= OPf_KIDS
3611 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3612 | (reglist ? OPf_STACKED : 0);
3613 rcop->op_private = 1;
3616 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3618 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3621 /* establish postfix order */
3622 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3624 rcop->op_next = expr;
3625 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3628 rcop->op_next = LINKLIST(expr);
3629 expr->op_next = (OP*)rcop;
3632 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3637 if (pm->op_pmflags & PMf_EVAL) {
3639 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3640 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3642 else if (repl->op_type == OP_CONST)
3646 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3647 if (curop->op_type == OP_SCOPE
3648 || curop->op_type == OP_LEAVE
3649 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3650 if (curop->op_type == OP_GV) {
3651 GV * const gv = cGVOPx_gv(curop);
3653 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3656 else if (curop->op_type == OP_RV2CV)
3658 else if (curop->op_type == OP_RV2SV ||
3659 curop->op_type == OP_RV2AV ||
3660 curop->op_type == OP_RV2HV ||
3661 curop->op_type == OP_RV2GV) {
3662 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3665 else if (curop->op_type == OP_PADSV ||
3666 curop->op_type == OP_PADAV ||
3667 curop->op_type == OP_PADHV ||
3668 curop->op_type == OP_PADANY)
3672 else if (curop->op_type == OP_PUSHRE)
3673 NOOP; /* Okay here, dangerous in newASSIGNOP */
3683 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3685 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3686 prepend_elem(o->op_type, scalar(repl), o);
3689 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3690 pm->op_pmflags |= PMf_MAYBE_CONST;
3692 NewOp(1101, rcop, 1, LOGOP);
3693 rcop->op_type = OP_SUBSTCONT;
3694 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3695 rcop->op_first = scalar(repl);
3696 rcop->op_flags |= OPf_KIDS;
3697 rcop->op_private = 1;
3700 /* establish postfix order */
3701 rcop->op_next = LINKLIST(repl);
3702 repl->op_next = (OP*)rcop;
3704 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3705 assert(!(pm->op_pmflags & PMf_ONCE));
3706 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3715 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3720 PERL_ARGS_ASSERT_NEWSVOP;
3722 NewOp(1101, svop, 1, SVOP);
3723 svop->op_type = (OPCODE)type;
3724 svop->op_ppaddr = PL_ppaddr[type];
3726 svop->op_next = (OP*)svop;
3727 svop->op_flags = (U8)flags;
3728 if (PL_opargs[type] & OA_RETSCALAR)
3730 if (PL_opargs[type] & OA_TARGET)
3731 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3732 return CHECKOP(type, svop);
3737 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3742 PERL_ARGS_ASSERT_NEWPADOP;
3744 NewOp(1101, padop, 1, PADOP);
3745 padop->op_type = (OPCODE)type;
3746 padop->op_ppaddr = PL_ppaddr[type];
3747 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3748 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3749 PAD_SETSV(padop->op_padix, sv);
3752 padop->op_next = (OP*)padop;
3753 padop->op_flags = (U8)flags;
3754 if (PL_opargs[type] & OA_RETSCALAR)
3756 if (PL_opargs[type] & OA_TARGET)
3757 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3758 return CHECKOP(type, padop);
3763 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3767 PERL_ARGS_ASSERT_NEWGVOP;
3771 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3773 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3778 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3782 NewOp(1101, pvop, 1, PVOP);
3783 pvop->op_type = (OPCODE)type;
3784 pvop->op_ppaddr = PL_ppaddr[type];
3786 pvop->op_next = (OP*)pvop;
3787 pvop->op_flags = (U8)flags;
3788 if (PL_opargs[type] & OA_RETSCALAR)
3790 if (PL_opargs[type] & OA_TARGET)
3791 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3792 return CHECKOP(type, pvop);
3800 Perl_package(pTHX_ OP *o)
3803 SV *const sv = cSVOPo->op_sv;
3808 PERL_ARGS_ASSERT_PACKAGE;
3810 save_hptr(&PL_curstash);
3811 save_item(PL_curstname);
3813 PL_curstash = gv_stashsv(sv, GV_ADD);
3815 sv_setsv(PL_curstname, sv);
3817 PL_hints |= HINT_BLOCK_SCOPE;
3818 PL_parser->copline = NOLINE;
3819 PL_parser->expect = XSTATE;
3824 if (!PL_madskills) {
3829 pegop = newOP(OP_NULL,0);
3830 op_getmad(o,pegop,'P');
3840 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3847 OP *pegop = newOP(OP_NULL,0);
3850 PERL_ARGS_ASSERT_UTILIZE;
3852 if (idop->op_type != OP_CONST)
3853 Perl_croak(aTHX_ "Module name must be constant");
3856 op_getmad(idop,pegop,'U');
3861 SV * const vesv = ((SVOP*)version)->op_sv;
3864 op_getmad(version,pegop,'V');
3865 if (!arg && !SvNIOKp(vesv)) {
3872 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3873 Perl_croak(aTHX_ "Version number must be constant number");
3875 /* Make copy of idop so we don't free it twice */
3876 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3878 /* Fake up a method call to VERSION */
3879 meth = newSVpvs_share("VERSION");
3880 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3881 append_elem(OP_LIST,
3882 prepend_elem(OP_LIST, pack, list(version)),
3883 newSVOP(OP_METHOD_NAMED, 0, meth)));
3887 /* Fake up an import/unimport */
3888 if (arg && arg->op_type == OP_STUB) {
3890 op_getmad(arg,pegop,'S');
3891 imop = arg; /* no import on explicit () */
3893 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3894 imop = NULL; /* use 5.0; */
3896 idop->op_private |= OPpCONST_NOVER;
3902 op_getmad(arg,pegop,'A');
3904 /* Make copy of idop so we don't free it twice */
3905 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3907 /* Fake up a method call to import/unimport */
3909 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3910 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3911 append_elem(OP_LIST,
3912 prepend_elem(OP_LIST, pack, list(arg)),
3913 newSVOP(OP_METHOD_NAMED, 0, meth)));
3916 /* Fake up the BEGIN {}, which does its thing immediately. */
3918 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3921 append_elem(OP_LINESEQ,
3922 append_elem(OP_LINESEQ,
3923 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3924 newSTATEOP(0, NULL, veop)),
3925 newSTATEOP(0, NULL, imop) ));
3927 /* The "did you use incorrect case?" warning used to be here.
3928 * The problem is that on case-insensitive filesystems one
3929 * might get false positives for "use" (and "require"):
3930 * "use Strict" or "require CARP" will work. This causes
3931 * portability problems for the script: in case-strict
3932 * filesystems the script will stop working.
3934 * The "incorrect case" warning checked whether "use Foo"
3935 * imported "Foo" to your namespace, but that is wrong, too:
3936 * there is no requirement nor promise in the language that
3937 * a Foo.pm should or would contain anything in package "Foo".
3939 * There is very little Configure-wise that can be done, either:
3940 * the case-sensitivity of the build filesystem of Perl does not
3941 * help in guessing the case-sensitivity of the runtime environment.
3944 PL_hints |= HINT_BLOCK_SCOPE;
3945 PL_parser->copline = NOLINE;
3946 PL_parser->expect = XSTATE;
3947 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3950 if (!PL_madskills) {
3951 /* FIXME - don't allocate pegop if !PL_madskills */
3960 =head1 Embedding Functions
3962 =for apidoc load_module
3964 Loads the module whose name is pointed to by the string part of name.
3965 Note that the actual module name, not its filename, should be given.
3966 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3967 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3968 (or 0 for no flags). ver, if specified, provides version semantics
3969 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3970 arguments can be used to specify arguments to the module's import()
3971 method, similar to C<use Foo::Bar VERSION LIST>.
3976 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3980 PERL_ARGS_ASSERT_LOAD_MODULE;
3982 va_start(args, ver);
3983 vload_module(flags, name, ver, &args);
3987 #ifdef PERL_IMPLICIT_CONTEXT
3989 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3993 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3994 va_start(args, ver);
3995 vload_module(flags, name, ver, &args);
4001 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4005 OP * const modname = newSVOP(OP_CONST, 0, name);
4007 PERL_ARGS_ASSERT_VLOAD_MODULE;
4009 modname->op_private |= OPpCONST_BARE;
4011 veop = newSVOP(OP_CONST, 0, ver);
4015 if (flags & PERL_LOADMOD_NOIMPORT) {
4016 imop = sawparens(newNULLLIST());
4018 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4019 imop = va_arg(*args, OP*);
4024 sv = va_arg(*args, SV*);
4026 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4027 sv = va_arg(*args, SV*);
4031 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4032 * that it has a PL_parser to play with while doing that, and also
4033 * that it doesn't mess with any existing parser, by creating a tmp
4034 * new parser with lex_start(). This won't actually be used for much,
4035 * since pp_require() will create another parser for the real work. */
4038 SAVEVPTR(PL_curcop);
4039 lex_start(NULL, NULL, FALSE);
4040 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4041 veop, modname, imop);
4046 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4052 PERL_ARGS_ASSERT_DOFILE;
4054 if (!force_builtin) {
4055 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4056 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4057 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4058 gv = gvp ? *gvp : NULL;
4062 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4063 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4064 append_elem(OP_LIST, term,
4065 scalar(newUNOP(OP_RV2CV, 0,
4066 newGVOP(OP_GV, 0, gv))))));
4069 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4075 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4077 return newBINOP(OP_LSLICE, flags,
4078 list(force_list(subscript)),
4079 list(force_list(listval)) );
4083 S_is_list_assignment(pTHX_ register const OP *o)
4091 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4092 o = cUNOPo->op_first;
4094 flags = o->op_flags;
4096 if (type == OP_COND_EXPR) {
4097 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4098 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4103 yyerror("Assignment to both a list and a scalar");
4107 if (type == OP_LIST &&
4108 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4109 o->op_private & OPpLVAL_INTRO)
4112 if (type == OP_LIST || flags & OPf_PARENS ||
4113 type == OP_RV2AV || type == OP_RV2HV ||
4114 type == OP_ASLICE || type == OP_HSLICE)
4117 if (type == OP_PADAV || type == OP_PADHV)
4120 if (type == OP_RV2SV)
4127 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4133 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4134 return newLOGOP(optype, 0,
4135 mod(scalar(left), optype),
4136 newUNOP(OP_SASSIGN, 0, scalar(right)));
4139 return newBINOP(optype, OPf_STACKED,
4140 mod(scalar(left), optype), scalar(right));
4144 if (is_list_assignment(left)) {
4145 static const char no_list_state[] = "Initialization of state variables"
4146 " in list context currently forbidden";
4148 bool maybe_common_vars = TRUE;
4151 /* Grandfathering $[ assignment here. Bletch.*/
4152 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4153 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4154 left = mod(left, OP_AASSIGN);
4157 else if (left->op_type == OP_CONST) {
4159 /* Result of assignment is always 1 (or we'd be dead already) */
4160 return newSVOP(OP_CONST, 0, newSViv(1));
4162 curop = list(force_list(left));
4163 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4164 o->op_private = (U8)(0 | (flags >> 8));
4166 if ((left->op_type == OP_LIST
4167 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4169 OP* lop = ((LISTOP*)left)->op_first;
4170 maybe_common_vars = FALSE;
4172 if (lop->op_type == OP_PADSV ||
4173 lop->op_type == OP_PADAV ||
4174 lop->op_type == OP_PADHV ||
4175 lop->op_type == OP_PADANY) {
4176 if (!(lop->op_private & OPpLVAL_INTRO))
4177 maybe_common_vars = TRUE;
4179 if (lop->op_private & OPpPAD_STATE) {
4180 if (left->op_private & OPpLVAL_INTRO) {
4181 /* Each variable in state($a, $b, $c) = ... */
4184 /* Each state variable in
4185 (state $a, my $b, our $c, $d, undef) = ... */
4187 yyerror(no_list_state);
4189 /* Each my variable in
4190 (state $a, my $b, our $c, $d, undef) = ... */
4192 } else if (lop->op_type == OP_UNDEF ||
4193 lop->op_type == OP_PUSHMARK) {
4194 /* undef may be interesting in
4195 (state $a, undef, state $c) */
4197 /* Other ops in the list. */
4198 maybe_common_vars = TRUE;
4200 lop = lop->op_sibling;
4203 else if ((left->op_private & OPpLVAL_INTRO)
4204 && ( left->op_type == OP_PADSV
4205 || left->op_type == OP_PADAV
4206 || left->op_type == OP_PADHV
4207 || left->op_type == OP_PADANY))
4209 maybe_common_vars = FALSE;
4210 if (left->op_private & OPpPAD_STATE) {
4211 /* All single variable list context state assignments, hence
4221 yyerror(no_list_state);
4225 /* PL_generation sorcery:
4226 * an assignment like ($a,$b) = ($c,$d) is easier than
4227 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4228 * To detect whether there are common vars, the global var
4229 * PL_generation is incremented for each assign op we compile.
4230 * Then, while compiling the assign op, we run through all the
4231 * variables on both sides of the assignment, setting a spare slot
4232 * in each of them to PL_generation. If any of them already have
4233 * that value, we know we've got commonality. We could use a
4234 * single bit marker, but then we'd have to make 2 passes, first
4235 * to clear the flag, then to test and set it. To find somewhere
4236 * to store these values, evil chicanery is done with SvUVX().
4239 if (maybe_common_vars) {
4242 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4243 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4244 if (curop->op_type == OP_GV) {
4245 GV *gv = cGVOPx_gv(curop);
4247 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4249 GvASSIGN_GENERATION_set(gv, PL_generation);
4251 else if (curop->op_type == OP_PADSV ||
4252 curop->op_type == OP_PADAV ||
4253 curop->op_type == OP_PADHV ||
4254 curop->op_type == OP_PADANY)
4256 if (PAD_COMPNAME_GEN(curop->op_targ)
4257 == (STRLEN)PL_generation)
4259 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4262 else if (curop->op_type == OP_RV2CV)
4264 else if (curop->op_type == OP_RV2SV ||
4265 curop->op_type == OP_RV2AV ||
4266 curop->op_type == OP_RV2HV ||
4267 curop->op_type == OP_RV2GV) {
4268 if (lastop->op_type != OP_GV) /* funny deref? */
4271 else if (curop->op_type == OP_PUSHRE) {
4273 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4274 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4276 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4278 GvASSIGN_GENERATION_set(gv, PL_generation);
4282 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4285 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4287 GvASSIGN_GENERATION_set(gv, PL_generation);
4297 o->op_private |= OPpASSIGN_COMMON;
4300 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4301 OP* tmpop = ((LISTOP*)right)->op_first;
4302 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4303 PMOP * const pm = (PMOP*)tmpop;
4304 if (left->op_type == OP_RV2AV &&
4305 !(left->op_private & OPpLVAL_INTRO) &&
4306 !(o->op_private & OPpASSIGN_COMMON) )
4308 tmpop = ((UNOP*)left)->op_first;
4309 if (tmpop->op_type == OP_GV
4311 && !pm->op_pmreplrootu.op_pmtargetoff
4313 && !pm->op_pmreplrootu.op_pmtargetgv
4317 pm->op_pmreplrootu.op_pmtargetoff
4318 = cPADOPx(tmpop)->op_padix;
4319 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4321 pm->op_pmreplrootu.op_pmtargetgv
4322 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4323 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4325 pm->op_pmflags |= PMf_ONCE;
4326 tmpop = cUNOPo->op_first; /* to list (nulled) */
4327 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4328 tmpop->op_sibling = NULL; /* don't free split */
4329 right->op_next = tmpop->op_next; /* fix starting loc */
4330 op_free(o); /* blow off assign */
4331 right->op_flags &= ~OPf_WANT;
4332 /* "I don't know and I don't care." */
4337 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4338 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4340 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4342 sv_setiv(sv, PL_modcount+1);
4350 right = newOP(OP_UNDEF, 0);
4351 if (right->op_type == OP_READLINE) {
4352 right->op_flags |= OPf_STACKED;
4353 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4356 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4357 o = newBINOP(OP_SASSIGN, flags,
4358 scalar(right), mod(scalar(left), OP_SASSIGN) );
4362 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4364 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4365 o->op_private |= OPpCONST_ARYBASE;
4373 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4376 const U32 seq = intro_my();
4379 NewOp(1101, cop, 1, COP);
4380 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4381 cop->op_type = OP_DBSTATE;
4382 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4385 cop->op_type = OP_NEXTSTATE;
4386 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4388 cop->op_flags = (U8)flags;
4389 CopHINTS_set(cop, PL_hints);
4391 cop->op_private |= NATIVE_HINTS;
4393 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4394 cop->op_next = (OP*)cop;
4397 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4398 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4400 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4401 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4402 if (cop->cop_hints_hash) {
4404 cop->cop_hints_hash->refcounted_he_refcnt++;
4405 HINTS_REFCNT_UNLOCK;
4409 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4411 PL_hints |= HINT_BLOCK_SCOPE;
4412 /* It seems that we need to defer freeing this pointer, as other parts
4413 of the grammar end up wanting to copy it after this op has been
4418 if (PL_parser && PL_parser->copline == NOLINE)
4419 CopLINE_set(cop, CopLINE(PL_curcop));
4421 CopLINE_set(cop, PL_parser->copline);
4423 PL_parser->copline = NOLINE;
4426 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4428 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4430 CopSTASH_set(cop, PL_curstash);
4432 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4433 /* this line can have a breakpoint - store the cop in IV */
4434 AV *av = CopFILEAVx(PL_curcop);
4436 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4437 if (svp && *svp != &PL_sv_undef ) {
4438 (void)SvIOK_on(*svp);
4439 SvIV_set(*svp, PTR2IV(cop));
4444 if (flags & OPf_SPECIAL)
4446 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4451 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4455 PERL_ARGS_ASSERT_NEWLOGOP;
4457 return new_logop(type, flags, &first, &other);
4461 S_search_const(pTHX_ OP *o)
4463 PERL_ARGS_ASSERT_SEARCH_CONST;
4465 switch (o->op_type) {
4469 if (o->op_flags & OPf_KIDS)
4470 return search_const(cUNOPo->op_first);
4477 if (!(o->op_flags & OPf_KIDS))
4479 kid = cLISTOPo->op_first;
4481 switch (kid->op_type) {
4485 kid = kid->op_sibling;
4488 if (kid != cLISTOPo->op_last)
4494 kid = cLISTOPo->op_last;
4496 return search_const(kid);
4504 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4512 int prepend_not = 0;
4514 PERL_ARGS_ASSERT_NEW_LOGOP;
4519 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4520 return newBINOP(type, flags, scalar(first), scalar(other));
4522 scalarboolean(first);
4523 /* optimize AND and OR ops that have NOTs as children */
4524 if (first->op_type == OP_NOT
4525 && (first->op_flags & OPf_KIDS)
4526 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4527 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4529 if (type == OP_AND || type == OP_OR) {
4535 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4537 prepend_not = 1; /* prepend a NOT op later */
4541 /* search for a constant op that could let us fold the test */
4542 if ((cstop = search_const(first))) {
4543 if (cstop->op_private & OPpCONST_STRICT)
4544 no_bareword_allowed(cstop);
4545 else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4546 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4547 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4548 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4549 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4551 if (other->op_type == OP_CONST)
4552 other->op_private |= OPpCONST_SHORTCIRCUIT;
4554 OP *newop = newUNOP(OP_NULL, 0, other);
4555 op_getmad(first, newop, '1');
4556 newop->op_targ = type; /* set "was" field */
4563 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4564 const OP *o2 = other;
4565 if ( ! (o2->op_type == OP_LIST
4566 && (( o2 = cUNOPx(o2)->op_first))
4567 && o2->op_type == OP_PUSHMARK
4568 && (( o2 = o2->op_sibling)) )
4571 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4572 || o2->op_type == OP_PADHV)
4573 && o2->op_private & OPpLVAL_INTRO
4574 && !(o2->op_private & OPpPAD_STATE)
4575 && ckWARN(WARN_DEPRECATED))
4577 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4578 "Deprecated use of my() in false conditional");
4582 if (first->op_type == OP_CONST)
4583 first->op_private |= OPpCONST_SHORTCIRCUIT;
4585 first = newUNOP(OP_NULL, 0, first);
4586 op_getmad(other, first, '2');
4587 first->op_targ = type; /* set "was" field */
4594 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4595 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4597 const OP * const k1 = ((UNOP*)first)->op_first;
4598 const OP * const k2 = k1->op_sibling;
4600 switch (first->op_type)
4603 if (k2 && k2->op_type == OP_READLINE
4604 && (k2->op_flags & OPf_STACKED)
4605 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4607 warnop = k2->op_type;
4612 if (k1->op_type == OP_READDIR
4613 || k1->op_type == OP_GLOB
4614 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4615 || k1->op_type == OP_EACH)
4617 warnop = ((k1->op_type == OP_NULL)
4618 ? (OPCODE)k1->op_targ : k1->op_type);
4623 const line_t oldline = CopLINE(PL_curcop);
4624 CopLINE_set(PL_curcop, PL_parser->copline);
4625 Perl_warner(aTHX_ packWARN(WARN_MISC),
4626 "Value of %s%s can be \"0\"; test with defined()",
4628 ((warnop == OP_READLINE || warnop == OP_GLOB)
4629 ? " construct" : "() operator"));
4630 CopLINE_set(PL_curcop, oldline);
4637 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4638 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4640 NewOp(1101, logop, 1, LOGOP);
4642 logop->op_type = (OPCODE)type;
4643 logop->op_ppaddr = PL_ppaddr[type];
4644 logop->op_first = first;
4645 logop->op_flags = (U8)(flags | OPf_KIDS);
4646 logop->op_other = LINKLIST(other);
4647 logop->op_private = (U8)(1 | (flags >> 8));
4649 /* establish postfix order */
4650 logop->op_next = LINKLIST(first);
4651 first->op_next = (OP*)logop;
4652 first->op_sibling = other;
4654 CHECKOP(type,logop);
4656 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4663 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4671 PERL_ARGS_ASSERT_NEWCONDOP;
4674 return newLOGOP(OP_AND, 0, first, trueop);
4676 return newLOGOP(OP_OR, 0, first, falseop);
4678 scalarboolean(first);
4679 if ((cstop = search_const(first))) {
4680 /* Left or right arm of the conditional? */
4681 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4682 OP *live = left ? trueop : falseop;
4683 OP *const dead = left ? falseop : trueop;
4684 if (cstop->op_private & OPpCONST_BARE &&
4685 cstop->op_private & OPpCONST_STRICT) {
4686 no_bareword_allowed(cstop);
4689 /* This is all dead code when PERL_MAD is not defined. */
4690 live = newUNOP(OP_NULL, 0, live);
4691 op_getmad(first, live, 'C');
4692 op_getmad(dead, live, left ? 'e' : 't');
4699 NewOp(1101, logop, 1, LOGOP);
4700 logop->op_type = OP_COND_EXPR;
4701 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4702 logop->op_first = first;
4703 logop->op_flags = (U8)(flags | OPf_KIDS);
4704 logop->op_private = (U8)(1 | (flags >> 8));
4705 logop->op_other = LINKLIST(trueop);
4706 logop->op_next = LINKLIST(falseop);
4708 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4711 /* establish postfix order */
4712 start = LINKLIST(first);
4713 first->op_next = (OP*)logop;
4715 first->op_sibling = trueop;
4716 trueop->op_sibling = falseop;
4717 o = newUNOP(OP_NULL, 0, (OP*)logop);
4719 trueop->op_next = falseop->op_next = o;
4726 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4735 PERL_ARGS_ASSERT_NEWRANGE;
4737 NewOp(1101, range, 1, LOGOP);
4739 range->op_type = OP_RANGE;
4740 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4741 range->op_first = left;
4742 range->op_flags = OPf_KIDS;
4743 leftstart = LINKLIST(left);
4744 range->op_other = LINKLIST(right);
4745 range->op_private = (U8)(1 | (flags >> 8));
4747 left->op_sibling = right;
4749 range->op_next = (OP*)range;
4750 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4751 flop = newUNOP(OP_FLOP, 0, flip);
4752 o = newUNOP(OP_NULL, 0, flop);
4754 range->op_next = leftstart;
4756 left->op_next = flip;
4757 right->op_next = flop;
4759 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4760 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4761 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4762 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4764 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4765 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4768 if (!flip->op_private || !flop->op_private)
4769 linklist(o); /* blow off optimizer unless constant */
4775 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4780 const bool once = block && block->op_flags & OPf_SPECIAL &&
4781 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4783 PERL_UNUSED_ARG(debuggable);
4786 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4787 return block; /* do {} while 0 does once */
4788 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4789 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4790 expr = newUNOP(OP_DEFINED, 0,
4791 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4792 } else if (expr->op_flags & OPf_KIDS) {
4793 const OP * const k1 = ((UNOP*)expr)->op_first;
4794 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4795 switch (expr->op_type) {
4797 if (k2 && k2->op_type == OP_READLINE
4798 && (k2->op_flags & OPf_STACKED)
4799 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4800 expr = newUNOP(OP_DEFINED, 0, expr);
4804 if (k1 && (k1->op_type == OP_READDIR
4805 || k1->op_type == OP_GLOB
4806 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4807 || k1->op_type == OP_EACH))
4808 expr = newUNOP(OP_DEFINED, 0, expr);
4814 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4815 * op, in listop. This is wrong. [perl #27024] */
4817 block = newOP(OP_NULL, 0);
4818 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4819 o = new_logop(OP_AND, 0, &expr, &listop);
4822 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4824 if (once && o != listop)
4825 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4828 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4830 o->op_flags |= flags;
4832 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4837 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4838 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4847 PERL_UNUSED_ARG(debuggable);
4850 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4851 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4852 expr = newUNOP(OP_DEFINED, 0,
4853 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4854 } else if (expr->op_flags & OPf_KIDS) {
4855 const OP * const k1 = ((UNOP*)expr)->op_first;
4856 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4857 switch (expr->op_type) {
4859 if (k2 && k2->op_type == OP_READLINE
4860 && (k2->op_flags & OPf_STACKED)
4861 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4862 expr = newUNOP(OP_DEFINED, 0, expr);
4866 if (k1 && (k1->op_type == OP_READDIR
4867 || k1->op_type == OP_GLOB
4868 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4869 || k1->op_type == OP_EACH))
4870 expr = newUNOP(OP_DEFINED, 0, expr);
4877 block = newOP(OP_NULL, 0);
4878 else if (cont || has_my) {
4879 block = scope(block);
4883 next = LINKLIST(cont);
4886 OP * const unstack = newOP(OP_UNSTACK, 0);
4889 cont = append_elem(OP_LINESEQ, cont, unstack);
4893 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4895 redo = LINKLIST(listop);
4898 PL_parser->copline = (line_t)whileline;
4900 o = new_logop(OP_AND, 0, &expr, &listop);
4901 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4902 op_free(expr); /* oops, it's a while (0) */
4904 return NULL; /* listop already freed by new_logop */
4907 ((LISTOP*)listop)->op_last->op_next =
4908 (o == listop ? redo : LINKLIST(o));
4914 NewOp(1101,loop,1,LOOP);
4915 loop->op_type = OP_ENTERLOOP;
4916 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4917 loop->op_private = 0;
4918 loop->op_next = (OP*)loop;
4921 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4923 loop->op_redoop = redo;
4924 loop->op_lastop = o;
4925 o->op_private |= loopflags;
4928 loop->op_nextop = next;
4930 loop->op_nextop = o;
4932 o->op_flags |= flags;
4933 o->op_private |= (flags >> 8);
4938 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4943 PADOFFSET padoff = 0;
4948 PERL_ARGS_ASSERT_NEWFOROP;
4951 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4952 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4953 sv->op_type = OP_RV2GV;
4954 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4956 /* The op_type check is needed to prevent a possible segfault
4957 * if the loop variable is undeclared and 'strict vars' is in
4958 * effect. This is illegal but is nonetheless parsed, so we
4959 * may reach this point with an OP_CONST where we're expecting
4962 if (cUNOPx(sv)->op_first->op_type == OP_GV
4963 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4964 iterpflags |= OPpITER_DEF;
4966 else if (sv->op_type == OP_PADSV) { /* private variable */
4967 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4968 padoff = sv->op_targ;
4978 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4980 SV *const namesv = PAD_COMPNAME_SV(padoff);
4982 const char *const name = SvPV_const(namesv, len);
4984 if (len == 2 && name[0] == '$' && name[1] == '_')
4985 iterpflags |= OPpITER_DEF;
4989 const PADOFFSET offset = pad_findmy("$_");
4990 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4991 sv = newGVOP(OP_GV, 0, PL_defgv);
4996 iterpflags |= OPpITER_DEF;
4998 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4999 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5000 iterflags |= OPf_STACKED;
5002 else if (expr->op_type == OP_NULL &&
5003 (expr->op_flags & OPf_KIDS) &&
5004 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5006 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5007 * set the STACKED flag to indicate that these values are to be
5008 * treated as min/max values by 'pp_iterinit'.
5010 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5011 LOGOP* const range = (LOGOP*) flip->op_first;
5012 OP* const left = range->op_first;
5013 OP* const right = left->op_sibling;
5016 range->op_flags &= ~OPf_KIDS;
5017 range->op_first = NULL;
5019 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5020 listop->op_first->op_next = range->op_next;
5021 left->op_next = range->op_other;
5022 right->op_next = (OP*)listop;
5023 listop->op_next = listop->op_first;
5026 op_getmad(expr,(OP*)listop,'O');
5030 expr = (OP*)(listop);
5032 iterflags |= OPf_STACKED;
5035 expr = mod(force_list(expr), OP_GREPSTART);
5038 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5039 append_elem(OP_LIST, expr, scalar(sv))));
5040 assert(!loop->op_next);
5041 /* for my $x () sets OPpLVAL_INTRO;
5042 * for our $x () sets OPpOUR_INTRO */
5043 loop->op_private = (U8)iterpflags;
5044 #ifdef PL_OP_SLAB_ALLOC
5047 NewOp(1234,tmp,1,LOOP);
5048 Copy(loop,tmp,1,LISTOP);
5049 S_op_destroy(aTHX_ (OP*)loop);
5053 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5055 loop->op_targ = padoff;
5056 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5058 op_getmad(madsv, (OP*)loop, 'v');
5059 PL_parser->copline = forline;
5060 return newSTATEOP(0, label, wop);
5064 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5069 PERL_ARGS_ASSERT_NEWLOOPEX;
5071 if (type != OP_GOTO || label->op_type == OP_CONST) {
5072 /* "last()" means "last" */
5073 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5074 o = newOP(type, OPf_SPECIAL);
5076 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5077 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5081 op_getmad(label,o,'L');
5087 /* Check whether it's going to be a goto &function */
5088 if (label->op_type == OP_ENTERSUB
5089 && !(label->op_flags & OPf_STACKED))
5090 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5091 o = newUNOP(type, OPf_STACKED, label);
5093 PL_hints |= HINT_BLOCK_SCOPE;
5097 /* if the condition is a literal array or hash
5098 (or @{ ... } etc), make a reference to it.
5101 S_ref_array_or_hash(pTHX_ OP *cond)
5104 && (cond->op_type == OP_RV2AV
5105 || cond->op_type == OP_PADAV
5106 || cond->op_type == OP_RV2HV
5107 || cond->op_type == OP_PADHV))
5109 return newUNOP(OP_REFGEN,
5110 0, mod(cond, OP_REFGEN));
5116 /* These construct the optree fragments representing given()
5119 entergiven and enterwhen are LOGOPs; the op_other pointer
5120 points up to the associated leave op. We need this so we
5121 can put it in the context and make break/continue work.
5122 (Also, of course, pp_enterwhen will jump straight to
5123 op_other if the match fails.)
5127 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5128 I32 enter_opcode, I32 leave_opcode,
5129 PADOFFSET entertarg)
5135 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5137 NewOp(1101, enterop, 1, LOGOP);
5138 enterop->op_type = (Optype)enter_opcode;
5139 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5140 enterop->op_flags = (U8) OPf_KIDS;
5141 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5142 enterop->op_private = 0;
5144 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5147 enterop->op_first = scalar(cond);
5148 cond->op_sibling = block;
5150 o->op_next = LINKLIST(cond);
5151 cond->op_next = (OP *) enterop;
5154 /* This is a default {} block */
5155 enterop->op_first = block;
5156 enterop->op_flags |= OPf_SPECIAL;
5158 o->op_next = (OP *) enterop;
5161 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5162 entergiven and enterwhen both
5165 enterop->op_next = LINKLIST(block);
5166 block->op_next = enterop->op_other = o;
5171 /* Does this look like a boolean operation? For these purposes
5172 a boolean operation is:
5173 - a subroutine call [*]
5174 - a logical connective
5175 - a comparison operator
5176 - a filetest operator, with the exception of -s -M -A -C
5177 - defined(), exists() or eof()
5178 - /$re/ or $foo =~ /$re/
5180 [*] possibly surprising
5183 S_looks_like_bool(pTHX_ const OP *o)
5187 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5189 switch(o->op_type) {
5191 return looks_like_bool(cLOGOPo->op_first);
5195 looks_like_bool(cLOGOPo->op_first)
5196 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5200 o->op_flags & OPf_KIDS
5201 && looks_like_bool(cUNOPo->op_first));
5205 case OP_NOT: case OP_XOR:
5206 /* Note that OP_DOR is not here */
5208 case OP_EQ: case OP_NE: case OP_LT:
5209 case OP_GT: case OP_LE: case OP_GE:
5211 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5212 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5214 case OP_SEQ: case OP_SNE: case OP_SLT:
5215 case OP_SGT: case OP_SLE: case OP_SGE:
5219 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5220 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5221 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5222 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5223 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5224 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5225 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5226 case OP_FTTEXT: case OP_FTBINARY:
5228 case OP_DEFINED: case OP_EXISTS:
5229 case OP_MATCH: case OP_EOF:
5234 /* Detect comparisons that have been optimized away */
5235 if (cSVOPo->op_sv == &PL_sv_yes
5236 || cSVOPo->op_sv == &PL_sv_no)
5247 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5250 PERL_ARGS_ASSERT_NEWGIVENOP;
5251 return newGIVWHENOP(
5252 ref_array_or_hash(cond),
5254 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5258 /* If cond is null, this is a default {} block */
5260 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5262 const bool cond_llb = (!cond || looks_like_bool(cond));
5265 PERL_ARGS_ASSERT_NEWWHENOP;
5270 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5272 scalar(ref_array_or_hash(cond)));
5275 return newGIVWHENOP(
5277 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5278 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5282 =for apidoc cv_undef
5284 Clear out all the active components of a CV. This can happen either
5285 by an explicit C<undef &foo>, or by the reference count going to zero.
5286 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5287 children can still follow the full lexical scope chain.
5293 Perl_cv_undef(pTHX_ CV *cv)
5297 PERL_ARGS_ASSERT_CV_UNDEF;
5299 DEBUG_X(PerlIO_printf(Perl_debug_log,
5300 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5301 PTR2UV(cv), PTR2UV(PL_comppad))
5305 if (CvFILE(cv) && !CvISXSUB(cv)) {
5306 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5307 Safefree(CvFILE(cv));
5312 if (!CvISXSUB(cv) && CvROOT(cv)) {
5313 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5314 Perl_croak(aTHX_ "Can't undef active subroutine");
5317 PAD_SAVE_SETNULLPAD();
5319 op_free(CvROOT(cv));
5324 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5329 /* remove CvOUTSIDE unless this is an undef rather than a free */
5330 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5331 if (!CvWEAKOUTSIDE(cv))
5332 SvREFCNT_dec(CvOUTSIDE(cv));
5333 CvOUTSIDE(cv) = NULL;
5336 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5339 if (CvISXSUB(cv) && CvXSUB(cv)) {
5342 /* delete all flags except WEAKOUTSIDE */
5343 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5347 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5350 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5352 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5353 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5354 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5355 || (p && (len != SvCUR(cv) /* Not the same length. */
5356 || memNE(p, SvPVX_const(cv), len))))
5357 && ckWARN_d(WARN_PROTOTYPE)) {
5358 SV* const msg = sv_newmortal();
5362 gv_efullname3(name = sv_newmortal(), gv, NULL);
5363 sv_setpvs(msg, "Prototype mismatch:");
5365 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5367 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5369 sv_catpvs(msg, ": none");
5370 sv_catpvs(msg, " vs ");
5372 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5374 sv_catpvs(msg, "none");
5375 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5379 static void const_sv_xsub(pTHX_ CV* cv);
5383 =head1 Optree Manipulation Functions
5385 =for apidoc cv_const_sv
5387 If C<cv> is a constant sub eligible for inlining. returns the constant
5388 value returned by the sub. Otherwise, returns NULL.
5390 Constant subs can be created with C<newCONSTSUB> or as described in
5391 L<perlsub/"Constant Functions">.
5396 Perl_cv_const_sv(pTHX_ const CV *const cv)
5398 PERL_UNUSED_CONTEXT;
5401 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5403 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5406 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5407 * Can be called in 3 ways:
5410 * look for a single OP_CONST with attached value: return the value
5412 * cv && CvCLONE(cv) && !CvCONST(cv)
5414 * examine the clone prototype, and if contains only a single
5415 * OP_CONST referencing a pad const, or a single PADSV referencing
5416 * an outer lexical, return a non-zero value to indicate the CV is
5417 * a candidate for "constizing" at clone time
5421 * We have just cloned an anon prototype that was marked as a const
5422 * candidiate. Try to grab the current value, and in the case of
5423 * PADSV, ignore it if it has multiple references. Return the value.
5427 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5438 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5439 o = cLISTOPo->op_first->op_sibling;
5441 for (; o; o = o->op_next) {
5442 const OPCODE type = o->op_type;
5444 if (sv && o->op_next == o)
5446 if (o->op_next != o) {
5447 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5449 if (type == OP_DBSTATE)
5452 if (type == OP_LEAVESUB || type == OP_RETURN)
5456 if (type == OP_CONST && cSVOPo->op_sv)
5458 else if (cv && type == OP_CONST) {
5459 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5463 else if (cv && type == OP_PADSV) {
5464 if (CvCONST(cv)) { /* newly cloned anon */
5465 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5466 /* the candidate should have 1 ref from this pad and 1 ref
5467 * from the parent */
5468 if (!sv || SvREFCNT(sv) != 2)
5475 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5476 sv = &PL_sv_undef; /* an arbitrary non-null value */
5491 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5494 /* This would be the return value, but the return cannot be reached. */
5495 OP* pegop = newOP(OP_NULL, 0);
5498 PERL_UNUSED_ARG(floor);
5508 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5510 NORETURN_FUNCTION_END;
5515 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5517 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5521 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5528 register CV *cv = NULL;
5530 /* If the subroutine has no body, no attributes, and no builtin attributes
5531 then it's just a sub declaration, and we may be able to get away with
5532 storing with a placeholder scalar in the symbol table, rather than a
5533 full GV and CV. If anything is present then it will take a full CV to
5535 const I32 gv_fetch_flags
5536 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5538 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5539 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5542 assert(proto->op_type == OP_CONST);
5543 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5548 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5549 SV * const sv = sv_newmortal();
5550 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5551 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5552 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5553 aname = SvPVX_const(sv);
5558 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5559 : gv_fetchpv(aname ? aname
5560 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5561 gv_fetch_flags, SVt_PVCV);
5563 if (!PL_madskills) {
5572 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5573 maximum a prototype before. */
5574 if (SvTYPE(gv) > SVt_NULL) {
5575 if (!SvPOK((const SV *)gv)
5576 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
5577 && ckWARN_d(WARN_PROTOTYPE))
5579 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5581 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5584 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5586 sv_setiv(MUTABLE_SV(gv), -1);
5588 SvREFCNT_dec(PL_compcv);
5589 cv = PL_compcv = NULL;
5593 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5595 #ifdef GV_UNIQUE_CHECK
5596 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5597 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5601 if (!block || !ps || *ps || attrs
5602 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5604 || block->op_type == OP_NULL
5609 const_sv = op_const_sv(block, NULL);
5612 const bool exists = CvROOT(cv) || CvXSUB(cv);
5614 #ifdef GV_UNIQUE_CHECK
5615 if (exists && GvUNIQUE(gv)) {
5616 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5620 /* if the subroutine doesn't exist and wasn't pre-declared
5621 * with a prototype, assume it will be AUTOLOADed,
5622 * skipping the prototype check
5624 if (exists || SvPOK(cv))
5625 cv_ckproto_len(cv, gv, ps, ps_len);
5626 /* already defined (or promised)? */
5627 if (exists || GvASSUMECV(gv)) {
5630 || block->op_type == OP_NULL
5633 if (CvFLAGS(PL_compcv)) {
5634 /* might have had built-in attrs applied */
5635 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5637 /* just a "sub foo;" when &foo is already defined */
5638 SAVEFREESV(PL_compcv);
5643 && block->op_type != OP_NULL
5646 if (ckWARN(WARN_REDEFINE)
5648 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5650 const line_t oldline = CopLINE(PL_curcop);
5651 if (PL_parser && PL_parser->copline != NOLINE)
5652 CopLINE_set(PL_curcop, PL_parser->copline);
5653 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5654 CvCONST(cv) ? "Constant subroutine %s redefined"
5655 : "Subroutine %s redefined", name);
5656 CopLINE_set(PL_curcop, oldline);
5659 if (!PL_minus_c) /* keep old one around for madskills */
5662 /* (PL_madskills unset in used file.) */
5670 SvREFCNT_inc_simple_void_NN(const_sv);
5672 assert(!CvROOT(cv) && !CvCONST(cv));
5673 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5674 CvXSUBANY(cv).any_ptr = const_sv;
5675 CvXSUB(cv) = const_sv_xsub;
5681 cv = newCONSTSUB(NULL, name, const_sv);
5683 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5684 (CvGV(cv) && GvSTASH(CvGV(cv)))
5693 SvREFCNT_dec(PL_compcv);
5701 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5702 * before we clobber PL_compcv.
5706 || block->op_type == OP_NULL
5709 rcv = MUTABLE_SV(cv);
5710 /* Might have had built-in attributes applied -- propagate them. */
5711 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5712 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5713 stash = GvSTASH(CvGV(cv));
5714 else if (CvSTASH(cv))
5715 stash = CvSTASH(cv);
5717 stash = PL_curstash;
5720 /* possibly about to re-define existing subr -- ignore old cv */
5721 rcv = MUTABLE_SV(PL_compcv);
5722 if (name && GvSTASH(gv))
5723 stash = GvSTASH(gv);
5725 stash = PL_curstash;
5727 apply_attrs(stash, rcv, attrs, FALSE);
5729 if (cv) { /* must reuse cv if autoloaded */
5736 || block->op_type == OP_NULL) && !PL_madskills
5739 /* got here with just attrs -- work done, so bug out */
5740 SAVEFREESV(PL_compcv);
5743 /* transfer PL_compcv to cv */
5745 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5746 if (!CvWEAKOUTSIDE(cv))
5747 SvREFCNT_dec(CvOUTSIDE(cv));
5748 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5749 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5750 CvOUTSIDE(PL_compcv) = 0;
5751 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5752 CvPADLIST(PL_compcv) = 0;
5753 /* inner references to PL_compcv must be fixed up ... */
5754 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5755 /* ... before we throw it away */
5756 SvREFCNT_dec(PL_compcv);
5758 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5759 ++PL_sub_generation;
5766 if (strEQ(name, "import")) {
5767 PL_formfeed = MUTABLE_SV(cv);
5768 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5772 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5776 CvFILE_set_from_cop(cv, PL_curcop);
5777 CvSTASH(cv) = PL_curstash;
5780 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5782 if (PL_parser && PL_parser->error_count) {
5786 const char *s = strrchr(name, ':');
5788 if (strEQ(s, "BEGIN")) {
5789 const char not_safe[] =
5790 "BEGIN not safe after errors--compilation aborted";
5791 if (PL_in_eval & EVAL_KEEPERR)
5792 Perl_croak(aTHX_ not_safe);
5794 /* force display of errors found but not reported */
5795 sv_catpv(ERRSV, not_safe);
5796 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5805 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5806 the debugger could be able to set a breakpoint in, so signal to
5807 pp_entereval that it should not throw away any saved lines at scope
5810 PL_breakable_sub_gen++;
5812 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5813 mod(scalarseq(block), OP_LEAVESUBLV));
5814 block->op_attached = 1;
5817 /* This makes sub {}; work as expected. */
5818 if (block->op_type == OP_STUB) {
5819 OP* const newblock = newSTATEOP(0, NULL, 0);
5821 op_getmad(block,newblock,'B');
5828 block->op_attached = 1;
5829 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5831 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5832 OpREFCNT_set(CvROOT(cv), 1);
5833 CvSTART(cv) = LINKLIST(CvROOT(cv));
5834 CvROOT(cv)->op_next = 0;
5835 CALL_PEEP(CvSTART(cv));
5837 /* now that optimizer has done its work, adjust pad values */
5839 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5842 assert(!CvCONST(cv));
5843 if (ps && !*ps && op_const_sv(block, cv))
5847 if (name || aname) {
5848 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5849 SV * const sv = newSV(0);
5850 SV * const tmpstr = sv_newmortal();
5851 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5852 GV_ADDMULTI, SVt_PVHV);
5855 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5857 (long)PL_subline, (long)CopLINE(PL_curcop));
5858 gv_efullname3(tmpstr, gv, NULL);
5859 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5860 SvCUR(tmpstr), sv, 0);
5861 hv = GvHVn(db_postponed);
5862 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5863 CV * const pcv = GvCV(db_postponed);
5869 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5874 if (name && ! (PL_parser && PL_parser->error_count))
5875 process_special_blocks(name, gv, cv);
5880 PL_parser->copline = NOLINE;
5886 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5889 const char *const colon = strrchr(fullname,':');
5890 const char *const name = colon ? colon + 1 : fullname;
5892 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5895 if (strEQ(name, "BEGIN")) {
5896 const I32 oldscope = PL_scopestack_ix;
5898 SAVECOPFILE(&PL_compiling);
5899 SAVECOPLINE(&PL_compiling);
5901 DEBUG_x( dump_sub(gv) );
5902 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5903 GvCV(gv) = 0; /* cv has been hijacked */
5904 call_list(oldscope, PL_beginav);
5906 PL_curcop = &PL_compiling;
5907 CopHINTS_set(&PL_compiling, PL_hints);
5914 if strEQ(name, "END") {
5915 DEBUG_x( dump_sub(gv) );
5916 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5919 } else if (*name == 'U') {
5920 if (strEQ(name, "UNITCHECK")) {
5921 /* It's never too late to run a unitcheck block */
5922 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5926 } else if (*name == 'C') {
5927 if (strEQ(name, "CHECK")) {
5928 if (PL_main_start && ckWARN(WARN_VOID))
5929 Perl_warner(aTHX_ packWARN(WARN_VOID),
5930 "Too late to run CHECK block");
5931 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5935 } else if (*name == 'I') {
5936 if (strEQ(name, "INIT")) {
5937 if (PL_main_start && ckWARN(WARN_VOID))
5938 Perl_warner(aTHX_ packWARN(WARN_VOID),
5939 "Too late to run INIT block");
5940 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5946 DEBUG_x( dump_sub(gv) );
5947 GvCV(gv) = 0; /* cv has been hijacked */
5952 =for apidoc newCONSTSUB
5954 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5955 eligible for inlining at compile-time.
5961 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5966 const char *const temp_p = CopFILE(PL_curcop);
5967 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5969 SV *const temp_sv = CopFILESV(PL_curcop);
5971 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5973 char *const file = savepvn(temp_p, temp_p ? len : 0);
5977 if (IN_PERL_RUNTIME) {
5978 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5979 * an op shared between threads. Use a non-shared COP for our
5981 SAVEVPTR(PL_curcop);
5982 PL_curcop = &PL_compiling;
5984 SAVECOPLINE(PL_curcop);
5985 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5988 PL_hints &= ~HINT_BLOCK_SCOPE;
5991 SAVESPTR(PL_curstash);
5992 SAVECOPSTASH(PL_curcop);
5993 PL_curstash = stash;
5994 CopSTASH_set(PL_curcop,stash);
5997 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5998 and so doesn't get free()d. (It's expected to be from the C pre-
5999 processor __FILE__ directive). But we need a dynamically allocated one,
6000 and we need it to get freed. */
6001 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
6002 CvXSUBANY(cv).any_ptr = sv;
6008 CopSTASH_free(PL_curcop);
6016 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6017 const char *const filename, const char *const proto,
6020 CV *cv = newXS(name, subaddr, filename);
6022 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6024 if (flags & XS_DYNAMIC_FILENAME) {
6025 /* We need to "make arrangements" (ie cheat) to ensure that the
6026 filename lasts as long as the PVCV we just created, but also doesn't
6028 STRLEN filename_len = strlen(filename);
6029 STRLEN proto_and_file_len = filename_len;
6030 char *proto_and_file;
6034 proto_len = strlen(proto);
6035 proto_and_file_len += proto_len;
6037 Newx(proto_and_file, proto_and_file_len + 1, char);
6038 Copy(proto, proto_and_file, proto_len, char);
6039 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6042 proto_and_file = savepvn(filename, filename_len);
6045 /* This gets free()d. :-) */
6046 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6047 SV_HAS_TRAILING_NUL);
6049 /* This gives us the correct prototype, rather than one with the
6050 file name appended. */
6051 SvCUR_set(cv, proto_len);
6055 CvFILE(cv) = proto_and_file + proto_len;
6057 sv_setpv(MUTABLE_SV(cv), proto);
6063 =for apidoc U||newXS
6065 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6066 static storage, as it is used directly as CvFILE(), without a copy being made.
6072 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6075 GV * const gv = gv_fetchpv(name ? name :
6076 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6077 GV_ADDMULTI, SVt_PVCV);
6080 PERL_ARGS_ASSERT_NEWXS;
6083 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6085 if ((cv = (name ? GvCV(gv) : NULL))) {
6087 /* just a cached method */
6091 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6092 /* already defined (or promised) */
6093 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6094 if (ckWARN(WARN_REDEFINE)) {
6095 GV * const gvcv = CvGV(cv);
6097 HV * const stash = GvSTASH(gvcv);
6099 const char *redefined_name = HvNAME_get(stash);
6100 if ( strEQ(redefined_name,"autouse") ) {
6101 const line_t oldline = CopLINE(PL_curcop);
6102 if (PL_parser && PL_parser->copline != NOLINE)
6103 CopLINE_set(PL_curcop, PL_parser->copline);
6104 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6105 CvCONST(cv) ? "Constant subroutine %s redefined"
6106 : "Subroutine %s redefined"
6108 CopLINE_set(PL_curcop, oldline);
6118 if (cv) /* must reuse cv if autoloaded */
6121 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6125 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6129 (void)gv_fetchfile(filename);
6130 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6131 an external constant string */
6133 CvXSUB(cv) = subaddr;
6136 process_special_blocks(name, gv, cv);
6148 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6153 OP* pegop = newOP(OP_NULL, 0);
6157 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6158 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6160 #ifdef GV_UNIQUE_CHECK
6162 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6166 if ((cv = GvFORM(gv))) {
6167 if (ckWARN(WARN_REDEFINE)) {
6168 const line_t oldline = CopLINE(PL_curcop);
6169 if (PL_parser && PL_parser->copline != NOLINE)
6170 CopLINE_set(PL_curcop, PL_parser->copline);
6171 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6172 o ? "Format %"SVf" redefined"
6173 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6174 CopLINE_set(PL_curcop, oldline);
6181 CvFILE_set_from_cop(cv, PL_curcop);
6184 pad_tidy(padtidy_FORMAT);
6185 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6186 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6187 OpREFCNT_set(CvROOT(cv), 1);
6188 CvSTART(cv) = LINKLIST(CvROOT(cv));
6189 CvROOT(cv)->op_next = 0;
6190 CALL_PEEP(CvSTART(cv));
6192 op_getmad(o,pegop,'n');
6193 op_getmad_weak(block, pegop, 'b');
6198 PL_parser->copline = NOLINE;
6206 Perl_newANONLIST(pTHX_ OP *o)
6208 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6212 Perl_newANONHASH(pTHX_ OP *o)
6214 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6218 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6220 return newANONATTRSUB(floor, proto, NULL, block);
6224 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6226 return newUNOP(OP_REFGEN, 0,
6227 newSVOP(OP_ANONCODE, 0,
6228 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6232 Perl_oopsAV(pTHX_ OP *o)
6236 PERL_ARGS_ASSERT_OOPSAV;
6238 switch (o->op_type) {
6240 o->op_type = OP_PADAV;
6241 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6242 return ref(o, OP_RV2AV);
6245 o->op_type = OP_RV2AV;
6246 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6251 if (ckWARN_d(WARN_INTERNAL))
6252 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6259 Perl_oopsHV(pTHX_ OP *o)
6263 PERL_ARGS_ASSERT_OOPSHV;
6265 switch (o->op_type) {
6268 o->op_type = OP_PADHV;
6269 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6270 return ref(o, OP_RV2HV);
6274 o->op_type = OP_RV2HV;
6275 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6280 if (ckWARN_d(WARN_INTERNAL))
6281 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6288 Perl_newAVREF(pTHX_ OP *o)
6292 PERL_ARGS_ASSERT_NEWAVREF;
6294 if (o->op_type == OP_PADANY) {
6295 o->op_type = OP_PADAV;
6296 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6299 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6300 && ckWARN(WARN_DEPRECATED)) {
6301 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6302 "Using an array as a reference is deprecated");
6304 return newUNOP(OP_RV2AV, 0, scalar(o));
6308 Perl_newGVREF(pTHX_ I32 type, OP *o)
6310 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6311 return newUNOP(OP_NULL, 0, o);
6312 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6316 Perl_newHVREF(pTHX_ OP *o)
6320 PERL_ARGS_ASSERT_NEWHVREF;
6322 if (o->op_type == OP_PADANY) {
6323 o->op_type = OP_PADHV;
6324 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6327 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6328 && ckWARN(WARN_DEPRECATED)) {
6329 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6330 "Using a hash as a reference is deprecated");
6332 return newUNOP(OP_RV2HV, 0, scalar(o));
6336 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6338 return newUNOP(OP_RV2CV, flags, scalar(o));
6342 Perl_newSVREF(pTHX_ OP *o)
6346 PERL_ARGS_ASSERT_NEWSVREF;
6348 if (o->op_type == OP_PADANY) {
6349 o->op_type = OP_PADSV;
6350 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6353 return newUNOP(OP_RV2SV, 0, scalar(o));
6356 /* Check routines. See the comments at the top of this file for details
6357 * on when these are called */
6360 Perl_ck_anoncode(pTHX_ OP *o)
6362 PERL_ARGS_ASSERT_CK_ANONCODE;
6364 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6366 cSVOPo->op_sv = NULL;
6371 Perl_ck_bitop(pTHX_ OP *o)
6375 PERL_ARGS_ASSERT_CK_BITOP;
6377 #define OP_IS_NUMCOMPARE(op) \
6378 ((op) == OP_LT || (op) == OP_I_LT || \
6379 (op) == OP_GT || (op) == OP_I_GT || \
6380 (op) == OP_LE || (op) == OP_I_LE || \
6381 (op) == OP_GE || (op) == OP_I_GE || \
6382 (op) == OP_EQ || (op) == OP_I_EQ || \
6383 (op) == OP_NE || (op) == OP_I_NE || \
6384 (op) == OP_NCMP || (op) == OP_I_NCMP)
6385 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6386 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6387 && (o->op_type == OP_BIT_OR
6388 || o->op_type == OP_BIT_AND
6389 || o->op_type == OP_BIT_XOR))
6391 const OP * const left = cBINOPo->op_first;
6392 const OP * const right = left->op_sibling;
6393 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6394 (left->op_flags & OPf_PARENS) == 0) ||
6395 (OP_IS_NUMCOMPARE(right->op_type) &&
6396 (right->op_flags & OPf_PARENS) == 0))
6397 if (ckWARN(WARN_PRECEDENCE))
6398 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6399 "Possible precedence problem on bitwise %c operator",
6400 o->op_type == OP_BIT_OR ? '|'
6401 : o->op_type == OP_BIT_AND ? '&' : '^'
6408 Perl_ck_concat(pTHX_ OP *o)
6410 const OP * const kid = cUNOPo->op_first;
6412 PERL_ARGS_ASSERT_CK_CONCAT;
6413 PERL_UNUSED_CONTEXT;
6415 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6416 !(kUNOP->op_first->op_flags & OPf_MOD))
6417 o->op_flags |= OPf_STACKED;
6422 Perl_ck_spair(pTHX_ OP *o)
6426 PERL_ARGS_ASSERT_CK_SPAIR;
6428 if (o->op_flags & OPf_KIDS) {
6431 const OPCODE type = o->op_type;
6432 o = modkids(ck_fun(o), type);
6433 kid = cUNOPo->op_first;
6434 newop = kUNOP->op_first->op_sibling;
6436 const OPCODE type = newop->op_type;
6437 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6438 type == OP_PADAV || type == OP_PADHV ||
6439 type == OP_RV2AV || type == OP_RV2HV)
6443 op_getmad(kUNOP->op_first,newop,'K');
6445 op_free(kUNOP->op_first);
6447 kUNOP->op_first = newop;
6449 o->op_ppaddr = PL_ppaddr[++o->op_type];
6454 Perl_ck_delete(pTHX_ OP *o)
6456 PERL_ARGS_ASSERT_CK_DELETE;
6460 if (o->op_flags & OPf_KIDS) {
6461 OP * const kid = cUNOPo->op_first;
6462 switch (kid->op_type) {
6464 o->op_flags |= OPf_SPECIAL;
6467 o->op_private |= OPpSLICE;
6470 o->op_flags |= OPf_SPECIAL;
6475 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6484 Perl_ck_die(pTHX_ OP *o)
6486 PERL_ARGS_ASSERT_CK_DIE;
6489 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6495 Perl_ck_eof(pTHX_ OP *o)
6499 PERL_ARGS_ASSERT_CK_EOF;
6501 if (o->op_flags & OPf_KIDS) {
6502 if (cLISTOPo->op_first->op_type == OP_STUB) {
6504 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6506 op_getmad(o,newop,'O');
6518 Perl_ck_eval(pTHX_ OP *o)
6522 PERL_ARGS_ASSERT_CK_EVAL;
6524 PL_hints |= HINT_BLOCK_SCOPE;
6525 if (o->op_flags & OPf_KIDS) {
6526 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6529 o->op_flags &= ~OPf_KIDS;
6532 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6538 cUNOPo->op_first = 0;
6543 NewOp(1101, enter, 1, LOGOP);
6544 enter->op_type = OP_ENTERTRY;
6545 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6546 enter->op_private = 0;
6548 /* establish postfix order */
6549 enter->op_next = (OP*)enter;
6551 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6552 o->op_type = OP_LEAVETRY;
6553 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6554 enter->op_other = o;
6555 op_getmad(oldo,o,'O');
6569 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6570 op_getmad(oldo,o,'O');
6572 o->op_targ = (PADOFFSET)PL_hints;
6573 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6574 /* Store a copy of %^H that pp_entereval can pick up. */
6575 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6576 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6577 cUNOPo->op_first->op_sibling = hhop;
6578 o->op_private |= OPpEVAL_HAS_HH;
6584 Perl_ck_exit(pTHX_ OP *o)
6586 PERL_ARGS_ASSERT_CK_EXIT;
6589 HV * const table = GvHV(PL_hintgv);
6591 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6592 if (svp && *svp && SvTRUE(*svp))
6593 o->op_private |= OPpEXIT_VMSISH;
6595 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6601 Perl_ck_exec(pTHX_ OP *o)
6603 PERL_ARGS_ASSERT_CK_EXEC;
6605 if (o->op_flags & OPf_STACKED) {
6608 kid = cUNOPo->op_first->op_sibling;
6609 if (kid->op_type == OP_RV2GV)
6618 Perl_ck_exists(pTHX_ OP *o)
6622 PERL_ARGS_ASSERT_CK_EXISTS;
6625 if (o->op_flags & OPf_KIDS) {
6626 OP * const kid = cUNOPo->op_first;
6627 if (kid->op_type == OP_ENTERSUB) {
6628 (void) ref(kid, o->op_type);
6629 if (kid->op_type != OP_RV2CV
6630 && !(PL_parser && PL_parser->error_count))
6631 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6633 o->op_private |= OPpEXISTS_SUB;
6635 else if (kid->op_type == OP_AELEM)
6636 o->op_flags |= OPf_SPECIAL;
6637 else if (kid->op_type != OP_HELEM)
6638 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6646 Perl_ck_rvconst(pTHX_ register OP *o)
6649 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6651 PERL_ARGS_ASSERT_CK_RVCONST;
6653 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6654 if (o->op_type == OP_RV2CV)
6655 o->op_private &= ~1;
6657 if (kid->op_type == OP_CONST) {
6660 SV * const kidsv = kid->op_sv;
6662 /* Is it a constant from cv_const_sv()? */
6663 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6664 SV * const rsv = SvRV(kidsv);
6665 const svtype type = SvTYPE(rsv);
6666 const char *badtype = NULL;
6668 switch (o->op_type) {
6670 if (type > SVt_PVMG)
6671 badtype = "a SCALAR";
6674 if (type != SVt_PVAV)
6675 badtype = "an ARRAY";
6678 if (type != SVt_PVHV)
6682 if (type != SVt_PVCV)
6687 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6690 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6691 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6692 /* If this is an access to a stash, disable "strict refs", because
6693 * stashes aren't auto-vivified at compile-time (unless we store
6694 * symbols in them), and we don't want to produce a run-time
6695 * stricture error when auto-vivifying the stash. */
6696 const char *s = SvPV_nolen(kidsv);
6697 const STRLEN l = SvCUR(kidsv);
6698 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6699 o->op_private &= ~HINT_STRICT_REFS;
6701 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6702 const char *badthing;
6703 switch (o->op_type) {
6705 badthing = "a SCALAR";
6708 badthing = "an ARRAY";
6711 badthing = "a HASH";
6719 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6720 SVfARG(kidsv), badthing);
6723 * This is a little tricky. We only want to add the symbol if we
6724 * didn't add it in the lexer. Otherwise we get duplicate strict
6725 * warnings. But if we didn't add it in the lexer, we must at
6726 * least pretend like we wanted to add it even if it existed before,
6727 * or we get possible typo warnings. OPpCONST_ENTERED says
6728 * whether the lexer already added THIS instance of this symbol.
6730 iscv = (o->op_type == OP_RV2CV) * 2;
6732 gv = gv_fetchsv(kidsv,
6733 iscv | !(kid->op_private & OPpCONST_ENTERED),
6736 : o->op_type == OP_RV2SV
6738 : o->op_type == OP_RV2AV
6740 : o->op_type == OP_RV2HV
6743 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6745 kid->op_type = OP_GV;
6746 SvREFCNT_dec(kid->op_sv);
6748 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6749 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6750 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6752 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6754 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6756 kid->op_private = 0;
6757 kid->op_ppaddr = PL_ppaddr[OP_GV];
6764 Perl_ck_ftst(pTHX_ OP *o)
6767 const I32 type = o->op_type;
6769 PERL_ARGS_ASSERT_CK_FTST;
6771 if (o->op_flags & OPf_REF) {
6774 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6775 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6776 const OPCODE kidtype = kid->op_type;
6778 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6779 OP * const newop = newGVOP(type, OPf_REF,
6780 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6782 op_getmad(o,newop,'O');
6788 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6789 o->op_private |= OPpFT_ACCESS;
6790 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6791 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6792 o->op_private |= OPpFT_STACKED;
6800 if (type == OP_FTTTY)
6801 o = newGVOP(type, OPf_REF, PL_stdingv);
6803 o = newUNOP(type, 0, newDEFSVOP());
6804 op_getmad(oldo,o,'O');
6810 Perl_ck_fun(pTHX_ OP *o)
6813 const int type = o->op_type;
6814 register I32 oa = PL_opargs[type] >> OASHIFT;
6816 PERL_ARGS_ASSERT_CK_FUN;
6818 if (o->op_flags & OPf_STACKED) {
6819 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6822 return no_fh_allowed(o);
6825 if (o->op_flags & OPf_KIDS) {
6826 OP **tokid = &cLISTOPo->op_first;
6827 register OP *kid = cLISTOPo->op_first;
6831 if (kid->op_type == OP_PUSHMARK ||
6832 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6834 tokid = &kid->op_sibling;
6835 kid = kid->op_sibling;
6837 if (!kid && PL_opargs[type] & OA_DEFGV)
6838 *tokid = kid = newDEFSVOP();
6842 sibl = kid->op_sibling;
6844 if (!sibl && kid->op_type == OP_STUB) {
6851 /* list seen where single (scalar) arg expected? */
6852 if (numargs == 1 && !(oa >> 4)
6853 && kid->op_type == OP_LIST && type != OP_SCALAR)
6855 return too_many_arguments(o,PL_op_desc[type]);
6868 if ((type == OP_PUSH || type == OP_UNSHIFT)
6869 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6870 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6871 "Useless use of %s with no values",
6874 if (kid->op_type == OP_CONST &&
6875 (kid->op_private & OPpCONST_BARE))
6877 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6878 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6879 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6880 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6881 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6882 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6884 op_getmad(kid,newop,'K');
6889 kid->op_sibling = sibl;
6892 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6893 bad_type(numargs, "array", PL_op_desc[type], kid);
6897 if (kid->op_type == OP_CONST &&
6898 (kid->op_private & OPpCONST_BARE))
6900 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6901 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6902 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6903 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6904 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6905 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6907 op_getmad(kid,newop,'K');
6912 kid->op_sibling = sibl;
6915 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6916 bad_type(numargs, "hash", PL_op_desc[type], kid);
6921 OP * const newop = newUNOP(OP_NULL, 0, kid);
6922 kid->op_sibling = 0;
6924 newop->op_next = newop;
6926 kid->op_sibling = sibl;
6931 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6932 if (kid->op_type == OP_CONST &&
6933 (kid->op_private & OPpCONST_BARE))
6935 OP * const newop = newGVOP(OP_GV, 0,
6936 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6937 if (!(o->op_private & 1) && /* if not unop */
6938 kid == cLISTOPo->op_last)
6939 cLISTOPo->op_last = newop;
6941 op_getmad(kid,newop,'K');
6947 else if (kid->op_type == OP_READLINE) {
6948 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6949 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6952 I32 flags = OPf_SPECIAL;
6956 /* is this op a FH constructor? */
6957 if (is_handle_constructor(o,numargs)) {
6958 const char *name = NULL;
6962 /* Set a flag to tell rv2gv to vivify
6963 * need to "prove" flag does not mean something
6964 * else already - NI-S 1999/05/07
6967 if (kid->op_type == OP_PADSV) {
6969 = PAD_COMPNAME_SV(kid->op_targ);
6970 name = SvPV_const(namesv, len);
6972 else if (kid->op_type == OP_RV2SV
6973 && kUNOP->op_first->op_type == OP_GV)
6975 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6977 len = GvNAMELEN(gv);
6979 else if (kid->op_type == OP_AELEM
6980 || kid->op_type == OP_HELEM)
6983 OP *op = ((BINOP*)kid)->op_first;
6987 const char * const a =
6988 kid->op_type == OP_AELEM ?
6990 if (((op->op_type == OP_RV2AV) ||
6991 (op->op_type == OP_RV2HV)) &&
6992 (firstop = ((UNOP*)op)->op_first) &&
6993 (firstop->op_type == OP_GV)) {
6994 /* packagevar $a[] or $h{} */
6995 GV * const gv = cGVOPx_gv(firstop);
7003 else if (op->op_type == OP_PADAV
7004 || op->op_type == OP_PADHV) {
7005 /* lexicalvar $a[] or $h{} */
7006 const char * const padname =
7007 PAD_COMPNAME_PV(op->op_targ);
7016 name = SvPV_const(tmpstr, len);
7021 name = "__ANONIO__";
7028 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7029 namesv = PAD_SVl(targ);
7030 SvUPGRADE(namesv, SVt_PV);
7032 sv_setpvs(namesv, "$");
7033 sv_catpvn(namesv, name, len);
7036 kid->op_sibling = 0;
7037 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7038 kid->op_targ = targ;
7039 kid->op_private |= priv;
7041 kid->op_sibling = sibl;
7047 mod(scalar(kid), type);
7051 tokid = &kid->op_sibling;
7052 kid = kid->op_sibling;
7055 if (kid && kid->op_type != OP_STUB)
7056 return too_many_arguments(o,OP_DESC(o));
7057 o->op_private |= numargs;
7059 /* FIXME - should the numargs move as for the PERL_MAD case? */
7060 o->op_private |= numargs;
7062 return too_many_arguments(o,OP_DESC(o));
7066 else if (PL_opargs[type] & OA_DEFGV) {
7068 OP *newop = newUNOP(type, 0, newDEFSVOP());
7069 op_getmad(o,newop,'O');
7072 /* Ordering of these two is important to keep f_map.t passing. */
7074 return newUNOP(type, 0, newDEFSVOP());
7079 while (oa & OA_OPTIONAL)
7081 if (oa && oa != OA_LIST)
7082 return too_few_arguments(o,OP_DESC(o));
7088 Perl_ck_glob(pTHX_ OP *o)
7093 PERL_ARGS_ASSERT_CK_GLOB;
7096 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7097 append_elem(OP_GLOB, o, newDEFSVOP());
7099 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7100 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7102 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7105 #if !defined(PERL_EXTERNAL_GLOB)
7106 /* XXX this can be tightened up and made more failsafe. */
7107 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7110 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7111 newSVpvs("File::Glob"), NULL, NULL, NULL);
7112 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7113 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7114 GvCV(gv) = GvCV(glob_gv);
7115 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7116 GvIMPORTED_CV_on(gv);
7119 #endif /* PERL_EXTERNAL_GLOB */
7121 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7122 append_elem(OP_GLOB, o,
7123 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7124 o->op_type = OP_LIST;
7125 o->op_ppaddr = PL_ppaddr[OP_LIST];
7126 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7127 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7128 cLISTOPo->op_first->op_targ = 0;
7129 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7130 append_elem(OP_LIST, o,
7131 scalar(newUNOP(OP_RV2CV, 0,
7132 newGVOP(OP_GV, 0, gv)))));
7133 o = newUNOP(OP_NULL, 0, ck_subr(o));
7134 o->op_targ = OP_GLOB; /* hint at what it used to be */
7137 gv = newGVgen("main");
7139 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7145 Perl_ck_grep(pTHX_ OP *o)
7150 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7153 PERL_ARGS_ASSERT_CK_GREP;
7155 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7156 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7158 if (o->op_flags & OPf_STACKED) {
7161 kid = cLISTOPo->op_first->op_sibling;
7162 if (!cUNOPx(kid)->op_next)
7163 Perl_croak(aTHX_ "panic: ck_grep");
7164 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7167 NewOp(1101, gwop, 1, LOGOP);
7168 kid->op_next = (OP*)gwop;
7169 o->op_flags &= ~OPf_STACKED;
7171 kid = cLISTOPo->op_first->op_sibling;
7172 if (type == OP_MAPWHILE)
7177 if (PL_parser && PL_parser->error_count)
7179 kid = cLISTOPo->op_first->op_sibling;
7180 if (kid->op_type != OP_NULL)
7181 Perl_croak(aTHX_ "panic: ck_grep");
7182 kid = kUNOP->op_first;
7185 NewOp(1101, gwop, 1, LOGOP);
7186 gwop->op_type = type;
7187 gwop->op_ppaddr = PL_ppaddr[type];
7188 gwop->op_first = listkids(o);
7189 gwop->op_flags |= OPf_KIDS;
7190 gwop->op_other = LINKLIST(kid);
7191 kid->op_next = (OP*)gwop;
7192 offset = pad_findmy("$_");
7193 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7194 o->op_private = gwop->op_private = 0;
7195 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7198 o->op_private = gwop->op_private = OPpGREP_LEX;
7199 gwop->op_targ = o->op_targ = offset;
7202 kid = cLISTOPo->op_first->op_sibling;
7203 if (!kid || !kid->op_sibling)
7204 return too_few_arguments(o,OP_DESC(o));
7205 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7206 mod(kid, OP_GREPSTART);
7212 Perl_ck_index(pTHX_ OP *o)
7214 PERL_ARGS_ASSERT_CK_INDEX;
7216 if (o->op_flags & OPf_KIDS) {
7217 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7219 kid = kid->op_sibling; /* get past "big" */
7220 if (kid && kid->op_type == OP_CONST)
7221 fbm_compile(((SVOP*)kid)->op_sv, 0);
7227 Perl_ck_lfun(pTHX_ OP *o)
7229 const OPCODE type = o->op_type;
7231 PERL_ARGS_ASSERT_CK_LFUN;
7233 return modkids(ck_fun(o), type);
7237 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7239 PERL_ARGS_ASSERT_CK_DEFINED;
7241 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7242 switch (cUNOPo->op_first->op_type) {
7244 /* This is needed for
7245 if (defined %stash::)
7246 to work. Do not break Tk.
7248 break; /* Globals via GV can be undef */
7250 case OP_AASSIGN: /* Is this a good idea? */
7251 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7252 "defined(@array) is deprecated");
7253 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7254 "\t(Maybe you should just omit the defined()?)\n");
7257 /* This is needed for
7258 if (defined %stash::)
7259 to work. Do not break Tk.
7261 break; /* Globals via GV can be undef */
7263 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7264 "defined(%%hash) is deprecated");
7265 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7266 "\t(Maybe you should just omit the defined()?)\n");
7277 Perl_ck_readline(pTHX_ OP *o)
7279 PERL_ARGS_ASSERT_CK_READLINE;
7281 if (!(o->op_flags & OPf_KIDS)) {
7283 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7285 op_getmad(o,newop,'O');
7295 Perl_ck_rfun(pTHX_ OP *o)
7297 const OPCODE type = o->op_type;
7299 PERL_ARGS_ASSERT_CK_RFUN;
7301 return refkids(ck_fun(o), type);
7305 Perl_ck_listiob(pTHX_ OP *o)
7309 PERL_ARGS_ASSERT_CK_LISTIOB;
7311 kid = cLISTOPo->op_first;
7314 kid = cLISTOPo->op_first;
7316 if (kid->op_type == OP_PUSHMARK)
7317 kid = kid->op_sibling;
7318 if (kid && o->op_flags & OPf_STACKED)
7319 kid = kid->op_sibling;
7320 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7321 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7322 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7323 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7324 cLISTOPo->op_first->op_sibling = kid;
7325 cLISTOPo->op_last = kid;
7326 kid = kid->op_sibling;
7331 append_elem(o->op_type, o, newDEFSVOP());
7337 Perl_ck_smartmatch(pTHX_ OP *o)
7340 if (0 == (o->op_flags & OPf_SPECIAL)) {
7341 OP *first = cBINOPo->op_first;
7342 OP *second = first->op_sibling;
7344 /* Implicitly take a reference to an array or hash */
7345 first->op_sibling = NULL;
7346 first = cBINOPo->op_first = ref_array_or_hash(first);
7347 second = first->op_sibling = ref_array_or_hash(second);
7349 /* Implicitly take a reference to a regular expression */
7350 if (first->op_type == OP_MATCH) {
7351 first->op_type = OP_QR;
7352 first->op_ppaddr = PL_ppaddr[OP_QR];
7354 if (second->op_type == OP_MATCH) {
7355 second->op_type = OP_QR;
7356 second->op_ppaddr = PL_ppaddr[OP_QR];
7365 Perl_ck_sassign(pTHX_ OP *o)
7368 OP * const kid = cLISTOPo->op_first;
7370 PERL_ARGS_ASSERT_CK_SASSIGN;
7372 /* has a disposable target? */
7373 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7374 && !(kid->op_flags & OPf_STACKED)
7375 /* Cannot steal the second time! */
7376 && !(kid->op_private & OPpTARGET_MY)
7377 /* Keep the full thing for madskills */
7381 OP * const kkid = kid->op_sibling;
7383 /* Can just relocate the target. */
7384 if (kkid && kkid->op_type == OP_PADSV
7385 && !(kkid->op_private & OPpLVAL_INTRO))
7387 kid->op_targ = kkid->op_targ;
7389 /* Now we do not need PADSV and SASSIGN. */
7390 kid->op_sibling = o->op_sibling; /* NULL */
7391 cLISTOPo->op_first = NULL;
7394 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7398 if (kid->op_sibling) {
7399 OP *kkid = kid->op_sibling;
7400 if (kkid->op_type == OP_PADSV
7401 && (kkid->op_private & OPpLVAL_INTRO)
7402 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7403 const PADOFFSET target = kkid->op_targ;
7404 OP *const other = newOP(OP_PADSV,
7406 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7407 OP *const first = newOP(OP_NULL, 0);
7408 OP *const nullop = newCONDOP(0, first, o, other);
7409 OP *const condop = first->op_next;
7410 /* hijacking PADSTALE for uninitialized state variables */
7411 SvPADSTALE_on(PAD_SVl(target));
7413 condop->op_type = OP_ONCE;
7414 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7415 condop->op_targ = target;
7416 other->op_targ = target;
7418 /* Because we change the type of the op here, we will skip the
7419 assinment binop->op_last = binop->op_first->op_sibling; at the
7420 end of Perl_newBINOP(). So need to do it here. */
7421 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7430 Perl_ck_match(pTHX_ OP *o)
7434 PERL_ARGS_ASSERT_CK_MATCH;
7436 if (o->op_type != OP_QR && PL_compcv) {
7437 const PADOFFSET offset = pad_findmy("$_");
7438 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7439 o->op_targ = offset;
7440 o->op_private |= OPpTARGET_MY;
7443 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7444 o->op_private |= OPpRUNTIME;
7449 Perl_ck_method(pTHX_ OP *o)
7451 OP * const kid = cUNOPo->op_first;
7453 PERL_ARGS_ASSERT_CK_METHOD;
7455 if (kid->op_type == OP_CONST) {
7456 SV* sv = kSVOP->op_sv;
7457 const char * const method = SvPVX_const(sv);
7458 if (!(strchr(method, ':') || strchr(method, '\''))) {
7460 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7461 sv = newSVpvn_share(method, SvCUR(sv), 0);
7464 kSVOP->op_sv = NULL;
7466 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7468 op_getmad(o,cmop,'O');
7479 Perl_ck_null(pTHX_ OP *o)
7481 PERL_ARGS_ASSERT_CK_NULL;
7482 PERL_UNUSED_CONTEXT;
7487 Perl_ck_open(pTHX_ OP *o)
7490 HV * const table = GvHV(PL_hintgv);
7492 PERL_ARGS_ASSERT_CK_OPEN;
7495 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7498 const char *d = SvPV_const(*svp, len);
7499 const I32 mode = mode_from_discipline(d, len);
7500 if (mode & O_BINARY)
7501 o->op_private |= OPpOPEN_IN_RAW;
7502 else if (mode & O_TEXT)
7503 o->op_private |= OPpOPEN_IN_CRLF;
7506 svp = hv_fetchs(table, "open_OUT", FALSE);
7509 const char *d = SvPV_const(*svp, len);
7510 const I32 mode = mode_from_discipline(d, len);
7511 if (mode & O_BINARY)
7512 o->op_private |= OPpOPEN_OUT_RAW;
7513 else if (mode & O_TEXT)
7514 o->op_private |= OPpOPEN_OUT_CRLF;
7517 if (o->op_type == OP_BACKTICK) {
7518 if (!(o->op_flags & OPf_KIDS)) {
7519 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7521 op_getmad(o,newop,'O');
7530 /* In case of three-arg dup open remove strictness
7531 * from the last arg if it is a bareword. */
7532 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7533 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7537 if ((last->op_type == OP_CONST) && /* The bareword. */
7538 (last->op_private & OPpCONST_BARE) &&
7539 (last->op_private & OPpCONST_STRICT) &&
7540 (oa = first->op_sibling) && /* The fh. */
7541 (oa = oa->op_sibling) && /* The mode. */
7542 (oa->op_type == OP_CONST) &&
7543 SvPOK(((SVOP*)oa)->op_sv) &&
7544 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7545 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7546 (last == oa->op_sibling)) /* The bareword. */
7547 last->op_private &= ~OPpCONST_STRICT;
7553 Perl_ck_repeat(pTHX_ OP *o)
7555 PERL_ARGS_ASSERT_CK_REPEAT;
7557 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7558 o->op_private |= OPpREPEAT_DOLIST;
7559 cBINOPo->op_first = force_list(cBINOPo->op_first);
7567 Perl_ck_require(pTHX_ OP *o)
7572 PERL_ARGS_ASSERT_CK_REQUIRE;
7574 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7575 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7577 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7578 SV * const sv = kid->op_sv;
7579 U32 was_readonly = SvREADONLY(sv);
7586 sv_force_normal_flags(sv, 0);
7587 assert(!SvREADONLY(sv));
7597 for (; s < end; s++) {
7598 if (*s == ':' && s[1] == ':') {
7600 Move(s+2, s+1, end - s - 1, char);
7605 sv_catpvs(sv, ".pm");
7606 SvFLAGS(sv) |= was_readonly;
7610 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7611 /* handle override, if any */
7612 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7613 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7614 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7615 gv = gvp ? *gvp : NULL;
7619 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7620 OP * const kid = cUNOPo->op_first;
7623 cUNOPo->op_first = 0;
7627 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7628 append_elem(OP_LIST, kid,
7629 scalar(newUNOP(OP_RV2CV, 0,
7632 op_getmad(o,newop,'O');
7640 Perl_ck_return(pTHX_ OP *o)
7645 PERL_ARGS_ASSERT_CK_RETURN;
7647 kid = cLISTOPo->op_first->op_sibling;
7648 if (CvLVALUE(PL_compcv)) {
7649 for (; kid; kid = kid->op_sibling)
7650 mod(kid, OP_LEAVESUBLV);
7652 for (; kid; kid = kid->op_sibling)
7653 if ((kid->op_type == OP_NULL)
7654 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7655 /* This is a do block */
7656 OP *op = kUNOP->op_first;
7657 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7658 op = cUNOPx(op)->op_first;
7659 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7660 /* Force the use of the caller's context */
7661 op->op_flags |= OPf_SPECIAL;
7670 Perl_ck_select(pTHX_ OP *o)
7675 PERL_ARGS_ASSERT_CK_SELECT;
7677 if (o->op_flags & OPf_KIDS) {
7678 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7679 if (kid && kid->op_sibling) {
7680 o->op_type = OP_SSELECT;
7681 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7683 return fold_constants(o);
7687 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7688 if (kid && kid->op_type == OP_RV2GV)
7689 kid->op_private &= ~HINT_STRICT_REFS;
7694 Perl_ck_shift(pTHX_ OP *o)
7697 const I32 type = o->op_type;
7699 PERL_ARGS_ASSERT_CK_SHIFT;
7701 if (!(o->op_flags & OPf_KIDS)) {
7703 /* FIXME - this can be refactored to reduce code in #ifdefs */
7705 OP * const oldo = o;
7709 argop = newUNOP(OP_RV2AV, 0,
7710 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7712 o = newUNOP(type, 0, scalar(argop));
7713 op_getmad(oldo,o,'O');
7716 return newUNOP(type, 0, scalar(argop));
7719 return scalar(modkids(ck_fun(o), type));
7723 Perl_ck_sort(pTHX_ OP *o)
7728 PERL_ARGS_ASSERT_CK_SORT;
7730 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7731 HV * const hinthv = GvHV(PL_hintgv);
7733 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7735 const I32 sorthints = (I32)SvIV(*svp);
7736 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7737 o->op_private |= OPpSORT_QSORT;
7738 if ((sorthints & HINT_SORT_STABLE) != 0)
7739 o->op_private |= OPpSORT_STABLE;
7744 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7746 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7747 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7749 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7751 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7753 if (kid->op_type == OP_SCOPE) {
7757 else if (kid->op_type == OP_LEAVE) {
7758 if (o->op_type == OP_SORT) {
7759 op_null(kid); /* wipe out leave */
7762 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7763 if (k->op_next == kid)
7765 /* don't descend into loops */
7766 else if (k->op_type == OP_ENTERLOOP
7767 || k->op_type == OP_ENTERITER)
7769 k = cLOOPx(k)->op_lastop;
7774 kid->op_next = 0; /* just disconnect the leave */
7775 k = kLISTOP->op_first;
7780 if (o->op_type == OP_SORT) {
7781 /* provide scalar context for comparison function/block */
7787 o->op_flags |= OPf_SPECIAL;
7789 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7792 firstkid = firstkid->op_sibling;
7795 /* provide list context for arguments */
7796 if (o->op_type == OP_SORT)
7803 S_simplify_sort(pTHX_ OP *o)
7806 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7812 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7814 if (!(o->op_flags & OPf_STACKED))
7816 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7817 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7818 kid = kUNOP->op_first; /* get past null */
7819 if (kid->op_type != OP_SCOPE)
7821 kid = kLISTOP->op_last; /* get past scope */
7822 switch(kid->op_type) {
7830 k = kid; /* remember this node*/
7831 if (kBINOP->op_first->op_type != OP_RV2SV)
7833 kid = kBINOP->op_first; /* get past cmp */
7834 if (kUNOP->op_first->op_type != OP_GV)
7836 kid = kUNOP->op_first; /* get past rv2sv */
7838 if (GvSTASH(gv) != PL_curstash)
7840 gvname = GvNAME(gv);
7841 if (*gvname == 'a' && gvname[1] == '\0')
7843 else if (*gvname == 'b' && gvname[1] == '\0')
7848 kid = k; /* back to cmp */
7849 if (kBINOP->op_last->op_type != OP_RV2SV)
7851 kid = kBINOP->op_last; /* down to 2nd arg */
7852 if (kUNOP->op_first->op_type != OP_GV)
7854 kid = kUNOP->op_first; /* get past rv2sv */
7856 if (GvSTASH(gv) != PL_curstash)
7858 gvname = GvNAME(gv);
7860 ? !(*gvname == 'a' && gvname[1] == '\0')
7861 : !(*gvname == 'b' && gvname[1] == '\0'))
7863 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7865 o->op_private |= OPpSORT_DESCEND;
7866 if (k->op_type == OP_NCMP)
7867 o->op_private |= OPpSORT_NUMERIC;
7868 if (k->op_type == OP_I_NCMP)
7869 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7870 kid = cLISTOPo->op_first->op_sibling;
7871 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7873 op_getmad(kid,o,'S'); /* then delete it */
7875 op_free(kid); /* then delete it */
7880 Perl_ck_split(pTHX_ OP *o)
7885 PERL_ARGS_ASSERT_CK_SPLIT;
7887 if (o->op_flags & OPf_STACKED)
7888 return no_fh_allowed(o);
7890 kid = cLISTOPo->op_first;
7891 if (kid->op_type != OP_NULL)
7892 Perl_croak(aTHX_ "panic: ck_split");
7893 kid = kid->op_sibling;
7894 op_free(cLISTOPo->op_first);
7895 cLISTOPo->op_first = kid;
7897 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7898 cLISTOPo->op_last = kid; /* There was only one element previously */
7901 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7902 OP * const sibl = kid->op_sibling;
7903 kid->op_sibling = 0;
7904 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7905 if (cLISTOPo->op_first == cLISTOPo->op_last)
7906 cLISTOPo->op_last = kid;
7907 cLISTOPo->op_first = kid;
7908 kid->op_sibling = sibl;
7911 kid->op_type = OP_PUSHRE;
7912 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7914 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7915 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7916 "Use of /g modifier is meaningless in split");
7919 if (!kid->op_sibling)
7920 append_elem(OP_SPLIT, o, newDEFSVOP());
7922 kid = kid->op_sibling;
7925 if (!kid->op_sibling)
7926 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7927 assert(kid->op_sibling);
7929 kid = kid->op_sibling;
7932 if (kid->op_sibling)
7933 return too_many_arguments(o,OP_DESC(o));
7939 Perl_ck_join(pTHX_ OP *o)
7941 const OP * const kid = cLISTOPo->op_first->op_sibling;
7943 PERL_ARGS_ASSERT_CK_JOIN;
7945 if (kid && kid->op_type == OP_MATCH) {
7946 if (ckWARN(WARN_SYNTAX)) {
7947 const REGEXP *re = PM_GETRE(kPMOP);
7948 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7949 const STRLEN len = re ? RX_PRELEN(re) : 6;
7950 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7951 "/%.*s/ should probably be written as \"%.*s\"",
7952 (int)len, pmstr, (int)len, pmstr);
7959 Perl_ck_subr(pTHX_ OP *o)
7962 OP *prev = ((cUNOPo->op_first->op_sibling)
7963 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7964 OP *o2 = prev->op_sibling;
7966 const char *proto = NULL;
7967 const char *proto_end = NULL;
7972 I32 contextclass = 0;
7973 const char *e = NULL;
7976 PERL_ARGS_ASSERT_CK_SUBR;
7978 o->op_private |= OPpENTERSUB_HASTARG;
7979 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7980 if (cvop->op_type == OP_RV2CV) {
7982 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7983 op_null(cvop); /* disable rv2cv */
7984 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7985 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7986 GV *gv = cGVOPx_gv(tmpop);
7989 tmpop->op_private |= OPpEARLY_CV;
7993 namegv = CvANON(cv) ? gv : CvGV(cv);
7994 proto = SvPV(MUTABLE_SV(cv), len);
7995 proto_end = proto + len;
8000 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8001 if (o2->op_type == OP_CONST)
8002 o2->op_private &= ~OPpCONST_STRICT;
8003 else if (o2->op_type == OP_LIST) {
8004 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8005 if (sib && sib->op_type == OP_CONST)
8006 sib->op_private &= ~OPpCONST_STRICT;
8009 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8010 if (PERLDB_SUB && PL_curstash != PL_debstash)
8011 o->op_private |= OPpENTERSUB_DB;
8012 while (o2 != cvop) {
8014 if (PL_madskills && o2->op_type == OP_STUB) {
8015 o2 = o2->op_sibling;
8018 if (PL_madskills && o2->op_type == OP_NULL)
8019 o3 = ((UNOP*)o2)->op_first;
8023 if (proto >= proto_end)
8024 return too_many_arguments(o, gv_ename(namegv));
8032 /* _ must be at the end */
8033 if (proto[1] && proto[1] != ';')
8048 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8050 arg == 1 ? "block or sub {}" : "sub {}",
8051 gv_ename(namegv), o3);
8054 /* '*' allows any scalar type, including bareword */
8057 if (o3->op_type == OP_RV2GV)
8058 goto wrapref; /* autoconvert GLOB -> GLOBref */
8059 else if (o3->op_type == OP_CONST)
8060 o3->op_private &= ~OPpCONST_STRICT;
8061 else if (o3->op_type == OP_ENTERSUB) {
8062 /* accidental subroutine, revert to bareword */
8063 OP *gvop = ((UNOP*)o3)->op_first;
8064 if (gvop && gvop->op_type == OP_NULL) {
8065 gvop = ((UNOP*)gvop)->op_first;
8067 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8070 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8071 (gvop = ((UNOP*)gvop)->op_first) &&
8072 gvop->op_type == OP_GV)
8074 GV * const gv = cGVOPx_gv(gvop);
8075 OP * const sibling = o2->op_sibling;
8076 SV * const n = newSVpvs("");
8078 OP * const oldo2 = o2;
8082 gv_fullname4(n, gv, "", FALSE);
8083 o2 = newSVOP(OP_CONST, 0, n);
8084 op_getmad(oldo2,o2,'O');
8085 prev->op_sibling = o2;
8086 o2->op_sibling = sibling;
8102 if (contextclass++ == 0) {
8103 e = strchr(proto, ']');
8104 if (!e || e == proto)
8113 const char *p = proto;
8114 const char *const end = proto;
8116 while (*--p != '[') {}
8117 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8119 gv_ename(namegv), o3);
8124 if (o3->op_type == OP_RV2GV)
8127 bad_type(arg, "symbol", gv_ename(namegv), o3);
8130 if (o3->op_type == OP_ENTERSUB)
8133 bad_type(arg, "subroutine entry", gv_ename(namegv),
8137 if (o3->op_type == OP_RV2SV ||
8138 o3->op_type == OP_PADSV ||
8139 o3->op_type == OP_HELEM ||
8140 o3->op_type == OP_AELEM)
8143 bad_type(arg, "scalar", gv_ename(namegv), o3);
8146 if (o3->op_type == OP_RV2AV ||
8147 o3->op_type == OP_PADAV)
8150 bad_type(arg, "array", gv_ename(namegv), o3);
8153 if (o3->op_type == OP_RV2HV ||
8154 o3->op_type == OP_PADHV)
8157 bad_type(arg, "hash", gv_ename(namegv), o3);
8162 OP* const sib = kid->op_sibling;
8163 kid->op_sibling = 0;
8164 o2 = newUNOP(OP_REFGEN, 0, kid);
8165 o2->op_sibling = sib;
8166 prev->op_sibling = o2;
8168 if (contextclass && e) {
8183 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8184 gv_ename(namegv), SVfARG(cv));
8189 mod(o2, OP_ENTERSUB);
8191 o2 = o2->op_sibling;
8193 if (o2 == cvop && proto && *proto == '_') {
8194 /* generate an access to $_ */
8196 o2->op_sibling = prev->op_sibling;
8197 prev->op_sibling = o2; /* instead of cvop */
8199 if (proto && !optional && proto_end > proto &&
8200 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8201 return too_few_arguments(o, gv_ename(namegv));
8204 OP * const oldo = o;
8208 o=newSVOP(OP_CONST, 0, newSViv(0));
8209 op_getmad(oldo,o,'O');
8215 Perl_ck_svconst(pTHX_ OP *o)
8217 PERL_ARGS_ASSERT_CK_SVCONST;
8218 PERL_UNUSED_CONTEXT;
8219 SvREADONLY_on(cSVOPo->op_sv);
8224 Perl_ck_chdir(pTHX_ OP *o)
8226 if (o->op_flags & OPf_KIDS) {
8227 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8229 if (kid && kid->op_type == OP_CONST &&
8230 (kid->op_private & OPpCONST_BARE))
8232 o->op_flags |= OPf_SPECIAL;
8233 kid->op_private &= ~OPpCONST_STRICT;
8240 Perl_ck_trunc(pTHX_ OP *o)
8242 PERL_ARGS_ASSERT_CK_TRUNC;
8244 if (o->op_flags & OPf_KIDS) {
8245 SVOP *kid = (SVOP*)cUNOPo->op_first;
8247 if (kid->op_type == OP_NULL)
8248 kid = (SVOP*)kid->op_sibling;
8249 if (kid && kid->op_type == OP_CONST &&
8250 (kid->op_private & OPpCONST_BARE))
8252 o->op_flags |= OPf_SPECIAL;
8253 kid->op_private &= ~OPpCONST_STRICT;
8260 Perl_ck_unpack(pTHX_ OP *o)
8262 OP *kid = cLISTOPo->op_first;
8264 PERL_ARGS_ASSERT_CK_UNPACK;
8266 if (kid->op_sibling) {
8267 kid = kid->op_sibling;
8268 if (!kid->op_sibling)
8269 kid->op_sibling = newDEFSVOP();
8275 Perl_ck_substr(pTHX_ OP *o)
8277 PERL_ARGS_ASSERT_CK_SUBSTR;
8280 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8281 OP *kid = cLISTOPo->op_first;
8283 if (kid->op_type == OP_NULL)
8284 kid = kid->op_sibling;
8286 kid->op_flags |= OPf_MOD;
8293 Perl_ck_each(pTHX_ OP *o)
8296 OP *kid = cLISTOPo->op_first;
8298 PERL_ARGS_ASSERT_CK_EACH;
8300 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8301 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8302 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8303 o->op_type = new_type;
8304 o->op_ppaddr = PL_ppaddr[new_type];
8306 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8307 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8309 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8315 /* A peephole optimizer. We visit the ops in the order they're to execute.
8316 * See the comments at the top of this file for more details about when
8317 * peep() is called */
8320 Perl_peep(pTHX_ register OP *o)
8323 register OP* oldop = NULL;
8325 if (!o || o->op_opt)
8329 SAVEVPTR(PL_curcop);
8330 for (; o; o = o->op_next) {
8333 /* By default, this op has now been optimised. A couple of cases below
8334 clear this again. */
8337 switch (o->op_type) {
8340 PL_curcop = ((COP*)o); /* for warnings */
8344 if (cSVOPo->op_private & OPpCONST_STRICT)
8345 no_bareword_allowed(o);
8348 case OP_METHOD_NAMED:
8349 /* Relocate sv to the pad for thread safety.
8350 * Despite being a "constant", the SV is written to,
8351 * for reference counts, sv_upgrade() etc. */
8353 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8354 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8355 /* If op_sv is already a PADTMP then it is being used by
8356 * some pad, so make a copy. */
8357 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8358 SvREADONLY_on(PAD_SVl(ix));
8359 SvREFCNT_dec(cSVOPo->op_sv);
8361 else if (o->op_type != OP_METHOD_NAMED
8362 && cSVOPo->op_sv == &PL_sv_undef) {
8363 /* PL_sv_undef is hack - it's unsafe to store it in the
8364 AV that is the pad, because av_fetch treats values of
8365 PL_sv_undef as a "free" AV entry and will merrily
8366 replace them with a new SV, causing pad_alloc to think
8367 that this pad slot is free. (When, clearly, it is not)
8369 SvOK_off(PAD_SVl(ix));
8370 SvPADTMP_on(PAD_SVl(ix));
8371 SvREADONLY_on(PAD_SVl(ix));
8374 SvREFCNT_dec(PAD_SVl(ix));
8375 SvPADTMP_on(cSVOPo->op_sv);
8376 PAD_SETSV(ix, cSVOPo->op_sv);
8377 /* XXX I don't know how this isn't readonly already. */
8378 SvREADONLY_on(PAD_SVl(ix));
8380 cSVOPo->op_sv = NULL;
8387 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8388 if (o->op_next->op_private & OPpTARGET_MY) {
8389 if (o->op_flags & OPf_STACKED) /* chained concats */
8390 break; /* ignore_optimization */
8392 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8393 o->op_targ = o->op_next->op_targ;
8394 o->op_next->op_targ = 0;
8395 o->op_private |= OPpTARGET_MY;
8398 op_null(o->op_next);
8402 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8403 break; /* Scalar stub must produce undef. List stub is noop */
8407 if (o->op_targ == OP_NEXTSTATE
8408 || o->op_targ == OP_DBSTATE)
8410 PL_curcop = ((COP*)o);
8412 /* XXX: We avoid setting op_seq here to prevent later calls
8413 to peep() from mistakenly concluding that optimisation
8414 has already occurred. This doesn't fix the real problem,
8415 though (See 20010220.007). AMS 20010719 */
8416 /* op_seq functionality is now replaced by op_opt */
8423 if (oldop && o->op_next) {
8424 oldop->op_next = o->op_next;
8432 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8433 OP* const pop = (o->op_type == OP_PADAV) ?
8434 o->op_next : o->op_next->op_next;
8436 if (pop && pop->op_type == OP_CONST &&
8437 ((PL_op = pop->op_next)) &&
8438 pop->op_next->op_type == OP_AELEM &&
8439 !(pop->op_next->op_private &
8440 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8441 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8446 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8447 no_bareword_allowed(pop);
8448 if (o->op_type == OP_GV)
8449 op_null(o->op_next);
8450 op_null(pop->op_next);
8452 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8453 o->op_next = pop->op_next->op_next;
8454 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8455 o->op_private = (U8)i;
8456 if (o->op_type == OP_GV) {
8461 o->op_flags |= OPf_SPECIAL;
8462 o->op_type = OP_AELEMFAST;
8467 if (o->op_next->op_type == OP_RV2SV) {
8468 if (!(o->op_next->op_private & OPpDEREF)) {
8469 op_null(o->op_next);
8470 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8472 o->op_next = o->op_next->op_next;
8473 o->op_type = OP_GVSV;
8474 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8477 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8478 GV * const gv = cGVOPo_gv;
8479 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8480 /* XXX could check prototype here instead of just carping */
8481 SV * const sv = sv_newmortal();
8482 gv_efullname3(sv, gv, NULL);
8483 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8484 "%"SVf"() called too early to check prototype",
8488 else if (o->op_next->op_type == OP_READLINE
8489 && o->op_next->op_next->op_type == OP_CONCAT
8490 && (o->op_next->op_next->op_flags & OPf_STACKED))
8492 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8493 o->op_type = OP_RCATLINE;
8494 o->op_flags |= OPf_STACKED;
8495 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8496 op_null(o->op_next->op_next);
8497 op_null(o->op_next);
8513 while (cLOGOP->op_other->op_type == OP_NULL)
8514 cLOGOP->op_other = cLOGOP->op_other->op_next;
8515 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8520 while (cLOOP->op_redoop->op_type == OP_NULL)
8521 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8522 peep(cLOOP->op_redoop);
8523 while (cLOOP->op_nextop->op_type == OP_NULL)
8524 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8525 peep(cLOOP->op_nextop);
8526 while (cLOOP->op_lastop->op_type == OP_NULL)
8527 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8528 peep(cLOOP->op_lastop);
8532 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8533 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8534 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8535 cPMOP->op_pmstashstartu.op_pmreplstart
8536 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8537 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8541 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8542 && ckWARN(WARN_SYNTAX))
8544 if (o->op_next->op_sibling) {
8545 const OPCODE type = o->op_next->op_sibling->op_type;
8546 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8547 const line_t oldline = CopLINE(PL_curcop);
8548 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8549 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8550 "Statement unlikely to be reached");
8551 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8552 "\t(Maybe you meant system() when you said exec()?)\n");
8553 CopLINE_set(PL_curcop, oldline);
8564 const char *key = NULL;
8567 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8570 /* Make the CONST have a shared SV */
8571 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8572 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8573 key = SvPV_const(sv, keylen);
8574 lexname = newSVpvn_share(key,
8575 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8581 if ((o->op_private & (OPpLVAL_INTRO)))
8584 rop = (UNOP*)((BINOP*)o)->op_first;
8585 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8587 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8588 if (!SvPAD_TYPED(lexname))
8590 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8591 if (!fields || !GvHV(*fields))
8593 key = SvPV_const(*svp, keylen);
8594 if (!hv_fetch(GvHV(*fields), key,
8595 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8597 Perl_croak(aTHX_ "No such class field \"%s\" "
8598 "in variable %s of type %s",
8599 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8612 SVOP *first_key_op, *key_op;
8614 if ((o->op_private & (OPpLVAL_INTRO))
8615 /* I bet there's always a pushmark... */
8616 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8617 /* hmmm, no optimization if list contains only one key. */
8619 rop = (UNOP*)((LISTOP*)o)->op_last;
8620 if (rop->op_type != OP_RV2HV)
8622 if (rop->op_first->op_type == OP_PADSV)
8623 /* @$hash{qw(keys here)} */
8624 rop = (UNOP*)rop->op_first;
8626 /* @{$hash}{qw(keys here)} */
8627 if (rop->op_first->op_type == OP_SCOPE
8628 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8630 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8636 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8637 if (!SvPAD_TYPED(lexname))
8639 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8640 if (!fields || !GvHV(*fields))
8642 /* Again guessing that the pushmark can be jumped over.... */
8643 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8644 ->op_first->op_sibling;
8645 for (key_op = first_key_op; key_op;
8646 key_op = (SVOP*)key_op->op_sibling) {
8647 if (key_op->op_type != OP_CONST)
8649 svp = cSVOPx_svp(key_op);
8650 key = SvPV_const(*svp, keylen);
8651 if (!hv_fetch(GvHV(*fields), key,
8652 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8654 Perl_croak(aTHX_ "No such class field \"%s\" "
8655 "in variable %s of type %s",
8656 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8663 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8667 /* check that RHS of sort is a single plain array */
8668 OP *oright = cUNOPo->op_first;
8669 if (!oright || oright->op_type != OP_PUSHMARK)
8672 /* reverse sort ... can be optimised. */
8673 if (!cUNOPo->op_sibling) {
8674 /* Nothing follows us on the list. */
8675 OP * const reverse = o->op_next;
8677 if (reverse->op_type == OP_REVERSE &&
8678 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8679 OP * const pushmark = cUNOPx(reverse)->op_first;
8680 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8681 && (cUNOPx(pushmark)->op_sibling == o)) {
8682 /* reverse -> pushmark -> sort */
8683 o->op_private |= OPpSORT_REVERSE;
8685 pushmark->op_next = oright->op_next;
8691 /* make @a = sort @a act in-place */
8693 oright = cUNOPx(oright)->op_sibling;
8696 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8697 oright = cUNOPx(oright)->op_sibling;
8701 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8702 || oright->op_next != o
8703 || (oright->op_private & OPpLVAL_INTRO)
8707 /* o2 follows the chain of op_nexts through the LHS of the
8708 * assign (if any) to the aassign op itself */
8710 if (!o2 || o2->op_type != OP_NULL)
8713 if (!o2 || o2->op_type != OP_PUSHMARK)
8716 if (o2 && o2->op_type == OP_GV)
8719 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8720 || (o2->op_private & OPpLVAL_INTRO)
8725 if (!o2 || o2->op_type != OP_NULL)
8728 if (!o2 || o2->op_type != OP_AASSIGN
8729 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8732 /* check that the sort is the first arg on RHS of assign */
8734 o2 = cUNOPx(o2)->op_first;
8735 if (!o2 || o2->op_type != OP_NULL)
8737 o2 = cUNOPx(o2)->op_first;
8738 if (!o2 || o2->op_type != OP_PUSHMARK)
8740 if (o2->op_sibling != o)
8743 /* check the array is the same on both sides */
8744 if (oleft->op_type == OP_RV2AV) {
8745 if (oright->op_type != OP_RV2AV
8746 || !cUNOPx(oright)->op_first
8747 || cUNOPx(oright)->op_first->op_type != OP_GV
8748 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8749 cGVOPx_gv(cUNOPx(oright)->op_first)
8753 else if (oright->op_type != OP_PADAV
8754 || oright->op_targ != oleft->op_targ
8758 /* transfer MODishness etc from LHS arg to RHS arg */
8759 oright->op_flags = oleft->op_flags;
8760 o->op_private |= OPpSORT_INPLACE;
8762 /* excise push->gv->rv2av->null->aassign */
8763 o2 = o->op_next->op_next;
8764 op_null(o2); /* PUSHMARK */
8766 if (o2->op_type == OP_GV) {
8767 op_null(o2); /* GV */
8770 op_null(o2); /* RV2AV or PADAV */
8771 o2 = o2->op_next->op_next;
8772 op_null(o2); /* AASSIGN */
8774 o->op_next = o2->op_next;
8780 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8782 LISTOP *enter, *exlist;
8784 enter = (LISTOP *) o->op_next;
8787 if (enter->op_type == OP_NULL) {
8788 enter = (LISTOP *) enter->op_next;
8792 /* for $a (...) will have OP_GV then OP_RV2GV here.
8793 for (...) just has an OP_GV. */
8794 if (enter->op_type == OP_GV) {
8795 gvop = (OP *) enter;
8796 enter = (LISTOP *) enter->op_next;
8799 if (enter->op_type == OP_RV2GV) {
8800 enter = (LISTOP *) enter->op_next;
8806 if (enter->op_type != OP_ENTERITER)
8809 iter = enter->op_next;
8810 if (!iter || iter->op_type != OP_ITER)
8813 expushmark = enter->op_first;
8814 if (!expushmark || expushmark->op_type != OP_NULL
8815 || expushmark->op_targ != OP_PUSHMARK)
8818 exlist = (LISTOP *) expushmark->op_sibling;
8819 if (!exlist || exlist->op_type != OP_NULL
8820 || exlist->op_targ != OP_LIST)
8823 if (exlist->op_last != o) {
8824 /* Mmm. Was expecting to point back to this op. */
8827 theirmark = exlist->op_first;
8828 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8831 if (theirmark->op_sibling != o) {
8832 /* There's something between the mark and the reverse, eg
8833 for (1, reverse (...))
8838 ourmark = ((LISTOP *)o)->op_first;
8839 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8842 ourlast = ((LISTOP *)o)->op_last;
8843 if (!ourlast || ourlast->op_next != o)
8846 rv2av = ourmark->op_sibling;
8847 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8848 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8849 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8850 /* We're just reversing a single array. */
8851 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8852 enter->op_flags |= OPf_STACKED;
8855 /* We don't have control over who points to theirmark, so sacrifice
8857 theirmark->op_next = ourmark->op_next;
8858 theirmark->op_flags = ourmark->op_flags;
8859 ourlast->op_next = gvop ? gvop : (OP *) enter;
8862 enter->op_private |= OPpITER_REVERSED;
8863 iter->op_private |= OPpITER_REVERSED;
8870 UNOP *refgen, *rv2cv;
8873 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8876 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8879 rv2gv = ((BINOP *)o)->op_last;
8880 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8883 refgen = (UNOP *)((BINOP *)o)->op_first;
8885 if (!refgen || refgen->op_type != OP_REFGEN)
8888 exlist = (LISTOP *)refgen->op_first;
8889 if (!exlist || exlist->op_type != OP_NULL
8890 || exlist->op_targ != OP_LIST)
8893 if (exlist->op_first->op_type != OP_PUSHMARK)
8896 rv2cv = (UNOP*)exlist->op_last;
8898 if (rv2cv->op_type != OP_RV2CV)
8901 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8902 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8903 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8905 o->op_private |= OPpASSIGN_CV_TO_GV;
8906 rv2gv->op_private |= OPpDONT_INIT_GV;
8907 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8915 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8916 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8926 Perl_custom_op_name(pTHX_ const OP* o)
8929 const IV index = PTR2IV(o->op_ppaddr);
8933 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8935 if (!PL_custom_op_names) /* This probably shouldn't happen */
8936 return (char *)PL_op_name[OP_CUSTOM];
8938 keysv = sv_2mortal(newSViv(index));
8940 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8942 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8944 return SvPV_nolen(HeVAL(he));
8948 Perl_custom_op_desc(pTHX_ const OP* o)
8951 const IV index = PTR2IV(o->op_ppaddr);
8955 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8957 if (!PL_custom_op_descs)
8958 return (char *)PL_op_desc[OP_CUSTOM];
8960 keysv = sv_2mortal(newSViv(index));
8962 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8964 return (char *)PL_op_desc[OP_CUSTOM];
8966 return SvPV_nolen(HeVAL(he));
8971 /* Efficient sub that returns a constant scalar value. */
8973 const_sv_xsub(pTHX_ CV* cv)
8980 Perl_croak(aTHX_ "usage: %s::%s()",
8981 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8985 ST(0) = MUTABLE_SV(XSANY.any_ptr);
8991 * c-indentation-style: bsd
8993 * indent-tabs-mode: t
8996 * ex: set ts=8 sts=4 sw=4 noet: