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. So we cheat, and take advantage of the
5433 fact that the first 0 bytes of any string always look the same. */
5434 cv = newXS(name, const_sv_xsub, file);
5435 CvXSUBANY(cv).any_ptr = sv;
5437 /* prototype is "". But this gets free()d. :-) */
5438 sv_usepvn_flags((SV*)cv, file, len, SV_HAS_TRAILING_NUL);
5439 /* This gives us a prototype of "", rather than the file name. */
5444 CopSTASH_free(PL_curcop);
5452 =for apidoc U||newXS
5454 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5460 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5463 GV * const gv = gv_fetchpv(name ? name :
5464 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5465 GV_ADDMULTI, SVt_PVCV);
5469 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5471 if ((cv = (name ? GvCV(gv) : NULL))) {
5473 /* just a cached method */
5477 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5478 /* already defined (or promised) */
5479 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5480 if (ckWARN(WARN_REDEFINE)) {
5481 GV * const gvcv = CvGV(cv);
5483 HV * const stash = GvSTASH(gvcv);
5485 const char *redefined_name = HvNAME_get(stash);
5486 if ( strEQ(redefined_name,"autouse") ) {
5487 const line_t oldline = CopLINE(PL_curcop);
5488 if (PL_copline != NOLINE)
5489 CopLINE_set(PL_curcop, PL_copline);
5490 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5491 CvCONST(cv) ? "Constant subroutine %s redefined"
5492 : "Subroutine %s redefined"
5494 CopLINE_set(PL_curcop, oldline);
5504 if (cv) /* must reuse cv if autoloaded */
5508 sv_upgrade((SV *)cv, SVt_PVCV);
5512 PL_sub_generation++;
5516 (void)gv_fetchfile(filename);
5517 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5518 an external constant string */
5520 CvXSUB(cv) = subaddr;
5523 const char *s = strrchr(name,':');
5529 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5532 if (strEQ(s, "BEGIN")) {
5534 PL_beginav = newAV();
5535 av_push(PL_beginav, (SV*)cv);
5536 GvCV(gv) = 0; /* cv has been hijacked */
5538 else if (strEQ(s, "END")) {
5541 av_unshift(PL_endav, 1);
5542 av_store(PL_endav, 0, (SV*)cv);
5543 GvCV(gv) = 0; /* cv has been hijacked */
5545 else if (strEQ(s, "CHECK")) {
5547 PL_checkav = newAV();
5548 if (PL_main_start && ckWARN(WARN_VOID))
5549 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5550 av_unshift(PL_checkav, 1);
5551 av_store(PL_checkav, 0, (SV*)cv);
5552 GvCV(gv) = 0; /* cv has been hijacked */
5554 else if (strEQ(s, "INIT")) {
5556 PL_initav = newAV();
5557 if (PL_main_start && ckWARN(WARN_VOID))
5558 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5559 av_push(PL_initav, (SV*)cv);
5560 GvCV(gv) = 0; /* cv has been hijacked */
5575 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5580 OP* pegop = newOP(OP_NULL, 0);
5584 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5585 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5587 #ifdef GV_UNIQUE_CHECK
5589 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5593 if ((cv = GvFORM(gv))) {
5594 if (ckWARN(WARN_REDEFINE)) {
5595 const line_t oldline = CopLINE(PL_curcop);
5596 if (PL_copline != NOLINE)
5597 CopLINE_set(PL_curcop, PL_copline);
5598 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5599 o ? "Format %"SVf" redefined"
5600 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5601 CopLINE_set(PL_curcop, oldline);
5608 CvFILE_set_from_cop(cv, PL_curcop);
5611 pad_tidy(padtidy_FORMAT);
5612 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5613 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5614 OpREFCNT_set(CvROOT(cv), 1);
5615 CvSTART(cv) = LINKLIST(CvROOT(cv));
5616 CvROOT(cv)->op_next = 0;
5617 CALL_PEEP(CvSTART(cv));
5619 op_getmad(o,pegop,'n');
5620 op_getmad_weak(block, pegop, 'b');
5624 PL_copline = NOLINE;
5632 Perl_newANONLIST(pTHX_ OP *o)
5634 return newUNOP(OP_REFGEN, 0,
5635 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5639 Perl_newANONHASH(pTHX_ OP *o)
5641 return newUNOP(OP_REFGEN, 0,
5642 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5646 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5648 return newANONATTRSUB(floor, proto, NULL, block);
5652 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5654 return newUNOP(OP_REFGEN, 0,
5655 newSVOP(OP_ANONCODE, 0,
5656 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5660 Perl_oopsAV(pTHX_ OP *o)
5663 switch (o->op_type) {
5665 o->op_type = OP_PADAV;
5666 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5667 return ref(o, OP_RV2AV);
5670 o->op_type = OP_RV2AV;
5671 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5676 if (ckWARN_d(WARN_INTERNAL))
5677 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5684 Perl_oopsHV(pTHX_ OP *o)
5687 switch (o->op_type) {
5690 o->op_type = OP_PADHV;
5691 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5692 return ref(o, OP_RV2HV);
5696 o->op_type = OP_RV2HV;
5697 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5702 if (ckWARN_d(WARN_INTERNAL))
5703 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5710 Perl_newAVREF(pTHX_ OP *o)
5713 if (o->op_type == OP_PADANY) {
5714 o->op_type = OP_PADAV;
5715 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5718 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5719 && ckWARN(WARN_DEPRECATED)) {
5720 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5721 "Using an array as a reference is deprecated");
5723 return newUNOP(OP_RV2AV, 0, scalar(o));
5727 Perl_newGVREF(pTHX_ I32 type, OP *o)
5729 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5730 return newUNOP(OP_NULL, 0, o);
5731 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5735 Perl_newHVREF(pTHX_ OP *o)
5738 if (o->op_type == OP_PADANY) {
5739 o->op_type = OP_PADHV;
5740 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5743 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5744 && ckWARN(WARN_DEPRECATED)) {
5745 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5746 "Using a hash as a reference is deprecated");
5748 return newUNOP(OP_RV2HV, 0, scalar(o));
5752 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5754 return newUNOP(OP_RV2CV, flags, scalar(o));
5758 Perl_newSVREF(pTHX_ OP *o)
5761 if (o->op_type == OP_PADANY) {
5762 o->op_type = OP_PADSV;
5763 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5766 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5767 o->op_flags |= OPpDONE_SVREF;
5770 return newUNOP(OP_RV2SV, 0, scalar(o));
5773 /* Check routines. See the comments at the top of this file for details
5774 * on when these are called */
5777 Perl_ck_anoncode(pTHX_ OP *o)
5779 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5781 cSVOPo->op_sv = NULL;
5786 Perl_ck_bitop(pTHX_ OP *o)
5789 #define OP_IS_NUMCOMPARE(op) \
5790 ((op) == OP_LT || (op) == OP_I_LT || \
5791 (op) == OP_GT || (op) == OP_I_GT || \
5792 (op) == OP_LE || (op) == OP_I_LE || \
5793 (op) == OP_GE || (op) == OP_I_GE || \
5794 (op) == OP_EQ || (op) == OP_I_EQ || \
5795 (op) == OP_NE || (op) == OP_I_NE || \
5796 (op) == OP_NCMP || (op) == OP_I_NCMP)
5797 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5798 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5799 && (o->op_type == OP_BIT_OR
5800 || o->op_type == OP_BIT_AND
5801 || o->op_type == OP_BIT_XOR))
5803 const OP * const left = cBINOPo->op_first;
5804 const OP * const right = left->op_sibling;
5805 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5806 (left->op_flags & OPf_PARENS) == 0) ||
5807 (OP_IS_NUMCOMPARE(right->op_type) &&
5808 (right->op_flags & OPf_PARENS) == 0))
5809 if (ckWARN(WARN_PRECEDENCE))
5810 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5811 "Possible precedence problem on bitwise %c operator",
5812 o->op_type == OP_BIT_OR ? '|'
5813 : o->op_type == OP_BIT_AND ? '&' : '^'
5820 Perl_ck_concat(pTHX_ OP *o)
5822 const OP * const kid = cUNOPo->op_first;
5823 PERL_UNUSED_CONTEXT;
5824 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5825 !(kUNOP->op_first->op_flags & OPf_MOD))
5826 o->op_flags |= OPf_STACKED;
5831 Perl_ck_spair(pTHX_ OP *o)
5834 if (o->op_flags & OPf_KIDS) {
5837 const OPCODE type = o->op_type;
5838 o = modkids(ck_fun(o), type);
5839 kid = cUNOPo->op_first;
5840 newop = kUNOP->op_first->op_sibling;
5842 const OPCODE type = newop->op_type;
5843 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5844 type == OP_PADAV || type == OP_PADHV ||
5845 type == OP_RV2AV || type == OP_RV2HV)
5849 op_getmad(kUNOP->op_first,newop,'K');
5851 op_free(kUNOP->op_first);
5853 kUNOP->op_first = newop;
5855 o->op_ppaddr = PL_ppaddr[++o->op_type];
5860 Perl_ck_delete(pTHX_ OP *o)
5864 if (o->op_flags & OPf_KIDS) {
5865 OP * const kid = cUNOPo->op_first;
5866 switch (kid->op_type) {
5868 o->op_flags |= OPf_SPECIAL;
5871 o->op_private |= OPpSLICE;
5874 o->op_flags |= OPf_SPECIAL;
5879 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5888 Perl_ck_die(pTHX_ OP *o)
5891 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5897 Perl_ck_eof(pTHX_ OP *o)
5901 if (o->op_flags & OPf_KIDS) {
5902 if (cLISTOPo->op_first->op_type == OP_STUB) {
5904 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5906 op_getmad(o,newop,'O');
5918 Perl_ck_eval(pTHX_ OP *o)
5921 PL_hints |= HINT_BLOCK_SCOPE;
5922 if (o->op_flags & OPf_KIDS) {
5923 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5926 o->op_flags &= ~OPf_KIDS;
5929 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5935 cUNOPo->op_first = 0;
5940 NewOp(1101, enter, 1, LOGOP);
5941 enter->op_type = OP_ENTERTRY;
5942 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5943 enter->op_private = 0;
5945 /* establish postfix order */
5946 enter->op_next = (OP*)enter;
5948 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5949 o->op_type = OP_LEAVETRY;
5950 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5951 enter->op_other = o;
5952 op_getmad(oldo,o,'O');
5966 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5967 op_getmad(oldo,o,'O');
5969 o->op_targ = (PADOFFSET)PL_hints;
5970 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5971 /* Store a copy of %^H that pp_entereval can pick up */
5972 OP *hhop = newSVOP(OP_CONST, 0,
5973 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
5974 cUNOPo->op_first->op_sibling = hhop;
5975 o->op_private |= OPpEVAL_HAS_HH;
5981 Perl_ck_exit(pTHX_ OP *o)
5984 HV * const table = GvHV(PL_hintgv);
5986 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5987 if (svp && *svp && SvTRUE(*svp))
5988 o->op_private |= OPpEXIT_VMSISH;
5990 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5996 Perl_ck_exec(pTHX_ OP *o)
5998 if (o->op_flags & OPf_STACKED) {
6001 kid = cUNOPo->op_first->op_sibling;
6002 if (kid->op_type == OP_RV2GV)
6011 Perl_ck_exists(pTHX_ OP *o)
6015 if (o->op_flags & OPf_KIDS) {
6016 OP * const kid = cUNOPo->op_first;
6017 if (kid->op_type == OP_ENTERSUB) {
6018 (void) ref(kid, o->op_type);
6019 if (kid->op_type != OP_RV2CV && !PL_error_count)
6020 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6022 o->op_private |= OPpEXISTS_SUB;
6024 else if (kid->op_type == OP_AELEM)
6025 o->op_flags |= OPf_SPECIAL;
6026 else if (kid->op_type != OP_HELEM)
6027 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6035 Perl_ck_rvconst(pTHX_ register OP *o)
6038 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6040 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6041 if (o->op_type == OP_RV2CV)
6042 o->op_private &= ~1;
6044 if (kid->op_type == OP_CONST) {
6047 SV * const kidsv = kid->op_sv;
6049 /* Is it a constant from cv_const_sv()? */
6050 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6051 SV * const rsv = SvRV(kidsv);
6052 const int svtype = SvTYPE(rsv);
6053 const char *badtype = NULL;
6055 switch (o->op_type) {
6057 if (svtype > SVt_PVMG)
6058 badtype = "a SCALAR";
6061 if (svtype != SVt_PVAV)
6062 badtype = "an ARRAY";
6065 if (svtype != SVt_PVHV)
6069 if (svtype != SVt_PVCV)
6074 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6077 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6078 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6079 /* If this is an access to a stash, disable "strict refs", because
6080 * stashes aren't auto-vivified at compile-time (unless we store
6081 * symbols in them), and we don't want to produce a run-time
6082 * stricture error when auto-vivifying the stash. */
6083 const char *s = SvPV_nolen(kidsv);
6084 const STRLEN l = SvCUR(kidsv);
6085 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6086 o->op_private &= ~HINT_STRICT_REFS;
6088 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6089 const char *badthing;
6090 switch (o->op_type) {
6092 badthing = "a SCALAR";
6095 badthing = "an ARRAY";
6098 badthing = "a HASH";
6106 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6107 (void*)kidsv, badthing);
6110 * This is a little tricky. We only want to add the symbol if we
6111 * didn't add it in the lexer. Otherwise we get duplicate strict
6112 * warnings. But if we didn't add it in the lexer, we must at
6113 * least pretend like we wanted to add it even if it existed before,
6114 * or we get possible typo warnings. OPpCONST_ENTERED says
6115 * whether the lexer already added THIS instance of this symbol.
6117 iscv = (o->op_type == OP_RV2CV) * 2;
6119 gv = gv_fetchsv(kidsv,
6120 iscv | !(kid->op_private & OPpCONST_ENTERED),
6123 : o->op_type == OP_RV2SV
6125 : o->op_type == OP_RV2AV
6127 : o->op_type == OP_RV2HV
6130 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6132 kid->op_type = OP_GV;
6133 SvREFCNT_dec(kid->op_sv);
6135 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6136 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6137 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6139 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6141 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6143 kid->op_private = 0;
6144 kid->op_ppaddr = PL_ppaddr[OP_GV];
6151 Perl_ck_ftst(pTHX_ OP *o)
6154 const I32 type = o->op_type;
6156 if (o->op_flags & OPf_REF) {
6159 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6160 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6161 const OPCODE kidtype = kid->op_type;
6163 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6164 OP * const newop = newGVOP(type, OPf_REF,
6165 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6167 op_getmad(o,newop,'O');
6173 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6174 o->op_private |= OPpFT_ACCESS;
6175 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6176 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6177 o->op_private |= OPpFT_STACKED;
6185 if (type == OP_FTTTY)
6186 o = newGVOP(type, OPf_REF, PL_stdingv);
6188 o = newUNOP(type, 0, newDEFSVOP());
6189 op_getmad(oldo,o,'O');
6195 Perl_ck_fun(pTHX_ OP *o)
6198 const int type = o->op_type;
6199 register I32 oa = PL_opargs[type] >> OASHIFT;
6201 if (o->op_flags & OPf_STACKED) {
6202 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6205 return no_fh_allowed(o);
6208 if (o->op_flags & OPf_KIDS) {
6209 OP **tokid = &cLISTOPo->op_first;
6210 register OP *kid = cLISTOPo->op_first;
6214 if (kid->op_type == OP_PUSHMARK ||
6215 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6217 tokid = &kid->op_sibling;
6218 kid = kid->op_sibling;
6220 if (!kid && PL_opargs[type] & OA_DEFGV)
6221 *tokid = kid = newDEFSVOP();
6225 sibl = kid->op_sibling;
6227 if (!sibl && kid->op_type == OP_STUB) {
6234 /* list seen where single (scalar) arg expected? */
6235 if (numargs == 1 && !(oa >> 4)
6236 && kid->op_type == OP_LIST && type != OP_SCALAR)
6238 return too_many_arguments(o,PL_op_desc[type]);
6251 if ((type == OP_PUSH || type == OP_UNSHIFT)
6252 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6253 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6254 "Useless use of %s with no values",
6257 if (kid->op_type == OP_CONST &&
6258 (kid->op_private & OPpCONST_BARE))
6260 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6261 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6262 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6263 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6264 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6265 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6267 op_getmad(kid,newop,'K');
6272 kid->op_sibling = sibl;
6275 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6276 bad_type(numargs, "array", PL_op_desc[type], kid);
6280 if (kid->op_type == OP_CONST &&
6281 (kid->op_private & OPpCONST_BARE))
6283 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6284 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6285 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6286 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6287 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6288 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6290 op_getmad(kid,newop,'K');
6295 kid->op_sibling = sibl;
6298 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6299 bad_type(numargs, "hash", PL_op_desc[type], kid);
6304 OP * const newop = newUNOP(OP_NULL, 0, kid);
6305 kid->op_sibling = 0;
6307 newop->op_next = newop;
6309 kid->op_sibling = sibl;
6314 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6315 if (kid->op_type == OP_CONST &&
6316 (kid->op_private & OPpCONST_BARE))
6318 OP * const newop = newGVOP(OP_GV, 0,
6319 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6320 if (!(o->op_private & 1) && /* if not unop */
6321 kid == cLISTOPo->op_last)
6322 cLISTOPo->op_last = newop;
6324 op_getmad(kid,newop,'K');
6330 else if (kid->op_type == OP_READLINE) {
6331 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6332 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6335 I32 flags = OPf_SPECIAL;
6339 /* is this op a FH constructor? */
6340 if (is_handle_constructor(o,numargs)) {
6341 const char *name = NULL;
6345 /* Set a flag to tell rv2gv to vivify
6346 * need to "prove" flag does not mean something
6347 * else already - NI-S 1999/05/07
6350 if (kid->op_type == OP_PADSV) {
6351 name = PAD_COMPNAME_PV(kid->op_targ);
6352 /* SvCUR of a pad namesv can't be trusted
6353 * (see PL_generation), so calc its length
6359 else if (kid->op_type == OP_RV2SV
6360 && kUNOP->op_first->op_type == OP_GV)
6362 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6364 len = GvNAMELEN(gv);
6366 else if (kid->op_type == OP_AELEM
6367 || kid->op_type == OP_HELEM)
6369 OP *op = ((BINOP*)kid)->op_first;
6373 const char * const a =
6374 kid->op_type == OP_AELEM ?
6376 if (((op->op_type == OP_RV2AV) ||
6377 (op->op_type == OP_RV2HV)) &&
6378 (op = ((UNOP*)op)->op_first) &&
6379 (op->op_type == OP_GV)) {
6380 /* packagevar $a[] or $h{} */
6381 GV * const gv = cGVOPx_gv(op);
6389 else if (op->op_type == OP_PADAV
6390 || op->op_type == OP_PADHV) {
6391 /* lexicalvar $a[] or $h{} */
6392 const char * const padname =
6393 PAD_COMPNAME_PV(op->op_targ);
6402 name = SvPV_const(tmpstr, len);
6407 name = "__ANONIO__";
6414 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6415 namesv = PAD_SVl(targ);
6416 SvUPGRADE(namesv, SVt_PV);
6418 sv_setpvn(namesv, "$", 1);
6419 sv_catpvn(namesv, name, len);
6422 kid->op_sibling = 0;
6423 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6424 kid->op_targ = targ;
6425 kid->op_private |= priv;
6427 kid->op_sibling = sibl;
6433 mod(scalar(kid), type);
6437 tokid = &kid->op_sibling;
6438 kid = kid->op_sibling;
6441 if (kid && kid->op_type != OP_STUB)
6442 return too_many_arguments(o,OP_DESC(o));
6443 o->op_private |= numargs;
6445 /* FIXME - should the numargs move as for the PERL_MAD case? */
6446 o->op_private |= numargs;
6448 return too_many_arguments(o,OP_DESC(o));
6452 else if (PL_opargs[type] & OA_DEFGV) {
6454 OP *newop = newUNOP(type, 0, newDEFSVOP());
6455 op_getmad(o,newop,'O');
6458 /* Ordering of these two is important to keep f_map.t passing. */
6460 return newUNOP(type, 0, newDEFSVOP());
6465 while (oa & OA_OPTIONAL)
6467 if (oa && oa != OA_LIST)
6468 return too_few_arguments(o,OP_DESC(o));
6474 Perl_ck_glob(pTHX_ OP *o)
6480 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6481 append_elem(OP_GLOB, o, newDEFSVOP());
6483 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6484 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6486 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6489 #if !defined(PERL_EXTERNAL_GLOB)
6490 /* XXX this can be tightened up and made more failsafe. */
6491 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6494 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6495 newSVpvs("File::Glob"), NULL, NULL, NULL);
6496 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6497 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6498 GvCV(gv) = GvCV(glob_gv);
6499 SvREFCNT_inc_void((SV*)GvCV(gv));
6500 GvIMPORTED_CV_on(gv);
6503 #endif /* PERL_EXTERNAL_GLOB */
6505 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6506 append_elem(OP_GLOB, o,
6507 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6508 o->op_type = OP_LIST;
6509 o->op_ppaddr = PL_ppaddr[OP_LIST];
6510 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6511 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6512 cLISTOPo->op_first->op_targ = 0;
6513 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6514 append_elem(OP_LIST, o,
6515 scalar(newUNOP(OP_RV2CV, 0,
6516 newGVOP(OP_GV, 0, gv)))));
6517 o = newUNOP(OP_NULL, 0, ck_subr(o));
6518 o->op_targ = OP_GLOB; /* hint at what it used to be */
6521 gv = newGVgen("main");
6523 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6529 Perl_ck_grep(pTHX_ OP *o)
6534 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6537 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6538 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6540 if (o->op_flags & OPf_STACKED) {
6543 kid = cLISTOPo->op_first->op_sibling;
6544 if (!cUNOPx(kid)->op_next)
6545 Perl_croak(aTHX_ "panic: ck_grep");
6546 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6549 NewOp(1101, gwop, 1, LOGOP);
6550 kid->op_next = (OP*)gwop;
6551 o->op_flags &= ~OPf_STACKED;
6553 kid = cLISTOPo->op_first->op_sibling;
6554 if (type == OP_MAPWHILE)
6561 kid = cLISTOPo->op_first->op_sibling;
6562 if (kid->op_type != OP_NULL)
6563 Perl_croak(aTHX_ "panic: ck_grep");
6564 kid = kUNOP->op_first;
6567 NewOp(1101, gwop, 1, LOGOP);
6568 gwop->op_type = type;
6569 gwop->op_ppaddr = PL_ppaddr[type];
6570 gwop->op_first = listkids(o);
6571 gwop->op_flags |= OPf_KIDS;
6572 gwop->op_other = LINKLIST(kid);
6573 kid->op_next = (OP*)gwop;
6574 offset = pad_findmy("$_");
6575 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6576 o->op_private = gwop->op_private = 0;
6577 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6580 o->op_private = gwop->op_private = OPpGREP_LEX;
6581 gwop->op_targ = o->op_targ = offset;
6584 kid = cLISTOPo->op_first->op_sibling;
6585 if (!kid || !kid->op_sibling)
6586 return too_few_arguments(o,OP_DESC(o));
6587 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6588 mod(kid, OP_GREPSTART);
6594 Perl_ck_index(pTHX_ OP *o)
6596 if (o->op_flags & OPf_KIDS) {
6597 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6599 kid = kid->op_sibling; /* get past "big" */
6600 if (kid && kid->op_type == OP_CONST)
6601 fbm_compile(((SVOP*)kid)->op_sv, 0);
6607 Perl_ck_lengthconst(pTHX_ OP *o)
6609 /* XXX length optimization goes here */
6614 Perl_ck_lfun(pTHX_ OP *o)
6616 const OPCODE type = o->op_type;
6617 return modkids(ck_fun(o), type);
6621 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6623 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6624 switch (cUNOPo->op_first->op_type) {
6626 /* This is needed for
6627 if (defined %stash::)
6628 to work. Do not break Tk.
6630 break; /* Globals via GV can be undef */
6632 case OP_AASSIGN: /* Is this a good idea? */
6633 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6634 "defined(@array) is deprecated");
6635 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6636 "\t(Maybe you should just omit the defined()?)\n");
6639 /* This is needed for
6640 if (defined %stash::)
6641 to work. Do not break Tk.
6643 break; /* Globals via GV can be undef */
6645 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6646 "defined(%%hash) is deprecated");
6647 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6648 "\t(Maybe you should just omit the defined()?)\n");
6659 Perl_ck_rfun(pTHX_ OP *o)
6661 const OPCODE type = o->op_type;
6662 return refkids(ck_fun(o), type);
6666 Perl_ck_listiob(pTHX_ OP *o)
6670 kid = cLISTOPo->op_first;
6673 kid = cLISTOPo->op_first;
6675 if (kid->op_type == OP_PUSHMARK)
6676 kid = kid->op_sibling;
6677 if (kid && o->op_flags & OPf_STACKED)
6678 kid = kid->op_sibling;
6679 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6680 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6681 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6682 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6683 cLISTOPo->op_first->op_sibling = kid;
6684 cLISTOPo->op_last = kid;
6685 kid = kid->op_sibling;
6690 append_elem(o->op_type, o, newDEFSVOP());
6696 Perl_ck_say(pTHX_ OP *o)
6699 o->op_type = OP_PRINT;
6700 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6701 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6706 Perl_ck_smartmatch(pTHX_ OP *o)
6709 if (0 == (o->op_flags & OPf_SPECIAL)) {
6710 OP *first = cBINOPo->op_first;
6711 OP *second = first->op_sibling;
6713 /* Implicitly take a reference to an array or hash */
6714 first->op_sibling = NULL;
6715 first = cBINOPo->op_first = ref_array_or_hash(first);
6716 second = first->op_sibling = ref_array_or_hash(second);
6718 /* Implicitly take a reference to a regular expression */
6719 if (first->op_type == OP_MATCH) {
6720 first->op_type = OP_QR;
6721 first->op_ppaddr = PL_ppaddr[OP_QR];
6723 if (second->op_type == OP_MATCH) {
6724 second->op_type = OP_QR;
6725 second->op_ppaddr = PL_ppaddr[OP_QR];
6734 Perl_ck_sassign(pTHX_ OP *o)
6736 OP * const kid = cLISTOPo->op_first;
6737 /* has a disposable target? */
6738 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6739 && !(kid->op_flags & OPf_STACKED)
6740 /* Cannot steal the second time! */
6741 && !(kid->op_private & OPpTARGET_MY))
6743 OP * const kkid = kid->op_sibling;
6745 /* Can just relocate the target. */
6746 if (kkid && kkid->op_type == OP_PADSV
6747 && !(kkid->op_private & OPpLVAL_INTRO))
6749 kid->op_targ = kkid->op_targ;
6751 /* Now we do not need PADSV and SASSIGN. */
6752 kid->op_sibling = o->op_sibling; /* NULL */
6753 cLISTOPo->op_first = NULL;
6755 op_getmad(o,kid,'O');
6756 op_getmad(kkid,kid,'M');
6761 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6769 Perl_ck_match(pTHX_ OP *o)
6772 if (o->op_type != OP_QR && PL_compcv) {
6773 const PADOFFSET offset = pad_findmy("$_");
6774 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6775 o->op_targ = offset;
6776 o->op_private |= OPpTARGET_MY;
6779 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6780 o->op_private |= OPpRUNTIME;
6785 Perl_ck_method(pTHX_ OP *o)
6787 OP * const kid = cUNOPo->op_first;
6788 if (kid->op_type == OP_CONST) {
6789 SV* sv = kSVOP->op_sv;
6790 const char * const method = SvPVX_const(sv);
6791 if (!(strchr(method, ':') || strchr(method, '\''))) {
6793 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6794 sv = newSVpvn_share(method, SvCUR(sv), 0);
6797 kSVOP->op_sv = NULL;
6799 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6801 op_getmad(o,cmop,'O');
6812 Perl_ck_null(pTHX_ OP *o)
6814 PERL_UNUSED_CONTEXT;
6819 Perl_ck_open(pTHX_ OP *o)
6822 HV * const table = GvHV(PL_hintgv);
6824 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6826 const I32 mode = mode_from_discipline(*svp);
6827 if (mode & O_BINARY)
6828 o->op_private |= OPpOPEN_IN_RAW;
6829 else if (mode & O_TEXT)
6830 o->op_private |= OPpOPEN_IN_CRLF;
6833 svp = hv_fetchs(table, "open_OUT", FALSE);
6835 const I32 mode = mode_from_discipline(*svp);
6836 if (mode & O_BINARY)
6837 o->op_private |= OPpOPEN_OUT_RAW;
6838 else if (mode & O_TEXT)
6839 o->op_private |= OPpOPEN_OUT_CRLF;
6842 if (o->op_type == OP_BACKTICK)
6845 /* In case of three-arg dup open remove strictness
6846 * from the last arg if it is a bareword. */
6847 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6848 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6852 if ((last->op_type == OP_CONST) && /* The bareword. */
6853 (last->op_private & OPpCONST_BARE) &&
6854 (last->op_private & OPpCONST_STRICT) &&
6855 (oa = first->op_sibling) && /* The fh. */
6856 (oa = oa->op_sibling) && /* The mode. */
6857 (oa->op_type == OP_CONST) &&
6858 SvPOK(((SVOP*)oa)->op_sv) &&
6859 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6860 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6861 (last == oa->op_sibling)) /* The bareword. */
6862 last->op_private &= ~OPpCONST_STRICT;
6868 Perl_ck_repeat(pTHX_ OP *o)
6870 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6871 o->op_private |= OPpREPEAT_DOLIST;
6872 cBINOPo->op_first = force_list(cBINOPo->op_first);
6880 Perl_ck_require(pTHX_ OP *o)
6885 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6886 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6888 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6889 SV * const sv = kid->op_sv;
6890 U32 was_readonly = SvREADONLY(sv);
6895 sv_force_normal_flags(sv, 0);
6896 assert(!SvREADONLY(sv));
6903 for (s = SvPVX(sv); *s; s++) {
6904 if (*s == ':' && s[1] == ':') {
6905 const STRLEN len = strlen(s+2)+1;
6907 Move(s+2, s+1, len, char);
6908 SvCUR_set(sv, SvCUR(sv) - 1);
6911 sv_catpvs(sv, ".pm");
6912 SvFLAGS(sv) |= was_readonly;
6916 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6917 /* handle override, if any */
6918 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6919 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6920 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6921 gv = gvp ? *gvp : NULL;
6925 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6926 OP * const kid = cUNOPo->op_first;
6929 cUNOPo->op_first = 0;
6933 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6934 append_elem(OP_LIST, kid,
6935 scalar(newUNOP(OP_RV2CV, 0,
6938 op_getmad(o,newop,'O');
6946 Perl_ck_return(pTHX_ OP *o)
6949 if (CvLVALUE(PL_compcv)) {
6951 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6952 mod(kid, OP_LEAVESUBLV);
6958 Perl_ck_select(pTHX_ OP *o)
6962 if (o->op_flags & OPf_KIDS) {
6963 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6964 if (kid && kid->op_sibling) {
6965 o->op_type = OP_SSELECT;
6966 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6968 return fold_constants(o);
6972 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6973 if (kid && kid->op_type == OP_RV2GV)
6974 kid->op_private &= ~HINT_STRICT_REFS;
6979 Perl_ck_shift(pTHX_ OP *o)
6982 const I32 type = o->op_type;
6984 if (!(o->op_flags & OPf_KIDS)) {
6986 /* FIXME - this can be refactored to reduce code in #ifdefs */
6988 OP * const oldo = o;
6992 argop = newUNOP(OP_RV2AV, 0,
6993 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6995 o = newUNOP(type, 0, scalar(argop));
6996 op_getmad(oldo,o,'O');
6999 return newUNOP(type, 0, scalar(argop));
7002 return scalar(modkids(ck_fun(o), type));
7006 Perl_ck_sort(pTHX_ OP *o)
7011 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7012 HV * const hinthv = GvHV(PL_hintgv);
7014 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7016 const I32 sorthints = (I32)SvIV(*svp);
7017 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7018 o->op_private |= OPpSORT_QSORT;
7019 if ((sorthints & HINT_SORT_STABLE) != 0)
7020 o->op_private |= OPpSORT_STABLE;
7025 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7027 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7028 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7030 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7032 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7034 if (kid->op_type == OP_SCOPE) {
7038 else if (kid->op_type == OP_LEAVE) {
7039 if (o->op_type == OP_SORT) {
7040 op_null(kid); /* wipe out leave */
7043 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7044 if (k->op_next == kid)
7046 /* don't descend into loops */
7047 else if (k->op_type == OP_ENTERLOOP
7048 || k->op_type == OP_ENTERITER)
7050 k = cLOOPx(k)->op_lastop;
7055 kid->op_next = 0; /* just disconnect the leave */
7056 k = kLISTOP->op_first;
7061 if (o->op_type == OP_SORT) {
7062 /* provide scalar context for comparison function/block */
7068 o->op_flags |= OPf_SPECIAL;
7070 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7073 firstkid = firstkid->op_sibling;
7076 /* provide list context for arguments */
7077 if (o->op_type == OP_SORT)
7084 S_simplify_sort(pTHX_ OP *o)
7087 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7092 if (!(o->op_flags & OPf_STACKED))
7094 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7095 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7096 kid = kUNOP->op_first; /* get past null */
7097 if (kid->op_type != OP_SCOPE)
7099 kid = kLISTOP->op_last; /* get past scope */
7100 switch(kid->op_type) {
7108 k = kid; /* remember this node*/
7109 if (kBINOP->op_first->op_type != OP_RV2SV)
7111 kid = kBINOP->op_first; /* get past cmp */
7112 if (kUNOP->op_first->op_type != OP_GV)
7114 kid = kUNOP->op_first; /* get past rv2sv */
7116 if (GvSTASH(gv) != PL_curstash)
7118 gvname = GvNAME(gv);
7119 if (*gvname == 'a' && gvname[1] == '\0')
7121 else if (*gvname == 'b' && gvname[1] == '\0')
7126 kid = k; /* back to cmp */
7127 if (kBINOP->op_last->op_type != OP_RV2SV)
7129 kid = kBINOP->op_last; /* down to 2nd arg */
7130 if (kUNOP->op_first->op_type != OP_GV)
7132 kid = kUNOP->op_first; /* get past rv2sv */
7134 if (GvSTASH(gv) != PL_curstash)
7136 gvname = GvNAME(gv);
7138 ? !(*gvname == 'a' && gvname[1] == '\0')
7139 : !(*gvname == 'b' && gvname[1] == '\0'))
7141 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7143 o->op_private |= OPpSORT_DESCEND;
7144 if (k->op_type == OP_NCMP)
7145 o->op_private |= OPpSORT_NUMERIC;
7146 if (k->op_type == OP_I_NCMP)
7147 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7148 kid = cLISTOPo->op_first->op_sibling;
7149 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7151 op_getmad(kid,o,'S'); /* then delete it */
7153 op_free(kid); /* then delete it */
7158 Perl_ck_split(pTHX_ OP *o)
7163 if (o->op_flags & OPf_STACKED)
7164 return no_fh_allowed(o);
7166 kid = cLISTOPo->op_first;
7167 if (kid->op_type != OP_NULL)
7168 Perl_croak(aTHX_ "panic: ck_split");
7169 kid = kid->op_sibling;
7170 op_free(cLISTOPo->op_first);
7171 cLISTOPo->op_first = kid;
7173 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7174 cLISTOPo->op_last = kid; /* There was only one element previously */
7177 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7178 OP * const sibl = kid->op_sibling;
7179 kid->op_sibling = 0;
7180 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7181 if (cLISTOPo->op_first == cLISTOPo->op_last)
7182 cLISTOPo->op_last = kid;
7183 cLISTOPo->op_first = kid;
7184 kid->op_sibling = sibl;
7187 kid->op_type = OP_PUSHRE;
7188 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7190 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7191 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7192 "Use of /g modifier is meaningless in split");
7195 if (!kid->op_sibling)
7196 append_elem(OP_SPLIT, o, newDEFSVOP());
7198 kid = kid->op_sibling;
7201 if (!kid->op_sibling)
7202 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7203 assert(kid->op_sibling);
7205 kid = kid->op_sibling;
7208 if (kid->op_sibling)
7209 return too_many_arguments(o,OP_DESC(o));
7215 Perl_ck_join(pTHX_ OP *o)
7217 const OP * const kid = cLISTOPo->op_first->op_sibling;
7218 if (kid && kid->op_type == OP_MATCH) {
7219 if (ckWARN(WARN_SYNTAX)) {
7220 const REGEXP *re = PM_GETRE(kPMOP);
7221 const char *pmstr = re ? re->precomp : "STRING";
7222 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7223 "/%s/ should probably be written as \"%s\"",
7231 Perl_ck_subr(pTHX_ OP *o)
7234 OP *prev = ((cUNOPo->op_first->op_sibling)
7235 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7236 OP *o2 = prev->op_sibling;
7238 const char *proto = NULL;
7239 const char *proto_end = NULL;
7244 I32 contextclass = 0;
7248 o->op_private |= OPpENTERSUB_HASTARG;
7249 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7250 if (cvop->op_type == OP_RV2CV) {
7252 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7253 op_null(cvop); /* disable rv2cv */
7254 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7255 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7256 GV *gv = cGVOPx_gv(tmpop);
7259 tmpop->op_private |= OPpEARLY_CV;
7263 namegv = CvANON(cv) ? gv : CvGV(cv);
7264 proto = SvPV((SV*)cv, len);
7265 proto_end = proto + len;
7267 if (CvASSERTION(cv)) {
7268 if (PL_hints & HINT_ASSERTING) {
7269 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7270 o->op_private |= OPpENTERSUB_DB;
7274 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7275 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7276 "Impossible to activate assertion call");
7283 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7284 if (o2->op_type == OP_CONST)
7285 o2->op_private &= ~OPpCONST_STRICT;
7286 else if (o2->op_type == OP_LIST) {
7287 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7288 if (sib && sib->op_type == OP_CONST)
7289 sib->op_private &= ~OPpCONST_STRICT;
7292 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7293 if (PERLDB_SUB && PL_curstash != PL_debstash)
7294 o->op_private |= OPpENTERSUB_DB;
7295 while (o2 != cvop) {
7297 if (PL_madskills && o2->op_type == OP_NULL)
7298 o3 = ((UNOP*)o2)->op_first;
7302 if (proto >= proto_end)
7303 return too_many_arguments(o, gv_ename(namegv));
7323 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7325 arg == 1 ? "block or sub {}" : "sub {}",
7326 gv_ename(namegv), o3);
7329 /* '*' allows any scalar type, including bareword */
7332 if (o3->op_type == OP_RV2GV)
7333 goto wrapref; /* autoconvert GLOB -> GLOBref */
7334 else if (o3->op_type == OP_CONST)
7335 o3->op_private &= ~OPpCONST_STRICT;
7336 else if (o3->op_type == OP_ENTERSUB) {
7337 /* accidental subroutine, revert to bareword */
7338 OP *gvop = ((UNOP*)o3)->op_first;
7339 if (gvop && gvop->op_type == OP_NULL) {
7340 gvop = ((UNOP*)gvop)->op_first;
7342 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7345 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7346 (gvop = ((UNOP*)gvop)->op_first) &&
7347 gvop->op_type == OP_GV)
7349 GV * const gv = cGVOPx_gv(gvop);
7350 OP * const sibling = o2->op_sibling;
7351 SV * const n = newSVpvs("");
7353 OP * const oldo2 = o2;
7357 gv_fullname4(n, gv, "", FALSE);
7358 o2 = newSVOP(OP_CONST, 0, n);
7359 op_getmad(oldo2,o2,'O');
7360 prev->op_sibling = o2;
7361 o2->op_sibling = sibling;
7377 if (contextclass++ == 0) {
7378 e = strchr(proto, ']');
7379 if (!e || e == proto)
7388 const char *p = proto;
7389 const char *const end = proto;
7391 while (*--p != '[');
7392 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7394 gv_ename(namegv), o3);
7399 if (o3->op_type == OP_RV2GV)
7402 bad_type(arg, "symbol", gv_ename(namegv), o3);
7405 if (o3->op_type == OP_ENTERSUB)
7408 bad_type(arg, "subroutine entry", gv_ename(namegv),
7412 if (o3->op_type == OP_RV2SV ||
7413 o3->op_type == OP_PADSV ||
7414 o3->op_type == OP_HELEM ||
7415 o3->op_type == OP_AELEM ||
7416 o3->op_type == OP_THREADSV)
7419 bad_type(arg, "scalar", gv_ename(namegv), o3);
7422 if (o3->op_type == OP_RV2AV ||
7423 o3->op_type == OP_PADAV)
7426 bad_type(arg, "array", gv_ename(namegv), o3);
7429 if (o3->op_type == OP_RV2HV ||
7430 o3->op_type == OP_PADHV)
7433 bad_type(arg, "hash", gv_ename(namegv), o3);
7438 OP* const sib = kid->op_sibling;
7439 kid->op_sibling = 0;
7440 o2 = newUNOP(OP_REFGEN, 0, kid);
7441 o2->op_sibling = sib;
7442 prev->op_sibling = o2;
7444 if (contextclass && e) {
7459 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7460 gv_ename(namegv), (void*)cv);
7465 mod(o2, OP_ENTERSUB);
7467 o2 = o2->op_sibling;
7469 if (proto && !optional && proto_end > proto &&
7470 (*proto != '@' && *proto != '%' && *proto != ';'))
7471 return too_few_arguments(o, gv_ename(namegv));
7474 OP * const oldo = o;
7478 o=newSVOP(OP_CONST, 0, newSViv(0));
7479 op_getmad(oldo,o,'O');
7485 Perl_ck_svconst(pTHX_ OP *o)
7487 PERL_UNUSED_CONTEXT;
7488 SvREADONLY_on(cSVOPo->op_sv);
7493 Perl_ck_chdir(pTHX_ OP *o)
7495 if (o->op_flags & OPf_KIDS) {
7496 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7498 if (kid && kid->op_type == OP_CONST &&
7499 (kid->op_private & OPpCONST_BARE))
7501 o->op_flags |= OPf_SPECIAL;
7502 kid->op_private &= ~OPpCONST_STRICT;
7509 Perl_ck_trunc(pTHX_ OP *o)
7511 if (o->op_flags & OPf_KIDS) {
7512 SVOP *kid = (SVOP*)cUNOPo->op_first;
7514 if (kid->op_type == OP_NULL)
7515 kid = (SVOP*)kid->op_sibling;
7516 if (kid && kid->op_type == OP_CONST &&
7517 (kid->op_private & OPpCONST_BARE))
7519 o->op_flags |= OPf_SPECIAL;
7520 kid->op_private &= ~OPpCONST_STRICT;
7527 Perl_ck_unpack(pTHX_ OP *o)
7529 OP *kid = cLISTOPo->op_first;
7530 if (kid->op_sibling) {
7531 kid = kid->op_sibling;
7532 if (!kid->op_sibling)
7533 kid->op_sibling = newDEFSVOP();
7539 Perl_ck_substr(pTHX_ OP *o)
7542 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7543 OP *kid = cLISTOPo->op_first;
7545 if (kid->op_type == OP_NULL)
7546 kid = kid->op_sibling;
7548 kid->op_flags |= OPf_MOD;
7554 /* A peephole optimizer. We visit the ops in the order they're to execute.
7555 * See the comments at the top of this file for more details about when
7556 * peep() is called */
7559 Perl_peep(pTHX_ register OP *o)
7562 register OP* oldop = NULL;
7564 if (!o || o->op_opt)
7568 SAVEVPTR(PL_curcop);
7569 for (; o; o = o->op_next) {
7573 switch (o->op_type) {
7577 PL_curcop = ((COP*)o); /* for warnings */
7582 if (cSVOPo->op_private & OPpCONST_STRICT)
7583 no_bareword_allowed(o);
7585 case OP_METHOD_NAMED:
7586 /* Relocate sv to the pad for thread safety.
7587 * Despite being a "constant", the SV is written to,
7588 * for reference counts, sv_upgrade() etc. */
7590 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7591 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7592 /* If op_sv is already a PADTMP then it is being used by
7593 * some pad, so make a copy. */
7594 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7595 SvREADONLY_on(PAD_SVl(ix));
7596 SvREFCNT_dec(cSVOPo->op_sv);
7598 else if (o->op_type == OP_CONST
7599 && cSVOPo->op_sv == &PL_sv_undef) {
7600 /* PL_sv_undef is hack - it's unsafe to store it in the
7601 AV that is the pad, because av_fetch treats values of
7602 PL_sv_undef as a "free" AV entry and will merrily
7603 replace them with a new SV, causing pad_alloc to think
7604 that this pad slot is free. (When, clearly, it is not)
7606 SvOK_off(PAD_SVl(ix));
7607 SvPADTMP_on(PAD_SVl(ix));
7608 SvREADONLY_on(PAD_SVl(ix));
7611 SvREFCNT_dec(PAD_SVl(ix));
7612 SvPADTMP_on(cSVOPo->op_sv);
7613 PAD_SETSV(ix, cSVOPo->op_sv);
7614 /* XXX I don't know how this isn't readonly already. */
7615 SvREADONLY_on(PAD_SVl(ix));
7617 cSVOPo->op_sv = NULL;
7625 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7626 if (o->op_next->op_private & OPpTARGET_MY) {
7627 if (o->op_flags & OPf_STACKED) /* chained concats */
7628 goto ignore_optimization;
7630 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7631 o->op_targ = o->op_next->op_targ;
7632 o->op_next->op_targ = 0;
7633 o->op_private |= OPpTARGET_MY;
7636 op_null(o->op_next);
7638 ignore_optimization:
7642 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7644 break; /* Scalar stub must produce undef. List stub is noop */
7648 if (o->op_targ == OP_NEXTSTATE
7649 || o->op_targ == OP_DBSTATE
7650 || o->op_targ == OP_SETSTATE)
7652 PL_curcop = ((COP*)o);
7654 /* XXX: We avoid setting op_seq here to prevent later calls
7655 to peep() from mistakenly concluding that optimisation
7656 has already occurred. This doesn't fix the real problem,
7657 though (See 20010220.007). AMS 20010719 */
7658 /* op_seq functionality is now replaced by op_opt */
7659 if (oldop && o->op_next) {
7660 oldop->op_next = o->op_next;
7668 if (oldop && o->op_next) {
7669 oldop->op_next = o->op_next;
7677 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7678 OP* const pop = (o->op_type == OP_PADAV) ?
7679 o->op_next : o->op_next->op_next;
7681 if (pop && pop->op_type == OP_CONST &&
7682 ((PL_op = pop->op_next)) &&
7683 pop->op_next->op_type == OP_AELEM &&
7684 !(pop->op_next->op_private &
7685 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7686 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7691 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7692 no_bareword_allowed(pop);
7693 if (o->op_type == OP_GV)
7694 op_null(o->op_next);
7695 op_null(pop->op_next);
7697 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7698 o->op_next = pop->op_next->op_next;
7699 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7700 o->op_private = (U8)i;
7701 if (o->op_type == OP_GV) {
7706 o->op_flags |= OPf_SPECIAL;
7707 o->op_type = OP_AELEMFAST;
7713 if (o->op_next->op_type == OP_RV2SV) {
7714 if (!(o->op_next->op_private & OPpDEREF)) {
7715 op_null(o->op_next);
7716 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7718 o->op_next = o->op_next->op_next;
7719 o->op_type = OP_GVSV;
7720 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7723 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7724 GV * const gv = cGVOPo_gv;
7725 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7726 /* XXX could check prototype here instead of just carping */
7727 SV * const sv = sv_newmortal();
7728 gv_efullname3(sv, gv, NULL);
7729 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7730 "%"SVf"() called too early to check prototype",
7734 else if (o->op_next->op_type == OP_READLINE
7735 && o->op_next->op_next->op_type == OP_CONCAT
7736 && (o->op_next->op_next->op_flags & OPf_STACKED))
7738 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7739 o->op_type = OP_RCATLINE;
7740 o->op_flags |= OPf_STACKED;
7741 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7742 op_null(o->op_next->op_next);
7743 op_null(o->op_next);
7760 while (cLOGOP->op_other->op_type == OP_NULL)
7761 cLOGOP->op_other = cLOGOP->op_other->op_next;
7762 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7768 while (cLOOP->op_redoop->op_type == OP_NULL)
7769 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7770 peep(cLOOP->op_redoop);
7771 while (cLOOP->op_nextop->op_type == OP_NULL)
7772 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7773 peep(cLOOP->op_nextop);
7774 while (cLOOP->op_lastop->op_type == OP_NULL)
7775 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7776 peep(cLOOP->op_lastop);
7783 while (cPMOP->op_pmreplstart &&
7784 cPMOP->op_pmreplstart->op_type == OP_NULL)
7785 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7786 peep(cPMOP->op_pmreplstart);
7791 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7792 && ckWARN(WARN_SYNTAX))
7794 if (o->op_next->op_sibling) {
7795 const OPCODE type = o->op_next->op_sibling->op_type;
7796 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7797 const line_t oldline = CopLINE(PL_curcop);
7798 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7799 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7800 "Statement unlikely to be reached");
7801 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7802 "\t(Maybe you meant system() when you said exec()?)\n");
7803 CopLINE_set(PL_curcop, oldline);
7814 const char *key = NULL;
7819 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7822 /* Make the CONST have a shared SV */
7823 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7824 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7825 key = SvPV_const(sv, keylen);
7826 lexname = newSVpvn_share(key,
7827 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7833 if ((o->op_private & (OPpLVAL_INTRO)))
7836 rop = (UNOP*)((BINOP*)o)->op_first;
7837 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7839 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7840 if (!SvPAD_TYPED(lexname))
7842 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7843 if (!fields || !GvHV(*fields))
7845 key = SvPV_const(*svp, keylen);
7846 if (!hv_fetch(GvHV(*fields), key,
7847 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7849 Perl_croak(aTHX_ "No such class field \"%s\" "
7850 "in variable %s of type %s",
7851 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7864 SVOP *first_key_op, *key_op;
7866 if ((o->op_private & (OPpLVAL_INTRO))
7867 /* I bet there's always a pushmark... */
7868 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7869 /* hmmm, no optimization if list contains only one key. */
7871 rop = (UNOP*)((LISTOP*)o)->op_last;
7872 if (rop->op_type != OP_RV2HV)
7874 if (rop->op_first->op_type == OP_PADSV)
7875 /* @$hash{qw(keys here)} */
7876 rop = (UNOP*)rop->op_first;
7878 /* @{$hash}{qw(keys here)} */
7879 if (rop->op_first->op_type == OP_SCOPE
7880 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7882 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7888 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7889 if (!SvPAD_TYPED(lexname))
7891 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7892 if (!fields || !GvHV(*fields))
7894 /* Again guessing that the pushmark can be jumped over.... */
7895 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7896 ->op_first->op_sibling;
7897 for (key_op = first_key_op; key_op;
7898 key_op = (SVOP*)key_op->op_sibling) {
7899 if (key_op->op_type != OP_CONST)
7901 svp = cSVOPx_svp(key_op);
7902 key = SvPV_const(*svp, keylen);
7903 if (!hv_fetch(GvHV(*fields), key,
7904 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7906 Perl_croak(aTHX_ "No such class field \"%s\" "
7907 "in variable %s of type %s",
7908 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7915 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7919 /* check that RHS of sort is a single plain array */
7920 OP *oright = cUNOPo->op_first;
7921 if (!oright || oright->op_type != OP_PUSHMARK)
7924 /* reverse sort ... can be optimised. */
7925 if (!cUNOPo->op_sibling) {
7926 /* Nothing follows us on the list. */
7927 OP * const reverse = o->op_next;
7929 if (reverse->op_type == OP_REVERSE &&
7930 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7931 OP * const pushmark = cUNOPx(reverse)->op_first;
7932 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7933 && (cUNOPx(pushmark)->op_sibling == o)) {
7934 /* reverse -> pushmark -> sort */
7935 o->op_private |= OPpSORT_REVERSE;
7937 pushmark->op_next = oright->op_next;
7943 /* make @a = sort @a act in-place */
7947 oright = cUNOPx(oright)->op_sibling;
7950 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7951 oright = cUNOPx(oright)->op_sibling;
7955 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7956 || oright->op_next != o
7957 || (oright->op_private & OPpLVAL_INTRO)
7961 /* o2 follows the chain of op_nexts through the LHS of the
7962 * assign (if any) to the aassign op itself */
7964 if (!o2 || o2->op_type != OP_NULL)
7967 if (!o2 || o2->op_type != OP_PUSHMARK)
7970 if (o2 && o2->op_type == OP_GV)
7973 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7974 || (o2->op_private & OPpLVAL_INTRO)
7979 if (!o2 || o2->op_type != OP_NULL)
7982 if (!o2 || o2->op_type != OP_AASSIGN
7983 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7986 /* check that the sort is the first arg on RHS of assign */
7988 o2 = cUNOPx(o2)->op_first;
7989 if (!o2 || o2->op_type != OP_NULL)
7991 o2 = cUNOPx(o2)->op_first;
7992 if (!o2 || o2->op_type != OP_PUSHMARK)
7994 if (o2->op_sibling != o)
7997 /* check the array is the same on both sides */
7998 if (oleft->op_type == OP_RV2AV) {
7999 if (oright->op_type != OP_RV2AV
8000 || !cUNOPx(oright)->op_first
8001 || cUNOPx(oright)->op_first->op_type != OP_GV
8002 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8003 cGVOPx_gv(cUNOPx(oright)->op_first)
8007 else if (oright->op_type != OP_PADAV
8008 || oright->op_targ != oleft->op_targ
8012 /* transfer MODishness etc from LHS arg to RHS arg */
8013 oright->op_flags = oleft->op_flags;
8014 o->op_private |= OPpSORT_INPLACE;
8016 /* excise push->gv->rv2av->null->aassign */
8017 o2 = o->op_next->op_next;
8018 op_null(o2); /* PUSHMARK */
8020 if (o2->op_type == OP_GV) {
8021 op_null(o2); /* GV */
8024 op_null(o2); /* RV2AV or PADAV */
8025 o2 = o2->op_next->op_next;
8026 op_null(o2); /* AASSIGN */
8028 o->op_next = o2->op_next;
8034 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8036 LISTOP *enter, *exlist;
8039 enter = (LISTOP *) o->op_next;
8042 if (enter->op_type == OP_NULL) {
8043 enter = (LISTOP *) enter->op_next;
8047 /* for $a (...) will have OP_GV then OP_RV2GV here.
8048 for (...) just has an OP_GV. */
8049 if (enter->op_type == OP_GV) {
8050 gvop = (OP *) enter;
8051 enter = (LISTOP *) enter->op_next;
8054 if (enter->op_type == OP_RV2GV) {
8055 enter = (LISTOP *) enter->op_next;
8061 if (enter->op_type != OP_ENTERITER)
8064 iter = enter->op_next;
8065 if (!iter || iter->op_type != OP_ITER)
8068 expushmark = enter->op_first;
8069 if (!expushmark || expushmark->op_type != OP_NULL
8070 || expushmark->op_targ != OP_PUSHMARK)
8073 exlist = (LISTOP *) expushmark->op_sibling;
8074 if (!exlist || exlist->op_type != OP_NULL
8075 || exlist->op_targ != OP_LIST)
8078 if (exlist->op_last != o) {
8079 /* Mmm. Was expecting to point back to this op. */
8082 theirmark = exlist->op_first;
8083 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8086 if (theirmark->op_sibling != o) {
8087 /* There's something between the mark and the reverse, eg
8088 for (1, reverse (...))
8093 ourmark = ((LISTOP *)o)->op_first;
8094 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8097 ourlast = ((LISTOP *)o)->op_last;
8098 if (!ourlast || ourlast->op_next != o)
8101 rv2av = ourmark->op_sibling;
8102 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8103 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8104 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8105 /* We're just reversing a single array. */
8106 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8107 enter->op_flags |= OPf_STACKED;
8110 /* We don't have control over who points to theirmark, so sacrifice
8112 theirmark->op_next = ourmark->op_next;
8113 theirmark->op_flags = ourmark->op_flags;
8114 ourlast->op_next = gvop ? gvop : (OP *) enter;
8117 enter->op_private |= OPpITER_REVERSED;
8118 iter->op_private |= OPpITER_REVERSED;
8125 UNOP *refgen, *rv2cv;
8128 /* I do not understand this, but if o->op_opt isn't set to 1,
8129 various tests in ext/B/t/bytecode.t fail with no readily
8135 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8138 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8141 rv2gv = ((BINOP *)o)->op_last;
8142 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8145 refgen = (UNOP *)((BINOP *)o)->op_first;
8147 if (!refgen || refgen->op_type != OP_REFGEN)
8150 exlist = (LISTOP *)refgen->op_first;
8151 if (!exlist || exlist->op_type != OP_NULL
8152 || exlist->op_targ != OP_LIST)
8155 if (exlist->op_first->op_type != OP_PUSHMARK)
8158 rv2cv = (UNOP*)exlist->op_last;
8160 if (rv2cv->op_type != OP_RV2CV)
8163 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8164 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8165 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8167 o->op_private |= OPpASSIGN_CV_TO_GV;
8168 rv2gv->op_private |= OPpDONT_INIT_GV;
8169 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8185 Perl_custom_op_name(pTHX_ const OP* o)
8188 const IV index = PTR2IV(o->op_ppaddr);
8192 if (!PL_custom_op_names) /* This probably shouldn't happen */
8193 return (char *)PL_op_name[OP_CUSTOM];
8195 keysv = sv_2mortal(newSViv(index));
8197 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8199 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8201 return SvPV_nolen(HeVAL(he));
8205 Perl_custom_op_desc(pTHX_ const OP* o)
8208 const IV index = PTR2IV(o->op_ppaddr);
8212 if (!PL_custom_op_descs)
8213 return (char *)PL_op_desc[OP_CUSTOM];
8215 keysv = sv_2mortal(newSViv(index));
8217 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8219 return (char *)PL_op_desc[OP_CUSTOM];
8221 return SvPV_nolen(HeVAL(he));
8226 /* Efficient sub that returns a constant scalar value. */
8228 const_sv_xsub(pTHX_ CV* cv)
8235 Perl_croak(aTHX_ "usage: %s::%s()",
8236 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8240 ST(0) = (SV*)XSANY.any_ptr;
8246 * c-indentation-style: bsd
8248 * indent-tabs-mode: t
8251 * ex: set ts=8 sts=4 sw=4 noet: