3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints> on the save stack, so that it
95 will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifndef PERL_SLAB_SIZE
108 #define PERL_SLAB_SIZE 2048
112 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
115 * To make incrementing use count easy PL_OpSlab is an I32 *
116 * To make inserting the link to slab PL_OpPtr is I32 **
117 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
118 * Add an overhead for pointer to slab and round up as a number of pointers
120 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
121 if ((PL_OpSpace -= sz) < 0) {
122 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
126 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
127 /* We reserve the 0'th I32 sized chunk as a use count */
128 PL_OpSlab = (I32 *) PL_OpPtr;
129 /* Reduce size by the use count word, and by the size we need.
130 * Latter is to mimic the '-=' in the if() above
132 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
133 /* Allocation pointer starts at the top.
134 Theory: because we build leaves before trunk allocating at end
135 means that at run time access is cache friendly upward
137 PL_OpPtr += PERL_SLAB_SIZE;
139 assert( PL_OpSpace >= 0 );
140 /* Move the allocation pointer down */
142 assert( PL_OpPtr > (I32 **) PL_OpSlab );
143 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
144 (*PL_OpSlab)++; /* Increment use count of slab */
145 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
146 assert( *PL_OpSlab > 0 );
147 return (void *)(PL_OpPtr + 1);
151 Perl_Slab_Free(pTHX_ void *op)
153 I32 * const * const ptr = (I32 **) op;
154 I32 * const slab = ptr[-1];
155 assert( ptr-1 > (I32 **) slab );
156 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
158 if (--(*slab) == 0) {
160 # define PerlMemShared PerlMem
163 PerlMemShared_free(slab);
164 if (slab == PL_OpSlab) {
171 * In the following definition, the ", (OP*)0" is just to make the compiler
172 * think the expression is of the right type: croak actually does a Siglongjmp.
174 #define CHECKOP(type,o) \
175 ((PL_op_mask && PL_op_mask[type]) \
176 ? ( op_free((OP*)o), \
177 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
179 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
181 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
184 S_gv_ename(pTHX_ GV *gv)
186 SV* const tmpsv = sv_newmortal();
187 gv_efullname3(tmpsv, gv, NULL);
188 return SvPV_nolen_const(tmpsv);
192 S_no_fh_allowed(pTHX_ OP *o)
194 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
200 S_too_few_arguments(pTHX_ OP *o, const char *name)
202 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
207 S_too_many_arguments(pTHX_ OP *o, const char *name)
209 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
214 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
216 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
217 (int)n, name, t, OP_DESC(kid)));
221 S_no_bareword_allowed(pTHX_ const OP *o)
224 return; /* various ok barewords are hidden in extra OP_NULL */
225 qerror(Perl_mess(aTHX_
226 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
230 /* "register" allocation */
233 Perl_allocmy(pTHX_ char *name)
237 const bool is_our = (PL_in_my == KEY_our);
239 /* complain about "my $<special_var>" etc etc */
243 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
244 (name[1] == '_' && (*name == '$' || name[2]))))
246 /* name[2] is true if strlen(name) > 2 */
247 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
248 /* 1999-02-27 mjd@plover.com */
250 p = strchr(name, '\0');
251 /* The next block assumes the buffer is at least 205 chars
252 long. At present, it's always at least 256 chars. */
254 strcpy(name+200, "...");
260 /* Move everything else down one character */
261 for (; p-name > 2; p--)
263 name[2] = toCTRL(name[1]);
266 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
269 /* check for duplicate declaration */
270 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
272 if (PL_in_my_stash && *name != '$') {
273 yyerror(Perl_form(aTHX_
274 "Can't declare class for non-scalar %s in \"%s\"",
275 name, is_our ? "our" : "my"));
278 /* allocate a spare slot and store the name in that slot */
280 off = pad_add_name(name,
283 /* $_ is always in main::, even with our */
284 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
295 Perl_op_free(pTHX_ OP *o)
300 if (!o || o->op_static)
304 if (o->op_private & OPpREFCOUNTED) {
315 refcnt = OpREFCNT_dec(o);
326 if (o->op_flags & OPf_KIDS) {
327 register OP *kid, *nextkid;
328 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
329 nextkid = kid->op_sibling; /* Get before next freeing kid */
334 type = (OPCODE)o->op_targ;
336 /* COP* is not cleared by op_clear() so that we may track line
337 * numbers etc even after null() */
338 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
343 #ifdef DEBUG_LEAKING_SCALARS
350 Perl_op_clear(pTHX_ OP *o)
355 /* if (o->op_madprop && o->op_madprop->mad_next)
357 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
358 "modification of a read only value" for a reason I can't fathom why.
359 It's the "" stringification of $_, where $_ was set to '' in a foreach
360 loop, but it defies simplification into a small test case.
361 However, commenting them out has caused ext/List/Util/t/weak.t to fail
364 mad_free(o->op_madprop);
370 switch (o->op_type) {
371 case OP_NULL: /* Was holding old type, if any. */
372 if (PL_madskills && o->op_targ != OP_NULL) {
373 o->op_type = o->op_targ;
377 case OP_ENTEREVAL: /* Was holding hints. */
381 if (!(o->op_flags & OPf_REF)
382 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
388 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
389 /* not an OP_PADAV replacement */
391 if (cPADOPo->op_padix > 0) {
392 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
393 * may still exist on the pad */
394 pad_swipe(cPADOPo->op_padix, TRUE);
395 cPADOPo->op_padix = 0;
398 SvREFCNT_dec(cSVOPo->op_sv);
399 cSVOPo->op_sv = NULL;
403 case OP_METHOD_NAMED:
405 SvREFCNT_dec(cSVOPo->op_sv);
406 cSVOPo->op_sv = NULL;
409 Even if op_clear does a pad_free for the target of the op,
410 pad_free doesn't actually remove the sv that exists in the pad;
411 instead it lives on. This results in that it could be reused as
412 a target later on when the pad was reallocated.
415 pad_swipe(o->op_targ,1);
424 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
428 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
429 SvREFCNT_dec(cSVOPo->op_sv);
430 cSVOPo->op_sv = NULL;
433 Safefree(cPVOPo->op_pv);
434 cPVOPo->op_pv = NULL;
438 op_free(cPMOPo->op_pmreplroot);
442 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
443 /* No GvIN_PAD_off here, because other references may still
444 * exist on the pad */
445 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
448 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
455 HV * const pmstash = PmopSTASH(cPMOPo);
456 if (pmstash && !SvIS_FREED(pmstash)) {
457 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
459 PMOP *pmop = (PMOP*) mg->mg_obj;
460 PMOP *lastpmop = NULL;
462 if (cPMOPo == pmop) {
464 lastpmop->op_pmnext = pmop->op_pmnext;
466 mg->mg_obj = (SV*) pmop->op_pmnext;
470 pmop = pmop->op_pmnext;
474 PmopSTASH_free(cPMOPo);
476 cPMOPo->op_pmreplroot = NULL;
477 /* we use the "SAFE" version of the PM_ macros here
478 * since sv_clean_all might release some PMOPs
479 * after PL_regex_padav has been cleared
480 * and the clearing of PL_regex_padav needs to
481 * happen before sv_clean_all
483 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
484 PM_SETRE_SAFE(cPMOPo, NULL);
486 if(PL_regex_pad) { /* We could be in destruction */
487 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
488 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
489 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
496 if (o->op_targ > 0) {
497 pad_free(o->op_targ);
503 S_cop_free(pTHX_ COP* cop)
505 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
508 if (! specialWARN(cop->cop_warnings))
509 SvREFCNT_dec(cop->cop_warnings);
510 if (! specialCopIO(cop->cop_io)) {
514 SvREFCNT_dec(cop->cop_io);
517 Perl_refcounted_he_free(aTHX_ cop->cop_hints);
521 Perl_op_null(pTHX_ OP *o)
524 if (o->op_type == OP_NULL)
528 o->op_targ = o->op_type;
529 o->op_type = OP_NULL;
530 o->op_ppaddr = PL_ppaddr[OP_NULL];
534 Perl_op_refcnt_lock(pTHX)
542 Perl_op_refcnt_unlock(pTHX)
549 /* Contextualizers */
551 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
554 Perl_linklist(pTHX_ OP *o)
561 /* establish postfix order */
562 first = cUNOPo->op_first;
565 o->op_next = LINKLIST(first);
568 if (kid->op_sibling) {
569 kid->op_next = LINKLIST(kid->op_sibling);
570 kid = kid->op_sibling;
584 Perl_scalarkids(pTHX_ OP *o)
586 if (o && o->op_flags & OPf_KIDS) {
588 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
595 S_scalarboolean(pTHX_ OP *o)
598 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
599 if (ckWARN(WARN_SYNTAX)) {
600 const line_t oldline = CopLINE(PL_curcop);
602 if (PL_copline != NOLINE)
603 CopLINE_set(PL_curcop, PL_copline);
604 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
605 CopLINE_set(PL_curcop, oldline);
612 Perl_scalar(pTHX_ OP *o)
617 /* assumes no premature commitment */
618 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
619 || o->op_type == OP_RETURN)
624 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
626 switch (o->op_type) {
628 scalar(cBINOPo->op_first);
633 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
637 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
638 if (!kPMOP->op_pmreplroot)
639 deprecate_old("implicit split to @_");
647 if (o->op_flags & OPf_KIDS) {
648 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
654 kid = cLISTOPo->op_first;
656 while ((kid = kid->op_sibling)) {
662 WITH_THR(PL_curcop = &PL_compiling);
667 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
673 WITH_THR(PL_curcop = &PL_compiling);
676 if (ckWARN(WARN_VOID))
677 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
683 Perl_scalarvoid(pTHX_ OP *o)
687 const char* useless = NULL;
691 /* trailing mad null ops don't count as "there" for void processing */
693 o->op_type != OP_NULL &&
695 o->op_sibling->op_type == OP_NULL)
698 for (sib = o->op_sibling;
699 sib && sib->op_type == OP_NULL;
700 sib = sib->op_sibling) ;
706 if (o->op_type == OP_NEXTSTATE
707 || o->op_type == OP_SETSTATE
708 || o->op_type == OP_DBSTATE
709 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
710 || o->op_targ == OP_SETSTATE
711 || o->op_targ == OP_DBSTATE)))
712 PL_curcop = (COP*)o; /* for warning below */
714 /* assumes no premature commitment */
715 want = o->op_flags & OPf_WANT;
716 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
717 || o->op_type == OP_RETURN)
722 if ((o->op_private & OPpTARGET_MY)
723 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
725 return scalar(o); /* As if inside SASSIGN */
728 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
730 switch (o->op_type) {
732 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
736 if (o->op_flags & OPf_STACKED)
740 if (o->op_private == 4)
812 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
813 useless = OP_DESC(o);
817 kid = cUNOPo->op_first;
818 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
819 kid->op_type != OP_TRANS) {
822 useless = "negative pattern binding (!~)";
829 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
830 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
831 useless = "a variable";
836 if (cSVOPo->op_private & OPpCONST_STRICT)
837 no_bareword_allowed(o);
839 if (ckWARN(WARN_VOID)) {
840 useless = "a constant";
841 if (o->op_private & OPpCONST_ARYBASE)
843 /* don't warn on optimised away booleans, eg
844 * use constant Foo, 5; Foo || print; */
845 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
847 /* the constants 0 and 1 are permitted as they are
848 conventionally used as dummies in constructs like
849 1 while some_condition_with_side_effects; */
850 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
852 else if (SvPOK(sv)) {
853 /* perl4's way of mixing documentation and code
854 (before the invention of POD) was based on a
855 trick to mix nroff and perl code. The trick was
856 built upon these three nroff macros being used in
857 void context. The pink camel has the details in
858 the script wrapman near page 319. */
859 const char * const maybe_macro = SvPVX_const(sv);
860 if (strnEQ(maybe_macro, "di", 2) ||
861 strnEQ(maybe_macro, "ds", 2) ||
862 strnEQ(maybe_macro, "ig", 2))
867 op_null(o); /* don't execute or even remember it */
871 o->op_type = OP_PREINC; /* pre-increment is faster */
872 o->op_ppaddr = PL_ppaddr[OP_PREINC];
876 o->op_type = OP_PREDEC; /* pre-decrement is faster */
877 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
881 o->op_type = OP_I_PREINC; /* pre-increment is faster */
882 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
886 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
887 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
896 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
901 if (o->op_flags & OPf_STACKED)
908 if (!(o->op_flags & OPf_KIDS))
919 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
926 /* all requires must return a boolean value */
927 o->op_flags &= ~OPf_WANT;
932 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
933 if (!kPMOP->op_pmreplroot)
934 deprecate_old("implicit split to @_");
938 if (useless && ckWARN(WARN_VOID))
939 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
944 Perl_listkids(pTHX_ OP *o)
946 if (o && o->op_flags & OPf_KIDS) {
948 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
955 Perl_list(pTHX_ OP *o)
960 /* assumes no premature commitment */
961 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
962 || o->op_type == OP_RETURN)
967 if ((o->op_private & OPpTARGET_MY)
968 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
970 return o; /* As if inside SASSIGN */
973 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
975 switch (o->op_type) {
978 list(cBINOPo->op_first);
983 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
991 if (!(o->op_flags & OPf_KIDS))
993 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
994 list(cBINOPo->op_first);
995 return gen_constant_list(o);
1002 kid = cLISTOPo->op_first;
1004 while ((kid = kid->op_sibling)) {
1005 if (kid->op_sibling)
1010 WITH_THR(PL_curcop = &PL_compiling);
1014 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1015 if (kid->op_sibling)
1020 WITH_THR(PL_curcop = &PL_compiling);
1023 /* all requires must return a boolean value */
1024 o->op_flags &= ~OPf_WANT;
1031 Perl_scalarseq(pTHX_ OP *o)
1035 if (o->op_type == OP_LINESEQ ||
1036 o->op_type == OP_SCOPE ||
1037 o->op_type == OP_LEAVE ||
1038 o->op_type == OP_LEAVETRY)
1041 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1042 if (kid->op_sibling) {
1046 PL_curcop = &PL_compiling;
1048 o->op_flags &= ~OPf_PARENS;
1049 if (PL_hints & HINT_BLOCK_SCOPE)
1050 o->op_flags |= OPf_PARENS;
1053 o = newOP(OP_STUB, 0);
1058 S_modkids(pTHX_ OP *o, I32 type)
1060 if (o && o->op_flags & OPf_KIDS) {
1062 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1068 /* Propagate lvalue ("modifiable") context to an op and its children.
1069 * 'type' represents the context type, roughly based on the type of op that
1070 * would do the modifying, although local() is represented by OP_NULL.
1071 * It's responsible for detecting things that can't be modified, flag
1072 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1073 * might have to vivify a reference in $x), and so on.
1075 * For example, "$a+1 = 2" would cause mod() to be called with o being
1076 * OP_ADD and type being OP_SASSIGN, and would output an error.
1080 Perl_mod(pTHX_ OP *o, I32 type)
1084 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1087 if (!o || PL_error_count)
1090 if ((o->op_private & OPpTARGET_MY)
1091 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1096 switch (o->op_type) {
1102 if (!(o->op_private & OPpCONST_ARYBASE))
1105 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1106 CopARYBASE_set(&PL_compiling,
1107 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1111 SAVECOPARYBASE(&PL_compiling);
1112 CopARYBASE_set(&PL_compiling, 0);
1114 else if (type == OP_REFGEN)
1117 Perl_croak(aTHX_ "That use of $[ is unsupported");
1120 if (o->op_flags & OPf_PARENS || PL_madskills)
1124 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1125 !(o->op_flags & OPf_STACKED)) {
1126 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1127 /* The default is to set op_private to the number of children,
1128 which for a UNOP such as RV2CV is always 1. And w're using
1129 the bit for a flag in RV2CV, so we need it clear. */
1130 o->op_private &= ~1;
1131 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1132 assert(cUNOPo->op_first->op_type == OP_NULL);
1133 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1136 else if (o->op_private & OPpENTERSUB_NOMOD)
1138 else { /* lvalue subroutine call */
1139 o->op_private |= OPpLVAL_INTRO;
1140 PL_modcount = RETURN_UNLIMITED_NUMBER;
1141 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1142 /* Backward compatibility mode: */
1143 o->op_private |= OPpENTERSUB_INARGS;
1146 else { /* Compile-time error message: */
1147 OP *kid = cUNOPo->op_first;
1151 if (kid->op_type == OP_PUSHMARK)
1153 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1155 "panic: unexpected lvalue entersub "
1156 "args: type/targ %ld:%"UVuf,
1157 (long)kid->op_type, (UV)kid->op_targ);
1158 kid = kLISTOP->op_first;
1160 while (kid->op_sibling)
1161 kid = kid->op_sibling;
1162 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1164 if (kid->op_type == OP_METHOD_NAMED
1165 || kid->op_type == OP_METHOD)
1169 NewOp(1101, newop, 1, UNOP);
1170 newop->op_type = OP_RV2CV;
1171 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1172 newop->op_first = NULL;
1173 newop->op_next = (OP*)newop;
1174 kid->op_sibling = (OP*)newop;
1175 newop->op_private |= OPpLVAL_INTRO;
1176 newop->op_private &= ~1;
1180 if (kid->op_type != OP_RV2CV)
1182 "panic: unexpected lvalue entersub "
1183 "entry via type/targ %ld:%"UVuf,
1184 (long)kid->op_type, (UV)kid->op_targ);
1185 kid->op_private |= OPpLVAL_INTRO;
1186 break; /* Postpone until runtime */
1190 kid = kUNOP->op_first;
1191 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1192 kid = kUNOP->op_first;
1193 if (kid->op_type == OP_NULL)
1195 "Unexpected constant lvalue entersub "
1196 "entry via type/targ %ld:%"UVuf,
1197 (long)kid->op_type, (UV)kid->op_targ);
1198 if (kid->op_type != OP_GV) {
1199 /* Restore RV2CV to check lvalueness */
1201 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1202 okid->op_next = kid->op_next;
1203 kid->op_next = okid;
1206 okid->op_next = NULL;
1207 okid->op_type = OP_RV2CV;
1209 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1210 okid->op_private |= OPpLVAL_INTRO;
1211 okid->op_private &= ~1;
1215 cv = GvCV(kGVOP_gv);
1225 /* grep, foreach, subcalls, refgen */
1226 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1228 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1229 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1231 : (o->op_type == OP_ENTERSUB
1232 ? "non-lvalue subroutine call"
1234 type ? PL_op_desc[type] : "local"));
1248 case OP_RIGHT_SHIFT:
1257 if (!(o->op_flags & OPf_STACKED))
1264 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1270 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1271 PL_modcount = RETURN_UNLIMITED_NUMBER;
1272 return o; /* Treat \(@foo) like ordinary list. */
1276 if (scalar_mod_type(o, type))
1278 ref(cUNOPo->op_first, o->op_type);
1282 if (type == OP_LEAVESUBLV)
1283 o->op_private |= OPpMAYBE_LVSUB;
1289 PL_modcount = RETURN_UNLIMITED_NUMBER;
1292 ref(cUNOPo->op_first, o->op_type);
1297 PL_hints |= HINT_BLOCK_SCOPE;
1312 PL_modcount = RETURN_UNLIMITED_NUMBER;
1313 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1314 return o; /* Treat \(@foo) like ordinary list. */
1315 if (scalar_mod_type(o, type))
1317 if (type == OP_LEAVESUBLV)
1318 o->op_private |= OPpMAYBE_LVSUB;
1322 if (!type) /* local() */
1323 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1324 PAD_COMPNAME_PV(o->op_targ));
1332 if (type != OP_SASSIGN)
1336 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1341 if (type == OP_LEAVESUBLV)
1342 o->op_private |= OPpMAYBE_LVSUB;
1344 pad_free(o->op_targ);
1345 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1346 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1347 if (o->op_flags & OPf_KIDS)
1348 mod(cBINOPo->op_first->op_sibling, type);
1353 ref(cBINOPo->op_first, o->op_type);
1354 if (type == OP_ENTERSUB &&
1355 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1356 o->op_private |= OPpLVAL_DEFER;
1357 if (type == OP_LEAVESUBLV)
1358 o->op_private |= OPpMAYBE_LVSUB;
1368 if (o->op_flags & OPf_KIDS)
1369 mod(cLISTOPo->op_last, type);
1374 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1376 else if (!(o->op_flags & OPf_KIDS))
1378 if (o->op_targ != OP_LIST) {
1379 mod(cBINOPo->op_first, type);
1385 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1390 if (type != OP_LEAVESUBLV)
1392 break; /* mod()ing was handled by ck_return() */
1395 /* [20011101.069] File test operators interpret OPf_REF to mean that
1396 their argument is a filehandle; thus \stat(".") should not set
1398 if (type == OP_REFGEN &&
1399 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1402 if (type != OP_LEAVESUBLV)
1403 o->op_flags |= OPf_MOD;
1405 if (type == OP_AASSIGN || type == OP_SASSIGN)
1406 o->op_flags |= OPf_SPECIAL|OPf_REF;
1407 else if (!type) { /* local() */
1410 o->op_private |= OPpLVAL_INTRO;
1411 o->op_flags &= ~OPf_SPECIAL;
1412 PL_hints |= HINT_BLOCK_SCOPE;
1417 if (ckWARN(WARN_SYNTAX)) {
1418 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1419 "Useless localization of %s", OP_DESC(o));
1423 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1424 && type != OP_LEAVESUBLV)
1425 o->op_flags |= OPf_REF;
1430 S_scalar_mod_type(const OP *o, I32 type)
1434 if (o->op_type == OP_RV2GV)
1458 case OP_RIGHT_SHIFT:
1477 S_is_handle_constructor(const OP *o, I32 numargs)
1479 switch (o->op_type) {
1487 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1500 Perl_refkids(pTHX_ OP *o, I32 type)
1502 if (o && o->op_flags & OPf_KIDS) {
1504 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1511 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1516 if (!o || PL_error_count)
1519 switch (o->op_type) {
1521 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1522 !(o->op_flags & OPf_STACKED)) {
1523 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1524 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1525 assert(cUNOPo->op_first->op_type == OP_NULL);
1526 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1527 o->op_flags |= OPf_SPECIAL;
1528 o->op_private &= ~1;
1533 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1534 doref(kid, type, set_op_ref);
1537 if (type == OP_DEFINED)
1538 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1539 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1542 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1543 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1544 : type == OP_RV2HV ? OPpDEREF_HV
1546 o->op_flags |= OPf_MOD;
1551 o->op_flags |= OPf_MOD; /* XXX ??? */
1557 o->op_flags |= OPf_REF;
1560 if (type == OP_DEFINED)
1561 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1562 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1568 o->op_flags |= OPf_REF;
1573 if (!(o->op_flags & OPf_KIDS))
1575 doref(cBINOPo->op_first, type, set_op_ref);
1579 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1580 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1581 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1582 : type == OP_RV2HV ? OPpDEREF_HV
1584 o->op_flags |= OPf_MOD;
1594 if (!(o->op_flags & OPf_KIDS))
1596 doref(cLISTOPo->op_last, type, set_op_ref);
1606 S_dup_attrlist(pTHX_ OP *o)
1611 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1612 * where the first kid is OP_PUSHMARK and the remaining ones
1613 * are OP_CONST. We need to push the OP_CONST values.
1615 if (o->op_type == OP_CONST)
1616 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1618 else if (o->op_type == OP_NULL)
1622 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1624 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1625 if (o->op_type == OP_CONST)
1626 rop = append_elem(OP_LIST, rop,
1627 newSVOP(OP_CONST, o->op_flags,
1628 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1635 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1640 /* fake up C<use attributes $pkg,$rv,@attrs> */
1641 ENTER; /* need to protect against side-effects of 'use' */
1643 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1645 #define ATTRSMODULE "attributes"
1646 #define ATTRSMODULE_PM "attributes.pm"
1649 /* Don't force the C<use> if we don't need it. */
1650 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1651 if (svp && *svp != &PL_sv_undef)
1652 /*EMPTY*/; /* already in %INC */
1654 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1655 newSVpvs(ATTRSMODULE), NULL);
1658 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1659 newSVpvs(ATTRSMODULE),
1661 prepend_elem(OP_LIST,
1662 newSVOP(OP_CONST, 0, stashsv),
1663 prepend_elem(OP_LIST,
1664 newSVOP(OP_CONST, 0,
1666 dup_attrlist(attrs))));
1672 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1675 OP *pack, *imop, *arg;
1681 assert(target->op_type == OP_PADSV ||
1682 target->op_type == OP_PADHV ||
1683 target->op_type == OP_PADAV);
1685 /* Ensure that attributes.pm is loaded. */
1686 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1688 /* Need package name for method call. */
1689 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1691 /* Build up the real arg-list. */
1692 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1694 arg = newOP(OP_PADSV, 0);
1695 arg->op_targ = target->op_targ;
1696 arg = prepend_elem(OP_LIST,
1697 newSVOP(OP_CONST, 0, stashsv),
1698 prepend_elem(OP_LIST,
1699 newUNOP(OP_REFGEN, 0,
1700 mod(arg, OP_REFGEN)),
1701 dup_attrlist(attrs)));
1703 /* Fake up a method call to import */
1704 meth = newSVpvs_share("import");
1705 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1706 append_elem(OP_LIST,
1707 prepend_elem(OP_LIST, pack, list(arg)),
1708 newSVOP(OP_METHOD_NAMED, 0, meth)));
1709 imop->op_private |= OPpENTERSUB_NOMOD;
1711 /* Combine the ops. */
1712 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1716 =notfor apidoc apply_attrs_string
1718 Attempts to apply a list of attributes specified by the C<attrstr> and
1719 C<len> arguments to the subroutine identified by the C<cv> argument which
1720 is expected to be associated with the package identified by the C<stashpv>
1721 argument (see L<attributes>). It gets this wrong, though, in that it
1722 does not correctly identify the boundaries of the individual attribute
1723 specifications within C<attrstr>. This is not really intended for the
1724 public API, but has to be listed here for systems such as AIX which
1725 need an explicit export list for symbols. (It's called from XS code
1726 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1727 to respect attribute syntax properly would be welcome.
1733 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1734 const char *attrstr, STRLEN len)
1739 len = strlen(attrstr);
1743 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1745 const char * const sstr = attrstr;
1746 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1747 attrs = append_elem(OP_LIST, attrs,
1748 newSVOP(OP_CONST, 0,
1749 newSVpvn(sstr, attrstr-sstr)));
1753 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1754 newSVpvs(ATTRSMODULE),
1755 NULL, prepend_elem(OP_LIST,
1756 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1757 prepend_elem(OP_LIST,
1758 newSVOP(OP_CONST, 0,
1764 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1769 if (!o || PL_error_count)
1773 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1774 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1778 if (type == OP_LIST) {
1780 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1781 my_kid(kid, attrs, imopsp);
1782 } else if (type == OP_UNDEF
1788 } else if (type == OP_RV2SV || /* "our" declaration */
1790 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1791 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1792 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1793 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1795 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1797 PL_in_my_stash = NULL;
1798 apply_attrs(GvSTASH(gv),
1799 (type == OP_RV2SV ? GvSV(gv) :
1800 type == OP_RV2AV ? (SV*)GvAV(gv) :
1801 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1804 o->op_private |= OPpOUR_INTRO;
1807 else if (type != OP_PADSV &&
1810 type != OP_PUSHMARK)
1812 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1814 PL_in_my == KEY_our ? "our" : "my"));
1817 else if (attrs && type != OP_PUSHMARK) {
1821 PL_in_my_stash = NULL;
1823 /* check for C<my Dog $spot> when deciding package */
1824 stash = PAD_COMPNAME_TYPE(o->op_targ);
1826 stash = PL_curstash;
1827 apply_attrs_my(stash, o, attrs, imopsp);
1829 o->op_flags |= OPf_MOD;
1830 o->op_private |= OPpLVAL_INTRO;
1835 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1839 int maybe_scalar = 0;
1841 /* [perl #17376]: this appears to be premature, and results in code such as
1842 C< our(%x); > executing in list mode rather than void mode */
1844 if (o->op_flags & OPf_PARENS)
1854 o = my_kid(o, attrs, &rops);
1856 if (maybe_scalar && o->op_type == OP_PADSV) {
1857 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1858 o->op_private |= OPpLVAL_INTRO;
1861 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1864 PL_in_my_stash = NULL;
1869 Perl_my(pTHX_ OP *o)
1871 return my_attrs(o, NULL);
1875 Perl_sawparens(pTHX_ OP *o)
1877 PERL_UNUSED_CONTEXT;
1879 o->op_flags |= OPf_PARENS;
1884 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1889 if ( (left->op_type == OP_RV2AV ||
1890 left->op_type == OP_RV2HV ||
1891 left->op_type == OP_PADAV ||
1892 left->op_type == OP_PADHV)
1893 && ckWARN(WARN_MISC))
1895 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1896 right->op_type == OP_TRANS)
1897 ? right->op_type : OP_MATCH];
1898 const char * const sample = ((left->op_type == OP_RV2AV ||
1899 left->op_type == OP_PADAV)
1900 ? "@array" : "%hash");
1901 Perl_warner(aTHX_ packWARN(WARN_MISC),
1902 "Applying %s to %s will act on scalar(%s)",
1903 desc, sample, sample);
1906 if (right->op_type == OP_CONST &&
1907 cSVOPx(right)->op_private & OPpCONST_BARE &&
1908 cSVOPx(right)->op_private & OPpCONST_STRICT)
1910 no_bareword_allowed(right);
1913 ismatchop = right->op_type == OP_MATCH ||
1914 right->op_type == OP_SUBST ||
1915 right->op_type == OP_TRANS;
1916 if (ismatchop && right->op_private & OPpTARGET_MY) {
1918 right->op_private &= ~OPpTARGET_MY;
1920 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1921 right->op_flags |= OPf_STACKED;
1922 if (right->op_type != OP_MATCH &&
1923 ! (right->op_type == OP_TRANS &&
1924 right->op_private & OPpTRANS_IDENTICAL))
1925 left = mod(left, right->op_type);
1926 if (right->op_type == OP_TRANS)
1927 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1929 o = prepend_elem(right->op_type, scalar(left), right);
1931 return newUNOP(OP_NOT, 0, scalar(o));
1935 return bind_match(type, left,
1936 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1940 Perl_invert(pTHX_ OP *o)
1944 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1948 Perl_scope(pTHX_ OP *o)
1952 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1953 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1954 o->op_type = OP_LEAVE;
1955 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1957 else if (o->op_type == OP_LINESEQ) {
1959 o->op_type = OP_SCOPE;
1960 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1961 kid = ((LISTOP*)o)->op_first;
1962 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1965 /* The following deals with things like 'do {1 for 1}' */
1966 kid = kid->op_sibling;
1968 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1973 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1979 Perl_block_start(pTHX_ int full)
1982 const int retval = PL_savestack_ix;
1983 pad_block_start(full);
1985 PL_hints &= ~HINT_BLOCK_SCOPE;
1986 SAVESPTR(PL_compiling.cop_warnings);
1987 if (! specialWARN(PL_compiling.cop_warnings)) {
1988 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1989 SAVEFREESV(PL_compiling.cop_warnings) ;
1991 SAVESPTR(PL_compiling.cop_io);
1992 if (! specialCopIO(PL_compiling.cop_io)) {
1993 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1994 SAVEFREESV(PL_compiling.cop_io) ;
2000 Perl_block_end(pTHX_ I32 floor, OP *seq)
2003 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2004 OP* const retval = scalarseq(seq);
2006 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2008 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2017 const I32 offset = pad_findmy("$_");
2018 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2019 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2022 OP * const o = newOP(OP_PADSV, 0);
2023 o->op_targ = offset;
2029 Perl_newPROG(pTHX_ OP *o)
2035 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2036 ((PL_in_eval & EVAL_KEEPERR)
2037 ? OPf_SPECIAL : 0), o);
2038 PL_eval_start = linklist(PL_eval_root);
2039 PL_eval_root->op_private |= OPpREFCOUNTED;
2040 OpREFCNT_set(PL_eval_root, 1);
2041 PL_eval_root->op_next = 0;
2042 CALL_PEEP(PL_eval_start);
2045 if (o->op_type == OP_STUB) {
2046 PL_comppad_name = 0;
2051 PL_main_root = scope(sawparens(scalarvoid(o)));
2052 PL_curcop = &PL_compiling;
2053 PL_main_start = LINKLIST(PL_main_root);
2054 PL_main_root->op_private |= OPpREFCOUNTED;
2055 OpREFCNT_set(PL_main_root, 1);
2056 PL_main_root->op_next = 0;
2057 CALL_PEEP(PL_main_start);
2060 /* Register with debugger */
2062 CV * const cv = get_cv("DB::postponed", FALSE);
2066 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2068 call_sv((SV*)cv, G_DISCARD);
2075 Perl_localize(pTHX_ OP *o, I32 lex)
2078 if (o->op_flags & OPf_PARENS)
2079 /* [perl #17376]: this appears to be premature, and results in code such as
2080 C< our(%x); > executing in list mode rather than void mode */
2087 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2088 && ckWARN(WARN_PARENTHESIS))
2090 char *s = PL_bufptr;
2093 /* some heuristics to detect a potential error */
2094 while (*s && (strchr(", \t\n", *s)))
2098 if (*s && strchr("@$%*", *s) && *++s
2099 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2102 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2104 while (*s && (strchr(", \t\n", *s)))
2110 if (sigil && (*s == ';' || *s == '=')) {
2111 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2112 "Parentheses missing around \"%s\" list",
2113 lex ? (PL_in_my == KEY_our ? "our" : "my")
2121 o = mod(o, OP_NULL); /* a bit kludgey */
2123 PL_in_my_stash = NULL;
2128 Perl_jmaybe(pTHX_ OP *o)
2130 if (o->op_type == OP_LIST) {
2132 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2133 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2139 Perl_fold_constants(pTHX_ register OP *o)
2144 I32 type = o->op_type;
2151 if (PL_opargs[type] & OA_RETSCALAR)
2153 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2154 o->op_targ = pad_alloc(type, SVs_PADTMP);
2156 /* integerize op, unless it happens to be C<-foo>.
2157 * XXX should pp_i_negate() do magic string negation instead? */
2158 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2159 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2160 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2162 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2165 if (!(PL_opargs[type] & OA_FOLDCONST))
2170 /* XXX might want a ck_negate() for this */
2171 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2182 /* XXX what about the numeric ops? */
2183 if (PL_hints & HINT_LOCALE)
2188 goto nope; /* Don't try to run w/ errors */
2190 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2191 if ((curop->op_type != OP_CONST ||
2192 (curop->op_private & OPpCONST_BARE)) &&
2193 curop->op_type != OP_LIST &&
2194 curop->op_type != OP_SCALAR &&
2195 curop->op_type != OP_NULL &&
2196 curop->op_type != OP_PUSHMARK)
2202 curop = LINKLIST(o);
2203 old_next = o->op_next;
2207 oldscope = PL_scopestack_ix;
2208 create_eval_scope(G_FAKINGEVAL);
2215 sv = *(PL_stack_sp--);
2216 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2217 pad_swipe(o->op_targ, FALSE);
2218 else if (SvTEMP(sv)) { /* grab mortal temp? */
2219 SvREFCNT_inc_simple_void(sv);
2224 /* Something tried to die. Abandon constant folding. */
2225 /* Pretend the error never happened. */
2226 sv_setpvn(ERRSV,"",0);
2227 o->op_next = old_next;
2231 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2232 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2237 if (PL_scopestack_ix > oldscope)
2238 delete_eval_scope();
2246 if (type == OP_RV2GV)
2247 newop = newGVOP(OP_GV, 0, (GV*)sv);
2249 newop = newSVOP(OP_CONST, 0, sv);
2250 op_getmad(o,newop,'f');
2258 Perl_gen_constant_list(pTHX_ register OP *o)
2262 const I32 oldtmps_floor = PL_tmps_floor;
2266 return o; /* Don't attempt to run with errors */
2268 PL_op = curop = LINKLIST(o);
2275 PL_tmps_floor = oldtmps_floor;
2277 o->op_type = OP_RV2AV;
2278 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2279 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2280 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2281 o->op_opt = 0; /* needs to be revisited in peep() */
2282 curop = ((UNOP*)o)->op_first;
2283 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2285 op_getmad(curop,o,'O');
2294 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2297 if (!o || o->op_type != OP_LIST)
2298 o = newLISTOP(OP_LIST, 0, o, NULL);
2300 o->op_flags &= ~OPf_WANT;
2302 if (!(PL_opargs[type] & OA_MARK))
2303 op_null(cLISTOPo->op_first);
2305 o->op_type = (OPCODE)type;
2306 o->op_ppaddr = PL_ppaddr[type];
2307 o->op_flags |= flags;
2309 o = CHECKOP(type, o);
2310 if (o->op_type != (unsigned)type)
2313 return fold_constants(o);
2316 /* List constructors */
2319 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2327 if (first->op_type != (unsigned)type
2328 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2330 return newLISTOP(type, 0, first, last);
2333 if (first->op_flags & OPf_KIDS)
2334 ((LISTOP*)first)->op_last->op_sibling = last;
2336 first->op_flags |= OPf_KIDS;
2337 ((LISTOP*)first)->op_first = last;
2339 ((LISTOP*)first)->op_last = last;
2344 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2352 if (first->op_type != (unsigned)type)
2353 return prepend_elem(type, (OP*)first, (OP*)last);
2355 if (last->op_type != (unsigned)type)
2356 return append_elem(type, (OP*)first, (OP*)last);
2358 first->op_last->op_sibling = last->op_first;
2359 first->op_last = last->op_last;
2360 first->op_flags |= (last->op_flags & OPf_KIDS);
2363 if (last->op_first && first->op_madprop) {
2364 MADPROP *mp = last->op_first->op_madprop;
2366 while (mp->mad_next)
2368 mp->mad_next = first->op_madprop;
2371 last->op_first->op_madprop = first->op_madprop;
2374 first->op_madprop = last->op_madprop;
2375 last->op_madprop = 0;
2384 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2392 if (last->op_type == (unsigned)type) {
2393 if (type == OP_LIST) { /* already a PUSHMARK there */
2394 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2395 ((LISTOP*)last)->op_first->op_sibling = first;
2396 if (!(first->op_flags & OPf_PARENS))
2397 last->op_flags &= ~OPf_PARENS;
2400 if (!(last->op_flags & OPf_KIDS)) {
2401 ((LISTOP*)last)->op_last = first;
2402 last->op_flags |= OPf_KIDS;
2404 first->op_sibling = ((LISTOP*)last)->op_first;
2405 ((LISTOP*)last)->op_first = first;
2407 last->op_flags |= OPf_KIDS;
2411 return newLISTOP(type, 0, first, last);
2419 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2422 Newxz(tk, 1, TOKEN);
2423 tk->tk_type = (OPCODE)optype;
2424 tk->tk_type = 12345;
2426 tk->tk_mad = madprop;
2431 Perl_token_free(pTHX_ TOKEN* tk)
2433 if (tk->tk_type != 12345)
2435 mad_free(tk->tk_mad);
2440 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2444 if (tk->tk_type != 12345) {
2445 Perl_warner(aTHX_ packWARN(WARN_MISC),
2446 "Invalid TOKEN object ignored");
2453 /* faked up qw list? */
2455 tm->mad_type == MAD_SV &&
2456 SvPVX((SV*)tm->mad_val)[0] == 'q')
2463 /* pretend constant fold didn't happen? */
2464 if (mp->mad_key == 'f' &&
2465 (o->op_type == OP_CONST ||
2466 o->op_type == OP_GV) )
2468 token_getmad(tk,(OP*)mp->mad_val,slot);
2482 if (mp->mad_key == 'X')
2483 mp->mad_key = slot; /* just change the first one */
2493 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2502 /* pretend constant fold didn't happen? */
2503 if (mp->mad_key == 'f' &&
2504 (o->op_type == OP_CONST ||
2505 o->op_type == OP_GV) )
2507 op_getmad(from,(OP*)mp->mad_val,slot);
2514 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2517 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2523 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2532 /* pretend constant fold didn't happen? */
2533 if (mp->mad_key == 'f' &&
2534 (o->op_type == OP_CONST ||
2535 o->op_type == OP_GV) )
2537 op_getmad(from,(OP*)mp->mad_val,slot);
2544 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2547 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2551 PerlIO_printf(PerlIO_stderr(),
2552 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2558 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2576 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2580 addmad(tm, &(o->op_madprop), slot);
2584 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2605 Perl_newMADsv(pTHX_ char key, SV* sv)
2607 return newMADPROP(key, MAD_SV, sv, 0);
2611 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2614 Newxz(mp, 1, MADPROP);
2617 mp->mad_vlen = vlen;
2618 mp->mad_type = type;
2620 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2625 Perl_mad_free(pTHX_ MADPROP* mp)
2627 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2631 mad_free(mp->mad_next);
2632 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2633 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2634 switch (mp->mad_type) {
2638 Safefree((char*)mp->mad_val);
2641 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2642 op_free((OP*)mp->mad_val);
2645 sv_free((SV*)mp->mad_val);
2648 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2657 Perl_newNULLLIST(pTHX)
2659 return newOP(OP_STUB, 0);
2663 Perl_force_list(pTHX_ OP *o)
2665 if (!o || o->op_type != OP_LIST)
2666 o = newLISTOP(OP_LIST, 0, o, NULL);
2672 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2677 NewOp(1101, listop, 1, LISTOP);
2679 listop->op_type = (OPCODE)type;
2680 listop->op_ppaddr = PL_ppaddr[type];
2683 listop->op_flags = (U8)flags;
2687 else if (!first && last)
2690 first->op_sibling = last;
2691 listop->op_first = first;
2692 listop->op_last = last;
2693 if (type == OP_LIST) {
2694 OP* const pushop = newOP(OP_PUSHMARK, 0);
2695 pushop->op_sibling = first;
2696 listop->op_first = pushop;
2697 listop->op_flags |= OPf_KIDS;
2699 listop->op_last = pushop;
2702 return CHECKOP(type, listop);
2706 Perl_newOP(pTHX_ I32 type, I32 flags)
2710 NewOp(1101, o, 1, OP);
2711 o->op_type = (OPCODE)type;
2712 o->op_ppaddr = PL_ppaddr[type];
2713 o->op_flags = (U8)flags;
2716 o->op_private = (U8)(0 | (flags >> 8));
2717 if (PL_opargs[type] & OA_RETSCALAR)
2719 if (PL_opargs[type] & OA_TARGET)
2720 o->op_targ = pad_alloc(type, SVs_PADTMP);
2721 return CHECKOP(type, o);
2725 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2731 first = newOP(OP_STUB, 0);
2732 if (PL_opargs[type] & OA_MARK)
2733 first = force_list(first);
2735 NewOp(1101, unop, 1, UNOP);
2736 unop->op_type = (OPCODE)type;
2737 unop->op_ppaddr = PL_ppaddr[type];
2738 unop->op_first = first;
2739 unop->op_flags = (U8)(flags | OPf_KIDS);
2740 unop->op_private = (U8)(1 | (flags >> 8));
2741 unop = (UNOP*) CHECKOP(type, unop);
2745 return fold_constants((OP *) unop);
2749 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2753 NewOp(1101, binop, 1, BINOP);
2756 first = newOP(OP_NULL, 0);
2758 binop->op_type = (OPCODE)type;
2759 binop->op_ppaddr = PL_ppaddr[type];
2760 binop->op_first = first;
2761 binop->op_flags = (U8)(flags | OPf_KIDS);
2764 binop->op_private = (U8)(1 | (flags >> 8));
2767 binop->op_private = (U8)(2 | (flags >> 8));
2768 first->op_sibling = last;
2771 binop = (BINOP*)CHECKOP(type, binop);
2772 if (binop->op_next || binop->op_type != (OPCODE)type)
2775 binop->op_last = binop->op_first->op_sibling;
2777 return fold_constants((OP *)binop);
2780 static int uvcompare(const void *a, const void *b)
2781 __attribute__nonnull__(1)
2782 __attribute__nonnull__(2)
2783 __attribute__pure__;
2784 static int uvcompare(const void *a, const void *b)
2786 if (*((const UV *)a) < (*(const UV *)b))
2788 if (*((const UV *)a) > (*(const UV *)b))
2790 if (*((const UV *)a+1) < (*(const UV *)b+1))
2792 if (*((const UV *)a+1) > (*(const UV *)b+1))
2798 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2801 SV * const tstr = ((SVOP*)expr)->op_sv;
2802 SV * const rstr = ((SVOP*)repl)->op_sv;
2805 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2806 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2810 register short *tbl;
2812 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2813 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2814 I32 del = o->op_private & OPpTRANS_DELETE;
2815 PL_hints |= HINT_BLOCK_SCOPE;
2818 o->op_private |= OPpTRANS_FROM_UTF;
2821 o->op_private |= OPpTRANS_TO_UTF;
2823 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2824 SV* const listsv = newSVpvs("# comment\n");
2826 const U8* tend = t + tlen;
2827 const U8* rend = r + rlen;
2841 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2842 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2848 t = tsave = bytes_to_utf8(t, &len);
2851 if (!to_utf && rlen) {
2853 r = rsave = bytes_to_utf8(r, &len);
2857 /* There are several snags with this code on EBCDIC:
2858 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2859 2. scan_const() in toke.c has encoded chars in native encoding which makes
2860 ranges at least in EBCDIC 0..255 range the bottom odd.
2864 U8 tmpbuf[UTF8_MAXBYTES+1];
2867 Newx(cp, 2*tlen, UV);
2869 transv = newSVpvs("");
2871 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2873 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2875 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2879 cp[2*i+1] = cp[2*i];
2883 qsort(cp, i, 2*sizeof(UV), uvcompare);
2884 for (j = 0; j < i; j++) {
2886 diff = val - nextmin;
2888 t = uvuni_to_utf8(tmpbuf,nextmin);
2889 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2891 U8 range_mark = UTF_TO_NATIVE(0xff);
2892 t = uvuni_to_utf8(tmpbuf, val - 1);
2893 sv_catpvn(transv, (char *)&range_mark, 1);
2894 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2901 t = uvuni_to_utf8(tmpbuf,nextmin);
2902 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2904 U8 range_mark = UTF_TO_NATIVE(0xff);
2905 sv_catpvn(transv, (char *)&range_mark, 1);
2907 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2908 UNICODE_ALLOW_SUPER);
2909 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2910 t = (const U8*)SvPVX_const(transv);
2911 tlen = SvCUR(transv);
2915 else if (!rlen && !del) {
2916 r = t; rlen = tlen; rend = tend;
2919 if ((!rlen && !del) || t == r ||
2920 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2922 o->op_private |= OPpTRANS_IDENTICAL;
2926 while (t < tend || tfirst <= tlast) {
2927 /* see if we need more "t" chars */
2928 if (tfirst > tlast) {
2929 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2931 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2933 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2940 /* now see if we need more "r" chars */
2941 if (rfirst > rlast) {
2943 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2945 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2947 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2956 rfirst = rlast = 0xffffffff;
2960 /* now see which range will peter our first, if either. */
2961 tdiff = tlast - tfirst;
2962 rdiff = rlast - rfirst;
2969 if (rfirst == 0xffffffff) {
2970 diff = tdiff; /* oops, pretend rdiff is infinite */
2972 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2973 (long)tfirst, (long)tlast);
2975 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2979 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2980 (long)tfirst, (long)(tfirst + diff),
2983 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2984 (long)tfirst, (long)rfirst);
2986 if (rfirst + diff > max)
2987 max = rfirst + diff;
2989 grows = (tfirst < rfirst &&
2990 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3002 else if (max > 0xff)
3007 Safefree(cPVOPo->op_pv);
3008 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3009 SvREFCNT_dec(listsv);
3010 SvREFCNT_dec(transv);
3012 if (!del && havefinal && rlen)
3013 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3014 newSVuv((UV)final), 0);
3017 o->op_private |= OPpTRANS_GROWS;
3023 op_getmad(expr,o,'e');
3024 op_getmad(repl,o,'r');
3032 tbl = (short*)cPVOPo->op_pv;
3034 Zero(tbl, 256, short);
3035 for (i = 0; i < (I32)tlen; i++)
3037 for (i = 0, j = 0; i < 256; i++) {
3039 if (j >= (I32)rlen) {
3048 if (i < 128 && r[j] >= 128)
3058 o->op_private |= OPpTRANS_IDENTICAL;
3060 else if (j >= (I32)rlen)
3063 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3064 tbl[0x100] = (short)(rlen - j);
3065 for (i=0; i < (I32)rlen - j; i++)
3066 tbl[0x101+i] = r[j+i];
3070 if (!rlen && !del) {
3073 o->op_private |= OPpTRANS_IDENTICAL;
3075 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3076 o->op_private |= OPpTRANS_IDENTICAL;
3078 for (i = 0; i < 256; i++)
3080 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3081 if (j >= (I32)rlen) {
3083 if (tbl[t[i]] == -1)
3089 if (tbl[t[i]] == -1) {
3090 if (t[i] < 128 && r[j] >= 128)
3097 o->op_private |= OPpTRANS_GROWS;
3099 op_getmad(expr,o,'e');
3100 op_getmad(repl,o,'r');
3110 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3115 NewOp(1101, pmop, 1, PMOP);
3116 pmop->op_type = (OPCODE)type;
3117 pmop->op_ppaddr = PL_ppaddr[type];
3118 pmop->op_flags = (U8)flags;
3119 pmop->op_private = (U8)(0 | (flags >> 8));
3121 if (PL_hints & HINT_RE_TAINT)
3122 pmop->op_pmpermflags |= PMf_RETAINT;
3123 if (PL_hints & HINT_LOCALE)
3124 pmop->op_pmpermflags |= PMf_LOCALE;
3125 pmop->op_pmflags = pmop->op_pmpermflags;
3128 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3129 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3130 pmop->op_pmoffset = SvIV(repointer);
3131 SvREPADTMP_off(repointer);
3132 sv_setiv(repointer,0);
3134 SV * const repointer = newSViv(0);
3135 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3136 pmop->op_pmoffset = av_len(PL_regex_padav);
3137 PL_regex_pad = AvARRAY(PL_regex_padav);
3141 /* link into pm list */
3142 if (type != OP_TRANS && PL_curstash) {
3143 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3146 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3148 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3149 mg->mg_obj = (SV*)pmop;
3150 PmopSTASH_set(pmop,PL_curstash);
3153 return CHECKOP(type, pmop);
3156 /* Given some sort of match op o, and an expression expr containing a
3157 * pattern, either compile expr into a regex and attach it to o (if it's
3158 * constant), or convert expr into a runtime regcomp op sequence (if it's
3161 * isreg indicates that the pattern is part of a regex construct, eg
3162 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3163 * split "pattern", which aren't. In the former case, expr will be a list
3164 * if the pattern contains more than one term (eg /a$b/) or if it contains
3165 * a replacement, ie s/// or tr///.
3169 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3174 I32 repl_has_vars = 0;
3178 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3179 /* last element in list is the replacement; pop it */
3181 repl = cLISTOPx(expr)->op_last;
3182 kid = cLISTOPx(expr)->op_first;
3183 while (kid->op_sibling != repl)
3184 kid = kid->op_sibling;
3185 kid->op_sibling = NULL;
3186 cLISTOPx(expr)->op_last = kid;
3189 if (isreg && expr->op_type == OP_LIST &&
3190 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3192 /* convert single element list to element */
3193 OP* const oe = expr;
3194 expr = cLISTOPx(oe)->op_first->op_sibling;
3195 cLISTOPx(oe)->op_first->op_sibling = NULL;
3196 cLISTOPx(oe)->op_last = NULL;
3200 if (o->op_type == OP_TRANS) {
3201 return pmtrans(o, expr, repl);
3204 reglist = isreg && expr->op_type == OP_LIST;
3208 PL_hints |= HINT_BLOCK_SCOPE;
3211 if (expr->op_type == OP_CONST) {
3213 SV * const pat = ((SVOP*)expr)->op_sv;
3214 const char *p = SvPV_const(pat, plen);
3215 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3216 U32 was_readonly = SvREADONLY(pat);
3220 sv_force_normal_flags(pat, 0);
3221 assert(!SvREADONLY(pat));
3224 SvREADONLY_off(pat);
3228 sv_setpvn(pat, "\\s+", 3);
3230 SvFLAGS(pat) |= was_readonly;
3232 p = SvPV_const(pat, plen);
3233 pm->op_pmflags |= PMf_SKIPWHITE;
3236 pm->op_pmdynflags |= PMdf_UTF8;
3237 /* FIXME - can we make this function take const char * args? */
3238 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3239 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3240 pm->op_pmflags |= PMf_WHITE;
3242 op_getmad(expr,(OP*)pm,'e');
3248 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3249 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3251 : OP_REGCMAYBE),0,expr);
3253 NewOp(1101, rcop, 1, LOGOP);
3254 rcop->op_type = OP_REGCOMP;
3255 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3256 rcop->op_first = scalar(expr);
3257 rcop->op_flags |= OPf_KIDS
3258 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3259 | (reglist ? OPf_STACKED : 0);
3260 rcop->op_private = 1;
3263 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3265 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3268 /* establish postfix order */
3269 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3271 rcop->op_next = expr;
3272 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3275 rcop->op_next = LINKLIST(expr);
3276 expr->op_next = (OP*)rcop;
3279 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3284 if (pm->op_pmflags & PMf_EVAL) {
3286 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3287 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3289 else if (repl->op_type == OP_CONST)
3293 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3294 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3295 if (curop->op_type == OP_GV) {
3296 GV * const gv = cGVOPx_gv(curop);
3298 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3301 else if (curop->op_type == OP_RV2CV)
3303 else if (curop->op_type == OP_RV2SV ||
3304 curop->op_type == OP_RV2AV ||
3305 curop->op_type == OP_RV2HV ||
3306 curop->op_type == OP_RV2GV) {
3307 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3310 else if (curop->op_type == OP_PADSV ||
3311 curop->op_type == OP_PADAV ||
3312 curop->op_type == OP_PADHV ||
3313 curop->op_type == OP_PADANY) {
3316 else if (curop->op_type == OP_PUSHRE)
3317 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
3327 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3328 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3329 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3330 prepend_elem(o->op_type, scalar(repl), o);
3333 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3334 pm->op_pmflags |= PMf_MAYBE_CONST;
3335 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3337 NewOp(1101, rcop, 1, LOGOP);
3338 rcop->op_type = OP_SUBSTCONT;
3339 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3340 rcop->op_first = scalar(repl);
3341 rcop->op_flags |= OPf_KIDS;
3342 rcop->op_private = 1;
3345 /* establish postfix order */
3346 rcop->op_next = LINKLIST(repl);
3347 repl->op_next = (OP*)rcop;
3349 pm->op_pmreplroot = scalar((OP*)rcop);
3350 pm->op_pmreplstart = LINKLIST(rcop);
3359 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3363 NewOp(1101, svop, 1, SVOP);
3364 svop->op_type = (OPCODE)type;
3365 svop->op_ppaddr = PL_ppaddr[type];
3367 svop->op_next = (OP*)svop;
3368 svop->op_flags = (U8)flags;
3369 if (PL_opargs[type] & OA_RETSCALAR)
3371 if (PL_opargs[type] & OA_TARGET)
3372 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3373 return CHECKOP(type, svop);
3377 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3381 NewOp(1101, padop, 1, PADOP);
3382 padop->op_type = (OPCODE)type;
3383 padop->op_ppaddr = PL_ppaddr[type];
3384 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3385 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3386 PAD_SETSV(padop->op_padix, sv);
3389 padop->op_next = (OP*)padop;
3390 padop->op_flags = (U8)flags;
3391 if (PL_opargs[type] & OA_RETSCALAR)
3393 if (PL_opargs[type] & OA_TARGET)
3394 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3395 return CHECKOP(type, padop);
3399 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3405 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3407 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3412 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3416 NewOp(1101, pvop, 1, PVOP);
3417 pvop->op_type = (OPCODE)type;
3418 pvop->op_ppaddr = PL_ppaddr[type];
3420 pvop->op_next = (OP*)pvop;
3421 pvop->op_flags = (U8)flags;
3422 if (PL_opargs[type] & OA_RETSCALAR)
3424 if (PL_opargs[type] & OA_TARGET)
3425 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3426 return CHECKOP(type, pvop);
3434 Perl_package(pTHX_ OP *o)
3443 save_hptr(&PL_curstash);
3444 save_item(PL_curstname);
3446 name = SvPV_const(cSVOPo->op_sv, len);
3447 PL_curstash = gv_stashpvn(name, len, TRUE);
3448 sv_setpvn(PL_curstname, name, len);
3450 PL_hints |= HINT_BLOCK_SCOPE;
3451 PL_copline = NOLINE;
3457 if (!PL_madskills) {
3462 pegop = newOP(OP_NULL,0);
3463 op_getmad(o,pegop,'P');
3473 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3480 OP *pegop = newOP(OP_NULL,0);
3483 if (idop->op_type != OP_CONST)
3484 Perl_croak(aTHX_ "Module name must be constant");
3487 op_getmad(idop,pegop,'U');
3492 SV * const vesv = ((SVOP*)version)->op_sv;
3495 op_getmad(version,pegop,'V');
3496 if (!arg && !SvNIOKp(vesv)) {
3503 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3504 Perl_croak(aTHX_ "Version number must be constant number");
3506 /* Make copy of idop so we don't free it twice */
3507 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3509 /* Fake up a method call to VERSION */
3510 meth = newSVpvs_share("VERSION");
3511 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3512 append_elem(OP_LIST,
3513 prepend_elem(OP_LIST, pack, list(version)),
3514 newSVOP(OP_METHOD_NAMED, 0, meth)));
3518 /* Fake up an import/unimport */
3519 if (arg && arg->op_type == OP_STUB) {
3521 op_getmad(arg,pegop,'S');
3522 imop = arg; /* no import on explicit () */
3524 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3525 imop = NULL; /* use 5.0; */
3527 idop->op_private |= OPpCONST_NOVER;
3533 op_getmad(arg,pegop,'A');
3535 /* Make copy of idop so we don't free it twice */
3536 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3538 /* Fake up a method call to import/unimport */
3540 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3541 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3542 append_elem(OP_LIST,
3543 prepend_elem(OP_LIST, pack, list(arg)),
3544 newSVOP(OP_METHOD_NAMED, 0, meth)));
3547 /* Fake up the BEGIN {}, which does its thing immediately. */
3549 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3552 append_elem(OP_LINESEQ,
3553 append_elem(OP_LINESEQ,
3554 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3555 newSTATEOP(0, NULL, veop)),
3556 newSTATEOP(0, NULL, imop) ));
3558 /* The "did you use incorrect case?" warning used to be here.
3559 * The problem is that on case-insensitive filesystems one
3560 * might get false positives for "use" (and "require"):
3561 * "use Strict" or "require CARP" will work. This causes
3562 * portability problems for the script: in case-strict
3563 * filesystems the script will stop working.
3565 * The "incorrect case" warning checked whether "use Foo"
3566 * imported "Foo" to your namespace, but that is wrong, too:
3567 * there is no requirement nor promise in the language that
3568 * a Foo.pm should or would contain anything in package "Foo".
3570 * There is very little Configure-wise that can be done, either:
3571 * the case-sensitivity of the build filesystem of Perl does not
3572 * help in guessing the case-sensitivity of the runtime environment.
3575 PL_hints |= HINT_BLOCK_SCOPE;
3576 PL_copline = NOLINE;
3578 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3581 if (!PL_madskills) {
3582 /* FIXME - don't allocate pegop if !PL_madskills */
3591 =head1 Embedding Functions
3593 =for apidoc load_module
3595 Loads the module whose name is pointed to by the string part of name.
3596 Note that the actual module name, not its filename, should be given.
3597 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3598 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3599 (or 0 for no flags). ver, if specified, provides version semantics
3600 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3601 arguments can be used to specify arguments to the module's import()
3602 method, similar to C<use Foo::Bar VERSION LIST>.
3607 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3610 va_start(args, ver);
3611 vload_module(flags, name, ver, &args);
3615 #ifdef PERL_IMPLICIT_CONTEXT
3617 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3621 va_start(args, ver);
3622 vload_module(flags, name, ver, &args);
3628 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3633 OP * const modname = newSVOP(OP_CONST, 0, name);
3634 modname->op_private |= OPpCONST_BARE;
3636 veop = newSVOP(OP_CONST, 0, ver);
3640 if (flags & PERL_LOADMOD_NOIMPORT) {
3641 imop = sawparens(newNULLLIST());
3643 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3644 imop = va_arg(*args, OP*);
3649 sv = va_arg(*args, SV*);
3651 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3652 sv = va_arg(*args, SV*);
3656 const line_t ocopline = PL_copline;
3657 COP * const ocurcop = PL_curcop;
3658 const int oexpect = PL_expect;
3660 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3661 veop, modname, imop);
3662 PL_expect = oexpect;
3663 PL_copline = ocopline;
3664 PL_curcop = ocurcop;
3669 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3675 if (!force_builtin) {
3676 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3677 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3678 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3679 gv = gvp ? *gvp : NULL;
3683 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3684 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3685 append_elem(OP_LIST, term,
3686 scalar(newUNOP(OP_RV2CV, 0,
3687 newGVOP(OP_GV, 0, gv))))));
3690 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3696 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3698 return newBINOP(OP_LSLICE, flags,
3699 list(force_list(subscript)),
3700 list(force_list(listval)) );
3704 S_is_list_assignment(pTHX_ register const OP *o)
3709 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3710 o = cUNOPo->op_first;
3712 if (o->op_type == OP_COND_EXPR) {
3713 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3714 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3719 yyerror("Assignment to both a list and a scalar");
3723 if (o->op_type == OP_LIST &&
3724 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3725 o->op_private & OPpLVAL_INTRO)
3728 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3729 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3730 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3733 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3736 if (o->op_type == OP_RV2SV)
3743 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3749 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3750 return newLOGOP(optype, 0,
3751 mod(scalar(left), optype),
3752 newUNOP(OP_SASSIGN, 0, scalar(right)));
3755 return newBINOP(optype, OPf_STACKED,
3756 mod(scalar(left), optype), scalar(right));
3760 if (is_list_assignment(left)) {
3764 /* Grandfathering $[ assignment here. Bletch.*/
3765 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3766 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3767 left = mod(left, OP_AASSIGN);
3770 else if (left->op_type == OP_CONST) {
3772 /* Result of assignment is always 1 (or we'd be dead already) */
3773 return newSVOP(OP_CONST, 0, newSViv(1));
3775 curop = list(force_list(left));
3776 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3777 o->op_private = (U8)(0 | (flags >> 8));
3779 /* PL_generation sorcery:
3780 * an assignment like ($a,$b) = ($c,$d) is easier than
3781 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3782 * To detect whether there are common vars, the global var
3783 * PL_generation is incremented for each assign op we compile.
3784 * Then, while compiling the assign op, we run through all the
3785 * variables on both sides of the assignment, setting a spare slot
3786 * in each of them to PL_generation. If any of them already have
3787 * that value, we know we've got commonality. We could use a
3788 * single bit marker, but then we'd have to make 2 passes, first
3789 * to clear the flag, then to test and set it. To find somewhere
3790 * to store these values, evil chicanery is done with SvCUR().
3793 if (!(left->op_private & OPpLVAL_INTRO)) {
3796 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3797 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3798 if (curop->op_type == OP_GV) {
3799 GV *gv = cGVOPx_gv(curop);
3801 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3803 GvASSIGN_GENERATION_set(gv, PL_generation);
3805 else if (curop->op_type == OP_PADSV ||
3806 curop->op_type == OP_PADAV ||
3807 curop->op_type == OP_PADHV ||
3808 curop->op_type == OP_PADANY)
3810 if (PAD_COMPNAME_GEN(curop->op_targ)
3811 == (STRLEN)PL_generation)
3813 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3816 else if (curop->op_type == OP_RV2CV)
3818 else if (curop->op_type == OP_RV2SV ||
3819 curop->op_type == OP_RV2AV ||
3820 curop->op_type == OP_RV2HV ||
3821 curop->op_type == OP_RV2GV) {
3822 if (lastop->op_type != OP_GV) /* funny deref? */
3825 else if (curop->op_type == OP_PUSHRE) {
3826 if (((PMOP*)curop)->op_pmreplroot) {
3828 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3829 ((PMOP*)curop)->op_pmreplroot));
3831 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3834 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3836 GvASSIGN_GENERATION_set(gv, PL_generation);
3837 GvASSIGN_GENERATION_set(gv, PL_generation);
3846 o->op_private |= OPpASSIGN_COMMON;
3848 if (right && right->op_type == OP_SPLIT) {
3850 if ((tmpop = ((LISTOP*)right)->op_first) &&
3851 tmpop->op_type == OP_PUSHRE)
3853 PMOP * const pm = (PMOP*)tmpop;
3854 if (left->op_type == OP_RV2AV &&
3855 !(left->op_private & OPpLVAL_INTRO) &&
3856 !(o->op_private & OPpASSIGN_COMMON) )
3858 tmpop = ((UNOP*)left)->op_first;
3859 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3861 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3862 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3864 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3865 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3867 pm->op_pmflags |= PMf_ONCE;
3868 tmpop = cUNOPo->op_first; /* to list (nulled) */
3869 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3870 tmpop->op_sibling = NULL; /* don't free split */
3871 right->op_next = tmpop->op_next; /* fix starting loc */
3873 op_getmad(o,right,'R'); /* blow off assign */
3875 op_free(o); /* blow off assign */
3877 right->op_flags &= ~OPf_WANT;
3878 /* "I don't know and I don't care." */
3883 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3884 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3886 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3888 sv_setiv(sv, PL_modcount+1);
3896 right = newOP(OP_UNDEF, 0);
3897 if (right->op_type == OP_READLINE) {
3898 right->op_flags |= OPf_STACKED;
3899 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3902 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3903 o = newBINOP(OP_SASSIGN, flags,
3904 scalar(right), mod(scalar(left), OP_SASSIGN) );
3910 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3911 o->op_private |= OPpCONST_ARYBASE;
3918 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3921 const U32 seq = intro_my();
3924 NewOp(1101, cop, 1, COP);
3925 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3926 cop->op_type = OP_DBSTATE;
3927 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3930 cop->op_type = OP_NEXTSTATE;
3931 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3933 cop->op_flags = (U8)flags;
3934 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3936 cop->op_private |= NATIVE_HINTS;
3938 PL_compiling.op_private = cop->op_private;
3939 cop->op_next = (OP*)cop;
3942 cop->cop_label = label;
3943 PL_hints |= HINT_BLOCK_SCOPE;
3946 CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
3947 if (specialWARN(PL_curcop->cop_warnings))
3948 cop->cop_warnings = PL_curcop->cop_warnings ;
3950 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3951 if (specialCopIO(PL_curcop->cop_io))
3952 cop->cop_io = PL_curcop->cop_io;
3954 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3955 cop->cop_hints = PL_curcop->cop_hints;
3956 if (cop->cop_hints) {
3957 cop->cop_hints->refcounted_he_refcnt++;
3960 if (PL_copline == NOLINE)
3961 CopLINE_set(cop, CopLINE(PL_curcop));
3963 CopLINE_set(cop, PL_copline);
3964 PL_copline = NOLINE;
3967 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3969 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3971 CopSTASH_set(cop, PL_curstash);
3973 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3974 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3975 if (svp && *svp != &PL_sv_undef ) {
3976 (void)SvIOK_on(*svp);
3977 SvIV_set(*svp, PTR2IV(cop));
3981 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3986 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3989 return new_logop(type, flags, &first, &other);
3993 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3998 OP *first = *firstp;
3999 OP * const other = *otherp;
4001 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4002 return newBINOP(type, flags, scalar(first), scalar(other));
4004 scalarboolean(first);
4005 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4006 if (first->op_type == OP_NOT
4007 && (first->op_flags & OPf_SPECIAL)
4008 && (first->op_flags & OPf_KIDS)) {
4009 if (type == OP_AND || type == OP_OR) {
4015 first = *firstp = cUNOPo->op_first;
4017 first->op_next = o->op_next;
4018 cUNOPo->op_first = NULL;
4020 op_getmad(o,first,'O');
4026 if (first->op_type == OP_CONST) {
4027 if (first->op_private & OPpCONST_STRICT)
4028 no_bareword_allowed(first);
4029 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4030 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4031 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4032 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4033 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4035 if (other->op_type == OP_CONST)
4036 other->op_private |= OPpCONST_SHORTCIRCUIT;
4038 OP *newop = newUNOP(OP_NULL, 0, other);
4039 op_getmad(first, newop, '1');
4040 newop->op_targ = type; /* set "was" field */
4047 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4048 const OP *o2 = other;
4049 if ( ! (o2->op_type == OP_LIST
4050 && (( o2 = cUNOPx(o2)->op_first))
4051 && o2->op_type == OP_PUSHMARK
4052 && (( o2 = o2->op_sibling)) )
4055 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4056 || o2->op_type == OP_PADHV)
4057 && o2->op_private & OPpLVAL_INTRO
4058 && ckWARN(WARN_DEPRECATED))
4060 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4061 "Deprecated use of my() in false conditional");
4065 if (first->op_type == OP_CONST)
4066 first->op_private |= OPpCONST_SHORTCIRCUIT;
4068 first = newUNOP(OP_NULL, 0, first);
4069 op_getmad(other, first, '2');
4070 first->op_targ = type; /* set "was" field */
4077 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4078 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4080 const OP * const k1 = ((UNOP*)first)->op_first;
4081 const OP * const k2 = k1->op_sibling;
4083 switch (first->op_type)
4086 if (k2 && k2->op_type == OP_READLINE
4087 && (k2->op_flags & OPf_STACKED)
4088 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4090 warnop = k2->op_type;
4095 if (k1->op_type == OP_READDIR
4096 || k1->op_type == OP_GLOB
4097 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4098 || k1->op_type == OP_EACH)
4100 warnop = ((k1->op_type == OP_NULL)
4101 ? (OPCODE)k1->op_targ : k1->op_type);
4106 const line_t oldline = CopLINE(PL_curcop);
4107 CopLINE_set(PL_curcop, PL_copline);
4108 Perl_warner(aTHX_ packWARN(WARN_MISC),
4109 "Value of %s%s can be \"0\"; test with defined()",
4111 ((warnop == OP_READLINE || warnop == OP_GLOB)
4112 ? " construct" : "() operator"));
4113 CopLINE_set(PL_curcop, oldline);
4120 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4121 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4123 NewOp(1101, logop, 1, LOGOP);
4125 logop->op_type = (OPCODE)type;
4126 logop->op_ppaddr = PL_ppaddr[type];
4127 logop->op_first = first;
4128 logop->op_flags = (U8)(flags | OPf_KIDS);
4129 logop->op_other = LINKLIST(other);
4130 logop->op_private = (U8)(1 | (flags >> 8));
4132 /* establish postfix order */
4133 logop->op_next = LINKLIST(first);
4134 first->op_next = (OP*)logop;
4135 first->op_sibling = other;
4137 CHECKOP(type,logop);
4139 o = newUNOP(OP_NULL, 0, (OP*)logop);
4146 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4154 return newLOGOP(OP_AND, 0, first, trueop);
4156 return newLOGOP(OP_OR, 0, first, falseop);
4158 scalarboolean(first);
4159 if (first->op_type == OP_CONST) {
4160 if (first->op_private & OPpCONST_BARE &&
4161 first->op_private & OPpCONST_STRICT) {
4162 no_bareword_allowed(first);
4164 if (SvTRUE(((SVOP*)first)->op_sv)) {
4167 trueop = newUNOP(OP_NULL, 0, trueop);
4168 op_getmad(first,trueop,'C');
4169 op_getmad(falseop,trueop,'e');
4171 /* FIXME for MAD - should there be an ELSE here? */
4181 falseop = newUNOP(OP_NULL, 0, falseop);
4182 op_getmad(first,falseop,'C');
4183 op_getmad(trueop,falseop,'t');
4185 /* FIXME for MAD - should there be an ELSE here? */
4193 NewOp(1101, logop, 1, LOGOP);
4194 logop->op_type = OP_COND_EXPR;
4195 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4196 logop->op_first = first;
4197 logop->op_flags = (U8)(flags | OPf_KIDS);
4198 logop->op_private = (U8)(1 | (flags >> 8));
4199 logop->op_other = LINKLIST(trueop);
4200 logop->op_next = LINKLIST(falseop);
4202 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4205 /* establish postfix order */
4206 start = LINKLIST(first);
4207 first->op_next = (OP*)logop;
4209 first->op_sibling = trueop;
4210 trueop->op_sibling = falseop;
4211 o = newUNOP(OP_NULL, 0, (OP*)logop);
4213 trueop->op_next = falseop->op_next = o;
4220 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4229 NewOp(1101, range, 1, LOGOP);
4231 range->op_type = OP_RANGE;
4232 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4233 range->op_first = left;
4234 range->op_flags = OPf_KIDS;
4235 leftstart = LINKLIST(left);
4236 range->op_other = LINKLIST(right);
4237 range->op_private = (U8)(1 | (flags >> 8));
4239 left->op_sibling = right;
4241 range->op_next = (OP*)range;
4242 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4243 flop = newUNOP(OP_FLOP, 0, flip);
4244 o = newUNOP(OP_NULL, 0, flop);
4246 range->op_next = leftstart;
4248 left->op_next = flip;
4249 right->op_next = flop;
4251 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4252 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4253 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4254 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4256 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4257 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4260 if (!flip->op_private || !flop->op_private)
4261 linklist(o); /* blow off optimizer unless constant */
4267 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4272 const bool once = block && block->op_flags & OPf_SPECIAL &&
4273 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4275 PERL_UNUSED_ARG(debuggable);
4278 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4279 return block; /* do {} while 0 does once */
4280 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4281 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4282 expr = newUNOP(OP_DEFINED, 0,
4283 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4284 } else if (expr->op_flags & OPf_KIDS) {
4285 const OP * const k1 = ((UNOP*)expr)->op_first;
4286 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4287 switch (expr->op_type) {
4289 if (k2 && k2->op_type == OP_READLINE
4290 && (k2->op_flags & OPf_STACKED)
4291 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4292 expr = newUNOP(OP_DEFINED, 0, expr);
4296 if (k1 && (k1->op_type == OP_READDIR
4297 || k1->op_type == OP_GLOB
4298 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4299 || k1->op_type == OP_EACH))
4300 expr = newUNOP(OP_DEFINED, 0, expr);
4306 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4307 * op, in listop. This is wrong. [perl #27024] */
4309 block = newOP(OP_NULL, 0);
4310 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4311 o = new_logop(OP_AND, 0, &expr, &listop);
4314 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4316 if (once && o != listop)
4317 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4320 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4322 o->op_flags |= flags;
4324 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4329 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4330 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4339 PERL_UNUSED_ARG(debuggable);
4342 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4343 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4344 expr = newUNOP(OP_DEFINED, 0,
4345 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4346 } else if (expr->op_flags & OPf_KIDS) {
4347 const OP * const k1 = ((UNOP*)expr)->op_first;
4348 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4349 switch (expr->op_type) {
4351 if (k2 && k2->op_type == OP_READLINE
4352 && (k2->op_flags & OPf_STACKED)
4353 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4354 expr = newUNOP(OP_DEFINED, 0, expr);
4358 if (k1 && (k1->op_type == OP_READDIR
4359 || k1->op_type == OP_GLOB
4360 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4361 || k1->op_type == OP_EACH))
4362 expr = newUNOP(OP_DEFINED, 0, expr);
4369 block = newOP(OP_NULL, 0);
4370 else if (cont || has_my) {
4371 block = scope(block);
4375 next = LINKLIST(cont);
4378 OP * const unstack = newOP(OP_UNSTACK, 0);
4381 cont = append_elem(OP_LINESEQ, cont, unstack);
4384 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4385 redo = LINKLIST(listop);
4388 PL_copline = (line_t)whileline;
4390 o = new_logop(OP_AND, 0, &expr, &listop);
4391 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4392 op_free(expr); /* oops, it's a while (0) */
4394 return NULL; /* listop already freed by new_logop */
4397 ((LISTOP*)listop)->op_last->op_next =
4398 (o == listop ? redo : LINKLIST(o));
4404 NewOp(1101,loop,1,LOOP);
4405 loop->op_type = OP_ENTERLOOP;
4406 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4407 loop->op_private = 0;
4408 loop->op_next = (OP*)loop;
4411 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4413 loop->op_redoop = redo;
4414 loop->op_lastop = o;
4415 o->op_private |= loopflags;
4418 loop->op_nextop = next;
4420 loop->op_nextop = o;
4422 o->op_flags |= flags;
4423 o->op_private |= (flags >> 8);
4428 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4433 PADOFFSET padoff = 0;
4439 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4440 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4441 sv->op_type = OP_RV2GV;
4442 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4443 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4444 iterpflags |= OPpITER_DEF;
4446 else if (sv->op_type == OP_PADSV) { /* private variable */
4447 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4448 padoff = sv->op_targ;
4457 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4458 padoff = sv->op_targ;
4463 iterflags |= OPf_SPECIAL;
4469 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4470 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4471 iterpflags |= OPpITER_DEF;
4474 const I32 offset = pad_findmy("$_");
4475 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4476 sv = newGVOP(OP_GV, 0, PL_defgv);
4481 iterpflags |= OPpITER_DEF;
4483 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4484 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4485 iterflags |= OPf_STACKED;
4487 else if (expr->op_type == OP_NULL &&
4488 (expr->op_flags & OPf_KIDS) &&
4489 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4491 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4492 * set the STACKED flag to indicate that these values are to be
4493 * treated as min/max values by 'pp_iterinit'.
4495 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4496 LOGOP* const range = (LOGOP*) flip->op_first;
4497 OP* const left = range->op_first;
4498 OP* const right = left->op_sibling;
4501 range->op_flags &= ~OPf_KIDS;
4502 range->op_first = NULL;
4504 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4505 listop->op_first->op_next = range->op_next;
4506 left->op_next = range->op_other;
4507 right->op_next = (OP*)listop;
4508 listop->op_next = listop->op_first;
4511 op_getmad(expr,(OP*)listop,'O');
4515 expr = (OP*)(listop);
4517 iterflags |= OPf_STACKED;
4520 expr = mod(force_list(expr), OP_GREPSTART);
4523 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4524 append_elem(OP_LIST, expr, scalar(sv))));
4525 assert(!loop->op_next);
4526 /* for my $x () sets OPpLVAL_INTRO;
4527 * for our $x () sets OPpOUR_INTRO */
4528 loop->op_private = (U8)iterpflags;
4529 #ifdef PL_OP_SLAB_ALLOC
4532 NewOp(1234,tmp,1,LOOP);
4533 Copy(loop,tmp,1,LISTOP);
4538 Renew(loop, 1, LOOP);
4540 loop->op_targ = padoff;
4541 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4543 op_getmad(madsv, (OP*)loop, 'v');
4544 PL_copline = forline;
4545 return newSTATEOP(0, label, wop);
4549 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4554 if (type != OP_GOTO || label->op_type == OP_CONST) {
4555 /* "last()" means "last" */
4556 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4557 o = newOP(type, OPf_SPECIAL);
4559 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4560 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4564 op_getmad(label,o,'L');
4570 /* Check whether it's going to be a goto &function */
4571 if (label->op_type == OP_ENTERSUB
4572 && !(label->op_flags & OPf_STACKED))
4573 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4574 o = newUNOP(type, OPf_STACKED, label);
4576 PL_hints |= HINT_BLOCK_SCOPE;
4580 /* if the condition is a literal array or hash
4581 (or @{ ... } etc), make a reference to it.
4584 S_ref_array_or_hash(pTHX_ OP *cond)
4587 && (cond->op_type == OP_RV2AV
4588 || cond->op_type == OP_PADAV
4589 || cond->op_type == OP_RV2HV
4590 || cond->op_type == OP_PADHV))
4592 return newUNOP(OP_REFGEN,
4593 0, mod(cond, OP_REFGEN));
4599 /* These construct the optree fragments representing given()
4602 entergiven and enterwhen are LOGOPs; the op_other pointer
4603 points up to the associated leave op. We need this so we
4604 can put it in the context and make break/continue work.
4605 (Also, of course, pp_enterwhen will jump straight to
4606 op_other if the match fails.)
4611 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4612 I32 enter_opcode, I32 leave_opcode,
4613 PADOFFSET entertarg)
4619 NewOp(1101, enterop, 1, LOGOP);
4620 enterop->op_type = enter_opcode;
4621 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4622 enterop->op_flags = (U8) OPf_KIDS;
4623 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4624 enterop->op_private = 0;
4626 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4629 enterop->op_first = scalar(cond);
4630 cond->op_sibling = block;
4632 o->op_next = LINKLIST(cond);
4633 cond->op_next = (OP *) enterop;
4636 /* This is a default {} block */
4637 enterop->op_first = block;
4638 enterop->op_flags |= OPf_SPECIAL;
4640 o->op_next = (OP *) enterop;
4643 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4644 entergiven and enterwhen both
4647 enterop->op_next = LINKLIST(block);
4648 block->op_next = enterop->op_other = o;
4653 /* Does this look like a boolean operation? For these purposes
4654 a boolean operation is:
4655 - a subroutine call [*]
4656 - a logical connective
4657 - a comparison operator
4658 - a filetest operator, with the exception of -s -M -A -C
4659 - defined(), exists() or eof()
4660 - /$re/ or $foo =~ /$re/
4662 [*] possibly surprising
4666 S_looks_like_bool(pTHX_ const OP *o)
4669 switch(o->op_type) {
4671 return looks_like_bool(cLOGOPo->op_first);
4675 looks_like_bool(cLOGOPo->op_first)
4676 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4680 case OP_NOT: case OP_XOR:
4681 /* Note that OP_DOR is not here */
4683 case OP_EQ: case OP_NE: case OP_LT:
4684 case OP_GT: case OP_LE: case OP_GE:
4686 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4687 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4689 case OP_SEQ: case OP_SNE: case OP_SLT:
4690 case OP_SGT: case OP_SLE: case OP_SGE:
4694 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4695 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4696 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4697 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4698 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4699 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4700 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4701 case OP_FTTEXT: case OP_FTBINARY:
4703 case OP_DEFINED: case OP_EXISTS:
4704 case OP_MATCH: case OP_EOF:
4709 /* Detect comparisons that have been optimized away */
4710 if (cSVOPo->op_sv == &PL_sv_yes
4711 || cSVOPo->op_sv == &PL_sv_no)
4722 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4726 return newGIVWHENOP(
4727 ref_array_or_hash(cond),
4729 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4733 /* If cond is null, this is a default {} block */
4735 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4737 const bool cond_llb = (!cond || looks_like_bool(cond));
4743 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4745 scalar(ref_array_or_hash(cond)));
4748 return newGIVWHENOP(
4750 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4751 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4755 =for apidoc cv_undef
4757 Clear out all the active components of a CV. This can happen either
4758 by an explicit C<undef &foo>, or by the reference count going to zero.
4759 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4760 children can still follow the full lexical scope chain.
4766 Perl_cv_undef(pTHX_ CV *cv)
4770 if (CvFILE(cv) && !CvISXSUB(cv)) {
4771 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4772 Safefree(CvFILE(cv));
4777 if (!CvISXSUB(cv) && CvROOT(cv)) {
4778 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4779 Perl_croak(aTHX_ "Can't undef active subroutine");
4782 PAD_SAVE_SETNULLPAD();
4784 op_free(CvROOT(cv));
4789 SvPOK_off((SV*)cv); /* forget prototype */
4794 /* remove CvOUTSIDE unless this is an undef rather than a free */
4795 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4796 if (!CvWEAKOUTSIDE(cv))
4797 SvREFCNT_dec(CvOUTSIDE(cv));
4798 CvOUTSIDE(cv) = NULL;
4801 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4804 if (CvISXSUB(cv) && CvXSUB(cv)) {
4807 /* delete all flags except WEAKOUTSIDE */
4808 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4812 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4814 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4815 SV* const msg = sv_newmortal();
4819 gv_efullname3(name = sv_newmortal(), gv, NULL);
4820 sv_setpv(msg, "Prototype mismatch:");
4822 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4824 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4826 sv_catpvs(msg, ": none");
4827 sv_catpvs(msg, " vs ");
4829 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4831 sv_catpvs(msg, "none");
4832 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4836 static void const_sv_xsub(pTHX_ CV* cv);
4840 =head1 Optree Manipulation Functions
4842 =for apidoc cv_const_sv
4844 If C<cv> is a constant sub eligible for inlining. returns the constant
4845 value returned by the sub. Otherwise, returns NULL.
4847 Constant subs can be created with C<newCONSTSUB> or as described in
4848 L<perlsub/"Constant Functions">.
4853 Perl_cv_const_sv(pTHX_ CV *cv)
4855 PERL_UNUSED_CONTEXT;
4858 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4860 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4863 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4864 * Can be called in 3 ways:
4867 * look for a single OP_CONST with attached value: return the value
4869 * cv && CvCLONE(cv) && !CvCONST(cv)
4871 * examine the clone prototype, and if contains only a single
4872 * OP_CONST referencing a pad const, or a single PADSV referencing
4873 * an outer lexical, return a non-zero value to indicate the CV is
4874 * a candidate for "constizing" at clone time
4878 * We have just cloned an anon prototype that was marked as a const
4879 * candidiate. Try to grab the current value, and in the case of
4880 * PADSV, ignore it if it has multiple references. Return the value.
4884 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4892 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4893 o = cLISTOPo->op_first->op_sibling;
4895 for (; o; o = o->op_next) {
4896 const OPCODE type = o->op_type;
4898 if (sv && o->op_next == o)
4900 if (o->op_next != o) {
4901 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4903 if (type == OP_DBSTATE)
4906 if (type == OP_LEAVESUB || type == OP_RETURN)
4910 if (type == OP_CONST && cSVOPo->op_sv)
4912 else if (cv && type == OP_CONST) {
4913 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4917 else if (cv && type == OP_PADSV) {
4918 if (CvCONST(cv)) { /* newly cloned anon */
4919 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4920 /* the candidate should have 1 ref from this pad and 1 ref
4921 * from the parent */
4922 if (!sv || SvREFCNT(sv) != 2)
4929 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4930 sv = &PL_sv_undef; /* an arbitrary non-null value */
4945 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4948 /* This would be the return value, but the return cannot be reached. */
4949 OP* pegop = newOP(OP_NULL, 0);
4952 PERL_UNUSED_ARG(floor);
4962 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4964 NORETURN_FUNCTION_END;
4969 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4971 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4975 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4982 register CV *cv = NULL;
4984 /* If the subroutine has no body, no attributes, and no builtin attributes
4985 then it's just a sub declaration, and we may be able to get away with
4986 storing with a placeholder scalar in the symbol table, rather than a
4987 full GV and CV. If anything is present then it will take a full CV to
4989 const I32 gv_fetch_flags
4990 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4992 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4993 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4996 assert(proto->op_type == OP_CONST);
4997 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5002 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5003 SV * const sv = sv_newmortal();
5004 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5005 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5006 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5007 aname = SvPVX_const(sv);
5012 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5013 : gv_fetchpv(aname ? aname
5014 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5015 gv_fetch_flags, SVt_PVCV);
5017 if (!PL_madskills) {
5026 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5027 maximum a prototype before. */
5028 if (SvTYPE(gv) > SVt_NULL) {
5029 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5030 && ckWARN_d(WARN_PROTOTYPE))
5032 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5034 cv_ckproto((CV*)gv, NULL, ps);
5037 sv_setpvn((SV*)gv, ps, ps_len);
5039 sv_setiv((SV*)gv, -1);
5040 SvREFCNT_dec(PL_compcv);
5041 cv = PL_compcv = NULL;
5042 PL_sub_generation++;
5046 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5048 #ifdef GV_UNIQUE_CHECK
5049 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5050 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5054 if (!block || !ps || *ps || attrs
5055 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5057 || block->op_type == OP_NULL
5062 const_sv = op_const_sv(block, NULL);
5065 const bool exists = CvROOT(cv) || CvXSUB(cv);
5067 #ifdef GV_UNIQUE_CHECK
5068 if (exists && GvUNIQUE(gv)) {
5069 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5073 /* if the subroutine doesn't exist and wasn't pre-declared
5074 * with a prototype, assume it will be AUTOLOADed,
5075 * skipping the prototype check
5077 if (exists || SvPOK(cv))
5078 cv_ckproto(cv, gv, ps);
5079 /* already defined (or promised)? */
5080 if (exists || GvASSUMECV(gv)) {
5083 || block->op_type == OP_NULL
5086 if (CvFLAGS(PL_compcv)) {
5087 /* might have had built-in attrs applied */
5088 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5090 /* just a "sub foo;" when &foo is already defined */
5091 SAVEFREESV(PL_compcv);
5096 && block->op_type != OP_NULL
5099 if (ckWARN(WARN_REDEFINE)
5101 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5103 const line_t oldline = CopLINE(PL_curcop);
5104 if (PL_copline != NOLINE)
5105 CopLINE_set(PL_curcop, PL_copline);
5106 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5107 CvCONST(cv) ? "Constant subroutine %s redefined"
5108 : "Subroutine %s redefined", name);
5109 CopLINE_set(PL_curcop, oldline);
5112 if (!PL_minus_c) /* keep old one around for madskills */
5115 /* (PL_madskills unset in used file.) */
5123 SvREFCNT_inc_void_NN(const_sv);
5125 assert(!CvROOT(cv) && !CvCONST(cv));
5126 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5127 CvXSUBANY(cv).any_ptr = const_sv;
5128 CvXSUB(cv) = const_sv_xsub;
5134 cv = newCONSTSUB(NULL, name, const_sv);
5136 PL_sub_generation++;
5140 SvREFCNT_dec(PL_compcv);
5148 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5149 * before we clobber PL_compcv.
5153 || block->op_type == OP_NULL
5157 /* Might have had built-in attributes applied -- propagate them. */
5158 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5159 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5160 stash = GvSTASH(CvGV(cv));
5161 else if (CvSTASH(cv))
5162 stash = CvSTASH(cv);
5164 stash = PL_curstash;
5167 /* possibly about to re-define existing subr -- ignore old cv */
5168 rcv = (SV*)PL_compcv;
5169 if (name && GvSTASH(gv))
5170 stash = GvSTASH(gv);
5172 stash = PL_curstash;
5174 apply_attrs(stash, rcv, attrs, FALSE);
5176 if (cv) { /* must reuse cv if autoloaded */
5183 || block->op_type == OP_NULL) && !PL_madskills
5186 /* got here with just attrs -- work done, so bug out */
5187 SAVEFREESV(PL_compcv);
5190 /* transfer PL_compcv to cv */
5192 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5193 if (!CvWEAKOUTSIDE(cv))
5194 SvREFCNT_dec(CvOUTSIDE(cv));
5195 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5196 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5197 CvOUTSIDE(PL_compcv) = 0;
5198 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5199 CvPADLIST(PL_compcv) = 0;
5200 /* inner references to PL_compcv must be fixed up ... */
5201 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5202 /* ... before we throw it away */
5203 SvREFCNT_dec(PL_compcv);
5205 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5206 ++PL_sub_generation;
5213 if (strEQ(name, "import")) {
5214 PL_formfeed = (SV*)cv;
5215 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5219 PL_sub_generation++;
5223 CvFILE_set_from_cop(cv, PL_curcop);
5224 CvSTASH(cv) = PL_curstash;
5227 sv_setpvn((SV*)cv, ps, ps_len);
5229 if (PL_error_count) {
5233 const char *s = strrchr(name, ':');
5235 if (strEQ(s, "BEGIN")) {
5236 const char not_safe[] =
5237 "BEGIN not safe after errors--compilation aborted";
5238 if (PL_in_eval & EVAL_KEEPERR)
5239 Perl_croak(aTHX_ not_safe);
5241 /* force display of errors found but not reported */
5242 sv_catpv(ERRSV, not_safe);
5243 Perl_croak(aTHX_ "%"SVf, ERRSV);
5253 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5254 mod(scalarseq(block), OP_LEAVESUBLV));
5257 /* This makes sub {}; work as expected. */
5258 if (block->op_type == OP_STUB) {
5259 OP* newblock = newSTATEOP(0, NULL, 0);
5261 op_getmad(block,newblock,'B');
5267 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5269 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5270 OpREFCNT_set(CvROOT(cv), 1);
5271 CvSTART(cv) = LINKLIST(CvROOT(cv));
5272 CvROOT(cv)->op_next = 0;
5273 CALL_PEEP(CvSTART(cv));
5275 /* now that optimizer has done its work, adjust pad values */
5277 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5280 assert(!CvCONST(cv));
5281 if (ps && !*ps && op_const_sv(block, cv))
5285 if (name || aname) {
5287 const char * const tname = (name ? name : aname);
5289 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5290 SV * const sv = newSV(0);
5291 SV * const tmpstr = sv_newmortal();
5292 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5293 GV_ADDMULTI, SVt_PVHV);
5296 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5298 (long)PL_subline, (long)CopLINE(PL_curcop));
5299 gv_efullname3(tmpstr, gv, NULL);
5300 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5301 hv = GvHVn(db_postponed);
5302 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5303 CV * const pcv = GvCV(db_postponed);
5309 call_sv((SV*)pcv, G_DISCARD);
5314 if ((s = strrchr(tname,':')))
5319 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5322 if (strEQ(s, "BEGIN") && !PL_error_count) {
5323 const I32 oldscope = PL_scopestack_ix;
5325 SAVECOPFILE(&PL_compiling);
5326 SAVECOPLINE(&PL_compiling);
5329 PL_beginav = newAV();
5330 DEBUG_x( dump_sub(gv) );
5331 av_push(PL_beginav, (SV*)cv);
5332 GvCV(gv) = 0; /* cv has been hijacked */
5333 call_list(oldscope, PL_beginav);
5335 PL_curcop = &PL_compiling;
5336 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5339 else if (strEQ(s, "END") && !PL_error_count) {
5342 DEBUG_x( dump_sub(gv) );
5343 av_unshift(PL_endav, 1);
5344 av_store(PL_endav, 0, (SV*)cv);
5345 GvCV(gv) = 0; /* cv has been hijacked */
5347 else if (strEQ(s, "CHECK") && !PL_error_count) {
5349 PL_checkav = newAV();
5350 DEBUG_x( dump_sub(gv) );
5351 if (PL_main_start && ckWARN(WARN_VOID))
5352 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5353 av_unshift(PL_checkav, 1);
5354 av_store(PL_checkav, 0, (SV*)cv);
5355 GvCV(gv) = 0; /* cv has been hijacked */
5357 else if (strEQ(s, "INIT") && !PL_error_count) {
5359 PL_initav = newAV();
5360 DEBUG_x( dump_sub(gv) );
5361 if (PL_main_start && ckWARN(WARN_VOID))
5362 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5363 av_push(PL_initav, (SV*)cv);
5364 GvCV(gv) = 0; /* cv has been hijacked */
5369 PL_copline = NOLINE;
5374 /* XXX unsafe for threads if eval_owner isn't held */
5376 =for apidoc newCONSTSUB
5378 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5379 eligible for inlining at compile-time.
5385 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5392 SAVECOPLINE(PL_curcop);
5393 CopLINE_set(PL_curcop, PL_copline);
5396 PL_hints &= ~HINT_BLOCK_SCOPE;
5399 SAVESPTR(PL_curstash);
5400 SAVECOPSTASH(PL_curcop);
5401 PL_curstash = stash;
5402 CopSTASH_set(PL_curcop,stash);
5405 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
5406 CvXSUBANY(cv).any_ptr = sv;
5408 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5412 CopSTASH_free(PL_curcop);
5420 =for apidoc U||newXS
5422 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5428 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5431 GV * const gv = gv_fetchpv(name ? name :
5432 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5433 GV_ADDMULTI, SVt_PVCV);
5437 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5439 if ((cv = (name ? GvCV(gv) : NULL))) {
5441 /* just a cached method */
5445 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5446 /* already defined (or promised) */
5447 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5448 if (ckWARN(WARN_REDEFINE)) {
5449 GV * const gvcv = CvGV(cv);
5451 HV * const stash = GvSTASH(gvcv);
5453 const char *redefined_name = HvNAME_get(stash);
5454 if ( strEQ(redefined_name,"autouse") ) {
5455 const line_t oldline = CopLINE(PL_curcop);
5456 if (PL_copline != NOLINE)
5457 CopLINE_set(PL_curcop, PL_copline);
5458 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5459 CvCONST(cv) ? "Constant subroutine %s redefined"
5460 : "Subroutine %s redefined"
5462 CopLINE_set(PL_curcop, oldline);
5472 if (cv) /* must reuse cv if autoloaded */
5476 sv_upgrade((SV *)cv, SVt_PVCV);
5480 PL_sub_generation++;
5484 (void)gv_fetchfile(filename);
5485 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5486 an external constant string */
5488 CvXSUB(cv) = subaddr;
5491 const char *s = strrchr(name,':');
5497 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5500 if (strEQ(s, "BEGIN")) {
5502 PL_beginav = newAV();
5503 av_push(PL_beginav, (SV*)cv);
5504 GvCV(gv) = 0; /* cv has been hijacked */
5506 else if (strEQ(s, "END")) {
5509 av_unshift(PL_endav, 1);
5510 av_store(PL_endav, 0, (SV*)cv);
5511 GvCV(gv) = 0; /* cv has been hijacked */
5513 else if (strEQ(s, "CHECK")) {
5515 PL_checkav = newAV();
5516 if (PL_main_start && ckWARN(WARN_VOID))
5517 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5518 av_unshift(PL_checkav, 1);
5519 av_store(PL_checkav, 0, (SV*)cv);
5520 GvCV(gv) = 0; /* cv has been hijacked */
5522 else if (strEQ(s, "INIT")) {
5524 PL_initav = newAV();
5525 if (PL_main_start && ckWARN(WARN_VOID))
5526 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5527 av_push(PL_initav, (SV*)cv);
5528 GvCV(gv) = 0; /* cv has been hijacked */
5543 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5548 OP* pegop = newOP(OP_NULL, 0);
5552 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5553 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5555 #ifdef GV_UNIQUE_CHECK
5557 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5561 if ((cv = GvFORM(gv))) {
5562 if (ckWARN(WARN_REDEFINE)) {
5563 const line_t oldline = CopLINE(PL_curcop);
5564 if (PL_copline != NOLINE)
5565 CopLINE_set(PL_curcop, PL_copline);
5566 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5567 o ? "Format %"SVf" redefined"
5568 : "Format STDOUT redefined" ,cSVOPo->op_sv);
5569 CopLINE_set(PL_curcop, oldline);
5576 CvFILE_set_from_cop(cv, PL_curcop);
5579 pad_tidy(padtidy_FORMAT);
5580 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5581 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5582 OpREFCNT_set(CvROOT(cv), 1);
5583 CvSTART(cv) = LINKLIST(CvROOT(cv));
5584 CvROOT(cv)->op_next = 0;
5585 CALL_PEEP(CvSTART(cv));
5587 op_getmad(o,pegop,'n');
5588 op_getmad_weak(block, pegop, 'b');
5592 PL_copline = NOLINE;
5600 Perl_newANONLIST(pTHX_ OP *o)
5602 return newUNOP(OP_REFGEN, 0,
5603 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5607 Perl_newANONHASH(pTHX_ OP *o)
5609 return newUNOP(OP_REFGEN, 0,
5610 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5614 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5616 return newANONATTRSUB(floor, proto, NULL, block);
5620 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5622 return newUNOP(OP_REFGEN, 0,
5623 newSVOP(OP_ANONCODE, 0,
5624 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5628 Perl_oopsAV(pTHX_ OP *o)
5631 switch (o->op_type) {
5633 o->op_type = OP_PADAV;
5634 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5635 return ref(o, OP_RV2AV);
5638 o->op_type = OP_RV2AV;
5639 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5644 if (ckWARN_d(WARN_INTERNAL))
5645 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5652 Perl_oopsHV(pTHX_ OP *o)
5655 switch (o->op_type) {
5658 o->op_type = OP_PADHV;
5659 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5660 return ref(o, OP_RV2HV);
5664 o->op_type = OP_RV2HV;
5665 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5670 if (ckWARN_d(WARN_INTERNAL))
5671 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5678 Perl_newAVREF(pTHX_ OP *o)
5681 if (o->op_type == OP_PADANY) {
5682 o->op_type = OP_PADAV;
5683 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5686 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5687 && ckWARN(WARN_DEPRECATED)) {
5688 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5689 "Using an array as a reference is deprecated");
5691 return newUNOP(OP_RV2AV, 0, scalar(o));
5695 Perl_newGVREF(pTHX_ I32 type, OP *o)
5697 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5698 return newUNOP(OP_NULL, 0, o);
5699 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5703 Perl_newHVREF(pTHX_ OP *o)
5706 if (o->op_type == OP_PADANY) {
5707 o->op_type = OP_PADHV;
5708 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5711 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5712 && ckWARN(WARN_DEPRECATED)) {
5713 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5714 "Using a hash as a reference is deprecated");
5716 return newUNOP(OP_RV2HV, 0, scalar(o));
5720 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5722 return newUNOP(OP_RV2CV, flags, scalar(o));
5726 Perl_newSVREF(pTHX_ OP *o)
5729 if (o->op_type == OP_PADANY) {
5730 o->op_type = OP_PADSV;
5731 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5734 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5735 o->op_flags |= OPpDONE_SVREF;
5738 return newUNOP(OP_RV2SV, 0, scalar(o));
5741 /* Check routines. See the comments at the top of this file for details
5742 * on when these are called */
5745 Perl_ck_anoncode(pTHX_ OP *o)
5747 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5749 cSVOPo->op_sv = NULL;
5754 Perl_ck_bitop(pTHX_ OP *o)
5757 #define OP_IS_NUMCOMPARE(op) \
5758 ((op) == OP_LT || (op) == OP_I_LT || \
5759 (op) == OP_GT || (op) == OP_I_GT || \
5760 (op) == OP_LE || (op) == OP_I_LE || \
5761 (op) == OP_GE || (op) == OP_I_GE || \
5762 (op) == OP_EQ || (op) == OP_I_EQ || \
5763 (op) == OP_NE || (op) == OP_I_NE || \
5764 (op) == OP_NCMP || (op) == OP_I_NCMP)
5765 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5766 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5767 && (o->op_type == OP_BIT_OR
5768 || o->op_type == OP_BIT_AND
5769 || o->op_type == OP_BIT_XOR))
5771 const OP * const left = cBINOPo->op_first;
5772 const OP * const right = left->op_sibling;
5773 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5774 (left->op_flags & OPf_PARENS) == 0) ||
5775 (OP_IS_NUMCOMPARE(right->op_type) &&
5776 (right->op_flags & OPf_PARENS) == 0))
5777 if (ckWARN(WARN_PRECEDENCE))
5778 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5779 "Possible precedence problem on bitwise %c operator",
5780 o->op_type == OP_BIT_OR ? '|'
5781 : o->op_type == OP_BIT_AND ? '&' : '^'
5788 Perl_ck_concat(pTHX_ OP *o)
5790 const OP * const kid = cUNOPo->op_first;
5791 PERL_UNUSED_CONTEXT;
5792 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5793 !(kUNOP->op_first->op_flags & OPf_MOD))
5794 o->op_flags |= OPf_STACKED;
5799 Perl_ck_spair(pTHX_ OP *o)
5802 if (o->op_flags & OPf_KIDS) {
5805 const OPCODE type = o->op_type;
5806 o = modkids(ck_fun(o), type);
5807 kid = cUNOPo->op_first;
5808 newop = kUNOP->op_first->op_sibling;
5810 (newop->op_sibling ||
5811 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5812 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5813 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5818 op_getmad(kUNOP->op_first,newop,'K');
5820 op_free(kUNOP->op_first);
5822 kUNOP->op_first = newop;
5824 o->op_ppaddr = PL_ppaddr[++o->op_type];
5829 Perl_ck_delete(pTHX_ OP *o)
5833 if (o->op_flags & OPf_KIDS) {
5834 OP * const kid = cUNOPo->op_first;
5835 switch (kid->op_type) {
5837 o->op_flags |= OPf_SPECIAL;
5840 o->op_private |= OPpSLICE;
5843 o->op_flags |= OPf_SPECIAL;
5848 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5857 Perl_ck_die(pTHX_ OP *o)
5860 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5866 Perl_ck_eof(pTHX_ OP *o)
5870 if (o->op_flags & OPf_KIDS) {
5871 if (cLISTOPo->op_first->op_type == OP_STUB) {
5873 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5875 op_getmad(o,newop,'O');
5887 Perl_ck_eval(pTHX_ OP *o)
5890 PL_hints |= HINT_BLOCK_SCOPE;
5891 if (o->op_flags & OPf_KIDS) {
5892 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5895 o->op_flags &= ~OPf_KIDS;
5898 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5904 cUNOPo->op_first = 0;
5909 NewOp(1101, enter, 1, LOGOP);
5910 enter->op_type = OP_ENTERTRY;
5911 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5912 enter->op_private = 0;
5914 /* establish postfix order */
5915 enter->op_next = (OP*)enter;
5917 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5918 o->op_type = OP_LEAVETRY;
5919 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5920 enter->op_other = o;
5921 op_getmad(oldo,o,'O');
5935 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5936 op_getmad(oldo,o,'O');
5938 o->op_targ = (PADOFFSET)PL_hints;
5939 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5940 /* Store a copy of %^H that pp_entereval can pick up */
5941 OP *hhop = newSVOP(OP_CONST, 0,
5942 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
5943 cUNOPo->op_first->op_sibling = hhop;
5944 o->op_private |= OPpEVAL_HAS_HH;
5950 Perl_ck_exit(pTHX_ OP *o)
5953 HV * const table = GvHV(PL_hintgv);
5955 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5956 if (svp && *svp && SvTRUE(*svp))
5957 o->op_private |= OPpEXIT_VMSISH;
5959 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5965 Perl_ck_exec(pTHX_ OP *o)
5967 if (o->op_flags & OPf_STACKED) {
5970 kid = cUNOPo->op_first->op_sibling;
5971 if (kid->op_type == OP_RV2GV)
5980 Perl_ck_exists(pTHX_ OP *o)
5984 if (o->op_flags & OPf_KIDS) {
5985 OP * const kid = cUNOPo->op_first;
5986 if (kid->op_type == OP_ENTERSUB) {
5987 (void) ref(kid, o->op_type);
5988 if (kid->op_type != OP_RV2CV && !PL_error_count)
5989 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5991 o->op_private |= OPpEXISTS_SUB;
5993 else if (kid->op_type == OP_AELEM)
5994 o->op_flags |= OPf_SPECIAL;
5995 else if (kid->op_type != OP_HELEM)
5996 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6004 Perl_ck_rvconst(pTHX_ register OP *o)
6007 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6009 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6010 if (o->op_type == OP_RV2CV)
6011 o->op_private &= ~1;
6013 if (kid->op_type == OP_CONST) {
6016 SV * const kidsv = kid->op_sv;
6018 /* Is it a constant from cv_const_sv()? */
6019 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6020 SV * const rsv = SvRV(kidsv);
6021 const int svtype = SvTYPE(rsv);
6022 const char *badtype = NULL;
6024 switch (o->op_type) {
6026 if (svtype > SVt_PVMG)
6027 badtype = "a SCALAR";
6030 if (svtype != SVt_PVAV)
6031 badtype = "an ARRAY";
6034 if (svtype != SVt_PVHV)
6038 if (svtype != SVt_PVCV)
6043 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6046 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6047 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6048 /* If this is an access to a stash, disable "strict refs", because
6049 * stashes aren't auto-vivified at compile-time (unless we store
6050 * symbols in them), and we don't want to produce a run-time
6051 * stricture error when auto-vivifying the stash. */
6052 const char *s = SvPV_nolen(kidsv);
6053 const STRLEN l = SvCUR(kidsv);
6054 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6055 o->op_private &= ~HINT_STRICT_REFS;
6057 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6058 const char *badthing;
6059 switch (o->op_type) {
6061 badthing = "a SCALAR";
6064 badthing = "an ARRAY";
6067 badthing = "a HASH";
6075 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6079 * This is a little tricky. We only want to add the symbol if we
6080 * didn't add it in the lexer. Otherwise we get duplicate strict
6081 * warnings. But if we didn't add it in the lexer, we must at
6082 * least pretend like we wanted to add it even if it existed before,
6083 * or we get possible typo warnings. OPpCONST_ENTERED says
6084 * whether the lexer already added THIS instance of this symbol.
6086 iscv = (o->op_type == OP_RV2CV) * 2;
6088 gv = gv_fetchsv(kidsv,
6089 iscv | !(kid->op_private & OPpCONST_ENTERED),
6092 : o->op_type == OP_RV2SV
6094 : o->op_type == OP_RV2AV
6096 : o->op_type == OP_RV2HV
6099 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6101 kid->op_type = OP_GV;
6102 SvREFCNT_dec(kid->op_sv);
6104 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6105 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6106 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6108 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6110 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6112 kid->op_private = 0;
6113 kid->op_ppaddr = PL_ppaddr[OP_GV];
6120 Perl_ck_ftst(pTHX_ OP *o)
6123 const I32 type = o->op_type;
6125 if (o->op_flags & OPf_REF) {
6128 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6129 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6131 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6132 OP * const newop = newGVOP(type, OPf_REF,
6133 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6135 op_getmad(o,newop,'O');
6141 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6142 o->op_private |= OPpFT_ACCESS;
6143 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
6144 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
6145 o->op_private |= OPpFT_STACKED;
6153 if (type == OP_FTTTY)
6154 o = newGVOP(type, OPf_REF, PL_stdingv);
6156 o = newUNOP(type, 0, newDEFSVOP());
6157 op_getmad(oldo,o,'O');
6163 Perl_ck_fun(pTHX_ OP *o)
6166 const int type = o->op_type;
6167 register I32 oa = PL_opargs[type] >> OASHIFT;
6169 if (o->op_flags & OPf_STACKED) {
6170 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6173 return no_fh_allowed(o);
6176 if (o->op_flags & OPf_KIDS) {
6177 OP **tokid = &cLISTOPo->op_first;
6178 register OP *kid = cLISTOPo->op_first;
6182 if (kid->op_type == OP_PUSHMARK ||
6183 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6185 tokid = &kid->op_sibling;
6186 kid = kid->op_sibling;
6188 if (!kid && PL_opargs[type] & OA_DEFGV)
6189 *tokid = kid = newDEFSVOP();
6193 sibl = kid->op_sibling;
6195 if (!sibl && kid->op_type == OP_STUB) {
6202 /* list seen where single (scalar) arg expected? */
6203 if (numargs == 1 && !(oa >> 4)
6204 && kid->op_type == OP_LIST && type != OP_SCALAR)
6206 return too_many_arguments(o,PL_op_desc[type]);
6219 if ((type == OP_PUSH || type == OP_UNSHIFT)
6220 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6221 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6222 "Useless use of %s with no values",
6225 if (kid->op_type == OP_CONST &&
6226 (kid->op_private & OPpCONST_BARE))
6228 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6229 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6230 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6231 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6232 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6233 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6235 op_getmad(kid,newop,'K');
6240 kid->op_sibling = sibl;
6243 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6244 bad_type(numargs, "array", PL_op_desc[type], kid);
6248 if (kid->op_type == OP_CONST &&
6249 (kid->op_private & OPpCONST_BARE))
6251 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6252 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6253 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6254 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6255 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6256 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6258 op_getmad(kid,newop,'K');
6263 kid->op_sibling = sibl;
6266 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6267 bad_type(numargs, "hash", PL_op_desc[type], kid);
6272 OP * const newop = newUNOP(OP_NULL, 0, kid);
6273 kid->op_sibling = 0;
6275 newop->op_next = newop;
6277 kid->op_sibling = sibl;
6282 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6283 if (kid->op_type == OP_CONST &&
6284 (kid->op_private & OPpCONST_BARE))
6286 OP * const newop = newGVOP(OP_GV, 0,
6287 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6288 if (!(o->op_private & 1) && /* if not unop */
6289 kid == cLISTOPo->op_last)
6290 cLISTOPo->op_last = newop;
6292 op_getmad(kid,newop,'K');
6298 else if (kid->op_type == OP_READLINE) {
6299 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6300 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6303 I32 flags = OPf_SPECIAL;
6307 /* is this op a FH constructor? */
6308 if (is_handle_constructor(o,numargs)) {
6309 const char *name = NULL;
6313 /* Set a flag to tell rv2gv to vivify
6314 * need to "prove" flag does not mean something
6315 * else already - NI-S 1999/05/07
6318 if (kid->op_type == OP_PADSV) {
6319 name = PAD_COMPNAME_PV(kid->op_targ);
6320 /* SvCUR of a pad namesv can't be trusted
6321 * (see PL_generation), so calc its length
6327 else if (kid->op_type == OP_RV2SV
6328 && kUNOP->op_first->op_type == OP_GV)
6330 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6332 len = GvNAMELEN(gv);
6334 else if (kid->op_type == OP_AELEM
6335 || kid->op_type == OP_HELEM)
6337 OP *op = ((BINOP*)kid)->op_first;
6341 const char * const a =
6342 kid->op_type == OP_AELEM ?
6344 if (((op->op_type == OP_RV2AV) ||
6345 (op->op_type == OP_RV2HV)) &&
6346 (op = ((UNOP*)op)->op_first) &&
6347 (op->op_type == OP_GV)) {
6348 /* packagevar $a[] or $h{} */
6349 GV * const gv = cGVOPx_gv(op);
6357 else if (op->op_type == OP_PADAV
6358 || op->op_type == OP_PADHV) {
6359 /* lexicalvar $a[] or $h{} */
6360 const char * const padname =
6361 PAD_COMPNAME_PV(op->op_targ);
6370 name = SvPV_const(tmpstr, len);
6375 name = "__ANONIO__";
6382 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6383 namesv = PAD_SVl(targ);
6384 SvUPGRADE(namesv, SVt_PV);
6386 sv_setpvn(namesv, "$", 1);
6387 sv_catpvn(namesv, name, len);
6390 kid->op_sibling = 0;
6391 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6392 kid->op_targ = targ;
6393 kid->op_private |= priv;
6395 kid->op_sibling = sibl;
6401 mod(scalar(kid), type);
6405 tokid = &kid->op_sibling;
6406 kid = kid->op_sibling;
6409 if (kid && kid->op_type != OP_STUB)
6410 return too_many_arguments(o,OP_DESC(o));
6411 o->op_private |= numargs;
6413 /* FIXME - should the numargs move as for the PERL_MAD case? */
6414 o->op_private |= numargs;
6416 return too_many_arguments(o,OP_DESC(o));
6420 else if (PL_opargs[type] & OA_DEFGV) {
6422 OP *newop = newUNOP(type, 0, newDEFSVOP());
6423 op_getmad(o,newop,'O');
6426 /* Ordering of these two is important to keep f_map.t passing. */
6428 return newUNOP(type, 0, newDEFSVOP());
6433 while (oa & OA_OPTIONAL)
6435 if (oa && oa != OA_LIST)
6436 return too_few_arguments(o,OP_DESC(o));
6442 Perl_ck_glob(pTHX_ OP *o)
6448 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6449 append_elem(OP_GLOB, o, newDEFSVOP());
6451 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6452 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6454 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6457 #if !defined(PERL_EXTERNAL_GLOB)
6458 /* XXX this can be tightened up and made more failsafe. */
6459 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6462 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6463 newSVpvs("File::Glob"), NULL, NULL, NULL);
6464 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6465 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6466 GvCV(gv) = GvCV(glob_gv);
6467 SvREFCNT_inc_void((SV*)GvCV(gv));
6468 GvIMPORTED_CV_on(gv);
6471 #endif /* PERL_EXTERNAL_GLOB */
6473 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6474 append_elem(OP_GLOB, o,
6475 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6476 o->op_type = OP_LIST;
6477 o->op_ppaddr = PL_ppaddr[OP_LIST];
6478 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6479 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6480 cLISTOPo->op_first->op_targ = 0;
6481 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6482 append_elem(OP_LIST, o,
6483 scalar(newUNOP(OP_RV2CV, 0,
6484 newGVOP(OP_GV, 0, gv)))));
6485 o = newUNOP(OP_NULL, 0, ck_subr(o));
6486 o->op_targ = OP_GLOB; /* hint at what it used to be */
6489 gv = newGVgen("main");
6491 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6497 Perl_ck_grep(pTHX_ OP *o)
6502 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6505 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6506 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6508 if (o->op_flags & OPf_STACKED) {
6511 kid = cLISTOPo->op_first->op_sibling;
6512 if (!cUNOPx(kid)->op_next)
6513 Perl_croak(aTHX_ "panic: ck_grep");
6514 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6517 NewOp(1101, gwop, 1, LOGOP);
6518 kid->op_next = (OP*)gwop;
6519 o->op_flags &= ~OPf_STACKED;
6521 kid = cLISTOPo->op_first->op_sibling;
6522 if (type == OP_MAPWHILE)
6529 kid = cLISTOPo->op_first->op_sibling;
6530 if (kid->op_type != OP_NULL)
6531 Perl_croak(aTHX_ "panic: ck_grep");
6532 kid = kUNOP->op_first;
6535 NewOp(1101, gwop, 1, LOGOP);
6536 gwop->op_type = type;
6537 gwop->op_ppaddr = PL_ppaddr[type];
6538 gwop->op_first = listkids(o);
6539 gwop->op_flags |= OPf_KIDS;
6540 gwop->op_other = LINKLIST(kid);
6541 kid->op_next = (OP*)gwop;
6542 offset = pad_findmy("$_");
6543 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6544 o->op_private = gwop->op_private = 0;
6545 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6548 o->op_private = gwop->op_private = OPpGREP_LEX;
6549 gwop->op_targ = o->op_targ = offset;
6552 kid = cLISTOPo->op_first->op_sibling;
6553 if (!kid || !kid->op_sibling)
6554 return too_few_arguments(o,OP_DESC(o));
6555 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6556 mod(kid, OP_GREPSTART);
6562 Perl_ck_index(pTHX_ OP *o)
6564 if (o->op_flags & OPf_KIDS) {
6565 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6567 kid = kid->op_sibling; /* get past "big" */
6568 if (kid && kid->op_type == OP_CONST)
6569 fbm_compile(((SVOP*)kid)->op_sv, 0);
6575 Perl_ck_lengthconst(pTHX_ OP *o)
6577 /* XXX length optimization goes here */
6582 Perl_ck_lfun(pTHX_ OP *o)
6584 const OPCODE type = o->op_type;
6585 return modkids(ck_fun(o), type);
6589 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6591 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6592 switch (cUNOPo->op_first->op_type) {
6594 /* This is needed for
6595 if (defined %stash::)
6596 to work. Do not break Tk.
6598 break; /* Globals via GV can be undef */
6600 case OP_AASSIGN: /* Is this a good idea? */
6601 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6602 "defined(@array) is deprecated");
6603 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6604 "\t(Maybe you should just omit the defined()?)\n");
6607 /* This is needed for
6608 if (defined %stash::)
6609 to work. Do not break Tk.
6611 break; /* Globals via GV can be undef */
6613 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6614 "defined(%%hash) is deprecated");
6615 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6616 "\t(Maybe you should just omit the defined()?)\n");
6627 Perl_ck_rfun(pTHX_ OP *o)
6629 const OPCODE type = o->op_type;
6630 return refkids(ck_fun(o), type);
6634 Perl_ck_listiob(pTHX_ OP *o)
6638 kid = cLISTOPo->op_first;
6641 kid = cLISTOPo->op_first;
6643 if (kid->op_type == OP_PUSHMARK)
6644 kid = kid->op_sibling;
6645 if (kid && o->op_flags & OPf_STACKED)
6646 kid = kid->op_sibling;
6647 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6648 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6649 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6650 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6651 cLISTOPo->op_first->op_sibling = kid;
6652 cLISTOPo->op_last = kid;
6653 kid = kid->op_sibling;
6658 append_elem(o->op_type, o, newDEFSVOP());
6664 Perl_ck_say(pTHX_ OP *o)
6667 o->op_type = OP_PRINT;
6668 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6669 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6674 Perl_ck_smartmatch(pTHX_ OP *o)
6677 if (0 == (o->op_flags & OPf_SPECIAL)) {
6678 OP *first = cBINOPo->op_first;
6679 OP *second = first->op_sibling;
6681 /* Implicitly take a reference to an array or hash */
6682 first->op_sibling = NULL;
6683 first = cBINOPo->op_first = ref_array_or_hash(first);
6684 second = first->op_sibling = ref_array_or_hash(second);
6686 /* Implicitly take a reference to a regular expression */
6687 if (first->op_type == OP_MATCH) {
6688 first->op_type = OP_QR;
6689 first->op_ppaddr = PL_ppaddr[OP_QR];
6691 if (second->op_type == OP_MATCH) {
6692 second->op_type = OP_QR;
6693 second->op_ppaddr = PL_ppaddr[OP_QR];
6702 Perl_ck_sassign(pTHX_ OP *o)
6704 OP *kid = cLISTOPo->op_first;
6705 /* has a disposable target? */
6706 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6707 && !(kid->op_flags & OPf_STACKED)
6708 /* Cannot steal the second time! */
6709 && !(kid->op_private & OPpTARGET_MY))
6711 OP * const kkid = kid->op_sibling;
6713 /* Can just relocate the target. */
6714 if (kkid && kkid->op_type == OP_PADSV
6715 && !(kkid->op_private & OPpLVAL_INTRO))
6717 kid->op_targ = kkid->op_targ;
6719 /* Now we do not need PADSV and SASSIGN. */
6720 kid->op_sibling = o->op_sibling; /* NULL */
6721 cLISTOPo->op_first = NULL;
6723 op_getmad(o,kid,'O');
6724 op_getmad(kkid,kid,'M');
6729 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6737 Perl_ck_match(pTHX_ OP *o)
6740 if (o->op_type != OP_QR && PL_compcv) {
6741 const I32 offset = pad_findmy("$_");
6742 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6743 o->op_targ = offset;
6744 o->op_private |= OPpTARGET_MY;
6747 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6748 o->op_private |= OPpRUNTIME;
6753 Perl_ck_method(pTHX_ OP *o)
6755 OP * const kid = cUNOPo->op_first;
6756 if (kid->op_type == OP_CONST) {
6757 SV* sv = kSVOP->op_sv;
6758 const char * const method = SvPVX_const(sv);
6759 if (!(strchr(method, ':') || strchr(method, '\''))) {
6761 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6762 sv = newSVpvn_share(method, SvCUR(sv), 0);
6765 kSVOP->op_sv = NULL;
6767 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6769 op_getmad(o,cmop,'O');
6780 Perl_ck_null(pTHX_ OP *o)
6782 PERL_UNUSED_CONTEXT;
6787 Perl_ck_open(pTHX_ OP *o)
6790 HV * const table = GvHV(PL_hintgv);
6792 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6794 const I32 mode = mode_from_discipline(*svp);
6795 if (mode & O_BINARY)
6796 o->op_private |= OPpOPEN_IN_RAW;
6797 else if (mode & O_TEXT)
6798 o->op_private |= OPpOPEN_IN_CRLF;
6801 svp = hv_fetchs(table, "open_OUT", FALSE);
6803 const I32 mode = mode_from_discipline(*svp);
6804 if (mode & O_BINARY)
6805 o->op_private |= OPpOPEN_OUT_RAW;
6806 else if (mode & O_TEXT)
6807 o->op_private |= OPpOPEN_OUT_CRLF;
6810 if (o->op_type == OP_BACKTICK)
6813 /* In case of three-arg dup open remove strictness
6814 * from the last arg if it is a bareword. */
6815 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6816 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6820 if ((last->op_type == OP_CONST) && /* The bareword. */
6821 (last->op_private & OPpCONST_BARE) &&
6822 (last->op_private & OPpCONST_STRICT) &&
6823 (oa = first->op_sibling) && /* The fh. */
6824 (oa = oa->op_sibling) && /* The mode. */
6825 (oa->op_type == OP_CONST) &&
6826 SvPOK(((SVOP*)oa)->op_sv) &&
6827 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6828 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6829 (last == oa->op_sibling)) /* The bareword. */
6830 last->op_private &= ~OPpCONST_STRICT;
6836 Perl_ck_repeat(pTHX_ OP *o)
6838 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6839 o->op_private |= OPpREPEAT_DOLIST;
6840 cBINOPo->op_first = force_list(cBINOPo->op_first);
6848 Perl_ck_require(pTHX_ OP *o)
6853 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6854 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6856 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6857 SV * const sv = kid->op_sv;
6858 U32 was_readonly = SvREADONLY(sv);
6863 sv_force_normal_flags(sv, 0);
6864 assert(!SvREADONLY(sv));
6871 for (s = SvPVX(sv); *s; s++) {
6872 if (*s == ':' && s[1] == ':') {
6873 const STRLEN len = strlen(s+2)+1;
6875 Move(s+2, s+1, len, char);
6876 SvCUR_set(sv, SvCUR(sv) - 1);
6879 sv_catpvs(sv, ".pm");
6880 SvFLAGS(sv) |= was_readonly;
6884 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6885 /* handle override, if any */
6886 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6887 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6888 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6889 gv = gvp ? *gvp : NULL;
6893 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6894 OP * const kid = cUNOPo->op_first;
6897 cUNOPo->op_first = 0;
6901 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6902 append_elem(OP_LIST, kid,
6903 scalar(newUNOP(OP_RV2CV, 0,
6906 op_getmad(o,newop,'O');
6914 Perl_ck_return(pTHX_ OP *o)
6917 if (CvLVALUE(PL_compcv)) {
6919 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6920 mod(kid, OP_LEAVESUBLV);
6926 Perl_ck_select(pTHX_ OP *o)
6930 if (o->op_flags & OPf_KIDS) {
6931 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6932 if (kid && kid->op_sibling) {
6933 o->op_type = OP_SSELECT;
6934 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6936 return fold_constants(o);
6940 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6941 if (kid && kid->op_type == OP_RV2GV)
6942 kid->op_private &= ~HINT_STRICT_REFS;
6947 Perl_ck_shift(pTHX_ OP *o)
6950 const I32 type = o->op_type;
6952 if (!(o->op_flags & OPf_KIDS)) {
6954 /* FIXME - this can be refactored to reduce code in #ifdefs */
6956 OP * const oldo = o;
6960 argop = newUNOP(OP_RV2AV, 0,
6961 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6963 o = newUNOP(type, 0, scalar(argop));
6964 op_getmad(oldo,o,'O');
6967 return newUNOP(type, 0, scalar(argop));
6970 return scalar(modkids(ck_fun(o), type));
6974 Perl_ck_sort(pTHX_ OP *o)
6979 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6981 HV * const hinthv = GvHV(PL_hintgv);
6983 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6985 const I32 sorthints = (I32)SvIV(*svp);
6986 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6987 o->op_private |= OPpSORT_QSORT;
6988 if ((sorthints & HINT_SORT_STABLE) != 0)
6989 o->op_private |= OPpSORT_STABLE;
6994 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6996 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6997 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6999 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7001 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7003 if (kid->op_type == OP_SCOPE) {
7007 else if (kid->op_type == OP_LEAVE) {
7008 if (o->op_type == OP_SORT) {
7009 op_null(kid); /* wipe out leave */
7012 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7013 if (k->op_next == kid)
7015 /* don't descend into loops */
7016 else if (k->op_type == OP_ENTERLOOP
7017 || k->op_type == OP_ENTERITER)
7019 k = cLOOPx(k)->op_lastop;
7024 kid->op_next = 0; /* just disconnect the leave */
7025 k = kLISTOP->op_first;
7030 if (o->op_type == OP_SORT) {
7031 /* provide scalar context for comparison function/block */
7037 o->op_flags |= OPf_SPECIAL;
7039 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7042 firstkid = firstkid->op_sibling;
7045 /* provide list context for arguments */
7046 if (o->op_type == OP_SORT)
7053 S_simplify_sort(pTHX_ OP *o)
7056 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7061 if (!(o->op_flags & OPf_STACKED))
7063 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7064 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7065 kid = kUNOP->op_first; /* get past null */
7066 if (kid->op_type != OP_SCOPE)
7068 kid = kLISTOP->op_last; /* get past scope */
7069 switch(kid->op_type) {
7077 k = kid; /* remember this node*/
7078 if (kBINOP->op_first->op_type != OP_RV2SV)
7080 kid = kBINOP->op_first; /* get past cmp */
7081 if (kUNOP->op_first->op_type != OP_GV)
7083 kid = kUNOP->op_first; /* get past rv2sv */
7085 if (GvSTASH(gv) != PL_curstash)
7087 gvname = GvNAME(gv);
7088 if (*gvname == 'a' && gvname[1] == '\0')
7090 else if (*gvname == 'b' && gvname[1] == '\0')
7095 kid = k; /* back to cmp */
7096 if (kBINOP->op_last->op_type != OP_RV2SV)
7098 kid = kBINOP->op_last; /* down to 2nd arg */
7099 if (kUNOP->op_first->op_type != OP_GV)
7101 kid = kUNOP->op_first; /* get past rv2sv */
7103 if (GvSTASH(gv) != PL_curstash)
7105 gvname = GvNAME(gv);
7107 ? !(*gvname == 'a' && gvname[1] == '\0')
7108 : !(*gvname == 'b' && gvname[1] == '\0'))
7110 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7112 o->op_private |= OPpSORT_DESCEND;
7113 if (k->op_type == OP_NCMP)
7114 o->op_private |= OPpSORT_NUMERIC;
7115 if (k->op_type == OP_I_NCMP)
7116 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7117 kid = cLISTOPo->op_first->op_sibling;
7118 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7120 op_getmad(kid,o,'S'); /* then delete it */
7122 op_free(kid); /* then delete it */
7127 Perl_ck_split(pTHX_ OP *o)
7132 if (o->op_flags & OPf_STACKED)
7133 return no_fh_allowed(o);
7135 kid = cLISTOPo->op_first;
7136 if (kid->op_type != OP_NULL)
7137 Perl_croak(aTHX_ "panic: ck_split");
7138 kid = kid->op_sibling;
7139 op_free(cLISTOPo->op_first);
7140 cLISTOPo->op_first = kid;
7142 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7143 cLISTOPo->op_last = kid; /* There was only one element previously */
7146 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7147 OP * const sibl = kid->op_sibling;
7148 kid->op_sibling = 0;
7149 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7150 if (cLISTOPo->op_first == cLISTOPo->op_last)
7151 cLISTOPo->op_last = kid;
7152 cLISTOPo->op_first = kid;
7153 kid->op_sibling = sibl;
7156 kid->op_type = OP_PUSHRE;
7157 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7159 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7160 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7161 "Use of /g modifier is meaningless in split");
7164 if (!kid->op_sibling)
7165 append_elem(OP_SPLIT, o, newDEFSVOP());
7167 kid = kid->op_sibling;
7170 if (!kid->op_sibling)
7171 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7173 kid = kid->op_sibling;
7176 if (kid->op_sibling)
7177 return too_many_arguments(o,OP_DESC(o));
7183 Perl_ck_join(pTHX_ OP *o)
7185 const OP * const kid = cLISTOPo->op_first->op_sibling;
7186 if (kid && kid->op_type == OP_MATCH) {
7187 if (ckWARN(WARN_SYNTAX)) {
7188 const REGEXP *re = PM_GETRE(kPMOP);
7189 const char *pmstr = re ? re->precomp : "STRING";
7190 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7191 "/%s/ should probably be written as \"%s\"",
7199 Perl_ck_subr(pTHX_ OP *o)
7202 OP *prev = ((cUNOPo->op_first->op_sibling)
7203 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7204 OP *o2 = prev->op_sibling;
7211 I32 contextclass = 0;
7215 o->op_private |= OPpENTERSUB_HASTARG;
7216 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7217 if (cvop->op_type == OP_RV2CV) {
7219 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7220 op_null(cvop); /* disable rv2cv */
7221 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7222 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7223 GV *gv = cGVOPx_gv(tmpop);
7226 tmpop->op_private |= OPpEARLY_CV;
7229 namegv = CvANON(cv) ? gv : CvGV(cv);
7230 proto = SvPV_nolen((SV*)cv);
7232 if (CvASSERTION(cv)) {
7233 if (PL_hints & HINT_ASSERTING) {
7234 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7235 o->op_private |= OPpENTERSUB_DB;
7239 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7240 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7241 "Impossible to activate assertion call");
7248 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7249 if (o2->op_type == OP_CONST)
7250 o2->op_private &= ~OPpCONST_STRICT;
7251 else if (o2->op_type == OP_LIST) {
7252 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7253 if (sib && sib->op_type == OP_CONST)
7254 sib->op_private &= ~OPpCONST_STRICT;
7257 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7258 if (PERLDB_SUB && PL_curstash != PL_debstash)
7259 o->op_private |= OPpENTERSUB_DB;
7260 while (o2 != cvop) {
7262 if (PL_madskills && o2->op_type == OP_NULL)
7263 o3 = ((UNOP*)o2)->op_first;
7269 return too_many_arguments(o, gv_ename(namegv));
7287 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7289 arg == 1 ? "block or sub {}" : "sub {}",
7290 gv_ename(namegv), o3);
7293 /* '*' allows any scalar type, including bareword */
7296 if (o3->op_type == OP_RV2GV)
7297 goto wrapref; /* autoconvert GLOB -> GLOBref */
7298 else if (o3->op_type == OP_CONST)
7299 o3->op_private &= ~OPpCONST_STRICT;
7300 else if (o3->op_type == OP_ENTERSUB) {
7301 /* accidental subroutine, revert to bareword */
7302 OP *gvop = ((UNOP*)o3)->op_first;
7303 if (gvop && gvop->op_type == OP_NULL) {
7304 gvop = ((UNOP*)gvop)->op_first;
7306 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7309 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7310 (gvop = ((UNOP*)gvop)->op_first) &&
7311 gvop->op_type == OP_GV)
7313 GV * const gv = cGVOPx_gv(gvop);
7314 OP * const sibling = o2->op_sibling;
7315 SV * const n = newSVpvs("");
7317 OP * const oldo2 = o2;
7321 gv_fullname4(n, gv, "", FALSE);
7322 o2 = newSVOP(OP_CONST, 0, n);
7323 op_getmad(oldo2,o2,'O');
7324 prev->op_sibling = o2;
7325 o2->op_sibling = sibling;
7341 if (contextclass++ == 0) {
7342 e = strchr(proto, ']');
7343 if (!e || e == proto)
7352 /* XXX We shouldn't be modifying proto, so we can const proto */
7357 while (*--p != '[');
7358 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
7359 gv_ename(namegv), o3);
7365 if (o3->op_type == OP_RV2GV)
7368 bad_type(arg, "symbol", gv_ename(namegv), o3);
7371 if (o3->op_type == OP_ENTERSUB)
7374 bad_type(arg, "subroutine entry", gv_ename(namegv),
7378 if (o3->op_type == OP_RV2SV ||
7379 o3->op_type == OP_PADSV ||
7380 o3->op_type == OP_HELEM ||
7381 o3->op_type == OP_AELEM ||
7382 o3->op_type == OP_THREADSV)
7385 bad_type(arg, "scalar", gv_ename(namegv), o3);
7388 if (o3->op_type == OP_RV2AV ||
7389 o3->op_type == OP_PADAV)
7392 bad_type(arg, "array", gv_ename(namegv), o3);
7395 if (o3->op_type == OP_RV2HV ||
7396 o3->op_type == OP_PADHV)
7399 bad_type(arg, "hash", gv_ename(namegv), o3);
7404 OP* const sib = kid->op_sibling;
7405 kid->op_sibling = 0;
7406 o2 = newUNOP(OP_REFGEN, 0, kid);
7407 o2->op_sibling = sib;
7408 prev->op_sibling = o2;
7410 if (contextclass && e) {
7425 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7426 gv_ename(namegv), cv);
7431 mod(o2, OP_ENTERSUB);
7433 o2 = o2->op_sibling;
7435 if (proto && !optional &&
7436 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
7437 return too_few_arguments(o, gv_ename(namegv));
7440 OP * const oldo = o;
7444 o=newSVOP(OP_CONST, 0, newSViv(0));
7445 op_getmad(oldo,o,'O');
7451 Perl_ck_svconst(pTHX_ OP *o)
7453 PERL_UNUSED_CONTEXT;
7454 SvREADONLY_on(cSVOPo->op_sv);
7459 Perl_ck_chdir(pTHX_ OP *o)
7461 if (o->op_flags & OPf_KIDS) {
7462 SVOP *kid = (SVOP*)cUNOPo->op_first;
7464 if (kid && kid->op_type == OP_CONST &&
7465 (kid->op_private & OPpCONST_BARE))
7467 o->op_flags |= OPf_SPECIAL;
7468 kid->op_private &= ~OPpCONST_STRICT;
7475 Perl_ck_trunc(pTHX_ OP *o)
7477 if (o->op_flags & OPf_KIDS) {
7478 SVOP *kid = (SVOP*)cUNOPo->op_first;
7480 if (kid->op_type == OP_NULL)
7481 kid = (SVOP*)kid->op_sibling;
7482 if (kid && kid->op_type == OP_CONST &&
7483 (kid->op_private & OPpCONST_BARE))
7485 o->op_flags |= OPf_SPECIAL;
7486 kid->op_private &= ~OPpCONST_STRICT;
7493 Perl_ck_unpack(pTHX_ OP *o)
7495 OP *kid = cLISTOPo->op_first;
7496 if (kid->op_sibling) {
7497 kid = kid->op_sibling;
7498 if (!kid->op_sibling)
7499 kid->op_sibling = newDEFSVOP();
7505 Perl_ck_substr(pTHX_ OP *o)
7508 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7509 OP *kid = cLISTOPo->op_first;
7511 if (kid->op_type == OP_NULL)
7512 kid = kid->op_sibling;
7514 kid->op_flags |= OPf_MOD;
7520 /* A peephole optimizer. We visit the ops in the order they're to execute.
7521 * See the comments at the top of this file for more details about when
7522 * peep() is called */
7525 Perl_peep(pTHX_ register OP *o)
7528 register OP* oldop = NULL;
7530 if (!o || o->op_opt)
7534 SAVEVPTR(PL_curcop);
7535 for (; o; o = o->op_next) {
7539 switch (o->op_type) {
7543 PL_curcop = ((COP*)o); /* for warnings */
7548 if (cSVOPo->op_private & OPpCONST_STRICT)
7549 no_bareword_allowed(o);
7551 case OP_METHOD_NAMED:
7552 /* Relocate sv to the pad for thread safety.
7553 * Despite being a "constant", the SV is written to,
7554 * for reference counts, sv_upgrade() etc. */
7556 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7557 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7558 /* If op_sv is already a PADTMP then it is being used by
7559 * some pad, so make a copy. */
7560 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7561 SvREADONLY_on(PAD_SVl(ix));
7562 SvREFCNT_dec(cSVOPo->op_sv);
7564 else if (o->op_type == OP_CONST
7565 && cSVOPo->op_sv == &PL_sv_undef) {
7566 /* PL_sv_undef is hack - it's unsafe to store it in the
7567 AV that is the pad, because av_fetch treats values of
7568 PL_sv_undef as a "free" AV entry and will merrily
7569 replace them with a new SV, causing pad_alloc to think
7570 that this pad slot is free. (When, clearly, it is not)
7572 SvOK_off(PAD_SVl(ix));
7573 SvPADTMP_on(PAD_SVl(ix));
7574 SvREADONLY_on(PAD_SVl(ix));
7577 SvREFCNT_dec(PAD_SVl(ix));
7578 SvPADTMP_on(cSVOPo->op_sv);
7579 PAD_SETSV(ix, cSVOPo->op_sv);
7580 /* XXX I don't know how this isn't readonly already. */
7581 SvREADONLY_on(PAD_SVl(ix));
7583 cSVOPo->op_sv = NULL;
7591 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7592 if (o->op_next->op_private & OPpTARGET_MY) {
7593 if (o->op_flags & OPf_STACKED) /* chained concats */
7594 goto ignore_optimization;
7596 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7597 o->op_targ = o->op_next->op_targ;
7598 o->op_next->op_targ = 0;
7599 o->op_private |= OPpTARGET_MY;
7602 op_null(o->op_next);
7604 ignore_optimization:
7608 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7610 break; /* Scalar stub must produce undef. List stub is noop */
7614 if (o->op_targ == OP_NEXTSTATE
7615 || o->op_targ == OP_DBSTATE
7616 || o->op_targ == OP_SETSTATE)
7618 PL_curcop = ((COP*)o);
7620 /* XXX: We avoid setting op_seq here to prevent later calls
7621 to peep() from mistakenly concluding that optimisation
7622 has already occurred. This doesn't fix the real problem,
7623 though (See 20010220.007). AMS 20010719 */
7624 /* op_seq functionality is now replaced by op_opt */
7625 if (oldop && o->op_next) {
7626 oldop->op_next = o->op_next;
7634 if (oldop && o->op_next) {
7635 oldop->op_next = o->op_next;
7643 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7644 OP* const pop = (o->op_type == OP_PADAV) ?
7645 o->op_next : o->op_next->op_next;
7647 if (pop && pop->op_type == OP_CONST &&
7648 ((PL_op = pop->op_next)) &&
7649 pop->op_next->op_type == OP_AELEM &&
7650 !(pop->op_next->op_private &
7651 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7652 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7657 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7658 no_bareword_allowed(pop);
7659 if (o->op_type == OP_GV)
7660 op_null(o->op_next);
7661 op_null(pop->op_next);
7663 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7664 o->op_next = pop->op_next->op_next;
7665 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7666 o->op_private = (U8)i;
7667 if (o->op_type == OP_GV) {
7672 o->op_flags |= OPf_SPECIAL;
7673 o->op_type = OP_AELEMFAST;
7679 if (o->op_next->op_type == OP_RV2SV) {
7680 if (!(o->op_next->op_private & OPpDEREF)) {
7681 op_null(o->op_next);
7682 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7684 o->op_next = o->op_next->op_next;
7685 o->op_type = OP_GVSV;
7686 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7689 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7690 GV * const gv = cGVOPo_gv;
7691 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7692 /* XXX could check prototype here instead of just carping */
7693 SV * const sv = sv_newmortal();
7694 gv_efullname3(sv, gv, NULL);
7695 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7696 "%"SVf"() called too early to check prototype",
7700 else if (o->op_next->op_type == OP_READLINE
7701 && o->op_next->op_next->op_type == OP_CONCAT
7702 && (o->op_next->op_next->op_flags & OPf_STACKED))
7704 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7705 o->op_type = OP_RCATLINE;
7706 o->op_flags |= OPf_STACKED;
7707 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7708 op_null(o->op_next->op_next);
7709 op_null(o->op_next);
7726 while (cLOGOP->op_other->op_type == OP_NULL)
7727 cLOGOP->op_other = cLOGOP->op_other->op_next;
7728 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7734 while (cLOOP->op_redoop->op_type == OP_NULL)
7735 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7736 peep(cLOOP->op_redoop);
7737 while (cLOOP->op_nextop->op_type == OP_NULL)
7738 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7739 peep(cLOOP->op_nextop);
7740 while (cLOOP->op_lastop->op_type == OP_NULL)
7741 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7742 peep(cLOOP->op_lastop);
7749 while (cPMOP->op_pmreplstart &&
7750 cPMOP->op_pmreplstart->op_type == OP_NULL)
7751 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7752 peep(cPMOP->op_pmreplstart);
7757 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7758 && ckWARN(WARN_SYNTAX))
7760 if (o->op_next->op_sibling &&
7761 o->op_next->op_sibling->op_type != OP_EXIT &&
7762 o->op_next->op_sibling->op_type != OP_WARN &&
7763 o->op_next->op_sibling->op_type != OP_DIE) {
7764 const line_t oldline = CopLINE(PL_curcop);
7766 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7767 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7768 "Statement unlikely to be reached");
7769 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7770 "\t(Maybe you meant system() when you said exec()?)\n");
7771 CopLINE_set(PL_curcop, oldline);
7781 const char *key = NULL;
7786 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7789 /* Make the CONST have a shared SV */
7790 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7791 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7792 key = SvPV_const(sv, keylen);
7793 lexname = newSVpvn_share(key,
7794 SvUTF8(sv) ? -(I32)keylen : keylen,
7800 if ((o->op_private & (OPpLVAL_INTRO)))
7803 rop = (UNOP*)((BINOP*)o)->op_first;
7804 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7806 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7807 if (!SvPAD_TYPED(lexname))
7809 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7810 if (!fields || !GvHV(*fields))
7812 key = SvPV_const(*svp, keylen);
7813 if (!hv_fetch(GvHV(*fields), key,
7814 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7816 Perl_croak(aTHX_ "No such class field \"%s\" "
7817 "in variable %s of type %s",
7818 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7831 SVOP *first_key_op, *key_op;
7833 if ((o->op_private & (OPpLVAL_INTRO))
7834 /* I bet there's always a pushmark... */
7835 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7836 /* hmmm, no optimization if list contains only one key. */
7838 rop = (UNOP*)((LISTOP*)o)->op_last;
7839 if (rop->op_type != OP_RV2HV)
7841 if (rop->op_first->op_type == OP_PADSV)
7842 /* @$hash{qw(keys here)} */
7843 rop = (UNOP*)rop->op_first;
7845 /* @{$hash}{qw(keys here)} */
7846 if (rop->op_first->op_type == OP_SCOPE
7847 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7849 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7855 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7856 if (!SvPAD_TYPED(lexname))
7858 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7859 if (!fields || !GvHV(*fields))
7861 /* Again guessing that the pushmark can be jumped over.... */
7862 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7863 ->op_first->op_sibling;
7864 for (key_op = first_key_op; key_op;
7865 key_op = (SVOP*)key_op->op_sibling) {
7866 if (key_op->op_type != OP_CONST)
7868 svp = cSVOPx_svp(key_op);
7869 key = SvPV_const(*svp, keylen);
7870 if (!hv_fetch(GvHV(*fields), key,
7871 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7873 Perl_croak(aTHX_ "No such class field \"%s\" "
7874 "in variable %s of type %s",
7875 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7882 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7886 /* check that RHS of sort is a single plain array */
7887 OP *oright = cUNOPo->op_first;
7888 if (!oright || oright->op_type != OP_PUSHMARK)
7891 /* reverse sort ... can be optimised. */
7892 if (!cUNOPo->op_sibling) {
7893 /* Nothing follows us on the list. */
7894 OP * const reverse = o->op_next;
7896 if (reverse->op_type == OP_REVERSE &&
7897 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7898 OP * const pushmark = cUNOPx(reverse)->op_first;
7899 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7900 && (cUNOPx(pushmark)->op_sibling == o)) {
7901 /* reverse -> pushmark -> sort */
7902 o->op_private |= OPpSORT_REVERSE;
7904 pushmark->op_next = oright->op_next;
7910 /* make @a = sort @a act in-place */
7914 oright = cUNOPx(oright)->op_sibling;
7917 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7918 oright = cUNOPx(oright)->op_sibling;
7922 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7923 || oright->op_next != o
7924 || (oright->op_private & OPpLVAL_INTRO)
7928 /* o2 follows the chain of op_nexts through the LHS of the
7929 * assign (if any) to the aassign op itself */
7931 if (!o2 || o2->op_type != OP_NULL)
7934 if (!o2 || o2->op_type != OP_PUSHMARK)
7937 if (o2 && o2->op_type == OP_GV)
7940 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7941 || (o2->op_private & OPpLVAL_INTRO)
7946 if (!o2 || o2->op_type != OP_NULL)
7949 if (!o2 || o2->op_type != OP_AASSIGN
7950 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7953 /* check that the sort is the first arg on RHS of assign */
7955 o2 = cUNOPx(o2)->op_first;
7956 if (!o2 || o2->op_type != OP_NULL)
7958 o2 = cUNOPx(o2)->op_first;
7959 if (!o2 || o2->op_type != OP_PUSHMARK)
7961 if (o2->op_sibling != o)
7964 /* check the array is the same on both sides */
7965 if (oleft->op_type == OP_RV2AV) {
7966 if (oright->op_type != OP_RV2AV
7967 || !cUNOPx(oright)->op_first
7968 || cUNOPx(oright)->op_first->op_type != OP_GV
7969 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7970 cGVOPx_gv(cUNOPx(oright)->op_first)
7974 else if (oright->op_type != OP_PADAV
7975 || oright->op_targ != oleft->op_targ
7979 /* transfer MODishness etc from LHS arg to RHS arg */
7980 oright->op_flags = oleft->op_flags;
7981 o->op_private |= OPpSORT_INPLACE;
7983 /* excise push->gv->rv2av->null->aassign */
7984 o2 = o->op_next->op_next;
7985 op_null(o2); /* PUSHMARK */
7987 if (o2->op_type == OP_GV) {
7988 op_null(o2); /* GV */
7991 op_null(o2); /* RV2AV or PADAV */
7992 o2 = o2->op_next->op_next;
7993 op_null(o2); /* AASSIGN */
7995 o->op_next = o2->op_next;
8001 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8003 LISTOP *enter, *exlist;
8006 enter = (LISTOP *) o->op_next;
8009 if (enter->op_type == OP_NULL) {
8010 enter = (LISTOP *) enter->op_next;
8014 /* for $a (...) will have OP_GV then OP_RV2GV here.
8015 for (...) just has an OP_GV. */
8016 if (enter->op_type == OP_GV) {
8017 gvop = (OP *) enter;
8018 enter = (LISTOP *) enter->op_next;
8021 if (enter->op_type == OP_RV2GV) {
8022 enter = (LISTOP *) enter->op_next;
8028 if (enter->op_type != OP_ENTERITER)
8031 iter = enter->op_next;
8032 if (!iter || iter->op_type != OP_ITER)
8035 expushmark = enter->op_first;
8036 if (!expushmark || expushmark->op_type != OP_NULL
8037 || expushmark->op_targ != OP_PUSHMARK)
8040 exlist = (LISTOP *) expushmark->op_sibling;
8041 if (!exlist || exlist->op_type != OP_NULL
8042 || exlist->op_targ != OP_LIST)
8045 if (exlist->op_last != o) {
8046 /* Mmm. Was expecting to point back to this op. */
8049 theirmark = exlist->op_first;
8050 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8053 if (theirmark->op_sibling != o) {
8054 /* There's something between the mark and the reverse, eg
8055 for (1, reverse (...))
8060 ourmark = ((LISTOP *)o)->op_first;
8061 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8064 ourlast = ((LISTOP *)o)->op_last;
8065 if (!ourlast || ourlast->op_next != o)
8068 rv2av = ourmark->op_sibling;
8069 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8070 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8071 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8072 /* We're just reversing a single array. */
8073 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8074 enter->op_flags |= OPf_STACKED;
8077 /* We don't have control over who points to theirmark, so sacrifice
8079 theirmark->op_next = ourmark->op_next;
8080 theirmark->op_flags = ourmark->op_flags;
8081 ourlast->op_next = gvop ? gvop : (OP *) enter;
8084 enter->op_private |= OPpITER_REVERSED;
8085 iter->op_private |= OPpITER_REVERSED;
8092 UNOP *refgen, *rv2cv;
8095 /* I do not understand this, but if o->op_opt isn't set to 1,
8096 various tests in ext/B/t/bytecode.t fail with no readily
8102 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8105 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8108 rv2gv = ((BINOP *)o)->op_last;
8109 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8112 refgen = (UNOP *)((BINOP *)o)->op_first;
8114 if (!refgen || refgen->op_type != OP_REFGEN)
8117 exlist = (LISTOP *)refgen->op_first;
8118 if (!exlist || exlist->op_type != OP_NULL
8119 || exlist->op_targ != OP_LIST)
8122 if (exlist->op_first->op_type != OP_PUSHMARK)
8125 rv2cv = (UNOP*)exlist->op_last;
8127 if (rv2cv->op_type != OP_RV2CV)
8130 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8131 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8132 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8134 o->op_private |= OPpASSIGN_CV_TO_GV;
8135 rv2gv->op_private |= OPpDONT_INIT_GV;
8136 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8152 Perl_custom_op_name(pTHX_ const OP* o)
8155 const IV index = PTR2IV(o->op_ppaddr);
8159 if (!PL_custom_op_names) /* This probably shouldn't happen */
8160 return (char *)PL_op_name[OP_CUSTOM];
8162 keysv = sv_2mortal(newSViv(index));
8164 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8166 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8168 return SvPV_nolen(HeVAL(he));
8172 Perl_custom_op_desc(pTHX_ const OP* o)
8175 const IV index = PTR2IV(o->op_ppaddr);
8179 if (!PL_custom_op_descs)
8180 return (char *)PL_op_desc[OP_CUSTOM];
8182 keysv = sv_2mortal(newSViv(index));
8184 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8186 return (char *)PL_op_desc[OP_CUSTOM];
8188 return SvPV_nolen(HeVAL(he));
8193 /* Efficient sub that returns a constant scalar value. */
8195 const_sv_xsub(pTHX_ CV* cv)
8202 Perl_croak(aTHX_ "usage: %s::%s()",
8203 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8207 ST(0) = (SV*)XSANY.any_ptr;
8213 * c-indentation-style: bsd
8215 * indent-tabs-mode: t
8218 * ex: set ts=8 sts=4 sw=4 noet: