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. */
253 if (p - name > 200) {
255 strlcpy(name + 200, "...", 4);
257 strcpy(name + 200, "...");
264 /* Move everything else down one character */
265 for (; p-name > 2; p--)
267 name[2] = toCTRL(name[1]);
270 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
273 /* check for duplicate declaration */
274 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
276 if (PL_in_my_stash && *name != '$') {
277 yyerror(Perl_form(aTHX_
278 "Can't declare class for non-scalar %s in \"%s\"",
279 name, is_our ? "our" : "my"));
282 /* allocate a spare slot and store the name in that slot */
284 off = pad_add_name(name,
287 /* $_ is always in main::, even with our */
288 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
299 Perl_op_free(pTHX_ OP *o)
304 if (!o || o->op_static)
308 if (o->op_private & OPpREFCOUNTED) {
319 refcnt = OpREFCNT_dec(o);
330 if (o->op_flags & OPf_KIDS) {
331 register OP *kid, *nextkid;
332 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
333 nextkid = kid->op_sibling; /* Get before next freeing kid */
338 type = (OPCODE)o->op_targ;
340 /* COP* is not cleared by op_clear() so that we may track line
341 * numbers etc even after null() */
342 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
347 #ifdef DEBUG_LEAKING_SCALARS
354 Perl_op_clear(pTHX_ OP *o)
359 /* if (o->op_madprop && o->op_madprop->mad_next)
361 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
362 "modification of a read only value" for a reason I can't fathom why.
363 It's the "" stringification of $_, where $_ was set to '' in a foreach
364 loop, but it defies simplification into a small test case.
365 However, commenting them out has caused ext/List/Util/t/weak.t to fail
368 mad_free(o->op_madprop);
374 switch (o->op_type) {
375 case OP_NULL: /* Was holding old type, if any. */
376 if (PL_madskills && o->op_targ != OP_NULL) {
377 o->op_type = o->op_targ;
381 case OP_ENTEREVAL: /* Was holding hints. */
385 if (!(o->op_flags & OPf_REF)
386 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
392 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
393 /* not an OP_PADAV replacement */
395 if (cPADOPo->op_padix > 0) {
396 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
397 * may still exist on the pad */
398 pad_swipe(cPADOPo->op_padix, TRUE);
399 cPADOPo->op_padix = 0;
402 SvREFCNT_dec(cSVOPo->op_sv);
403 cSVOPo->op_sv = NULL;
407 case OP_METHOD_NAMED:
409 SvREFCNT_dec(cSVOPo->op_sv);
410 cSVOPo->op_sv = NULL;
413 Even if op_clear does a pad_free for the target of the op,
414 pad_free doesn't actually remove the sv that exists in the pad;
415 instead it lives on. This results in that it could be reused as
416 a target later on when the pad was reallocated.
419 pad_swipe(o->op_targ,1);
428 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
432 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
433 SvREFCNT_dec(cSVOPo->op_sv);
434 cSVOPo->op_sv = NULL;
437 Safefree(cPVOPo->op_pv);
438 cPVOPo->op_pv = NULL;
442 op_free(cPMOPo->op_pmreplroot);
446 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
447 /* No GvIN_PAD_off here, because other references may still
448 * exist on the pad */
449 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
452 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
459 HV * const pmstash = PmopSTASH(cPMOPo);
460 if (pmstash && !SvIS_FREED(pmstash)) {
461 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
463 PMOP *pmop = (PMOP*) mg->mg_obj;
464 PMOP *lastpmop = NULL;
466 if (cPMOPo == pmop) {
468 lastpmop->op_pmnext = pmop->op_pmnext;
470 mg->mg_obj = (SV*) pmop->op_pmnext;
474 pmop = pmop->op_pmnext;
478 PmopSTASH_free(cPMOPo);
480 cPMOPo->op_pmreplroot = NULL;
481 /* we use the "SAFE" version of the PM_ macros here
482 * since sv_clean_all might release some PMOPs
483 * after PL_regex_padav has been cleared
484 * and the clearing of PL_regex_padav needs to
485 * happen before sv_clean_all
487 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
488 PM_SETRE_SAFE(cPMOPo, NULL);
490 if(PL_regex_pad) { /* We could be in destruction */
491 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
492 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
493 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
500 if (o->op_targ > 0) {
501 pad_free(o->op_targ);
507 S_cop_free(pTHX_ COP* cop)
509 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
512 if (! specialWARN(cop->cop_warnings))
513 PerlMemShared_free(cop->cop_warnings);
514 if (! specialCopIO(cop->cop_io)) {
518 SvREFCNT_dec(cop->cop_io);
521 Perl_refcounted_he_free(aTHX_ cop->cop_hints);
525 Perl_op_null(pTHX_ OP *o)
528 if (o->op_type == OP_NULL)
532 o->op_targ = o->op_type;
533 o->op_type = OP_NULL;
534 o->op_ppaddr = PL_ppaddr[OP_NULL];
538 Perl_op_refcnt_lock(pTHX)
546 Perl_op_refcnt_unlock(pTHX)
553 /* Contextualizers */
555 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
558 Perl_linklist(pTHX_ OP *o)
565 /* establish postfix order */
566 first = cUNOPo->op_first;
569 o->op_next = LINKLIST(first);
572 if (kid->op_sibling) {
573 kid->op_next = LINKLIST(kid->op_sibling);
574 kid = kid->op_sibling;
588 Perl_scalarkids(pTHX_ OP *o)
590 if (o && o->op_flags & OPf_KIDS) {
592 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
599 S_scalarboolean(pTHX_ OP *o)
602 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
603 if (ckWARN(WARN_SYNTAX)) {
604 const line_t oldline = CopLINE(PL_curcop);
606 if (PL_copline != NOLINE)
607 CopLINE_set(PL_curcop, PL_copline);
608 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
609 CopLINE_set(PL_curcop, oldline);
616 Perl_scalar(pTHX_ OP *o)
621 /* assumes no premature commitment */
622 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
623 || o->op_type == OP_RETURN)
628 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
630 switch (o->op_type) {
632 scalar(cBINOPo->op_first);
637 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
641 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
642 if (!kPMOP->op_pmreplroot)
643 deprecate_old("implicit split to @_");
651 if (o->op_flags & OPf_KIDS) {
652 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
658 kid = cLISTOPo->op_first;
660 while ((kid = kid->op_sibling)) {
666 WITH_THR(PL_curcop = &PL_compiling);
671 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
677 WITH_THR(PL_curcop = &PL_compiling);
680 if (ckWARN(WARN_VOID))
681 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
687 Perl_scalarvoid(pTHX_ OP *o)
691 const char* useless = NULL;
695 /* trailing mad null ops don't count as "there" for void processing */
697 o->op_type != OP_NULL &&
699 o->op_sibling->op_type == OP_NULL)
702 for (sib = o->op_sibling;
703 sib && sib->op_type == OP_NULL;
704 sib = sib->op_sibling) ;
710 if (o->op_type == OP_NEXTSTATE
711 || o->op_type == OP_SETSTATE
712 || o->op_type == OP_DBSTATE
713 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
714 || o->op_targ == OP_SETSTATE
715 || o->op_targ == OP_DBSTATE)))
716 PL_curcop = (COP*)o; /* for warning below */
718 /* assumes no premature commitment */
719 want = o->op_flags & OPf_WANT;
720 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
721 || o->op_type == OP_RETURN)
726 if ((o->op_private & OPpTARGET_MY)
727 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
729 return scalar(o); /* As if inside SASSIGN */
732 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
734 switch (o->op_type) {
736 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
740 if (o->op_flags & OPf_STACKED)
744 if (o->op_private == 4)
816 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
817 useless = OP_DESC(o);
821 kid = cUNOPo->op_first;
822 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
823 kid->op_type != OP_TRANS) {
826 useless = "negative pattern binding (!~)";
833 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
834 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
835 useless = "a variable";
840 if (cSVOPo->op_private & OPpCONST_STRICT)
841 no_bareword_allowed(o);
843 if (ckWARN(WARN_VOID)) {
844 useless = "a constant";
845 if (o->op_private & OPpCONST_ARYBASE)
847 /* don't warn on optimised away booleans, eg
848 * use constant Foo, 5; Foo || print; */
849 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
851 /* the constants 0 and 1 are permitted as they are
852 conventionally used as dummies in constructs like
853 1 while some_condition_with_side_effects; */
854 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
856 else if (SvPOK(sv)) {
857 /* perl4's way of mixing documentation and code
858 (before the invention of POD) was based on a
859 trick to mix nroff and perl code. The trick was
860 built upon these three nroff macros being used in
861 void context. The pink camel has the details in
862 the script wrapman near page 319. */
863 const char * const maybe_macro = SvPVX_const(sv);
864 if (strnEQ(maybe_macro, "di", 2) ||
865 strnEQ(maybe_macro, "ds", 2) ||
866 strnEQ(maybe_macro, "ig", 2))
871 op_null(o); /* don't execute or even remember it */
875 o->op_type = OP_PREINC; /* pre-increment is faster */
876 o->op_ppaddr = PL_ppaddr[OP_PREINC];
880 o->op_type = OP_PREDEC; /* pre-decrement is faster */
881 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
885 o->op_type = OP_I_PREINC; /* pre-increment is faster */
886 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
890 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
891 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
900 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
905 if (o->op_flags & OPf_STACKED)
912 if (!(o->op_flags & OPf_KIDS))
923 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
930 /* all requires must return a boolean value */
931 o->op_flags &= ~OPf_WANT;
936 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
937 if (!kPMOP->op_pmreplroot)
938 deprecate_old("implicit split to @_");
942 if (useless && ckWARN(WARN_VOID))
943 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
948 Perl_listkids(pTHX_ OP *o)
950 if (o && o->op_flags & OPf_KIDS) {
952 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
959 Perl_list(pTHX_ OP *o)
964 /* assumes no premature commitment */
965 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
966 || o->op_type == OP_RETURN)
971 if ((o->op_private & OPpTARGET_MY)
972 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
974 return o; /* As if inside SASSIGN */
977 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
979 switch (o->op_type) {
982 list(cBINOPo->op_first);
987 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
995 if (!(o->op_flags & OPf_KIDS))
997 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
998 list(cBINOPo->op_first);
999 return gen_constant_list(o);
1006 kid = cLISTOPo->op_first;
1008 while ((kid = kid->op_sibling)) {
1009 if (kid->op_sibling)
1014 WITH_THR(PL_curcop = &PL_compiling);
1018 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1019 if (kid->op_sibling)
1024 WITH_THR(PL_curcop = &PL_compiling);
1027 /* all requires must return a boolean value */
1028 o->op_flags &= ~OPf_WANT;
1035 Perl_scalarseq(pTHX_ OP *o)
1039 const OPCODE type = o->op_type;
1041 if (type == OP_LINESEQ || type == OP_SCOPE ||
1042 type == OP_LEAVE || type == OP_LEAVETRY)
1045 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1046 if (kid->op_sibling) {
1050 PL_curcop = &PL_compiling;
1052 o->op_flags &= ~OPf_PARENS;
1053 if (PL_hints & HINT_BLOCK_SCOPE)
1054 o->op_flags |= OPf_PARENS;
1057 o = newOP(OP_STUB, 0);
1062 S_modkids(pTHX_ OP *o, I32 type)
1064 if (o && o->op_flags & OPf_KIDS) {
1066 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1072 /* Propagate lvalue ("modifiable") context to an op and its children.
1073 * 'type' represents the context type, roughly based on the type of op that
1074 * would do the modifying, although local() is represented by OP_NULL.
1075 * It's responsible for detecting things that can't be modified, flag
1076 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1077 * might have to vivify a reference in $x), and so on.
1079 * For example, "$a+1 = 2" would cause mod() to be called with o being
1080 * OP_ADD and type being OP_SASSIGN, and would output an error.
1084 Perl_mod(pTHX_ OP *o, I32 type)
1088 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1091 if (!o || PL_error_count)
1094 if ((o->op_private & OPpTARGET_MY)
1095 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1100 switch (o->op_type) {
1106 if (!(o->op_private & OPpCONST_ARYBASE))
1109 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1110 CopARYBASE_set(&PL_compiling,
1111 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1115 SAVECOPARYBASE(&PL_compiling);
1116 CopARYBASE_set(&PL_compiling, 0);
1118 else if (type == OP_REFGEN)
1121 Perl_croak(aTHX_ "That use of $[ is unsupported");
1124 if (o->op_flags & OPf_PARENS || PL_madskills)
1128 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1129 !(o->op_flags & OPf_STACKED)) {
1130 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1131 /* The default is to set op_private to the number of children,
1132 which for a UNOP such as RV2CV is always 1. And w're using
1133 the bit for a flag in RV2CV, so we need it clear. */
1134 o->op_private &= ~1;
1135 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1136 assert(cUNOPo->op_first->op_type == OP_NULL);
1137 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1140 else if (o->op_private & OPpENTERSUB_NOMOD)
1142 else { /* lvalue subroutine call */
1143 o->op_private |= OPpLVAL_INTRO;
1144 PL_modcount = RETURN_UNLIMITED_NUMBER;
1145 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1146 /* Backward compatibility mode: */
1147 o->op_private |= OPpENTERSUB_INARGS;
1150 else { /* Compile-time error message: */
1151 OP *kid = cUNOPo->op_first;
1155 if (kid->op_type == OP_PUSHMARK)
1157 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1159 "panic: unexpected lvalue entersub "
1160 "args: type/targ %ld:%"UVuf,
1161 (long)kid->op_type, (UV)kid->op_targ);
1162 kid = kLISTOP->op_first;
1164 while (kid->op_sibling)
1165 kid = kid->op_sibling;
1166 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1168 if (kid->op_type == OP_METHOD_NAMED
1169 || kid->op_type == OP_METHOD)
1173 NewOp(1101, newop, 1, UNOP);
1174 newop->op_type = OP_RV2CV;
1175 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1176 newop->op_first = NULL;
1177 newop->op_next = (OP*)newop;
1178 kid->op_sibling = (OP*)newop;
1179 newop->op_private |= OPpLVAL_INTRO;
1180 newop->op_private &= ~1;
1184 if (kid->op_type != OP_RV2CV)
1186 "panic: unexpected lvalue entersub "
1187 "entry via type/targ %ld:%"UVuf,
1188 (long)kid->op_type, (UV)kid->op_targ);
1189 kid->op_private |= OPpLVAL_INTRO;
1190 break; /* Postpone until runtime */
1194 kid = kUNOP->op_first;
1195 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1196 kid = kUNOP->op_first;
1197 if (kid->op_type == OP_NULL)
1199 "Unexpected constant lvalue entersub "
1200 "entry via type/targ %ld:%"UVuf,
1201 (long)kid->op_type, (UV)kid->op_targ);
1202 if (kid->op_type != OP_GV) {
1203 /* Restore RV2CV to check lvalueness */
1205 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1206 okid->op_next = kid->op_next;
1207 kid->op_next = okid;
1210 okid->op_next = NULL;
1211 okid->op_type = OP_RV2CV;
1213 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1214 okid->op_private |= OPpLVAL_INTRO;
1215 okid->op_private &= ~1;
1219 cv = GvCV(kGVOP_gv);
1229 /* grep, foreach, subcalls, refgen */
1230 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1232 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1233 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1235 : (o->op_type == OP_ENTERSUB
1236 ? "non-lvalue subroutine call"
1238 type ? PL_op_desc[type] : "local"));
1252 case OP_RIGHT_SHIFT:
1261 if (!(o->op_flags & OPf_STACKED))
1268 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1274 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1275 PL_modcount = RETURN_UNLIMITED_NUMBER;
1276 return o; /* Treat \(@foo) like ordinary list. */
1280 if (scalar_mod_type(o, type))
1282 ref(cUNOPo->op_first, o->op_type);
1286 if (type == OP_LEAVESUBLV)
1287 o->op_private |= OPpMAYBE_LVSUB;
1293 PL_modcount = RETURN_UNLIMITED_NUMBER;
1296 ref(cUNOPo->op_first, o->op_type);
1301 PL_hints |= HINT_BLOCK_SCOPE;
1316 PL_modcount = RETURN_UNLIMITED_NUMBER;
1317 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1318 return o; /* Treat \(@foo) like ordinary list. */
1319 if (scalar_mod_type(o, type))
1321 if (type == OP_LEAVESUBLV)
1322 o->op_private |= OPpMAYBE_LVSUB;
1326 if (!type) /* local() */
1327 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1328 PAD_COMPNAME_PV(o->op_targ));
1336 if (type != OP_SASSIGN)
1340 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1345 if (type == OP_LEAVESUBLV)
1346 o->op_private |= OPpMAYBE_LVSUB;
1348 pad_free(o->op_targ);
1349 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1350 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1351 if (o->op_flags & OPf_KIDS)
1352 mod(cBINOPo->op_first->op_sibling, type);
1357 ref(cBINOPo->op_first, o->op_type);
1358 if (type == OP_ENTERSUB &&
1359 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1360 o->op_private |= OPpLVAL_DEFER;
1361 if (type == OP_LEAVESUBLV)
1362 o->op_private |= OPpMAYBE_LVSUB;
1372 if (o->op_flags & OPf_KIDS)
1373 mod(cLISTOPo->op_last, type);
1378 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1380 else if (!(o->op_flags & OPf_KIDS))
1382 if (o->op_targ != OP_LIST) {
1383 mod(cBINOPo->op_first, type);
1389 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1394 if (type != OP_LEAVESUBLV)
1396 break; /* mod()ing was handled by ck_return() */
1399 /* [20011101.069] File test operators interpret OPf_REF to mean that
1400 their argument is a filehandle; thus \stat(".") should not set
1402 if (type == OP_REFGEN &&
1403 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1406 if (type != OP_LEAVESUBLV)
1407 o->op_flags |= OPf_MOD;
1409 if (type == OP_AASSIGN || type == OP_SASSIGN)
1410 o->op_flags |= OPf_SPECIAL|OPf_REF;
1411 else if (!type) { /* local() */
1414 o->op_private |= OPpLVAL_INTRO;
1415 o->op_flags &= ~OPf_SPECIAL;
1416 PL_hints |= HINT_BLOCK_SCOPE;
1421 if (ckWARN(WARN_SYNTAX)) {
1422 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1423 "Useless localization of %s", OP_DESC(o));
1427 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1428 && type != OP_LEAVESUBLV)
1429 o->op_flags |= OPf_REF;
1434 S_scalar_mod_type(const OP *o, I32 type)
1438 if (o->op_type == OP_RV2GV)
1462 case OP_RIGHT_SHIFT:
1481 S_is_handle_constructor(const OP *o, I32 numargs)
1483 switch (o->op_type) {
1491 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1504 Perl_refkids(pTHX_ OP *o, I32 type)
1506 if (o && o->op_flags & OPf_KIDS) {
1508 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1515 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1520 if (!o || PL_error_count)
1523 switch (o->op_type) {
1525 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1526 !(o->op_flags & OPf_STACKED)) {
1527 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1528 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1529 assert(cUNOPo->op_first->op_type == OP_NULL);
1530 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1531 o->op_flags |= OPf_SPECIAL;
1532 o->op_private &= ~1;
1537 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1538 doref(kid, type, set_op_ref);
1541 if (type == OP_DEFINED)
1542 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1543 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1546 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1547 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1548 : type == OP_RV2HV ? OPpDEREF_HV
1550 o->op_flags |= OPf_MOD;
1555 o->op_flags |= OPf_MOD; /* XXX ??? */
1561 o->op_flags |= OPf_REF;
1564 if (type == OP_DEFINED)
1565 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1566 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1572 o->op_flags |= OPf_REF;
1577 if (!(o->op_flags & OPf_KIDS))
1579 doref(cBINOPo->op_first, type, set_op_ref);
1583 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1584 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1585 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1586 : type == OP_RV2HV ? OPpDEREF_HV
1588 o->op_flags |= OPf_MOD;
1598 if (!(o->op_flags & OPf_KIDS))
1600 doref(cLISTOPo->op_last, type, set_op_ref);
1610 S_dup_attrlist(pTHX_ OP *o)
1615 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1616 * where the first kid is OP_PUSHMARK and the remaining ones
1617 * are OP_CONST. We need to push the OP_CONST values.
1619 if (o->op_type == OP_CONST)
1620 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1622 else if (o->op_type == OP_NULL)
1626 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1628 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1629 if (o->op_type == OP_CONST)
1630 rop = append_elem(OP_LIST, rop,
1631 newSVOP(OP_CONST, o->op_flags,
1632 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1639 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1644 /* fake up C<use attributes $pkg,$rv,@attrs> */
1645 ENTER; /* need to protect against side-effects of 'use' */
1647 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1649 #define ATTRSMODULE "attributes"
1650 #define ATTRSMODULE_PM "attributes.pm"
1653 /* Don't force the C<use> if we don't need it. */
1654 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1655 if (svp && *svp != &PL_sv_undef)
1656 NOOP; /* already in %INC */
1658 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1659 newSVpvs(ATTRSMODULE), NULL);
1662 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1663 newSVpvs(ATTRSMODULE),
1665 prepend_elem(OP_LIST,
1666 newSVOP(OP_CONST, 0, stashsv),
1667 prepend_elem(OP_LIST,
1668 newSVOP(OP_CONST, 0,
1670 dup_attrlist(attrs))));
1676 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1679 OP *pack, *imop, *arg;
1685 assert(target->op_type == OP_PADSV ||
1686 target->op_type == OP_PADHV ||
1687 target->op_type == OP_PADAV);
1689 /* Ensure that attributes.pm is loaded. */
1690 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1692 /* Need package name for method call. */
1693 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1695 /* Build up the real arg-list. */
1696 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1698 arg = newOP(OP_PADSV, 0);
1699 arg->op_targ = target->op_targ;
1700 arg = prepend_elem(OP_LIST,
1701 newSVOP(OP_CONST, 0, stashsv),
1702 prepend_elem(OP_LIST,
1703 newUNOP(OP_REFGEN, 0,
1704 mod(arg, OP_REFGEN)),
1705 dup_attrlist(attrs)));
1707 /* Fake up a method call to import */
1708 meth = newSVpvs_share("import");
1709 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1710 append_elem(OP_LIST,
1711 prepend_elem(OP_LIST, pack, list(arg)),
1712 newSVOP(OP_METHOD_NAMED, 0, meth)));
1713 imop->op_private |= OPpENTERSUB_NOMOD;
1715 /* Combine the ops. */
1716 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1720 =notfor apidoc apply_attrs_string
1722 Attempts to apply a list of attributes specified by the C<attrstr> and
1723 C<len> arguments to the subroutine identified by the C<cv> argument which
1724 is expected to be associated with the package identified by the C<stashpv>
1725 argument (see L<attributes>). It gets this wrong, though, in that it
1726 does not correctly identify the boundaries of the individual attribute
1727 specifications within C<attrstr>. This is not really intended for the
1728 public API, but has to be listed here for systems such as AIX which
1729 need an explicit export list for symbols. (It's called from XS code
1730 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1731 to respect attribute syntax properly would be welcome.
1737 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1738 const char *attrstr, STRLEN len)
1743 len = strlen(attrstr);
1747 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1749 const char * const sstr = attrstr;
1750 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1751 attrs = append_elem(OP_LIST, attrs,
1752 newSVOP(OP_CONST, 0,
1753 newSVpvn(sstr, attrstr-sstr)));
1757 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1758 newSVpvs(ATTRSMODULE),
1759 NULL, prepend_elem(OP_LIST,
1760 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1761 prepend_elem(OP_LIST,
1762 newSVOP(OP_CONST, 0,
1768 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1773 if (!o || PL_error_count)
1777 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1778 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1782 if (type == OP_LIST) {
1784 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1785 my_kid(kid, attrs, imopsp);
1786 } else if (type == OP_UNDEF
1792 } else if (type == OP_RV2SV || /* "our" declaration */
1794 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1795 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1796 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1797 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1799 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1801 PL_in_my_stash = NULL;
1802 apply_attrs(GvSTASH(gv),
1803 (type == OP_RV2SV ? GvSV(gv) :
1804 type == OP_RV2AV ? (SV*)GvAV(gv) :
1805 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1808 o->op_private |= OPpOUR_INTRO;
1811 else if (type != OP_PADSV &&
1814 type != OP_PUSHMARK)
1816 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1818 PL_in_my == KEY_our ? "our" : "my"));
1821 else if (attrs && type != OP_PUSHMARK) {
1825 PL_in_my_stash = NULL;
1827 /* check for C<my Dog $spot> when deciding package */
1828 stash = PAD_COMPNAME_TYPE(o->op_targ);
1830 stash = PL_curstash;
1831 apply_attrs_my(stash, o, attrs, imopsp);
1833 o->op_flags |= OPf_MOD;
1834 o->op_private |= OPpLVAL_INTRO;
1839 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1843 int maybe_scalar = 0;
1845 /* [perl #17376]: this appears to be premature, and results in code such as
1846 C< our(%x); > executing in list mode rather than void mode */
1848 if (o->op_flags & OPf_PARENS)
1858 o = my_kid(o, attrs, &rops);
1860 if (maybe_scalar && o->op_type == OP_PADSV) {
1861 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1862 o->op_private |= OPpLVAL_INTRO;
1865 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1868 PL_in_my_stash = NULL;
1873 Perl_my(pTHX_ OP *o)
1875 return my_attrs(o, NULL);
1879 Perl_sawparens(pTHX_ OP *o)
1881 PERL_UNUSED_CONTEXT;
1883 o->op_flags |= OPf_PARENS;
1888 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1892 const OPCODE ltype = left->op_type;
1893 const OPCODE rtype = right->op_type;
1895 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1896 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
1898 const char * const desc
1899 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1900 ? rtype : OP_MATCH];
1901 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1902 ? "@array" : "%hash");
1903 Perl_warner(aTHX_ packWARN(WARN_MISC),
1904 "Applying %s to %s will act on scalar(%s)",
1905 desc, sample, sample);
1908 if (rtype == OP_CONST &&
1909 cSVOPx(right)->op_private & OPpCONST_BARE &&
1910 cSVOPx(right)->op_private & OPpCONST_STRICT)
1912 no_bareword_allowed(right);
1915 ismatchop = rtype == OP_MATCH ||
1916 rtype == OP_SUBST ||
1918 if (ismatchop && right->op_private & OPpTARGET_MY) {
1920 right->op_private &= ~OPpTARGET_MY;
1922 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1925 right->op_flags |= OPf_STACKED;
1926 if (rtype != OP_MATCH &&
1927 ! (rtype == OP_TRANS &&
1928 right->op_private & OPpTRANS_IDENTICAL))
1929 newleft = mod(left, rtype);
1932 if (right->op_type == OP_TRANS)
1933 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
1935 o = prepend_elem(rtype, scalar(newleft), right);
1937 return newUNOP(OP_NOT, 0, scalar(o));
1941 return bind_match(type, left,
1942 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1946 Perl_invert(pTHX_ OP *o)
1950 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1954 Perl_scope(pTHX_ OP *o)
1958 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1959 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1960 o->op_type = OP_LEAVE;
1961 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1963 else if (o->op_type == OP_LINESEQ) {
1965 o->op_type = OP_SCOPE;
1966 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1967 kid = ((LISTOP*)o)->op_first;
1968 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1971 /* The following deals with things like 'do {1 for 1}' */
1972 kid = kid->op_sibling;
1974 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1979 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1985 Perl_block_start(pTHX_ int full)
1988 const int retval = PL_savestack_ix;
1989 pad_block_start(full);
1991 PL_hints &= ~HINT_BLOCK_SCOPE;
1992 SAVECOMPILEWARNINGS();
1993 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1994 SAVESPTR(PL_compiling.cop_io);
1995 if (! specialCopIO(PL_compiling.cop_io)) {
1996 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1997 SAVEFREESV(PL_compiling.cop_io) ;
2003 Perl_block_end(pTHX_ I32 floor, OP *seq)
2006 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2007 OP* const retval = scalarseq(seq);
2009 CopHINTS_set(&PL_compiling, PL_hints);
2011 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2020 const PADOFFSET offset = pad_findmy("$_");
2021 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2022 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2025 OP * const o = newOP(OP_PADSV, 0);
2026 o->op_targ = offset;
2032 Perl_newPROG(pTHX_ OP *o)
2038 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2039 ((PL_in_eval & EVAL_KEEPERR)
2040 ? OPf_SPECIAL : 0), o);
2041 PL_eval_start = linklist(PL_eval_root);
2042 PL_eval_root->op_private |= OPpREFCOUNTED;
2043 OpREFCNT_set(PL_eval_root, 1);
2044 PL_eval_root->op_next = 0;
2045 CALL_PEEP(PL_eval_start);
2048 if (o->op_type == OP_STUB) {
2049 PL_comppad_name = 0;
2054 PL_main_root = scope(sawparens(scalarvoid(o)));
2055 PL_curcop = &PL_compiling;
2056 PL_main_start = LINKLIST(PL_main_root);
2057 PL_main_root->op_private |= OPpREFCOUNTED;
2058 OpREFCNT_set(PL_main_root, 1);
2059 PL_main_root->op_next = 0;
2060 CALL_PEEP(PL_main_start);
2063 /* Register with debugger */
2065 CV * const cv = get_cv("DB::postponed", FALSE);
2069 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2071 call_sv((SV*)cv, G_DISCARD);
2078 Perl_localize(pTHX_ OP *o, I32 lex)
2081 if (o->op_flags & OPf_PARENS)
2082 /* [perl #17376]: this appears to be premature, and results in code such as
2083 C< our(%x); > executing in list mode rather than void mode */
2090 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2091 && ckWARN(WARN_PARENTHESIS))
2093 char *s = PL_bufptr;
2096 /* some heuristics to detect a potential error */
2097 while (*s && (strchr(", \t\n", *s)))
2101 if (*s && strchr("@$%*", *s) && *++s
2102 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2105 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2107 while (*s && (strchr(", \t\n", *s)))
2113 if (sigil && (*s == ';' || *s == '=')) {
2114 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2115 "Parentheses missing around \"%s\" list",
2116 lex ? (PL_in_my == KEY_our ? "our" : "my")
2124 o = mod(o, OP_NULL); /* a bit kludgey */
2126 PL_in_my_stash = NULL;
2131 Perl_jmaybe(pTHX_ OP *o)
2133 if (o->op_type == OP_LIST) {
2135 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2136 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2142 Perl_fold_constants(pTHX_ register OP *o)
2147 I32 type = o->op_type;
2154 if (PL_opargs[type] & OA_RETSCALAR)
2156 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2157 o->op_targ = pad_alloc(type, SVs_PADTMP);
2159 /* integerize op, unless it happens to be C<-foo>.
2160 * XXX should pp_i_negate() do magic string negation instead? */
2161 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2162 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2163 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2165 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2168 if (!(PL_opargs[type] & OA_FOLDCONST))
2173 /* XXX might want a ck_negate() for this */
2174 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2185 /* XXX what about the numeric ops? */
2186 if (PL_hints & HINT_LOCALE)
2191 goto nope; /* Don't try to run w/ errors */
2193 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2194 const OPCODE type = curop->op_type;
2195 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2197 type != OP_SCALAR &&
2199 type != OP_PUSHMARK)
2205 curop = LINKLIST(o);
2206 old_next = o->op_next;
2210 oldscope = PL_scopestack_ix;
2211 create_eval_scope(G_FAKINGEVAL);
2218 sv = *(PL_stack_sp--);
2219 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2220 pad_swipe(o->op_targ, FALSE);
2221 else if (SvTEMP(sv)) { /* grab mortal temp? */
2222 SvREFCNT_inc_simple_void(sv);
2227 /* Something tried to die. Abandon constant folding. */
2228 /* Pretend the error never happened. */
2229 sv_setpvn(ERRSV,"",0);
2230 o->op_next = old_next;
2234 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2235 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2240 if (PL_scopestack_ix > oldscope)
2241 delete_eval_scope();
2250 if (type == OP_RV2GV)
2251 newop = newGVOP(OP_GV, 0, (GV*)sv);
2253 newop = newSVOP(OP_CONST, 0, sv);
2254 op_getmad(o,newop,'f');
2262 Perl_gen_constant_list(pTHX_ register OP *o)
2266 const I32 oldtmps_floor = PL_tmps_floor;
2270 return o; /* Don't attempt to run with errors */
2272 PL_op = curop = LINKLIST(o);
2279 PL_tmps_floor = oldtmps_floor;
2281 o->op_type = OP_RV2AV;
2282 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2283 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2284 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2285 o->op_opt = 0; /* needs to be revisited in peep() */
2286 curop = ((UNOP*)o)->op_first;
2287 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2289 op_getmad(curop,o,'O');
2298 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2301 if (!o || o->op_type != OP_LIST)
2302 o = newLISTOP(OP_LIST, 0, o, NULL);
2304 o->op_flags &= ~OPf_WANT;
2306 if (!(PL_opargs[type] & OA_MARK))
2307 op_null(cLISTOPo->op_first);
2309 o->op_type = (OPCODE)type;
2310 o->op_ppaddr = PL_ppaddr[type];
2311 o->op_flags |= flags;
2313 o = CHECKOP(type, o);
2314 if (o->op_type != (unsigned)type)
2317 return fold_constants(o);
2320 /* List constructors */
2323 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2331 if (first->op_type != (unsigned)type
2332 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2334 return newLISTOP(type, 0, first, last);
2337 if (first->op_flags & OPf_KIDS)
2338 ((LISTOP*)first)->op_last->op_sibling = last;
2340 first->op_flags |= OPf_KIDS;
2341 ((LISTOP*)first)->op_first = last;
2343 ((LISTOP*)first)->op_last = last;
2348 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2356 if (first->op_type != (unsigned)type)
2357 return prepend_elem(type, (OP*)first, (OP*)last);
2359 if (last->op_type != (unsigned)type)
2360 return append_elem(type, (OP*)first, (OP*)last);
2362 first->op_last->op_sibling = last->op_first;
2363 first->op_last = last->op_last;
2364 first->op_flags |= (last->op_flags & OPf_KIDS);
2367 if (last->op_first && first->op_madprop) {
2368 MADPROP *mp = last->op_first->op_madprop;
2370 while (mp->mad_next)
2372 mp->mad_next = first->op_madprop;
2375 last->op_first->op_madprop = first->op_madprop;
2378 first->op_madprop = last->op_madprop;
2379 last->op_madprop = 0;
2388 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2396 if (last->op_type == (unsigned)type) {
2397 if (type == OP_LIST) { /* already a PUSHMARK there */
2398 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2399 ((LISTOP*)last)->op_first->op_sibling = first;
2400 if (!(first->op_flags & OPf_PARENS))
2401 last->op_flags &= ~OPf_PARENS;
2404 if (!(last->op_flags & OPf_KIDS)) {
2405 ((LISTOP*)last)->op_last = first;
2406 last->op_flags |= OPf_KIDS;
2408 first->op_sibling = ((LISTOP*)last)->op_first;
2409 ((LISTOP*)last)->op_first = first;
2411 last->op_flags |= OPf_KIDS;
2415 return newLISTOP(type, 0, first, last);
2423 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2426 Newxz(tk, 1, TOKEN);
2427 tk->tk_type = (OPCODE)optype;
2428 tk->tk_type = 12345;
2430 tk->tk_mad = madprop;
2435 Perl_token_free(pTHX_ TOKEN* tk)
2437 if (tk->tk_type != 12345)
2439 mad_free(tk->tk_mad);
2444 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2448 if (tk->tk_type != 12345) {
2449 Perl_warner(aTHX_ packWARN(WARN_MISC),
2450 "Invalid TOKEN object ignored");
2457 /* faked up qw list? */
2459 tm->mad_type == MAD_SV &&
2460 SvPVX((SV*)tm->mad_val)[0] == 'q')
2467 /* pretend constant fold didn't happen? */
2468 if (mp->mad_key == 'f' &&
2469 (o->op_type == OP_CONST ||
2470 o->op_type == OP_GV) )
2472 token_getmad(tk,(OP*)mp->mad_val,slot);
2486 if (mp->mad_key == 'X')
2487 mp->mad_key = slot; /* just change the first one */
2497 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2506 /* pretend constant fold didn't happen? */
2507 if (mp->mad_key == 'f' &&
2508 (o->op_type == OP_CONST ||
2509 o->op_type == OP_GV) )
2511 op_getmad(from,(OP*)mp->mad_val,slot);
2518 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2521 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2527 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2536 /* pretend constant fold didn't happen? */
2537 if (mp->mad_key == 'f' &&
2538 (o->op_type == OP_CONST ||
2539 o->op_type == OP_GV) )
2541 op_getmad(from,(OP*)mp->mad_val,slot);
2548 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2551 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2555 PerlIO_printf(PerlIO_stderr(),
2556 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2562 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2580 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2584 addmad(tm, &(o->op_madprop), slot);
2588 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2609 Perl_newMADsv(pTHX_ char key, SV* sv)
2611 return newMADPROP(key, MAD_SV, sv, 0);
2615 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2618 Newxz(mp, 1, MADPROP);
2621 mp->mad_vlen = vlen;
2622 mp->mad_type = type;
2624 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2629 Perl_mad_free(pTHX_ MADPROP* mp)
2631 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2635 mad_free(mp->mad_next);
2636 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2637 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2638 switch (mp->mad_type) {
2642 Safefree((char*)mp->mad_val);
2645 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2646 op_free((OP*)mp->mad_val);
2649 sv_free((SV*)mp->mad_val);
2652 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2661 Perl_newNULLLIST(pTHX)
2663 return newOP(OP_STUB, 0);
2667 Perl_force_list(pTHX_ OP *o)
2669 if (!o || o->op_type != OP_LIST)
2670 o = newLISTOP(OP_LIST, 0, o, NULL);
2676 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2681 NewOp(1101, listop, 1, LISTOP);
2683 listop->op_type = (OPCODE)type;
2684 listop->op_ppaddr = PL_ppaddr[type];
2687 listop->op_flags = (U8)flags;
2691 else if (!first && last)
2694 first->op_sibling = last;
2695 listop->op_first = first;
2696 listop->op_last = last;
2697 if (type == OP_LIST) {
2698 OP* const pushop = newOP(OP_PUSHMARK, 0);
2699 pushop->op_sibling = first;
2700 listop->op_first = pushop;
2701 listop->op_flags |= OPf_KIDS;
2703 listop->op_last = pushop;
2706 return CHECKOP(type, listop);
2710 Perl_newOP(pTHX_ I32 type, I32 flags)
2714 NewOp(1101, o, 1, OP);
2715 o->op_type = (OPCODE)type;
2716 o->op_ppaddr = PL_ppaddr[type];
2717 o->op_flags = (U8)flags;
2720 o->op_private = (U8)(0 | (flags >> 8));
2721 if (PL_opargs[type] & OA_RETSCALAR)
2723 if (PL_opargs[type] & OA_TARGET)
2724 o->op_targ = pad_alloc(type, SVs_PADTMP);
2725 return CHECKOP(type, o);
2729 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2735 first = newOP(OP_STUB, 0);
2736 if (PL_opargs[type] & OA_MARK)
2737 first = force_list(first);
2739 NewOp(1101, unop, 1, UNOP);
2740 unop->op_type = (OPCODE)type;
2741 unop->op_ppaddr = PL_ppaddr[type];
2742 unop->op_first = first;
2743 unop->op_flags = (U8)(flags | OPf_KIDS);
2744 unop->op_private = (U8)(1 | (flags >> 8));
2745 unop = (UNOP*) CHECKOP(type, unop);
2749 return fold_constants((OP *) unop);
2753 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2757 NewOp(1101, binop, 1, BINOP);
2760 first = newOP(OP_NULL, 0);
2762 binop->op_type = (OPCODE)type;
2763 binop->op_ppaddr = PL_ppaddr[type];
2764 binop->op_first = first;
2765 binop->op_flags = (U8)(flags | OPf_KIDS);
2768 binop->op_private = (U8)(1 | (flags >> 8));
2771 binop->op_private = (U8)(2 | (flags >> 8));
2772 first->op_sibling = last;
2775 binop = (BINOP*)CHECKOP(type, binop);
2776 if (binop->op_next || binop->op_type != (OPCODE)type)
2779 binop->op_last = binop->op_first->op_sibling;
2781 return fold_constants((OP *)binop);
2784 static int uvcompare(const void *a, const void *b)
2785 __attribute__nonnull__(1)
2786 __attribute__nonnull__(2)
2787 __attribute__pure__;
2788 static int uvcompare(const void *a, const void *b)
2790 if (*((const UV *)a) < (*(const UV *)b))
2792 if (*((const UV *)a) > (*(const UV *)b))
2794 if (*((const UV *)a+1) < (*(const UV *)b+1))
2796 if (*((const UV *)a+1) > (*(const UV *)b+1))
2802 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2805 SV * const tstr = ((SVOP*)expr)->op_sv;
2806 SV * const rstr = ((SVOP*)repl)->op_sv;
2809 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2810 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2814 register short *tbl;
2816 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2817 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2818 I32 del = o->op_private & OPpTRANS_DELETE;
2819 PL_hints |= HINT_BLOCK_SCOPE;
2822 o->op_private |= OPpTRANS_FROM_UTF;
2825 o->op_private |= OPpTRANS_TO_UTF;
2827 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2828 SV* const listsv = newSVpvs("# comment\n");
2830 const U8* tend = t + tlen;
2831 const U8* rend = r + rlen;
2845 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2846 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2849 const U32 flags = UTF8_ALLOW_DEFAULT;
2853 t = tsave = bytes_to_utf8(t, &len);
2856 if (!to_utf && rlen) {
2858 r = rsave = bytes_to_utf8(r, &len);
2862 /* There are several snags with this code on EBCDIC:
2863 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2864 2. scan_const() in toke.c has encoded chars in native encoding which makes
2865 ranges at least in EBCDIC 0..255 range the bottom odd.
2869 U8 tmpbuf[UTF8_MAXBYTES+1];
2872 Newx(cp, 2*tlen, UV);
2874 transv = newSVpvs("");
2876 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2878 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2880 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2884 cp[2*i+1] = cp[2*i];
2888 qsort(cp, i, 2*sizeof(UV), uvcompare);
2889 for (j = 0; j < i; j++) {
2891 diff = val - nextmin;
2893 t = uvuni_to_utf8(tmpbuf,nextmin);
2894 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2896 U8 range_mark = UTF_TO_NATIVE(0xff);
2897 t = uvuni_to_utf8(tmpbuf, val - 1);
2898 sv_catpvn(transv, (char *)&range_mark, 1);
2899 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2906 t = uvuni_to_utf8(tmpbuf,nextmin);
2907 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2909 U8 range_mark = UTF_TO_NATIVE(0xff);
2910 sv_catpvn(transv, (char *)&range_mark, 1);
2912 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2913 UNICODE_ALLOW_SUPER);
2914 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2915 t = (const U8*)SvPVX_const(transv);
2916 tlen = SvCUR(transv);
2920 else if (!rlen && !del) {
2921 r = t; rlen = tlen; rend = tend;
2924 if ((!rlen && !del) || t == r ||
2925 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2927 o->op_private |= OPpTRANS_IDENTICAL;
2931 while (t < tend || tfirst <= tlast) {
2932 /* see if we need more "t" chars */
2933 if (tfirst > tlast) {
2934 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2936 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2938 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2945 /* now see if we need more "r" chars */
2946 if (rfirst > rlast) {
2948 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2950 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2952 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2961 rfirst = rlast = 0xffffffff;
2965 /* now see which range will peter our first, if either. */
2966 tdiff = tlast - tfirst;
2967 rdiff = rlast - rfirst;
2974 if (rfirst == 0xffffffff) {
2975 diff = tdiff; /* oops, pretend rdiff is infinite */
2977 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2978 (long)tfirst, (long)tlast);
2980 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2984 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2985 (long)tfirst, (long)(tfirst + diff),
2988 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2989 (long)tfirst, (long)rfirst);
2991 if (rfirst + diff > max)
2992 max = rfirst + diff;
2994 grows = (tfirst < rfirst &&
2995 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3007 else if (max > 0xff)
3012 Safefree(cPVOPo->op_pv);
3013 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3014 SvREFCNT_dec(listsv);
3015 SvREFCNT_dec(transv);
3017 if (!del && havefinal && rlen)
3018 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3019 newSVuv((UV)final), 0);
3022 o->op_private |= OPpTRANS_GROWS;
3028 op_getmad(expr,o,'e');
3029 op_getmad(repl,o,'r');
3037 tbl = (short*)cPVOPo->op_pv;
3039 Zero(tbl, 256, short);
3040 for (i = 0; i < (I32)tlen; i++)
3042 for (i = 0, j = 0; i < 256; i++) {
3044 if (j >= (I32)rlen) {
3053 if (i < 128 && r[j] >= 128)
3063 o->op_private |= OPpTRANS_IDENTICAL;
3065 else if (j >= (I32)rlen)
3068 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3069 tbl[0x100] = (short)(rlen - j);
3070 for (i=0; i < (I32)rlen - j; i++)
3071 tbl[0x101+i] = r[j+i];
3075 if (!rlen && !del) {
3078 o->op_private |= OPpTRANS_IDENTICAL;
3080 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3081 o->op_private |= OPpTRANS_IDENTICAL;
3083 for (i = 0; i < 256; i++)
3085 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3086 if (j >= (I32)rlen) {
3088 if (tbl[t[i]] == -1)
3094 if (tbl[t[i]] == -1) {
3095 if (t[i] < 128 && r[j] >= 128)
3102 o->op_private |= OPpTRANS_GROWS;
3104 op_getmad(expr,o,'e');
3105 op_getmad(repl,o,'r');
3115 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3120 NewOp(1101, pmop, 1, PMOP);
3121 pmop->op_type = (OPCODE)type;
3122 pmop->op_ppaddr = PL_ppaddr[type];
3123 pmop->op_flags = (U8)flags;
3124 pmop->op_private = (U8)(0 | (flags >> 8));
3126 if (PL_hints & HINT_RE_TAINT)
3127 pmop->op_pmpermflags |= PMf_RETAINT;
3128 if (PL_hints & HINT_LOCALE)
3129 pmop->op_pmpermflags |= PMf_LOCALE;
3130 pmop->op_pmflags = pmop->op_pmpermflags;
3133 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3134 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3135 pmop->op_pmoffset = SvIV(repointer);
3136 SvREPADTMP_off(repointer);
3137 sv_setiv(repointer,0);
3139 SV * const repointer = newSViv(0);
3140 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3141 pmop->op_pmoffset = av_len(PL_regex_padav);
3142 PL_regex_pad = AvARRAY(PL_regex_padav);
3146 /* link into pm list */
3147 if (type != OP_TRANS && PL_curstash) {
3148 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3151 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3153 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3154 mg->mg_obj = (SV*)pmop;
3155 PmopSTASH_set(pmop,PL_curstash);
3158 return CHECKOP(type, pmop);
3161 /* Given some sort of match op o, and an expression expr containing a
3162 * pattern, either compile expr into a regex and attach it to o (if it's
3163 * constant), or convert expr into a runtime regcomp op sequence (if it's
3166 * isreg indicates that the pattern is part of a regex construct, eg
3167 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3168 * split "pattern", which aren't. In the former case, expr will be a list
3169 * if the pattern contains more than one term (eg /a$b/) or if it contains
3170 * a replacement, ie s/// or tr///.
3174 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3179 I32 repl_has_vars = 0;
3183 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3184 /* last element in list is the replacement; pop it */
3186 repl = cLISTOPx(expr)->op_last;
3187 kid = cLISTOPx(expr)->op_first;
3188 while (kid->op_sibling != repl)
3189 kid = kid->op_sibling;
3190 kid->op_sibling = NULL;
3191 cLISTOPx(expr)->op_last = kid;
3194 if (isreg && expr->op_type == OP_LIST &&
3195 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3197 /* convert single element list to element */
3198 OP* const oe = expr;
3199 expr = cLISTOPx(oe)->op_first->op_sibling;
3200 cLISTOPx(oe)->op_first->op_sibling = NULL;
3201 cLISTOPx(oe)->op_last = NULL;
3205 if (o->op_type == OP_TRANS) {
3206 return pmtrans(o, expr, repl);
3209 reglist = isreg && expr->op_type == OP_LIST;
3213 PL_hints |= HINT_BLOCK_SCOPE;
3216 if (expr->op_type == OP_CONST) {
3218 SV * const pat = ((SVOP*)expr)->op_sv;
3219 const char *p = SvPV_const(pat, plen);
3220 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3221 U32 was_readonly = SvREADONLY(pat);
3225 sv_force_normal_flags(pat, 0);
3226 assert(!SvREADONLY(pat));
3229 SvREADONLY_off(pat);
3233 sv_setpvn(pat, "\\s+", 3);
3235 SvFLAGS(pat) |= was_readonly;
3237 p = SvPV_const(pat, plen);
3238 pm->op_pmflags |= PMf_SKIPWHITE;
3241 pm->op_pmdynflags |= PMdf_UTF8;
3242 /* FIXME - can we make this function take const char * args? */
3243 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3244 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3245 pm->op_pmflags |= PMf_WHITE;
3247 op_getmad(expr,(OP*)pm,'e');
3253 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3254 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3256 : OP_REGCMAYBE),0,expr);
3258 NewOp(1101, rcop, 1, LOGOP);
3259 rcop->op_type = OP_REGCOMP;
3260 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3261 rcop->op_first = scalar(expr);
3262 rcop->op_flags |= OPf_KIDS
3263 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3264 | (reglist ? OPf_STACKED : 0);
3265 rcop->op_private = 1;
3268 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3270 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3273 /* establish postfix order */
3274 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3276 rcop->op_next = expr;
3277 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3280 rcop->op_next = LINKLIST(expr);
3281 expr->op_next = (OP*)rcop;
3284 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3289 if (pm->op_pmflags & PMf_EVAL) {
3291 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3292 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3294 else if (repl->op_type == OP_CONST)
3298 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3299 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3300 if (curop->op_type == OP_GV) {
3301 GV * const gv = cGVOPx_gv(curop);
3303 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3306 else if (curop->op_type == OP_RV2CV)
3308 else if (curop->op_type == OP_RV2SV ||
3309 curop->op_type == OP_RV2AV ||
3310 curop->op_type == OP_RV2HV ||
3311 curop->op_type == OP_RV2GV) {
3312 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3315 else if (curop->op_type == OP_PADSV ||
3316 curop->op_type == OP_PADAV ||
3317 curop->op_type == OP_PADHV ||
3318 curop->op_type == OP_PADANY) {
3321 else if (curop->op_type == OP_PUSHRE)
3322 NOOP; /* Okay here, dangerous in newASSIGNOP */
3332 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3333 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3334 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3335 prepend_elem(o->op_type, scalar(repl), o);
3338 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3339 pm->op_pmflags |= PMf_MAYBE_CONST;
3340 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3342 NewOp(1101, rcop, 1, LOGOP);
3343 rcop->op_type = OP_SUBSTCONT;
3344 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3345 rcop->op_first = scalar(repl);
3346 rcop->op_flags |= OPf_KIDS;
3347 rcop->op_private = 1;
3350 /* establish postfix order */
3351 rcop->op_next = LINKLIST(repl);
3352 repl->op_next = (OP*)rcop;
3354 pm->op_pmreplroot = scalar((OP*)rcop);
3355 pm->op_pmreplstart = LINKLIST(rcop);
3364 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3368 NewOp(1101, svop, 1, SVOP);
3369 svop->op_type = (OPCODE)type;
3370 svop->op_ppaddr = PL_ppaddr[type];
3372 svop->op_next = (OP*)svop;
3373 svop->op_flags = (U8)flags;
3374 if (PL_opargs[type] & OA_RETSCALAR)
3376 if (PL_opargs[type] & OA_TARGET)
3377 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3378 return CHECKOP(type, svop);
3382 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3386 NewOp(1101, padop, 1, PADOP);
3387 padop->op_type = (OPCODE)type;
3388 padop->op_ppaddr = PL_ppaddr[type];
3389 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3390 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3391 PAD_SETSV(padop->op_padix, sv);
3394 padop->op_next = (OP*)padop;
3395 padop->op_flags = (U8)flags;
3396 if (PL_opargs[type] & OA_RETSCALAR)
3398 if (PL_opargs[type] & OA_TARGET)
3399 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3400 return CHECKOP(type, padop);
3404 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3410 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3412 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3417 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3421 NewOp(1101, pvop, 1, PVOP);
3422 pvop->op_type = (OPCODE)type;
3423 pvop->op_ppaddr = PL_ppaddr[type];
3425 pvop->op_next = (OP*)pvop;
3426 pvop->op_flags = (U8)flags;
3427 if (PL_opargs[type] & OA_RETSCALAR)
3429 if (PL_opargs[type] & OA_TARGET)
3430 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3431 return CHECKOP(type, pvop);
3439 Perl_package(pTHX_ OP *o)
3448 save_hptr(&PL_curstash);
3449 save_item(PL_curstname);
3451 name = SvPV_const(cSVOPo->op_sv, len);
3452 PL_curstash = gv_stashpvn(name, len, TRUE);
3453 sv_setpvn(PL_curstname, name, len);
3455 PL_hints |= HINT_BLOCK_SCOPE;
3456 PL_copline = NOLINE;
3462 if (!PL_madskills) {
3467 pegop = newOP(OP_NULL,0);
3468 op_getmad(o,pegop,'P');
3478 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3485 OP *pegop = newOP(OP_NULL,0);
3488 if (idop->op_type != OP_CONST)
3489 Perl_croak(aTHX_ "Module name must be constant");
3492 op_getmad(idop,pegop,'U');
3497 SV * const vesv = ((SVOP*)version)->op_sv;
3500 op_getmad(version,pegop,'V');
3501 if (!arg && !SvNIOKp(vesv)) {
3508 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3509 Perl_croak(aTHX_ "Version number must be constant number");
3511 /* Make copy of idop so we don't free it twice */
3512 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3514 /* Fake up a method call to VERSION */
3515 meth = newSVpvs_share("VERSION");
3516 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3517 append_elem(OP_LIST,
3518 prepend_elem(OP_LIST, pack, list(version)),
3519 newSVOP(OP_METHOD_NAMED, 0, meth)));
3523 /* Fake up an import/unimport */
3524 if (arg && arg->op_type == OP_STUB) {
3526 op_getmad(arg,pegop,'S');
3527 imop = arg; /* no import on explicit () */
3529 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3530 imop = NULL; /* use 5.0; */
3532 idop->op_private |= OPpCONST_NOVER;
3538 op_getmad(arg,pegop,'A');
3540 /* Make copy of idop so we don't free it twice */
3541 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3543 /* Fake up a method call to import/unimport */
3545 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3546 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3547 append_elem(OP_LIST,
3548 prepend_elem(OP_LIST, pack, list(arg)),
3549 newSVOP(OP_METHOD_NAMED, 0, meth)));
3552 /* Fake up the BEGIN {}, which does its thing immediately. */
3554 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3557 append_elem(OP_LINESEQ,
3558 append_elem(OP_LINESEQ,
3559 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3560 newSTATEOP(0, NULL, veop)),
3561 newSTATEOP(0, NULL, imop) ));
3563 /* The "did you use incorrect case?" warning used to be here.
3564 * The problem is that on case-insensitive filesystems one
3565 * might get false positives for "use" (and "require"):
3566 * "use Strict" or "require CARP" will work. This causes
3567 * portability problems for the script: in case-strict
3568 * filesystems the script will stop working.
3570 * The "incorrect case" warning checked whether "use Foo"
3571 * imported "Foo" to your namespace, but that is wrong, too:
3572 * there is no requirement nor promise in the language that
3573 * a Foo.pm should or would contain anything in package "Foo".
3575 * There is very little Configure-wise that can be done, either:
3576 * the case-sensitivity of the build filesystem of Perl does not
3577 * help in guessing the case-sensitivity of the runtime environment.
3580 PL_hints |= HINT_BLOCK_SCOPE;
3581 PL_copline = NOLINE;
3583 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3586 if (!PL_madskills) {
3587 /* FIXME - don't allocate pegop if !PL_madskills */
3596 =head1 Embedding Functions
3598 =for apidoc load_module
3600 Loads the module whose name is pointed to by the string part of name.
3601 Note that the actual module name, not its filename, should be given.
3602 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3603 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3604 (or 0 for no flags). ver, if specified, provides version semantics
3605 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3606 arguments can be used to specify arguments to the module's import()
3607 method, similar to C<use Foo::Bar VERSION LIST>.
3612 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3615 va_start(args, ver);
3616 vload_module(flags, name, ver, &args);
3620 #ifdef PERL_IMPLICIT_CONTEXT
3622 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3626 va_start(args, ver);
3627 vload_module(flags, name, ver, &args);
3633 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3638 OP * const modname = newSVOP(OP_CONST, 0, name);
3639 modname->op_private |= OPpCONST_BARE;
3641 veop = newSVOP(OP_CONST, 0, ver);
3645 if (flags & PERL_LOADMOD_NOIMPORT) {
3646 imop = sawparens(newNULLLIST());
3648 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3649 imop = va_arg(*args, OP*);
3654 sv = va_arg(*args, SV*);
3656 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3657 sv = va_arg(*args, SV*);
3661 const line_t ocopline = PL_copline;
3662 COP * const ocurcop = PL_curcop;
3663 const int oexpect = PL_expect;
3665 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3666 veop, modname, imop);
3667 PL_expect = oexpect;
3668 PL_copline = ocopline;
3669 PL_curcop = ocurcop;
3674 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3680 if (!force_builtin) {
3681 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3682 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3683 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3684 gv = gvp ? *gvp : NULL;
3688 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3689 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3690 append_elem(OP_LIST, term,
3691 scalar(newUNOP(OP_RV2CV, 0,
3692 newGVOP(OP_GV, 0, gv))))));
3695 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3701 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3703 return newBINOP(OP_LSLICE, flags,
3704 list(force_list(subscript)),
3705 list(force_list(listval)) );
3709 S_is_list_assignment(pTHX_ register const OP *o)
3717 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3718 o = cUNOPo->op_first;
3720 flags = o->op_flags;
3722 if (type == OP_COND_EXPR) {
3723 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3724 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3729 yyerror("Assignment to both a list and a scalar");
3733 if (type == OP_LIST &&
3734 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3735 o->op_private & OPpLVAL_INTRO)
3738 if (type == OP_LIST || flags & OPf_PARENS ||
3739 type == OP_RV2AV || type == OP_RV2HV ||
3740 type == OP_ASLICE || type == OP_HSLICE)
3743 if (type == OP_PADAV || type == OP_PADHV)
3746 if (type == OP_RV2SV)
3753 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3759 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3760 return newLOGOP(optype, 0,
3761 mod(scalar(left), optype),
3762 newUNOP(OP_SASSIGN, 0, scalar(right)));
3765 return newBINOP(optype, OPf_STACKED,
3766 mod(scalar(left), optype), scalar(right));
3770 if (is_list_assignment(left)) {
3774 /* Grandfathering $[ assignment here. Bletch.*/
3775 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3776 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3777 left = mod(left, OP_AASSIGN);
3780 else if (left->op_type == OP_CONST) {
3782 /* Result of assignment is always 1 (or we'd be dead already) */
3783 return newSVOP(OP_CONST, 0, newSViv(1));
3785 curop = list(force_list(left));
3786 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3787 o->op_private = (U8)(0 | (flags >> 8));
3789 /* PL_generation sorcery:
3790 * an assignment like ($a,$b) = ($c,$d) is easier than
3791 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3792 * To detect whether there are common vars, the global var
3793 * PL_generation is incremented for each assign op we compile.
3794 * Then, while compiling the assign op, we run through all the
3795 * variables on both sides of the assignment, setting a spare slot
3796 * in each of them to PL_generation. If any of them already have
3797 * that value, we know we've got commonality. We could use a
3798 * single bit marker, but then we'd have to make 2 passes, first
3799 * to clear the flag, then to test and set it. To find somewhere
3800 * to store these values, evil chicanery is done with SvCUR().
3803 if (!(left->op_private & OPpLVAL_INTRO)) {
3806 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3807 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3808 if (curop->op_type == OP_GV) {
3809 GV *gv = cGVOPx_gv(curop);
3811 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3813 GvASSIGN_GENERATION_set(gv, PL_generation);
3815 else if (curop->op_type == OP_PADSV ||
3816 curop->op_type == OP_PADAV ||
3817 curop->op_type == OP_PADHV ||
3818 curop->op_type == OP_PADANY)
3820 if (PAD_COMPNAME_GEN(curop->op_targ)
3821 == (STRLEN)PL_generation)
3823 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3826 else if (curop->op_type == OP_RV2CV)
3828 else if (curop->op_type == OP_RV2SV ||
3829 curop->op_type == OP_RV2AV ||
3830 curop->op_type == OP_RV2HV ||
3831 curop->op_type == OP_RV2GV) {
3832 if (lastop->op_type != OP_GV) /* funny deref? */
3835 else if (curop->op_type == OP_PUSHRE) {
3836 if (((PMOP*)curop)->op_pmreplroot) {
3838 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3839 ((PMOP*)curop)->op_pmreplroot));
3841 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3844 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3846 GvASSIGN_GENERATION_set(gv, PL_generation);
3847 GvASSIGN_GENERATION_set(gv, PL_generation);
3856 o->op_private |= OPpASSIGN_COMMON;
3858 if (right && right->op_type == OP_SPLIT) {
3859 OP* tmpop = ((LISTOP*)right)->op_first;
3860 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3861 PMOP * const pm = (PMOP*)tmpop;
3862 if (left->op_type == OP_RV2AV &&
3863 !(left->op_private & OPpLVAL_INTRO) &&
3864 !(o->op_private & OPpASSIGN_COMMON) )
3866 tmpop = ((UNOP*)left)->op_first;
3867 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3869 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3870 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3872 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3873 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3875 pm->op_pmflags |= PMf_ONCE;
3876 tmpop = cUNOPo->op_first; /* to list (nulled) */
3877 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3878 tmpop->op_sibling = NULL; /* don't free split */
3879 right->op_next = tmpop->op_next; /* fix starting loc */
3881 op_getmad(o,right,'R'); /* blow off assign */
3883 op_free(o); /* blow off assign */
3885 right->op_flags &= ~OPf_WANT;
3886 /* "I don't know and I don't care." */
3891 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3892 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3894 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3896 sv_setiv(sv, PL_modcount+1);
3904 right = newOP(OP_UNDEF, 0);
3905 if (right->op_type == OP_READLINE) {
3906 right->op_flags |= OPf_STACKED;
3907 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3910 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3911 o = newBINOP(OP_SASSIGN, flags,
3912 scalar(right), mod(scalar(left), OP_SASSIGN) );
3918 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3919 o->op_private |= OPpCONST_ARYBASE;
3926 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3929 const U32 seq = intro_my();
3932 NewOp(1101, cop, 1, COP);
3933 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3934 cop->op_type = OP_DBSTATE;
3935 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3938 cop->op_type = OP_NEXTSTATE;
3939 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3941 cop->op_flags = (U8)flags;
3942 CopHINTS_set(cop, PL_hints);
3944 cop->op_private |= NATIVE_HINTS;
3946 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3947 cop->op_next = (OP*)cop;
3950 cop->cop_label = label;
3951 PL_hints |= HINT_BLOCK_SCOPE;
3954 CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
3955 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3956 if (specialCopIO(PL_curcop->cop_io))
3957 cop->cop_io = PL_curcop->cop_io;
3959 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3960 cop->cop_hints = PL_curcop->cop_hints;
3961 if (cop->cop_hints) {
3963 cop->cop_hints->refcounted_he_refcnt++;
3964 HINTS_REFCNT_UNLOCK;
3967 if (PL_copline == NOLINE)
3968 CopLINE_set(cop, CopLINE(PL_curcop));
3970 CopLINE_set(cop, PL_copline);
3971 PL_copline = NOLINE;
3974 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3976 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3978 CopSTASH_set(cop, PL_curstash);
3980 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3981 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3982 if (svp && *svp != &PL_sv_undef ) {
3983 (void)SvIOK_on(*svp);
3984 SvIV_set(*svp, PTR2IV(cop));
3988 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3993 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3996 return new_logop(type, flags, &first, &other);
4000 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4005 OP *first = *firstp;
4006 OP * const other = *otherp;
4008 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4009 return newBINOP(type, flags, scalar(first), scalar(other));
4011 scalarboolean(first);
4012 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4013 if (first->op_type == OP_NOT
4014 && (first->op_flags & OPf_SPECIAL)
4015 && (first->op_flags & OPf_KIDS)) {
4016 if (type == OP_AND || type == OP_OR) {
4022 first = *firstp = cUNOPo->op_first;
4024 first->op_next = o->op_next;
4025 cUNOPo->op_first = NULL;
4027 op_getmad(o,first,'O');
4033 if (first->op_type == OP_CONST) {
4034 if (first->op_private & OPpCONST_STRICT)
4035 no_bareword_allowed(first);
4036 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4037 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4038 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4039 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4040 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4042 if (other->op_type == OP_CONST)
4043 other->op_private |= OPpCONST_SHORTCIRCUIT;
4045 OP *newop = newUNOP(OP_NULL, 0, other);
4046 op_getmad(first, newop, '1');
4047 newop->op_targ = type; /* set "was" field */
4054 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4055 const OP *o2 = other;
4056 if ( ! (o2->op_type == OP_LIST
4057 && (( o2 = cUNOPx(o2)->op_first))
4058 && o2->op_type == OP_PUSHMARK
4059 && (( o2 = o2->op_sibling)) )
4062 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4063 || o2->op_type == OP_PADHV)
4064 && o2->op_private & OPpLVAL_INTRO
4065 && ckWARN(WARN_DEPRECATED))
4067 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4068 "Deprecated use of my() in false conditional");
4072 if (first->op_type == OP_CONST)
4073 first->op_private |= OPpCONST_SHORTCIRCUIT;
4075 first = newUNOP(OP_NULL, 0, first);
4076 op_getmad(other, first, '2');
4077 first->op_targ = type; /* set "was" field */
4084 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4085 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4087 const OP * const k1 = ((UNOP*)first)->op_first;
4088 const OP * const k2 = k1->op_sibling;
4090 switch (first->op_type)
4093 if (k2 && k2->op_type == OP_READLINE
4094 && (k2->op_flags & OPf_STACKED)
4095 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4097 warnop = k2->op_type;
4102 if (k1->op_type == OP_READDIR
4103 || k1->op_type == OP_GLOB
4104 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4105 || k1->op_type == OP_EACH)
4107 warnop = ((k1->op_type == OP_NULL)
4108 ? (OPCODE)k1->op_targ : k1->op_type);
4113 const line_t oldline = CopLINE(PL_curcop);
4114 CopLINE_set(PL_curcop, PL_copline);
4115 Perl_warner(aTHX_ packWARN(WARN_MISC),
4116 "Value of %s%s can be \"0\"; test with defined()",
4118 ((warnop == OP_READLINE || warnop == OP_GLOB)
4119 ? " construct" : "() operator"));
4120 CopLINE_set(PL_curcop, oldline);
4127 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4128 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4130 NewOp(1101, logop, 1, LOGOP);
4132 logop->op_type = (OPCODE)type;
4133 logop->op_ppaddr = PL_ppaddr[type];
4134 logop->op_first = first;
4135 logop->op_flags = (U8)(flags | OPf_KIDS);
4136 logop->op_other = LINKLIST(other);
4137 logop->op_private = (U8)(1 | (flags >> 8));
4139 /* establish postfix order */
4140 logop->op_next = LINKLIST(first);
4141 first->op_next = (OP*)logop;
4142 first->op_sibling = other;
4144 CHECKOP(type,logop);
4146 o = newUNOP(OP_NULL, 0, (OP*)logop);
4153 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4161 return newLOGOP(OP_AND, 0, first, trueop);
4163 return newLOGOP(OP_OR, 0, first, falseop);
4165 scalarboolean(first);
4166 if (first->op_type == OP_CONST) {
4167 if (first->op_private & OPpCONST_BARE &&
4168 first->op_private & OPpCONST_STRICT) {
4169 no_bareword_allowed(first);
4171 if (SvTRUE(((SVOP*)first)->op_sv)) {
4174 trueop = newUNOP(OP_NULL, 0, trueop);
4175 op_getmad(first,trueop,'C');
4176 op_getmad(falseop,trueop,'e');
4178 /* FIXME for MAD - should there be an ELSE here? */
4188 falseop = newUNOP(OP_NULL, 0, falseop);
4189 op_getmad(first,falseop,'C');
4190 op_getmad(trueop,falseop,'t');
4192 /* FIXME for MAD - should there be an ELSE here? */
4200 NewOp(1101, logop, 1, LOGOP);
4201 logop->op_type = OP_COND_EXPR;
4202 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4203 logop->op_first = first;
4204 logop->op_flags = (U8)(flags | OPf_KIDS);
4205 logop->op_private = (U8)(1 | (flags >> 8));
4206 logop->op_other = LINKLIST(trueop);
4207 logop->op_next = LINKLIST(falseop);
4209 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4212 /* establish postfix order */
4213 start = LINKLIST(first);
4214 first->op_next = (OP*)logop;
4216 first->op_sibling = trueop;
4217 trueop->op_sibling = falseop;
4218 o = newUNOP(OP_NULL, 0, (OP*)logop);
4220 trueop->op_next = falseop->op_next = o;
4227 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4236 NewOp(1101, range, 1, LOGOP);
4238 range->op_type = OP_RANGE;
4239 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4240 range->op_first = left;
4241 range->op_flags = OPf_KIDS;
4242 leftstart = LINKLIST(left);
4243 range->op_other = LINKLIST(right);
4244 range->op_private = (U8)(1 | (flags >> 8));
4246 left->op_sibling = right;
4248 range->op_next = (OP*)range;
4249 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4250 flop = newUNOP(OP_FLOP, 0, flip);
4251 o = newUNOP(OP_NULL, 0, flop);
4253 range->op_next = leftstart;
4255 left->op_next = flip;
4256 right->op_next = flop;
4258 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4259 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4260 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4261 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4263 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4264 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4267 if (!flip->op_private || !flop->op_private)
4268 linklist(o); /* blow off optimizer unless constant */
4274 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4279 const bool once = block && block->op_flags & OPf_SPECIAL &&
4280 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4282 PERL_UNUSED_ARG(debuggable);
4285 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4286 return block; /* do {} while 0 does once */
4287 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4288 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4289 expr = newUNOP(OP_DEFINED, 0,
4290 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4291 } else if (expr->op_flags & OPf_KIDS) {
4292 const OP * const k1 = ((UNOP*)expr)->op_first;
4293 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4294 switch (expr->op_type) {
4296 if (k2 && k2->op_type == OP_READLINE
4297 && (k2->op_flags & OPf_STACKED)
4298 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4299 expr = newUNOP(OP_DEFINED, 0, expr);
4303 if (k1 && (k1->op_type == OP_READDIR
4304 || k1->op_type == OP_GLOB
4305 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4306 || k1->op_type == OP_EACH))
4307 expr = newUNOP(OP_DEFINED, 0, expr);
4313 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4314 * op, in listop. This is wrong. [perl #27024] */
4316 block = newOP(OP_NULL, 0);
4317 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4318 o = new_logop(OP_AND, 0, &expr, &listop);
4321 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4323 if (once && o != listop)
4324 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4327 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4329 o->op_flags |= flags;
4331 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4336 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4337 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4346 PERL_UNUSED_ARG(debuggable);
4349 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4350 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4351 expr = newUNOP(OP_DEFINED, 0,
4352 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4353 } else if (expr->op_flags & OPf_KIDS) {
4354 const OP * const k1 = ((UNOP*)expr)->op_first;
4355 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4356 switch (expr->op_type) {
4358 if (k2 && k2->op_type == OP_READLINE
4359 && (k2->op_flags & OPf_STACKED)
4360 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4361 expr = newUNOP(OP_DEFINED, 0, expr);
4365 if (k1 && (k1->op_type == OP_READDIR
4366 || k1->op_type == OP_GLOB
4367 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4368 || k1->op_type == OP_EACH))
4369 expr = newUNOP(OP_DEFINED, 0, expr);
4376 block = newOP(OP_NULL, 0);
4377 else if (cont || has_my) {
4378 block = scope(block);
4382 next = LINKLIST(cont);
4385 OP * const unstack = newOP(OP_UNSTACK, 0);
4388 cont = append_elem(OP_LINESEQ, cont, unstack);
4392 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4394 redo = LINKLIST(listop);
4397 PL_copline = (line_t)whileline;
4399 o = new_logop(OP_AND, 0, &expr, &listop);
4400 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4401 op_free(expr); /* oops, it's a while (0) */
4403 return NULL; /* listop already freed by new_logop */
4406 ((LISTOP*)listop)->op_last->op_next =
4407 (o == listop ? redo : LINKLIST(o));
4413 NewOp(1101,loop,1,LOOP);
4414 loop->op_type = OP_ENTERLOOP;
4415 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4416 loop->op_private = 0;
4417 loop->op_next = (OP*)loop;
4420 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4422 loop->op_redoop = redo;
4423 loop->op_lastop = o;
4424 o->op_private |= loopflags;
4427 loop->op_nextop = next;
4429 loop->op_nextop = o;
4431 o->op_flags |= flags;
4432 o->op_private |= (flags >> 8);
4437 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4442 PADOFFSET padoff = 0;
4448 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4449 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4450 sv->op_type = OP_RV2GV;
4451 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4452 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4453 iterpflags |= OPpITER_DEF;
4455 else if (sv->op_type == OP_PADSV) { /* private variable */
4456 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4457 padoff = sv->op_targ;
4466 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4467 padoff = sv->op_targ;
4472 iterflags |= OPf_SPECIAL;
4478 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4479 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4480 iterpflags |= OPpITER_DEF;
4483 const PADOFFSET offset = pad_findmy("$_");
4484 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4485 sv = newGVOP(OP_GV, 0, PL_defgv);
4490 iterpflags |= OPpITER_DEF;
4492 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4493 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4494 iterflags |= OPf_STACKED;
4496 else if (expr->op_type == OP_NULL &&
4497 (expr->op_flags & OPf_KIDS) &&
4498 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4500 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4501 * set the STACKED flag to indicate that these values are to be
4502 * treated as min/max values by 'pp_iterinit'.
4504 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4505 LOGOP* const range = (LOGOP*) flip->op_first;
4506 OP* const left = range->op_first;
4507 OP* const right = left->op_sibling;
4510 range->op_flags &= ~OPf_KIDS;
4511 range->op_first = NULL;
4513 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4514 listop->op_first->op_next = range->op_next;
4515 left->op_next = range->op_other;
4516 right->op_next = (OP*)listop;
4517 listop->op_next = listop->op_first;
4520 op_getmad(expr,(OP*)listop,'O');
4524 expr = (OP*)(listop);
4526 iterflags |= OPf_STACKED;
4529 expr = mod(force_list(expr), OP_GREPSTART);
4532 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4533 append_elem(OP_LIST, expr, scalar(sv))));
4534 assert(!loop->op_next);
4535 /* for my $x () sets OPpLVAL_INTRO;
4536 * for our $x () sets OPpOUR_INTRO */
4537 loop->op_private = (U8)iterpflags;
4538 #ifdef PL_OP_SLAB_ALLOC
4541 NewOp(1234,tmp,1,LOOP);
4542 Copy(loop,tmp,1,LISTOP);
4547 loop = PerlMemShared_realloc(loop, sizeof(LOOP));
4549 loop->op_targ = padoff;
4550 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4552 op_getmad(madsv, (OP*)loop, 'v');
4553 PL_copline = forline;
4554 return newSTATEOP(0, label, wop);
4558 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4563 if (type != OP_GOTO || label->op_type == OP_CONST) {
4564 /* "last()" means "last" */
4565 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4566 o = newOP(type, OPf_SPECIAL);
4568 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4569 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4573 op_getmad(label,o,'L');
4579 /* Check whether it's going to be a goto &function */
4580 if (label->op_type == OP_ENTERSUB
4581 && !(label->op_flags & OPf_STACKED))
4582 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4583 o = newUNOP(type, OPf_STACKED, label);
4585 PL_hints |= HINT_BLOCK_SCOPE;
4589 /* if the condition is a literal array or hash
4590 (or @{ ... } etc), make a reference to it.
4593 S_ref_array_or_hash(pTHX_ OP *cond)
4596 && (cond->op_type == OP_RV2AV
4597 || cond->op_type == OP_PADAV
4598 || cond->op_type == OP_RV2HV
4599 || cond->op_type == OP_PADHV))
4601 return newUNOP(OP_REFGEN,
4602 0, mod(cond, OP_REFGEN));
4608 /* These construct the optree fragments representing given()
4611 entergiven and enterwhen are LOGOPs; the op_other pointer
4612 points up to the associated leave op. We need this so we
4613 can put it in the context and make break/continue work.
4614 (Also, of course, pp_enterwhen will jump straight to
4615 op_other if the match fails.)
4620 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4621 I32 enter_opcode, I32 leave_opcode,
4622 PADOFFSET entertarg)
4628 NewOp(1101, enterop, 1, LOGOP);
4629 enterop->op_type = enter_opcode;
4630 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4631 enterop->op_flags = (U8) OPf_KIDS;
4632 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4633 enterop->op_private = 0;
4635 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4638 enterop->op_first = scalar(cond);
4639 cond->op_sibling = block;
4641 o->op_next = LINKLIST(cond);
4642 cond->op_next = (OP *) enterop;
4645 /* This is a default {} block */
4646 enterop->op_first = block;
4647 enterop->op_flags |= OPf_SPECIAL;
4649 o->op_next = (OP *) enterop;
4652 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4653 entergiven and enterwhen both
4656 enterop->op_next = LINKLIST(block);
4657 block->op_next = enterop->op_other = o;
4662 /* Does this look like a boolean operation? For these purposes
4663 a boolean operation is:
4664 - a subroutine call [*]
4665 - a logical connective
4666 - a comparison operator
4667 - a filetest operator, with the exception of -s -M -A -C
4668 - defined(), exists() or eof()
4669 - /$re/ or $foo =~ /$re/
4671 [*] possibly surprising
4675 S_looks_like_bool(pTHX_ const OP *o)
4678 switch(o->op_type) {
4680 return looks_like_bool(cLOGOPo->op_first);
4684 looks_like_bool(cLOGOPo->op_first)
4685 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4689 case OP_NOT: case OP_XOR:
4690 /* Note that OP_DOR is not here */
4692 case OP_EQ: case OP_NE: case OP_LT:
4693 case OP_GT: case OP_LE: case OP_GE:
4695 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4696 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4698 case OP_SEQ: case OP_SNE: case OP_SLT:
4699 case OP_SGT: case OP_SLE: case OP_SGE:
4703 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4704 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4705 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4706 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4707 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4708 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4709 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4710 case OP_FTTEXT: case OP_FTBINARY:
4712 case OP_DEFINED: case OP_EXISTS:
4713 case OP_MATCH: case OP_EOF:
4718 /* Detect comparisons that have been optimized away */
4719 if (cSVOPo->op_sv == &PL_sv_yes
4720 || cSVOPo->op_sv == &PL_sv_no)
4731 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4735 return newGIVWHENOP(
4736 ref_array_or_hash(cond),
4738 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4742 /* If cond is null, this is a default {} block */
4744 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4746 const bool cond_llb = (!cond || looks_like_bool(cond));
4752 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4754 scalar(ref_array_or_hash(cond)));
4757 return newGIVWHENOP(
4759 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4760 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4764 =for apidoc cv_undef
4766 Clear out all the active components of a CV. This can happen either
4767 by an explicit C<undef &foo>, or by the reference count going to zero.
4768 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4769 children can still follow the full lexical scope chain.
4775 Perl_cv_undef(pTHX_ CV *cv)
4779 if (CvFILE(cv) && !CvISXSUB(cv)) {
4780 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4781 Safefree(CvFILE(cv));
4786 if (!CvISXSUB(cv) && CvROOT(cv)) {
4787 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4788 Perl_croak(aTHX_ "Can't undef active subroutine");
4791 PAD_SAVE_SETNULLPAD();
4793 op_free(CvROOT(cv));
4798 SvPOK_off((SV*)cv); /* forget prototype */
4803 /* remove CvOUTSIDE unless this is an undef rather than a free */
4804 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4805 if (!CvWEAKOUTSIDE(cv))
4806 SvREFCNT_dec(CvOUTSIDE(cv));
4807 CvOUTSIDE(cv) = NULL;
4810 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4813 if (CvISXSUB(cv) && CvXSUB(cv)) {
4816 /* delete all flags except WEAKOUTSIDE */
4817 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4821 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4824 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4825 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4826 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4827 || (p && (len != SvCUR(cv) /* Not the same length. */
4828 || memNE(p, SvPVX_const(cv), len))))
4829 && ckWARN_d(WARN_PROTOTYPE)) {
4830 SV* const msg = sv_newmortal();
4834 gv_efullname3(name = sv_newmortal(), gv, NULL);
4835 sv_setpv(msg, "Prototype mismatch:");
4837 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4839 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4841 sv_catpvs(msg, ": none");
4842 sv_catpvs(msg, " vs ");
4844 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4846 sv_catpvs(msg, "none");
4847 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4851 static void const_sv_xsub(pTHX_ CV* cv);
4855 =head1 Optree Manipulation Functions
4857 =for apidoc cv_const_sv
4859 If C<cv> is a constant sub eligible for inlining. returns the constant
4860 value returned by the sub. Otherwise, returns NULL.
4862 Constant subs can be created with C<newCONSTSUB> or as described in
4863 L<perlsub/"Constant Functions">.
4868 Perl_cv_const_sv(pTHX_ CV *cv)
4870 PERL_UNUSED_CONTEXT;
4873 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4875 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4878 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4879 * Can be called in 3 ways:
4882 * look for a single OP_CONST with attached value: return the value
4884 * cv && CvCLONE(cv) && !CvCONST(cv)
4886 * examine the clone prototype, and if contains only a single
4887 * OP_CONST referencing a pad const, or a single PADSV referencing
4888 * an outer lexical, return a non-zero value to indicate the CV is
4889 * a candidate for "constizing" at clone time
4893 * We have just cloned an anon prototype that was marked as a const
4894 * candidiate. Try to grab the current value, and in the case of
4895 * PADSV, ignore it if it has multiple references. Return the value.
4899 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4907 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4908 o = cLISTOPo->op_first->op_sibling;
4910 for (; o; o = o->op_next) {
4911 const OPCODE type = o->op_type;
4913 if (sv && o->op_next == o)
4915 if (o->op_next != o) {
4916 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4918 if (type == OP_DBSTATE)
4921 if (type == OP_LEAVESUB || type == OP_RETURN)
4925 if (type == OP_CONST && cSVOPo->op_sv)
4927 else if (cv && type == OP_CONST) {
4928 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4932 else if (cv && type == OP_PADSV) {
4933 if (CvCONST(cv)) { /* newly cloned anon */
4934 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4935 /* the candidate should have 1 ref from this pad and 1 ref
4936 * from the parent */
4937 if (!sv || SvREFCNT(sv) != 2)
4944 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4945 sv = &PL_sv_undef; /* an arbitrary non-null value */
4960 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4963 /* This would be the return value, but the return cannot be reached. */
4964 OP* pegop = newOP(OP_NULL, 0);
4967 PERL_UNUSED_ARG(floor);
4977 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4979 NORETURN_FUNCTION_END;
4984 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4986 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4990 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4997 register CV *cv = NULL;
4999 /* If the subroutine has no body, no attributes, and no builtin attributes
5000 then it's just a sub declaration, and we may be able to get away with
5001 storing with a placeholder scalar in the symbol table, rather than a
5002 full GV and CV. If anything is present then it will take a full CV to
5004 const I32 gv_fetch_flags
5005 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5007 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5008 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5011 assert(proto->op_type == OP_CONST);
5012 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5017 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5018 SV * const sv = sv_newmortal();
5019 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5020 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5021 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5022 aname = SvPVX_const(sv);
5027 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5028 : gv_fetchpv(aname ? aname
5029 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5030 gv_fetch_flags, SVt_PVCV);
5032 if (!PL_madskills) {
5041 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5042 maximum a prototype before. */
5043 if (SvTYPE(gv) > SVt_NULL) {
5044 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5045 && ckWARN_d(WARN_PROTOTYPE))
5047 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5049 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5052 sv_setpvn((SV*)gv, ps, ps_len);
5054 sv_setiv((SV*)gv, -1);
5055 SvREFCNT_dec(PL_compcv);
5056 cv = PL_compcv = NULL;
5057 PL_sub_generation++;
5061 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5063 #ifdef GV_UNIQUE_CHECK
5064 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5065 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5069 if (!block || !ps || *ps || attrs
5070 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5072 || block->op_type == OP_NULL
5077 const_sv = op_const_sv(block, NULL);
5080 const bool exists = CvROOT(cv) || CvXSUB(cv);
5082 #ifdef GV_UNIQUE_CHECK
5083 if (exists && GvUNIQUE(gv)) {
5084 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5088 /* if the subroutine doesn't exist and wasn't pre-declared
5089 * with a prototype, assume it will be AUTOLOADed,
5090 * skipping the prototype check
5092 if (exists || SvPOK(cv))
5093 cv_ckproto_len(cv, gv, ps, ps_len);
5094 /* already defined (or promised)? */
5095 if (exists || GvASSUMECV(gv)) {
5098 || block->op_type == OP_NULL
5101 if (CvFLAGS(PL_compcv)) {
5102 /* might have had built-in attrs applied */
5103 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5105 /* just a "sub foo;" when &foo is already defined */
5106 SAVEFREESV(PL_compcv);
5111 && block->op_type != OP_NULL
5114 if (ckWARN(WARN_REDEFINE)
5116 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5118 const line_t oldline = CopLINE(PL_curcop);
5119 if (PL_copline != NOLINE)
5120 CopLINE_set(PL_curcop, PL_copline);
5121 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5122 CvCONST(cv) ? "Constant subroutine %s redefined"
5123 : "Subroutine %s redefined", name);
5124 CopLINE_set(PL_curcop, oldline);
5127 if (!PL_minus_c) /* keep old one around for madskills */
5130 /* (PL_madskills unset in used file.) */
5138 SvREFCNT_inc_simple_void_NN(const_sv);
5140 assert(!CvROOT(cv) && !CvCONST(cv));
5141 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5142 CvXSUBANY(cv).any_ptr = const_sv;
5143 CvXSUB(cv) = const_sv_xsub;
5149 cv = newCONSTSUB(NULL, name, const_sv);
5151 PL_sub_generation++;
5155 SvREFCNT_dec(PL_compcv);
5163 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5164 * before we clobber PL_compcv.
5168 || block->op_type == OP_NULL
5172 /* Might have had built-in attributes applied -- propagate them. */
5173 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5174 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5175 stash = GvSTASH(CvGV(cv));
5176 else if (CvSTASH(cv))
5177 stash = CvSTASH(cv);
5179 stash = PL_curstash;
5182 /* possibly about to re-define existing subr -- ignore old cv */
5183 rcv = (SV*)PL_compcv;
5184 if (name && GvSTASH(gv))
5185 stash = GvSTASH(gv);
5187 stash = PL_curstash;
5189 apply_attrs(stash, rcv, attrs, FALSE);
5191 if (cv) { /* must reuse cv if autoloaded */
5198 || block->op_type == OP_NULL) && !PL_madskills
5201 /* got here with just attrs -- work done, so bug out */
5202 SAVEFREESV(PL_compcv);
5205 /* transfer PL_compcv to cv */
5207 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5208 if (!CvWEAKOUTSIDE(cv))
5209 SvREFCNT_dec(CvOUTSIDE(cv));
5210 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5211 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5212 CvOUTSIDE(PL_compcv) = 0;
5213 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5214 CvPADLIST(PL_compcv) = 0;
5215 /* inner references to PL_compcv must be fixed up ... */
5216 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5217 /* ... before we throw it away */
5218 SvREFCNT_dec(PL_compcv);
5220 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5221 ++PL_sub_generation;
5228 if (strEQ(name, "import")) {
5229 PL_formfeed = (SV*)cv;
5230 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5234 PL_sub_generation++;
5238 CvFILE_set_from_cop(cv, PL_curcop);
5239 CvSTASH(cv) = PL_curstash;
5242 sv_setpvn((SV*)cv, ps, ps_len);
5244 if (PL_error_count) {
5248 const char *s = strrchr(name, ':');
5250 if (strEQ(s, "BEGIN")) {
5251 const char not_safe[] =
5252 "BEGIN not safe after errors--compilation aborted";
5253 if (PL_in_eval & EVAL_KEEPERR)
5254 Perl_croak(aTHX_ not_safe);
5256 /* force display of errors found but not reported */
5257 sv_catpv(ERRSV, not_safe);
5258 Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
5268 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5269 mod(scalarseq(block), OP_LEAVESUBLV));
5272 /* This makes sub {}; work as expected. */
5273 if (block->op_type == OP_STUB) {
5274 OP* const newblock = newSTATEOP(0, NULL, 0);
5276 op_getmad(block,newblock,'B');
5282 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5284 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5285 OpREFCNT_set(CvROOT(cv), 1);
5286 CvSTART(cv) = LINKLIST(CvROOT(cv));
5287 CvROOT(cv)->op_next = 0;
5288 CALL_PEEP(CvSTART(cv));
5290 /* now that optimizer has done its work, adjust pad values */
5292 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5295 assert(!CvCONST(cv));
5296 if (ps && !*ps && op_const_sv(block, cv))
5300 if (name || aname) {
5302 const char * const tname = (name ? name : aname);
5304 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5305 SV * const sv = newSV(0);
5306 SV * const tmpstr = sv_newmortal();
5307 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5308 GV_ADDMULTI, SVt_PVHV);
5311 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5313 (long)PL_subline, (long)CopLINE(PL_curcop));
5314 gv_efullname3(tmpstr, gv, NULL);
5315 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5316 hv = GvHVn(db_postponed);
5317 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5318 CV * const pcv = GvCV(db_postponed);
5324 call_sv((SV*)pcv, G_DISCARD);
5329 if ((s = strrchr(tname,':')))
5334 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5337 if (strEQ(s, "BEGIN") && !PL_error_count) {
5338 const I32 oldscope = PL_scopestack_ix;
5340 SAVECOPFILE(&PL_compiling);
5341 SAVECOPLINE(&PL_compiling);
5344 PL_beginav = newAV();
5345 DEBUG_x( dump_sub(gv) );
5346 av_push(PL_beginav, (SV*)cv);
5347 GvCV(gv) = 0; /* cv has been hijacked */
5348 call_list(oldscope, PL_beginav);
5350 PL_curcop = &PL_compiling;
5351 CopHINTS_set(&PL_compiling, PL_hints);
5354 else if (strEQ(s, "END") && !PL_error_count) {
5357 DEBUG_x( dump_sub(gv) );
5358 av_unshift(PL_endav, 1);
5359 av_store(PL_endav, 0, (SV*)cv);
5360 GvCV(gv) = 0; /* cv has been hijacked */
5362 else if (strEQ(s, "CHECK") && !PL_error_count) {
5364 PL_checkav = newAV();
5365 DEBUG_x( dump_sub(gv) );
5366 if (PL_main_start && ckWARN(WARN_VOID))
5367 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5368 av_unshift(PL_checkav, 1);
5369 av_store(PL_checkav, 0, (SV*)cv);
5370 GvCV(gv) = 0; /* cv has been hijacked */
5372 else if (strEQ(s, "INIT") && !PL_error_count) {
5374 PL_initav = newAV();
5375 DEBUG_x( dump_sub(gv) );
5376 if (PL_main_start && ckWARN(WARN_VOID))
5377 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5378 av_push(PL_initav, (SV*)cv);
5379 GvCV(gv) = 0; /* cv has been hijacked */
5384 PL_copline = NOLINE;
5389 /* XXX unsafe for threads if eval_owner isn't held */
5391 =for apidoc newCONSTSUB
5393 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5394 eligible for inlining at compile-time.
5400 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5405 const char *const temp_p = CopFILE(PL_curcop);
5406 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5408 SV *const temp_sv = CopFILESV(PL_curcop);
5410 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5412 char *const file = savepvn(temp_p, temp_p ? len : 0);
5416 SAVECOPLINE(PL_curcop);
5417 CopLINE_set(PL_curcop, PL_copline);
5420 PL_hints &= ~HINT_BLOCK_SCOPE;
5423 SAVESPTR(PL_curstash);
5424 SAVECOPSTASH(PL_curcop);
5425 PL_curstash = stash;
5426 CopSTASH_set(PL_curcop,stash);
5429 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5430 and so doesn't get free()d. (It's expected to be from the C pre-
5431 processor __FILE__ directive). But we need a dynamically allocated one,
5432 and we need it to get freed. */
5433 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5434 CvXSUBANY(cv).any_ptr = sv;
5439 CopSTASH_free(PL_curcop);
5447 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5448 const char *const filename, const char *const proto,
5451 CV *cv = newXS(name, subaddr, filename);
5453 if (flags & XS_DYNAMIC_FILENAME) {
5454 /* We need to "make arrangements" (ie cheat) to ensure that the
5455 filename lasts as long as the PVCV we just created, but also doesn't
5457 STRLEN filename_len = strlen(filename);
5458 STRLEN proto_and_file_len = filename_len;
5459 char *proto_and_file;
5463 proto_len = strlen(proto);
5464 proto_and_file_len += proto_len;
5466 Newx(proto_and_file, proto_and_file_len + 1, char);
5467 Copy(proto, proto_and_file, proto_len, char);
5468 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5471 proto_and_file = savepvn(filename, filename_len);
5474 /* This gets free()d. :-) */
5475 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5476 SV_HAS_TRAILING_NUL);
5478 /* This gives us the correct prototype, rather than one with the
5479 file name appended. */
5480 SvCUR_set(cv, proto_len);
5484 CvFILE(cv) = proto_and_file + proto_len;
5486 sv_setpv((SV *)cv, proto);
5492 =for apidoc U||newXS
5494 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5495 static storage, as it is used directly as CvFILE(), without a copy being made.
5501 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5504 GV * const gv = gv_fetchpv(name ? name :
5505 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5506 GV_ADDMULTI, SVt_PVCV);
5510 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5512 if ((cv = (name ? GvCV(gv) : NULL))) {
5514 /* just a cached method */
5518 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5519 /* already defined (or promised) */
5520 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5521 if (ckWARN(WARN_REDEFINE)) {
5522 GV * const gvcv = CvGV(cv);
5524 HV * const stash = GvSTASH(gvcv);
5526 const char *redefined_name = HvNAME_get(stash);
5527 if ( strEQ(redefined_name,"autouse") ) {
5528 const line_t oldline = CopLINE(PL_curcop);
5529 if (PL_copline != NOLINE)
5530 CopLINE_set(PL_curcop, PL_copline);
5531 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5532 CvCONST(cv) ? "Constant subroutine %s redefined"
5533 : "Subroutine %s redefined"
5535 CopLINE_set(PL_curcop, oldline);
5545 if (cv) /* must reuse cv if autoloaded */
5549 sv_upgrade((SV *)cv, SVt_PVCV);
5553 PL_sub_generation++;
5557 (void)gv_fetchfile(filename);
5558 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5559 an external constant string */
5561 CvXSUB(cv) = subaddr;
5564 const char *s = strrchr(name,':');
5570 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5573 if (strEQ(s, "BEGIN")) {
5575 PL_beginav = newAV();
5576 av_push(PL_beginav, (SV*)cv);
5577 GvCV(gv) = 0; /* cv has been hijacked */
5579 else if (strEQ(s, "END")) {
5582 av_unshift(PL_endav, 1);
5583 av_store(PL_endav, 0, (SV*)cv);
5584 GvCV(gv) = 0; /* cv has been hijacked */
5586 else if (strEQ(s, "CHECK")) {
5588 PL_checkav = newAV();
5589 if (PL_main_start && ckWARN(WARN_VOID))
5590 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5591 av_unshift(PL_checkav, 1);
5592 av_store(PL_checkav, 0, (SV*)cv);
5593 GvCV(gv) = 0; /* cv has been hijacked */
5595 else if (strEQ(s, "INIT")) {
5597 PL_initav = newAV();
5598 if (PL_main_start && ckWARN(WARN_VOID))
5599 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5600 av_push(PL_initav, (SV*)cv);
5601 GvCV(gv) = 0; /* cv has been hijacked */
5616 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5621 OP* pegop = newOP(OP_NULL, 0);
5625 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5626 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5628 #ifdef GV_UNIQUE_CHECK
5630 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5634 if ((cv = GvFORM(gv))) {
5635 if (ckWARN(WARN_REDEFINE)) {
5636 const line_t oldline = CopLINE(PL_curcop);
5637 if (PL_copline != NOLINE)
5638 CopLINE_set(PL_curcop, PL_copline);
5639 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5640 o ? "Format %"SVf" redefined"
5641 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5642 CopLINE_set(PL_curcop, oldline);
5649 CvFILE_set_from_cop(cv, PL_curcop);
5652 pad_tidy(padtidy_FORMAT);
5653 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5654 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5655 OpREFCNT_set(CvROOT(cv), 1);
5656 CvSTART(cv) = LINKLIST(CvROOT(cv));
5657 CvROOT(cv)->op_next = 0;
5658 CALL_PEEP(CvSTART(cv));
5660 op_getmad(o,pegop,'n');
5661 op_getmad_weak(block, pegop, 'b');
5665 PL_copline = NOLINE;
5673 Perl_newANONLIST(pTHX_ OP *o)
5675 return newUNOP(OP_REFGEN, 0,
5676 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5680 Perl_newANONHASH(pTHX_ OP *o)
5682 return newUNOP(OP_REFGEN, 0,
5683 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5687 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5689 return newANONATTRSUB(floor, proto, NULL, block);
5693 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5695 return newUNOP(OP_REFGEN, 0,
5696 newSVOP(OP_ANONCODE, 0,
5697 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5701 Perl_oopsAV(pTHX_ OP *o)
5704 switch (o->op_type) {
5706 o->op_type = OP_PADAV;
5707 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5708 return ref(o, OP_RV2AV);
5711 o->op_type = OP_RV2AV;
5712 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5717 if (ckWARN_d(WARN_INTERNAL))
5718 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5725 Perl_oopsHV(pTHX_ OP *o)
5728 switch (o->op_type) {
5731 o->op_type = OP_PADHV;
5732 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5733 return ref(o, OP_RV2HV);
5737 o->op_type = OP_RV2HV;
5738 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5743 if (ckWARN_d(WARN_INTERNAL))
5744 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5751 Perl_newAVREF(pTHX_ OP *o)
5754 if (o->op_type == OP_PADANY) {
5755 o->op_type = OP_PADAV;
5756 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5759 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5760 && ckWARN(WARN_DEPRECATED)) {
5761 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5762 "Using an array as a reference is deprecated");
5764 return newUNOP(OP_RV2AV, 0, scalar(o));
5768 Perl_newGVREF(pTHX_ I32 type, OP *o)
5770 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5771 return newUNOP(OP_NULL, 0, o);
5772 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5776 Perl_newHVREF(pTHX_ OP *o)
5779 if (o->op_type == OP_PADANY) {
5780 o->op_type = OP_PADHV;
5781 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5784 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5785 && ckWARN(WARN_DEPRECATED)) {
5786 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5787 "Using a hash as a reference is deprecated");
5789 return newUNOP(OP_RV2HV, 0, scalar(o));
5793 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5795 return newUNOP(OP_RV2CV, flags, scalar(o));
5799 Perl_newSVREF(pTHX_ OP *o)
5802 if (o->op_type == OP_PADANY) {
5803 o->op_type = OP_PADSV;
5804 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5807 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5808 o->op_flags |= OPpDONE_SVREF;
5811 return newUNOP(OP_RV2SV, 0, scalar(o));
5814 /* Check routines. See the comments at the top of this file for details
5815 * on when these are called */
5818 Perl_ck_anoncode(pTHX_ OP *o)
5820 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5822 cSVOPo->op_sv = NULL;
5827 Perl_ck_bitop(pTHX_ OP *o)
5830 #define OP_IS_NUMCOMPARE(op) \
5831 ((op) == OP_LT || (op) == OP_I_LT || \
5832 (op) == OP_GT || (op) == OP_I_GT || \
5833 (op) == OP_LE || (op) == OP_I_LE || \
5834 (op) == OP_GE || (op) == OP_I_GE || \
5835 (op) == OP_EQ || (op) == OP_I_EQ || \
5836 (op) == OP_NE || (op) == OP_I_NE || \
5837 (op) == OP_NCMP || (op) == OP_I_NCMP)
5838 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5839 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5840 && (o->op_type == OP_BIT_OR
5841 || o->op_type == OP_BIT_AND
5842 || o->op_type == OP_BIT_XOR))
5844 const OP * const left = cBINOPo->op_first;
5845 const OP * const right = left->op_sibling;
5846 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5847 (left->op_flags & OPf_PARENS) == 0) ||
5848 (OP_IS_NUMCOMPARE(right->op_type) &&
5849 (right->op_flags & OPf_PARENS) == 0))
5850 if (ckWARN(WARN_PRECEDENCE))
5851 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5852 "Possible precedence problem on bitwise %c operator",
5853 o->op_type == OP_BIT_OR ? '|'
5854 : o->op_type == OP_BIT_AND ? '&' : '^'
5861 Perl_ck_concat(pTHX_ OP *o)
5863 const OP * const kid = cUNOPo->op_first;
5864 PERL_UNUSED_CONTEXT;
5865 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5866 !(kUNOP->op_first->op_flags & OPf_MOD))
5867 o->op_flags |= OPf_STACKED;
5872 Perl_ck_spair(pTHX_ OP *o)
5875 if (o->op_flags & OPf_KIDS) {
5878 const OPCODE type = o->op_type;
5879 o = modkids(ck_fun(o), type);
5880 kid = cUNOPo->op_first;
5881 newop = kUNOP->op_first->op_sibling;
5883 const OPCODE type = newop->op_type;
5884 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5885 type == OP_PADAV || type == OP_PADHV ||
5886 type == OP_RV2AV || type == OP_RV2HV)
5890 op_getmad(kUNOP->op_first,newop,'K');
5892 op_free(kUNOP->op_first);
5894 kUNOP->op_first = newop;
5896 o->op_ppaddr = PL_ppaddr[++o->op_type];
5901 Perl_ck_delete(pTHX_ OP *o)
5905 if (o->op_flags & OPf_KIDS) {
5906 OP * const kid = cUNOPo->op_first;
5907 switch (kid->op_type) {
5909 o->op_flags |= OPf_SPECIAL;
5912 o->op_private |= OPpSLICE;
5915 o->op_flags |= OPf_SPECIAL;
5920 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5929 Perl_ck_die(pTHX_ OP *o)
5932 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5938 Perl_ck_eof(pTHX_ OP *o)
5942 if (o->op_flags & OPf_KIDS) {
5943 if (cLISTOPo->op_first->op_type == OP_STUB) {
5945 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5947 op_getmad(o,newop,'O');
5959 Perl_ck_eval(pTHX_ OP *o)
5962 PL_hints |= HINT_BLOCK_SCOPE;
5963 if (o->op_flags & OPf_KIDS) {
5964 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5967 o->op_flags &= ~OPf_KIDS;
5970 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5976 cUNOPo->op_first = 0;
5981 NewOp(1101, enter, 1, LOGOP);
5982 enter->op_type = OP_ENTERTRY;
5983 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5984 enter->op_private = 0;
5986 /* establish postfix order */
5987 enter->op_next = (OP*)enter;
5989 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5990 o->op_type = OP_LEAVETRY;
5991 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5992 enter->op_other = o;
5993 op_getmad(oldo,o,'O');
6007 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6008 op_getmad(oldo,o,'O');
6010 o->op_targ = (PADOFFSET)PL_hints;
6011 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6012 /* Store a copy of %^H that pp_entereval can pick up */
6013 OP *hhop = newSVOP(OP_CONST, 0,
6014 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6015 cUNOPo->op_first->op_sibling = hhop;
6016 o->op_private |= OPpEVAL_HAS_HH;
6022 Perl_ck_exit(pTHX_ OP *o)
6025 HV * const table = GvHV(PL_hintgv);
6027 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6028 if (svp && *svp && SvTRUE(*svp))
6029 o->op_private |= OPpEXIT_VMSISH;
6031 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6037 Perl_ck_exec(pTHX_ OP *o)
6039 if (o->op_flags & OPf_STACKED) {
6042 kid = cUNOPo->op_first->op_sibling;
6043 if (kid->op_type == OP_RV2GV)
6052 Perl_ck_exists(pTHX_ OP *o)
6056 if (o->op_flags & OPf_KIDS) {
6057 OP * const kid = cUNOPo->op_first;
6058 if (kid->op_type == OP_ENTERSUB) {
6059 (void) ref(kid, o->op_type);
6060 if (kid->op_type != OP_RV2CV && !PL_error_count)
6061 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6063 o->op_private |= OPpEXISTS_SUB;
6065 else if (kid->op_type == OP_AELEM)
6066 o->op_flags |= OPf_SPECIAL;
6067 else if (kid->op_type != OP_HELEM)
6068 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6076 Perl_ck_rvconst(pTHX_ register OP *o)
6079 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6081 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6082 if (o->op_type == OP_RV2CV)
6083 o->op_private &= ~1;
6085 if (kid->op_type == OP_CONST) {
6088 SV * const kidsv = kid->op_sv;
6090 /* Is it a constant from cv_const_sv()? */
6091 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6092 SV * const rsv = SvRV(kidsv);
6093 const int svtype = SvTYPE(rsv);
6094 const char *badtype = NULL;
6096 switch (o->op_type) {
6098 if (svtype > SVt_PVMG)
6099 badtype = "a SCALAR";
6102 if (svtype != SVt_PVAV)
6103 badtype = "an ARRAY";
6106 if (svtype != SVt_PVHV)
6110 if (svtype != SVt_PVCV)
6115 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6118 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6119 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6120 /* If this is an access to a stash, disable "strict refs", because
6121 * stashes aren't auto-vivified at compile-time (unless we store
6122 * symbols in them), and we don't want to produce a run-time
6123 * stricture error when auto-vivifying the stash. */
6124 const char *s = SvPV_nolen(kidsv);
6125 const STRLEN l = SvCUR(kidsv);
6126 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6127 o->op_private &= ~HINT_STRICT_REFS;
6129 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6130 const char *badthing;
6131 switch (o->op_type) {
6133 badthing = "a SCALAR";
6136 badthing = "an ARRAY";
6139 badthing = "a HASH";
6147 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6148 (void*)kidsv, badthing);
6151 * This is a little tricky. We only want to add the symbol if we
6152 * didn't add it in the lexer. Otherwise we get duplicate strict
6153 * warnings. But if we didn't add it in the lexer, we must at
6154 * least pretend like we wanted to add it even if it existed before,
6155 * or we get possible typo warnings. OPpCONST_ENTERED says
6156 * whether the lexer already added THIS instance of this symbol.
6158 iscv = (o->op_type == OP_RV2CV) * 2;
6160 gv = gv_fetchsv(kidsv,
6161 iscv | !(kid->op_private & OPpCONST_ENTERED),
6164 : o->op_type == OP_RV2SV
6166 : o->op_type == OP_RV2AV
6168 : o->op_type == OP_RV2HV
6171 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6173 kid->op_type = OP_GV;
6174 SvREFCNT_dec(kid->op_sv);
6176 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6177 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6178 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6180 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6182 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6184 kid->op_private = 0;
6185 kid->op_ppaddr = PL_ppaddr[OP_GV];
6192 Perl_ck_ftst(pTHX_ OP *o)
6195 const I32 type = o->op_type;
6197 if (o->op_flags & OPf_REF) {
6200 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6201 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6202 const OPCODE kidtype = kid->op_type;
6204 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6205 OP * const newop = newGVOP(type, OPf_REF,
6206 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6208 op_getmad(o,newop,'O');
6214 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6215 o->op_private |= OPpFT_ACCESS;
6216 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6217 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6218 o->op_private |= OPpFT_STACKED;
6226 if (type == OP_FTTTY)
6227 o = newGVOP(type, OPf_REF, PL_stdingv);
6229 o = newUNOP(type, 0, newDEFSVOP());
6230 op_getmad(oldo,o,'O');
6236 Perl_ck_fun(pTHX_ OP *o)
6239 const int type = o->op_type;
6240 register I32 oa = PL_opargs[type] >> OASHIFT;
6242 if (o->op_flags & OPf_STACKED) {
6243 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6246 return no_fh_allowed(o);
6249 if (o->op_flags & OPf_KIDS) {
6250 OP **tokid = &cLISTOPo->op_first;
6251 register OP *kid = cLISTOPo->op_first;
6255 if (kid->op_type == OP_PUSHMARK ||
6256 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6258 tokid = &kid->op_sibling;
6259 kid = kid->op_sibling;
6261 if (!kid && PL_opargs[type] & OA_DEFGV)
6262 *tokid = kid = newDEFSVOP();
6266 sibl = kid->op_sibling;
6268 if (!sibl && kid->op_type == OP_STUB) {
6275 /* list seen where single (scalar) arg expected? */
6276 if (numargs == 1 && !(oa >> 4)
6277 && kid->op_type == OP_LIST && type != OP_SCALAR)
6279 return too_many_arguments(o,PL_op_desc[type]);
6292 if ((type == OP_PUSH || type == OP_UNSHIFT)
6293 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6294 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6295 "Useless use of %s with no values",
6298 if (kid->op_type == OP_CONST &&
6299 (kid->op_private & OPpCONST_BARE))
6301 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6302 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6303 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6304 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6305 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6306 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6308 op_getmad(kid,newop,'K');
6313 kid->op_sibling = sibl;
6316 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6317 bad_type(numargs, "array", PL_op_desc[type], kid);
6321 if (kid->op_type == OP_CONST &&
6322 (kid->op_private & OPpCONST_BARE))
6324 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6325 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6326 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6327 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6328 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6329 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6331 op_getmad(kid,newop,'K');
6336 kid->op_sibling = sibl;
6339 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6340 bad_type(numargs, "hash", PL_op_desc[type], kid);
6345 OP * const newop = newUNOP(OP_NULL, 0, kid);
6346 kid->op_sibling = 0;
6348 newop->op_next = newop;
6350 kid->op_sibling = sibl;
6355 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6356 if (kid->op_type == OP_CONST &&
6357 (kid->op_private & OPpCONST_BARE))
6359 OP * const newop = newGVOP(OP_GV, 0,
6360 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6361 if (!(o->op_private & 1) && /* if not unop */
6362 kid == cLISTOPo->op_last)
6363 cLISTOPo->op_last = newop;
6365 op_getmad(kid,newop,'K');
6371 else if (kid->op_type == OP_READLINE) {
6372 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6373 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6376 I32 flags = OPf_SPECIAL;
6380 /* is this op a FH constructor? */
6381 if (is_handle_constructor(o,numargs)) {
6382 const char *name = NULL;
6386 /* Set a flag to tell rv2gv to vivify
6387 * need to "prove" flag does not mean something
6388 * else already - NI-S 1999/05/07
6391 if (kid->op_type == OP_PADSV) {
6392 name = PAD_COMPNAME_PV(kid->op_targ);
6393 /* SvCUR of a pad namesv can't be trusted
6394 * (see PL_generation), so calc its length
6400 else if (kid->op_type == OP_RV2SV
6401 && kUNOP->op_first->op_type == OP_GV)
6403 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6405 len = GvNAMELEN(gv);
6407 else if (kid->op_type == OP_AELEM
6408 || kid->op_type == OP_HELEM)
6410 OP *op = ((BINOP*)kid)->op_first;
6414 const char * const a =
6415 kid->op_type == OP_AELEM ?
6417 if (((op->op_type == OP_RV2AV) ||
6418 (op->op_type == OP_RV2HV)) &&
6419 (op = ((UNOP*)op)->op_first) &&
6420 (op->op_type == OP_GV)) {
6421 /* packagevar $a[] or $h{} */
6422 GV * const gv = cGVOPx_gv(op);
6430 else if (op->op_type == OP_PADAV
6431 || op->op_type == OP_PADHV) {
6432 /* lexicalvar $a[] or $h{} */
6433 const char * const padname =
6434 PAD_COMPNAME_PV(op->op_targ);
6443 name = SvPV_const(tmpstr, len);
6448 name = "__ANONIO__";
6455 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6456 namesv = PAD_SVl(targ);
6457 SvUPGRADE(namesv, SVt_PV);
6459 sv_setpvn(namesv, "$", 1);
6460 sv_catpvn(namesv, name, len);
6463 kid->op_sibling = 0;
6464 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6465 kid->op_targ = targ;
6466 kid->op_private |= priv;
6468 kid->op_sibling = sibl;
6474 mod(scalar(kid), type);
6478 tokid = &kid->op_sibling;
6479 kid = kid->op_sibling;
6482 if (kid && kid->op_type != OP_STUB)
6483 return too_many_arguments(o,OP_DESC(o));
6484 o->op_private |= numargs;
6486 /* FIXME - should the numargs move as for the PERL_MAD case? */
6487 o->op_private |= numargs;
6489 return too_many_arguments(o,OP_DESC(o));
6493 else if (PL_opargs[type] & OA_DEFGV) {
6495 OP *newop = newUNOP(type, 0, newDEFSVOP());
6496 op_getmad(o,newop,'O');
6499 /* Ordering of these two is important to keep f_map.t passing. */
6501 return newUNOP(type, 0, newDEFSVOP());
6506 while (oa & OA_OPTIONAL)
6508 if (oa && oa != OA_LIST)
6509 return too_few_arguments(o,OP_DESC(o));
6515 Perl_ck_glob(pTHX_ OP *o)
6521 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6522 append_elem(OP_GLOB, o, newDEFSVOP());
6524 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6525 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6527 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6530 #if !defined(PERL_EXTERNAL_GLOB)
6531 /* XXX this can be tightened up and made more failsafe. */
6532 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6535 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6536 newSVpvs("File::Glob"), NULL, NULL, NULL);
6537 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6538 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6539 GvCV(gv) = GvCV(glob_gv);
6540 SvREFCNT_inc_void((SV*)GvCV(gv));
6541 GvIMPORTED_CV_on(gv);
6544 #endif /* PERL_EXTERNAL_GLOB */
6546 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6547 append_elem(OP_GLOB, o,
6548 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6549 o->op_type = OP_LIST;
6550 o->op_ppaddr = PL_ppaddr[OP_LIST];
6551 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6552 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6553 cLISTOPo->op_first->op_targ = 0;
6554 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6555 append_elem(OP_LIST, o,
6556 scalar(newUNOP(OP_RV2CV, 0,
6557 newGVOP(OP_GV, 0, gv)))));
6558 o = newUNOP(OP_NULL, 0, ck_subr(o));
6559 o->op_targ = OP_GLOB; /* hint at what it used to be */
6562 gv = newGVgen("main");
6564 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6570 Perl_ck_grep(pTHX_ OP *o)
6575 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6578 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6579 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6581 if (o->op_flags & OPf_STACKED) {
6584 kid = cLISTOPo->op_first->op_sibling;
6585 if (!cUNOPx(kid)->op_next)
6586 Perl_croak(aTHX_ "panic: ck_grep");
6587 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6590 NewOp(1101, gwop, 1, LOGOP);
6591 kid->op_next = (OP*)gwop;
6592 o->op_flags &= ~OPf_STACKED;
6594 kid = cLISTOPo->op_first->op_sibling;
6595 if (type == OP_MAPWHILE)
6602 kid = cLISTOPo->op_first->op_sibling;
6603 if (kid->op_type != OP_NULL)
6604 Perl_croak(aTHX_ "panic: ck_grep");
6605 kid = kUNOP->op_first;
6608 NewOp(1101, gwop, 1, LOGOP);
6609 gwop->op_type = type;
6610 gwop->op_ppaddr = PL_ppaddr[type];
6611 gwop->op_first = listkids(o);
6612 gwop->op_flags |= OPf_KIDS;
6613 gwop->op_other = LINKLIST(kid);
6614 kid->op_next = (OP*)gwop;
6615 offset = pad_findmy("$_");
6616 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6617 o->op_private = gwop->op_private = 0;
6618 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6621 o->op_private = gwop->op_private = OPpGREP_LEX;
6622 gwop->op_targ = o->op_targ = offset;
6625 kid = cLISTOPo->op_first->op_sibling;
6626 if (!kid || !kid->op_sibling)
6627 return too_few_arguments(o,OP_DESC(o));
6628 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6629 mod(kid, OP_GREPSTART);
6635 Perl_ck_index(pTHX_ OP *o)
6637 if (o->op_flags & OPf_KIDS) {
6638 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6640 kid = kid->op_sibling; /* get past "big" */
6641 if (kid && kid->op_type == OP_CONST)
6642 fbm_compile(((SVOP*)kid)->op_sv, 0);
6648 Perl_ck_lengthconst(pTHX_ OP *o)
6650 /* XXX length optimization goes here */
6655 Perl_ck_lfun(pTHX_ OP *o)
6657 const OPCODE type = o->op_type;
6658 return modkids(ck_fun(o), type);
6662 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6664 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6665 switch (cUNOPo->op_first->op_type) {
6667 /* This is needed for
6668 if (defined %stash::)
6669 to work. Do not break Tk.
6671 break; /* Globals via GV can be undef */
6673 case OP_AASSIGN: /* Is this a good idea? */
6674 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6675 "defined(@array) is deprecated");
6676 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6677 "\t(Maybe you should just omit the defined()?)\n");
6680 /* This is needed for
6681 if (defined %stash::)
6682 to work. Do not break Tk.
6684 break; /* Globals via GV can be undef */
6686 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6687 "defined(%%hash) is deprecated");
6688 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6689 "\t(Maybe you should just omit the defined()?)\n");
6700 Perl_ck_rfun(pTHX_ OP *o)
6702 const OPCODE type = o->op_type;
6703 return refkids(ck_fun(o), type);
6707 Perl_ck_listiob(pTHX_ OP *o)
6711 kid = cLISTOPo->op_first;
6714 kid = cLISTOPo->op_first;
6716 if (kid->op_type == OP_PUSHMARK)
6717 kid = kid->op_sibling;
6718 if (kid && o->op_flags & OPf_STACKED)
6719 kid = kid->op_sibling;
6720 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6721 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6722 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6723 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6724 cLISTOPo->op_first->op_sibling = kid;
6725 cLISTOPo->op_last = kid;
6726 kid = kid->op_sibling;
6731 append_elem(o->op_type, o, newDEFSVOP());
6737 Perl_ck_say(pTHX_ OP *o)
6740 o->op_type = OP_PRINT;
6741 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6742 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6747 Perl_ck_smartmatch(pTHX_ OP *o)
6750 if (0 == (o->op_flags & OPf_SPECIAL)) {
6751 OP *first = cBINOPo->op_first;
6752 OP *second = first->op_sibling;
6754 /* Implicitly take a reference to an array or hash */
6755 first->op_sibling = NULL;
6756 first = cBINOPo->op_first = ref_array_or_hash(first);
6757 second = first->op_sibling = ref_array_or_hash(second);
6759 /* Implicitly take a reference to a regular expression */
6760 if (first->op_type == OP_MATCH) {
6761 first->op_type = OP_QR;
6762 first->op_ppaddr = PL_ppaddr[OP_QR];
6764 if (second->op_type == OP_MATCH) {
6765 second->op_type = OP_QR;
6766 second->op_ppaddr = PL_ppaddr[OP_QR];
6775 Perl_ck_sassign(pTHX_ OP *o)
6777 OP * const kid = cLISTOPo->op_first;
6778 /* has a disposable target? */
6779 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6780 && !(kid->op_flags & OPf_STACKED)
6781 /* Cannot steal the second time! */
6782 && !(kid->op_private & OPpTARGET_MY))
6784 OP * const kkid = kid->op_sibling;
6786 /* Can just relocate the target. */
6787 if (kkid && kkid->op_type == OP_PADSV
6788 && !(kkid->op_private & OPpLVAL_INTRO))
6790 kid->op_targ = kkid->op_targ;
6792 /* Now we do not need PADSV and SASSIGN. */
6793 kid->op_sibling = o->op_sibling; /* NULL */
6794 cLISTOPo->op_first = NULL;
6796 op_getmad(o,kid,'O');
6797 op_getmad(kkid,kid,'M');
6802 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6810 Perl_ck_match(pTHX_ OP *o)
6813 if (o->op_type != OP_QR && PL_compcv) {
6814 const PADOFFSET offset = pad_findmy("$_");
6815 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6816 o->op_targ = offset;
6817 o->op_private |= OPpTARGET_MY;
6820 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6821 o->op_private |= OPpRUNTIME;
6826 Perl_ck_method(pTHX_ OP *o)
6828 OP * const kid = cUNOPo->op_first;
6829 if (kid->op_type == OP_CONST) {
6830 SV* sv = kSVOP->op_sv;
6831 const char * const method = SvPVX_const(sv);
6832 if (!(strchr(method, ':') || strchr(method, '\''))) {
6834 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6835 sv = newSVpvn_share(method, SvCUR(sv), 0);
6838 kSVOP->op_sv = NULL;
6840 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6842 op_getmad(o,cmop,'O');
6853 Perl_ck_null(pTHX_ OP *o)
6855 PERL_UNUSED_CONTEXT;
6860 Perl_ck_open(pTHX_ OP *o)
6863 HV * const table = GvHV(PL_hintgv);
6865 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6867 const I32 mode = mode_from_discipline(*svp);
6868 if (mode & O_BINARY)
6869 o->op_private |= OPpOPEN_IN_RAW;
6870 else if (mode & O_TEXT)
6871 o->op_private |= OPpOPEN_IN_CRLF;
6874 svp = hv_fetchs(table, "open_OUT", FALSE);
6876 const I32 mode = mode_from_discipline(*svp);
6877 if (mode & O_BINARY)
6878 o->op_private |= OPpOPEN_OUT_RAW;
6879 else if (mode & O_TEXT)
6880 o->op_private |= OPpOPEN_OUT_CRLF;
6883 if (o->op_type == OP_BACKTICK)
6886 /* In case of three-arg dup open remove strictness
6887 * from the last arg if it is a bareword. */
6888 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6889 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6893 if ((last->op_type == OP_CONST) && /* The bareword. */
6894 (last->op_private & OPpCONST_BARE) &&
6895 (last->op_private & OPpCONST_STRICT) &&
6896 (oa = first->op_sibling) && /* The fh. */
6897 (oa = oa->op_sibling) && /* The mode. */
6898 (oa->op_type == OP_CONST) &&
6899 SvPOK(((SVOP*)oa)->op_sv) &&
6900 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6901 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6902 (last == oa->op_sibling)) /* The bareword. */
6903 last->op_private &= ~OPpCONST_STRICT;
6909 Perl_ck_repeat(pTHX_ OP *o)
6911 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6912 o->op_private |= OPpREPEAT_DOLIST;
6913 cBINOPo->op_first = force_list(cBINOPo->op_first);
6921 Perl_ck_require(pTHX_ OP *o)
6926 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6927 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6929 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6930 SV * const sv = kid->op_sv;
6931 U32 was_readonly = SvREADONLY(sv);
6936 sv_force_normal_flags(sv, 0);
6937 assert(!SvREADONLY(sv));
6944 for (s = SvPVX(sv); *s; s++) {
6945 if (*s == ':' && s[1] == ':') {
6946 const STRLEN len = strlen(s+2)+1;
6948 Move(s+2, s+1, len, char);
6949 SvCUR_set(sv, SvCUR(sv) - 1);
6952 sv_catpvs(sv, ".pm");
6953 SvFLAGS(sv) |= was_readonly;
6957 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6958 /* handle override, if any */
6959 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6960 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6961 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6962 gv = gvp ? *gvp : NULL;
6966 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6967 OP * const kid = cUNOPo->op_first;
6970 cUNOPo->op_first = 0;
6974 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6975 append_elem(OP_LIST, kid,
6976 scalar(newUNOP(OP_RV2CV, 0,
6979 op_getmad(o,newop,'O');
6987 Perl_ck_return(pTHX_ OP *o)
6990 if (CvLVALUE(PL_compcv)) {
6992 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6993 mod(kid, OP_LEAVESUBLV);
6999 Perl_ck_select(pTHX_ OP *o)
7003 if (o->op_flags & OPf_KIDS) {
7004 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7005 if (kid && kid->op_sibling) {
7006 o->op_type = OP_SSELECT;
7007 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7009 return fold_constants(o);
7013 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7014 if (kid && kid->op_type == OP_RV2GV)
7015 kid->op_private &= ~HINT_STRICT_REFS;
7020 Perl_ck_shift(pTHX_ OP *o)
7023 const I32 type = o->op_type;
7025 if (!(o->op_flags & OPf_KIDS)) {
7027 /* FIXME - this can be refactored to reduce code in #ifdefs */
7029 OP * const oldo = o;
7033 argop = newUNOP(OP_RV2AV, 0,
7034 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7036 o = newUNOP(type, 0, scalar(argop));
7037 op_getmad(oldo,o,'O');
7040 return newUNOP(type, 0, scalar(argop));
7043 return scalar(modkids(ck_fun(o), type));
7047 Perl_ck_sort(pTHX_ OP *o)
7052 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7053 HV * const hinthv = GvHV(PL_hintgv);
7055 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7057 const I32 sorthints = (I32)SvIV(*svp);
7058 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7059 o->op_private |= OPpSORT_QSORT;
7060 if ((sorthints & HINT_SORT_STABLE) != 0)
7061 o->op_private |= OPpSORT_STABLE;
7066 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7068 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7069 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7071 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7073 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7075 if (kid->op_type == OP_SCOPE) {
7079 else if (kid->op_type == OP_LEAVE) {
7080 if (o->op_type == OP_SORT) {
7081 op_null(kid); /* wipe out leave */
7084 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7085 if (k->op_next == kid)
7087 /* don't descend into loops */
7088 else if (k->op_type == OP_ENTERLOOP
7089 || k->op_type == OP_ENTERITER)
7091 k = cLOOPx(k)->op_lastop;
7096 kid->op_next = 0; /* just disconnect the leave */
7097 k = kLISTOP->op_first;
7102 if (o->op_type == OP_SORT) {
7103 /* provide scalar context for comparison function/block */
7109 o->op_flags |= OPf_SPECIAL;
7111 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7114 firstkid = firstkid->op_sibling;
7117 /* provide list context for arguments */
7118 if (o->op_type == OP_SORT)
7125 S_simplify_sort(pTHX_ OP *o)
7128 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7133 if (!(o->op_flags & OPf_STACKED))
7135 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7136 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7137 kid = kUNOP->op_first; /* get past null */
7138 if (kid->op_type != OP_SCOPE)
7140 kid = kLISTOP->op_last; /* get past scope */
7141 switch(kid->op_type) {
7149 k = kid; /* remember this node*/
7150 if (kBINOP->op_first->op_type != OP_RV2SV)
7152 kid = kBINOP->op_first; /* get past cmp */
7153 if (kUNOP->op_first->op_type != OP_GV)
7155 kid = kUNOP->op_first; /* get past rv2sv */
7157 if (GvSTASH(gv) != PL_curstash)
7159 gvname = GvNAME(gv);
7160 if (*gvname == 'a' && gvname[1] == '\0')
7162 else if (*gvname == 'b' && gvname[1] == '\0')
7167 kid = k; /* back to cmp */
7168 if (kBINOP->op_last->op_type != OP_RV2SV)
7170 kid = kBINOP->op_last; /* down to 2nd arg */
7171 if (kUNOP->op_first->op_type != OP_GV)
7173 kid = kUNOP->op_first; /* get past rv2sv */
7175 if (GvSTASH(gv) != PL_curstash)
7177 gvname = GvNAME(gv);
7179 ? !(*gvname == 'a' && gvname[1] == '\0')
7180 : !(*gvname == 'b' && gvname[1] == '\0'))
7182 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7184 o->op_private |= OPpSORT_DESCEND;
7185 if (k->op_type == OP_NCMP)
7186 o->op_private |= OPpSORT_NUMERIC;
7187 if (k->op_type == OP_I_NCMP)
7188 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7189 kid = cLISTOPo->op_first->op_sibling;
7190 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7192 op_getmad(kid,o,'S'); /* then delete it */
7194 op_free(kid); /* then delete it */
7199 Perl_ck_split(pTHX_ OP *o)
7204 if (o->op_flags & OPf_STACKED)
7205 return no_fh_allowed(o);
7207 kid = cLISTOPo->op_first;
7208 if (kid->op_type != OP_NULL)
7209 Perl_croak(aTHX_ "panic: ck_split");
7210 kid = kid->op_sibling;
7211 op_free(cLISTOPo->op_first);
7212 cLISTOPo->op_first = kid;
7214 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7215 cLISTOPo->op_last = kid; /* There was only one element previously */
7218 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7219 OP * const sibl = kid->op_sibling;
7220 kid->op_sibling = 0;
7221 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7222 if (cLISTOPo->op_first == cLISTOPo->op_last)
7223 cLISTOPo->op_last = kid;
7224 cLISTOPo->op_first = kid;
7225 kid->op_sibling = sibl;
7228 kid->op_type = OP_PUSHRE;
7229 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7231 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7232 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7233 "Use of /g modifier is meaningless in split");
7236 if (!kid->op_sibling)
7237 append_elem(OP_SPLIT, o, newDEFSVOP());
7239 kid = kid->op_sibling;
7242 if (!kid->op_sibling)
7243 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7244 assert(kid->op_sibling);
7246 kid = kid->op_sibling;
7249 if (kid->op_sibling)
7250 return too_many_arguments(o,OP_DESC(o));
7256 Perl_ck_join(pTHX_ OP *o)
7258 const OP * const kid = cLISTOPo->op_first->op_sibling;
7259 if (kid && kid->op_type == OP_MATCH) {
7260 if (ckWARN(WARN_SYNTAX)) {
7261 const REGEXP *re = PM_GETRE(kPMOP);
7262 const char *pmstr = re ? re->precomp : "STRING";
7263 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7264 "/%s/ should probably be written as \"%s\"",
7272 Perl_ck_subr(pTHX_ OP *o)
7275 OP *prev = ((cUNOPo->op_first->op_sibling)
7276 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7277 OP *o2 = prev->op_sibling;
7279 const char *proto = NULL;
7280 const char *proto_end = NULL;
7285 I32 contextclass = 0;
7289 o->op_private |= OPpENTERSUB_HASTARG;
7290 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7291 if (cvop->op_type == OP_RV2CV) {
7293 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7294 op_null(cvop); /* disable rv2cv */
7295 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7296 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7297 GV *gv = cGVOPx_gv(tmpop);
7300 tmpop->op_private |= OPpEARLY_CV;
7304 namegv = CvANON(cv) ? gv : CvGV(cv);
7305 proto = SvPV((SV*)cv, len);
7306 proto_end = proto + len;
7308 if (CvASSERTION(cv)) {
7309 if (PL_hints & HINT_ASSERTING) {
7310 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7311 o->op_private |= OPpENTERSUB_DB;
7315 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7316 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7317 "Impossible to activate assertion call");
7324 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7325 if (o2->op_type == OP_CONST)
7326 o2->op_private &= ~OPpCONST_STRICT;
7327 else if (o2->op_type == OP_LIST) {
7328 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7329 if (sib && sib->op_type == OP_CONST)
7330 sib->op_private &= ~OPpCONST_STRICT;
7333 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7334 if (PERLDB_SUB && PL_curstash != PL_debstash)
7335 o->op_private |= OPpENTERSUB_DB;
7336 while (o2 != cvop) {
7338 if (PL_madskills && o2->op_type == OP_NULL)
7339 o3 = ((UNOP*)o2)->op_first;
7343 if (proto >= proto_end)
7344 return too_many_arguments(o, gv_ename(namegv));
7364 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7366 arg == 1 ? "block or sub {}" : "sub {}",
7367 gv_ename(namegv), o3);
7370 /* '*' allows any scalar type, including bareword */
7373 if (o3->op_type == OP_RV2GV)
7374 goto wrapref; /* autoconvert GLOB -> GLOBref */
7375 else if (o3->op_type == OP_CONST)
7376 o3->op_private &= ~OPpCONST_STRICT;
7377 else if (o3->op_type == OP_ENTERSUB) {
7378 /* accidental subroutine, revert to bareword */
7379 OP *gvop = ((UNOP*)o3)->op_first;
7380 if (gvop && gvop->op_type == OP_NULL) {
7381 gvop = ((UNOP*)gvop)->op_first;
7383 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7386 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7387 (gvop = ((UNOP*)gvop)->op_first) &&
7388 gvop->op_type == OP_GV)
7390 GV * const gv = cGVOPx_gv(gvop);
7391 OP * const sibling = o2->op_sibling;
7392 SV * const n = newSVpvs("");
7394 OP * const oldo2 = o2;
7398 gv_fullname4(n, gv, "", FALSE);
7399 o2 = newSVOP(OP_CONST, 0, n);
7400 op_getmad(oldo2,o2,'O');
7401 prev->op_sibling = o2;
7402 o2->op_sibling = sibling;
7418 if (contextclass++ == 0) {
7419 e = strchr(proto, ']');
7420 if (!e || e == proto)
7429 const char *p = proto;
7430 const char *const end = proto;
7432 while (*--p != '[');
7433 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7435 gv_ename(namegv), o3);
7440 if (o3->op_type == OP_RV2GV)
7443 bad_type(arg, "symbol", gv_ename(namegv), o3);
7446 if (o3->op_type == OP_ENTERSUB)
7449 bad_type(arg, "subroutine entry", gv_ename(namegv),
7453 if (o3->op_type == OP_RV2SV ||
7454 o3->op_type == OP_PADSV ||
7455 o3->op_type == OP_HELEM ||
7456 o3->op_type == OP_AELEM ||
7457 o3->op_type == OP_THREADSV)
7460 bad_type(arg, "scalar", gv_ename(namegv), o3);
7463 if (o3->op_type == OP_RV2AV ||
7464 o3->op_type == OP_PADAV)
7467 bad_type(arg, "array", gv_ename(namegv), o3);
7470 if (o3->op_type == OP_RV2HV ||
7471 o3->op_type == OP_PADHV)
7474 bad_type(arg, "hash", gv_ename(namegv), o3);
7479 OP* const sib = kid->op_sibling;
7480 kid->op_sibling = 0;
7481 o2 = newUNOP(OP_REFGEN, 0, kid);
7482 o2->op_sibling = sib;
7483 prev->op_sibling = o2;
7485 if (contextclass && e) {
7500 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7501 gv_ename(namegv), (void*)cv);
7506 mod(o2, OP_ENTERSUB);
7508 o2 = o2->op_sibling;
7510 if (proto && !optional && proto_end > proto &&
7511 (*proto != '@' && *proto != '%' && *proto != ';'))
7512 return too_few_arguments(o, gv_ename(namegv));
7515 OP * const oldo = o;
7519 o=newSVOP(OP_CONST, 0, newSViv(0));
7520 op_getmad(oldo,o,'O');
7526 Perl_ck_svconst(pTHX_ OP *o)
7528 PERL_UNUSED_CONTEXT;
7529 SvREADONLY_on(cSVOPo->op_sv);
7534 Perl_ck_chdir(pTHX_ OP *o)
7536 if (o->op_flags & OPf_KIDS) {
7537 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7539 if (kid && kid->op_type == OP_CONST &&
7540 (kid->op_private & OPpCONST_BARE))
7542 o->op_flags |= OPf_SPECIAL;
7543 kid->op_private &= ~OPpCONST_STRICT;
7550 Perl_ck_trunc(pTHX_ OP *o)
7552 if (o->op_flags & OPf_KIDS) {
7553 SVOP *kid = (SVOP*)cUNOPo->op_first;
7555 if (kid->op_type == OP_NULL)
7556 kid = (SVOP*)kid->op_sibling;
7557 if (kid && kid->op_type == OP_CONST &&
7558 (kid->op_private & OPpCONST_BARE))
7560 o->op_flags |= OPf_SPECIAL;
7561 kid->op_private &= ~OPpCONST_STRICT;
7568 Perl_ck_unpack(pTHX_ OP *o)
7570 OP *kid = cLISTOPo->op_first;
7571 if (kid->op_sibling) {
7572 kid = kid->op_sibling;
7573 if (!kid->op_sibling)
7574 kid->op_sibling = newDEFSVOP();
7580 Perl_ck_substr(pTHX_ OP *o)
7583 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7584 OP *kid = cLISTOPo->op_first;
7586 if (kid->op_type == OP_NULL)
7587 kid = kid->op_sibling;
7589 kid->op_flags |= OPf_MOD;
7595 /* A peephole optimizer. We visit the ops in the order they're to execute.
7596 * See the comments at the top of this file for more details about when
7597 * peep() is called */
7600 Perl_peep(pTHX_ register OP *o)
7603 register OP* oldop = NULL;
7605 if (!o || o->op_opt)
7609 SAVEVPTR(PL_curcop);
7610 for (; o; o = o->op_next) {
7614 switch (o->op_type) {
7618 PL_curcop = ((COP*)o); /* for warnings */
7623 if (cSVOPo->op_private & OPpCONST_STRICT)
7624 no_bareword_allowed(o);
7626 case OP_METHOD_NAMED:
7627 /* Relocate sv to the pad for thread safety.
7628 * Despite being a "constant", the SV is written to,
7629 * for reference counts, sv_upgrade() etc. */
7631 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7632 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7633 /* If op_sv is already a PADTMP then it is being used by
7634 * some pad, so make a copy. */
7635 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7636 SvREADONLY_on(PAD_SVl(ix));
7637 SvREFCNT_dec(cSVOPo->op_sv);
7639 else if (o->op_type == OP_CONST
7640 && cSVOPo->op_sv == &PL_sv_undef) {
7641 /* PL_sv_undef is hack - it's unsafe to store it in the
7642 AV that is the pad, because av_fetch treats values of
7643 PL_sv_undef as a "free" AV entry and will merrily
7644 replace them with a new SV, causing pad_alloc to think
7645 that this pad slot is free. (When, clearly, it is not)
7647 SvOK_off(PAD_SVl(ix));
7648 SvPADTMP_on(PAD_SVl(ix));
7649 SvREADONLY_on(PAD_SVl(ix));
7652 SvREFCNT_dec(PAD_SVl(ix));
7653 SvPADTMP_on(cSVOPo->op_sv);
7654 PAD_SETSV(ix, cSVOPo->op_sv);
7655 /* XXX I don't know how this isn't readonly already. */
7656 SvREADONLY_on(PAD_SVl(ix));
7658 cSVOPo->op_sv = NULL;
7666 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7667 if (o->op_next->op_private & OPpTARGET_MY) {
7668 if (o->op_flags & OPf_STACKED) /* chained concats */
7669 goto ignore_optimization;
7671 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7672 o->op_targ = o->op_next->op_targ;
7673 o->op_next->op_targ = 0;
7674 o->op_private |= OPpTARGET_MY;
7677 op_null(o->op_next);
7679 ignore_optimization:
7683 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7685 break; /* Scalar stub must produce undef. List stub is noop */
7689 if (o->op_targ == OP_NEXTSTATE
7690 || o->op_targ == OP_DBSTATE
7691 || o->op_targ == OP_SETSTATE)
7693 PL_curcop = ((COP*)o);
7695 /* XXX: We avoid setting op_seq here to prevent later calls
7696 to peep() from mistakenly concluding that optimisation
7697 has already occurred. This doesn't fix the real problem,
7698 though (See 20010220.007). AMS 20010719 */
7699 /* op_seq functionality is now replaced by op_opt */
7700 if (oldop && o->op_next) {
7701 oldop->op_next = o->op_next;
7709 if (oldop && o->op_next) {
7710 oldop->op_next = o->op_next;
7718 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7719 OP* const pop = (o->op_type == OP_PADAV) ?
7720 o->op_next : o->op_next->op_next;
7722 if (pop && pop->op_type == OP_CONST &&
7723 ((PL_op = pop->op_next)) &&
7724 pop->op_next->op_type == OP_AELEM &&
7725 !(pop->op_next->op_private &
7726 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7727 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7732 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7733 no_bareword_allowed(pop);
7734 if (o->op_type == OP_GV)
7735 op_null(o->op_next);
7736 op_null(pop->op_next);
7738 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7739 o->op_next = pop->op_next->op_next;
7740 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7741 o->op_private = (U8)i;
7742 if (o->op_type == OP_GV) {
7747 o->op_flags |= OPf_SPECIAL;
7748 o->op_type = OP_AELEMFAST;
7754 if (o->op_next->op_type == OP_RV2SV) {
7755 if (!(o->op_next->op_private & OPpDEREF)) {
7756 op_null(o->op_next);
7757 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7759 o->op_next = o->op_next->op_next;
7760 o->op_type = OP_GVSV;
7761 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7764 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7765 GV * const gv = cGVOPo_gv;
7766 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7767 /* XXX could check prototype here instead of just carping */
7768 SV * const sv = sv_newmortal();
7769 gv_efullname3(sv, gv, NULL);
7770 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7771 "%"SVf"() called too early to check prototype",
7775 else if (o->op_next->op_type == OP_READLINE
7776 && o->op_next->op_next->op_type == OP_CONCAT
7777 && (o->op_next->op_next->op_flags & OPf_STACKED))
7779 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7780 o->op_type = OP_RCATLINE;
7781 o->op_flags |= OPf_STACKED;
7782 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7783 op_null(o->op_next->op_next);
7784 op_null(o->op_next);
7801 while (cLOGOP->op_other->op_type == OP_NULL)
7802 cLOGOP->op_other = cLOGOP->op_other->op_next;
7803 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7809 while (cLOOP->op_redoop->op_type == OP_NULL)
7810 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7811 peep(cLOOP->op_redoop);
7812 while (cLOOP->op_nextop->op_type == OP_NULL)
7813 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7814 peep(cLOOP->op_nextop);
7815 while (cLOOP->op_lastop->op_type == OP_NULL)
7816 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7817 peep(cLOOP->op_lastop);
7824 while (cPMOP->op_pmreplstart &&
7825 cPMOP->op_pmreplstart->op_type == OP_NULL)
7826 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7827 peep(cPMOP->op_pmreplstart);
7832 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7833 && ckWARN(WARN_SYNTAX))
7835 if (o->op_next->op_sibling) {
7836 const OPCODE type = o->op_next->op_sibling->op_type;
7837 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7838 const line_t oldline = CopLINE(PL_curcop);
7839 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7840 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7841 "Statement unlikely to be reached");
7842 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7843 "\t(Maybe you meant system() when you said exec()?)\n");
7844 CopLINE_set(PL_curcop, oldline);
7855 const char *key = NULL;
7860 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7863 /* Make the CONST have a shared SV */
7864 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7865 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7866 key = SvPV_const(sv, keylen);
7867 lexname = newSVpvn_share(key,
7868 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7874 if ((o->op_private & (OPpLVAL_INTRO)))
7877 rop = (UNOP*)((BINOP*)o)->op_first;
7878 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7880 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7881 if (!SvPAD_TYPED(lexname))
7883 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7884 if (!fields || !GvHV(*fields))
7886 key = SvPV_const(*svp, keylen);
7887 if (!hv_fetch(GvHV(*fields), key,
7888 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7890 Perl_croak(aTHX_ "No such class field \"%s\" "
7891 "in variable %s of type %s",
7892 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7905 SVOP *first_key_op, *key_op;
7907 if ((o->op_private & (OPpLVAL_INTRO))
7908 /* I bet there's always a pushmark... */
7909 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7910 /* hmmm, no optimization if list contains only one key. */
7912 rop = (UNOP*)((LISTOP*)o)->op_last;
7913 if (rop->op_type != OP_RV2HV)
7915 if (rop->op_first->op_type == OP_PADSV)
7916 /* @$hash{qw(keys here)} */
7917 rop = (UNOP*)rop->op_first;
7919 /* @{$hash}{qw(keys here)} */
7920 if (rop->op_first->op_type == OP_SCOPE
7921 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7923 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7929 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7930 if (!SvPAD_TYPED(lexname))
7932 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7933 if (!fields || !GvHV(*fields))
7935 /* Again guessing that the pushmark can be jumped over.... */
7936 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7937 ->op_first->op_sibling;
7938 for (key_op = first_key_op; key_op;
7939 key_op = (SVOP*)key_op->op_sibling) {
7940 if (key_op->op_type != OP_CONST)
7942 svp = cSVOPx_svp(key_op);
7943 key = SvPV_const(*svp, keylen);
7944 if (!hv_fetch(GvHV(*fields), key,
7945 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7947 Perl_croak(aTHX_ "No such class field \"%s\" "
7948 "in variable %s of type %s",
7949 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7956 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7960 /* check that RHS of sort is a single plain array */
7961 OP *oright = cUNOPo->op_first;
7962 if (!oright || oright->op_type != OP_PUSHMARK)
7965 /* reverse sort ... can be optimised. */
7966 if (!cUNOPo->op_sibling) {
7967 /* Nothing follows us on the list. */
7968 OP * const reverse = o->op_next;
7970 if (reverse->op_type == OP_REVERSE &&
7971 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7972 OP * const pushmark = cUNOPx(reverse)->op_first;
7973 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7974 && (cUNOPx(pushmark)->op_sibling == o)) {
7975 /* reverse -> pushmark -> sort */
7976 o->op_private |= OPpSORT_REVERSE;
7978 pushmark->op_next = oright->op_next;
7984 /* make @a = sort @a act in-place */
7988 oright = cUNOPx(oright)->op_sibling;
7991 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7992 oright = cUNOPx(oright)->op_sibling;
7996 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7997 || oright->op_next != o
7998 || (oright->op_private & OPpLVAL_INTRO)
8002 /* o2 follows the chain of op_nexts through the LHS of the
8003 * assign (if any) to the aassign op itself */
8005 if (!o2 || o2->op_type != OP_NULL)
8008 if (!o2 || o2->op_type != OP_PUSHMARK)
8011 if (o2 && o2->op_type == OP_GV)
8014 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8015 || (o2->op_private & OPpLVAL_INTRO)
8020 if (!o2 || o2->op_type != OP_NULL)
8023 if (!o2 || o2->op_type != OP_AASSIGN
8024 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8027 /* check that the sort is the first arg on RHS of assign */
8029 o2 = cUNOPx(o2)->op_first;
8030 if (!o2 || o2->op_type != OP_NULL)
8032 o2 = cUNOPx(o2)->op_first;
8033 if (!o2 || o2->op_type != OP_PUSHMARK)
8035 if (o2->op_sibling != o)
8038 /* check the array is the same on both sides */
8039 if (oleft->op_type == OP_RV2AV) {
8040 if (oright->op_type != OP_RV2AV
8041 || !cUNOPx(oright)->op_first
8042 || cUNOPx(oright)->op_first->op_type != OP_GV
8043 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8044 cGVOPx_gv(cUNOPx(oright)->op_first)
8048 else if (oright->op_type != OP_PADAV
8049 || oright->op_targ != oleft->op_targ
8053 /* transfer MODishness etc from LHS arg to RHS arg */
8054 oright->op_flags = oleft->op_flags;
8055 o->op_private |= OPpSORT_INPLACE;
8057 /* excise push->gv->rv2av->null->aassign */
8058 o2 = o->op_next->op_next;
8059 op_null(o2); /* PUSHMARK */
8061 if (o2->op_type == OP_GV) {
8062 op_null(o2); /* GV */
8065 op_null(o2); /* RV2AV or PADAV */
8066 o2 = o2->op_next->op_next;
8067 op_null(o2); /* AASSIGN */
8069 o->op_next = o2->op_next;
8075 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8077 LISTOP *enter, *exlist;
8080 enter = (LISTOP *) o->op_next;
8083 if (enter->op_type == OP_NULL) {
8084 enter = (LISTOP *) enter->op_next;
8088 /* for $a (...) will have OP_GV then OP_RV2GV here.
8089 for (...) just has an OP_GV. */
8090 if (enter->op_type == OP_GV) {
8091 gvop = (OP *) enter;
8092 enter = (LISTOP *) enter->op_next;
8095 if (enter->op_type == OP_RV2GV) {
8096 enter = (LISTOP *) enter->op_next;
8102 if (enter->op_type != OP_ENTERITER)
8105 iter = enter->op_next;
8106 if (!iter || iter->op_type != OP_ITER)
8109 expushmark = enter->op_first;
8110 if (!expushmark || expushmark->op_type != OP_NULL
8111 || expushmark->op_targ != OP_PUSHMARK)
8114 exlist = (LISTOP *) expushmark->op_sibling;
8115 if (!exlist || exlist->op_type != OP_NULL
8116 || exlist->op_targ != OP_LIST)
8119 if (exlist->op_last != o) {
8120 /* Mmm. Was expecting to point back to this op. */
8123 theirmark = exlist->op_first;
8124 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8127 if (theirmark->op_sibling != o) {
8128 /* There's something between the mark and the reverse, eg
8129 for (1, reverse (...))
8134 ourmark = ((LISTOP *)o)->op_first;
8135 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8138 ourlast = ((LISTOP *)o)->op_last;
8139 if (!ourlast || ourlast->op_next != o)
8142 rv2av = ourmark->op_sibling;
8143 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8144 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8145 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8146 /* We're just reversing a single array. */
8147 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8148 enter->op_flags |= OPf_STACKED;
8151 /* We don't have control over who points to theirmark, so sacrifice
8153 theirmark->op_next = ourmark->op_next;
8154 theirmark->op_flags = ourmark->op_flags;
8155 ourlast->op_next = gvop ? gvop : (OP *) enter;
8158 enter->op_private |= OPpITER_REVERSED;
8159 iter->op_private |= OPpITER_REVERSED;
8166 UNOP *refgen, *rv2cv;
8169 /* I do not understand this, but if o->op_opt isn't set to 1,
8170 various tests in ext/B/t/bytecode.t fail with no readily
8176 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8179 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8182 rv2gv = ((BINOP *)o)->op_last;
8183 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8186 refgen = (UNOP *)((BINOP *)o)->op_first;
8188 if (!refgen || refgen->op_type != OP_REFGEN)
8191 exlist = (LISTOP *)refgen->op_first;
8192 if (!exlist || exlist->op_type != OP_NULL
8193 || exlist->op_targ != OP_LIST)
8196 if (exlist->op_first->op_type != OP_PUSHMARK)
8199 rv2cv = (UNOP*)exlist->op_last;
8201 if (rv2cv->op_type != OP_RV2CV)
8204 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8205 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8206 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8208 o->op_private |= OPpASSIGN_CV_TO_GV;
8209 rv2gv->op_private |= OPpDONT_INIT_GV;
8210 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8226 Perl_custom_op_name(pTHX_ const OP* o)
8229 const IV index = PTR2IV(o->op_ppaddr);
8233 if (!PL_custom_op_names) /* This probably shouldn't happen */
8234 return (char *)PL_op_name[OP_CUSTOM];
8236 keysv = sv_2mortal(newSViv(index));
8238 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8240 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8242 return SvPV_nolen(HeVAL(he));
8246 Perl_custom_op_desc(pTHX_ const OP* o)
8249 const IV index = PTR2IV(o->op_ppaddr);
8253 if (!PL_custom_op_descs)
8254 return (char *)PL_op_desc[OP_CUSTOM];
8256 keysv = sv_2mortal(newSViv(index));
8258 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8260 return (char *)PL_op_desc[OP_CUSTOM];
8262 return SvPV_nolen(HeVAL(he));
8267 /* Efficient sub that returns a constant scalar value. */
8269 const_sv_xsub(pTHX_ CV* cv)
8276 Perl_croak(aTHX_ "usage: %s::%s()",
8277 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8281 ST(0) = (SV*)XSANY.any_ptr;
8287 * c-indentation-style: bsd
8289 * indent-tabs-mode: t
8292 * ex: set ts=8 sts=4 sw=4 noet: