3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints> on the save stack, so that it
95 will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifndef PERL_SLAB_SIZE
108 #define PERL_SLAB_SIZE 2048
112 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
115 * To make incrementing use count easy PL_OpSlab is an I32 *
116 * To make inserting the link to slab PL_OpPtr is I32 **
117 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
118 * Add an overhead for pointer to slab and round up as a number of pointers
120 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
121 if ((PL_OpSpace -= sz) < 0) {
122 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
126 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
127 /* We reserve the 0'th I32 sized chunk as a use count */
128 PL_OpSlab = (I32 *) PL_OpPtr;
129 /* Reduce size by the use count word, and by the size we need.
130 * Latter is to mimic the '-=' in the if() above
132 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
133 /* Allocation pointer starts at the top.
134 Theory: because we build leaves before trunk allocating at end
135 means that at run time access is cache friendly upward
137 PL_OpPtr += PERL_SLAB_SIZE;
139 assert( PL_OpSpace >= 0 );
140 /* Move the allocation pointer down */
142 assert( PL_OpPtr > (I32 **) PL_OpSlab );
143 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
144 (*PL_OpSlab)++; /* Increment use count of slab */
145 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
146 assert( *PL_OpSlab > 0 );
147 return (void *)(PL_OpPtr + 1);
151 Perl_Slab_Free(pTHX_ void *op)
153 I32 * const * const ptr = (I32 **) op;
154 I32 * const slab = ptr[-1];
155 assert( ptr-1 > (I32 **) slab );
156 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
158 if (--(*slab) == 0) {
160 # define PerlMemShared PerlMem
163 PerlMemShared_free(slab);
164 if (slab == PL_OpSlab) {
171 * In the following definition, the ", (OP*)0" is just to make the compiler
172 * think the expression is of the right type: croak actually does a Siglongjmp.
174 #define CHECKOP(type,o) \
175 ((PL_op_mask && PL_op_mask[type]) \
176 ? ( op_free((OP*)o), \
177 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
179 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
181 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
184 S_gv_ename(pTHX_ GV *gv)
186 SV* const tmpsv = sv_newmortal();
187 gv_efullname3(tmpsv, gv, NULL);
188 return SvPV_nolen_const(tmpsv);
192 S_no_fh_allowed(pTHX_ OP *o)
194 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
200 S_too_few_arguments(pTHX_ OP *o, const char *name)
202 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
207 S_too_many_arguments(pTHX_ OP *o, const char *name)
209 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
214 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
216 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
217 (int)n, name, t, OP_DESC(kid)));
221 S_no_bareword_allowed(pTHX_ const OP *o)
224 return; /* various ok barewords are hidden in extra OP_NULL */
225 qerror(Perl_mess(aTHX_
226 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
230 /* "register" allocation */
233 Perl_allocmy(pTHX_ char *name)
237 const bool is_our = (PL_in_my == KEY_our);
239 /* complain about "my $<special_var>" etc etc */
243 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
244 (name[1] == '_' && (*name == '$' || name[2]))))
246 /* name[2] is true if strlen(name) > 2 */
247 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
248 /* 1999-02-27 mjd@plover.com */
250 p = strchr(name, '\0');
251 /* The next block assumes the buffer is at least 205 chars
252 long. At present, it's always at least 256 chars. */
254 strcpy(name+200, "...");
260 /* Move everything else down one character */
261 for (; p-name > 2; p--)
263 name[2] = toCTRL(name[1]);
266 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
269 /* check for duplicate declaration */
270 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
272 if (PL_in_my_stash && *name != '$') {
273 yyerror(Perl_form(aTHX_
274 "Can't declare class for non-scalar %s in \"%s\"",
275 name, is_our ? "our" : "my"));
278 /* allocate a spare slot and store the name in that slot */
280 off = pad_add_name(name,
283 /* $_ is always in main::, even with our */
284 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
295 Perl_op_free(pTHX_ OP *o)
300 if (!o || o->op_static)
304 if (o->op_private & OPpREFCOUNTED) {
315 refcnt = OpREFCNT_dec(o);
326 if (o->op_flags & OPf_KIDS) {
327 register OP *kid, *nextkid;
328 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
329 nextkid = kid->op_sibling; /* Get before next freeing kid */
334 type = (OPCODE)o->op_targ;
336 /* COP* is not cleared by op_clear() so that we may track line
337 * numbers etc even after null() */
338 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
343 #ifdef DEBUG_LEAKING_SCALARS
350 Perl_op_clear(pTHX_ OP *o)
355 /* if (o->op_madprop && o->op_madprop->mad_next)
357 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
358 "modification of a read only value" for a reason I can't fathom why.
359 It's the "" stringification of $_, where $_ was set to '' in a foreach
360 loop, but it defies simplification into a small test case.
361 However, commenting them out has caused ext/List/Util/t/weak.t to fail
364 mad_free(o->op_madprop);
370 switch (o->op_type) {
371 case OP_NULL: /* Was holding old type, if any. */
372 if (PL_madskills && o->op_targ != OP_NULL) {
373 o->op_type = o->op_targ;
377 case OP_ENTEREVAL: /* Was holding hints. */
381 if (!(o->op_flags & OPf_REF)
382 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
388 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
389 /* not an OP_PADAV replacement */
391 if (cPADOPo->op_padix > 0) {
392 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
393 * may still exist on the pad */
394 pad_swipe(cPADOPo->op_padix, TRUE);
395 cPADOPo->op_padix = 0;
398 SvREFCNT_dec(cSVOPo->op_sv);
399 cSVOPo->op_sv = NULL;
403 case OP_METHOD_NAMED:
405 SvREFCNT_dec(cSVOPo->op_sv);
406 cSVOPo->op_sv = NULL;
409 Even if op_clear does a pad_free for the target of the op,
410 pad_free doesn't actually remove the sv that exists in the pad;
411 instead it lives on. This results in that it could be reused as
412 a target later on when the pad was reallocated.
415 pad_swipe(o->op_targ,1);
424 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
428 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
429 SvREFCNT_dec(cSVOPo->op_sv);
430 cSVOPo->op_sv = NULL;
433 Safefree(cPVOPo->op_pv);
434 cPVOPo->op_pv = NULL;
438 op_free(cPMOPo->op_pmreplroot);
442 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
443 /* No GvIN_PAD_off here, because other references may still
444 * exist on the pad */
445 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
448 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
455 HV * const pmstash = PmopSTASH(cPMOPo);
456 if (pmstash && !SvIS_FREED(pmstash)) {
457 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
459 PMOP *pmop = (PMOP*) mg->mg_obj;
460 PMOP *lastpmop = NULL;
462 if (cPMOPo == pmop) {
464 lastpmop->op_pmnext = pmop->op_pmnext;
466 mg->mg_obj = (SV*) pmop->op_pmnext;
470 pmop = pmop->op_pmnext;
474 PmopSTASH_free(cPMOPo);
476 cPMOPo->op_pmreplroot = NULL;
477 /* we use the "SAFE" version of the PM_ macros here
478 * since sv_clean_all might release some PMOPs
479 * after PL_regex_padav has been cleared
480 * and the clearing of PL_regex_padav needs to
481 * happen before sv_clean_all
483 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
484 PM_SETRE_SAFE(cPMOPo, NULL);
486 if(PL_regex_pad) { /* We could be in destruction */
487 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
488 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
489 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
496 if (o->op_targ > 0) {
497 pad_free(o->op_targ);
503 S_cop_free(pTHX_ COP* cop)
505 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
508 if (! specialWARN(cop->cop_warnings))
509 PerlMemShared_free(cop->cop_warnings);
510 if (! specialCopIO(cop->cop_io)) {
514 SvREFCNT_dec(cop->cop_io);
517 Perl_refcounted_he_free(aTHX_ cop->cop_hints);
521 Perl_op_null(pTHX_ OP *o)
524 if (o->op_type == OP_NULL)
528 o->op_targ = o->op_type;
529 o->op_type = OP_NULL;
530 o->op_ppaddr = PL_ppaddr[OP_NULL];
534 Perl_op_refcnt_lock(pTHX)
542 Perl_op_refcnt_unlock(pTHX)
549 /* Contextualizers */
551 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
554 Perl_linklist(pTHX_ OP *o)
561 /* establish postfix order */
562 first = cUNOPo->op_first;
565 o->op_next = LINKLIST(first);
568 if (kid->op_sibling) {
569 kid->op_next = LINKLIST(kid->op_sibling);
570 kid = kid->op_sibling;
584 Perl_scalarkids(pTHX_ OP *o)
586 if (o && o->op_flags & OPf_KIDS) {
588 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
595 S_scalarboolean(pTHX_ OP *o)
598 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
599 if (ckWARN(WARN_SYNTAX)) {
600 const line_t oldline = CopLINE(PL_curcop);
602 if (PL_copline != NOLINE)
603 CopLINE_set(PL_curcop, PL_copline);
604 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
605 CopLINE_set(PL_curcop, oldline);
612 Perl_scalar(pTHX_ OP *o)
617 /* assumes no premature commitment */
618 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
619 || o->op_type == OP_RETURN)
624 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
626 switch (o->op_type) {
628 scalar(cBINOPo->op_first);
633 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
637 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
638 if (!kPMOP->op_pmreplroot)
639 deprecate_old("implicit split to @_");
647 if (o->op_flags & OPf_KIDS) {
648 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
654 kid = cLISTOPo->op_first;
656 while ((kid = kid->op_sibling)) {
662 WITH_THR(PL_curcop = &PL_compiling);
667 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
673 WITH_THR(PL_curcop = &PL_compiling);
676 if (ckWARN(WARN_VOID))
677 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
683 Perl_scalarvoid(pTHX_ OP *o)
687 const char* useless = NULL;
691 /* trailing mad null ops don't count as "there" for void processing */
693 o->op_type != OP_NULL &&
695 o->op_sibling->op_type == OP_NULL)
698 for (sib = o->op_sibling;
699 sib && sib->op_type == OP_NULL;
700 sib = sib->op_sibling) ;
706 if (o->op_type == OP_NEXTSTATE
707 || o->op_type == OP_SETSTATE
708 || o->op_type == OP_DBSTATE
709 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
710 || o->op_targ == OP_SETSTATE
711 || o->op_targ == OP_DBSTATE)))
712 PL_curcop = (COP*)o; /* for warning below */
714 /* assumes no premature commitment */
715 want = o->op_flags & OPf_WANT;
716 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
717 || o->op_type == OP_RETURN)
722 if ((o->op_private & OPpTARGET_MY)
723 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
725 return scalar(o); /* As if inside SASSIGN */
728 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
730 switch (o->op_type) {
732 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
736 if (o->op_flags & OPf_STACKED)
740 if (o->op_private == 4)
812 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
813 useless = OP_DESC(o);
817 kid = cUNOPo->op_first;
818 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
819 kid->op_type != OP_TRANS) {
822 useless = "negative pattern binding (!~)";
829 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
830 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
831 useless = "a variable";
836 if (cSVOPo->op_private & OPpCONST_STRICT)
837 no_bareword_allowed(o);
839 if (ckWARN(WARN_VOID)) {
840 useless = "a constant";
841 if (o->op_private & OPpCONST_ARYBASE)
843 /* don't warn on optimised away booleans, eg
844 * use constant Foo, 5; Foo || print; */
845 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
847 /* the constants 0 and 1 are permitted as they are
848 conventionally used as dummies in constructs like
849 1 while some_condition_with_side_effects; */
850 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
852 else if (SvPOK(sv)) {
853 /* perl4's way of mixing documentation and code
854 (before the invention of POD) was based on a
855 trick to mix nroff and perl code. The trick was
856 built upon these three nroff macros being used in
857 void context. The pink camel has the details in
858 the script wrapman near page 319. */
859 const char * const maybe_macro = SvPVX_const(sv);
860 if (strnEQ(maybe_macro, "di", 2) ||
861 strnEQ(maybe_macro, "ds", 2) ||
862 strnEQ(maybe_macro, "ig", 2))
867 op_null(o); /* don't execute or even remember it */
871 o->op_type = OP_PREINC; /* pre-increment is faster */
872 o->op_ppaddr = PL_ppaddr[OP_PREINC];
876 o->op_type = OP_PREDEC; /* pre-decrement is faster */
877 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
881 o->op_type = OP_I_PREINC; /* pre-increment is faster */
882 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
886 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
887 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
896 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
901 if (o->op_flags & OPf_STACKED)
908 if (!(o->op_flags & OPf_KIDS))
919 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
926 /* all requires must return a boolean value */
927 o->op_flags &= ~OPf_WANT;
932 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
933 if (!kPMOP->op_pmreplroot)
934 deprecate_old("implicit split to @_");
938 if (useless && ckWARN(WARN_VOID))
939 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
944 Perl_listkids(pTHX_ OP *o)
946 if (o && o->op_flags & OPf_KIDS) {
948 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
955 Perl_list(pTHX_ OP *o)
960 /* assumes no premature commitment */
961 if (!o || (o->op_flags & OPf_WANT) || PL_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 o; /* As if inside SASSIGN */
973 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
975 switch (o->op_type) {
978 list(cBINOPo->op_first);
983 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
991 if (!(o->op_flags & OPf_KIDS))
993 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
994 list(cBINOPo->op_first);
995 return gen_constant_list(o);
1002 kid = cLISTOPo->op_first;
1004 while ((kid = kid->op_sibling)) {
1005 if (kid->op_sibling)
1010 WITH_THR(PL_curcop = &PL_compiling);
1014 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1015 if (kid->op_sibling)
1020 WITH_THR(PL_curcop = &PL_compiling);
1023 /* all requires must return a boolean value */
1024 o->op_flags &= ~OPf_WANT;
1031 Perl_scalarseq(pTHX_ OP *o)
1035 if (o->op_type == OP_LINESEQ ||
1036 o->op_type == OP_SCOPE ||
1037 o->op_type == OP_LEAVE ||
1038 o->op_type == OP_LEAVETRY)
1041 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1042 if (kid->op_sibling) {
1046 PL_curcop = &PL_compiling;
1048 o->op_flags &= ~OPf_PARENS;
1049 if (PL_hints & HINT_BLOCK_SCOPE)
1050 o->op_flags |= OPf_PARENS;
1053 o = newOP(OP_STUB, 0);
1058 S_modkids(pTHX_ OP *o, I32 type)
1060 if (o && o->op_flags & OPf_KIDS) {
1062 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1068 /* Propagate lvalue ("modifiable") context to an op and its children.
1069 * 'type' represents the context type, roughly based on the type of op that
1070 * would do the modifying, although local() is represented by OP_NULL.
1071 * It's responsible for detecting things that can't be modified, flag
1072 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1073 * might have to vivify a reference in $x), and so on.
1075 * For example, "$a+1 = 2" would cause mod() to be called with o being
1076 * OP_ADD and type being OP_SASSIGN, and would output an error.
1080 Perl_mod(pTHX_ OP *o, I32 type)
1084 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1087 if (!o || PL_error_count)
1090 if ((o->op_private & OPpTARGET_MY)
1091 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1096 switch (o->op_type) {
1102 if (!(o->op_private & OPpCONST_ARYBASE))
1105 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1106 CopARYBASE_set(&PL_compiling,
1107 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1111 SAVECOPARYBASE(&PL_compiling);
1112 CopARYBASE_set(&PL_compiling, 0);
1114 else if (type == OP_REFGEN)
1117 Perl_croak(aTHX_ "That use of $[ is unsupported");
1120 if (o->op_flags & OPf_PARENS || PL_madskills)
1124 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1125 !(o->op_flags & OPf_STACKED)) {
1126 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1127 /* The default is to set op_private to the number of children,
1128 which for a UNOP such as RV2CV is always 1. And w're using
1129 the bit for a flag in RV2CV, so we need it clear. */
1130 o->op_private &= ~1;
1131 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1132 assert(cUNOPo->op_first->op_type == OP_NULL);
1133 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1136 else if (o->op_private & OPpENTERSUB_NOMOD)
1138 else { /* lvalue subroutine call */
1139 o->op_private |= OPpLVAL_INTRO;
1140 PL_modcount = RETURN_UNLIMITED_NUMBER;
1141 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1142 /* Backward compatibility mode: */
1143 o->op_private |= OPpENTERSUB_INARGS;
1146 else { /* Compile-time error message: */
1147 OP *kid = cUNOPo->op_first;
1151 if (kid->op_type == OP_PUSHMARK)
1153 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1155 "panic: unexpected lvalue entersub "
1156 "args: type/targ %ld:%"UVuf,
1157 (long)kid->op_type, (UV)kid->op_targ);
1158 kid = kLISTOP->op_first;
1160 while (kid->op_sibling)
1161 kid = kid->op_sibling;
1162 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1164 if (kid->op_type == OP_METHOD_NAMED
1165 || kid->op_type == OP_METHOD)
1169 NewOp(1101, newop, 1, UNOP);
1170 newop->op_type = OP_RV2CV;
1171 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1172 newop->op_first = NULL;
1173 newop->op_next = (OP*)newop;
1174 kid->op_sibling = (OP*)newop;
1175 newop->op_private |= OPpLVAL_INTRO;
1176 newop->op_private &= ~1;
1180 if (kid->op_type != OP_RV2CV)
1182 "panic: unexpected lvalue entersub "
1183 "entry via type/targ %ld:%"UVuf,
1184 (long)kid->op_type, (UV)kid->op_targ);
1185 kid->op_private |= OPpLVAL_INTRO;
1186 break; /* Postpone until runtime */
1190 kid = kUNOP->op_first;
1191 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1192 kid = kUNOP->op_first;
1193 if (kid->op_type == OP_NULL)
1195 "Unexpected constant lvalue entersub "
1196 "entry via type/targ %ld:%"UVuf,
1197 (long)kid->op_type, (UV)kid->op_targ);
1198 if (kid->op_type != OP_GV) {
1199 /* Restore RV2CV to check lvalueness */
1201 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1202 okid->op_next = kid->op_next;
1203 kid->op_next = okid;
1206 okid->op_next = NULL;
1207 okid->op_type = OP_RV2CV;
1209 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1210 okid->op_private |= OPpLVAL_INTRO;
1211 okid->op_private &= ~1;
1215 cv = GvCV(kGVOP_gv);
1225 /* grep, foreach, subcalls, refgen */
1226 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1228 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1229 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1231 : (o->op_type == OP_ENTERSUB
1232 ? "non-lvalue subroutine call"
1234 type ? PL_op_desc[type] : "local"));
1248 case OP_RIGHT_SHIFT:
1257 if (!(o->op_flags & OPf_STACKED))
1264 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1270 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1271 PL_modcount = RETURN_UNLIMITED_NUMBER;
1272 return o; /* Treat \(@foo) like ordinary list. */
1276 if (scalar_mod_type(o, type))
1278 ref(cUNOPo->op_first, o->op_type);
1282 if (type == OP_LEAVESUBLV)
1283 o->op_private |= OPpMAYBE_LVSUB;
1289 PL_modcount = RETURN_UNLIMITED_NUMBER;
1292 ref(cUNOPo->op_first, o->op_type);
1297 PL_hints |= HINT_BLOCK_SCOPE;
1312 PL_modcount = RETURN_UNLIMITED_NUMBER;
1313 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1314 return o; /* Treat \(@foo) like ordinary list. */
1315 if (scalar_mod_type(o, type))
1317 if (type == OP_LEAVESUBLV)
1318 o->op_private |= OPpMAYBE_LVSUB;
1322 if (!type) /* local() */
1323 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1324 PAD_COMPNAME_PV(o->op_targ));
1332 if (type != OP_SASSIGN)
1336 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1341 if (type == OP_LEAVESUBLV)
1342 o->op_private |= OPpMAYBE_LVSUB;
1344 pad_free(o->op_targ);
1345 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1346 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1347 if (o->op_flags & OPf_KIDS)
1348 mod(cBINOPo->op_first->op_sibling, type);
1353 ref(cBINOPo->op_first, o->op_type);
1354 if (type == OP_ENTERSUB &&
1355 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1356 o->op_private |= OPpLVAL_DEFER;
1357 if (type == OP_LEAVESUBLV)
1358 o->op_private |= OPpMAYBE_LVSUB;
1368 if (o->op_flags & OPf_KIDS)
1369 mod(cLISTOPo->op_last, type);
1374 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1376 else if (!(o->op_flags & OPf_KIDS))
1378 if (o->op_targ != OP_LIST) {
1379 mod(cBINOPo->op_first, type);
1385 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1390 if (type != OP_LEAVESUBLV)
1392 break; /* mod()ing was handled by ck_return() */
1395 /* [20011101.069] File test operators interpret OPf_REF to mean that
1396 their argument is a filehandle; thus \stat(".") should not set
1398 if (type == OP_REFGEN &&
1399 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1402 if (type != OP_LEAVESUBLV)
1403 o->op_flags |= OPf_MOD;
1405 if (type == OP_AASSIGN || type == OP_SASSIGN)
1406 o->op_flags |= OPf_SPECIAL|OPf_REF;
1407 else if (!type) { /* local() */
1410 o->op_private |= OPpLVAL_INTRO;
1411 o->op_flags &= ~OPf_SPECIAL;
1412 PL_hints |= HINT_BLOCK_SCOPE;
1417 if (ckWARN(WARN_SYNTAX)) {
1418 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1419 "Useless localization of %s", OP_DESC(o));
1423 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1424 && type != OP_LEAVESUBLV)
1425 o->op_flags |= OPf_REF;
1430 S_scalar_mod_type(const OP *o, I32 type)
1434 if (o->op_type == OP_RV2GV)
1458 case OP_RIGHT_SHIFT:
1477 S_is_handle_constructor(const OP *o, I32 numargs)
1479 switch (o->op_type) {
1487 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1500 Perl_refkids(pTHX_ OP *o, I32 type)
1502 if (o && o->op_flags & OPf_KIDS) {
1504 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1511 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1516 if (!o || PL_error_count)
1519 switch (o->op_type) {
1521 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1522 !(o->op_flags & OPf_STACKED)) {
1523 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1524 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1525 assert(cUNOPo->op_first->op_type == OP_NULL);
1526 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1527 o->op_flags |= OPf_SPECIAL;
1528 o->op_private &= ~1;
1533 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1534 doref(kid, type, set_op_ref);
1537 if (type == OP_DEFINED)
1538 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1539 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1542 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1543 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1544 : type == OP_RV2HV ? OPpDEREF_HV
1546 o->op_flags |= OPf_MOD;
1551 o->op_flags |= OPf_MOD; /* XXX ??? */
1557 o->op_flags |= OPf_REF;
1560 if (type == OP_DEFINED)
1561 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1562 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1568 o->op_flags |= OPf_REF;
1573 if (!(o->op_flags & OPf_KIDS))
1575 doref(cBINOPo->op_first, type, set_op_ref);
1579 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1580 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1581 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1582 : type == OP_RV2HV ? OPpDEREF_HV
1584 o->op_flags |= OPf_MOD;
1594 if (!(o->op_flags & OPf_KIDS))
1596 doref(cLISTOPo->op_last, type, set_op_ref);
1606 S_dup_attrlist(pTHX_ OP *o)
1611 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1612 * where the first kid is OP_PUSHMARK and the remaining ones
1613 * are OP_CONST. We need to push the OP_CONST values.
1615 if (o->op_type == OP_CONST)
1616 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1618 else if (o->op_type == OP_NULL)
1622 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1624 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1625 if (o->op_type == OP_CONST)
1626 rop = append_elem(OP_LIST, rop,
1627 newSVOP(OP_CONST, o->op_flags,
1628 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1635 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1640 /* fake up C<use attributes $pkg,$rv,@attrs> */
1641 ENTER; /* need to protect against side-effects of 'use' */
1643 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1645 #define ATTRSMODULE "attributes"
1646 #define ATTRSMODULE_PM "attributes.pm"
1649 /* Don't force the C<use> if we don't need it. */
1650 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1651 if (svp && *svp != &PL_sv_undef)
1652 /*EMPTY*/; /* already in %INC */
1654 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1655 newSVpvs(ATTRSMODULE), NULL);
1658 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1659 newSVpvs(ATTRSMODULE),
1661 prepend_elem(OP_LIST,
1662 newSVOP(OP_CONST, 0, stashsv),
1663 prepend_elem(OP_LIST,
1664 newSVOP(OP_CONST, 0,
1666 dup_attrlist(attrs))));
1672 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1675 OP *pack, *imop, *arg;
1681 assert(target->op_type == OP_PADSV ||
1682 target->op_type == OP_PADHV ||
1683 target->op_type == OP_PADAV);
1685 /* Ensure that attributes.pm is loaded. */
1686 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1688 /* Need package name for method call. */
1689 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1691 /* Build up the real arg-list. */
1692 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1694 arg = newOP(OP_PADSV, 0);
1695 arg->op_targ = target->op_targ;
1696 arg = prepend_elem(OP_LIST,
1697 newSVOP(OP_CONST, 0, stashsv),
1698 prepend_elem(OP_LIST,
1699 newUNOP(OP_REFGEN, 0,
1700 mod(arg, OP_REFGEN)),
1701 dup_attrlist(attrs)));
1703 /* Fake up a method call to import */
1704 meth = newSVpvs_share("import");
1705 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1706 append_elem(OP_LIST,
1707 prepend_elem(OP_LIST, pack, list(arg)),
1708 newSVOP(OP_METHOD_NAMED, 0, meth)));
1709 imop->op_private |= OPpENTERSUB_NOMOD;
1711 /* Combine the ops. */
1712 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1716 =notfor apidoc apply_attrs_string
1718 Attempts to apply a list of attributes specified by the C<attrstr> and
1719 C<len> arguments to the subroutine identified by the C<cv> argument which
1720 is expected to be associated with the package identified by the C<stashpv>
1721 argument (see L<attributes>). It gets this wrong, though, in that it
1722 does not correctly identify the boundaries of the individual attribute
1723 specifications within C<attrstr>. This is not really intended for the
1724 public API, but has to be listed here for systems such as AIX which
1725 need an explicit export list for symbols. (It's called from XS code
1726 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1727 to respect attribute syntax properly would be welcome.
1733 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1734 const char *attrstr, STRLEN len)
1739 len = strlen(attrstr);
1743 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1745 const char * const sstr = attrstr;
1746 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1747 attrs = append_elem(OP_LIST, attrs,
1748 newSVOP(OP_CONST, 0,
1749 newSVpvn(sstr, attrstr-sstr)));
1753 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1754 newSVpvs(ATTRSMODULE),
1755 NULL, prepend_elem(OP_LIST,
1756 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1757 prepend_elem(OP_LIST,
1758 newSVOP(OP_CONST, 0,
1764 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1769 if (!o || PL_error_count)
1773 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1774 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1778 if (type == OP_LIST) {
1780 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1781 my_kid(kid, attrs, imopsp);
1782 } else if (type == OP_UNDEF
1788 } else if (type == OP_RV2SV || /* "our" declaration */
1790 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1791 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1792 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1793 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1795 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1797 PL_in_my_stash = NULL;
1798 apply_attrs(GvSTASH(gv),
1799 (type == OP_RV2SV ? GvSV(gv) :
1800 type == OP_RV2AV ? (SV*)GvAV(gv) :
1801 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1804 o->op_private |= OPpOUR_INTRO;
1807 else if (type != OP_PADSV &&
1810 type != OP_PUSHMARK)
1812 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1814 PL_in_my == KEY_our ? "our" : "my"));
1817 else if (attrs && type != OP_PUSHMARK) {
1821 PL_in_my_stash = NULL;
1823 /* check for C<my Dog $spot> when deciding package */
1824 stash = PAD_COMPNAME_TYPE(o->op_targ);
1826 stash = PL_curstash;
1827 apply_attrs_my(stash, o, attrs, imopsp);
1829 o->op_flags |= OPf_MOD;
1830 o->op_private |= OPpLVAL_INTRO;
1835 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1839 int maybe_scalar = 0;
1841 /* [perl #17376]: this appears to be premature, and results in code such as
1842 C< our(%x); > executing in list mode rather than void mode */
1844 if (o->op_flags & OPf_PARENS)
1854 o = my_kid(o, attrs, &rops);
1856 if (maybe_scalar && o->op_type == OP_PADSV) {
1857 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1858 o->op_private |= OPpLVAL_INTRO;
1861 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1864 PL_in_my_stash = NULL;
1869 Perl_my(pTHX_ OP *o)
1871 return my_attrs(o, NULL);
1875 Perl_sawparens(pTHX_ OP *o)
1877 PERL_UNUSED_CONTEXT;
1879 o->op_flags |= OPf_PARENS;
1884 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1889 if ( (left->op_type == OP_RV2AV ||
1890 left->op_type == OP_RV2HV ||
1891 left->op_type == OP_PADAV ||
1892 left->op_type == OP_PADHV)
1893 && ckWARN(WARN_MISC))
1895 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1896 right->op_type == OP_TRANS)
1897 ? right->op_type : OP_MATCH];
1898 const char * const sample = ((left->op_type == OP_RV2AV ||
1899 left->op_type == OP_PADAV)
1900 ? "@array" : "%hash");
1901 Perl_warner(aTHX_ packWARN(WARN_MISC),
1902 "Applying %s to %s will act on scalar(%s)",
1903 desc, sample, sample);
1906 if (right->op_type == OP_CONST &&
1907 cSVOPx(right)->op_private & OPpCONST_BARE &&
1908 cSVOPx(right)->op_private & OPpCONST_STRICT)
1910 no_bareword_allowed(right);
1913 ismatchop = right->op_type == OP_MATCH ||
1914 right->op_type == OP_SUBST ||
1915 right->op_type == OP_TRANS;
1916 if (ismatchop && right->op_private & OPpTARGET_MY) {
1918 right->op_private &= ~OPpTARGET_MY;
1920 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1921 right->op_flags |= OPf_STACKED;
1922 if (right->op_type != OP_MATCH &&
1923 ! (right->op_type == OP_TRANS &&
1924 right->op_private & OPpTRANS_IDENTICAL))
1925 left = mod(left, right->op_type);
1926 if (right->op_type == OP_TRANS)
1927 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1929 o = prepend_elem(right->op_type, scalar(left), right);
1931 return newUNOP(OP_NOT, 0, scalar(o));
1935 return bind_match(type, left,
1936 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1940 Perl_invert(pTHX_ OP *o)
1944 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1948 Perl_scope(pTHX_ OP *o)
1952 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1953 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1954 o->op_type = OP_LEAVE;
1955 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1957 else if (o->op_type == OP_LINESEQ) {
1959 o->op_type = OP_SCOPE;
1960 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1961 kid = ((LISTOP*)o)->op_first;
1962 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1965 /* The following deals with things like 'do {1 for 1}' */
1966 kid = kid->op_sibling;
1968 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1973 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1979 Perl_block_start(pTHX_ int full)
1982 const int retval = PL_savestack_ix;
1983 pad_block_start(full);
1985 PL_hints &= ~HINT_BLOCK_SCOPE;
1986 SAVECOPWARNINGS(&PL_compiling);
1987 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1988 SAVESPTR(PL_compiling.cop_io);
1989 if (! specialCopIO(PL_compiling.cop_io)) {
1990 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1991 SAVEFREESV(PL_compiling.cop_io) ;
1997 Perl_block_end(pTHX_ I32 floor, OP *seq)
2000 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2001 OP* const retval = scalarseq(seq);
2003 CopHINTS_set(&PL_compiling, PL_hints);
2005 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2014 const I32 offset = pad_findmy("$_");
2015 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2016 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2019 OP * const o = newOP(OP_PADSV, 0);
2020 o->op_targ = offset;
2026 Perl_newPROG(pTHX_ OP *o)
2032 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2033 ((PL_in_eval & EVAL_KEEPERR)
2034 ? OPf_SPECIAL : 0), o);
2035 PL_eval_start = linklist(PL_eval_root);
2036 PL_eval_root->op_private |= OPpREFCOUNTED;
2037 OpREFCNT_set(PL_eval_root, 1);
2038 PL_eval_root->op_next = 0;
2039 CALL_PEEP(PL_eval_start);
2042 if (o->op_type == OP_STUB) {
2043 PL_comppad_name = 0;
2048 PL_main_root = scope(sawparens(scalarvoid(o)));
2049 PL_curcop = &PL_compiling;
2050 PL_main_start = LINKLIST(PL_main_root);
2051 PL_main_root->op_private |= OPpREFCOUNTED;
2052 OpREFCNT_set(PL_main_root, 1);
2053 PL_main_root->op_next = 0;
2054 CALL_PEEP(PL_main_start);
2057 /* Register with debugger */
2059 CV * const cv = get_cv("DB::postponed", FALSE);
2063 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2065 call_sv((SV*)cv, G_DISCARD);
2072 Perl_localize(pTHX_ OP *o, I32 lex)
2075 if (o->op_flags & OPf_PARENS)
2076 /* [perl #17376]: this appears to be premature, and results in code such as
2077 C< our(%x); > executing in list mode rather than void mode */
2084 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2085 && ckWARN(WARN_PARENTHESIS))
2087 char *s = PL_bufptr;
2090 /* some heuristics to detect a potential error */
2091 while (*s && (strchr(", \t\n", *s)))
2095 if (*s && strchr("@$%*", *s) && *++s
2096 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2099 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2101 while (*s && (strchr(", \t\n", *s)))
2107 if (sigil && (*s == ';' || *s == '=')) {
2108 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2109 "Parentheses missing around \"%s\" list",
2110 lex ? (PL_in_my == KEY_our ? "our" : "my")
2118 o = mod(o, OP_NULL); /* a bit kludgey */
2120 PL_in_my_stash = NULL;
2125 Perl_jmaybe(pTHX_ OP *o)
2127 if (o->op_type == OP_LIST) {
2129 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2130 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2136 Perl_fold_constants(pTHX_ register OP *o)
2141 I32 type = o->op_type;
2148 if (PL_opargs[type] & OA_RETSCALAR)
2150 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2151 o->op_targ = pad_alloc(type, SVs_PADTMP);
2153 /* integerize op, unless it happens to be C<-foo>.
2154 * XXX should pp_i_negate() do magic string negation instead? */
2155 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2156 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2157 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2159 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2162 if (!(PL_opargs[type] & OA_FOLDCONST))
2167 /* XXX might want a ck_negate() for this */
2168 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2179 /* XXX what about the numeric ops? */
2180 if (PL_hints & HINT_LOCALE)
2185 goto nope; /* Don't try to run w/ errors */
2187 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2188 if ((curop->op_type != OP_CONST ||
2189 (curop->op_private & OPpCONST_BARE)) &&
2190 curop->op_type != OP_LIST &&
2191 curop->op_type != OP_SCALAR &&
2192 curop->op_type != OP_NULL &&
2193 curop->op_type != OP_PUSHMARK)
2199 curop = LINKLIST(o);
2200 old_next = o->op_next;
2204 oldscope = PL_scopestack_ix;
2205 create_eval_scope(G_FAKINGEVAL);
2212 sv = *(PL_stack_sp--);
2213 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2214 pad_swipe(o->op_targ, FALSE);
2215 else if (SvTEMP(sv)) { /* grab mortal temp? */
2216 SvREFCNT_inc_simple_void(sv);
2221 /* Something tried to die. Abandon constant folding. */
2222 /* Pretend the error never happened. */
2223 sv_setpvn(ERRSV,"",0);
2224 o->op_next = old_next;
2228 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2229 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2234 if (PL_scopestack_ix > oldscope)
2235 delete_eval_scope();
2244 if (type == OP_RV2GV)
2245 newop = newGVOP(OP_GV, 0, (GV*)sv);
2247 newop = newSVOP(OP_CONST, 0, sv);
2248 op_getmad(o,newop,'f');
2256 Perl_gen_constant_list(pTHX_ register OP *o)
2260 const I32 oldtmps_floor = PL_tmps_floor;
2264 return o; /* Don't attempt to run with errors */
2266 PL_op = curop = LINKLIST(o);
2273 PL_tmps_floor = oldtmps_floor;
2275 o->op_type = OP_RV2AV;
2276 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2277 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2278 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2279 o->op_opt = 0; /* needs to be revisited in peep() */
2280 curop = ((UNOP*)o)->op_first;
2281 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2283 op_getmad(curop,o,'O');
2292 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2295 if (!o || o->op_type != OP_LIST)
2296 o = newLISTOP(OP_LIST, 0, o, NULL);
2298 o->op_flags &= ~OPf_WANT;
2300 if (!(PL_opargs[type] & OA_MARK))
2301 op_null(cLISTOPo->op_first);
2303 o->op_type = (OPCODE)type;
2304 o->op_ppaddr = PL_ppaddr[type];
2305 o->op_flags |= flags;
2307 o = CHECKOP(type, o);
2308 if (o->op_type != (unsigned)type)
2311 return fold_constants(o);
2314 /* List constructors */
2317 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2325 if (first->op_type != (unsigned)type
2326 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2328 return newLISTOP(type, 0, first, last);
2331 if (first->op_flags & OPf_KIDS)
2332 ((LISTOP*)first)->op_last->op_sibling = last;
2334 first->op_flags |= OPf_KIDS;
2335 ((LISTOP*)first)->op_first = last;
2337 ((LISTOP*)first)->op_last = last;
2342 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2350 if (first->op_type != (unsigned)type)
2351 return prepend_elem(type, (OP*)first, (OP*)last);
2353 if (last->op_type != (unsigned)type)
2354 return append_elem(type, (OP*)first, (OP*)last);
2356 first->op_last->op_sibling = last->op_first;
2357 first->op_last = last->op_last;
2358 first->op_flags |= (last->op_flags & OPf_KIDS);
2361 if (last->op_first && first->op_madprop) {
2362 MADPROP *mp = last->op_first->op_madprop;
2364 while (mp->mad_next)
2366 mp->mad_next = first->op_madprop;
2369 last->op_first->op_madprop = first->op_madprop;
2372 first->op_madprop = last->op_madprop;
2373 last->op_madprop = 0;
2382 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2390 if (last->op_type == (unsigned)type) {
2391 if (type == OP_LIST) { /* already a PUSHMARK there */
2392 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2393 ((LISTOP*)last)->op_first->op_sibling = first;
2394 if (!(first->op_flags & OPf_PARENS))
2395 last->op_flags &= ~OPf_PARENS;
2398 if (!(last->op_flags & OPf_KIDS)) {
2399 ((LISTOP*)last)->op_last = first;
2400 last->op_flags |= OPf_KIDS;
2402 first->op_sibling = ((LISTOP*)last)->op_first;
2403 ((LISTOP*)last)->op_first = first;
2405 last->op_flags |= OPf_KIDS;
2409 return newLISTOP(type, 0, first, last);
2417 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2420 Newxz(tk, 1, TOKEN);
2421 tk->tk_type = (OPCODE)optype;
2422 tk->tk_type = 12345;
2424 tk->tk_mad = madprop;
2429 Perl_token_free(pTHX_ TOKEN* tk)
2431 if (tk->tk_type != 12345)
2433 mad_free(tk->tk_mad);
2438 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2442 if (tk->tk_type != 12345) {
2443 Perl_warner(aTHX_ packWARN(WARN_MISC),
2444 "Invalid TOKEN object ignored");
2451 /* faked up qw list? */
2453 tm->mad_type == MAD_SV &&
2454 SvPVX((SV*)tm->mad_val)[0] == 'q')
2461 /* pretend constant fold didn't happen? */
2462 if (mp->mad_key == 'f' &&
2463 (o->op_type == OP_CONST ||
2464 o->op_type == OP_GV) )
2466 token_getmad(tk,(OP*)mp->mad_val,slot);
2480 if (mp->mad_key == 'X')
2481 mp->mad_key = slot; /* just change the first one */
2491 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2500 /* pretend constant fold didn't happen? */
2501 if (mp->mad_key == 'f' &&
2502 (o->op_type == OP_CONST ||
2503 o->op_type == OP_GV) )
2505 op_getmad(from,(OP*)mp->mad_val,slot);
2512 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2515 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2521 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2530 /* pretend constant fold didn't happen? */
2531 if (mp->mad_key == 'f' &&
2532 (o->op_type == OP_CONST ||
2533 o->op_type == OP_GV) )
2535 op_getmad(from,(OP*)mp->mad_val,slot);
2542 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2545 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2549 PerlIO_printf(PerlIO_stderr(),
2550 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2556 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2574 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2578 addmad(tm, &(o->op_madprop), slot);
2582 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2603 Perl_newMADsv(pTHX_ char key, SV* sv)
2605 return newMADPROP(key, MAD_SV, sv, 0);
2609 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2612 Newxz(mp, 1, MADPROP);
2615 mp->mad_vlen = vlen;
2616 mp->mad_type = type;
2618 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2623 Perl_mad_free(pTHX_ MADPROP* mp)
2625 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2629 mad_free(mp->mad_next);
2630 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2631 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2632 switch (mp->mad_type) {
2636 Safefree((char*)mp->mad_val);
2639 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2640 op_free((OP*)mp->mad_val);
2643 sv_free((SV*)mp->mad_val);
2646 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2655 Perl_newNULLLIST(pTHX)
2657 return newOP(OP_STUB, 0);
2661 Perl_force_list(pTHX_ OP *o)
2663 if (!o || o->op_type != OP_LIST)
2664 o = newLISTOP(OP_LIST, 0, o, NULL);
2670 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2675 NewOp(1101, listop, 1, LISTOP);
2677 listop->op_type = (OPCODE)type;
2678 listop->op_ppaddr = PL_ppaddr[type];
2681 listop->op_flags = (U8)flags;
2685 else if (!first && last)
2688 first->op_sibling = last;
2689 listop->op_first = first;
2690 listop->op_last = last;
2691 if (type == OP_LIST) {
2692 OP* const pushop = newOP(OP_PUSHMARK, 0);
2693 pushop->op_sibling = first;
2694 listop->op_first = pushop;
2695 listop->op_flags |= OPf_KIDS;
2697 listop->op_last = pushop;
2700 return CHECKOP(type, listop);
2704 Perl_newOP(pTHX_ I32 type, I32 flags)
2708 NewOp(1101, o, 1, OP);
2709 o->op_type = (OPCODE)type;
2710 o->op_ppaddr = PL_ppaddr[type];
2711 o->op_flags = (U8)flags;
2714 o->op_private = (U8)(0 | (flags >> 8));
2715 if (PL_opargs[type] & OA_RETSCALAR)
2717 if (PL_opargs[type] & OA_TARGET)
2718 o->op_targ = pad_alloc(type, SVs_PADTMP);
2719 return CHECKOP(type, o);
2723 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2729 first = newOP(OP_STUB, 0);
2730 if (PL_opargs[type] & OA_MARK)
2731 first = force_list(first);
2733 NewOp(1101, unop, 1, UNOP);
2734 unop->op_type = (OPCODE)type;
2735 unop->op_ppaddr = PL_ppaddr[type];
2736 unop->op_first = first;
2737 unop->op_flags = (U8)(flags | OPf_KIDS);
2738 unop->op_private = (U8)(1 | (flags >> 8));
2739 unop = (UNOP*) CHECKOP(type, unop);
2743 return fold_constants((OP *) unop);
2747 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2751 NewOp(1101, binop, 1, BINOP);
2754 first = newOP(OP_NULL, 0);
2756 binop->op_type = (OPCODE)type;
2757 binop->op_ppaddr = PL_ppaddr[type];
2758 binop->op_first = first;
2759 binop->op_flags = (U8)(flags | OPf_KIDS);
2762 binop->op_private = (U8)(1 | (flags >> 8));
2765 binop->op_private = (U8)(2 | (flags >> 8));
2766 first->op_sibling = last;
2769 binop = (BINOP*)CHECKOP(type, binop);
2770 if (binop->op_next || binop->op_type != (OPCODE)type)
2773 binop->op_last = binop->op_first->op_sibling;
2775 return fold_constants((OP *)binop);
2778 static int uvcompare(const void *a, const void *b)
2779 __attribute__nonnull__(1)
2780 __attribute__nonnull__(2)
2781 __attribute__pure__;
2782 static int uvcompare(const void *a, const void *b)
2784 if (*((const UV *)a) < (*(const UV *)b))
2786 if (*((const UV *)a) > (*(const UV *)b))
2788 if (*((const UV *)a+1) < (*(const UV *)b+1))
2790 if (*((const UV *)a+1) > (*(const UV *)b+1))
2796 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2799 SV * const tstr = ((SVOP*)expr)->op_sv;
2800 SV * const rstr = ((SVOP*)repl)->op_sv;
2803 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2804 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2808 register short *tbl;
2810 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2811 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2812 I32 del = o->op_private & OPpTRANS_DELETE;
2813 PL_hints |= HINT_BLOCK_SCOPE;
2816 o->op_private |= OPpTRANS_FROM_UTF;
2819 o->op_private |= OPpTRANS_TO_UTF;
2821 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2822 SV* const listsv = newSVpvs("# comment\n");
2824 const U8* tend = t + tlen;
2825 const U8* rend = r + rlen;
2839 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2840 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2843 const U32 flags = UTF8_ALLOW_DEFAULT;
2847 t = tsave = bytes_to_utf8(t, &len);
2850 if (!to_utf && rlen) {
2852 r = rsave = bytes_to_utf8(r, &len);
2856 /* There are several snags with this code on EBCDIC:
2857 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2858 2. scan_const() in toke.c has encoded chars in native encoding which makes
2859 ranges at least in EBCDIC 0..255 range the bottom odd.
2863 U8 tmpbuf[UTF8_MAXBYTES+1];
2866 Newx(cp, 2*tlen, UV);
2868 transv = newSVpvs("");
2870 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2872 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2874 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2878 cp[2*i+1] = cp[2*i];
2882 qsort(cp, i, 2*sizeof(UV), uvcompare);
2883 for (j = 0; j < i; j++) {
2885 diff = val - nextmin;
2887 t = uvuni_to_utf8(tmpbuf,nextmin);
2888 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2890 U8 range_mark = UTF_TO_NATIVE(0xff);
2891 t = uvuni_to_utf8(tmpbuf, val - 1);
2892 sv_catpvn(transv, (char *)&range_mark, 1);
2893 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2900 t = uvuni_to_utf8(tmpbuf,nextmin);
2901 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2903 U8 range_mark = UTF_TO_NATIVE(0xff);
2904 sv_catpvn(transv, (char *)&range_mark, 1);
2906 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2907 UNICODE_ALLOW_SUPER);
2908 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2909 t = (const U8*)SvPVX_const(transv);
2910 tlen = SvCUR(transv);
2914 else if (!rlen && !del) {
2915 r = t; rlen = tlen; rend = tend;
2918 if ((!rlen && !del) || t == r ||
2919 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2921 o->op_private |= OPpTRANS_IDENTICAL;
2925 while (t < tend || tfirst <= tlast) {
2926 /* see if we need more "t" chars */
2927 if (tfirst > tlast) {
2928 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2930 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2932 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2939 /* now see if we need more "r" chars */
2940 if (rfirst > rlast) {
2942 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2944 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2946 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2955 rfirst = rlast = 0xffffffff;
2959 /* now see which range will peter our first, if either. */
2960 tdiff = tlast - tfirst;
2961 rdiff = rlast - rfirst;
2968 if (rfirst == 0xffffffff) {
2969 diff = tdiff; /* oops, pretend rdiff is infinite */
2971 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2972 (long)tfirst, (long)tlast);
2974 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2978 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2979 (long)tfirst, (long)(tfirst + diff),
2982 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2983 (long)tfirst, (long)rfirst);
2985 if (rfirst + diff > max)
2986 max = rfirst + diff;
2988 grows = (tfirst < rfirst &&
2989 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3001 else if (max > 0xff)
3006 Safefree(cPVOPo->op_pv);
3007 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3008 SvREFCNT_dec(listsv);
3009 SvREFCNT_dec(transv);
3011 if (!del && havefinal && rlen)
3012 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3013 newSVuv((UV)final), 0);
3016 o->op_private |= OPpTRANS_GROWS;
3022 op_getmad(expr,o,'e');
3023 op_getmad(repl,o,'r');
3031 tbl = (short*)cPVOPo->op_pv;
3033 Zero(tbl, 256, short);
3034 for (i = 0; i < (I32)tlen; i++)
3036 for (i = 0, j = 0; i < 256; i++) {
3038 if (j >= (I32)rlen) {
3047 if (i < 128 && r[j] >= 128)
3057 o->op_private |= OPpTRANS_IDENTICAL;
3059 else if (j >= (I32)rlen)
3062 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3063 tbl[0x100] = (short)(rlen - j);
3064 for (i=0; i < (I32)rlen - j; i++)
3065 tbl[0x101+i] = r[j+i];
3069 if (!rlen && !del) {
3072 o->op_private |= OPpTRANS_IDENTICAL;
3074 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3075 o->op_private |= OPpTRANS_IDENTICAL;
3077 for (i = 0; i < 256; i++)
3079 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3080 if (j >= (I32)rlen) {
3082 if (tbl[t[i]] == -1)
3088 if (tbl[t[i]] == -1) {
3089 if (t[i] < 128 && r[j] >= 128)
3096 o->op_private |= OPpTRANS_GROWS;
3098 op_getmad(expr,o,'e');
3099 op_getmad(repl,o,'r');
3109 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3114 NewOp(1101, pmop, 1, PMOP);
3115 pmop->op_type = (OPCODE)type;
3116 pmop->op_ppaddr = PL_ppaddr[type];
3117 pmop->op_flags = (U8)flags;
3118 pmop->op_private = (U8)(0 | (flags >> 8));
3120 if (PL_hints & HINT_RE_TAINT)
3121 pmop->op_pmpermflags |= PMf_RETAINT;
3122 if (PL_hints & HINT_LOCALE)
3123 pmop->op_pmpermflags |= PMf_LOCALE;
3124 pmop->op_pmflags = pmop->op_pmpermflags;
3127 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3128 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3129 pmop->op_pmoffset = SvIV(repointer);
3130 SvREPADTMP_off(repointer);
3131 sv_setiv(repointer,0);
3133 SV * const repointer = newSViv(0);
3134 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3135 pmop->op_pmoffset = av_len(PL_regex_padav);
3136 PL_regex_pad = AvARRAY(PL_regex_padav);
3140 /* link into pm list */
3141 if (type != OP_TRANS && PL_curstash) {
3142 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3145 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3147 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3148 mg->mg_obj = (SV*)pmop;
3149 PmopSTASH_set(pmop,PL_curstash);
3152 return CHECKOP(type, pmop);
3155 /* Given some sort of match op o, and an expression expr containing a
3156 * pattern, either compile expr into a regex and attach it to o (if it's
3157 * constant), or convert expr into a runtime regcomp op sequence (if it's
3160 * isreg indicates that the pattern is part of a regex construct, eg
3161 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3162 * split "pattern", which aren't. In the former case, expr will be a list
3163 * if the pattern contains more than one term (eg /a$b/) or if it contains
3164 * a replacement, ie s/// or tr///.
3168 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3173 I32 repl_has_vars = 0;
3177 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3178 /* last element in list is the replacement; pop it */
3180 repl = cLISTOPx(expr)->op_last;
3181 kid = cLISTOPx(expr)->op_first;
3182 while (kid->op_sibling != repl)
3183 kid = kid->op_sibling;
3184 kid->op_sibling = NULL;
3185 cLISTOPx(expr)->op_last = kid;
3188 if (isreg && expr->op_type == OP_LIST &&
3189 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3191 /* convert single element list to element */
3192 OP* const oe = expr;
3193 expr = cLISTOPx(oe)->op_first->op_sibling;
3194 cLISTOPx(oe)->op_first->op_sibling = NULL;
3195 cLISTOPx(oe)->op_last = NULL;
3199 if (o->op_type == OP_TRANS) {
3200 return pmtrans(o, expr, repl);
3203 reglist = isreg && expr->op_type == OP_LIST;
3207 PL_hints |= HINT_BLOCK_SCOPE;
3210 if (expr->op_type == OP_CONST) {
3212 SV * const pat = ((SVOP*)expr)->op_sv;
3213 const char *p = SvPV_const(pat, plen);
3214 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3215 U32 was_readonly = SvREADONLY(pat);
3219 sv_force_normal_flags(pat, 0);
3220 assert(!SvREADONLY(pat));
3223 SvREADONLY_off(pat);
3227 sv_setpvn(pat, "\\s+", 3);
3229 SvFLAGS(pat) |= was_readonly;
3231 p = SvPV_const(pat, plen);
3232 pm->op_pmflags |= PMf_SKIPWHITE;
3235 pm->op_pmdynflags |= PMdf_UTF8;
3236 /* FIXME - can we make this function take const char * args? */
3237 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3238 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3239 pm->op_pmflags |= PMf_WHITE;
3241 op_getmad(expr,(OP*)pm,'e');
3247 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3248 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3250 : OP_REGCMAYBE),0,expr);
3252 NewOp(1101, rcop, 1, LOGOP);
3253 rcop->op_type = OP_REGCOMP;
3254 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3255 rcop->op_first = scalar(expr);
3256 rcop->op_flags |= OPf_KIDS
3257 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3258 | (reglist ? OPf_STACKED : 0);
3259 rcop->op_private = 1;
3262 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3264 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3267 /* establish postfix order */
3268 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3270 rcop->op_next = expr;
3271 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3274 rcop->op_next = LINKLIST(expr);
3275 expr->op_next = (OP*)rcop;
3278 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3283 if (pm->op_pmflags & PMf_EVAL) {
3285 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3286 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3288 else if (repl->op_type == OP_CONST)
3292 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3293 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3294 if (curop->op_type == OP_GV) {
3295 GV * const gv = cGVOPx_gv(curop);
3297 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3300 else if (curop->op_type == OP_RV2CV)
3302 else if (curop->op_type == OP_RV2SV ||
3303 curop->op_type == OP_RV2AV ||
3304 curop->op_type == OP_RV2HV ||
3305 curop->op_type == OP_RV2GV) {
3306 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3309 else if (curop->op_type == OP_PADSV ||
3310 curop->op_type == OP_PADAV ||
3311 curop->op_type == OP_PADHV ||
3312 curop->op_type == OP_PADANY) {
3315 else if (curop->op_type == OP_PUSHRE)
3316 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
3326 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3327 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3328 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3329 prepend_elem(o->op_type, scalar(repl), o);
3332 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3333 pm->op_pmflags |= PMf_MAYBE_CONST;
3334 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3336 NewOp(1101, rcop, 1, LOGOP);
3337 rcop->op_type = OP_SUBSTCONT;
3338 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3339 rcop->op_first = scalar(repl);
3340 rcop->op_flags |= OPf_KIDS;
3341 rcop->op_private = 1;
3344 /* establish postfix order */
3345 rcop->op_next = LINKLIST(repl);
3346 repl->op_next = (OP*)rcop;
3348 pm->op_pmreplroot = scalar((OP*)rcop);
3349 pm->op_pmreplstart = LINKLIST(rcop);
3358 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3362 NewOp(1101, svop, 1, SVOP);
3363 svop->op_type = (OPCODE)type;
3364 svop->op_ppaddr = PL_ppaddr[type];
3366 svop->op_next = (OP*)svop;
3367 svop->op_flags = (U8)flags;
3368 if (PL_opargs[type] & OA_RETSCALAR)
3370 if (PL_opargs[type] & OA_TARGET)
3371 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3372 return CHECKOP(type, svop);
3376 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3380 NewOp(1101, padop, 1, PADOP);
3381 padop->op_type = (OPCODE)type;
3382 padop->op_ppaddr = PL_ppaddr[type];
3383 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3384 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3385 PAD_SETSV(padop->op_padix, sv);
3388 padop->op_next = (OP*)padop;
3389 padop->op_flags = (U8)flags;
3390 if (PL_opargs[type] & OA_RETSCALAR)
3392 if (PL_opargs[type] & OA_TARGET)
3393 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3394 return CHECKOP(type, padop);
3398 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3404 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3406 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3411 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3415 NewOp(1101, pvop, 1, PVOP);
3416 pvop->op_type = (OPCODE)type;
3417 pvop->op_ppaddr = PL_ppaddr[type];
3419 pvop->op_next = (OP*)pvop;
3420 pvop->op_flags = (U8)flags;
3421 if (PL_opargs[type] & OA_RETSCALAR)
3423 if (PL_opargs[type] & OA_TARGET)
3424 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3425 return CHECKOP(type, pvop);
3433 Perl_package(pTHX_ OP *o)
3442 save_hptr(&PL_curstash);
3443 save_item(PL_curstname);
3445 name = SvPV_const(cSVOPo->op_sv, len);
3446 PL_curstash = gv_stashpvn(name, len, TRUE);
3447 sv_setpvn(PL_curstname, name, len);
3449 PL_hints |= HINT_BLOCK_SCOPE;
3450 PL_copline = NOLINE;
3456 if (!PL_madskills) {
3461 pegop = newOP(OP_NULL,0);
3462 op_getmad(o,pegop,'P');
3472 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3479 OP *pegop = newOP(OP_NULL,0);
3482 if (idop->op_type != OP_CONST)
3483 Perl_croak(aTHX_ "Module name must be constant");
3486 op_getmad(idop,pegop,'U');
3491 SV * const vesv = ((SVOP*)version)->op_sv;
3494 op_getmad(version,pegop,'V');
3495 if (!arg && !SvNIOKp(vesv)) {
3502 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3503 Perl_croak(aTHX_ "Version number must be constant number");
3505 /* Make copy of idop so we don't free it twice */
3506 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3508 /* Fake up a method call to VERSION */
3509 meth = newSVpvs_share("VERSION");
3510 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3511 append_elem(OP_LIST,
3512 prepend_elem(OP_LIST, pack, list(version)),
3513 newSVOP(OP_METHOD_NAMED, 0, meth)));
3517 /* Fake up an import/unimport */
3518 if (arg && arg->op_type == OP_STUB) {
3520 op_getmad(arg,pegop,'S');
3521 imop = arg; /* no import on explicit () */
3523 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3524 imop = NULL; /* use 5.0; */
3526 idop->op_private |= OPpCONST_NOVER;
3532 op_getmad(arg,pegop,'A');
3534 /* Make copy of idop so we don't free it twice */
3535 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3537 /* Fake up a method call to import/unimport */
3539 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3540 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3541 append_elem(OP_LIST,
3542 prepend_elem(OP_LIST, pack, list(arg)),
3543 newSVOP(OP_METHOD_NAMED, 0, meth)));
3546 /* Fake up the BEGIN {}, which does its thing immediately. */
3548 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3551 append_elem(OP_LINESEQ,
3552 append_elem(OP_LINESEQ,
3553 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3554 newSTATEOP(0, NULL, veop)),
3555 newSTATEOP(0, NULL, imop) ));
3557 /* The "did you use incorrect case?" warning used to be here.
3558 * The problem is that on case-insensitive filesystems one
3559 * might get false positives for "use" (and "require"):
3560 * "use Strict" or "require CARP" will work. This causes
3561 * portability problems for the script: in case-strict
3562 * filesystems the script will stop working.
3564 * The "incorrect case" warning checked whether "use Foo"
3565 * imported "Foo" to your namespace, but that is wrong, too:
3566 * there is no requirement nor promise in the language that
3567 * a Foo.pm should or would contain anything in package "Foo".
3569 * There is very little Configure-wise that can be done, either:
3570 * the case-sensitivity of the build filesystem of Perl does not
3571 * help in guessing the case-sensitivity of the runtime environment.
3574 PL_hints |= HINT_BLOCK_SCOPE;
3575 PL_copline = NOLINE;
3577 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3580 if (!PL_madskills) {
3581 /* FIXME - don't allocate pegop if !PL_madskills */
3590 =head1 Embedding Functions
3592 =for apidoc load_module
3594 Loads the module whose name is pointed to by the string part of name.
3595 Note that the actual module name, not its filename, should be given.
3596 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3597 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3598 (or 0 for no flags). ver, if specified, provides version semantics
3599 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3600 arguments can be used to specify arguments to the module's import()
3601 method, similar to C<use Foo::Bar VERSION LIST>.
3606 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3609 va_start(args, ver);
3610 vload_module(flags, name, ver, &args);
3614 #ifdef PERL_IMPLICIT_CONTEXT
3616 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3620 va_start(args, ver);
3621 vload_module(flags, name, ver, &args);
3627 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3632 OP * const modname = newSVOP(OP_CONST, 0, name);
3633 modname->op_private |= OPpCONST_BARE;
3635 veop = newSVOP(OP_CONST, 0, ver);
3639 if (flags & PERL_LOADMOD_NOIMPORT) {
3640 imop = sawparens(newNULLLIST());
3642 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3643 imop = va_arg(*args, OP*);
3648 sv = va_arg(*args, SV*);
3650 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3651 sv = va_arg(*args, SV*);
3655 const line_t ocopline = PL_copline;
3656 COP * const ocurcop = PL_curcop;
3657 const int oexpect = PL_expect;
3659 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3660 veop, modname, imop);
3661 PL_expect = oexpect;
3662 PL_copline = ocopline;
3663 PL_curcop = ocurcop;
3668 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3674 if (!force_builtin) {
3675 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3676 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3677 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3678 gv = gvp ? *gvp : NULL;
3682 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3683 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3684 append_elem(OP_LIST, term,
3685 scalar(newUNOP(OP_RV2CV, 0,
3686 newGVOP(OP_GV, 0, gv))))));
3689 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3695 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3697 return newBINOP(OP_LSLICE, flags,
3698 list(force_list(subscript)),
3699 list(force_list(listval)) );
3703 S_is_list_assignment(pTHX_ register const OP *o)
3708 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3709 o = cUNOPo->op_first;
3711 if (o->op_type == OP_COND_EXPR) {
3712 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3713 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3718 yyerror("Assignment to both a list and a scalar");
3722 if (o->op_type == OP_LIST &&
3723 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3724 o->op_private & OPpLVAL_INTRO)
3727 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3728 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3729 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3732 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3735 if (o->op_type == OP_RV2SV)
3742 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3748 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3749 return newLOGOP(optype, 0,
3750 mod(scalar(left), optype),
3751 newUNOP(OP_SASSIGN, 0, scalar(right)));
3754 return newBINOP(optype, OPf_STACKED,
3755 mod(scalar(left), optype), scalar(right));
3759 if (is_list_assignment(left)) {
3763 /* Grandfathering $[ assignment here. Bletch.*/
3764 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3765 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3766 left = mod(left, OP_AASSIGN);
3769 else if (left->op_type == OP_CONST) {
3771 /* Result of assignment is always 1 (or we'd be dead already) */
3772 return newSVOP(OP_CONST, 0, newSViv(1));
3774 curop = list(force_list(left));
3775 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3776 o->op_private = (U8)(0 | (flags >> 8));
3778 /* PL_generation sorcery:
3779 * an assignment like ($a,$b) = ($c,$d) is easier than
3780 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3781 * To detect whether there are common vars, the global var
3782 * PL_generation is incremented for each assign op we compile.
3783 * Then, while compiling the assign op, we run through all the
3784 * variables on both sides of the assignment, setting a spare slot
3785 * in each of them to PL_generation. If any of them already have
3786 * that value, we know we've got commonality. We could use a
3787 * single bit marker, but then we'd have to make 2 passes, first
3788 * to clear the flag, then to test and set it. To find somewhere
3789 * to store these values, evil chicanery is done with SvCUR().
3792 if (!(left->op_private & OPpLVAL_INTRO)) {
3795 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3796 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3797 if (curop->op_type == OP_GV) {
3798 GV *gv = cGVOPx_gv(curop);
3800 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3802 GvASSIGN_GENERATION_set(gv, PL_generation);
3804 else if (curop->op_type == OP_PADSV ||
3805 curop->op_type == OP_PADAV ||
3806 curop->op_type == OP_PADHV ||
3807 curop->op_type == OP_PADANY)
3809 if (PAD_COMPNAME_GEN(curop->op_targ)
3810 == (STRLEN)PL_generation)
3812 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3815 else if (curop->op_type == OP_RV2CV)
3817 else if (curop->op_type == OP_RV2SV ||
3818 curop->op_type == OP_RV2AV ||
3819 curop->op_type == OP_RV2HV ||
3820 curop->op_type == OP_RV2GV) {
3821 if (lastop->op_type != OP_GV) /* funny deref? */
3824 else if (curop->op_type == OP_PUSHRE) {
3825 if (((PMOP*)curop)->op_pmreplroot) {
3827 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3828 ((PMOP*)curop)->op_pmreplroot));
3830 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3833 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3835 GvASSIGN_GENERATION_set(gv, PL_generation);
3836 GvASSIGN_GENERATION_set(gv, PL_generation);
3845 o->op_private |= OPpASSIGN_COMMON;
3847 if (right && right->op_type == OP_SPLIT) {
3849 if ((tmpop = ((LISTOP*)right)->op_first) &&
3850 tmpop->op_type == OP_PUSHRE)
3852 PMOP * const pm = (PMOP*)tmpop;
3853 if (left->op_type == OP_RV2AV &&
3854 !(left->op_private & OPpLVAL_INTRO) &&
3855 !(o->op_private & OPpASSIGN_COMMON) )
3857 tmpop = ((UNOP*)left)->op_first;
3858 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3860 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3861 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3863 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3864 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3866 pm->op_pmflags |= PMf_ONCE;
3867 tmpop = cUNOPo->op_first; /* to list (nulled) */
3868 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3869 tmpop->op_sibling = NULL; /* don't free split */
3870 right->op_next = tmpop->op_next; /* fix starting loc */
3872 op_getmad(o,right,'R'); /* blow off assign */
3874 op_free(o); /* blow off assign */
3876 right->op_flags &= ~OPf_WANT;
3877 /* "I don't know and I don't care." */
3882 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3883 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3885 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3887 sv_setiv(sv, PL_modcount+1);
3895 right = newOP(OP_UNDEF, 0);
3896 if (right->op_type == OP_READLINE) {
3897 right->op_flags |= OPf_STACKED;
3898 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3901 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3902 o = newBINOP(OP_SASSIGN, flags,
3903 scalar(right), mod(scalar(left), OP_SASSIGN) );
3909 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3910 o->op_private |= OPpCONST_ARYBASE;
3917 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3920 const U32 seq = intro_my();
3923 NewOp(1101, cop, 1, COP);
3924 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3925 cop->op_type = OP_DBSTATE;
3926 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3929 cop->op_type = OP_NEXTSTATE;
3930 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3932 cop->op_flags = (U8)flags;
3933 CopHINTS_set(cop, PL_hints);
3935 cop->op_private |= NATIVE_HINTS;
3937 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3938 cop->op_next = (OP*)cop;
3941 cop->cop_label = label;
3942 PL_hints |= HINT_BLOCK_SCOPE;
3945 CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
3946 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3947 if (specialCopIO(PL_curcop->cop_io))
3948 cop->cop_io = PL_curcop->cop_io;
3950 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3951 cop->cop_hints = PL_curcop->cop_hints;
3952 if (cop->cop_hints) {
3954 cop->cop_hints->refcounted_he_refcnt++;
3955 HINTS_REFCNT_UNLOCK;
3958 if (PL_copline == NOLINE)
3959 CopLINE_set(cop, CopLINE(PL_curcop));
3961 CopLINE_set(cop, PL_copline);
3962 PL_copline = NOLINE;
3965 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3967 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3969 CopSTASH_set(cop, PL_curstash);
3971 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3972 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3973 if (svp && *svp != &PL_sv_undef ) {
3974 (void)SvIOK_on(*svp);
3975 SvIV_set(*svp, PTR2IV(cop));
3979 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3984 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3987 return new_logop(type, flags, &first, &other);
3991 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3996 OP *first = *firstp;
3997 OP * const other = *otherp;
3999 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4000 return newBINOP(type, flags, scalar(first), scalar(other));
4002 scalarboolean(first);
4003 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4004 if (first->op_type == OP_NOT
4005 && (first->op_flags & OPf_SPECIAL)
4006 && (first->op_flags & OPf_KIDS)) {
4007 if (type == OP_AND || type == OP_OR) {
4013 first = *firstp = cUNOPo->op_first;
4015 first->op_next = o->op_next;
4016 cUNOPo->op_first = NULL;
4018 op_getmad(o,first,'O');
4024 if (first->op_type == OP_CONST) {
4025 if (first->op_private & OPpCONST_STRICT)
4026 no_bareword_allowed(first);
4027 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4028 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4029 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4030 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4031 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4033 if (other->op_type == OP_CONST)
4034 other->op_private |= OPpCONST_SHORTCIRCUIT;
4036 OP *newop = newUNOP(OP_NULL, 0, other);
4037 op_getmad(first, newop, '1');
4038 newop->op_targ = type; /* set "was" field */
4045 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4046 const OP *o2 = other;
4047 if ( ! (o2->op_type == OP_LIST
4048 && (( o2 = cUNOPx(o2)->op_first))
4049 && o2->op_type == OP_PUSHMARK
4050 && (( o2 = o2->op_sibling)) )
4053 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4054 || o2->op_type == OP_PADHV)
4055 && o2->op_private & OPpLVAL_INTRO
4056 && ckWARN(WARN_DEPRECATED))
4058 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4059 "Deprecated use of my() in false conditional");
4063 if (first->op_type == OP_CONST)
4064 first->op_private |= OPpCONST_SHORTCIRCUIT;
4066 first = newUNOP(OP_NULL, 0, first);
4067 op_getmad(other, first, '2');
4068 first->op_targ = type; /* set "was" field */
4075 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4076 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4078 const OP * const k1 = ((UNOP*)first)->op_first;
4079 const OP * const k2 = k1->op_sibling;
4081 switch (first->op_type)
4084 if (k2 && k2->op_type == OP_READLINE
4085 && (k2->op_flags & OPf_STACKED)
4086 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4088 warnop = k2->op_type;
4093 if (k1->op_type == OP_READDIR
4094 || k1->op_type == OP_GLOB
4095 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4096 || k1->op_type == OP_EACH)
4098 warnop = ((k1->op_type == OP_NULL)
4099 ? (OPCODE)k1->op_targ : k1->op_type);
4104 const line_t oldline = CopLINE(PL_curcop);
4105 CopLINE_set(PL_curcop, PL_copline);
4106 Perl_warner(aTHX_ packWARN(WARN_MISC),
4107 "Value of %s%s can be \"0\"; test with defined()",
4109 ((warnop == OP_READLINE || warnop == OP_GLOB)
4110 ? " construct" : "() operator"));
4111 CopLINE_set(PL_curcop, oldline);
4118 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4119 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4121 NewOp(1101, logop, 1, LOGOP);
4123 logop->op_type = (OPCODE)type;
4124 logop->op_ppaddr = PL_ppaddr[type];
4125 logop->op_first = first;
4126 logop->op_flags = (U8)(flags | OPf_KIDS);
4127 logop->op_other = LINKLIST(other);
4128 logop->op_private = (U8)(1 | (flags >> 8));
4130 /* establish postfix order */
4131 logop->op_next = LINKLIST(first);
4132 first->op_next = (OP*)logop;
4133 first->op_sibling = other;
4135 CHECKOP(type,logop);
4137 o = newUNOP(OP_NULL, 0, (OP*)logop);
4144 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4152 return newLOGOP(OP_AND, 0, first, trueop);
4154 return newLOGOP(OP_OR, 0, first, falseop);
4156 scalarboolean(first);
4157 if (first->op_type == OP_CONST) {
4158 if (first->op_private & OPpCONST_BARE &&
4159 first->op_private & OPpCONST_STRICT) {
4160 no_bareword_allowed(first);
4162 if (SvTRUE(((SVOP*)first)->op_sv)) {
4165 trueop = newUNOP(OP_NULL, 0, trueop);
4166 op_getmad(first,trueop,'C');
4167 op_getmad(falseop,trueop,'e');
4169 /* FIXME for MAD - should there be an ELSE here? */
4179 falseop = newUNOP(OP_NULL, 0, falseop);
4180 op_getmad(first,falseop,'C');
4181 op_getmad(trueop,falseop,'t');
4183 /* FIXME for MAD - should there be an ELSE here? */
4191 NewOp(1101, logop, 1, LOGOP);
4192 logop->op_type = OP_COND_EXPR;
4193 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4194 logop->op_first = first;
4195 logop->op_flags = (U8)(flags | OPf_KIDS);
4196 logop->op_private = (U8)(1 | (flags >> 8));
4197 logop->op_other = LINKLIST(trueop);
4198 logop->op_next = LINKLIST(falseop);
4200 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4203 /* establish postfix order */
4204 start = LINKLIST(first);
4205 first->op_next = (OP*)logop;
4207 first->op_sibling = trueop;
4208 trueop->op_sibling = falseop;
4209 o = newUNOP(OP_NULL, 0, (OP*)logop);
4211 trueop->op_next = falseop->op_next = o;
4218 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4227 NewOp(1101, range, 1, LOGOP);
4229 range->op_type = OP_RANGE;
4230 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4231 range->op_first = left;
4232 range->op_flags = OPf_KIDS;
4233 leftstart = LINKLIST(left);
4234 range->op_other = LINKLIST(right);
4235 range->op_private = (U8)(1 | (flags >> 8));
4237 left->op_sibling = right;
4239 range->op_next = (OP*)range;
4240 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4241 flop = newUNOP(OP_FLOP, 0, flip);
4242 o = newUNOP(OP_NULL, 0, flop);
4244 range->op_next = leftstart;
4246 left->op_next = flip;
4247 right->op_next = flop;
4249 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4250 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4251 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4252 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4254 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4255 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4258 if (!flip->op_private || !flop->op_private)
4259 linklist(o); /* blow off optimizer unless constant */
4265 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4270 const bool once = block && block->op_flags & OPf_SPECIAL &&
4271 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4273 PERL_UNUSED_ARG(debuggable);
4276 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4277 return block; /* do {} while 0 does once */
4278 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4279 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4280 expr = newUNOP(OP_DEFINED, 0,
4281 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4282 } else if (expr->op_flags & OPf_KIDS) {
4283 const OP * const k1 = ((UNOP*)expr)->op_first;
4284 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4285 switch (expr->op_type) {
4287 if (k2 && k2->op_type == OP_READLINE
4288 && (k2->op_flags & OPf_STACKED)
4289 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4290 expr = newUNOP(OP_DEFINED, 0, expr);
4294 if (k1 && (k1->op_type == OP_READDIR
4295 || k1->op_type == OP_GLOB
4296 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4297 || k1->op_type == OP_EACH))
4298 expr = newUNOP(OP_DEFINED, 0, expr);
4304 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4305 * op, in listop. This is wrong. [perl #27024] */
4307 block = newOP(OP_NULL, 0);
4308 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4309 o = new_logop(OP_AND, 0, &expr, &listop);
4312 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4314 if (once && o != listop)
4315 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4318 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4320 o->op_flags |= flags;
4322 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4327 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4328 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4337 PERL_UNUSED_ARG(debuggable);
4340 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4341 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4342 expr = newUNOP(OP_DEFINED, 0,
4343 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4344 } else if (expr->op_flags & OPf_KIDS) {
4345 const OP * const k1 = ((UNOP*)expr)->op_first;
4346 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4347 switch (expr->op_type) {
4349 if (k2 && k2->op_type == OP_READLINE
4350 && (k2->op_flags & OPf_STACKED)
4351 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4352 expr = newUNOP(OP_DEFINED, 0, expr);
4356 if (k1 && (k1->op_type == OP_READDIR
4357 || k1->op_type == OP_GLOB
4358 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4359 || k1->op_type == OP_EACH))
4360 expr = newUNOP(OP_DEFINED, 0, expr);
4367 block = newOP(OP_NULL, 0);
4368 else if (cont || has_my) {
4369 block = scope(block);
4373 next = LINKLIST(cont);
4376 OP * const unstack = newOP(OP_UNSTACK, 0);
4379 cont = append_elem(OP_LINESEQ, cont, unstack);
4382 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4383 redo = LINKLIST(listop);
4386 PL_copline = (line_t)whileline;
4388 o = new_logop(OP_AND, 0, &expr, &listop);
4389 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4390 op_free(expr); /* oops, it's a while (0) */
4392 return NULL; /* listop already freed by new_logop */
4395 ((LISTOP*)listop)->op_last->op_next =
4396 (o == listop ? redo : LINKLIST(o));
4402 NewOp(1101,loop,1,LOOP);
4403 loop->op_type = OP_ENTERLOOP;
4404 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4405 loop->op_private = 0;
4406 loop->op_next = (OP*)loop;
4409 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4411 loop->op_redoop = redo;
4412 loop->op_lastop = o;
4413 o->op_private |= loopflags;
4416 loop->op_nextop = next;
4418 loop->op_nextop = o;
4420 o->op_flags |= flags;
4421 o->op_private |= (flags >> 8);
4426 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4431 PADOFFSET padoff = 0;
4437 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4438 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4439 sv->op_type = OP_RV2GV;
4440 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4441 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4442 iterpflags |= OPpITER_DEF;
4444 else if (sv->op_type == OP_PADSV) { /* private variable */
4445 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4446 padoff = sv->op_targ;
4455 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4456 padoff = sv->op_targ;
4461 iterflags |= OPf_SPECIAL;
4467 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4468 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4469 iterpflags |= OPpITER_DEF;
4472 const I32 offset = pad_findmy("$_");
4473 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4474 sv = newGVOP(OP_GV, 0, PL_defgv);
4479 iterpflags |= OPpITER_DEF;
4481 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4482 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4483 iterflags |= OPf_STACKED;
4485 else if (expr->op_type == OP_NULL &&
4486 (expr->op_flags & OPf_KIDS) &&
4487 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4489 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4490 * set the STACKED flag to indicate that these values are to be
4491 * treated as min/max values by 'pp_iterinit'.
4493 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4494 LOGOP* const range = (LOGOP*) flip->op_first;
4495 OP* const left = range->op_first;
4496 OP* const right = left->op_sibling;
4499 range->op_flags &= ~OPf_KIDS;
4500 range->op_first = NULL;
4502 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4503 listop->op_first->op_next = range->op_next;
4504 left->op_next = range->op_other;
4505 right->op_next = (OP*)listop;
4506 listop->op_next = listop->op_first;
4509 op_getmad(expr,(OP*)listop,'O');
4513 expr = (OP*)(listop);
4515 iterflags |= OPf_STACKED;
4518 expr = mod(force_list(expr), OP_GREPSTART);
4521 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4522 append_elem(OP_LIST, expr, scalar(sv))));
4523 assert(!loop->op_next);
4524 /* for my $x () sets OPpLVAL_INTRO;
4525 * for our $x () sets OPpOUR_INTRO */
4526 loop->op_private = (U8)iterpflags;
4527 #ifdef PL_OP_SLAB_ALLOC
4530 NewOp(1234,tmp,1,LOOP);
4531 Copy(loop,tmp,1,LISTOP);
4536 loop = PerlMemShared_realloc(loop, sizeof(LOOP));
4538 loop->op_targ = padoff;
4539 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4541 op_getmad(madsv, (OP*)loop, 'v');
4542 PL_copline = forline;
4543 return newSTATEOP(0, label, wop);
4547 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4552 if (type != OP_GOTO || label->op_type == OP_CONST) {
4553 /* "last()" means "last" */
4554 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4555 o = newOP(type, OPf_SPECIAL);
4557 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4558 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4562 op_getmad(label,o,'L');
4568 /* Check whether it's going to be a goto &function */
4569 if (label->op_type == OP_ENTERSUB
4570 && !(label->op_flags & OPf_STACKED))
4571 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4572 o = newUNOP(type, OPf_STACKED, label);
4574 PL_hints |= HINT_BLOCK_SCOPE;
4578 /* if the condition is a literal array or hash
4579 (or @{ ... } etc), make a reference to it.
4582 S_ref_array_or_hash(pTHX_ OP *cond)
4585 && (cond->op_type == OP_RV2AV
4586 || cond->op_type == OP_PADAV
4587 || cond->op_type == OP_RV2HV
4588 || cond->op_type == OP_PADHV))
4590 return newUNOP(OP_REFGEN,
4591 0, mod(cond, OP_REFGEN));
4597 /* These construct the optree fragments representing given()
4600 entergiven and enterwhen are LOGOPs; the op_other pointer
4601 points up to the associated leave op. We need this so we
4602 can put it in the context and make break/continue work.
4603 (Also, of course, pp_enterwhen will jump straight to
4604 op_other if the match fails.)
4609 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4610 I32 enter_opcode, I32 leave_opcode,
4611 PADOFFSET entertarg)
4617 NewOp(1101, enterop, 1, LOGOP);
4618 enterop->op_type = enter_opcode;
4619 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4620 enterop->op_flags = (U8) OPf_KIDS;
4621 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4622 enterop->op_private = 0;
4624 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4627 enterop->op_first = scalar(cond);
4628 cond->op_sibling = block;
4630 o->op_next = LINKLIST(cond);
4631 cond->op_next = (OP *) enterop;
4634 /* This is a default {} block */
4635 enterop->op_first = block;
4636 enterop->op_flags |= OPf_SPECIAL;
4638 o->op_next = (OP *) enterop;
4641 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4642 entergiven and enterwhen both
4645 enterop->op_next = LINKLIST(block);
4646 block->op_next = enterop->op_other = o;
4651 /* Does this look like a boolean operation? For these purposes
4652 a boolean operation is:
4653 - a subroutine call [*]
4654 - a logical connective
4655 - a comparison operator
4656 - a filetest operator, with the exception of -s -M -A -C
4657 - defined(), exists() or eof()
4658 - /$re/ or $foo =~ /$re/
4660 [*] possibly surprising
4664 S_looks_like_bool(pTHX_ const OP *o)
4667 switch(o->op_type) {
4669 return looks_like_bool(cLOGOPo->op_first);
4673 looks_like_bool(cLOGOPo->op_first)
4674 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4678 case OP_NOT: case OP_XOR:
4679 /* Note that OP_DOR is not here */
4681 case OP_EQ: case OP_NE: case OP_LT:
4682 case OP_GT: case OP_LE: case OP_GE:
4684 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4685 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4687 case OP_SEQ: case OP_SNE: case OP_SLT:
4688 case OP_SGT: case OP_SLE: case OP_SGE:
4692 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4693 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4694 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4695 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4696 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4697 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4698 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4699 case OP_FTTEXT: case OP_FTBINARY:
4701 case OP_DEFINED: case OP_EXISTS:
4702 case OP_MATCH: case OP_EOF:
4707 /* Detect comparisons that have been optimized away */
4708 if (cSVOPo->op_sv == &PL_sv_yes
4709 || cSVOPo->op_sv == &PL_sv_no)
4720 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4724 return newGIVWHENOP(
4725 ref_array_or_hash(cond),
4727 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4731 /* If cond is null, this is a default {} block */
4733 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4735 const bool cond_llb = (!cond || looks_like_bool(cond));
4741 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4743 scalar(ref_array_or_hash(cond)));
4746 return newGIVWHENOP(
4748 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4749 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4753 =for apidoc cv_undef
4755 Clear out all the active components of a CV. This can happen either
4756 by an explicit C<undef &foo>, or by the reference count going to zero.
4757 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4758 children can still follow the full lexical scope chain.
4764 Perl_cv_undef(pTHX_ CV *cv)
4768 if (CvFILE(cv) && !CvISXSUB(cv)) {
4769 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4770 Safefree(CvFILE(cv));
4775 if (!CvISXSUB(cv) && CvROOT(cv)) {
4776 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4777 Perl_croak(aTHX_ "Can't undef active subroutine");
4780 PAD_SAVE_SETNULLPAD();
4782 op_free(CvROOT(cv));
4787 SvPOK_off((SV*)cv); /* forget prototype */
4792 /* remove CvOUTSIDE unless this is an undef rather than a free */
4793 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4794 if (!CvWEAKOUTSIDE(cv))
4795 SvREFCNT_dec(CvOUTSIDE(cv));
4796 CvOUTSIDE(cv) = NULL;
4799 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4802 if (CvISXSUB(cv) && CvXSUB(cv)) {
4805 /* delete all flags except WEAKOUTSIDE */
4806 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4810 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4812 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4813 SV* const msg = sv_newmortal();
4817 gv_efullname3(name = sv_newmortal(), gv, NULL);
4818 sv_setpv(msg, "Prototype mismatch:");
4820 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4822 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4824 sv_catpvs(msg, ": none");
4825 sv_catpvs(msg, " vs ");
4827 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4829 sv_catpvs(msg, "none");
4830 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4834 static void const_sv_xsub(pTHX_ CV* cv);
4838 =head1 Optree Manipulation Functions
4840 =for apidoc cv_const_sv
4842 If C<cv> is a constant sub eligible for inlining. returns the constant
4843 value returned by the sub. Otherwise, returns NULL.
4845 Constant subs can be created with C<newCONSTSUB> or as described in
4846 L<perlsub/"Constant Functions">.
4851 Perl_cv_const_sv(pTHX_ CV *cv)
4853 PERL_UNUSED_CONTEXT;
4856 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4858 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4861 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4862 * Can be called in 3 ways:
4865 * look for a single OP_CONST with attached value: return the value
4867 * cv && CvCLONE(cv) && !CvCONST(cv)
4869 * examine the clone prototype, and if contains only a single
4870 * OP_CONST referencing a pad const, or a single PADSV referencing
4871 * an outer lexical, return a non-zero value to indicate the CV is
4872 * a candidate for "constizing" at clone time
4876 * We have just cloned an anon prototype that was marked as a const
4877 * candidiate. Try to grab the current value, and in the case of
4878 * PADSV, ignore it if it has multiple references. Return the value.
4882 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4890 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4891 o = cLISTOPo->op_first->op_sibling;
4893 for (; o; o = o->op_next) {
4894 const OPCODE type = o->op_type;
4896 if (sv && o->op_next == o)
4898 if (o->op_next != o) {
4899 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4901 if (type == OP_DBSTATE)
4904 if (type == OP_LEAVESUB || type == OP_RETURN)
4908 if (type == OP_CONST && cSVOPo->op_sv)
4910 else if (cv && type == OP_CONST) {
4911 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4915 else if (cv && type == OP_PADSV) {
4916 if (CvCONST(cv)) { /* newly cloned anon */
4917 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4918 /* the candidate should have 1 ref from this pad and 1 ref
4919 * from the parent */
4920 if (!sv || SvREFCNT(sv) != 2)
4927 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4928 sv = &PL_sv_undef; /* an arbitrary non-null value */
4943 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4946 /* This would be the return value, but the return cannot be reached. */
4947 OP* pegop = newOP(OP_NULL, 0);
4950 PERL_UNUSED_ARG(floor);
4960 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4962 NORETURN_FUNCTION_END;
4967 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4969 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4973 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4980 register CV *cv = NULL;
4982 /* If the subroutine has no body, no attributes, and no builtin attributes
4983 then it's just a sub declaration, and we may be able to get away with
4984 storing with a placeholder scalar in the symbol table, rather than a
4985 full GV and CV. If anything is present then it will take a full CV to
4987 const I32 gv_fetch_flags
4988 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4990 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4991 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4994 assert(proto->op_type == OP_CONST);
4995 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5000 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5001 SV * const sv = sv_newmortal();
5002 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5003 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5004 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5005 aname = SvPVX_const(sv);
5010 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5011 : gv_fetchpv(aname ? aname
5012 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5013 gv_fetch_flags, SVt_PVCV);
5015 if (!PL_madskills) {
5024 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5025 maximum a prototype before. */
5026 if (SvTYPE(gv) > SVt_NULL) {
5027 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5028 && ckWARN_d(WARN_PROTOTYPE))
5030 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5032 cv_ckproto((CV*)gv, NULL, ps);
5035 sv_setpvn((SV*)gv, ps, ps_len);
5037 sv_setiv((SV*)gv, -1);
5038 SvREFCNT_dec(PL_compcv);
5039 cv = PL_compcv = NULL;
5040 PL_sub_generation++;
5044 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5046 #ifdef GV_UNIQUE_CHECK
5047 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5048 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5052 if (!block || !ps || *ps || attrs
5053 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5055 || block->op_type == OP_NULL
5060 const_sv = op_const_sv(block, NULL);
5063 const bool exists = CvROOT(cv) || CvXSUB(cv);
5065 #ifdef GV_UNIQUE_CHECK
5066 if (exists && GvUNIQUE(gv)) {
5067 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5071 /* if the subroutine doesn't exist and wasn't pre-declared
5072 * with a prototype, assume it will be AUTOLOADed,
5073 * skipping the prototype check
5075 if (exists || SvPOK(cv))
5076 cv_ckproto(cv, gv, ps);
5077 /* already defined (or promised)? */
5078 if (exists || GvASSUMECV(gv)) {
5081 || block->op_type == OP_NULL
5084 if (CvFLAGS(PL_compcv)) {
5085 /* might have had built-in attrs applied */
5086 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5088 /* just a "sub foo;" when &foo is already defined */
5089 SAVEFREESV(PL_compcv);
5094 && block->op_type != OP_NULL
5097 if (ckWARN(WARN_REDEFINE)
5099 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5101 const line_t oldline = CopLINE(PL_curcop);
5102 if (PL_copline != NOLINE)
5103 CopLINE_set(PL_curcop, PL_copline);
5104 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5105 CvCONST(cv) ? "Constant subroutine %s redefined"
5106 : "Subroutine %s redefined", name);
5107 CopLINE_set(PL_curcop, oldline);
5110 if (!PL_minus_c) /* keep old one around for madskills */
5113 /* (PL_madskills unset in used file.) */
5121 SvREFCNT_inc_simple_void_NN(const_sv);
5123 assert(!CvROOT(cv) && !CvCONST(cv));
5124 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5125 CvXSUBANY(cv).any_ptr = const_sv;
5126 CvXSUB(cv) = const_sv_xsub;
5132 cv = newCONSTSUB(NULL, name, const_sv);
5134 PL_sub_generation++;
5138 SvREFCNT_dec(PL_compcv);
5146 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5147 * before we clobber PL_compcv.
5151 || block->op_type == OP_NULL
5155 /* Might have had built-in attributes applied -- propagate them. */
5156 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5157 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5158 stash = GvSTASH(CvGV(cv));
5159 else if (CvSTASH(cv))
5160 stash = CvSTASH(cv);
5162 stash = PL_curstash;
5165 /* possibly about to re-define existing subr -- ignore old cv */
5166 rcv = (SV*)PL_compcv;
5167 if (name && GvSTASH(gv))
5168 stash = GvSTASH(gv);
5170 stash = PL_curstash;
5172 apply_attrs(stash, rcv, attrs, FALSE);
5174 if (cv) { /* must reuse cv if autoloaded */
5181 || block->op_type == OP_NULL) && !PL_madskills
5184 /* got here with just attrs -- work done, so bug out */
5185 SAVEFREESV(PL_compcv);
5188 /* transfer PL_compcv to cv */
5190 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5191 if (!CvWEAKOUTSIDE(cv))
5192 SvREFCNT_dec(CvOUTSIDE(cv));
5193 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5194 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5195 CvOUTSIDE(PL_compcv) = 0;
5196 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5197 CvPADLIST(PL_compcv) = 0;
5198 /* inner references to PL_compcv must be fixed up ... */
5199 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5200 /* ... before we throw it away */
5201 SvREFCNT_dec(PL_compcv);
5203 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5204 ++PL_sub_generation;
5211 if (strEQ(name, "import")) {
5212 PL_formfeed = (SV*)cv;
5213 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5217 PL_sub_generation++;
5221 CvFILE_set_from_cop(cv, PL_curcop);
5222 CvSTASH(cv) = PL_curstash;
5225 sv_setpvn((SV*)cv, ps, ps_len);
5227 if (PL_error_count) {
5231 const char *s = strrchr(name, ':');
5233 if (strEQ(s, "BEGIN")) {
5234 const char not_safe[] =
5235 "BEGIN not safe after errors--compilation aborted";
5236 if (PL_in_eval & EVAL_KEEPERR)
5237 Perl_croak(aTHX_ not_safe);
5239 /* force display of errors found but not reported */
5240 sv_catpv(ERRSV, not_safe);
5241 Perl_croak(aTHX_ "%"SVf, ERRSV);
5251 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5252 mod(scalarseq(block), OP_LEAVESUBLV));
5255 /* This makes sub {}; work as expected. */
5256 if (block->op_type == OP_STUB) {
5257 OP* newblock = newSTATEOP(0, NULL, 0);
5259 op_getmad(block,newblock,'B');
5265 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5267 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5268 OpREFCNT_set(CvROOT(cv), 1);
5269 CvSTART(cv) = LINKLIST(CvROOT(cv));
5270 CvROOT(cv)->op_next = 0;
5271 CALL_PEEP(CvSTART(cv));
5273 /* now that optimizer has done its work, adjust pad values */
5275 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5278 assert(!CvCONST(cv));
5279 if (ps && !*ps && op_const_sv(block, cv))
5283 if (name || aname) {
5285 const char * const tname = (name ? name : aname);
5287 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5288 SV * const sv = newSV(0);
5289 SV * const tmpstr = sv_newmortal();
5290 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5291 GV_ADDMULTI, SVt_PVHV);
5294 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5296 (long)PL_subline, (long)CopLINE(PL_curcop));
5297 gv_efullname3(tmpstr, gv, NULL);
5298 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5299 hv = GvHVn(db_postponed);
5300 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5301 CV * const pcv = GvCV(db_postponed);
5307 call_sv((SV*)pcv, G_DISCARD);
5312 if ((s = strrchr(tname,':')))
5317 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5320 if (strEQ(s, "BEGIN") && !PL_error_count) {
5321 const I32 oldscope = PL_scopestack_ix;
5323 SAVECOPFILE(&PL_compiling);
5324 SAVECOPLINE(&PL_compiling);
5327 PL_beginav = newAV();
5328 DEBUG_x( dump_sub(gv) );
5329 av_push(PL_beginav, (SV*)cv);
5330 GvCV(gv) = 0; /* cv has been hijacked */
5331 call_list(oldscope, PL_beginav);
5333 PL_curcop = &PL_compiling;
5334 CopHINTS_set(&PL_compiling, PL_hints);
5337 else if (strEQ(s, "END") && !PL_error_count) {
5340 DEBUG_x( dump_sub(gv) );
5341 av_unshift(PL_endav, 1);
5342 av_store(PL_endav, 0, (SV*)cv);
5343 GvCV(gv) = 0; /* cv has been hijacked */
5345 else if (strEQ(s, "CHECK") && !PL_error_count) {
5347 PL_checkav = newAV();
5348 DEBUG_x( dump_sub(gv) );
5349 if (PL_main_start && ckWARN(WARN_VOID))
5350 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5351 av_unshift(PL_checkav, 1);
5352 av_store(PL_checkav, 0, (SV*)cv);
5353 GvCV(gv) = 0; /* cv has been hijacked */
5355 else if (strEQ(s, "INIT") && !PL_error_count) {
5357 PL_initav = newAV();
5358 DEBUG_x( dump_sub(gv) );
5359 if (PL_main_start && ckWARN(WARN_VOID))
5360 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5361 av_push(PL_initav, (SV*)cv);
5362 GvCV(gv) = 0; /* cv has been hijacked */
5367 PL_copline = NOLINE;
5372 /* XXX unsafe for threads if eval_owner isn't held */
5374 =for apidoc newCONSTSUB
5376 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5377 eligible for inlining at compile-time.
5383 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5390 SAVECOPLINE(PL_curcop);
5391 CopLINE_set(PL_curcop, PL_copline);
5394 PL_hints &= ~HINT_BLOCK_SCOPE;
5397 SAVESPTR(PL_curstash);
5398 SAVECOPSTASH(PL_curcop);
5399 PL_curstash = stash;
5400 CopSTASH_set(PL_curcop,stash);
5403 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
5404 CvXSUBANY(cv).any_ptr = sv;
5406 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5410 CopSTASH_free(PL_curcop);
5418 =for apidoc U||newXS
5420 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5426 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5429 GV * const gv = gv_fetchpv(name ? name :
5430 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5431 GV_ADDMULTI, SVt_PVCV);
5435 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5437 if ((cv = (name ? GvCV(gv) : NULL))) {
5439 /* just a cached method */
5443 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5444 /* already defined (or promised) */
5445 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5446 if (ckWARN(WARN_REDEFINE)) {
5447 GV * const gvcv = CvGV(cv);
5449 HV * const stash = GvSTASH(gvcv);
5451 const char *redefined_name = HvNAME_get(stash);
5452 if ( strEQ(redefined_name,"autouse") ) {
5453 const line_t oldline = CopLINE(PL_curcop);
5454 if (PL_copline != NOLINE)
5455 CopLINE_set(PL_curcop, PL_copline);
5456 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5457 CvCONST(cv) ? "Constant subroutine %s redefined"
5458 : "Subroutine %s redefined"
5460 CopLINE_set(PL_curcop, oldline);
5470 if (cv) /* must reuse cv if autoloaded */
5474 sv_upgrade((SV *)cv, SVt_PVCV);
5478 PL_sub_generation++;
5482 (void)gv_fetchfile(filename);
5483 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5484 an external constant string */
5486 CvXSUB(cv) = subaddr;
5489 const char *s = strrchr(name,':');
5495 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5498 if (strEQ(s, "BEGIN")) {
5500 PL_beginav = newAV();
5501 av_push(PL_beginav, (SV*)cv);
5502 GvCV(gv) = 0; /* cv has been hijacked */
5504 else if (strEQ(s, "END")) {
5507 av_unshift(PL_endav, 1);
5508 av_store(PL_endav, 0, (SV*)cv);
5509 GvCV(gv) = 0; /* cv has been hijacked */
5511 else if (strEQ(s, "CHECK")) {
5513 PL_checkav = newAV();
5514 if (PL_main_start && ckWARN(WARN_VOID))
5515 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5516 av_unshift(PL_checkav, 1);
5517 av_store(PL_checkav, 0, (SV*)cv);
5518 GvCV(gv) = 0; /* cv has been hijacked */
5520 else if (strEQ(s, "INIT")) {
5522 PL_initav = newAV();
5523 if (PL_main_start && ckWARN(WARN_VOID))
5524 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5525 av_push(PL_initav, (SV*)cv);
5526 GvCV(gv) = 0; /* cv has been hijacked */
5541 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5546 OP* pegop = newOP(OP_NULL, 0);
5550 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5551 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5553 #ifdef GV_UNIQUE_CHECK
5555 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5559 if ((cv = GvFORM(gv))) {
5560 if (ckWARN(WARN_REDEFINE)) {
5561 const line_t oldline = CopLINE(PL_curcop);
5562 if (PL_copline != NOLINE)
5563 CopLINE_set(PL_curcop, PL_copline);
5564 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5565 o ? "Format %"SVf" redefined"
5566 : "Format STDOUT redefined" ,cSVOPo->op_sv);
5567 CopLINE_set(PL_curcop, oldline);
5574 CvFILE_set_from_cop(cv, PL_curcop);
5577 pad_tidy(padtidy_FORMAT);
5578 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5579 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5580 OpREFCNT_set(CvROOT(cv), 1);
5581 CvSTART(cv) = LINKLIST(CvROOT(cv));
5582 CvROOT(cv)->op_next = 0;
5583 CALL_PEEP(CvSTART(cv));
5585 op_getmad(o,pegop,'n');
5586 op_getmad_weak(block, pegop, 'b');
5590 PL_copline = NOLINE;
5598 Perl_newANONLIST(pTHX_ OP *o)
5600 return newUNOP(OP_REFGEN, 0,
5601 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5605 Perl_newANONHASH(pTHX_ OP *o)
5607 return newUNOP(OP_REFGEN, 0,
5608 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5612 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5614 return newANONATTRSUB(floor, proto, NULL, block);
5618 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5620 return newUNOP(OP_REFGEN, 0,
5621 newSVOP(OP_ANONCODE, 0,
5622 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5626 Perl_oopsAV(pTHX_ OP *o)
5629 switch (o->op_type) {
5631 o->op_type = OP_PADAV;
5632 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5633 return ref(o, OP_RV2AV);
5636 o->op_type = OP_RV2AV;
5637 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5642 if (ckWARN_d(WARN_INTERNAL))
5643 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5650 Perl_oopsHV(pTHX_ OP *o)
5653 switch (o->op_type) {
5656 o->op_type = OP_PADHV;
5657 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5658 return ref(o, OP_RV2HV);
5662 o->op_type = OP_RV2HV;
5663 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5668 if (ckWARN_d(WARN_INTERNAL))
5669 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5676 Perl_newAVREF(pTHX_ OP *o)
5679 if (o->op_type == OP_PADANY) {
5680 o->op_type = OP_PADAV;
5681 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5684 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5685 && ckWARN(WARN_DEPRECATED)) {
5686 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5687 "Using an array as a reference is deprecated");
5689 return newUNOP(OP_RV2AV, 0, scalar(o));
5693 Perl_newGVREF(pTHX_ I32 type, OP *o)
5695 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5696 return newUNOP(OP_NULL, 0, o);
5697 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5701 Perl_newHVREF(pTHX_ OP *o)
5704 if (o->op_type == OP_PADANY) {
5705 o->op_type = OP_PADHV;
5706 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5709 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5710 && ckWARN(WARN_DEPRECATED)) {
5711 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5712 "Using a hash as a reference is deprecated");
5714 return newUNOP(OP_RV2HV, 0, scalar(o));
5718 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5720 return newUNOP(OP_RV2CV, flags, scalar(o));
5724 Perl_newSVREF(pTHX_ OP *o)
5727 if (o->op_type == OP_PADANY) {
5728 o->op_type = OP_PADSV;
5729 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5732 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5733 o->op_flags |= OPpDONE_SVREF;
5736 return newUNOP(OP_RV2SV, 0, scalar(o));
5739 /* Check routines. See the comments at the top of this file for details
5740 * on when these are called */
5743 Perl_ck_anoncode(pTHX_ OP *o)
5745 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5747 cSVOPo->op_sv = NULL;
5752 Perl_ck_bitop(pTHX_ OP *o)
5755 #define OP_IS_NUMCOMPARE(op) \
5756 ((op) == OP_LT || (op) == OP_I_LT || \
5757 (op) == OP_GT || (op) == OP_I_GT || \
5758 (op) == OP_LE || (op) == OP_I_LE || \
5759 (op) == OP_GE || (op) == OP_I_GE || \
5760 (op) == OP_EQ || (op) == OP_I_EQ || \
5761 (op) == OP_NE || (op) == OP_I_NE || \
5762 (op) == OP_NCMP || (op) == OP_I_NCMP)
5763 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5764 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5765 && (o->op_type == OP_BIT_OR
5766 || o->op_type == OP_BIT_AND
5767 || o->op_type == OP_BIT_XOR))
5769 const OP * const left = cBINOPo->op_first;
5770 const OP * const right = left->op_sibling;
5771 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5772 (left->op_flags & OPf_PARENS) == 0) ||
5773 (OP_IS_NUMCOMPARE(right->op_type) &&
5774 (right->op_flags & OPf_PARENS) == 0))
5775 if (ckWARN(WARN_PRECEDENCE))
5776 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5777 "Possible precedence problem on bitwise %c operator",
5778 o->op_type == OP_BIT_OR ? '|'
5779 : o->op_type == OP_BIT_AND ? '&' : '^'
5786 Perl_ck_concat(pTHX_ OP *o)
5788 const OP * const kid = cUNOPo->op_first;
5789 PERL_UNUSED_CONTEXT;
5790 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5791 !(kUNOP->op_first->op_flags & OPf_MOD))
5792 o->op_flags |= OPf_STACKED;
5797 Perl_ck_spair(pTHX_ OP *o)
5800 if (o->op_flags & OPf_KIDS) {
5803 const OPCODE type = o->op_type;
5804 o = modkids(ck_fun(o), type);
5805 kid = cUNOPo->op_first;
5806 newop = kUNOP->op_first->op_sibling;
5808 (newop->op_sibling ||
5809 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5810 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5811 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5816 op_getmad(kUNOP->op_first,newop,'K');
5818 op_free(kUNOP->op_first);
5820 kUNOP->op_first = newop;
5822 o->op_ppaddr = PL_ppaddr[++o->op_type];
5827 Perl_ck_delete(pTHX_ OP *o)
5831 if (o->op_flags & OPf_KIDS) {
5832 OP * const kid = cUNOPo->op_first;
5833 switch (kid->op_type) {
5835 o->op_flags |= OPf_SPECIAL;
5838 o->op_private |= OPpSLICE;
5841 o->op_flags |= OPf_SPECIAL;
5846 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5855 Perl_ck_die(pTHX_ OP *o)
5858 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5864 Perl_ck_eof(pTHX_ OP *o)
5868 if (o->op_flags & OPf_KIDS) {
5869 if (cLISTOPo->op_first->op_type == OP_STUB) {
5871 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5873 op_getmad(o,newop,'O');
5885 Perl_ck_eval(pTHX_ OP *o)
5888 PL_hints |= HINT_BLOCK_SCOPE;
5889 if (o->op_flags & OPf_KIDS) {
5890 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5893 o->op_flags &= ~OPf_KIDS;
5896 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5902 cUNOPo->op_first = 0;
5907 NewOp(1101, enter, 1, LOGOP);
5908 enter->op_type = OP_ENTERTRY;
5909 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5910 enter->op_private = 0;
5912 /* establish postfix order */
5913 enter->op_next = (OP*)enter;
5915 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5916 o->op_type = OP_LEAVETRY;
5917 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5918 enter->op_other = o;
5919 op_getmad(oldo,o,'O');
5933 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5934 op_getmad(oldo,o,'O');
5936 o->op_targ = (PADOFFSET)PL_hints;
5937 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5938 /* Store a copy of %^H that pp_entereval can pick up */
5939 OP *hhop = newSVOP(OP_CONST, 0,
5940 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
5941 cUNOPo->op_first->op_sibling = hhop;
5942 o->op_private |= OPpEVAL_HAS_HH;
5948 Perl_ck_exit(pTHX_ OP *o)
5951 HV * const table = GvHV(PL_hintgv);
5953 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5954 if (svp && *svp && SvTRUE(*svp))
5955 o->op_private |= OPpEXIT_VMSISH;
5957 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5963 Perl_ck_exec(pTHX_ OP *o)
5965 if (o->op_flags & OPf_STACKED) {
5968 kid = cUNOPo->op_first->op_sibling;
5969 if (kid->op_type == OP_RV2GV)
5978 Perl_ck_exists(pTHX_ OP *o)
5982 if (o->op_flags & OPf_KIDS) {
5983 OP * const kid = cUNOPo->op_first;
5984 if (kid->op_type == OP_ENTERSUB) {
5985 (void) ref(kid, o->op_type);
5986 if (kid->op_type != OP_RV2CV && !PL_error_count)
5987 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5989 o->op_private |= OPpEXISTS_SUB;
5991 else if (kid->op_type == OP_AELEM)
5992 o->op_flags |= OPf_SPECIAL;
5993 else if (kid->op_type != OP_HELEM)
5994 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6002 Perl_ck_rvconst(pTHX_ register OP *o)
6005 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6007 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6008 if (o->op_type == OP_RV2CV)
6009 o->op_private &= ~1;
6011 if (kid->op_type == OP_CONST) {
6014 SV * const kidsv = kid->op_sv;
6016 /* Is it a constant from cv_const_sv()? */
6017 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6018 SV * const rsv = SvRV(kidsv);
6019 const int svtype = SvTYPE(rsv);
6020 const char *badtype = NULL;
6022 switch (o->op_type) {
6024 if (svtype > SVt_PVMG)
6025 badtype = "a SCALAR";
6028 if (svtype != SVt_PVAV)
6029 badtype = "an ARRAY";
6032 if (svtype != SVt_PVHV)
6036 if (svtype != SVt_PVCV)
6041 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6044 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6045 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6046 /* If this is an access to a stash, disable "strict refs", because
6047 * stashes aren't auto-vivified at compile-time (unless we store
6048 * symbols in them), and we don't want to produce a run-time
6049 * stricture error when auto-vivifying the stash. */
6050 const char *s = SvPV_nolen(kidsv);
6051 const STRLEN l = SvCUR(kidsv);
6052 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6053 o->op_private &= ~HINT_STRICT_REFS;
6055 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6056 const char *badthing;
6057 switch (o->op_type) {
6059 badthing = "a SCALAR";
6062 badthing = "an ARRAY";
6065 badthing = "a HASH";
6073 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6077 * This is a little tricky. We only want to add the symbol if we
6078 * didn't add it in the lexer. Otherwise we get duplicate strict
6079 * warnings. But if we didn't add it in the lexer, we must at
6080 * least pretend like we wanted to add it even if it existed before,
6081 * or we get possible typo warnings. OPpCONST_ENTERED says
6082 * whether the lexer already added THIS instance of this symbol.
6084 iscv = (o->op_type == OP_RV2CV) * 2;
6086 gv = gv_fetchsv(kidsv,
6087 iscv | !(kid->op_private & OPpCONST_ENTERED),
6090 : o->op_type == OP_RV2SV
6092 : o->op_type == OP_RV2AV
6094 : o->op_type == OP_RV2HV
6097 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6099 kid->op_type = OP_GV;
6100 SvREFCNT_dec(kid->op_sv);
6102 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6103 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6104 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6106 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6108 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6110 kid->op_private = 0;
6111 kid->op_ppaddr = PL_ppaddr[OP_GV];
6118 Perl_ck_ftst(pTHX_ OP *o)
6121 const I32 type = o->op_type;
6123 if (o->op_flags & OPf_REF) {
6126 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6127 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6129 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6130 OP * const newop = newGVOP(type, OPf_REF,
6131 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6133 op_getmad(o,newop,'O');
6139 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6140 o->op_private |= OPpFT_ACCESS;
6141 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
6142 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
6143 o->op_private |= OPpFT_STACKED;
6151 if (type == OP_FTTTY)
6152 o = newGVOP(type, OPf_REF, PL_stdingv);
6154 o = newUNOP(type, 0, newDEFSVOP());
6155 op_getmad(oldo,o,'O');
6161 Perl_ck_fun(pTHX_ OP *o)
6164 const int type = o->op_type;
6165 register I32 oa = PL_opargs[type] >> OASHIFT;
6167 if (o->op_flags & OPf_STACKED) {
6168 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6171 return no_fh_allowed(o);
6174 if (o->op_flags & OPf_KIDS) {
6175 OP **tokid = &cLISTOPo->op_first;
6176 register OP *kid = cLISTOPo->op_first;
6180 if (kid->op_type == OP_PUSHMARK ||
6181 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6183 tokid = &kid->op_sibling;
6184 kid = kid->op_sibling;
6186 if (!kid && PL_opargs[type] & OA_DEFGV)
6187 *tokid = kid = newDEFSVOP();
6191 sibl = kid->op_sibling;
6193 if (!sibl && kid->op_type == OP_STUB) {
6200 /* list seen where single (scalar) arg expected? */
6201 if (numargs == 1 && !(oa >> 4)
6202 && kid->op_type == OP_LIST && type != OP_SCALAR)
6204 return too_many_arguments(o,PL_op_desc[type]);
6217 if ((type == OP_PUSH || type == OP_UNSHIFT)
6218 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6219 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6220 "Useless use of %s with no values",
6223 if (kid->op_type == OP_CONST &&
6224 (kid->op_private & OPpCONST_BARE))
6226 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6227 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6228 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6229 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6230 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6231 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6233 op_getmad(kid,newop,'K');
6238 kid->op_sibling = sibl;
6241 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6242 bad_type(numargs, "array", PL_op_desc[type], kid);
6246 if (kid->op_type == OP_CONST &&
6247 (kid->op_private & OPpCONST_BARE))
6249 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6250 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6251 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6252 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6253 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6254 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6256 op_getmad(kid,newop,'K');
6261 kid->op_sibling = sibl;
6264 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6265 bad_type(numargs, "hash", PL_op_desc[type], kid);
6270 OP * const newop = newUNOP(OP_NULL, 0, kid);
6271 kid->op_sibling = 0;
6273 newop->op_next = newop;
6275 kid->op_sibling = sibl;
6280 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6281 if (kid->op_type == OP_CONST &&
6282 (kid->op_private & OPpCONST_BARE))
6284 OP * const newop = newGVOP(OP_GV, 0,
6285 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6286 if (!(o->op_private & 1) && /* if not unop */
6287 kid == cLISTOPo->op_last)
6288 cLISTOPo->op_last = newop;
6290 op_getmad(kid,newop,'K');
6296 else if (kid->op_type == OP_READLINE) {
6297 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6298 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6301 I32 flags = OPf_SPECIAL;
6305 /* is this op a FH constructor? */
6306 if (is_handle_constructor(o,numargs)) {
6307 const char *name = NULL;
6311 /* Set a flag to tell rv2gv to vivify
6312 * need to "prove" flag does not mean something
6313 * else already - NI-S 1999/05/07
6316 if (kid->op_type == OP_PADSV) {
6317 name = PAD_COMPNAME_PV(kid->op_targ);
6318 /* SvCUR of a pad namesv can't be trusted
6319 * (see PL_generation), so calc its length
6325 else if (kid->op_type == OP_RV2SV
6326 && kUNOP->op_first->op_type == OP_GV)
6328 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6330 len = GvNAMELEN(gv);
6332 else if (kid->op_type == OP_AELEM
6333 || kid->op_type == OP_HELEM)
6335 OP *op = ((BINOP*)kid)->op_first;
6339 const char * const a =
6340 kid->op_type == OP_AELEM ?
6342 if (((op->op_type == OP_RV2AV) ||
6343 (op->op_type == OP_RV2HV)) &&
6344 (op = ((UNOP*)op)->op_first) &&
6345 (op->op_type == OP_GV)) {
6346 /* packagevar $a[] or $h{} */
6347 GV * const gv = cGVOPx_gv(op);
6355 else if (op->op_type == OP_PADAV
6356 || op->op_type == OP_PADHV) {
6357 /* lexicalvar $a[] or $h{} */
6358 const char * const padname =
6359 PAD_COMPNAME_PV(op->op_targ);
6368 name = SvPV_const(tmpstr, len);
6373 name = "__ANONIO__";
6380 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6381 namesv = PAD_SVl(targ);
6382 SvUPGRADE(namesv, SVt_PV);
6384 sv_setpvn(namesv, "$", 1);
6385 sv_catpvn(namesv, name, len);
6388 kid->op_sibling = 0;
6389 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6390 kid->op_targ = targ;
6391 kid->op_private |= priv;
6393 kid->op_sibling = sibl;
6399 mod(scalar(kid), type);
6403 tokid = &kid->op_sibling;
6404 kid = kid->op_sibling;
6407 if (kid && kid->op_type != OP_STUB)
6408 return too_many_arguments(o,OP_DESC(o));
6409 o->op_private |= numargs;
6411 /* FIXME - should the numargs move as for the PERL_MAD case? */
6412 o->op_private |= numargs;
6414 return too_many_arguments(o,OP_DESC(o));
6418 else if (PL_opargs[type] & OA_DEFGV) {
6420 OP *newop = newUNOP(type, 0, newDEFSVOP());
6421 op_getmad(o,newop,'O');
6424 /* Ordering of these two is important to keep f_map.t passing. */
6426 return newUNOP(type, 0, newDEFSVOP());
6431 while (oa & OA_OPTIONAL)
6433 if (oa && oa != OA_LIST)
6434 return too_few_arguments(o,OP_DESC(o));
6440 Perl_ck_glob(pTHX_ OP *o)
6446 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6447 append_elem(OP_GLOB, o, newDEFSVOP());
6449 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6450 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6452 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6455 #if !defined(PERL_EXTERNAL_GLOB)
6456 /* XXX this can be tightened up and made more failsafe. */
6457 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6460 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6461 newSVpvs("File::Glob"), NULL, NULL, NULL);
6462 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6463 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6464 GvCV(gv) = GvCV(glob_gv);
6465 SvREFCNT_inc_void((SV*)GvCV(gv));
6466 GvIMPORTED_CV_on(gv);
6469 #endif /* PERL_EXTERNAL_GLOB */
6471 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6472 append_elem(OP_GLOB, o,
6473 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6474 o->op_type = OP_LIST;
6475 o->op_ppaddr = PL_ppaddr[OP_LIST];
6476 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6477 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6478 cLISTOPo->op_first->op_targ = 0;
6479 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6480 append_elem(OP_LIST, o,
6481 scalar(newUNOP(OP_RV2CV, 0,
6482 newGVOP(OP_GV, 0, gv)))));
6483 o = newUNOP(OP_NULL, 0, ck_subr(o));
6484 o->op_targ = OP_GLOB; /* hint at what it used to be */
6487 gv = newGVgen("main");
6489 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6495 Perl_ck_grep(pTHX_ OP *o)
6500 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6503 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6504 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6506 if (o->op_flags & OPf_STACKED) {
6509 kid = cLISTOPo->op_first->op_sibling;
6510 if (!cUNOPx(kid)->op_next)
6511 Perl_croak(aTHX_ "panic: ck_grep");
6512 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6515 NewOp(1101, gwop, 1, LOGOP);
6516 kid->op_next = (OP*)gwop;
6517 o->op_flags &= ~OPf_STACKED;
6519 kid = cLISTOPo->op_first->op_sibling;
6520 if (type == OP_MAPWHILE)
6527 kid = cLISTOPo->op_first->op_sibling;
6528 if (kid->op_type != OP_NULL)
6529 Perl_croak(aTHX_ "panic: ck_grep");
6530 kid = kUNOP->op_first;
6533 NewOp(1101, gwop, 1, LOGOP);
6534 gwop->op_type = type;
6535 gwop->op_ppaddr = PL_ppaddr[type];
6536 gwop->op_first = listkids(o);
6537 gwop->op_flags |= OPf_KIDS;
6538 gwop->op_other = LINKLIST(kid);
6539 kid->op_next = (OP*)gwop;
6540 offset = pad_findmy("$_");
6541 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6542 o->op_private = gwop->op_private = 0;
6543 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6546 o->op_private = gwop->op_private = OPpGREP_LEX;
6547 gwop->op_targ = o->op_targ = offset;
6550 kid = cLISTOPo->op_first->op_sibling;
6551 if (!kid || !kid->op_sibling)
6552 return too_few_arguments(o,OP_DESC(o));
6553 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6554 mod(kid, OP_GREPSTART);
6560 Perl_ck_index(pTHX_ OP *o)
6562 if (o->op_flags & OPf_KIDS) {
6563 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6565 kid = kid->op_sibling; /* get past "big" */
6566 if (kid && kid->op_type == OP_CONST)
6567 fbm_compile(((SVOP*)kid)->op_sv, 0);
6573 Perl_ck_lengthconst(pTHX_ OP *o)
6575 /* XXX length optimization goes here */
6580 Perl_ck_lfun(pTHX_ OP *o)
6582 const OPCODE type = o->op_type;
6583 return modkids(ck_fun(o), type);
6587 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6589 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6590 switch (cUNOPo->op_first->op_type) {
6592 /* This is needed for
6593 if (defined %stash::)
6594 to work. Do not break Tk.
6596 break; /* Globals via GV can be undef */
6598 case OP_AASSIGN: /* Is this a good idea? */
6599 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6600 "defined(@array) is deprecated");
6601 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6602 "\t(Maybe you should just omit the defined()?)\n");
6605 /* This is needed for
6606 if (defined %stash::)
6607 to work. Do not break Tk.
6609 break; /* Globals via GV can be undef */
6611 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6612 "defined(%%hash) is deprecated");
6613 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6614 "\t(Maybe you should just omit the defined()?)\n");
6625 Perl_ck_rfun(pTHX_ OP *o)
6627 const OPCODE type = o->op_type;
6628 return refkids(ck_fun(o), type);
6632 Perl_ck_listiob(pTHX_ OP *o)
6636 kid = cLISTOPo->op_first;
6639 kid = cLISTOPo->op_first;
6641 if (kid->op_type == OP_PUSHMARK)
6642 kid = kid->op_sibling;
6643 if (kid && o->op_flags & OPf_STACKED)
6644 kid = kid->op_sibling;
6645 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6646 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6647 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6648 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6649 cLISTOPo->op_first->op_sibling = kid;
6650 cLISTOPo->op_last = kid;
6651 kid = kid->op_sibling;
6656 append_elem(o->op_type, o, newDEFSVOP());
6662 Perl_ck_say(pTHX_ OP *o)
6665 o->op_type = OP_PRINT;
6666 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6667 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6672 Perl_ck_smartmatch(pTHX_ OP *o)
6675 if (0 == (o->op_flags & OPf_SPECIAL)) {
6676 OP *first = cBINOPo->op_first;
6677 OP *second = first->op_sibling;
6679 /* Implicitly take a reference to an array or hash */
6680 first->op_sibling = NULL;
6681 first = cBINOPo->op_first = ref_array_or_hash(first);
6682 second = first->op_sibling = ref_array_or_hash(second);
6684 /* Implicitly take a reference to a regular expression */
6685 if (first->op_type == OP_MATCH) {
6686 first->op_type = OP_QR;
6687 first->op_ppaddr = PL_ppaddr[OP_QR];
6689 if (second->op_type == OP_MATCH) {
6690 second->op_type = OP_QR;
6691 second->op_ppaddr = PL_ppaddr[OP_QR];
6700 Perl_ck_sassign(pTHX_ OP *o)
6702 OP *kid = cLISTOPo->op_first;
6703 /* has a disposable target? */
6704 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6705 && !(kid->op_flags & OPf_STACKED)
6706 /* Cannot steal the second time! */
6707 && !(kid->op_private & OPpTARGET_MY))
6709 OP * const kkid = kid->op_sibling;
6711 /* Can just relocate the target. */
6712 if (kkid && kkid->op_type == OP_PADSV
6713 && !(kkid->op_private & OPpLVAL_INTRO))
6715 kid->op_targ = kkid->op_targ;
6717 /* Now we do not need PADSV and SASSIGN. */
6718 kid->op_sibling = o->op_sibling; /* NULL */
6719 cLISTOPo->op_first = NULL;
6721 op_getmad(o,kid,'O');
6722 op_getmad(kkid,kid,'M');
6727 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6735 Perl_ck_match(pTHX_ OP *o)
6738 if (o->op_type != OP_QR && PL_compcv) {
6739 const I32 offset = pad_findmy("$_");
6740 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6741 o->op_targ = offset;
6742 o->op_private |= OPpTARGET_MY;
6745 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6746 o->op_private |= OPpRUNTIME;
6751 Perl_ck_method(pTHX_ OP *o)
6753 OP * const kid = cUNOPo->op_first;
6754 if (kid->op_type == OP_CONST) {
6755 SV* sv = kSVOP->op_sv;
6756 const char * const method = SvPVX_const(sv);
6757 if (!(strchr(method, ':') || strchr(method, '\''))) {
6759 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6760 sv = newSVpvn_share(method, SvCUR(sv), 0);
6763 kSVOP->op_sv = NULL;
6765 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6767 op_getmad(o,cmop,'O');
6778 Perl_ck_null(pTHX_ OP *o)
6780 PERL_UNUSED_CONTEXT;
6785 Perl_ck_open(pTHX_ OP *o)
6788 HV * const table = GvHV(PL_hintgv);
6790 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6792 const I32 mode = mode_from_discipline(*svp);
6793 if (mode & O_BINARY)
6794 o->op_private |= OPpOPEN_IN_RAW;
6795 else if (mode & O_TEXT)
6796 o->op_private |= OPpOPEN_IN_CRLF;
6799 svp = hv_fetchs(table, "open_OUT", FALSE);
6801 const I32 mode = mode_from_discipline(*svp);
6802 if (mode & O_BINARY)
6803 o->op_private |= OPpOPEN_OUT_RAW;
6804 else if (mode & O_TEXT)
6805 o->op_private |= OPpOPEN_OUT_CRLF;
6808 if (o->op_type == OP_BACKTICK)
6811 /* In case of three-arg dup open remove strictness
6812 * from the last arg if it is a bareword. */
6813 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6814 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6818 if ((last->op_type == OP_CONST) && /* The bareword. */
6819 (last->op_private & OPpCONST_BARE) &&
6820 (last->op_private & OPpCONST_STRICT) &&
6821 (oa = first->op_sibling) && /* The fh. */
6822 (oa = oa->op_sibling) && /* The mode. */
6823 (oa->op_type == OP_CONST) &&
6824 SvPOK(((SVOP*)oa)->op_sv) &&
6825 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6826 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6827 (last == oa->op_sibling)) /* The bareword. */
6828 last->op_private &= ~OPpCONST_STRICT;
6834 Perl_ck_repeat(pTHX_ OP *o)
6836 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6837 o->op_private |= OPpREPEAT_DOLIST;
6838 cBINOPo->op_first = force_list(cBINOPo->op_first);
6846 Perl_ck_require(pTHX_ OP *o)
6851 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6852 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6854 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6855 SV * const sv = kid->op_sv;
6856 U32 was_readonly = SvREADONLY(sv);
6861 sv_force_normal_flags(sv, 0);
6862 assert(!SvREADONLY(sv));
6869 for (s = SvPVX(sv); *s; s++) {
6870 if (*s == ':' && s[1] == ':') {
6871 const STRLEN len = strlen(s+2)+1;
6873 Move(s+2, s+1, len, char);
6874 SvCUR_set(sv, SvCUR(sv) - 1);
6877 sv_catpvs(sv, ".pm");
6878 SvFLAGS(sv) |= was_readonly;
6882 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6883 /* handle override, if any */
6884 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6885 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6886 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6887 gv = gvp ? *gvp : NULL;
6891 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6892 OP * const kid = cUNOPo->op_first;
6895 cUNOPo->op_first = 0;
6899 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6900 append_elem(OP_LIST, kid,
6901 scalar(newUNOP(OP_RV2CV, 0,
6904 op_getmad(o,newop,'O');
6912 Perl_ck_return(pTHX_ OP *o)
6915 if (CvLVALUE(PL_compcv)) {
6917 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6918 mod(kid, OP_LEAVESUBLV);
6924 Perl_ck_select(pTHX_ OP *o)
6928 if (o->op_flags & OPf_KIDS) {
6929 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6930 if (kid && kid->op_sibling) {
6931 o->op_type = OP_SSELECT;
6932 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6934 return fold_constants(o);
6938 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6939 if (kid && kid->op_type == OP_RV2GV)
6940 kid->op_private &= ~HINT_STRICT_REFS;
6945 Perl_ck_shift(pTHX_ OP *o)
6948 const I32 type = o->op_type;
6950 if (!(o->op_flags & OPf_KIDS)) {
6952 /* FIXME - this can be refactored to reduce code in #ifdefs */
6954 OP * const oldo = o;
6958 argop = newUNOP(OP_RV2AV, 0,
6959 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6961 o = newUNOP(type, 0, scalar(argop));
6962 op_getmad(oldo,o,'O');
6965 return newUNOP(type, 0, scalar(argop));
6968 return scalar(modkids(ck_fun(o), type));
6972 Perl_ck_sort(pTHX_ OP *o)
6977 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6979 HV * const hinthv = GvHV(PL_hintgv);
6981 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6983 const I32 sorthints = (I32)SvIV(*svp);
6984 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6985 o->op_private |= OPpSORT_QSORT;
6986 if ((sorthints & HINT_SORT_STABLE) != 0)
6987 o->op_private |= OPpSORT_STABLE;
6992 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6994 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6995 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6997 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6999 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7001 if (kid->op_type == OP_SCOPE) {
7005 else if (kid->op_type == OP_LEAVE) {
7006 if (o->op_type == OP_SORT) {
7007 op_null(kid); /* wipe out leave */
7010 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7011 if (k->op_next == kid)
7013 /* don't descend into loops */
7014 else if (k->op_type == OP_ENTERLOOP
7015 || k->op_type == OP_ENTERITER)
7017 k = cLOOPx(k)->op_lastop;
7022 kid->op_next = 0; /* just disconnect the leave */
7023 k = kLISTOP->op_first;
7028 if (o->op_type == OP_SORT) {
7029 /* provide scalar context for comparison function/block */
7035 o->op_flags |= OPf_SPECIAL;
7037 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7040 firstkid = firstkid->op_sibling;
7043 /* provide list context for arguments */
7044 if (o->op_type == OP_SORT)
7051 S_simplify_sort(pTHX_ OP *o)
7054 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7059 if (!(o->op_flags & OPf_STACKED))
7061 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7062 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7063 kid = kUNOP->op_first; /* get past null */
7064 if (kid->op_type != OP_SCOPE)
7066 kid = kLISTOP->op_last; /* get past scope */
7067 switch(kid->op_type) {
7075 k = kid; /* remember this node*/
7076 if (kBINOP->op_first->op_type != OP_RV2SV)
7078 kid = kBINOP->op_first; /* get past cmp */
7079 if (kUNOP->op_first->op_type != OP_GV)
7081 kid = kUNOP->op_first; /* get past rv2sv */
7083 if (GvSTASH(gv) != PL_curstash)
7085 gvname = GvNAME(gv);
7086 if (*gvname == 'a' && gvname[1] == '\0')
7088 else if (*gvname == 'b' && gvname[1] == '\0')
7093 kid = k; /* back to cmp */
7094 if (kBINOP->op_last->op_type != OP_RV2SV)
7096 kid = kBINOP->op_last; /* down to 2nd arg */
7097 if (kUNOP->op_first->op_type != OP_GV)
7099 kid = kUNOP->op_first; /* get past rv2sv */
7101 if (GvSTASH(gv) != PL_curstash)
7103 gvname = GvNAME(gv);
7105 ? !(*gvname == 'a' && gvname[1] == '\0')
7106 : !(*gvname == 'b' && gvname[1] == '\0'))
7108 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7110 o->op_private |= OPpSORT_DESCEND;
7111 if (k->op_type == OP_NCMP)
7112 o->op_private |= OPpSORT_NUMERIC;
7113 if (k->op_type == OP_I_NCMP)
7114 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7115 kid = cLISTOPo->op_first->op_sibling;
7116 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7118 op_getmad(kid,o,'S'); /* then delete it */
7120 op_free(kid); /* then delete it */
7125 Perl_ck_split(pTHX_ OP *o)
7130 if (o->op_flags & OPf_STACKED)
7131 return no_fh_allowed(o);
7133 kid = cLISTOPo->op_first;
7134 if (kid->op_type != OP_NULL)
7135 Perl_croak(aTHX_ "panic: ck_split");
7136 kid = kid->op_sibling;
7137 op_free(cLISTOPo->op_first);
7138 cLISTOPo->op_first = kid;
7140 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7141 cLISTOPo->op_last = kid; /* There was only one element previously */
7144 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7145 OP * const sibl = kid->op_sibling;
7146 kid->op_sibling = 0;
7147 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7148 if (cLISTOPo->op_first == cLISTOPo->op_last)
7149 cLISTOPo->op_last = kid;
7150 cLISTOPo->op_first = kid;
7151 kid->op_sibling = sibl;
7154 kid->op_type = OP_PUSHRE;
7155 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7157 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7158 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7159 "Use of /g modifier is meaningless in split");
7162 if (!kid->op_sibling)
7163 append_elem(OP_SPLIT, o, newDEFSVOP());
7165 kid = kid->op_sibling;
7168 if (!kid->op_sibling)
7169 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7171 kid = kid->op_sibling;
7174 if (kid->op_sibling)
7175 return too_many_arguments(o,OP_DESC(o));
7181 Perl_ck_join(pTHX_ OP *o)
7183 const OP * const kid = cLISTOPo->op_first->op_sibling;
7184 if (kid && kid->op_type == OP_MATCH) {
7185 if (ckWARN(WARN_SYNTAX)) {
7186 const REGEXP *re = PM_GETRE(kPMOP);
7187 const char *pmstr = re ? re->precomp : "STRING";
7188 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7189 "/%s/ should probably be written as \"%s\"",
7197 Perl_ck_subr(pTHX_ OP *o)
7200 OP *prev = ((cUNOPo->op_first->op_sibling)
7201 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7202 OP *o2 = prev->op_sibling;
7209 I32 contextclass = 0;
7213 o->op_private |= OPpENTERSUB_HASTARG;
7214 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7215 if (cvop->op_type == OP_RV2CV) {
7217 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7218 op_null(cvop); /* disable rv2cv */
7219 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7220 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7221 GV *gv = cGVOPx_gv(tmpop);
7224 tmpop->op_private |= OPpEARLY_CV;
7227 namegv = CvANON(cv) ? gv : CvGV(cv);
7228 proto = SvPV_nolen((SV*)cv);
7230 if (CvASSERTION(cv)) {
7231 if (PL_hints & HINT_ASSERTING) {
7232 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7233 o->op_private |= OPpENTERSUB_DB;
7237 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7238 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7239 "Impossible to activate assertion call");
7246 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7247 if (o2->op_type == OP_CONST)
7248 o2->op_private &= ~OPpCONST_STRICT;
7249 else if (o2->op_type == OP_LIST) {
7250 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7251 if (sib && sib->op_type == OP_CONST)
7252 sib->op_private &= ~OPpCONST_STRICT;
7255 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7256 if (PERLDB_SUB && PL_curstash != PL_debstash)
7257 o->op_private |= OPpENTERSUB_DB;
7258 while (o2 != cvop) {
7260 if (PL_madskills && o2->op_type == OP_NULL)
7261 o3 = ((UNOP*)o2)->op_first;
7267 return too_many_arguments(o, gv_ename(namegv));
7285 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7287 arg == 1 ? "block or sub {}" : "sub {}",
7288 gv_ename(namegv), o3);
7291 /* '*' allows any scalar type, including bareword */
7294 if (o3->op_type == OP_RV2GV)
7295 goto wrapref; /* autoconvert GLOB -> GLOBref */
7296 else if (o3->op_type == OP_CONST)
7297 o3->op_private &= ~OPpCONST_STRICT;
7298 else if (o3->op_type == OP_ENTERSUB) {
7299 /* accidental subroutine, revert to bareword */
7300 OP *gvop = ((UNOP*)o3)->op_first;
7301 if (gvop && gvop->op_type == OP_NULL) {
7302 gvop = ((UNOP*)gvop)->op_first;
7304 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7307 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7308 (gvop = ((UNOP*)gvop)->op_first) &&
7309 gvop->op_type == OP_GV)
7311 GV * const gv = cGVOPx_gv(gvop);
7312 OP * const sibling = o2->op_sibling;
7313 SV * const n = newSVpvs("");
7315 OP * const oldo2 = o2;
7319 gv_fullname4(n, gv, "", FALSE);
7320 o2 = newSVOP(OP_CONST, 0, n);
7321 op_getmad(oldo2,o2,'O');
7322 prev->op_sibling = o2;
7323 o2->op_sibling = sibling;
7339 if (contextclass++ == 0) {
7340 e = strchr(proto, ']');
7341 if (!e || e == proto)
7350 /* XXX We shouldn't be modifying proto, so we can const proto */
7355 while (*--p != '[');
7356 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
7357 gv_ename(namegv), o3);
7363 if (o3->op_type == OP_RV2GV)
7366 bad_type(arg, "symbol", gv_ename(namegv), o3);
7369 if (o3->op_type == OP_ENTERSUB)
7372 bad_type(arg, "subroutine entry", gv_ename(namegv),
7376 if (o3->op_type == OP_RV2SV ||
7377 o3->op_type == OP_PADSV ||
7378 o3->op_type == OP_HELEM ||
7379 o3->op_type == OP_AELEM ||
7380 o3->op_type == OP_THREADSV)
7383 bad_type(arg, "scalar", gv_ename(namegv), o3);
7386 if (o3->op_type == OP_RV2AV ||
7387 o3->op_type == OP_PADAV)
7390 bad_type(arg, "array", gv_ename(namegv), o3);
7393 if (o3->op_type == OP_RV2HV ||
7394 o3->op_type == OP_PADHV)
7397 bad_type(arg, "hash", gv_ename(namegv), o3);
7402 OP* const sib = kid->op_sibling;
7403 kid->op_sibling = 0;
7404 o2 = newUNOP(OP_REFGEN, 0, kid);
7405 o2->op_sibling = sib;
7406 prev->op_sibling = o2;
7408 if (contextclass && e) {
7423 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7424 gv_ename(namegv), cv);
7429 mod(o2, OP_ENTERSUB);
7431 o2 = o2->op_sibling;
7433 if (proto && !optional &&
7434 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
7435 return too_few_arguments(o, gv_ename(namegv));
7438 OP * const oldo = o;
7442 o=newSVOP(OP_CONST, 0, newSViv(0));
7443 op_getmad(oldo,o,'O');
7449 Perl_ck_svconst(pTHX_ OP *o)
7451 PERL_UNUSED_CONTEXT;
7452 SvREADONLY_on(cSVOPo->op_sv);
7457 Perl_ck_chdir(pTHX_ OP *o)
7459 if (o->op_flags & OPf_KIDS) {
7460 SVOP *kid = (SVOP*)cUNOPo->op_first;
7462 if (kid && kid->op_type == OP_CONST &&
7463 (kid->op_private & OPpCONST_BARE))
7465 o->op_flags |= OPf_SPECIAL;
7466 kid->op_private &= ~OPpCONST_STRICT;
7473 Perl_ck_trunc(pTHX_ OP *o)
7475 if (o->op_flags & OPf_KIDS) {
7476 SVOP *kid = (SVOP*)cUNOPo->op_first;
7478 if (kid->op_type == OP_NULL)
7479 kid = (SVOP*)kid->op_sibling;
7480 if (kid && kid->op_type == OP_CONST &&
7481 (kid->op_private & OPpCONST_BARE))
7483 o->op_flags |= OPf_SPECIAL;
7484 kid->op_private &= ~OPpCONST_STRICT;
7491 Perl_ck_unpack(pTHX_ OP *o)
7493 OP *kid = cLISTOPo->op_first;
7494 if (kid->op_sibling) {
7495 kid = kid->op_sibling;
7496 if (!kid->op_sibling)
7497 kid->op_sibling = newDEFSVOP();
7503 Perl_ck_substr(pTHX_ OP *o)
7506 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7507 OP *kid = cLISTOPo->op_first;
7509 if (kid->op_type == OP_NULL)
7510 kid = kid->op_sibling;
7512 kid->op_flags |= OPf_MOD;
7518 /* A peephole optimizer. We visit the ops in the order they're to execute.
7519 * See the comments at the top of this file for more details about when
7520 * peep() is called */
7523 Perl_peep(pTHX_ register OP *o)
7526 register OP* oldop = NULL;
7528 if (!o || o->op_opt)
7532 SAVEVPTR(PL_curcop);
7533 for (; o; o = o->op_next) {
7537 switch (o->op_type) {
7541 PL_curcop = ((COP*)o); /* for warnings */
7546 if (cSVOPo->op_private & OPpCONST_STRICT)
7547 no_bareword_allowed(o);
7549 case OP_METHOD_NAMED:
7550 /* Relocate sv to the pad for thread safety.
7551 * Despite being a "constant", the SV is written to,
7552 * for reference counts, sv_upgrade() etc. */
7554 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7555 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7556 /* If op_sv is already a PADTMP then it is being used by
7557 * some pad, so make a copy. */
7558 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7559 SvREADONLY_on(PAD_SVl(ix));
7560 SvREFCNT_dec(cSVOPo->op_sv);
7562 else if (o->op_type == OP_CONST
7563 && cSVOPo->op_sv == &PL_sv_undef) {
7564 /* PL_sv_undef is hack - it's unsafe to store it in the
7565 AV that is the pad, because av_fetch treats values of
7566 PL_sv_undef as a "free" AV entry and will merrily
7567 replace them with a new SV, causing pad_alloc to think
7568 that this pad slot is free. (When, clearly, it is not)
7570 SvOK_off(PAD_SVl(ix));
7571 SvPADTMP_on(PAD_SVl(ix));
7572 SvREADONLY_on(PAD_SVl(ix));
7575 SvREFCNT_dec(PAD_SVl(ix));
7576 SvPADTMP_on(cSVOPo->op_sv);
7577 PAD_SETSV(ix, cSVOPo->op_sv);
7578 /* XXX I don't know how this isn't readonly already. */
7579 SvREADONLY_on(PAD_SVl(ix));
7581 cSVOPo->op_sv = NULL;
7589 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7590 if (o->op_next->op_private & OPpTARGET_MY) {
7591 if (o->op_flags & OPf_STACKED) /* chained concats */
7592 goto ignore_optimization;
7594 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7595 o->op_targ = o->op_next->op_targ;
7596 o->op_next->op_targ = 0;
7597 o->op_private |= OPpTARGET_MY;
7600 op_null(o->op_next);
7602 ignore_optimization:
7606 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7608 break; /* Scalar stub must produce undef. List stub is noop */
7612 if (o->op_targ == OP_NEXTSTATE
7613 || o->op_targ == OP_DBSTATE
7614 || o->op_targ == OP_SETSTATE)
7616 PL_curcop = ((COP*)o);
7618 /* XXX: We avoid setting op_seq here to prevent later calls
7619 to peep() from mistakenly concluding that optimisation
7620 has already occurred. This doesn't fix the real problem,
7621 though (See 20010220.007). AMS 20010719 */
7622 /* op_seq functionality is now replaced by op_opt */
7623 if (oldop && o->op_next) {
7624 oldop->op_next = o->op_next;
7632 if (oldop && o->op_next) {
7633 oldop->op_next = o->op_next;
7641 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7642 OP* const pop = (o->op_type == OP_PADAV) ?
7643 o->op_next : o->op_next->op_next;
7645 if (pop && pop->op_type == OP_CONST &&
7646 ((PL_op = pop->op_next)) &&
7647 pop->op_next->op_type == OP_AELEM &&
7648 !(pop->op_next->op_private &
7649 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7650 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7655 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7656 no_bareword_allowed(pop);
7657 if (o->op_type == OP_GV)
7658 op_null(o->op_next);
7659 op_null(pop->op_next);
7661 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7662 o->op_next = pop->op_next->op_next;
7663 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7664 o->op_private = (U8)i;
7665 if (o->op_type == OP_GV) {
7670 o->op_flags |= OPf_SPECIAL;
7671 o->op_type = OP_AELEMFAST;
7677 if (o->op_next->op_type == OP_RV2SV) {
7678 if (!(o->op_next->op_private & OPpDEREF)) {
7679 op_null(o->op_next);
7680 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7682 o->op_next = o->op_next->op_next;
7683 o->op_type = OP_GVSV;
7684 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7687 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7688 GV * const gv = cGVOPo_gv;
7689 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7690 /* XXX could check prototype here instead of just carping */
7691 SV * const sv = sv_newmortal();
7692 gv_efullname3(sv, gv, NULL);
7693 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7694 "%"SVf"() called too early to check prototype",
7698 else if (o->op_next->op_type == OP_READLINE
7699 && o->op_next->op_next->op_type == OP_CONCAT
7700 && (o->op_next->op_next->op_flags & OPf_STACKED))
7702 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7703 o->op_type = OP_RCATLINE;
7704 o->op_flags |= OPf_STACKED;
7705 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7706 op_null(o->op_next->op_next);
7707 op_null(o->op_next);
7724 while (cLOGOP->op_other->op_type == OP_NULL)
7725 cLOGOP->op_other = cLOGOP->op_other->op_next;
7726 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7732 while (cLOOP->op_redoop->op_type == OP_NULL)
7733 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7734 peep(cLOOP->op_redoop);
7735 while (cLOOP->op_nextop->op_type == OP_NULL)
7736 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7737 peep(cLOOP->op_nextop);
7738 while (cLOOP->op_lastop->op_type == OP_NULL)
7739 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7740 peep(cLOOP->op_lastop);
7747 while (cPMOP->op_pmreplstart &&
7748 cPMOP->op_pmreplstart->op_type == OP_NULL)
7749 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7750 peep(cPMOP->op_pmreplstart);
7755 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7756 && ckWARN(WARN_SYNTAX))
7758 if (o->op_next->op_sibling &&
7759 o->op_next->op_sibling->op_type != OP_EXIT &&
7760 o->op_next->op_sibling->op_type != OP_WARN &&
7761 o->op_next->op_sibling->op_type != OP_DIE) {
7762 const line_t oldline = CopLINE(PL_curcop);
7764 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7765 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7766 "Statement unlikely to be reached");
7767 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7768 "\t(Maybe you meant system() when you said exec()?)\n");
7769 CopLINE_set(PL_curcop, oldline);
7779 const char *key = NULL;
7784 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7787 /* Make the CONST have a shared SV */
7788 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7789 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7790 key = SvPV_const(sv, keylen);
7791 lexname = newSVpvn_share(key,
7792 SvUTF8(sv) ? -(I32)keylen : keylen,
7798 if ((o->op_private & (OPpLVAL_INTRO)))
7801 rop = (UNOP*)((BINOP*)o)->op_first;
7802 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7804 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7805 if (!SvPAD_TYPED(lexname))
7807 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7808 if (!fields || !GvHV(*fields))
7810 key = SvPV_const(*svp, keylen);
7811 if (!hv_fetch(GvHV(*fields), key,
7812 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7814 Perl_croak(aTHX_ "No such class field \"%s\" "
7815 "in variable %s of type %s",
7816 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7829 SVOP *first_key_op, *key_op;
7831 if ((o->op_private & (OPpLVAL_INTRO))
7832 /* I bet there's always a pushmark... */
7833 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7834 /* hmmm, no optimization if list contains only one key. */
7836 rop = (UNOP*)((LISTOP*)o)->op_last;
7837 if (rop->op_type != OP_RV2HV)
7839 if (rop->op_first->op_type == OP_PADSV)
7840 /* @$hash{qw(keys here)} */
7841 rop = (UNOP*)rop->op_first;
7843 /* @{$hash}{qw(keys here)} */
7844 if (rop->op_first->op_type == OP_SCOPE
7845 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7847 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7853 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7854 if (!SvPAD_TYPED(lexname))
7856 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7857 if (!fields || !GvHV(*fields))
7859 /* Again guessing that the pushmark can be jumped over.... */
7860 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7861 ->op_first->op_sibling;
7862 for (key_op = first_key_op; key_op;
7863 key_op = (SVOP*)key_op->op_sibling) {
7864 if (key_op->op_type != OP_CONST)
7866 svp = cSVOPx_svp(key_op);
7867 key = SvPV_const(*svp, keylen);
7868 if (!hv_fetch(GvHV(*fields), key,
7869 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7871 Perl_croak(aTHX_ "No such class field \"%s\" "
7872 "in variable %s of type %s",
7873 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7880 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7884 /* check that RHS of sort is a single plain array */
7885 OP *oright = cUNOPo->op_first;
7886 if (!oright || oright->op_type != OP_PUSHMARK)
7889 /* reverse sort ... can be optimised. */
7890 if (!cUNOPo->op_sibling) {
7891 /* Nothing follows us on the list. */
7892 OP * const reverse = o->op_next;
7894 if (reverse->op_type == OP_REVERSE &&
7895 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7896 OP * const pushmark = cUNOPx(reverse)->op_first;
7897 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7898 && (cUNOPx(pushmark)->op_sibling == o)) {
7899 /* reverse -> pushmark -> sort */
7900 o->op_private |= OPpSORT_REVERSE;
7902 pushmark->op_next = oright->op_next;
7908 /* make @a = sort @a act in-place */
7912 oright = cUNOPx(oright)->op_sibling;
7915 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7916 oright = cUNOPx(oright)->op_sibling;
7920 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7921 || oright->op_next != o
7922 || (oright->op_private & OPpLVAL_INTRO)
7926 /* o2 follows the chain of op_nexts through the LHS of the
7927 * assign (if any) to the aassign op itself */
7929 if (!o2 || o2->op_type != OP_NULL)
7932 if (!o2 || o2->op_type != OP_PUSHMARK)
7935 if (o2 && o2->op_type == OP_GV)
7938 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7939 || (o2->op_private & OPpLVAL_INTRO)
7944 if (!o2 || o2->op_type != OP_NULL)
7947 if (!o2 || o2->op_type != OP_AASSIGN
7948 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7951 /* check that the sort is the first arg on RHS of assign */
7953 o2 = cUNOPx(o2)->op_first;
7954 if (!o2 || o2->op_type != OP_NULL)
7956 o2 = cUNOPx(o2)->op_first;
7957 if (!o2 || o2->op_type != OP_PUSHMARK)
7959 if (o2->op_sibling != o)
7962 /* check the array is the same on both sides */
7963 if (oleft->op_type == OP_RV2AV) {
7964 if (oright->op_type != OP_RV2AV
7965 || !cUNOPx(oright)->op_first
7966 || cUNOPx(oright)->op_first->op_type != OP_GV
7967 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7968 cGVOPx_gv(cUNOPx(oright)->op_first)
7972 else if (oright->op_type != OP_PADAV
7973 || oright->op_targ != oleft->op_targ
7977 /* transfer MODishness etc from LHS arg to RHS arg */
7978 oright->op_flags = oleft->op_flags;
7979 o->op_private |= OPpSORT_INPLACE;
7981 /* excise push->gv->rv2av->null->aassign */
7982 o2 = o->op_next->op_next;
7983 op_null(o2); /* PUSHMARK */
7985 if (o2->op_type == OP_GV) {
7986 op_null(o2); /* GV */
7989 op_null(o2); /* RV2AV or PADAV */
7990 o2 = o2->op_next->op_next;
7991 op_null(o2); /* AASSIGN */
7993 o->op_next = o2->op_next;
7999 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8001 LISTOP *enter, *exlist;
8004 enter = (LISTOP *) o->op_next;
8007 if (enter->op_type == OP_NULL) {
8008 enter = (LISTOP *) enter->op_next;
8012 /* for $a (...) will have OP_GV then OP_RV2GV here.
8013 for (...) just has an OP_GV. */
8014 if (enter->op_type == OP_GV) {
8015 gvop = (OP *) enter;
8016 enter = (LISTOP *) enter->op_next;
8019 if (enter->op_type == OP_RV2GV) {
8020 enter = (LISTOP *) enter->op_next;
8026 if (enter->op_type != OP_ENTERITER)
8029 iter = enter->op_next;
8030 if (!iter || iter->op_type != OP_ITER)
8033 expushmark = enter->op_first;
8034 if (!expushmark || expushmark->op_type != OP_NULL
8035 || expushmark->op_targ != OP_PUSHMARK)
8038 exlist = (LISTOP *) expushmark->op_sibling;
8039 if (!exlist || exlist->op_type != OP_NULL
8040 || exlist->op_targ != OP_LIST)
8043 if (exlist->op_last != o) {
8044 /* Mmm. Was expecting to point back to this op. */
8047 theirmark = exlist->op_first;
8048 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8051 if (theirmark->op_sibling != o) {
8052 /* There's something between the mark and the reverse, eg
8053 for (1, reverse (...))
8058 ourmark = ((LISTOP *)o)->op_first;
8059 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8062 ourlast = ((LISTOP *)o)->op_last;
8063 if (!ourlast || ourlast->op_next != o)
8066 rv2av = ourmark->op_sibling;
8067 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8068 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8069 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8070 /* We're just reversing a single array. */
8071 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8072 enter->op_flags |= OPf_STACKED;
8075 /* We don't have control over who points to theirmark, so sacrifice
8077 theirmark->op_next = ourmark->op_next;
8078 theirmark->op_flags = ourmark->op_flags;
8079 ourlast->op_next = gvop ? gvop : (OP *) enter;
8082 enter->op_private |= OPpITER_REVERSED;
8083 iter->op_private |= OPpITER_REVERSED;
8090 UNOP *refgen, *rv2cv;
8093 /* I do not understand this, but if o->op_opt isn't set to 1,
8094 various tests in ext/B/t/bytecode.t fail with no readily
8100 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8103 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8106 rv2gv = ((BINOP *)o)->op_last;
8107 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8110 refgen = (UNOP *)((BINOP *)o)->op_first;
8112 if (!refgen || refgen->op_type != OP_REFGEN)
8115 exlist = (LISTOP *)refgen->op_first;
8116 if (!exlist || exlist->op_type != OP_NULL
8117 || exlist->op_targ != OP_LIST)
8120 if (exlist->op_first->op_type != OP_PUSHMARK)
8123 rv2cv = (UNOP*)exlist->op_last;
8125 if (rv2cv->op_type != OP_RV2CV)
8128 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8129 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8130 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8132 o->op_private |= OPpASSIGN_CV_TO_GV;
8133 rv2gv->op_private |= OPpDONT_INIT_GV;
8134 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8150 Perl_custom_op_name(pTHX_ const OP* o)
8153 const IV index = PTR2IV(o->op_ppaddr);
8157 if (!PL_custom_op_names) /* This probably shouldn't happen */
8158 return (char *)PL_op_name[OP_CUSTOM];
8160 keysv = sv_2mortal(newSViv(index));
8162 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8164 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8166 return SvPV_nolen(HeVAL(he));
8170 Perl_custom_op_desc(pTHX_ const OP* o)
8173 const IV index = PTR2IV(o->op_ppaddr);
8177 if (!PL_custom_op_descs)
8178 return (char *)PL_op_desc[OP_CUSTOM];
8180 keysv = sv_2mortal(newSViv(index));
8182 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8184 return (char *)PL_op_desc[OP_CUSTOM];
8186 return SvPV_nolen(HeVAL(he));
8191 /* Efficient sub that returns a constant scalar value. */
8193 const_sv_xsub(pTHX_ CV* cv)
8200 Perl_croak(aTHX_ "usage: %s::%s()",
8201 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8205 ST(0) = (SV*)XSANY.any_ptr;
8211 * c-indentation-style: bsd
8213 * indent-tabs-mode: t
8216 * ex: set ts=8 sts=4 sw=4 noet: