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 const OPCODE type = o->op_type;
1037 if (type == OP_LINESEQ || type == OP_SCOPE ||
1038 type == OP_LEAVE || 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)
1888 const OPCODE ltype = left->op_type;
1889 const OPCODE rtype = right->op_type;
1891 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1892 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
1894 const char * const desc
1895 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1896 ? rtype : OP_MATCH];
1897 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1898 ? "@array" : "%hash");
1899 Perl_warner(aTHX_ packWARN(WARN_MISC),
1900 "Applying %s to %s will act on scalar(%s)",
1901 desc, sample, sample);
1904 if (rtype == OP_CONST &&
1905 cSVOPx(right)->op_private & OPpCONST_BARE &&
1906 cSVOPx(right)->op_private & OPpCONST_STRICT)
1908 no_bareword_allowed(right);
1911 ismatchop = rtype == OP_MATCH ||
1912 rtype == OP_SUBST ||
1914 if (ismatchop && right->op_private & OPpTARGET_MY) {
1916 right->op_private &= ~OPpTARGET_MY;
1918 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1921 right->op_flags |= OPf_STACKED;
1922 if (rtype != OP_MATCH &&
1923 ! (rtype == OP_TRANS &&
1924 right->op_private & OPpTRANS_IDENTICAL))
1925 newleft = mod(left, rtype);
1928 if (right->op_type == OP_TRANS)
1929 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
1931 o = prepend_elem(rtype, scalar(newleft), right);
1933 return newUNOP(OP_NOT, 0, scalar(o));
1937 return bind_match(type, left,
1938 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1942 Perl_invert(pTHX_ OP *o)
1946 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1950 Perl_scope(pTHX_ OP *o)
1954 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1955 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1956 o->op_type = OP_LEAVE;
1957 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1959 else if (o->op_type == OP_LINESEQ) {
1961 o->op_type = OP_SCOPE;
1962 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1963 kid = ((LISTOP*)o)->op_first;
1964 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1967 /* The following deals with things like 'do {1 for 1}' */
1968 kid = kid->op_sibling;
1970 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1975 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1981 Perl_block_start(pTHX_ int full)
1984 const int retval = PL_savestack_ix;
1985 pad_block_start(full);
1987 PL_hints &= ~HINT_BLOCK_SCOPE;
1988 SAVECOMPILEWARNINGS();
1989 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1990 SAVESPTR(PL_compiling.cop_io);
1991 if (! specialCopIO(PL_compiling.cop_io)) {
1992 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1993 SAVEFREESV(PL_compiling.cop_io) ;
1999 Perl_block_end(pTHX_ I32 floor, OP *seq)
2002 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2003 OP* const retval = scalarseq(seq);
2005 CopHINTS_set(&PL_compiling, PL_hints);
2007 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2016 const I32 offset = pad_findmy("$_");
2017 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2018 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2021 OP * const o = newOP(OP_PADSV, 0);
2022 o->op_targ = offset;
2028 Perl_newPROG(pTHX_ OP *o)
2034 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2035 ((PL_in_eval & EVAL_KEEPERR)
2036 ? OPf_SPECIAL : 0), o);
2037 PL_eval_start = linklist(PL_eval_root);
2038 PL_eval_root->op_private |= OPpREFCOUNTED;
2039 OpREFCNT_set(PL_eval_root, 1);
2040 PL_eval_root->op_next = 0;
2041 CALL_PEEP(PL_eval_start);
2044 if (o->op_type == OP_STUB) {
2045 PL_comppad_name = 0;
2050 PL_main_root = scope(sawparens(scalarvoid(o)));
2051 PL_curcop = &PL_compiling;
2052 PL_main_start = LINKLIST(PL_main_root);
2053 PL_main_root->op_private |= OPpREFCOUNTED;
2054 OpREFCNT_set(PL_main_root, 1);
2055 PL_main_root->op_next = 0;
2056 CALL_PEEP(PL_main_start);
2059 /* Register with debugger */
2061 CV * const cv = get_cv("DB::postponed", FALSE);
2065 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2067 call_sv((SV*)cv, G_DISCARD);
2074 Perl_localize(pTHX_ OP *o, I32 lex)
2077 if (o->op_flags & OPf_PARENS)
2078 /* [perl #17376]: this appears to be premature, and results in code such as
2079 C< our(%x); > executing in list mode rather than void mode */
2086 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2087 && ckWARN(WARN_PARENTHESIS))
2089 char *s = PL_bufptr;
2092 /* some heuristics to detect a potential error */
2093 while (*s && (strchr(", \t\n", *s)))
2097 if (*s && strchr("@$%*", *s) && *++s
2098 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2101 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2103 while (*s && (strchr(", \t\n", *s)))
2109 if (sigil && (*s == ';' || *s == '=')) {
2110 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2111 "Parentheses missing around \"%s\" list",
2112 lex ? (PL_in_my == KEY_our ? "our" : "my")
2120 o = mod(o, OP_NULL); /* a bit kludgey */
2122 PL_in_my_stash = NULL;
2127 Perl_jmaybe(pTHX_ OP *o)
2129 if (o->op_type == OP_LIST) {
2131 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2132 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2138 Perl_fold_constants(pTHX_ register OP *o)
2143 I32 type = o->op_type;
2150 if (PL_opargs[type] & OA_RETSCALAR)
2152 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2153 o->op_targ = pad_alloc(type, SVs_PADTMP);
2155 /* integerize op, unless it happens to be C<-foo>.
2156 * XXX should pp_i_negate() do magic string negation instead? */
2157 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2158 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2159 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2161 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2164 if (!(PL_opargs[type] & OA_FOLDCONST))
2169 /* XXX might want a ck_negate() for this */
2170 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2181 /* XXX what about the numeric ops? */
2182 if (PL_hints & HINT_LOCALE)
2187 goto nope; /* Don't try to run w/ errors */
2189 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2190 const OPCODE type = curop->op_type;
2191 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2193 type != OP_SCALAR &&
2195 type != OP_PUSHMARK)
2201 curop = LINKLIST(o);
2202 old_next = o->op_next;
2206 oldscope = PL_scopestack_ix;
2207 create_eval_scope(G_FAKINGEVAL);
2214 sv = *(PL_stack_sp--);
2215 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2216 pad_swipe(o->op_targ, FALSE);
2217 else if (SvTEMP(sv)) { /* grab mortal temp? */
2218 SvREFCNT_inc_simple_void(sv);
2223 /* Something tried to die. Abandon constant folding. */
2224 /* Pretend the error never happened. */
2225 sv_setpvn(ERRSV,"",0);
2226 o->op_next = old_next;
2230 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2231 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2236 if (PL_scopestack_ix > oldscope)
2237 delete_eval_scope();
2246 if (type == OP_RV2GV)
2247 newop = newGVOP(OP_GV, 0, (GV*)sv);
2249 newop = newSVOP(OP_CONST, 0, sv);
2250 op_getmad(o,newop,'f');
2258 Perl_gen_constant_list(pTHX_ register OP *o)
2262 const I32 oldtmps_floor = PL_tmps_floor;
2266 return o; /* Don't attempt to run with errors */
2268 PL_op = curop = LINKLIST(o);
2275 PL_tmps_floor = oldtmps_floor;
2277 o->op_type = OP_RV2AV;
2278 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2279 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2280 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2281 o->op_opt = 0; /* needs to be revisited in peep() */
2282 curop = ((UNOP*)o)->op_first;
2283 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2285 op_getmad(curop,o,'O');
2294 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2297 if (!o || o->op_type != OP_LIST)
2298 o = newLISTOP(OP_LIST, 0, o, NULL);
2300 o->op_flags &= ~OPf_WANT;
2302 if (!(PL_opargs[type] & OA_MARK))
2303 op_null(cLISTOPo->op_first);
2305 o->op_type = (OPCODE)type;
2306 o->op_ppaddr = PL_ppaddr[type];
2307 o->op_flags |= flags;
2309 o = CHECKOP(type, o);
2310 if (o->op_type != (unsigned)type)
2313 return fold_constants(o);
2316 /* List constructors */
2319 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2327 if (first->op_type != (unsigned)type
2328 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2330 return newLISTOP(type, 0, first, last);
2333 if (first->op_flags & OPf_KIDS)
2334 ((LISTOP*)first)->op_last->op_sibling = last;
2336 first->op_flags |= OPf_KIDS;
2337 ((LISTOP*)first)->op_first = last;
2339 ((LISTOP*)first)->op_last = last;
2344 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2352 if (first->op_type != (unsigned)type)
2353 return prepend_elem(type, (OP*)first, (OP*)last);
2355 if (last->op_type != (unsigned)type)
2356 return append_elem(type, (OP*)first, (OP*)last);
2358 first->op_last->op_sibling = last->op_first;
2359 first->op_last = last->op_last;
2360 first->op_flags |= (last->op_flags & OPf_KIDS);
2363 if (last->op_first && first->op_madprop) {
2364 MADPROP *mp = last->op_first->op_madprop;
2366 while (mp->mad_next)
2368 mp->mad_next = first->op_madprop;
2371 last->op_first->op_madprop = first->op_madprop;
2374 first->op_madprop = last->op_madprop;
2375 last->op_madprop = 0;
2384 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2392 if (last->op_type == (unsigned)type) {
2393 if (type == OP_LIST) { /* already a PUSHMARK there */
2394 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2395 ((LISTOP*)last)->op_first->op_sibling = first;
2396 if (!(first->op_flags & OPf_PARENS))
2397 last->op_flags &= ~OPf_PARENS;
2400 if (!(last->op_flags & OPf_KIDS)) {
2401 ((LISTOP*)last)->op_last = first;
2402 last->op_flags |= OPf_KIDS;
2404 first->op_sibling = ((LISTOP*)last)->op_first;
2405 ((LISTOP*)last)->op_first = first;
2407 last->op_flags |= OPf_KIDS;
2411 return newLISTOP(type, 0, first, last);
2419 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2422 Newxz(tk, 1, TOKEN);
2423 tk->tk_type = (OPCODE)optype;
2424 tk->tk_type = 12345;
2426 tk->tk_mad = madprop;
2431 Perl_token_free(pTHX_ TOKEN* tk)
2433 if (tk->tk_type != 12345)
2435 mad_free(tk->tk_mad);
2440 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2444 if (tk->tk_type != 12345) {
2445 Perl_warner(aTHX_ packWARN(WARN_MISC),
2446 "Invalid TOKEN object ignored");
2453 /* faked up qw list? */
2455 tm->mad_type == MAD_SV &&
2456 SvPVX((SV*)tm->mad_val)[0] == 'q')
2463 /* pretend constant fold didn't happen? */
2464 if (mp->mad_key == 'f' &&
2465 (o->op_type == OP_CONST ||
2466 o->op_type == OP_GV) )
2468 token_getmad(tk,(OP*)mp->mad_val,slot);
2482 if (mp->mad_key == 'X')
2483 mp->mad_key = slot; /* just change the first one */
2493 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2502 /* pretend constant fold didn't happen? */
2503 if (mp->mad_key == 'f' &&
2504 (o->op_type == OP_CONST ||
2505 o->op_type == OP_GV) )
2507 op_getmad(from,(OP*)mp->mad_val,slot);
2514 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2517 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2523 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2532 /* pretend constant fold didn't happen? */
2533 if (mp->mad_key == 'f' &&
2534 (o->op_type == OP_CONST ||
2535 o->op_type == OP_GV) )
2537 op_getmad(from,(OP*)mp->mad_val,slot);
2544 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2547 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2551 PerlIO_printf(PerlIO_stderr(),
2552 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2558 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2576 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2580 addmad(tm, &(o->op_madprop), slot);
2584 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2605 Perl_newMADsv(pTHX_ char key, SV* sv)
2607 return newMADPROP(key, MAD_SV, sv, 0);
2611 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2614 Newxz(mp, 1, MADPROP);
2617 mp->mad_vlen = vlen;
2618 mp->mad_type = type;
2620 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2625 Perl_mad_free(pTHX_ MADPROP* mp)
2627 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2631 mad_free(mp->mad_next);
2632 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2633 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2634 switch (mp->mad_type) {
2638 Safefree((char*)mp->mad_val);
2641 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2642 op_free((OP*)mp->mad_val);
2645 sv_free((SV*)mp->mad_val);
2648 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2657 Perl_newNULLLIST(pTHX)
2659 return newOP(OP_STUB, 0);
2663 Perl_force_list(pTHX_ OP *o)
2665 if (!o || o->op_type != OP_LIST)
2666 o = newLISTOP(OP_LIST, 0, o, NULL);
2672 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2677 NewOp(1101, listop, 1, LISTOP);
2679 listop->op_type = (OPCODE)type;
2680 listop->op_ppaddr = PL_ppaddr[type];
2683 listop->op_flags = (U8)flags;
2687 else if (!first && last)
2690 first->op_sibling = last;
2691 listop->op_first = first;
2692 listop->op_last = last;
2693 if (type == OP_LIST) {
2694 OP* const pushop = newOP(OP_PUSHMARK, 0);
2695 pushop->op_sibling = first;
2696 listop->op_first = pushop;
2697 listop->op_flags |= OPf_KIDS;
2699 listop->op_last = pushop;
2702 return CHECKOP(type, listop);
2706 Perl_newOP(pTHX_ I32 type, I32 flags)
2710 NewOp(1101, o, 1, OP);
2711 o->op_type = (OPCODE)type;
2712 o->op_ppaddr = PL_ppaddr[type];
2713 o->op_flags = (U8)flags;
2716 o->op_private = (U8)(0 | (flags >> 8));
2717 if (PL_opargs[type] & OA_RETSCALAR)
2719 if (PL_opargs[type] & OA_TARGET)
2720 o->op_targ = pad_alloc(type, SVs_PADTMP);
2721 return CHECKOP(type, o);
2725 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2731 first = newOP(OP_STUB, 0);
2732 if (PL_opargs[type] & OA_MARK)
2733 first = force_list(first);
2735 NewOp(1101, unop, 1, UNOP);
2736 unop->op_type = (OPCODE)type;
2737 unop->op_ppaddr = PL_ppaddr[type];
2738 unop->op_first = first;
2739 unop->op_flags = (U8)(flags | OPf_KIDS);
2740 unop->op_private = (U8)(1 | (flags >> 8));
2741 unop = (UNOP*) CHECKOP(type, unop);
2745 return fold_constants((OP *) unop);
2749 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2753 NewOp(1101, binop, 1, BINOP);
2756 first = newOP(OP_NULL, 0);
2758 binop->op_type = (OPCODE)type;
2759 binop->op_ppaddr = PL_ppaddr[type];
2760 binop->op_first = first;
2761 binop->op_flags = (U8)(flags | OPf_KIDS);
2764 binop->op_private = (U8)(1 | (flags >> 8));
2767 binop->op_private = (U8)(2 | (flags >> 8));
2768 first->op_sibling = last;
2771 binop = (BINOP*)CHECKOP(type, binop);
2772 if (binop->op_next || binop->op_type != (OPCODE)type)
2775 binop->op_last = binop->op_first->op_sibling;
2777 return fold_constants((OP *)binop);
2780 static int uvcompare(const void *a, const void *b)
2781 __attribute__nonnull__(1)
2782 __attribute__nonnull__(2)
2783 __attribute__pure__;
2784 static int uvcompare(const void *a, const void *b)
2786 if (*((const UV *)a) < (*(const UV *)b))
2788 if (*((const UV *)a) > (*(const UV *)b))
2790 if (*((const UV *)a+1) < (*(const UV *)b+1))
2792 if (*((const UV *)a+1) > (*(const UV *)b+1))
2798 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2801 SV * const tstr = ((SVOP*)expr)->op_sv;
2802 SV * const rstr = ((SVOP*)repl)->op_sv;
2805 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2806 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2810 register short *tbl;
2812 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2813 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2814 I32 del = o->op_private & OPpTRANS_DELETE;
2815 PL_hints |= HINT_BLOCK_SCOPE;
2818 o->op_private |= OPpTRANS_FROM_UTF;
2821 o->op_private |= OPpTRANS_TO_UTF;
2823 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2824 SV* const listsv = newSVpvs("# comment\n");
2826 const U8* tend = t + tlen;
2827 const U8* rend = r + rlen;
2841 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2842 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2845 const U32 flags = UTF8_ALLOW_DEFAULT;
2849 t = tsave = bytes_to_utf8(t, &len);
2852 if (!to_utf && rlen) {
2854 r = rsave = bytes_to_utf8(r, &len);
2858 /* There are several snags with this code on EBCDIC:
2859 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2860 2. scan_const() in toke.c has encoded chars in native encoding which makes
2861 ranges at least in EBCDIC 0..255 range the bottom odd.
2865 U8 tmpbuf[UTF8_MAXBYTES+1];
2868 Newx(cp, 2*tlen, UV);
2870 transv = newSVpvs("");
2872 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2874 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2876 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2880 cp[2*i+1] = cp[2*i];
2884 qsort(cp, i, 2*sizeof(UV), uvcompare);
2885 for (j = 0; j < i; j++) {
2887 diff = val - nextmin;
2889 t = uvuni_to_utf8(tmpbuf,nextmin);
2890 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2892 U8 range_mark = UTF_TO_NATIVE(0xff);
2893 t = uvuni_to_utf8(tmpbuf, val - 1);
2894 sv_catpvn(transv, (char *)&range_mark, 1);
2895 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2902 t = uvuni_to_utf8(tmpbuf,nextmin);
2903 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2905 U8 range_mark = UTF_TO_NATIVE(0xff);
2906 sv_catpvn(transv, (char *)&range_mark, 1);
2908 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2909 UNICODE_ALLOW_SUPER);
2910 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2911 t = (const U8*)SvPVX_const(transv);
2912 tlen = SvCUR(transv);
2916 else if (!rlen && !del) {
2917 r = t; rlen = tlen; rend = tend;
2920 if ((!rlen && !del) || t == r ||
2921 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2923 o->op_private |= OPpTRANS_IDENTICAL;
2927 while (t < tend || tfirst <= tlast) {
2928 /* see if we need more "t" chars */
2929 if (tfirst > tlast) {
2930 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2932 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2934 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2941 /* now see if we need more "r" chars */
2942 if (rfirst > rlast) {
2944 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2946 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2948 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2957 rfirst = rlast = 0xffffffff;
2961 /* now see which range will peter our first, if either. */
2962 tdiff = tlast - tfirst;
2963 rdiff = rlast - rfirst;
2970 if (rfirst == 0xffffffff) {
2971 diff = tdiff; /* oops, pretend rdiff is infinite */
2973 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2974 (long)tfirst, (long)tlast);
2976 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2980 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2981 (long)tfirst, (long)(tfirst + diff),
2984 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2985 (long)tfirst, (long)rfirst);
2987 if (rfirst + diff > max)
2988 max = rfirst + diff;
2990 grows = (tfirst < rfirst &&
2991 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3003 else if (max > 0xff)
3008 Safefree(cPVOPo->op_pv);
3009 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3010 SvREFCNT_dec(listsv);
3011 SvREFCNT_dec(transv);
3013 if (!del && havefinal && rlen)
3014 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3015 newSVuv((UV)final), 0);
3018 o->op_private |= OPpTRANS_GROWS;
3024 op_getmad(expr,o,'e');
3025 op_getmad(repl,o,'r');
3033 tbl = (short*)cPVOPo->op_pv;
3035 Zero(tbl, 256, short);
3036 for (i = 0; i < (I32)tlen; i++)
3038 for (i = 0, j = 0; i < 256; i++) {
3040 if (j >= (I32)rlen) {
3049 if (i < 128 && r[j] >= 128)
3059 o->op_private |= OPpTRANS_IDENTICAL;
3061 else if (j >= (I32)rlen)
3064 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3065 tbl[0x100] = (short)(rlen - j);
3066 for (i=0; i < (I32)rlen - j; i++)
3067 tbl[0x101+i] = r[j+i];
3071 if (!rlen && !del) {
3074 o->op_private |= OPpTRANS_IDENTICAL;
3076 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3077 o->op_private |= OPpTRANS_IDENTICAL;
3079 for (i = 0; i < 256; i++)
3081 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3082 if (j >= (I32)rlen) {
3084 if (tbl[t[i]] == -1)
3090 if (tbl[t[i]] == -1) {
3091 if (t[i] < 128 && r[j] >= 128)
3098 o->op_private |= OPpTRANS_GROWS;
3100 op_getmad(expr,o,'e');
3101 op_getmad(repl,o,'r');
3111 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3116 NewOp(1101, pmop, 1, PMOP);
3117 pmop->op_type = (OPCODE)type;
3118 pmop->op_ppaddr = PL_ppaddr[type];
3119 pmop->op_flags = (U8)flags;
3120 pmop->op_private = (U8)(0 | (flags >> 8));
3122 if (PL_hints & HINT_RE_TAINT)
3123 pmop->op_pmpermflags |= PMf_RETAINT;
3124 if (PL_hints & HINT_LOCALE)
3125 pmop->op_pmpermflags |= PMf_LOCALE;
3126 pmop->op_pmflags = pmop->op_pmpermflags;
3129 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3130 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3131 pmop->op_pmoffset = SvIV(repointer);
3132 SvREPADTMP_off(repointer);
3133 sv_setiv(repointer,0);
3135 SV * const repointer = newSViv(0);
3136 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3137 pmop->op_pmoffset = av_len(PL_regex_padav);
3138 PL_regex_pad = AvARRAY(PL_regex_padav);
3142 /* link into pm list */
3143 if (type != OP_TRANS && PL_curstash) {
3144 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3147 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3149 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3150 mg->mg_obj = (SV*)pmop;
3151 PmopSTASH_set(pmop,PL_curstash);
3154 return CHECKOP(type, pmop);
3157 /* Given some sort of match op o, and an expression expr containing a
3158 * pattern, either compile expr into a regex and attach it to o (if it's
3159 * constant), or convert expr into a runtime regcomp op sequence (if it's
3162 * isreg indicates that the pattern is part of a regex construct, eg
3163 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3164 * split "pattern", which aren't. In the former case, expr will be a list
3165 * if the pattern contains more than one term (eg /a$b/) or if it contains
3166 * a replacement, ie s/// or tr///.
3170 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3175 I32 repl_has_vars = 0;
3179 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3180 /* last element in list is the replacement; pop it */
3182 repl = cLISTOPx(expr)->op_last;
3183 kid = cLISTOPx(expr)->op_first;
3184 while (kid->op_sibling != repl)
3185 kid = kid->op_sibling;
3186 kid->op_sibling = NULL;
3187 cLISTOPx(expr)->op_last = kid;
3190 if (isreg && expr->op_type == OP_LIST &&
3191 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3193 /* convert single element list to element */
3194 OP* const oe = expr;
3195 expr = cLISTOPx(oe)->op_first->op_sibling;
3196 cLISTOPx(oe)->op_first->op_sibling = NULL;
3197 cLISTOPx(oe)->op_last = NULL;
3201 if (o->op_type == OP_TRANS) {
3202 return pmtrans(o, expr, repl);
3205 reglist = isreg && expr->op_type == OP_LIST;
3209 PL_hints |= HINT_BLOCK_SCOPE;
3212 if (expr->op_type == OP_CONST) {
3214 SV * const pat = ((SVOP*)expr)->op_sv;
3215 const char *p = SvPV_const(pat, plen);
3216 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3217 U32 was_readonly = SvREADONLY(pat);
3221 sv_force_normal_flags(pat, 0);
3222 assert(!SvREADONLY(pat));
3225 SvREADONLY_off(pat);
3229 sv_setpvn(pat, "\\s+", 3);
3231 SvFLAGS(pat) |= was_readonly;
3233 p = SvPV_const(pat, plen);
3234 pm->op_pmflags |= PMf_SKIPWHITE;
3237 pm->op_pmdynflags |= PMdf_UTF8;
3238 /* FIXME - can we make this function take const char * args? */
3239 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3240 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3241 pm->op_pmflags |= PMf_WHITE;
3243 op_getmad(expr,(OP*)pm,'e');
3249 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3250 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3252 : OP_REGCMAYBE),0,expr);
3254 NewOp(1101, rcop, 1, LOGOP);
3255 rcop->op_type = OP_REGCOMP;
3256 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3257 rcop->op_first = scalar(expr);
3258 rcop->op_flags |= OPf_KIDS
3259 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3260 | (reglist ? OPf_STACKED : 0);
3261 rcop->op_private = 1;
3264 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3266 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3269 /* establish postfix order */
3270 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3272 rcop->op_next = expr;
3273 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3276 rcop->op_next = LINKLIST(expr);
3277 expr->op_next = (OP*)rcop;
3280 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3285 if (pm->op_pmflags & PMf_EVAL) {
3287 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3288 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3290 else if (repl->op_type == OP_CONST)
3294 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3295 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3296 if (curop->op_type == OP_GV) {
3297 GV * const gv = cGVOPx_gv(curop);
3299 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3302 else if (curop->op_type == OP_RV2CV)
3304 else if (curop->op_type == OP_RV2SV ||
3305 curop->op_type == OP_RV2AV ||
3306 curop->op_type == OP_RV2HV ||
3307 curop->op_type == OP_RV2GV) {
3308 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3311 else if (curop->op_type == OP_PADSV ||
3312 curop->op_type == OP_PADAV ||
3313 curop->op_type == OP_PADHV ||
3314 curop->op_type == OP_PADANY) {
3317 else if (curop->op_type == OP_PUSHRE)
3318 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
3328 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3329 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3330 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3331 prepend_elem(o->op_type, scalar(repl), o);
3334 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3335 pm->op_pmflags |= PMf_MAYBE_CONST;
3336 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3338 NewOp(1101, rcop, 1, LOGOP);
3339 rcop->op_type = OP_SUBSTCONT;
3340 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3341 rcop->op_first = scalar(repl);
3342 rcop->op_flags |= OPf_KIDS;
3343 rcop->op_private = 1;
3346 /* establish postfix order */
3347 rcop->op_next = LINKLIST(repl);
3348 repl->op_next = (OP*)rcop;
3350 pm->op_pmreplroot = scalar((OP*)rcop);
3351 pm->op_pmreplstart = LINKLIST(rcop);
3360 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3364 NewOp(1101, svop, 1, SVOP);
3365 svop->op_type = (OPCODE)type;
3366 svop->op_ppaddr = PL_ppaddr[type];
3368 svop->op_next = (OP*)svop;
3369 svop->op_flags = (U8)flags;
3370 if (PL_opargs[type] & OA_RETSCALAR)
3372 if (PL_opargs[type] & OA_TARGET)
3373 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3374 return CHECKOP(type, svop);
3378 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3382 NewOp(1101, padop, 1, PADOP);
3383 padop->op_type = (OPCODE)type;
3384 padop->op_ppaddr = PL_ppaddr[type];
3385 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3386 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3387 PAD_SETSV(padop->op_padix, sv);
3390 padop->op_next = (OP*)padop;
3391 padop->op_flags = (U8)flags;
3392 if (PL_opargs[type] & OA_RETSCALAR)
3394 if (PL_opargs[type] & OA_TARGET)
3395 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3396 return CHECKOP(type, padop);
3400 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3406 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3408 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3413 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3417 NewOp(1101, pvop, 1, PVOP);
3418 pvop->op_type = (OPCODE)type;
3419 pvop->op_ppaddr = PL_ppaddr[type];
3421 pvop->op_next = (OP*)pvop;
3422 pvop->op_flags = (U8)flags;
3423 if (PL_opargs[type] & OA_RETSCALAR)
3425 if (PL_opargs[type] & OA_TARGET)
3426 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3427 return CHECKOP(type, pvop);
3435 Perl_package(pTHX_ OP *o)
3444 save_hptr(&PL_curstash);
3445 save_item(PL_curstname);
3447 name = SvPV_const(cSVOPo->op_sv, len);
3448 PL_curstash = gv_stashpvn(name, len, TRUE);
3449 sv_setpvn(PL_curstname, name, len);
3451 PL_hints |= HINT_BLOCK_SCOPE;
3452 PL_copline = NOLINE;
3458 if (!PL_madskills) {
3463 pegop = newOP(OP_NULL,0);
3464 op_getmad(o,pegop,'P');
3474 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3481 OP *pegop = newOP(OP_NULL,0);
3484 if (idop->op_type != OP_CONST)
3485 Perl_croak(aTHX_ "Module name must be constant");
3488 op_getmad(idop,pegop,'U');
3493 SV * const vesv = ((SVOP*)version)->op_sv;
3496 op_getmad(version,pegop,'V');
3497 if (!arg && !SvNIOKp(vesv)) {
3504 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3505 Perl_croak(aTHX_ "Version number must be constant number");
3507 /* Make copy of idop so we don't free it twice */
3508 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3510 /* Fake up a method call to VERSION */
3511 meth = newSVpvs_share("VERSION");
3512 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3513 append_elem(OP_LIST,
3514 prepend_elem(OP_LIST, pack, list(version)),
3515 newSVOP(OP_METHOD_NAMED, 0, meth)));
3519 /* Fake up an import/unimport */
3520 if (arg && arg->op_type == OP_STUB) {
3522 op_getmad(arg,pegop,'S');
3523 imop = arg; /* no import on explicit () */
3525 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3526 imop = NULL; /* use 5.0; */
3528 idop->op_private |= OPpCONST_NOVER;
3534 op_getmad(arg,pegop,'A');
3536 /* Make copy of idop so we don't free it twice */
3537 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3539 /* Fake up a method call to import/unimport */
3541 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3542 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3543 append_elem(OP_LIST,
3544 prepend_elem(OP_LIST, pack, list(arg)),
3545 newSVOP(OP_METHOD_NAMED, 0, meth)));
3548 /* Fake up the BEGIN {}, which does its thing immediately. */
3550 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3553 append_elem(OP_LINESEQ,
3554 append_elem(OP_LINESEQ,
3555 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3556 newSTATEOP(0, NULL, veop)),
3557 newSTATEOP(0, NULL, imop) ));
3559 /* The "did you use incorrect case?" warning used to be here.
3560 * The problem is that on case-insensitive filesystems one
3561 * might get false positives for "use" (and "require"):
3562 * "use Strict" or "require CARP" will work. This causes
3563 * portability problems for the script: in case-strict
3564 * filesystems the script will stop working.
3566 * The "incorrect case" warning checked whether "use Foo"
3567 * imported "Foo" to your namespace, but that is wrong, too:
3568 * there is no requirement nor promise in the language that
3569 * a Foo.pm should or would contain anything in package "Foo".
3571 * There is very little Configure-wise that can be done, either:
3572 * the case-sensitivity of the build filesystem of Perl does not
3573 * help in guessing the case-sensitivity of the runtime environment.
3576 PL_hints |= HINT_BLOCK_SCOPE;
3577 PL_copline = NOLINE;
3579 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3582 if (!PL_madskills) {
3583 /* FIXME - don't allocate pegop if !PL_madskills */
3592 =head1 Embedding Functions
3594 =for apidoc load_module
3596 Loads the module whose name is pointed to by the string part of name.
3597 Note that the actual module name, not its filename, should be given.
3598 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3599 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3600 (or 0 for no flags). ver, if specified, provides version semantics
3601 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3602 arguments can be used to specify arguments to the module's import()
3603 method, similar to C<use Foo::Bar VERSION LIST>.
3608 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3611 va_start(args, ver);
3612 vload_module(flags, name, ver, &args);
3616 #ifdef PERL_IMPLICIT_CONTEXT
3618 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3622 va_start(args, ver);
3623 vload_module(flags, name, ver, &args);
3629 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3634 OP * const modname = newSVOP(OP_CONST, 0, name);
3635 modname->op_private |= OPpCONST_BARE;
3637 veop = newSVOP(OP_CONST, 0, ver);
3641 if (flags & PERL_LOADMOD_NOIMPORT) {
3642 imop = sawparens(newNULLLIST());
3644 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3645 imop = va_arg(*args, OP*);
3650 sv = va_arg(*args, SV*);
3652 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3653 sv = va_arg(*args, SV*);
3657 const line_t ocopline = PL_copline;
3658 COP * const ocurcop = PL_curcop;
3659 const int oexpect = PL_expect;
3661 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3662 veop, modname, imop);
3663 PL_expect = oexpect;
3664 PL_copline = ocopline;
3665 PL_curcop = ocurcop;
3670 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3676 if (!force_builtin) {
3677 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3678 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3679 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3680 gv = gvp ? *gvp : NULL;
3684 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3685 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3686 append_elem(OP_LIST, term,
3687 scalar(newUNOP(OP_RV2CV, 0,
3688 newGVOP(OP_GV, 0, gv))))));
3691 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3697 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3699 return newBINOP(OP_LSLICE, flags,
3700 list(force_list(subscript)),
3701 list(force_list(listval)) );
3705 S_is_list_assignment(pTHX_ register const OP *o)
3713 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3714 o = cUNOPo->op_first;
3716 flags = o->op_flags;
3718 if (type == OP_COND_EXPR) {
3719 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3720 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3725 yyerror("Assignment to both a list and a scalar");
3729 if (type == OP_LIST &&
3730 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3731 o->op_private & OPpLVAL_INTRO)
3734 if (type == OP_LIST || flags & OPf_PARENS ||
3735 type == OP_RV2AV || type == OP_RV2HV ||
3736 type == OP_ASLICE || type == OP_HSLICE)
3739 if (type == OP_PADAV || type == OP_PADHV)
3742 if (type == OP_RV2SV)
3749 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3755 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3756 return newLOGOP(optype, 0,
3757 mod(scalar(left), optype),
3758 newUNOP(OP_SASSIGN, 0, scalar(right)));
3761 return newBINOP(optype, OPf_STACKED,
3762 mod(scalar(left), optype), scalar(right));
3766 if (is_list_assignment(left)) {
3770 /* Grandfathering $[ assignment here. Bletch.*/
3771 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3772 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3773 left = mod(left, OP_AASSIGN);
3776 else if (left->op_type == OP_CONST) {
3778 /* Result of assignment is always 1 (or we'd be dead already) */
3779 return newSVOP(OP_CONST, 0, newSViv(1));
3781 curop = list(force_list(left));
3782 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3783 o->op_private = (U8)(0 | (flags >> 8));
3785 /* PL_generation sorcery:
3786 * an assignment like ($a,$b) = ($c,$d) is easier than
3787 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3788 * To detect whether there are common vars, the global var
3789 * PL_generation is incremented for each assign op we compile.
3790 * Then, while compiling the assign op, we run through all the
3791 * variables on both sides of the assignment, setting a spare slot
3792 * in each of them to PL_generation. If any of them already have
3793 * that value, we know we've got commonality. We could use a
3794 * single bit marker, but then we'd have to make 2 passes, first
3795 * to clear the flag, then to test and set it. To find somewhere
3796 * to store these values, evil chicanery is done with SvCUR().
3799 if (!(left->op_private & OPpLVAL_INTRO)) {
3802 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3803 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3804 if (curop->op_type == OP_GV) {
3805 GV *gv = cGVOPx_gv(curop);
3807 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3809 GvASSIGN_GENERATION_set(gv, PL_generation);
3811 else if (curop->op_type == OP_PADSV ||
3812 curop->op_type == OP_PADAV ||
3813 curop->op_type == OP_PADHV ||
3814 curop->op_type == OP_PADANY)
3816 if (PAD_COMPNAME_GEN(curop->op_targ)
3817 == (STRLEN)PL_generation)
3819 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3822 else if (curop->op_type == OP_RV2CV)
3824 else if (curop->op_type == OP_RV2SV ||
3825 curop->op_type == OP_RV2AV ||
3826 curop->op_type == OP_RV2HV ||
3827 curop->op_type == OP_RV2GV) {
3828 if (lastop->op_type != OP_GV) /* funny deref? */
3831 else if (curop->op_type == OP_PUSHRE) {
3832 if (((PMOP*)curop)->op_pmreplroot) {
3834 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3835 ((PMOP*)curop)->op_pmreplroot));
3837 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3840 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3842 GvASSIGN_GENERATION_set(gv, PL_generation);
3843 GvASSIGN_GENERATION_set(gv, PL_generation);
3852 o->op_private |= OPpASSIGN_COMMON;
3854 if (right && right->op_type == OP_SPLIT) {
3855 OP* tmpop = ((LISTOP*)right)->op_first;
3856 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3857 PMOP * const pm = (PMOP*)tmpop;
3858 if (left->op_type == OP_RV2AV &&
3859 !(left->op_private & OPpLVAL_INTRO) &&
3860 !(o->op_private & OPpASSIGN_COMMON) )
3862 tmpop = ((UNOP*)left)->op_first;
3863 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3865 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3866 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3868 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3869 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3871 pm->op_pmflags |= PMf_ONCE;
3872 tmpop = cUNOPo->op_first; /* to list (nulled) */
3873 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3874 tmpop->op_sibling = NULL; /* don't free split */
3875 right->op_next = tmpop->op_next; /* fix starting loc */
3877 op_getmad(o,right,'R'); /* blow off assign */
3879 op_free(o); /* blow off assign */
3881 right->op_flags &= ~OPf_WANT;
3882 /* "I don't know and I don't care." */
3887 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3888 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3890 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3892 sv_setiv(sv, PL_modcount+1);
3900 right = newOP(OP_UNDEF, 0);
3901 if (right->op_type == OP_READLINE) {
3902 right->op_flags |= OPf_STACKED;
3903 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3906 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3907 o = newBINOP(OP_SASSIGN, flags,
3908 scalar(right), mod(scalar(left), OP_SASSIGN) );
3914 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3915 o->op_private |= OPpCONST_ARYBASE;
3922 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3925 const U32 seq = intro_my();
3928 NewOp(1101, cop, 1, COP);
3929 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3930 cop->op_type = OP_DBSTATE;
3931 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3934 cop->op_type = OP_NEXTSTATE;
3935 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3937 cop->op_flags = (U8)flags;
3938 CopHINTS_set(cop, PL_hints);
3940 cop->op_private |= NATIVE_HINTS;
3942 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3943 cop->op_next = (OP*)cop;
3946 cop->cop_label = label;
3947 PL_hints |= HINT_BLOCK_SCOPE;
3950 CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
3951 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3952 if (specialCopIO(PL_curcop->cop_io))
3953 cop->cop_io = PL_curcop->cop_io;
3955 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3956 cop->cop_hints = PL_curcop->cop_hints;
3957 if (cop->cop_hints) {
3959 cop->cop_hints->refcounted_he_refcnt++;
3960 HINTS_REFCNT_UNLOCK;
3963 if (PL_copline == NOLINE)
3964 CopLINE_set(cop, CopLINE(PL_curcop));
3966 CopLINE_set(cop, PL_copline);
3967 PL_copline = NOLINE;
3970 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3972 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3974 CopSTASH_set(cop, PL_curstash);
3976 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3977 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3978 if (svp && *svp != &PL_sv_undef ) {
3979 (void)SvIOK_on(*svp);
3980 SvIV_set(*svp, PTR2IV(cop));
3984 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3989 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3992 return new_logop(type, flags, &first, &other);
3996 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4001 OP *first = *firstp;
4002 OP * const other = *otherp;
4004 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4005 return newBINOP(type, flags, scalar(first), scalar(other));
4007 scalarboolean(first);
4008 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4009 if (first->op_type == OP_NOT
4010 && (first->op_flags & OPf_SPECIAL)
4011 && (first->op_flags & OPf_KIDS)) {
4012 if (type == OP_AND || type == OP_OR) {
4018 first = *firstp = cUNOPo->op_first;
4020 first->op_next = o->op_next;
4021 cUNOPo->op_first = NULL;
4023 op_getmad(o,first,'O');
4029 if (first->op_type == OP_CONST) {
4030 if (first->op_private & OPpCONST_STRICT)
4031 no_bareword_allowed(first);
4032 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4033 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4034 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4035 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4036 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4038 if (other->op_type == OP_CONST)
4039 other->op_private |= OPpCONST_SHORTCIRCUIT;
4041 OP *newop = newUNOP(OP_NULL, 0, other);
4042 op_getmad(first, newop, '1');
4043 newop->op_targ = type; /* set "was" field */
4050 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4051 const OP *o2 = other;
4052 if ( ! (o2->op_type == OP_LIST
4053 && (( o2 = cUNOPx(o2)->op_first))
4054 && o2->op_type == OP_PUSHMARK
4055 && (( o2 = o2->op_sibling)) )
4058 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4059 || o2->op_type == OP_PADHV)
4060 && o2->op_private & OPpLVAL_INTRO
4061 && ckWARN(WARN_DEPRECATED))
4063 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4064 "Deprecated use of my() in false conditional");
4068 if (first->op_type == OP_CONST)
4069 first->op_private |= OPpCONST_SHORTCIRCUIT;
4071 first = newUNOP(OP_NULL, 0, first);
4072 op_getmad(other, first, '2');
4073 first->op_targ = type; /* set "was" field */
4080 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4081 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4083 const OP * const k1 = ((UNOP*)first)->op_first;
4084 const OP * const k2 = k1->op_sibling;
4086 switch (first->op_type)
4089 if (k2 && k2->op_type == OP_READLINE
4090 && (k2->op_flags & OPf_STACKED)
4091 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4093 warnop = k2->op_type;
4098 if (k1->op_type == OP_READDIR
4099 || k1->op_type == OP_GLOB
4100 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4101 || k1->op_type == OP_EACH)
4103 warnop = ((k1->op_type == OP_NULL)
4104 ? (OPCODE)k1->op_targ : k1->op_type);
4109 const line_t oldline = CopLINE(PL_curcop);
4110 CopLINE_set(PL_curcop, PL_copline);
4111 Perl_warner(aTHX_ packWARN(WARN_MISC),
4112 "Value of %s%s can be \"0\"; test with defined()",
4114 ((warnop == OP_READLINE || warnop == OP_GLOB)
4115 ? " construct" : "() operator"));
4116 CopLINE_set(PL_curcop, oldline);
4123 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4124 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4126 NewOp(1101, logop, 1, LOGOP);
4128 logop->op_type = (OPCODE)type;
4129 logop->op_ppaddr = PL_ppaddr[type];
4130 logop->op_first = first;
4131 logop->op_flags = (U8)(flags | OPf_KIDS);
4132 logop->op_other = LINKLIST(other);
4133 logop->op_private = (U8)(1 | (flags >> 8));
4135 /* establish postfix order */
4136 logop->op_next = LINKLIST(first);
4137 first->op_next = (OP*)logop;
4138 first->op_sibling = other;
4140 CHECKOP(type,logop);
4142 o = newUNOP(OP_NULL, 0, (OP*)logop);
4149 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4157 return newLOGOP(OP_AND, 0, first, trueop);
4159 return newLOGOP(OP_OR, 0, first, falseop);
4161 scalarboolean(first);
4162 if (first->op_type == OP_CONST) {
4163 if (first->op_private & OPpCONST_BARE &&
4164 first->op_private & OPpCONST_STRICT) {
4165 no_bareword_allowed(first);
4167 if (SvTRUE(((SVOP*)first)->op_sv)) {
4170 trueop = newUNOP(OP_NULL, 0, trueop);
4171 op_getmad(first,trueop,'C');
4172 op_getmad(falseop,trueop,'e');
4174 /* FIXME for MAD - should there be an ELSE here? */
4184 falseop = newUNOP(OP_NULL, 0, falseop);
4185 op_getmad(first,falseop,'C');
4186 op_getmad(trueop,falseop,'t');
4188 /* FIXME for MAD - should there be an ELSE here? */
4196 NewOp(1101, logop, 1, LOGOP);
4197 logop->op_type = OP_COND_EXPR;
4198 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4199 logop->op_first = first;
4200 logop->op_flags = (U8)(flags | OPf_KIDS);
4201 logop->op_private = (U8)(1 | (flags >> 8));
4202 logop->op_other = LINKLIST(trueop);
4203 logop->op_next = LINKLIST(falseop);
4205 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4208 /* establish postfix order */
4209 start = LINKLIST(first);
4210 first->op_next = (OP*)logop;
4212 first->op_sibling = trueop;
4213 trueop->op_sibling = falseop;
4214 o = newUNOP(OP_NULL, 0, (OP*)logop);
4216 trueop->op_next = falseop->op_next = o;
4223 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4232 NewOp(1101, range, 1, LOGOP);
4234 range->op_type = OP_RANGE;
4235 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4236 range->op_first = left;
4237 range->op_flags = OPf_KIDS;
4238 leftstart = LINKLIST(left);
4239 range->op_other = LINKLIST(right);
4240 range->op_private = (U8)(1 | (flags >> 8));
4242 left->op_sibling = right;
4244 range->op_next = (OP*)range;
4245 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4246 flop = newUNOP(OP_FLOP, 0, flip);
4247 o = newUNOP(OP_NULL, 0, flop);
4249 range->op_next = leftstart;
4251 left->op_next = flip;
4252 right->op_next = flop;
4254 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4255 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4256 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4257 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4259 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4260 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4263 if (!flip->op_private || !flop->op_private)
4264 linklist(o); /* blow off optimizer unless constant */
4270 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4275 const bool once = block && block->op_flags & OPf_SPECIAL &&
4276 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4278 PERL_UNUSED_ARG(debuggable);
4281 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4282 return block; /* do {} while 0 does once */
4283 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4284 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4285 expr = newUNOP(OP_DEFINED, 0,
4286 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4287 } else if (expr->op_flags & OPf_KIDS) {
4288 const OP * const k1 = ((UNOP*)expr)->op_first;
4289 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4290 switch (expr->op_type) {
4292 if (k2 && k2->op_type == OP_READLINE
4293 && (k2->op_flags & OPf_STACKED)
4294 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4295 expr = newUNOP(OP_DEFINED, 0, expr);
4299 if (k1 && (k1->op_type == OP_READDIR
4300 || k1->op_type == OP_GLOB
4301 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4302 || k1->op_type == OP_EACH))
4303 expr = newUNOP(OP_DEFINED, 0, expr);
4309 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4310 * op, in listop. This is wrong. [perl #27024] */
4312 block = newOP(OP_NULL, 0);
4313 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4314 o = new_logop(OP_AND, 0, &expr, &listop);
4317 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4319 if (once && o != listop)
4320 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4323 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4325 o->op_flags |= flags;
4327 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4332 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4333 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4342 PERL_UNUSED_ARG(debuggable);
4345 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4346 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4347 expr = newUNOP(OP_DEFINED, 0,
4348 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4349 } else if (expr->op_flags & OPf_KIDS) {
4350 const OP * const k1 = ((UNOP*)expr)->op_first;
4351 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4352 switch (expr->op_type) {
4354 if (k2 && k2->op_type == OP_READLINE
4355 && (k2->op_flags & OPf_STACKED)
4356 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4357 expr = newUNOP(OP_DEFINED, 0, expr);
4361 if (k1 && (k1->op_type == OP_READDIR
4362 || k1->op_type == OP_GLOB
4363 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4364 || k1->op_type == OP_EACH))
4365 expr = newUNOP(OP_DEFINED, 0, expr);
4372 block = newOP(OP_NULL, 0);
4373 else if (cont || has_my) {
4374 block = scope(block);
4378 next = LINKLIST(cont);
4381 OP * const unstack = newOP(OP_UNSTACK, 0);
4384 cont = append_elem(OP_LINESEQ, cont, unstack);
4388 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4390 redo = LINKLIST(listop);
4393 PL_copline = (line_t)whileline;
4395 o = new_logop(OP_AND, 0, &expr, &listop);
4396 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4397 op_free(expr); /* oops, it's a while (0) */
4399 return NULL; /* listop already freed by new_logop */
4402 ((LISTOP*)listop)->op_last->op_next =
4403 (o == listop ? redo : LINKLIST(o));
4409 NewOp(1101,loop,1,LOOP);
4410 loop->op_type = OP_ENTERLOOP;
4411 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4412 loop->op_private = 0;
4413 loop->op_next = (OP*)loop;
4416 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4418 loop->op_redoop = redo;
4419 loop->op_lastop = o;
4420 o->op_private |= loopflags;
4423 loop->op_nextop = next;
4425 loop->op_nextop = o;
4427 o->op_flags |= flags;
4428 o->op_private |= (flags >> 8);
4433 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4438 PADOFFSET padoff = 0;
4444 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4445 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4446 sv->op_type = OP_RV2GV;
4447 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4448 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4449 iterpflags |= OPpITER_DEF;
4451 else if (sv->op_type == OP_PADSV) { /* private variable */
4452 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4453 padoff = sv->op_targ;
4462 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4463 padoff = sv->op_targ;
4468 iterflags |= OPf_SPECIAL;
4474 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4475 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4476 iterpflags |= OPpITER_DEF;
4479 const I32 offset = pad_findmy("$_");
4480 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4481 sv = newGVOP(OP_GV, 0, PL_defgv);
4486 iterpflags |= OPpITER_DEF;
4488 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4489 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4490 iterflags |= OPf_STACKED;
4492 else if (expr->op_type == OP_NULL &&
4493 (expr->op_flags & OPf_KIDS) &&
4494 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4496 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4497 * set the STACKED flag to indicate that these values are to be
4498 * treated as min/max values by 'pp_iterinit'.
4500 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4501 LOGOP* const range = (LOGOP*) flip->op_first;
4502 OP* const left = range->op_first;
4503 OP* const right = left->op_sibling;
4506 range->op_flags &= ~OPf_KIDS;
4507 range->op_first = NULL;
4509 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4510 listop->op_first->op_next = range->op_next;
4511 left->op_next = range->op_other;
4512 right->op_next = (OP*)listop;
4513 listop->op_next = listop->op_first;
4516 op_getmad(expr,(OP*)listop,'O');
4520 expr = (OP*)(listop);
4522 iterflags |= OPf_STACKED;
4525 expr = mod(force_list(expr), OP_GREPSTART);
4528 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4529 append_elem(OP_LIST, expr, scalar(sv))));
4530 assert(!loop->op_next);
4531 /* for my $x () sets OPpLVAL_INTRO;
4532 * for our $x () sets OPpOUR_INTRO */
4533 loop->op_private = (U8)iterpflags;
4534 #ifdef PL_OP_SLAB_ALLOC
4537 NewOp(1234,tmp,1,LOOP);
4538 Copy(loop,tmp,1,LISTOP);
4543 loop = PerlMemShared_realloc(loop, sizeof(LOOP));
4545 loop->op_targ = padoff;
4546 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4548 op_getmad(madsv, (OP*)loop, 'v');
4549 PL_copline = forline;
4550 return newSTATEOP(0, label, wop);
4554 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4559 if (type != OP_GOTO || label->op_type == OP_CONST) {
4560 /* "last()" means "last" */
4561 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4562 o = newOP(type, OPf_SPECIAL);
4564 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4565 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4569 op_getmad(label,o,'L');
4575 /* Check whether it's going to be a goto &function */
4576 if (label->op_type == OP_ENTERSUB
4577 && !(label->op_flags & OPf_STACKED))
4578 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4579 o = newUNOP(type, OPf_STACKED, label);
4581 PL_hints |= HINT_BLOCK_SCOPE;
4585 /* if the condition is a literal array or hash
4586 (or @{ ... } etc), make a reference to it.
4589 S_ref_array_or_hash(pTHX_ OP *cond)
4592 && (cond->op_type == OP_RV2AV
4593 || cond->op_type == OP_PADAV
4594 || cond->op_type == OP_RV2HV
4595 || cond->op_type == OP_PADHV))
4597 return newUNOP(OP_REFGEN,
4598 0, mod(cond, OP_REFGEN));
4604 /* These construct the optree fragments representing given()
4607 entergiven and enterwhen are LOGOPs; the op_other pointer
4608 points up to the associated leave op. We need this so we
4609 can put it in the context and make break/continue work.
4610 (Also, of course, pp_enterwhen will jump straight to
4611 op_other if the match fails.)
4616 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4617 I32 enter_opcode, I32 leave_opcode,
4618 PADOFFSET entertarg)
4624 NewOp(1101, enterop, 1, LOGOP);
4625 enterop->op_type = enter_opcode;
4626 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4627 enterop->op_flags = (U8) OPf_KIDS;
4628 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4629 enterop->op_private = 0;
4631 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4634 enterop->op_first = scalar(cond);
4635 cond->op_sibling = block;
4637 o->op_next = LINKLIST(cond);
4638 cond->op_next = (OP *) enterop;
4641 /* This is a default {} block */
4642 enterop->op_first = block;
4643 enterop->op_flags |= OPf_SPECIAL;
4645 o->op_next = (OP *) enterop;
4648 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4649 entergiven and enterwhen both
4652 enterop->op_next = LINKLIST(block);
4653 block->op_next = enterop->op_other = o;
4658 /* Does this look like a boolean operation? For these purposes
4659 a boolean operation is:
4660 - a subroutine call [*]
4661 - a logical connective
4662 - a comparison operator
4663 - a filetest operator, with the exception of -s -M -A -C
4664 - defined(), exists() or eof()
4665 - /$re/ or $foo =~ /$re/
4667 [*] possibly surprising
4671 S_looks_like_bool(pTHX_ const OP *o)
4674 switch(o->op_type) {
4676 return looks_like_bool(cLOGOPo->op_first);
4680 looks_like_bool(cLOGOPo->op_first)
4681 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4685 case OP_NOT: case OP_XOR:
4686 /* Note that OP_DOR is not here */
4688 case OP_EQ: case OP_NE: case OP_LT:
4689 case OP_GT: case OP_LE: case OP_GE:
4691 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4692 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4694 case OP_SEQ: case OP_SNE: case OP_SLT:
4695 case OP_SGT: case OP_SLE: case OP_SGE:
4699 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4700 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4701 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4702 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4703 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4704 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4705 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4706 case OP_FTTEXT: case OP_FTBINARY:
4708 case OP_DEFINED: case OP_EXISTS:
4709 case OP_MATCH: case OP_EOF:
4714 /* Detect comparisons that have been optimized away */
4715 if (cSVOPo->op_sv == &PL_sv_yes
4716 || cSVOPo->op_sv == &PL_sv_no)
4727 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4731 return newGIVWHENOP(
4732 ref_array_or_hash(cond),
4734 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4738 /* If cond is null, this is a default {} block */
4740 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4742 const bool cond_llb = (!cond || looks_like_bool(cond));
4748 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4750 scalar(ref_array_or_hash(cond)));
4753 return newGIVWHENOP(
4755 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4756 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4760 =for apidoc cv_undef
4762 Clear out all the active components of a CV. This can happen either
4763 by an explicit C<undef &foo>, or by the reference count going to zero.
4764 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4765 children can still follow the full lexical scope chain.
4771 Perl_cv_undef(pTHX_ CV *cv)
4775 if (CvFILE(cv) && !CvISXSUB(cv)) {
4776 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4777 Safefree(CvFILE(cv));
4782 if (!CvISXSUB(cv) && CvROOT(cv)) {
4783 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4784 Perl_croak(aTHX_ "Can't undef active subroutine");
4787 PAD_SAVE_SETNULLPAD();
4789 op_free(CvROOT(cv));
4794 SvPOK_off((SV*)cv); /* forget prototype */
4799 /* remove CvOUTSIDE unless this is an undef rather than a free */
4800 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4801 if (!CvWEAKOUTSIDE(cv))
4802 SvREFCNT_dec(CvOUTSIDE(cv));
4803 CvOUTSIDE(cv) = NULL;
4806 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4809 if (CvISXSUB(cv) && CvXSUB(cv)) {
4812 /* delete all flags except WEAKOUTSIDE */
4813 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4817 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4820 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4821 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4822 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4823 || (p && (len != SvCUR(cv) /* Not the same length. */
4824 || memNE(p, SvPVX_const(cv), len))))
4825 && ckWARN_d(WARN_PROTOTYPE)) {
4826 SV* const msg = sv_newmortal();
4830 gv_efullname3(name = sv_newmortal(), gv, NULL);
4831 sv_setpv(msg, "Prototype mismatch:");
4833 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4835 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4837 sv_catpvs(msg, ": none");
4838 sv_catpvs(msg, " vs ");
4840 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4842 sv_catpvs(msg, "none");
4843 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4847 static void const_sv_xsub(pTHX_ CV* cv);
4851 =head1 Optree Manipulation Functions
4853 =for apidoc cv_const_sv
4855 If C<cv> is a constant sub eligible for inlining. returns the constant
4856 value returned by the sub. Otherwise, returns NULL.
4858 Constant subs can be created with C<newCONSTSUB> or as described in
4859 L<perlsub/"Constant Functions">.
4864 Perl_cv_const_sv(pTHX_ CV *cv)
4866 PERL_UNUSED_CONTEXT;
4869 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4871 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4874 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4875 * Can be called in 3 ways:
4878 * look for a single OP_CONST with attached value: return the value
4880 * cv && CvCLONE(cv) && !CvCONST(cv)
4882 * examine the clone prototype, and if contains only a single
4883 * OP_CONST referencing a pad const, or a single PADSV referencing
4884 * an outer lexical, return a non-zero value to indicate the CV is
4885 * a candidate for "constizing" at clone time
4889 * We have just cloned an anon prototype that was marked as a const
4890 * candidiate. Try to grab the current value, and in the case of
4891 * PADSV, ignore it if it has multiple references. Return the value.
4895 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4903 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4904 o = cLISTOPo->op_first->op_sibling;
4906 for (; o; o = o->op_next) {
4907 const OPCODE type = o->op_type;
4909 if (sv && o->op_next == o)
4911 if (o->op_next != o) {
4912 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4914 if (type == OP_DBSTATE)
4917 if (type == OP_LEAVESUB || type == OP_RETURN)
4921 if (type == OP_CONST && cSVOPo->op_sv)
4923 else if (cv && type == OP_CONST) {
4924 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4928 else if (cv && type == OP_PADSV) {
4929 if (CvCONST(cv)) { /* newly cloned anon */
4930 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4931 /* the candidate should have 1 ref from this pad and 1 ref
4932 * from the parent */
4933 if (!sv || SvREFCNT(sv) != 2)
4940 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4941 sv = &PL_sv_undef; /* an arbitrary non-null value */
4956 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4959 /* This would be the return value, but the return cannot be reached. */
4960 OP* pegop = newOP(OP_NULL, 0);
4963 PERL_UNUSED_ARG(floor);
4973 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4975 NORETURN_FUNCTION_END;
4980 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4982 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4986 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4993 register CV *cv = NULL;
4995 /* If the subroutine has no body, no attributes, and no builtin attributes
4996 then it's just a sub declaration, and we may be able to get away with
4997 storing with a placeholder scalar in the symbol table, rather than a
4998 full GV and CV. If anything is present then it will take a full CV to
5000 const I32 gv_fetch_flags
5001 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5003 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5004 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5007 assert(proto->op_type == OP_CONST);
5008 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5013 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5014 SV * const sv = sv_newmortal();
5015 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5016 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5017 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5018 aname = SvPVX_const(sv);
5023 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5024 : gv_fetchpv(aname ? aname
5025 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5026 gv_fetch_flags, SVt_PVCV);
5028 if (!PL_madskills) {
5037 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5038 maximum a prototype before. */
5039 if (SvTYPE(gv) > SVt_NULL) {
5040 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5041 && ckWARN_d(WARN_PROTOTYPE))
5043 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5045 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5048 sv_setpvn((SV*)gv, ps, ps_len);
5050 sv_setiv((SV*)gv, -1);
5051 SvREFCNT_dec(PL_compcv);
5052 cv = PL_compcv = NULL;
5053 PL_sub_generation++;
5057 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5059 #ifdef GV_UNIQUE_CHECK
5060 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5061 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5065 if (!block || !ps || *ps || attrs
5066 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5068 || block->op_type == OP_NULL
5073 const_sv = op_const_sv(block, NULL);
5076 const bool exists = CvROOT(cv) || CvXSUB(cv);
5078 #ifdef GV_UNIQUE_CHECK
5079 if (exists && GvUNIQUE(gv)) {
5080 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5084 /* if the subroutine doesn't exist and wasn't pre-declared
5085 * with a prototype, assume it will be AUTOLOADed,
5086 * skipping the prototype check
5088 if (exists || SvPOK(cv))
5089 cv_ckproto_len(cv, gv, ps, ps_len);
5090 /* already defined (or promised)? */
5091 if (exists || GvASSUMECV(gv)) {
5094 || block->op_type == OP_NULL
5097 if (CvFLAGS(PL_compcv)) {
5098 /* might have had built-in attrs applied */
5099 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5101 /* just a "sub foo;" when &foo is already defined */
5102 SAVEFREESV(PL_compcv);
5107 && block->op_type != OP_NULL
5110 if (ckWARN(WARN_REDEFINE)
5112 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5114 const line_t oldline = CopLINE(PL_curcop);
5115 if (PL_copline != NOLINE)
5116 CopLINE_set(PL_curcop, PL_copline);
5117 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5118 CvCONST(cv) ? "Constant subroutine %s redefined"
5119 : "Subroutine %s redefined", name);
5120 CopLINE_set(PL_curcop, oldline);
5123 if (!PL_minus_c) /* keep old one around for madskills */
5126 /* (PL_madskills unset in used file.) */
5134 SvREFCNT_inc_simple_void_NN(const_sv);
5136 assert(!CvROOT(cv) && !CvCONST(cv));
5137 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5138 CvXSUBANY(cv).any_ptr = const_sv;
5139 CvXSUB(cv) = const_sv_xsub;
5145 cv = newCONSTSUB(NULL, name, const_sv);
5147 PL_sub_generation++;
5151 SvREFCNT_dec(PL_compcv);
5159 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5160 * before we clobber PL_compcv.
5164 || block->op_type == OP_NULL
5168 /* Might have had built-in attributes applied -- propagate them. */
5169 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5170 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5171 stash = GvSTASH(CvGV(cv));
5172 else if (CvSTASH(cv))
5173 stash = CvSTASH(cv);
5175 stash = PL_curstash;
5178 /* possibly about to re-define existing subr -- ignore old cv */
5179 rcv = (SV*)PL_compcv;
5180 if (name && GvSTASH(gv))
5181 stash = GvSTASH(gv);
5183 stash = PL_curstash;
5185 apply_attrs(stash, rcv, attrs, FALSE);
5187 if (cv) { /* must reuse cv if autoloaded */
5194 || block->op_type == OP_NULL) && !PL_madskills
5197 /* got here with just attrs -- work done, so bug out */
5198 SAVEFREESV(PL_compcv);
5201 /* transfer PL_compcv to cv */
5203 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5204 if (!CvWEAKOUTSIDE(cv))
5205 SvREFCNT_dec(CvOUTSIDE(cv));
5206 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5207 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5208 CvOUTSIDE(PL_compcv) = 0;
5209 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5210 CvPADLIST(PL_compcv) = 0;
5211 /* inner references to PL_compcv must be fixed up ... */
5212 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5213 /* ... before we throw it away */
5214 SvREFCNT_dec(PL_compcv);
5216 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5217 ++PL_sub_generation;
5224 if (strEQ(name, "import")) {
5225 PL_formfeed = (SV*)cv;
5226 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5230 PL_sub_generation++;
5234 CvFILE_set_from_cop(cv, PL_curcop);
5235 CvSTASH(cv) = PL_curstash;
5238 sv_setpvn((SV*)cv, ps, ps_len);
5240 if (PL_error_count) {
5244 const char *s = strrchr(name, ':');
5246 if (strEQ(s, "BEGIN")) {
5247 const char not_safe[] =
5248 "BEGIN not safe after errors--compilation aborted";
5249 if (PL_in_eval & EVAL_KEEPERR)
5250 Perl_croak(aTHX_ not_safe);
5252 /* force display of errors found but not reported */
5253 sv_catpv(ERRSV, not_safe);
5254 Perl_croak(aTHX_ "%"SVf, ERRSV);
5264 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5265 mod(scalarseq(block), OP_LEAVESUBLV));
5268 /* This makes sub {}; work as expected. */
5269 if (block->op_type == OP_STUB) {
5270 OP* const newblock = newSTATEOP(0, NULL, 0);
5272 op_getmad(block,newblock,'B');
5278 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5280 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5281 OpREFCNT_set(CvROOT(cv), 1);
5282 CvSTART(cv) = LINKLIST(CvROOT(cv));
5283 CvROOT(cv)->op_next = 0;
5284 CALL_PEEP(CvSTART(cv));
5286 /* now that optimizer has done its work, adjust pad values */
5288 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5291 assert(!CvCONST(cv));
5292 if (ps && !*ps && op_const_sv(block, cv))
5296 if (name || aname) {
5298 const char * const tname = (name ? name : aname);
5300 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5301 SV * const sv = newSV(0);
5302 SV * const tmpstr = sv_newmortal();
5303 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5304 GV_ADDMULTI, SVt_PVHV);
5307 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5309 (long)PL_subline, (long)CopLINE(PL_curcop));
5310 gv_efullname3(tmpstr, gv, NULL);
5311 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5312 hv = GvHVn(db_postponed);
5313 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5314 CV * const pcv = GvCV(db_postponed);
5320 call_sv((SV*)pcv, G_DISCARD);
5325 if ((s = strrchr(tname,':')))
5330 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5333 if (strEQ(s, "BEGIN") && !PL_error_count) {
5334 const I32 oldscope = PL_scopestack_ix;
5336 SAVECOPFILE(&PL_compiling);
5337 SAVECOPLINE(&PL_compiling);
5340 PL_beginav = newAV();
5341 DEBUG_x( dump_sub(gv) );
5342 av_push(PL_beginav, (SV*)cv);
5343 GvCV(gv) = 0; /* cv has been hijacked */
5344 call_list(oldscope, PL_beginav);
5346 PL_curcop = &PL_compiling;
5347 CopHINTS_set(&PL_compiling, PL_hints);
5350 else if (strEQ(s, "END") && !PL_error_count) {
5353 DEBUG_x( dump_sub(gv) );
5354 av_unshift(PL_endav, 1);
5355 av_store(PL_endav, 0, (SV*)cv);
5356 GvCV(gv) = 0; /* cv has been hijacked */
5358 else if (strEQ(s, "CHECK") && !PL_error_count) {
5360 PL_checkav = newAV();
5361 DEBUG_x( dump_sub(gv) );
5362 if (PL_main_start && ckWARN(WARN_VOID))
5363 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5364 av_unshift(PL_checkav, 1);
5365 av_store(PL_checkav, 0, (SV*)cv);
5366 GvCV(gv) = 0; /* cv has been hijacked */
5368 else if (strEQ(s, "INIT") && !PL_error_count) {
5370 PL_initav = newAV();
5371 DEBUG_x( dump_sub(gv) );
5372 if (PL_main_start && ckWARN(WARN_VOID))
5373 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5374 av_push(PL_initav, (SV*)cv);
5375 GvCV(gv) = 0; /* cv has been hijacked */
5380 PL_copline = NOLINE;
5385 /* XXX unsafe for threads if eval_owner isn't held */
5387 =for apidoc newCONSTSUB
5389 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5390 eligible for inlining at compile-time.
5396 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5401 const char *const temp_p = CopFILE(PL_curcop);
5402 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5404 SV *const temp_sv = CopFILESV(PL_curcop);
5406 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5408 char *const file = savepvn(temp_p, temp_p ? len : 0);
5412 SAVECOPLINE(PL_curcop);
5413 CopLINE_set(PL_curcop, PL_copline);
5416 PL_hints &= ~HINT_BLOCK_SCOPE;
5419 SAVESPTR(PL_curstash);
5420 SAVECOPSTASH(PL_curcop);
5421 PL_curstash = stash;
5422 CopSTASH_set(PL_curcop,stash);
5425 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5426 and so doesn't get free()d. (It's expected to be from the C pre-
5427 processor __FILE__ directive). But we need a dynamically allocated one,
5428 and we need it to get freed. So we cheat, and take advantage of the
5429 fact that the first 0 bytes of any string always look the same. */
5430 cv = newXS(name, const_sv_xsub, file);
5431 CvXSUBANY(cv).any_ptr = sv;
5433 /* prototype is "". But this gets free()d. :-) */
5434 sv_usepvn_flags((SV*)cv, file, len, SV_HAS_TRAILING_NUL);
5435 /* This gives us a prototype of "", rather than the file name. */
5440 CopSTASH_free(PL_curcop);
5448 =for apidoc U||newXS
5450 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5456 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5459 GV * const gv = gv_fetchpv(name ? name :
5460 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5461 GV_ADDMULTI, SVt_PVCV);
5465 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5467 if ((cv = (name ? GvCV(gv) : NULL))) {
5469 /* just a cached method */
5473 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5474 /* already defined (or promised) */
5475 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5476 if (ckWARN(WARN_REDEFINE)) {
5477 GV * const gvcv = CvGV(cv);
5479 HV * const stash = GvSTASH(gvcv);
5481 const char *redefined_name = HvNAME_get(stash);
5482 if ( strEQ(redefined_name,"autouse") ) {
5483 const line_t oldline = CopLINE(PL_curcop);
5484 if (PL_copline != NOLINE)
5485 CopLINE_set(PL_curcop, PL_copline);
5486 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5487 CvCONST(cv) ? "Constant subroutine %s redefined"
5488 : "Subroutine %s redefined"
5490 CopLINE_set(PL_curcop, oldline);
5500 if (cv) /* must reuse cv if autoloaded */
5504 sv_upgrade((SV *)cv, SVt_PVCV);
5508 PL_sub_generation++;
5512 (void)gv_fetchfile(filename);
5513 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5514 an external constant string */
5516 CvXSUB(cv) = subaddr;
5519 const char *s = strrchr(name,':');
5525 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5528 if (strEQ(s, "BEGIN")) {
5530 PL_beginav = newAV();
5531 av_push(PL_beginav, (SV*)cv);
5532 GvCV(gv) = 0; /* cv has been hijacked */
5534 else if (strEQ(s, "END")) {
5537 av_unshift(PL_endav, 1);
5538 av_store(PL_endav, 0, (SV*)cv);
5539 GvCV(gv) = 0; /* cv has been hijacked */
5541 else if (strEQ(s, "CHECK")) {
5543 PL_checkav = newAV();
5544 if (PL_main_start && ckWARN(WARN_VOID))
5545 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5546 av_unshift(PL_checkav, 1);
5547 av_store(PL_checkav, 0, (SV*)cv);
5548 GvCV(gv) = 0; /* cv has been hijacked */
5550 else if (strEQ(s, "INIT")) {
5552 PL_initav = newAV();
5553 if (PL_main_start && ckWARN(WARN_VOID))
5554 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5555 av_push(PL_initav, (SV*)cv);
5556 GvCV(gv) = 0; /* cv has been hijacked */
5571 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5576 OP* pegop = newOP(OP_NULL, 0);
5580 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5581 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5583 #ifdef GV_UNIQUE_CHECK
5585 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5589 if ((cv = GvFORM(gv))) {
5590 if (ckWARN(WARN_REDEFINE)) {
5591 const line_t oldline = CopLINE(PL_curcop);
5592 if (PL_copline != NOLINE)
5593 CopLINE_set(PL_curcop, PL_copline);
5594 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5595 o ? "Format %"SVf" redefined"
5596 : "Format STDOUT redefined" ,cSVOPo->op_sv);
5597 CopLINE_set(PL_curcop, oldline);
5604 CvFILE_set_from_cop(cv, PL_curcop);
5607 pad_tidy(padtidy_FORMAT);
5608 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5609 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5610 OpREFCNT_set(CvROOT(cv), 1);
5611 CvSTART(cv) = LINKLIST(CvROOT(cv));
5612 CvROOT(cv)->op_next = 0;
5613 CALL_PEEP(CvSTART(cv));
5615 op_getmad(o,pegop,'n');
5616 op_getmad_weak(block, pegop, 'b');
5620 PL_copline = NOLINE;
5628 Perl_newANONLIST(pTHX_ OP *o)
5630 return newUNOP(OP_REFGEN, 0,
5631 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5635 Perl_newANONHASH(pTHX_ OP *o)
5637 return newUNOP(OP_REFGEN, 0,
5638 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5642 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5644 return newANONATTRSUB(floor, proto, NULL, block);
5648 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5650 return newUNOP(OP_REFGEN, 0,
5651 newSVOP(OP_ANONCODE, 0,
5652 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5656 Perl_oopsAV(pTHX_ OP *o)
5659 switch (o->op_type) {
5661 o->op_type = OP_PADAV;
5662 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5663 return ref(o, OP_RV2AV);
5666 o->op_type = OP_RV2AV;
5667 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5672 if (ckWARN_d(WARN_INTERNAL))
5673 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5680 Perl_oopsHV(pTHX_ OP *o)
5683 switch (o->op_type) {
5686 o->op_type = OP_PADHV;
5687 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5688 return ref(o, OP_RV2HV);
5692 o->op_type = OP_RV2HV;
5693 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5698 if (ckWARN_d(WARN_INTERNAL))
5699 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5706 Perl_newAVREF(pTHX_ OP *o)
5709 if (o->op_type == OP_PADANY) {
5710 o->op_type = OP_PADAV;
5711 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5714 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5715 && ckWARN(WARN_DEPRECATED)) {
5716 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5717 "Using an array as a reference is deprecated");
5719 return newUNOP(OP_RV2AV, 0, scalar(o));
5723 Perl_newGVREF(pTHX_ I32 type, OP *o)
5725 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5726 return newUNOP(OP_NULL, 0, o);
5727 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5731 Perl_newHVREF(pTHX_ OP *o)
5734 if (o->op_type == OP_PADANY) {
5735 o->op_type = OP_PADHV;
5736 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5739 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5740 && ckWARN(WARN_DEPRECATED)) {
5741 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5742 "Using a hash as a reference is deprecated");
5744 return newUNOP(OP_RV2HV, 0, scalar(o));
5748 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5750 return newUNOP(OP_RV2CV, flags, scalar(o));
5754 Perl_newSVREF(pTHX_ OP *o)
5757 if (o->op_type == OP_PADANY) {
5758 o->op_type = OP_PADSV;
5759 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5762 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5763 o->op_flags |= OPpDONE_SVREF;
5766 return newUNOP(OP_RV2SV, 0, scalar(o));
5769 /* Check routines. See the comments at the top of this file for details
5770 * on when these are called */
5773 Perl_ck_anoncode(pTHX_ OP *o)
5775 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5777 cSVOPo->op_sv = NULL;
5782 Perl_ck_bitop(pTHX_ OP *o)
5785 #define OP_IS_NUMCOMPARE(op) \
5786 ((op) == OP_LT || (op) == OP_I_LT || \
5787 (op) == OP_GT || (op) == OP_I_GT || \
5788 (op) == OP_LE || (op) == OP_I_LE || \
5789 (op) == OP_GE || (op) == OP_I_GE || \
5790 (op) == OP_EQ || (op) == OP_I_EQ || \
5791 (op) == OP_NE || (op) == OP_I_NE || \
5792 (op) == OP_NCMP || (op) == OP_I_NCMP)
5793 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5794 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5795 && (o->op_type == OP_BIT_OR
5796 || o->op_type == OP_BIT_AND
5797 || o->op_type == OP_BIT_XOR))
5799 const OP * const left = cBINOPo->op_first;
5800 const OP * const right = left->op_sibling;
5801 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5802 (left->op_flags & OPf_PARENS) == 0) ||
5803 (OP_IS_NUMCOMPARE(right->op_type) &&
5804 (right->op_flags & OPf_PARENS) == 0))
5805 if (ckWARN(WARN_PRECEDENCE))
5806 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5807 "Possible precedence problem on bitwise %c operator",
5808 o->op_type == OP_BIT_OR ? '|'
5809 : o->op_type == OP_BIT_AND ? '&' : '^'
5816 Perl_ck_concat(pTHX_ OP *o)
5818 const OP * const kid = cUNOPo->op_first;
5819 PERL_UNUSED_CONTEXT;
5820 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5821 !(kUNOP->op_first->op_flags & OPf_MOD))
5822 o->op_flags |= OPf_STACKED;
5827 Perl_ck_spair(pTHX_ OP *o)
5830 if (o->op_flags & OPf_KIDS) {
5833 const OPCODE type = o->op_type;
5834 o = modkids(ck_fun(o), type);
5835 kid = cUNOPo->op_first;
5836 newop = kUNOP->op_first->op_sibling;
5838 const OPCODE type = newop->op_type;
5839 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5840 type == OP_PADAV || type == OP_PADHV ||
5841 type == OP_RV2AV || type == OP_RV2HV)
5845 op_getmad(kUNOP->op_first,newop,'K');
5847 op_free(kUNOP->op_first);
5849 kUNOP->op_first = newop;
5851 o->op_ppaddr = PL_ppaddr[++o->op_type];
5856 Perl_ck_delete(pTHX_ OP *o)
5860 if (o->op_flags & OPf_KIDS) {
5861 OP * const kid = cUNOPo->op_first;
5862 switch (kid->op_type) {
5864 o->op_flags |= OPf_SPECIAL;
5867 o->op_private |= OPpSLICE;
5870 o->op_flags |= OPf_SPECIAL;
5875 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5884 Perl_ck_die(pTHX_ OP *o)
5887 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5893 Perl_ck_eof(pTHX_ OP *o)
5897 if (o->op_flags & OPf_KIDS) {
5898 if (cLISTOPo->op_first->op_type == OP_STUB) {
5900 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5902 op_getmad(o,newop,'O');
5914 Perl_ck_eval(pTHX_ OP *o)
5917 PL_hints |= HINT_BLOCK_SCOPE;
5918 if (o->op_flags & OPf_KIDS) {
5919 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5922 o->op_flags &= ~OPf_KIDS;
5925 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5931 cUNOPo->op_first = 0;
5936 NewOp(1101, enter, 1, LOGOP);
5937 enter->op_type = OP_ENTERTRY;
5938 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5939 enter->op_private = 0;
5941 /* establish postfix order */
5942 enter->op_next = (OP*)enter;
5944 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5945 o->op_type = OP_LEAVETRY;
5946 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5947 enter->op_other = o;
5948 op_getmad(oldo,o,'O');
5962 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5963 op_getmad(oldo,o,'O');
5965 o->op_targ = (PADOFFSET)PL_hints;
5966 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5967 /* Store a copy of %^H that pp_entereval can pick up */
5968 OP *hhop = newSVOP(OP_CONST, 0,
5969 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
5970 cUNOPo->op_first->op_sibling = hhop;
5971 o->op_private |= OPpEVAL_HAS_HH;
5977 Perl_ck_exit(pTHX_ OP *o)
5980 HV * const table = GvHV(PL_hintgv);
5982 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5983 if (svp && *svp && SvTRUE(*svp))
5984 o->op_private |= OPpEXIT_VMSISH;
5986 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5992 Perl_ck_exec(pTHX_ OP *o)
5994 if (o->op_flags & OPf_STACKED) {
5997 kid = cUNOPo->op_first->op_sibling;
5998 if (kid->op_type == OP_RV2GV)
6007 Perl_ck_exists(pTHX_ OP *o)
6011 if (o->op_flags & OPf_KIDS) {
6012 OP * const kid = cUNOPo->op_first;
6013 if (kid->op_type == OP_ENTERSUB) {
6014 (void) ref(kid, o->op_type);
6015 if (kid->op_type != OP_RV2CV && !PL_error_count)
6016 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6018 o->op_private |= OPpEXISTS_SUB;
6020 else if (kid->op_type == OP_AELEM)
6021 o->op_flags |= OPf_SPECIAL;
6022 else if (kid->op_type != OP_HELEM)
6023 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6031 Perl_ck_rvconst(pTHX_ register OP *o)
6034 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6036 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6037 if (o->op_type == OP_RV2CV)
6038 o->op_private &= ~1;
6040 if (kid->op_type == OP_CONST) {
6043 SV * const kidsv = kid->op_sv;
6045 /* Is it a constant from cv_const_sv()? */
6046 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6047 SV * const rsv = SvRV(kidsv);
6048 const int svtype = SvTYPE(rsv);
6049 const char *badtype = NULL;
6051 switch (o->op_type) {
6053 if (svtype > SVt_PVMG)
6054 badtype = "a SCALAR";
6057 if (svtype != SVt_PVAV)
6058 badtype = "an ARRAY";
6061 if (svtype != SVt_PVHV)
6065 if (svtype != SVt_PVCV)
6070 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6073 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6074 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6075 /* If this is an access to a stash, disable "strict refs", because
6076 * stashes aren't auto-vivified at compile-time (unless we store
6077 * symbols in them), and we don't want to produce a run-time
6078 * stricture error when auto-vivifying the stash. */
6079 const char *s = SvPV_nolen(kidsv);
6080 const STRLEN l = SvCUR(kidsv);
6081 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6082 o->op_private &= ~HINT_STRICT_REFS;
6084 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6085 const char *badthing;
6086 switch (o->op_type) {
6088 badthing = "a SCALAR";
6091 badthing = "an ARRAY";
6094 badthing = "a HASH";
6102 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6106 * This is a little tricky. We only want to add the symbol if we
6107 * didn't add it in the lexer. Otherwise we get duplicate strict
6108 * warnings. But if we didn't add it in the lexer, we must at
6109 * least pretend like we wanted to add it even if it existed before,
6110 * or we get possible typo warnings. OPpCONST_ENTERED says
6111 * whether the lexer already added THIS instance of this symbol.
6113 iscv = (o->op_type == OP_RV2CV) * 2;
6115 gv = gv_fetchsv(kidsv,
6116 iscv | !(kid->op_private & OPpCONST_ENTERED),
6119 : o->op_type == OP_RV2SV
6121 : o->op_type == OP_RV2AV
6123 : o->op_type == OP_RV2HV
6126 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6128 kid->op_type = OP_GV;
6129 SvREFCNT_dec(kid->op_sv);
6131 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6132 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6133 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6135 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6137 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6139 kid->op_private = 0;
6140 kid->op_ppaddr = PL_ppaddr[OP_GV];
6147 Perl_ck_ftst(pTHX_ OP *o)
6150 const I32 type = o->op_type;
6152 if (o->op_flags & OPf_REF) {
6155 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6156 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6157 const OPCODE kidtype = kid->op_type;
6159 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6160 OP * const newop = newGVOP(type, OPf_REF,
6161 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6163 op_getmad(o,newop,'O');
6169 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6170 o->op_private |= OPpFT_ACCESS;
6171 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6172 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6173 o->op_private |= OPpFT_STACKED;
6181 if (type == OP_FTTTY)
6182 o = newGVOP(type, OPf_REF, PL_stdingv);
6184 o = newUNOP(type, 0, newDEFSVOP());
6185 op_getmad(oldo,o,'O');
6191 Perl_ck_fun(pTHX_ OP *o)
6194 const int type = o->op_type;
6195 register I32 oa = PL_opargs[type] >> OASHIFT;
6197 if (o->op_flags & OPf_STACKED) {
6198 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6201 return no_fh_allowed(o);
6204 if (o->op_flags & OPf_KIDS) {
6205 OP **tokid = &cLISTOPo->op_first;
6206 register OP *kid = cLISTOPo->op_first;
6210 if (kid->op_type == OP_PUSHMARK ||
6211 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6213 tokid = &kid->op_sibling;
6214 kid = kid->op_sibling;
6216 if (!kid && PL_opargs[type] & OA_DEFGV)
6217 *tokid = kid = newDEFSVOP();
6221 sibl = kid->op_sibling;
6223 if (!sibl && kid->op_type == OP_STUB) {
6230 /* list seen where single (scalar) arg expected? */
6231 if (numargs == 1 && !(oa >> 4)
6232 && kid->op_type == OP_LIST && type != OP_SCALAR)
6234 return too_many_arguments(o,PL_op_desc[type]);
6247 if ((type == OP_PUSH || type == OP_UNSHIFT)
6248 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6249 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6250 "Useless use of %s with no values",
6253 if (kid->op_type == OP_CONST &&
6254 (kid->op_private & OPpCONST_BARE))
6256 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6257 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6258 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6259 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6260 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6261 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6263 op_getmad(kid,newop,'K');
6268 kid->op_sibling = sibl;
6271 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6272 bad_type(numargs, "array", PL_op_desc[type], kid);
6276 if (kid->op_type == OP_CONST &&
6277 (kid->op_private & OPpCONST_BARE))
6279 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6280 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6281 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6282 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6283 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6284 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6286 op_getmad(kid,newop,'K');
6291 kid->op_sibling = sibl;
6294 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6295 bad_type(numargs, "hash", PL_op_desc[type], kid);
6300 OP * const newop = newUNOP(OP_NULL, 0, kid);
6301 kid->op_sibling = 0;
6303 newop->op_next = newop;
6305 kid->op_sibling = sibl;
6310 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6311 if (kid->op_type == OP_CONST &&
6312 (kid->op_private & OPpCONST_BARE))
6314 OP * const newop = newGVOP(OP_GV, 0,
6315 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6316 if (!(o->op_private & 1) && /* if not unop */
6317 kid == cLISTOPo->op_last)
6318 cLISTOPo->op_last = newop;
6320 op_getmad(kid,newop,'K');
6326 else if (kid->op_type == OP_READLINE) {
6327 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6328 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6331 I32 flags = OPf_SPECIAL;
6335 /* is this op a FH constructor? */
6336 if (is_handle_constructor(o,numargs)) {
6337 const char *name = NULL;
6341 /* Set a flag to tell rv2gv to vivify
6342 * need to "prove" flag does not mean something
6343 * else already - NI-S 1999/05/07
6346 if (kid->op_type == OP_PADSV) {
6347 name = PAD_COMPNAME_PV(kid->op_targ);
6348 /* SvCUR of a pad namesv can't be trusted
6349 * (see PL_generation), so calc its length
6355 else if (kid->op_type == OP_RV2SV
6356 && kUNOP->op_first->op_type == OP_GV)
6358 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6360 len = GvNAMELEN(gv);
6362 else if (kid->op_type == OP_AELEM
6363 || kid->op_type == OP_HELEM)
6365 OP *op = ((BINOP*)kid)->op_first;
6369 const char * const a =
6370 kid->op_type == OP_AELEM ?
6372 if (((op->op_type == OP_RV2AV) ||
6373 (op->op_type == OP_RV2HV)) &&
6374 (op = ((UNOP*)op)->op_first) &&
6375 (op->op_type == OP_GV)) {
6376 /* packagevar $a[] or $h{} */
6377 GV * const gv = cGVOPx_gv(op);
6385 else if (op->op_type == OP_PADAV
6386 || op->op_type == OP_PADHV) {
6387 /* lexicalvar $a[] or $h{} */
6388 const char * const padname =
6389 PAD_COMPNAME_PV(op->op_targ);
6398 name = SvPV_const(tmpstr, len);
6403 name = "__ANONIO__";
6410 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6411 namesv = PAD_SVl(targ);
6412 SvUPGRADE(namesv, SVt_PV);
6414 sv_setpvn(namesv, "$", 1);
6415 sv_catpvn(namesv, name, len);
6418 kid->op_sibling = 0;
6419 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6420 kid->op_targ = targ;
6421 kid->op_private |= priv;
6423 kid->op_sibling = sibl;
6429 mod(scalar(kid), type);
6433 tokid = &kid->op_sibling;
6434 kid = kid->op_sibling;
6437 if (kid && kid->op_type != OP_STUB)
6438 return too_many_arguments(o,OP_DESC(o));
6439 o->op_private |= numargs;
6441 /* FIXME - should the numargs move as for the PERL_MAD case? */
6442 o->op_private |= numargs;
6444 return too_many_arguments(o,OP_DESC(o));
6448 else if (PL_opargs[type] & OA_DEFGV) {
6450 OP *newop = newUNOP(type, 0, newDEFSVOP());
6451 op_getmad(o,newop,'O');
6454 /* Ordering of these two is important to keep f_map.t passing. */
6456 return newUNOP(type, 0, newDEFSVOP());
6461 while (oa & OA_OPTIONAL)
6463 if (oa && oa != OA_LIST)
6464 return too_few_arguments(o,OP_DESC(o));
6470 Perl_ck_glob(pTHX_ OP *o)
6476 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6477 append_elem(OP_GLOB, o, newDEFSVOP());
6479 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6480 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6482 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6485 #if !defined(PERL_EXTERNAL_GLOB)
6486 /* XXX this can be tightened up and made more failsafe. */
6487 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6490 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6491 newSVpvs("File::Glob"), NULL, NULL, NULL);
6492 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6493 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6494 GvCV(gv) = GvCV(glob_gv);
6495 SvREFCNT_inc_void((SV*)GvCV(gv));
6496 GvIMPORTED_CV_on(gv);
6499 #endif /* PERL_EXTERNAL_GLOB */
6501 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6502 append_elem(OP_GLOB, o,
6503 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6504 o->op_type = OP_LIST;
6505 o->op_ppaddr = PL_ppaddr[OP_LIST];
6506 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6507 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6508 cLISTOPo->op_first->op_targ = 0;
6509 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6510 append_elem(OP_LIST, o,
6511 scalar(newUNOP(OP_RV2CV, 0,
6512 newGVOP(OP_GV, 0, gv)))));
6513 o = newUNOP(OP_NULL, 0, ck_subr(o));
6514 o->op_targ = OP_GLOB; /* hint at what it used to be */
6517 gv = newGVgen("main");
6519 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6525 Perl_ck_grep(pTHX_ OP *o)
6530 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6533 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6534 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6536 if (o->op_flags & OPf_STACKED) {
6539 kid = cLISTOPo->op_first->op_sibling;
6540 if (!cUNOPx(kid)->op_next)
6541 Perl_croak(aTHX_ "panic: ck_grep");
6542 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6545 NewOp(1101, gwop, 1, LOGOP);
6546 kid->op_next = (OP*)gwop;
6547 o->op_flags &= ~OPf_STACKED;
6549 kid = cLISTOPo->op_first->op_sibling;
6550 if (type == OP_MAPWHILE)
6557 kid = cLISTOPo->op_first->op_sibling;
6558 if (kid->op_type != OP_NULL)
6559 Perl_croak(aTHX_ "panic: ck_grep");
6560 kid = kUNOP->op_first;
6563 NewOp(1101, gwop, 1, LOGOP);
6564 gwop->op_type = type;
6565 gwop->op_ppaddr = PL_ppaddr[type];
6566 gwop->op_first = listkids(o);
6567 gwop->op_flags |= OPf_KIDS;
6568 gwop->op_other = LINKLIST(kid);
6569 kid->op_next = (OP*)gwop;
6570 offset = pad_findmy("$_");
6571 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6572 o->op_private = gwop->op_private = 0;
6573 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6576 o->op_private = gwop->op_private = OPpGREP_LEX;
6577 gwop->op_targ = o->op_targ = offset;
6580 kid = cLISTOPo->op_first->op_sibling;
6581 if (!kid || !kid->op_sibling)
6582 return too_few_arguments(o,OP_DESC(o));
6583 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6584 mod(kid, OP_GREPSTART);
6590 Perl_ck_index(pTHX_ OP *o)
6592 if (o->op_flags & OPf_KIDS) {
6593 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6595 kid = kid->op_sibling; /* get past "big" */
6596 if (kid && kid->op_type == OP_CONST)
6597 fbm_compile(((SVOP*)kid)->op_sv, 0);
6603 Perl_ck_lengthconst(pTHX_ OP *o)
6605 /* XXX length optimization goes here */
6610 Perl_ck_lfun(pTHX_ OP *o)
6612 const OPCODE type = o->op_type;
6613 return modkids(ck_fun(o), type);
6617 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6619 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6620 switch (cUNOPo->op_first->op_type) {
6622 /* This is needed for
6623 if (defined %stash::)
6624 to work. Do not break Tk.
6626 break; /* Globals via GV can be undef */
6628 case OP_AASSIGN: /* Is this a good idea? */
6629 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6630 "defined(@array) is deprecated");
6631 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6632 "\t(Maybe you should just omit the defined()?)\n");
6635 /* This is needed for
6636 if (defined %stash::)
6637 to work. Do not break Tk.
6639 break; /* Globals via GV can be undef */
6641 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6642 "defined(%%hash) is deprecated");
6643 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6644 "\t(Maybe you should just omit the defined()?)\n");
6655 Perl_ck_rfun(pTHX_ OP *o)
6657 const OPCODE type = o->op_type;
6658 return refkids(ck_fun(o), type);
6662 Perl_ck_listiob(pTHX_ OP *o)
6666 kid = cLISTOPo->op_first;
6669 kid = cLISTOPo->op_first;
6671 if (kid->op_type == OP_PUSHMARK)
6672 kid = kid->op_sibling;
6673 if (kid && o->op_flags & OPf_STACKED)
6674 kid = kid->op_sibling;
6675 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6676 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6677 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6678 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6679 cLISTOPo->op_first->op_sibling = kid;
6680 cLISTOPo->op_last = kid;
6681 kid = kid->op_sibling;
6686 append_elem(o->op_type, o, newDEFSVOP());
6692 Perl_ck_say(pTHX_ OP *o)
6695 o->op_type = OP_PRINT;
6696 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6697 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6702 Perl_ck_smartmatch(pTHX_ OP *o)
6705 if (0 == (o->op_flags & OPf_SPECIAL)) {
6706 OP *first = cBINOPo->op_first;
6707 OP *second = first->op_sibling;
6709 /* Implicitly take a reference to an array or hash */
6710 first->op_sibling = NULL;
6711 first = cBINOPo->op_first = ref_array_or_hash(first);
6712 second = first->op_sibling = ref_array_or_hash(second);
6714 /* Implicitly take a reference to a regular expression */
6715 if (first->op_type == OP_MATCH) {
6716 first->op_type = OP_QR;
6717 first->op_ppaddr = PL_ppaddr[OP_QR];
6719 if (second->op_type == OP_MATCH) {
6720 second->op_type = OP_QR;
6721 second->op_ppaddr = PL_ppaddr[OP_QR];
6730 Perl_ck_sassign(pTHX_ OP *o)
6732 OP * const kid = cLISTOPo->op_first;
6733 /* has a disposable target? */
6734 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6735 && !(kid->op_flags & OPf_STACKED)
6736 /* Cannot steal the second time! */
6737 && !(kid->op_private & OPpTARGET_MY))
6739 OP * const kkid = kid->op_sibling;
6741 /* Can just relocate the target. */
6742 if (kkid && kkid->op_type == OP_PADSV
6743 && !(kkid->op_private & OPpLVAL_INTRO))
6745 kid->op_targ = kkid->op_targ;
6747 /* Now we do not need PADSV and SASSIGN. */
6748 kid->op_sibling = o->op_sibling; /* NULL */
6749 cLISTOPo->op_first = NULL;
6751 op_getmad(o,kid,'O');
6752 op_getmad(kkid,kid,'M');
6757 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6765 Perl_ck_match(pTHX_ OP *o)
6768 if (o->op_type != OP_QR && PL_compcv) {
6769 const I32 offset = pad_findmy("$_");
6770 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6771 o->op_targ = offset;
6772 o->op_private |= OPpTARGET_MY;
6775 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6776 o->op_private |= OPpRUNTIME;
6781 Perl_ck_method(pTHX_ OP *o)
6783 OP * const kid = cUNOPo->op_first;
6784 if (kid->op_type == OP_CONST) {
6785 SV* sv = kSVOP->op_sv;
6786 const char * const method = SvPVX_const(sv);
6787 if (!(strchr(method, ':') || strchr(method, '\''))) {
6789 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6790 sv = newSVpvn_share(method, SvCUR(sv), 0);
6793 kSVOP->op_sv = NULL;
6795 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6797 op_getmad(o,cmop,'O');
6808 Perl_ck_null(pTHX_ OP *o)
6810 PERL_UNUSED_CONTEXT;
6815 Perl_ck_open(pTHX_ OP *o)
6818 HV * const table = GvHV(PL_hintgv);
6820 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6822 const I32 mode = mode_from_discipline(*svp);
6823 if (mode & O_BINARY)
6824 o->op_private |= OPpOPEN_IN_RAW;
6825 else if (mode & O_TEXT)
6826 o->op_private |= OPpOPEN_IN_CRLF;
6829 svp = hv_fetchs(table, "open_OUT", FALSE);
6831 const I32 mode = mode_from_discipline(*svp);
6832 if (mode & O_BINARY)
6833 o->op_private |= OPpOPEN_OUT_RAW;
6834 else if (mode & O_TEXT)
6835 o->op_private |= OPpOPEN_OUT_CRLF;
6838 if (o->op_type == OP_BACKTICK)
6841 /* In case of three-arg dup open remove strictness
6842 * from the last arg if it is a bareword. */
6843 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6844 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6848 if ((last->op_type == OP_CONST) && /* The bareword. */
6849 (last->op_private & OPpCONST_BARE) &&
6850 (last->op_private & OPpCONST_STRICT) &&
6851 (oa = first->op_sibling) && /* The fh. */
6852 (oa = oa->op_sibling) && /* The mode. */
6853 (oa->op_type == OP_CONST) &&
6854 SvPOK(((SVOP*)oa)->op_sv) &&
6855 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6856 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6857 (last == oa->op_sibling)) /* The bareword. */
6858 last->op_private &= ~OPpCONST_STRICT;
6864 Perl_ck_repeat(pTHX_ OP *o)
6866 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6867 o->op_private |= OPpREPEAT_DOLIST;
6868 cBINOPo->op_first = force_list(cBINOPo->op_first);
6876 Perl_ck_require(pTHX_ OP *o)
6881 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6882 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6884 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6885 SV * const sv = kid->op_sv;
6886 U32 was_readonly = SvREADONLY(sv);
6891 sv_force_normal_flags(sv, 0);
6892 assert(!SvREADONLY(sv));
6899 for (s = SvPVX(sv); *s; s++) {
6900 if (*s == ':' && s[1] == ':') {
6901 const STRLEN len = strlen(s+2)+1;
6903 Move(s+2, s+1, len, char);
6904 SvCUR_set(sv, SvCUR(sv) - 1);
6907 sv_catpvs(sv, ".pm");
6908 SvFLAGS(sv) |= was_readonly;
6912 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6913 /* handle override, if any */
6914 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6915 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6916 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6917 gv = gvp ? *gvp : NULL;
6921 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6922 OP * const kid = cUNOPo->op_first;
6925 cUNOPo->op_first = 0;
6929 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6930 append_elem(OP_LIST, kid,
6931 scalar(newUNOP(OP_RV2CV, 0,
6934 op_getmad(o,newop,'O');
6942 Perl_ck_return(pTHX_ OP *o)
6945 if (CvLVALUE(PL_compcv)) {
6947 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6948 mod(kid, OP_LEAVESUBLV);
6954 Perl_ck_select(pTHX_ OP *o)
6958 if (o->op_flags & OPf_KIDS) {
6959 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6960 if (kid && kid->op_sibling) {
6961 o->op_type = OP_SSELECT;
6962 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6964 return fold_constants(o);
6968 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6969 if (kid && kid->op_type == OP_RV2GV)
6970 kid->op_private &= ~HINT_STRICT_REFS;
6975 Perl_ck_shift(pTHX_ OP *o)
6978 const I32 type = o->op_type;
6980 if (!(o->op_flags & OPf_KIDS)) {
6982 /* FIXME - this can be refactored to reduce code in #ifdefs */
6984 OP * const oldo = o;
6988 argop = newUNOP(OP_RV2AV, 0,
6989 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6991 o = newUNOP(type, 0, scalar(argop));
6992 op_getmad(oldo,o,'O');
6995 return newUNOP(type, 0, scalar(argop));
6998 return scalar(modkids(ck_fun(o), type));
7002 Perl_ck_sort(pTHX_ OP *o)
7007 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7008 HV * const hinthv = GvHV(PL_hintgv);
7010 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7012 const I32 sorthints = (I32)SvIV(*svp);
7013 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7014 o->op_private |= OPpSORT_QSORT;
7015 if ((sorthints & HINT_SORT_STABLE) != 0)
7016 o->op_private |= OPpSORT_STABLE;
7021 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7023 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7024 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7026 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7028 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7030 if (kid->op_type == OP_SCOPE) {
7034 else if (kid->op_type == OP_LEAVE) {
7035 if (o->op_type == OP_SORT) {
7036 op_null(kid); /* wipe out leave */
7039 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7040 if (k->op_next == kid)
7042 /* don't descend into loops */
7043 else if (k->op_type == OP_ENTERLOOP
7044 || k->op_type == OP_ENTERITER)
7046 k = cLOOPx(k)->op_lastop;
7051 kid->op_next = 0; /* just disconnect the leave */
7052 k = kLISTOP->op_first;
7057 if (o->op_type == OP_SORT) {
7058 /* provide scalar context for comparison function/block */
7064 o->op_flags |= OPf_SPECIAL;
7066 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7069 firstkid = firstkid->op_sibling;
7072 /* provide list context for arguments */
7073 if (o->op_type == OP_SORT)
7080 S_simplify_sort(pTHX_ OP *o)
7083 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7088 if (!(o->op_flags & OPf_STACKED))
7090 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7091 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7092 kid = kUNOP->op_first; /* get past null */
7093 if (kid->op_type != OP_SCOPE)
7095 kid = kLISTOP->op_last; /* get past scope */
7096 switch(kid->op_type) {
7104 k = kid; /* remember this node*/
7105 if (kBINOP->op_first->op_type != OP_RV2SV)
7107 kid = kBINOP->op_first; /* get past cmp */
7108 if (kUNOP->op_first->op_type != OP_GV)
7110 kid = kUNOP->op_first; /* get past rv2sv */
7112 if (GvSTASH(gv) != PL_curstash)
7114 gvname = GvNAME(gv);
7115 if (*gvname == 'a' && gvname[1] == '\0')
7117 else if (*gvname == 'b' && gvname[1] == '\0')
7122 kid = k; /* back to cmp */
7123 if (kBINOP->op_last->op_type != OP_RV2SV)
7125 kid = kBINOP->op_last; /* down to 2nd arg */
7126 if (kUNOP->op_first->op_type != OP_GV)
7128 kid = kUNOP->op_first; /* get past rv2sv */
7130 if (GvSTASH(gv) != PL_curstash)
7132 gvname = GvNAME(gv);
7134 ? !(*gvname == 'a' && gvname[1] == '\0')
7135 : !(*gvname == 'b' && gvname[1] == '\0'))
7137 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7139 o->op_private |= OPpSORT_DESCEND;
7140 if (k->op_type == OP_NCMP)
7141 o->op_private |= OPpSORT_NUMERIC;
7142 if (k->op_type == OP_I_NCMP)
7143 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7144 kid = cLISTOPo->op_first->op_sibling;
7145 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7147 op_getmad(kid,o,'S'); /* then delete it */
7149 op_free(kid); /* then delete it */
7154 Perl_ck_split(pTHX_ OP *o)
7159 if (o->op_flags & OPf_STACKED)
7160 return no_fh_allowed(o);
7162 kid = cLISTOPo->op_first;
7163 if (kid->op_type != OP_NULL)
7164 Perl_croak(aTHX_ "panic: ck_split");
7165 kid = kid->op_sibling;
7166 op_free(cLISTOPo->op_first);
7167 cLISTOPo->op_first = kid;
7169 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7170 cLISTOPo->op_last = kid; /* There was only one element previously */
7173 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7174 OP * const sibl = kid->op_sibling;
7175 kid->op_sibling = 0;
7176 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7177 if (cLISTOPo->op_first == cLISTOPo->op_last)
7178 cLISTOPo->op_last = kid;
7179 cLISTOPo->op_first = kid;
7180 kid->op_sibling = sibl;
7183 kid->op_type = OP_PUSHRE;
7184 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7186 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7187 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7188 "Use of /g modifier is meaningless in split");
7191 if (!kid->op_sibling)
7192 append_elem(OP_SPLIT, o, newDEFSVOP());
7194 kid = kid->op_sibling;
7197 if (!kid->op_sibling)
7198 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7199 assert(kid->op_sibling);
7201 kid = kid->op_sibling;
7204 if (kid->op_sibling)
7205 return too_many_arguments(o,OP_DESC(o));
7211 Perl_ck_join(pTHX_ OP *o)
7213 const OP * const kid = cLISTOPo->op_first->op_sibling;
7214 if (kid && kid->op_type == OP_MATCH) {
7215 if (ckWARN(WARN_SYNTAX)) {
7216 const REGEXP *re = PM_GETRE(kPMOP);
7217 const char *pmstr = re ? re->precomp : "STRING";
7218 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7219 "/%s/ should probably be written as \"%s\"",
7227 Perl_ck_subr(pTHX_ OP *o)
7230 OP *prev = ((cUNOPo->op_first->op_sibling)
7231 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7232 OP *o2 = prev->op_sibling;
7234 const char *proto = NULL;
7235 const char *proto_end = NULL;
7240 I32 contextclass = 0;
7244 o->op_private |= OPpENTERSUB_HASTARG;
7245 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7246 if (cvop->op_type == OP_RV2CV) {
7248 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7249 op_null(cvop); /* disable rv2cv */
7250 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7251 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7252 GV *gv = cGVOPx_gv(tmpop);
7255 tmpop->op_private |= OPpEARLY_CV;
7259 namegv = CvANON(cv) ? gv : CvGV(cv);
7260 proto = SvPV((SV*)cv, len);
7261 proto_end = proto + len;
7263 if (CvASSERTION(cv)) {
7264 if (PL_hints & HINT_ASSERTING) {
7265 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7266 o->op_private |= OPpENTERSUB_DB;
7270 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7271 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7272 "Impossible to activate assertion call");
7279 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7280 if (o2->op_type == OP_CONST)
7281 o2->op_private &= ~OPpCONST_STRICT;
7282 else if (o2->op_type == OP_LIST) {
7283 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7284 if (sib && sib->op_type == OP_CONST)
7285 sib->op_private &= ~OPpCONST_STRICT;
7288 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7289 if (PERLDB_SUB && PL_curstash != PL_debstash)
7290 o->op_private |= OPpENTERSUB_DB;
7291 while (o2 != cvop) {
7293 if (PL_madskills && o2->op_type == OP_NULL)
7294 o3 = ((UNOP*)o2)->op_first;
7298 if (proto >= proto_end)
7299 return too_many_arguments(o, gv_ename(namegv));
7319 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7321 arg == 1 ? "block or sub {}" : "sub {}",
7322 gv_ename(namegv), o3);
7325 /* '*' allows any scalar type, including bareword */
7328 if (o3->op_type == OP_RV2GV)
7329 goto wrapref; /* autoconvert GLOB -> GLOBref */
7330 else if (o3->op_type == OP_CONST)
7331 o3->op_private &= ~OPpCONST_STRICT;
7332 else if (o3->op_type == OP_ENTERSUB) {
7333 /* accidental subroutine, revert to bareword */
7334 OP *gvop = ((UNOP*)o3)->op_first;
7335 if (gvop && gvop->op_type == OP_NULL) {
7336 gvop = ((UNOP*)gvop)->op_first;
7338 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7341 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7342 (gvop = ((UNOP*)gvop)->op_first) &&
7343 gvop->op_type == OP_GV)
7345 GV * const gv = cGVOPx_gv(gvop);
7346 OP * const sibling = o2->op_sibling;
7347 SV * const n = newSVpvs("");
7349 OP * const oldo2 = o2;
7353 gv_fullname4(n, gv, "", FALSE);
7354 o2 = newSVOP(OP_CONST, 0, n);
7355 op_getmad(oldo2,o2,'O');
7356 prev->op_sibling = o2;
7357 o2->op_sibling = sibling;
7373 if (contextclass++ == 0) {
7374 e = strchr(proto, ']');
7375 if (!e || e == proto)
7384 const char *p = proto;
7385 const char *const end = proto;
7387 while (*--p != '[');
7388 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7390 gv_ename(namegv), o3);
7395 if (o3->op_type == OP_RV2GV)
7398 bad_type(arg, "symbol", gv_ename(namegv), o3);
7401 if (o3->op_type == OP_ENTERSUB)
7404 bad_type(arg, "subroutine entry", gv_ename(namegv),
7408 if (o3->op_type == OP_RV2SV ||
7409 o3->op_type == OP_PADSV ||
7410 o3->op_type == OP_HELEM ||
7411 o3->op_type == OP_AELEM ||
7412 o3->op_type == OP_THREADSV)
7415 bad_type(arg, "scalar", gv_ename(namegv), o3);
7418 if (o3->op_type == OP_RV2AV ||
7419 o3->op_type == OP_PADAV)
7422 bad_type(arg, "array", gv_ename(namegv), o3);
7425 if (o3->op_type == OP_RV2HV ||
7426 o3->op_type == OP_PADHV)
7429 bad_type(arg, "hash", gv_ename(namegv), o3);
7434 OP* const sib = kid->op_sibling;
7435 kid->op_sibling = 0;
7436 o2 = newUNOP(OP_REFGEN, 0, kid);
7437 o2->op_sibling = sib;
7438 prev->op_sibling = o2;
7440 if (contextclass && e) {
7455 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7456 gv_ename(namegv), cv);
7461 mod(o2, OP_ENTERSUB);
7463 o2 = o2->op_sibling;
7465 if (proto && !optional && proto_end > proto &&
7466 (*proto != '@' && *proto != '%' && *proto != ';'))
7467 return too_few_arguments(o, gv_ename(namegv));
7470 OP * const oldo = o;
7474 o=newSVOP(OP_CONST, 0, newSViv(0));
7475 op_getmad(oldo,o,'O');
7481 Perl_ck_svconst(pTHX_ OP *o)
7483 PERL_UNUSED_CONTEXT;
7484 SvREADONLY_on(cSVOPo->op_sv);
7489 Perl_ck_chdir(pTHX_ OP *o)
7491 if (o->op_flags & OPf_KIDS) {
7492 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7494 if (kid && kid->op_type == OP_CONST &&
7495 (kid->op_private & OPpCONST_BARE))
7497 o->op_flags |= OPf_SPECIAL;
7498 kid->op_private &= ~OPpCONST_STRICT;
7505 Perl_ck_trunc(pTHX_ OP *o)
7507 if (o->op_flags & OPf_KIDS) {
7508 SVOP *kid = (SVOP*)cUNOPo->op_first;
7510 if (kid->op_type == OP_NULL)
7511 kid = (SVOP*)kid->op_sibling;
7512 if (kid && kid->op_type == OP_CONST &&
7513 (kid->op_private & OPpCONST_BARE))
7515 o->op_flags |= OPf_SPECIAL;
7516 kid->op_private &= ~OPpCONST_STRICT;
7523 Perl_ck_unpack(pTHX_ OP *o)
7525 OP *kid = cLISTOPo->op_first;
7526 if (kid->op_sibling) {
7527 kid = kid->op_sibling;
7528 if (!kid->op_sibling)
7529 kid->op_sibling = newDEFSVOP();
7535 Perl_ck_substr(pTHX_ OP *o)
7538 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7539 OP *kid = cLISTOPo->op_first;
7541 if (kid->op_type == OP_NULL)
7542 kid = kid->op_sibling;
7544 kid->op_flags |= OPf_MOD;
7550 /* A peephole optimizer. We visit the ops in the order they're to execute.
7551 * See the comments at the top of this file for more details about when
7552 * peep() is called */
7555 Perl_peep(pTHX_ register OP *o)
7558 register OP* oldop = NULL;
7560 if (!o || o->op_opt)
7564 SAVEVPTR(PL_curcop);
7565 for (; o; o = o->op_next) {
7569 switch (o->op_type) {
7573 PL_curcop = ((COP*)o); /* for warnings */
7578 if (cSVOPo->op_private & OPpCONST_STRICT)
7579 no_bareword_allowed(o);
7581 case OP_METHOD_NAMED:
7582 /* Relocate sv to the pad for thread safety.
7583 * Despite being a "constant", the SV is written to,
7584 * for reference counts, sv_upgrade() etc. */
7586 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7587 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7588 /* If op_sv is already a PADTMP then it is being used by
7589 * some pad, so make a copy. */
7590 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7591 SvREADONLY_on(PAD_SVl(ix));
7592 SvREFCNT_dec(cSVOPo->op_sv);
7594 else if (o->op_type == OP_CONST
7595 && cSVOPo->op_sv == &PL_sv_undef) {
7596 /* PL_sv_undef is hack - it's unsafe to store it in the
7597 AV that is the pad, because av_fetch treats values of
7598 PL_sv_undef as a "free" AV entry and will merrily
7599 replace them with a new SV, causing pad_alloc to think
7600 that this pad slot is free. (When, clearly, it is not)
7602 SvOK_off(PAD_SVl(ix));
7603 SvPADTMP_on(PAD_SVl(ix));
7604 SvREADONLY_on(PAD_SVl(ix));
7607 SvREFCNT_dec(PAD_SVl(ix));
7608 SvPADTMP_on(cSVOPo->op_sv);
7609 PAD_SETSV(ix, cSVOPo->op_sv);
7610 /* XXX I don't know how this isn't readonly already. */
7611 SvREADONLY_on(PAD_SVl(ix));
7613 cSVOPo->op_sv = NULL;
7621 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7622 if (o->op_next->op_private & OPpTARGET_MY) {
7623 if (o->op_flags & OPf_STACKED) /* chained concats */
7624 goto ignore_optimization;
7626 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7627 o->op_targ = o->op_next->op_targ;
7628 o->op_next->op_targ = 0;
7629 o->op_private |= OPpTARGET_MY;
7632 op_null(o->op_next);
7634 ignore_optimization:
7638 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7640 break; /* Scalar stub must produce undef. List stub is noop */
7644 if (o->op_targ == OP_NEXTSTATE
7645 || o->op_targ == OP_DBSTATE
7646 || o->op_targ == OP_SETSTATE)
7648 PL_curcop = ((COP*)o);
7650 /* XXX: We avoid setting op_seq here to prevent later calls
7651 to peep() from mistakenly concluding that optimisation
7652 has already occurred. This doesn't fix the real problem,
7653 though (See 20010220.007). AMS 20010719 */
7654 /* op_seq functionality is now replaced by op_opt */
7655 if (oldop && o->op_next) {
7656 oldop->op_next = o->op_next;
7664 if (oldop && o->op_next) {
7665 oldop->op_next = o->op_next;
7673 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7674 OP* const pop = (o->op_type == OP_PADAV) ?
7675 o->op_next : o->op_next->op_next;
7677 if (pop && pop->op_type == OP_CONST &&
7678 ((PL_op = pop->op_next)) &&
7679 pop->op_next->op_type == OP_AELEM &&
7680 !(pop->op_next->op_private &
7681 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7682 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7687 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7688 no_bareword_allowed(pop);
7689 if (o->op_type == OP_GV)
7690 op_null(o->op_next);
7691 op_null(pop->op_next);
7693 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7694 o->op_next = pop->op_next->op_next;
7695 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7696 o->op_private = (U8)i;
7697 if (o->op_type == OP_GV) {
7702 o->op_flags |= OPf_SPECIAL;
7703 o->op_type = OP_AELEMFAST;
7709 if (o->op_next->op_type == OP_RV2SV) {
7710 if (!(o->op_next->op_private & OPpDEREF)) {
7711 op_null(o->op_next);
7712 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7714 o->op_next = o->op_next->op_next;
7715 o->op_type = OP_GVSV;
7716 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7719 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7720 GV * const gv = cGVOPo_gv;
7721 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7722 /* XXX could check prototype here instead of just carping */
7723 SV * const sv = sv_newmortal();
7724 gv_efullname3(sv, gv, NULL);
7725 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7726 "%"SVf"() called too early to check prototype",
7730 else if (o->op_next->op_type == OP_READLINE
7731 && o->op_next->op_next->op_type == OP_CONCAT
7732 && (o->op_next->op_next->op_flags & OPf_STACKED))
7734 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7735 o->op_type = OP_RCATLINE;
7736 o->op_flags |= OPf_STACKED;
7737 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7738 op_null(o->op_next->op_next);
7739 op_null(o->op_next);
7756 while (cLOGOP->op_other->op_type == OP_NULL)
7757 cLOGOP->op_other = cLOGOP->op_other->op_next;
7758 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7764 while (cLOOP->op_redoop->op_type == OP_NULL)
7765 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7766 peep(cLOOP->op_redoop);
7767 while (cLOOP->op_nextop->op_type == OP_NULL)
7768 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7769 peep(cLOOP->op_nextop);
7770 while (cLOOP->op_lastop->op_type == OP_NULL)
7771 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7772 peep(cLOOP->op_lastop);
7779 while (cPMOP->op_pmreplstart &&
7780 cPMOP->op_pmreplstart->op_type == OP_NULL)
7781 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7782 peep(cPMOP->op_pmreplstart);
7787 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7788 && ckWARN(WARN_SYNTAX))
7790 if (o->op_next->op_sibling) {
7791 const OPCODE type = o->op_next->op_sibling->op_type;
7792 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7793 const line_t oldline = CopLINE(PL_curcop);
7794 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7795 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7796 "Statement unlikely to be reached");
7797 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7798 "\t(Maybe you meant system() when you said exec()?)\n");
7799 CopLINE_set(PL_curcop, oldline);
7810 const char *key = NULL;
7815 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7818 /* Make the CONST have a shared SV */
7819 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7820 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7821 key = SvPV_const(sv, keylen);
7822 lexname = newSVpvn_share(key,
7823 SvUTF8(sv) ? -(I32)keylen : keylen,
7829 if ((o->op_private & (OPpLVAL_INTRO)))
7832 rop = (UNOP*)((BINOP*)o)->op_first;
7833 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7835 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7836 if (!SvPAD_TYPED(lexname))
7838 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7839 if (!fields || !GvHV(*fields))
7841 key = SvPV_const(*svp, keylen);
7842 if (!hv_fetch(GvHV(*fields), key,
7843 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7845 Perl_croak(aTHX_ "No such class field \"%s\" "
7846 "in variable %s of type %s",
7847 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7860 SVOP *first_key_op, *key_op;
7862 if ((o->op_private & (OPpLVAL_INTRO))
7863 /* I bet there's always a pushmark... */
7864 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7865 /* hmmm, no optimization if list contains only one key. */
7867 rop = (UNOP*)((LISTOP*)o)->op_last;
7868 if (rop->op_type != OP_RV2HV)
7870 if (rop->op_first->op_type == OP_PADSV)
7871 /* @$hash{qw(keys here)} */
7872 rop = (UNOP*)rop->op_first;
7874 /* @{$hash}{qw(keys here)} */
7875 if (rop->op_first->op_type == OP_SCOPE
7876 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7878 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7884 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7885 if (!SvPAD_TYPED(lexname))
7887 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7888 if (!fields || !GvHV(*fields))
7890 /* Again guessing that the pushmark can be jumped over.... */
7891 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7892 ->op_first->op_sibling;
7893 for (key_op = first_key_op; key_op;
7894 key_op = (SVOP*)key_op->op_sibling) {
7895 if (key_op->op_type != OP_CONST)
7897 svp = cSVOPx_svp(key_op);
7898 key = SvPV_const(*svp, keylen);
7899 if (!hv_fetch(GvHV(*fields), key,
7900 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7902 Perl_croak(aTHX_ "No such class field \"%s\" "
7903 "in variable %s of type %s",
7904 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7911 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7915 /* check that RHS of sort is a single plain array */
7916 OP *oright = cUNOPo->op_first;
7917 if (!oright || oright->op_type != OP_PUSHMARK)
7920 /* reverse sort ... can be optimised. */
7921 if (!cUNOPo->op_sibling) {
7922 /* Nothing follows us on the list. */
7923 OP * const reverse = o->op_next;
7925 if (reverse->op_type == OP_REVERSE &&
7926 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7927 OP * const pushmark = cUNOPx(reverse)->op_first;
7928 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7929 && (cUNOPx(pushmark)->op_sibling == o)) {
7930 /* reverse -> pushmark -> sort */
7931 o->op_private |= OPpSORT_REVERSE;
7933 pushmark->op_next = oright->op_next;
7939 /* make @a = sort @a act in-place */
7943 oright = cUNOPx(oright)->op_sibling;
7946 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7947 oright = cUNOPx(oright)->op_sibling;
7951 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7952 || oright->op_next != o
7953 || (oright->op_private & OPpLVAL_INTRO)
7957 /* o2 follows the chain of op_nexts through the LHS of the
7958 * assign (if any) to the aassign op itself */
7960 if (!o2 || o2->op_type != OP_NULL)
7963 if (!o2 || o2->op_type != OP_PUSHMARK)
7966 if (o2 && o2->op_type == OP_GV)
7969 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7970 || (o2->op_private & OPpLVAL_INTRO)
7975 if (!o2 || o2->op_type != OP_NULL)
7978 if (!o2 || o2->op_type != OP_AASSIGN
7979 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7982 /* check that the sort is the first arg on RHS of assign */
7984 o2 = cUNOPx(o2)->op_first;
7985 if (!o2 || o2->op_type != OP_NULL)
7987 o2 = cUNOPx(o2)->op_first;
7988 if (!o2 || o2->op_type != OP_PUSHMARK)
7990 if (o2->op_sibling != o)
7993 /* check the array is the same on both sides */
7994 if (oleft->op_type == OP_RV2AV) {
7995 if (oright->op_type != OP_RV2AV
7996 || !cUNOPx(oright)->op_first
7997 || cUNOPx(oright)->op_first->op_type != OP_GV
7998 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7999 cGVOPx_gv(cUNOPx(oright)->op_first)
8003 else if (oright->op_type != OP_PADAV
8004 || oright->op_targ != oleft->op_targ
8008 /* transfer MODishness etc from LHS arg to RHS arg */
8009 oright->op_flags = oleft->op_flags;
8010 o->op_private |= OPpSORT_INPLACE;
8012 /* excise push->gv->rv2av->null->aassign */
8013 o2 = o->op_next->op_next;
8014 op_null(o2); /* PUSHMARK */
8016 if (o2->op_type == OP_GV) {
8017 op_null(o2); /* GV */
8020 op_null(o2); /* RV2AV or PADAV */
8021 o2 = o2->op_next->op_next;
8022 op_null(o2); /* AASSIGN */
8024 o->op_next = o2->op_next;
8030 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8032 LISTOP *enter, *exlist;
8035 enter = (LISTOP *) o->op_next;
8038 if (enter->op_type == OP_NULL) {
8039 enter = (LISTOP *) enter->op_next;
8043 /* for $a (...) will have OP_GV then OP_RV2GV here.
8044 for (...) just has an OP_GV. */
8045 if (enter->op_type == OP_GV) {
8046 gvop = (OP *) enter;
8047 enter = (LISTOP *) enter->op_next;
8050 if (enter->op_type == OP_RV2GV) {
8051 enter = (LISTOP *) enter->op_next;
8057 if (enter->op_type != OP_ENTERITER)
8060 iter = enter->op_next;
8061 if (!iter || iter->op_type != OP_ITER)
8064 expushmark = enter->op_first;
8065 if (!expushmark || expushmark->op_type != OP_NULL
8066 || expushmark->op_targ != OP_PUSHMARK)
8069 exlist = (LISTOP *) expushmark->op_sibling;
8070 if (!exlist || exlist->op_type != OP_NULL
8071 || exlist->op_targ != OP_LIST)
8074 if (exlist->op_last != o) {
8075 /* Mmm. Was expecting to point back to this op. */
8078 theirmark = exlist->op_first;
8079 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8082 if (theirmark->op_sibling != o) {
8083 /* There's something between the mark and the reverse, eg
8084 for (1, reverse (...))
8089 ourmark = ((LISTOP *)o)->op_first;
8090 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8093 ourlast = ((LISTOP *)o)->op_last;
8094 if (!ourlast || ourlast->op_next != o)
8097 rv2av = ourmark->op_sibling;
8098 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8099 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8100 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8101 /* We're just reversing a single array. */
8102 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8103 enter->op_flags |= OPf_STACKED;
8106 /* We don't have control over who points to theirmark, so sacrifice
8108 theirmark->op_next = ourmark->op_next;
8109 theirmark->op_flags = ourmark->op_flags;
8110 ourlast->op_next = gvop ? gvop : (OP *) enter;
8113 enter->op_private |= OPpITER_REVERSED;
8114 iter->op_private |= OPpITER_REVERSED;
8121 UNOP *refgen, *rv2cv;
8124 /* I do not understand this, but if o->op_opt isn't set to 1,
8125 various tests in ext/B/t/bytecode.t fail with no readily
8131 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8134 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8137 rv2gv = ((BINOP *)o)->op_last;
8138 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8141 refgen = (UNOP *)((BINOP *)o)->op_first;
8143 if (!refgen || refgen->op_type != OP_REFGEN)
8146 exlist = (LISTOP *)refgen->op_first;
8147 if (!exlist || exlist->op_type != OP_NULL
8148 || exlist->op_targ != OP_LIST)
8151 if (exlist->op_first->op_type != OP_PUSHMARK)
8154 rv2cv = (UNOP*)exlist->op_last;
8156 if (rv2cv->op_type != OP_RV2CV)
8159 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8160 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8161 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8163 o->op_private |= OPpASSIGN_CV_TO_GV;
8164 rv2gv->op_private |= OPpDONT_INIT_GV;
8165 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8181 Perl_custom_op_name(pTHX_ const OP* o)
8184 const IV index = PTR2IV(o->op_ppaddr);
8188 if (!PL_custom_op_names) /* This probably shouldn't happen */
8189 return (char *)PL_op_name[OP_CUSTOM];
8191 keysv = sv_2mortal(newSViv(index));
8193 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8195 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8197 return SvPV_nolen(HeVAL(he));
8201 Perl_custom_op_desc(pTHX_ const OP* o)
8204 const IV index = PTR2IV(o->op_ppaddr);
8208 if (!PL_custom_op_descs)
8209 return (char *)PL_op_desc[OP_CUSTOM];
8211 keysv = sv_2mortal(newSViv(index));
8213 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8215 return (char *)PL_op_desc[OP_CUSTOM];
8217 return SvPV_nolen(HeVAL(he));
8222 /* Efficient sub that returns a constant scalar value. */
8224 const_sv_xsub(pTHX_ CV* cv)
8231 Perl_croak(aTHX_ "usage: %s::%s()",
8232 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8236 ST(0) = (SV*)XSANY.any_ptr;
8242 * c-indentation-style: bsd
8244 * indent-tabs-mode: t
8247 * ex: set ts=8 sts=4 sw=4 noet: