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 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1110 SAVEI32(PL_compiling.cop_arybase);
1111 PL_compiling.cop_arybase = 0;
1113 else if (type == OP_REFGEN)
1116 Perl_croak(aTHX_ "That use of $[ is unsupported");
1119 if (o->op_flags & OPf_PARENS || PL_madskills)
1123 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1124 !(o->op_flags & OPf_STACKED)) {
1125 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1126 /* The default is to set op_private to the number of children,
1127 which for a UNOP such as RV2CV is always 1. And w're using
1128 the bit for a flag in RV2CV, so we need it clear. */
1129 o->op_private &= ~1;
1130 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1131 assert(cUNOPo->op_first->op_type == OP_NULL);
1132 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1135 else if (o->op_private & OPpENTERSUB_NOMOD)
1137 else { /* lvalue subroutine call */
1138 o->op_private |= OPpLVAL_INTRO;
1139 PL_modcount = RETURN_UNLIMITED_NUMBER;
1140 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1141 /* Backward compatibility mode: */
1142 o->op_private |= OPpENTERSUB_INARGS;
1145 else { /* Compile-time error message: */
1146 OP *kid = cUNOPo->op_first;
1150 if (kid->op_type == OP_PUSHMARK)
1152 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1154 "panic: unexpected lvalue entersub "
1155 "args: type/targ %ld:%"UVuf,
1156 (long)kid->op_type, (UV)kid->op_targ);
1157 kid = kLISTOP->op_first;
1159 while (kid->op_sibling)
1160 kid = kid->op_sibling;
1161 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1163 if (kid->op_type == OP_METHOD_NAMED
1164 || kid->op_type == OP_METHOD)
1168 NewOp(1101, newop, 1, UNOP);
1169 newop->op_type = OP_RV2CV;
1170 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1171 newop->op_first = NULL;
1172 newop->op_next = (OP*)newop;
1173 kid->op_sibling = (OP*)newop;
1174 newop->op_private |= OPpLVAL_INTRO;
1175 newop->op_private &= ~1;
1179 if (kid->op_type != OP_RV2CV)
1181 "panic: unexpected lvalue entersub "
1182 "entry via type/targ %ld:%"UVuf,
1183 (long)kid->op_type, (UV)kid->op_targ);
1184 kid->op_private |= OPpLVAL_INTRO;
1185 break; /* Postpone until runtime */
1189 kid = kUNOP->op_first;
1190 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1191 kid = kUNOP->op_first;
1192 if (kid->op_type == OP_NULL)
1194 "Unexpected constant lvalue entersub "
1195 "entry via type/targ %ld:%"UVuf,
1196 (long)kid->op_type, (UV)kid->op_targ);
1197 if (kid->op_type != OP_GV) {
1198 /* Restore RV2CV to check lvalueness */
1200 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1201 okid->op_next = kid->op_next;
1202 kid->op_next = okid;
1205 okid->op_next = NULL;
1206 okid->op_type = OP_RV2CV;
1208 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1209 okid->op_private |= OPpLVAL_INTRO;
1210 okid->op_private &= ~1;
1214 cv = GvCV(kGVOP_gv);
1224 /* grep, foreach, subcalls, refgen */
1225 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1227 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1228 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1230 : (o->op_type == OP_ENTERSUB
1231 ? "non-lvalue subroutine call"
1233 type ? PL_op_desc[type] : "local"));
1247 case OP_RIGHT_SHIFT:
1256 if (!(o->op_flags & OPf_STACKED))
1263 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1269 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1270 PL_modcount = RETURN_UNLIMITED_NUMBER;
1271 return o; /* Treat \(@foo) like ordinary list. */
1275 if (scalar_mod_type(o, type))
1277 ref(cUNOPo->op_first, o->op_type);
1281 if (type == OP_LEAVESUBLV)
1282 o->op_private |= OPpMAYBE_LVSUB;
1288 PL_modcount = RETURN_UNLIMITED_NUMBER;
1291 ref(cUNOPo->op_first, o->op_type);
1296 PL_hints |= HINT_BLOCK_SCOPE;
1311 PL_modcount = RETURN_UNLIMITED_NUMBER;
1312 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1313 return o; /* Treat \(@foo) like ordinary list. */
1314 if (scalar_mod_type(o, type))
1316 if (type == OP_LEAVESUBLV)
1317 o->op_private |= OPpMAYBE_LVSUB;
1321 if (!type) /* local() */
1322 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1323 PAD_COMPNAME_PV(o->op_targ));
1331 if (type != OP_SASSIGN)
1335 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1340 if (type == OP_LEAVESUBLV)
1341 o->op_private |= OPpMAYBE_LVSUB;
1343 pad_free(o->op_targ);
1344 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1345 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1346 if (o->op_flags & OPf_KIDS)
1347 mod(cBINOPo->op_first->op_sibling, type);
1352 ref(cBINOPo->op_first, o->op_type);
1353 if (type == OP_ENTERSUB &&
1354 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1355 o->op_private |= OPpLVAL_DEFER;
1356 if (type == OP_LEAVESUBLV)
1357 o->op_private |= OPpMAYBE_LVSUB;
1367 if (o->op_flags & OPf_KIDS)
1368 mod(cLISTOPo->op_last, type);
1373 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1375 else if (!(o->op_flags & OPf_KIDS))
1377 if (o->op_targ != OP_LIST) {
1378 mod(cBINOPo->op_first, type);
1384 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1389 if (type != OP_LEAVESUBLV)
1391 break; /* mod()ing was handled by ck_return() */
1394 /* [20011101.069] File test operators interpret OPf_REF to mean that
1395 their argument is a filehandle; thus \stat(".") should not set
1397 if (type == OP_REFGEN &&
1398 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1401 if (type != OP_LEAVESUBLV)
1402 o->op_flags |= OPf_MOD;
1404 if (type == OP_AASSIGN || type == OP_SASSIGN)
1405 o->op_flags |= OPf_SPECIAL|OPf_REF;
1406 else if (!type) { /* local() */
1409 o->op_private |= OPpLVAL_INTRO;
1410 o->op_flags &= ~OPf_SPECIAL;
1411 PL_hints |= HINT_BLOCK_SCOPE;
1416 if (ckWARN(WARN_SYNTAX)) {
1417 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1418 "Useless localization of %s", OP_DESC(o));
1422 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1423 && type != OP_LEAVESUBLV)
1424 o->op_flags |= OPf_REF;
1429 S_scalar_mod_type(const OP *o, I32 type)
1433 if (o->op_type == OP_RV2GV)
1457 case OP_RIGHT_SHIFT:
1476 S_is_handle_constructor(const OP *o, I32 numargs)
1478 switch (o->op_type) {
1486 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1499 Perl_refkids(pTHX_ OP *o, I32 type)
1501 if (o && o->op_flags & OPf_KIDS) {
1503 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1510 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1515 if (!o || PL_error_count)
1518 switch (o->op_type) {
1520 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1521 !(o->op_flags & OPf_STACKED)) {
1522 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1523 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1524 assert(cUNOPo->op_first->op_type == OP_NULL);
1525 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1526 o->op_flags |= OPf_SPECIAL;
1527 o->op_private &= ~1;
1532 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1533 doref(kid, type, set_op_ref);
1536 if (type == OP_DEFINED)
1537 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1538 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1541 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1542 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1543 : type == OP_RV2HV ? OPpDEREF_HV
1545 o->op_flags |= OPf_MOD;
1550 o->op_flags |= OPf_MOD; /* XXX ??? */
1556 o->op_flags |= OPf_REF;
1559 if (type == OP_DEFINED)
1560 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1561 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1567 o->op_flags |= OPf_REF;
1572 if (!(o->op_flags & OPf_KIDS))
1574 doref(cBINOPo->op_first, type, set_op_ref);
1578 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1579 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1580 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1581 : type == OP_RV2HV ? OPpDEREF_HV
1583 o->op_flags |= OPf_MOD;
1593 if (!(o->op_flags & OPf_KIDS))
1595 doref(cLISTOPo->op_last, type, set_op_ref);
1605 S_dup_attrlist(pTHX_ OP *o)
1610 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1611 * where the first kid is OP_PUSHMARK and the remaining ones
1612 * are OP_CONST. We need to push the OP_CONST values.
1614 if (o->op_type == OP_CONST)
1615 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1617 else if (o->op_type == OP_NULL)
1621 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1623 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1624 if (o->op_type == OP_CONST)
1625 rop = append_elem(OP_LIST, rop,
1626 newSVOP(OP_CONST, o->op_flags,
1627 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1634 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1639 /* fake up C<use attributes $pkg,$rv,@attrs> */
1640 ENTER; /* need to protect against side-effects of 'use' */
1642 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1644 #define ATTRSMODULE "attributes"
1645 #define ATTRSMODULE_PM "attributes.pm"
1648 /* Don't force the C<use> if we don't need it. */
1649 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1650 if (svp && *svp != &PL_sv_undef)
1651 /*EMPTY*/; /* already in %INC */
1653 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1654 newSVpvs(ATTRSMODULE), NULL);
1657 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1658 newSVpvs(ATTRSMODULE),
1660 prepend_elem(OP_LIST,
1661 newSVOP(OP_CONST, 0, stashsv),
1662 prepend_elem(OP_LIST,
1663 newSVOP(OP_CONST, 0,
1665 dup_attrlist(attrs))));
1671 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1674 OP *pack, *imop, *arg;
1680 assert(target->op_type == OP_PADSV ||
1681 target->op_type == OP_PADHV ||
1682 target->op_type == OP_PADAV);
1684 /* Ensure that attributes.pm is loaded. */
1685 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1687 /* Need package name for method call. */
1688 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1690 /* Build up the real arg-list. */
1691 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1693 arg = newOP(OP_PADSV, 0);
1694 arg->op_targ = target->op_targ;
1695 arg = prepend_elem(OP_LIST,
1696 newSVOP(OP_CONST, 0, stashsv),
1697 prepend_elem(OP_LIST,
1698 newUNOP(OP_REFGEN, 0,
1699 mod(arg, OP_REFGEN)),
1700 dup_attrlist(attrs)));
1702 /* Fake up a method call to import */
1703 meth = newSVpvs_share("import");
1704 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1705 append_elem(OP_LIST,
1706 prepend_elem(OP_LIST, pack, list(arg)),
1707 newSVOP(OP_METHOD_NAMED, 0, meth)));
1708 imop->op_private |= OPpENTERSUB_NOMOD;
1710 /* Combine the ops. */
1711 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1715 =notfor apidoc apply_attrs_string
1717 Attempts to apply a list of attributes specified by the C<attrstr> and
1718 C<len> arguments to the subroutine identified by the C<cv> argument which
1719 is expected to be associated with the package identified by the C<stashpv>
1720 argument (see L<attributes>). It gets this wrong, though, in that it
1721 does not correctly identify the boundaries of the individual attribute
1722 specifications within C<attrstr>. This is not really intended for the
1723 public API, but has to be listed here for systems such as AIX which
1724 need an explicit export list for symbols. (It's called from XS code
1725 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1726 to respect attribute syntax properly would be welcome.
1732 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1733 const char *attrstr, STRLEN len)
1738 len = strlen(attrstr);
1742 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1744 const char * const sstr = attrstr;
1745 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1746 attrs = append_elem(OP_LIST, attrs,
1747 newSVOP(OP_CONST, 0,
1748 newSVpvn(sstr, attrstr-sstr)));
1752 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1753 newSVpvs(ATTRSMODULE),
1754 NULL, prepend_elem(OP_LIST,
1755 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1756 prepend_elem(OP_LIST,
1757 newSVOP(OP_CONST, 0,
1763 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1768 if (!o || PL_error_count)
1772 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1773 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1777 if (type == OP_LIST) {
1779 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1780 my_kid(kid, attrs, imopsp);
1781 } else if (type == OP_UNDEF
1787 } else if (type == OP_RV2SV || /* "our" declaration */
1789 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1790 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1791 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1792 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1794 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1796 PL_in_my_stash = NULL;
1797 apply_attrs(GvSTASH(gv),
1798 (type == OP_RV2SV ? GvSV(gv) :
1799 type == OP_RV2AV ? (SV*)GvAV(gv) :
1800 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1803 o->op_private |= OPpOUR_INTRO;
1806 else if (type != OP_PADSV &&
1809 type != OP_PUSHMARK)
1811 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1813 PL_in_my == KEY_our ? "our" : "my"));
1816 else if (attrs && type != OP_PUSHMARK) {
1820 PL_in_my_stash = NULL;
1822 /* check for C<my Dog $spot> when deciding package */
1823 stash = PAD_COMPNAME_TYPE(o->op_targ);
1825 stash = PL_curstash;
1826 apply_attrs_my(stash, o, attrs, imopsp);
1828 o->op_flags |= OPf_MOD;
1829 o->op_private |= OPpLVAL_INTRO;
1834 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1838 int maybe_scalar = 0;
1840 /* [perl #17376]: this appears to be premature, and results in code such as
1841 C< our(%x); > executing in list mode rather than void mode */
1843 if (o->op_flags & OPf_PARENS)
1853 o = my_kid(o, attrs, &rops);
1855 if (maybe_scalar && o->op_type == OP_PADSV) {
1856 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1857 o->op_private |= OPpLVAL_INTRO;
1860 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1863 PL_in_my_stash = NULL;
1868 Perl_my(pTHX_ OP *o)
1870 return my_attrs(o, NULL);
1874 Perl_sawparens(pTHX_ OP *o)
1876 PERL_UNUSED_CONTEXT;
1878 o->op_flags |= OPf_PARENS;
1883 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1888 if ( (left->op_type == OP_RV2AV ||
1889 left->op_type == OP_RV2HV ||
1890 left->op_type == OP_PADAV ||
1891 left->op_type == OP_PADHV)
1892 && ckWARN(WARN_MISC))
1894 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1895 right->op_type == OP_TRANS)
1896 ? right->op_type : OP_MATCH];
1897 const char * const sample = ((left->op_type == OP_RV2AV ||
1898 left->op_type == OP_PADAV)
1899 ? "@array" : "%hash");
1900 Perl_warner(aTHX_ packWARN(WARN_MISC),
1901 "Applying %s to %s will act on scalar(%s)",
1902 desc, sample, sample);
1905 if (right->op_type == OP_CONST &&
1906 cSVOPx(right)->op_private & OPpCONST_BARE &&
1907 cSVOPx(right)->op_private & OPpCONST_STRICT)
1909 no_bareword_allowed(right);
1912 ismatchop = right->op_type == OP_MATCH ||
1913 right->op_type == OP_SUBST ||
1914 right->op_type == OP_TRANS;
1915 if (ismatchop && right->op_private & OPpTARGET_MY) {
1917 right->op_private &= ~OPpTARGET_MY;
1919 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1920 right->op_flags |= OPf_STACKED;
1921 if (right->op_type != OP_MATCH &&
1922 ! (right->op_type == OP_TRANS &&
1923 right->op_private & OPpTRANS_IDENTICAL))
1924 left = mod(left, right->op_type);
1925 if (right->op_type == OP_TRANS)
1926 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1928 o = prepend_elem(right->op_type, scalar(left), right);
1930 return newUNOP(OP_NOT, 0, scalar(o));
1934 return bind_match(type, left,
1935 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1939 Perl_invert(pTHX_ OP *o)
1943 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1947 Perl_scope(pTHX_ OP *o)
1951 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1952 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1953 o->op_type = OP_LEAVE;
1954 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1956 else if (o->op_type == OP_LINESEQ) {
1958 o->op_type = OP_SCOPE;
1959 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1960 kid = ((LISTOP*)o)->op_first;
1961 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1964 /* The following deals with things like 'do {1 for 1}' */
1965 kid = kid->op_sibling;
1967 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1972 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1978 Perl_block_start(pTHX_ int full)
1981 const int retval = PL_savestack_ix;
1982 pad_block_start(full);
1984 PL_hints &= ~HINT_BLOCK_SCOPE;
1985 SAVESPTR(PL_compiling.cop_warnings);
1986 if (! specialWARN(PL_compiling.cop_warnings)) {
1987 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1988 SAVEFREESV(PL_compiling.cop_warnings) ;
1990 SAVESPTR(PL_compiling.cop_io);
1991 if (! specialCopIO(PL_compiling.cop_io)) {
1992 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1993 SAVEFREESV(PL_compiling.cop_io) ;
1999 Perl_block_end(pTHX_ I32 floor, OP *seq)
2002 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2003 OP* const retval = scalarseq(seq);
2005 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2007 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2016 const I32 offset = pad_findmy("$_");
2017 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2018 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2021 OP * const o = newOP(OP_PADSV, 0);
2022 o->op_targ = offset;
2028 Perl_newPROG(pTHX_ OP *o)
2034 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2035 ((PL_in_eval & EVAL_KEEPERR)
2036 ? OPf_SPECIAL : 0), o);
2037 PL_eval_start = linklist(PL_eval_root);
2038 PL_eval_root->op_private |= OPpREFCOUNTED;
2039 OpREFCNT_set(PL_eval_root, 1);
2040 PL_eval_root->op_next = 0;
2041 CALL_PEEP(PL_eval_start);
2044 if (o->op_type == OP_STUB) {
2045 PL_comppad_name = 0;
2050 PL_main_root = scope(sawparens(scalarvoid(o)));
2051 PL_curcop = &PL_compiling;
2052 PL_main_start = LINKLIST(PL_main_root);
2053 PL_main_root->op_private |= OPpREFCOUNTED;
2054 OpREFCNT_set(PL_main_root, 1);
2055 PL_main_root->op_next = 0;
2056 CALL_PEEP(PL_main_start);
2059 /* Register with debugger */
2061 CV * const cv = get_cv("DB::postponed", FALSE);
2065 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2067 call_sv((SV*)cv, G_DISCARD);
2074 Perl_localize(pTHX_ OP *o, I32 lex)
2077 if (o->op_flags & OPf_PARENS)
2078 /* [perl #17376]: this appears to be premature, and results in code such as
2079 C< our(%x); > executing in list mode rather than void mode */
2086 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2087 && ckWARN(WARN_PARENTHESIS))
2089 char *s = PL_bufptr;
2092 /* some heuristics to detect a potential error */
2093 while (*s && (strchr(", \t\n", *s)))
2097 if (*s && strchr("@$%*", *s) && *++s
2098 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2101 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2103 while (*s && (strchr(", \t\n", *s)))
2109 if (sigil && (*s == ';' || *s == '=')) {
2110 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2111 "Parentheses missing around \"%s\" list",
2112 lex ? (PL_in_my == KEY_our ? "our" : "my")
2120 o = mod(o, OP_NULL); /* a bit kludgey */
2122 PL_in_my_stash = NULL;
2127 Perl_jmaybe(pTHX_ OP *o)
2129 if (o->op_type == OP_LIST) {
2131 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2132 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2138 Perl_fold_constants(pTHX_ register OP *o)
2143 I32 type = o->op_type;
2150 if (PL_opargs[type] & OA_RETSCALAR)
2152 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2153 o->op_targ = pad_alloc(type, SVs_PADTMP);
2155 /* integerize op, unless it happens to be C<-foo>.
2156 * XXX should pp_i_negate() do magic string negation instead? */
2157 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2158 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2159 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2161 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2164 if (!(PL_opargs[type] & OA_FOLDCONST))
2169 /* XXX might want a ck_negate() for this */
2170 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2181 /* XXX what about the numeric ops? */
2182 if (PL_hints & HINT_LOCALE)
2187 goto nope; /* Don't try to run w/ errors */
2189 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2190 if ((curop->op_type != OP_CONST ||
2191 (curop->op_private & OPpCONST_BARE)) &&
2192 curop->op_type != OP_LIST &&
2193 curop->op_type != OP_SCALAR &&
2194 curop->op_type != OP_NULL &&
2195 curop->op_type != OP_PUSHMARK)
2201 curop = LINKLIST(o);
2202 old_next = o->op_next;
2206 oldscope = PL_scopestack_ix;
2207 create_eval_scope(G_FAKINGEVAL);
2214 sv = *(PL_stack_sp--);
2215 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2216 pad_swipe(o->op_targ, FALSE);
2217 else if (SvTEMP(sv)) { /* grab mortal temp? */
2218 SvREFCNT_inc_simple_void(sv);
2223 /* Something tried to die. Abandon constant folding. */
2224 /* Pretend the error never happened. */
2225 sv_setpvn(ERRSV,"",0);
2226 o->op_next = old_next;
2230 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2231 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2236 if (PL_scopestack_ix > oldscope)
2237 delete_eval_scope();
2245 if (type == OP_RV2GV)
2246 newop = newGVOP(OP_GV, 0, (GV*)sv);
2248 newop = newSVOP(OP_CONST, 0, sv);
2249 op_getmad(o,newop,'f');
2257 Perl_gen_constant_list(pTHX_ register OP *o)
2261 const I32 oldtmps_floor = PL_tmps_floor;
2265 return o; /* Don't attempt to run with errors */
2267 PL_op = curop = LINKLIST(o);
2274 PL_tmps_floor = oldtmps_floor;
2276 o->op_type = OP_RV2AV;
2277 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2278 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2279 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2280 o->op_opt = 0; /* needs to be revisited in peep() */
2281 curop = ((UNOP*)o)->op_first;
2282 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2284 op_getmad(curop,o,'O');
2293 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2296 if (!o || o->op_type != OP_LIST)
2297 o = newLISTOP(OP_LIST, 0, o, NULL);
2299 o->op_flags &= ~OPf_WANT;
2301 if (!(PL_opargs[type] & OA_MARK))
2302 op_null(cLISTOPo->op_first);
2304 o->op_type = (OPCODE)type;
2305 o->op_ppaddr = PL_ppaddr[type];
2306 o->op_flags |= flags;
2308 o = CHECKOP(type, o);
2309 if (o->op_type != (unsigned)type)
2312 return fold_constants(o);
2315 /* List constructors */
2318 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2326 if (first->op_type != (unsigned)type
2327 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2329 return newLISTOP(type, 0, first, last);
2332 if (first->op_flags & OPf_KIDS)
2333 ((LISTOP*)first)->op_last->op_sibling = last;
2335 first->op_flags |= OPf_KIDS;
2336 ((LISTOP*)first)->op_first = last;
2338 ((LISTOP*)first)->op_last = last;
2343 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2351 if (first->op_type != (unsigned)type)
2352 return prepend_elem(type, (OP*)first, (OP*)last);
2354 if (last->op_type != (unsigned)type)
2355 return append_elem(type, (OP*)first, (OP*)last);
2357 first->op_last->op_sibling = last->op_first;
2358 first->op_last = last->op_last;
2359 first->op_flags |= (last->op_flags & OPf_KIDS);
2362 if (last->op_first && first->op_madprop) {
2363 MADPROP *mp = last->op_first->op_madprop;
2365 while (mp->mad_next)
2367 mp->mad_next = first->op_madprop;
2370 last->op_first->op_madprop = first->op_madprop;
2373 first->op_madprop = last->op_madprop;
2374 last->op_madprop = 0;
2383 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2391 if (last->op_type == (unsigned)type) {
2392 if (type == OP_LIST) { /* already a PUSHMARK there */
2393 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2394 ((LISTOP*)last)->op_first->op_sibling = first;
2395 if (!(first->op_flags & OPf_PARENS))
2396 last->op_flags &= ~OPf_PARENS;
2399 if (!(last->op_flags & OPf_KIDS)) {
2400 ((LISTOP*)last)->op_last = first;
2401 last->op_flags |= OPf_KIDS;
2403 first->op_sibling = ((LISTOP*)last)->op_first;
2404 ((LISTOP*)last)->op_first = first;
2406 last->op_flags |= OPf_KIDS;
2410 return newLISTOP(type, 0, first, last);
2418 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2421 Newxz(tk, 1, TOKEN);
2422 tk->tk_type = (OPCODE)optype;
2423 tk->tk_type = 12345;
2425 tk->tk_mad = madprop;
2430 Perl_token_free(pTHX_ TOKEN* tk)
2432 if (tk->tk_type != 12345)
2434 mad_free(tk->tk_mad);
2439 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2443 if (tk->tk_type != 12345) {
2444 Perl_warner(aTHX_ packWARN(WARN_MISC),
2445 "Invalid TOKEN object ignored");
2452 /* faked up qw list? */
2454 tm->mad_type == MAD_SV &&
2455 SvPVX((SV*)tm->mad_val)[0] == 'q')
2462 /* pretend constant fold didn't happen? */
2463 if (mp->mad_key == 'f' &&
2464 (o->op_type == OP_CONST ||
2465 o->op_type == OP_GV) )
2467 token_getmad(tk,(OP*)mp->mad_val,slot);
2481 if (mp->mad_key == 'X')
2482 mp->mad_key = slot; /* just change the first one */
2492 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2501 /* pretend constant fold didn't happen? */
2502 if (mp->mad_key == 'f' &&
2503 (o->op_type == OP_CONST ||
2504 o->op_type == OP_GV) )
2506 op_getmad(from,(OP*)mp->mad_val,slot);
2513 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2516 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2522 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2531 /* pretend constant fold didn't happen? */
2532 if (mp->mad_key == 'f' &&
2533 (o->op_type == OP_CONST ||
2534 o->op_type == OP_GV) )
2536 op_getmad(from,(OP*)mp->mad_val,slot);
2543 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2546 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2550 PerlIO_printf(PerlIO_stderr(),
2551 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2557 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2575 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2579 addmad(tm, &(o->op_madprop), slot);
2583 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2604 Perl_newMADsv(pTHX_ char key, SV* sv)
2606 return newMADPROP(key, MAD_SV, sv, 0);
2610 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2613 Newxz(mp, 1, MADPROP);
2616 mp->mad_vlen = vlen;
2617 mp->mad_type = type;
2619 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2624 Perl_mad_free(pTHX_ MADPROP* mp)
2626 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2630 mad_free(mp->mad_next);
2631 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2632 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2633 switch (mp->mad_type) {
2637 Safefree((char*)mp->mad_val);
2640 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2641 op_free((OP*)mp->mad_val);
2644 sv_free((SV*)mp->mad_val);
2647 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2656 Perl_newNULLLIST(pTHX)
2658 return newOP(OP_STUB, 0);
2662 Perl_force_list(pTHX_ OP *o)
2664 if (!o || o->op_type != OP_LIST)
2665 o = newLISTOP(OP_LIST, 0, o, NULL);
2671 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2676 NewOp(1101, listop, 1, LISTOP);
2678 listop->op_type = (OPCODE)type;
2679 listop->op_ppaddr = PL_ppaddr[type];
2682 listop->op_flags = (U8)flags;
2686 else if (!first && last)
2689 first->op_sibling = last;
2690 listop->op_first = first;
2691 listop->op_last = last;
2692 if (type == OP_LIST) {
2693 OP* const pushop = newOP(OP_PUSHMARK, 0);
2694 pushop->op_sibling = first;
2695 listop->op_first = pushop;
2696 listop->op_flags |= OPf_KIDS;
2698 listop->op_last = pushop;
2701 return CHECKOP(type, listop);
2705 Perl_newOP(pTHX_ I32 type, I32 flags)
2709 NewOp(1101, o, 1, OP);
2710 o->op_type = (OPCODE)type;
2711 o->op_ppaddr = PL_ppaddr[type];
2712 o->op_flags = (U8)flags;
2715 o->op_private = (U8)(0 | (flags >> 8));
2716 if (PL_opargs[type] & OA_RETSCALAR)
2718 if (PL_opargs[type] & OA_TARGET)
2719 o->op_targ = pad_alloc(type, SVs_PADTMP);
2720 return CHECKOP(type, o);
2724 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2730 first = newOP(OP_STUB, 0);
2731 if (PL_opargs[type] & OA_MARK)
2732 first = force_list(first);
2734 NewOp(1101, unop, 1, UNOP);
2735 unop->op_type = (OPCODE)type;
2736 unop->op_ppaddr = PL_ppaddr[type];
2737 unop->op_first = first;
2738 unop->op_flags = (U8)(flags | OPf_KIDS);
2739 unop->op_private = (U8)(1 | (flags >> 8));
2740 unop = (UNOP*) CHECKOP(type, unop);
2744 return fold_constants((OP *) unop);
2748 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2752 NewOp(1101, binop, 1, BINOP);
2755 first = newOP(OP_NULL, 0);
2757 binop->op_type = (OPCODE)type;
2758 binop->op_ppaddr = PL_ppaddr[type];
2759 binop->op_first = first;
2760 binop->op_flags = (U8)(flags | OPf_KIDS);
2763 binop->op_private = (U8)(1 | (flags >> 8));
2766 binop->op_private = (U8)(2 | (flags >> 8));
2767 first->op_sibling = last;
2770 binop = (BINOP*)CHECKOP(type, binop);
2771 if (binop->op_next || binop->op_type != (OPCODE)type)
2774 binop->op_last = binop->op_first->op_sibling;
2776 return fold_constants((OP *)binop);
2779 static int uvcompare(const void *a, const void *b)
2780 __attribute__nonnull__(1)
2781 __attribute__nonnull__(2)
2782 __attribute__pure__;
2783 static int uvcompare(const void *a, const void *b)
2785 if (*((const UV *)a) < (*(const UV *)b))
2787 if (*((const UV *)a) > (*(const UV *)b))
2789 if (*((const UV *)a+1) < (*(const UV *)b+1))
2791 if (*((const UV *)a+1) > (*(const UV *)b+1))
2797 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2800 SV * const tstr = ((SVOP*)expr)->op_sv;
2801 SV * const rstr = ((SVOP*)repl)->op_sv;
2804 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2805 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2809 register short *tbl;
2811 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2812 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2813 I32 del = o->op_private & OPpTRANS_DELETE;
2814 PL_hints |= HINT_BLOCK_SCOPE;
2817 o->op_private |= OPpTRANS_FROM_UTF;
2820 o->op_private |= OPpTRANS_TO_UTF;
2822 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2823 SV* const listsv = newSVpvs("# comment\n");
2825 const U8* tend = t + tlen;
2826 const U8* rend = r + rlen;
2840 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2841 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2847 t = tsave = bytes_to_utf8(t, &len);
2850 if (!to_utf && rlen) {
2852 r = rsave = bytes_to_utf8(r, &len);
2856 /* There are several snags with this code on EBCDIC:
2857 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2858 2. scan_const() in toke.c has encoded chars in native encoding which makes
2859 ranges at least in EBCDIC 0..255 range the bottom odd.
2863 U8 tmpbuf[UTF8_MAXBYTES+1];
2866 Newx(cp, 2*tlen, UV);
2868 transv = newSVpvs("");
2870 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2872 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2874 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2878 cp[2*i+1] = cp[2*i];
2882 qsort(cp, i, 2*sizeof(UV), uvcompare);
2883 for (j = 0; j < i; j++) {
2885 diff = val - nextmin;
2887 t = uvuni_to_utf8(tmpbuf,nextmin);
2888 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2890 U8 range_mark = UTF_TO_NATIVE(0xff);
2891 t = uvuni_to_utf8(tmpbuf, val - 1);
2892 sv_catpvn(transv, (char *)&range_mark, 1);
2893 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2900 t = uvuni_to_utf8(tmpbuf,nextmin);
2901 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2903 U8 range_mark = UTF_TO_NATIVE(0xff);
2904 sv_catpvn(transv, (char *)&range_mark, 1);
2906 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2907 UNICODE_ALLOW_SUPER);
2908 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2909 t = (const U8*)SvPVX_const(transv);
2910 tlen = SvCUR(transv);
2914 else if (!rlen && !del) {
2915 r = t; rlen = tlen; rend = tend;
2918 if ((!rlen && !del) || t == r ||
2919 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2921 o->op_private |= OPpTRANS_IDENTICAL;
2925 while (t < tend || tfirst <= tlast) {
2926 /* see if we need more "t" chars */
2927 if (tfirst > tlast) {
2928 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2930 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2932 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2939 /* now see if we need more "r" chars */
2940 if (rfirst > rlast) {
2942 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2944 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2946 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2955 rfirst = rlast = 0xffffffff;
2959 /* now see which range will peter our first, if either. */
2960 tdiff = tlast - tfirst;
2961 rdiff = rlast - rfirst;
2968 if (rfirst == 0xffffffff) {
2969 diff = tdiff; /* oops, pretend rdiff is infinite */
2971 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2972 (long)tfirst, (long)tlast);
2974 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2978 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2979 (long)tfirst, (long)(tfirst + diff),
2982 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2983 (long)tfirst, (long)rfirst);
2985 if (rfirst + diff > max)
2986 max = rfirst + diff;
2988 grows = (tfirst < rfirst &&
2989 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3001 else if (max > 0xff)
3006 Safefree(cPVOPo->op_pv);
3007 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3008 SvREFCNT_dec(listsv);
3009 SvREFCNT_dec(transv);
3011 if (!del && havefinal && rlen)
3012 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3013 newSVuv((UV)final), 0);
3016 o->op_private |= OPpTRANS_GROWS;
3022 op_getmad(expr,o,'e');
3023 op_getmad(repl,o,'r');
3031 tbl = (short*)cPVOPo->op_pv;
3033 Zero(tbl, 256, short);
3034 for (i = 0; i < (I32)tlen; i++)
3036 for (i = 0, j = 0; i < 256; i++) {
3038 if (j >= (I32)rlen) {
3047 if (i < 128 && r[j] >= 128)
3057 o->op_private |= OPpTRANS_IDENTICAL;
3059 else if (j >= (I32)rlen)
3062 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3063 tbl[0x100] = (short)(rlen - j);
3064 for (i=0; i < (I32)rlen - j; i++)
3065 tbl[0x101+i] = r[j+i];
3069 if (!rlen && !del) {
3072 o->op_private |= OPpTRANS_IDENTICAL;
3074 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3075 o->op_private |= OPpTRANS_IDENTICAL;
3077 for (i = 0; i < 256; i++)
3079 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3080 if (j >= (I32)rlen) {
3082 if (tbl[t[i]] == -1)
3088 if (tbl[t[i]] == -1) {
3089 if (t[i] < 128 && r[j] >= 128)
3096 o->op_private |= OPpTRANS_GROWS;
3098 op_getmad(expr,o,'e');
3099 op_getmad(repl,o,'r');
3109 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3114 NewOp(1101, pmop, 1, PMOP);
3115 pmop->op_type = (OPCODE)type;
3116 pmop->op_ppaddr = PL_ppaddr[type];
3117 pmop->op_flags = (U8)flags;
3118 pmop->op_private = (U8)(0 | (flags >> 8));
3120 if (PL_hints & HINT_RE_TAINT)
3121 pmop->op_pmpermflags |= PMf_RETAINT;
3122 if (PL_hints & HINT_LOCALE)
3123 pmop->op_pmpermflags |= PMf_LOCALE;
3124 pmop->op_pmflags = pmop->op_pmpermflags;
3127 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3128 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3129 pmop->op_pmoffset = SvIV(repointer);
3130 SvREPADTMP_off(repointer);
3131 sv_setiv(repointer,0);
3133 SV * const repointer = newSViv(0);
3134 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3135 pmop->op_pmoffset = av_len(PL_regex_padav);
3136 PL_regex_pad = AvARRAY(PL_regex_padav);
3140 /* link into pm list */
3141 if (type != OP_TRANS && PL_curstash) {
3142 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3145 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3147 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3148 mg->mg_obj = (SV*)pmop;
3149 PmopSTASH_set(pmop,PL_curstash);
3152 return CHECKOP(type, pmop);
3155 /* Given some sort of match op o, and an expression expr containing a
3156 * pattern, either compile expr into a regex and attach it to o (if it's
3157 * constant), or convert expr into a runtime regcomp op sequence (if it's
3160 * isreg indicates that the pattern is part of a regex construct, eg
3161 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3162 * split "pattern", which aren't. In the former case, expr will be a list
3163 * if the pattern contains more than one term (eg /a$b/) or if it contains
3164 * a replacement, ie s/// or tr///.
3168 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3173 I32 repl_has_vars = 0;
3177 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3178 /* last element in list is the replacement; pop it */
3180 repl = cLISTOPx(expr)->op_last;
3181 kid = cLISTOPx(expr)->op_first;
3182 while (kid->op_sibling != repl)
3183 kid = kid->op_sibling;
3184 kid->op_sibling = NULL;
3185 cLISTOPx(expr)->op_last = kid;
3188 if (isreg && expr->op_type == OP_LIST &&
3189 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3191 /* convert single element list to element */
3192 OP* const oe = expr;
3193 expr = cLISTOPx(oe)->op_first->op_sibling;
3194 cLISTOPx(oe)->op_first->op_sibling = NULL;
3195 cLISTOPx(oe)->op_last = NULL;
3199 if (o->op_type == OP_TRANS) {
3200 return pmtrans(o, expr, repl);
3203 reglist = isreg && expr->op_type == OP_LIST;
3207 PL_hints |= HINT_BLOCK_SCOPE;
3210 if (expr->op_type == OP_CONST) {
3212 SV * const pat = ((SVOP*)expr)->op_sv;
3213 const char *p = SvPV_const(pat, plen);
3214 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3215 U32 was_readonly = SvREADONLY(pat);
3219 sv_force_normal_flags(pat, 0);
3220 assert(!SvREADONLY(pat));
3223 SvREADONLY_off(pat);
3227 sv_setpvn(pat, "\\s+", 3);
3229 SvFLAGS(pat) |= was_readonly;
3231 p = SvPV_const(pat, plen);
3232 pm->op_pmflags |= PMf_SKIPWHITE;
3235 pm->op_pmdynflags |= PMdf_UTF8;
3236 /* FIXME - can we make this function take const char * args? */
3237 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3238 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3239 pm->op_pmflags |= PMf_WHITE;
3241 op_getmad(expr,(OP*)pm,'e');
3247 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3248 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3250 : OP_REGCMAYBE),0,expr);
3252 NewOp(1101, rcop, 1, LOGOP);
3253 rcop->op_type = OP_REGCOMP;
3254 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3255 rcop->op_first = scalar(expr);
3256 rcop->op_flags |= OPf_KIDS
3257 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3258 | (reglist ? OPf_STACKED : 0);
3259 rcop->op_private = 1;
3262 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3264 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3267 /* establish postfix order */
3268 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3270 rcop->op_next = expr;
3271 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3274 rcop->op_next = LINKLIST(expr);
3275 expr->op_next = (OP*)rcop;
3278 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3283 if (pm->op_pmflags & PMf_EVAL) {
3285 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3286 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3288 else if (repl->op_type == OP_CONST)
3292 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3293 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3294 if (curop->op_type == OP_GV) {
3295 GV * const gv = cGVOPx_gv(curop);
3297 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3300 else if (curop->op_type == OP_RV2CV)
3302 else if (curop->op_type == OP_RV2SV ||
3303 curop->op_type == OP_RV2AV ||
3304 curop->op_type == OP_RV2HV ||
3305 curop->op_type == OP_RV2GV) {
3306 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3309 else if (curop->op_type == OP_PADSV ||
3310 curop->op_type == OP_PADAV ||
3311 curop->op_type == OP_PADHV ||
3312 curop->op_type == OP_PADANY) {
3315 else if (curop->op_type == OP_PUSHRE)
3316 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
3326 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3327 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3328 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3329 prepend_elem(o->op_type, scalar(repl), o);
3332 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3333 pm->op_pmflags |= PMf_MAYBE_CONST;
3334 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3336 NewOp(1101, rcop, 1, LOGOP);
3337 rcop->op_type = OP_SUBSTCONT;
3338 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3339 rcop->op_first = scalar(repl);
3340 rcop->op_flags |= OPf_KIDS;
3341 rcop->op_private = 1;
3344 /* establish postfix order */
3345 rcop->op_next = LINKLIST(repl);
3346 repl->op_next = (OP*)rcop;
3348 pm->op_pmreplroot = scalar((OP*)rcop);
3349 pm->op_pmreplstart = LINKLIST(rcop);
3358 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3362 NewOp(1101, svop, 1, SVOP);
3363 svop->op_type = (OPCODE)type;
3364 svop->op_ppaddr = PL_ppaddr[type];
3366 svop->op_next = (OP*)svop;
3367 svop->op_flags = (U8)flags;
3368 if (PL_opargs[type] & OA_RETSCALAR)
3370 if (PL_opargs[type] & OA_TARGET)
3371 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3372 return CHECKOP(type, svop);
3376 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3380 NewOp(1101, padop, 1, PADOP);
3381 padop->op_type = (OPCODE)type;
3382 padop->op_ppaddr = PL_ppaddr[type];
3383 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3384 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3385 PAD_SETSV(padop->op_padix, sv);
3388 padop->op_next = (OP*)padop;
3389 padop->op_flags = (U8)flags;
3390 if (PL_opargs[type] & OA_RETSCALAR)
3392 if (PL_opargs[type] & OA_TARGET)
3393 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3394 return CHECKOP(type, padop);
3398 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3404 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3406 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3411 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3415 NewOp(1101, pvop, 1, PVOP);
3416 pvop->op_type = (OPCODE)type;
3417 pvop->op_ppaddr = PL_ppaddr[type];
3419 pvop->op_next = (OP*)pvop;
3420 pvop->op_flags = (U8)flags;
3421 if (PL_opargs[type] & OA_RETSCALAR)
3423 if (PL_opargs[type] & OA_TARGET)
3424 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3425 return CHECKOP(type, pvop);
3433 Perl_package(pTHX_ OP *o)
3442 save_hptr(&PL_curstash);
3443 save_item(PL_curstname);
3445 name = SvPV_const(cSVOPo->op_sv, len);
3446 PL_curstash = gv_stashpvn(name, len, TRUE);
3447 sv_setpvn(PL_curstname, name, len);
3449 PL_hints |= HINT_BLOCK_SCOPE;
3450 PL_copline = NOLINE;
3456 if (!PL_madskills) {
3461 pegop = newOP(OP_NULL,0);
3462 op_getmad(o,pegop,'P');
3472 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3479 OP *pegop = newOP(OP_NULL,0);
3482 if (idop->op_type != OP_CONST)
3483 Perl_croak(aTHX_ "Module name must be constant");
3486 op_getmad(idop,pegop,'U');
3491 SV * const vesv = ((SVOP*)version)->op_sv;
3494 op_getmad(version,pegop,'V');
3495 if (!arg && !SvNIOKp(vesv)) {
3502 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3503 Perl_croak(aTHX_ "Version number must be constant number");
3505 /* Make copy of idop so we don't free it twice */
3506 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3508 /* Fake up a method call to VERSION */
3509 meth = newSVpvs_share("VERSION");
3510 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3511 append_elem(OP_LIST,
3512 prepend_elem(OP_LIST, pack, list(version)),
3513 newSVOP(OP_METHOD_NAMED, 0, meth)));
3517 /* Fake up an import/unimport */
3518 if (arg && arg->op_type == OP_STUB) {
3520 op_getmad(arg,pegop,'S');
3521 imop = arg; /* no import on explicit () */
3523 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3524 imop = NULL; /* use 5.0; */
3526 idop->op_private |= OPpCONST_NOVER;
3532 op_getmad(arg,pegop,'A');
3534 /* Make copy of idop so we don't free it twice */
3535 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3537 /* Fake up a method call to import/unimport */
3539 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3540 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3541 append_elem(OP_LIST,
3542 prepend_elem(OP_LIST, pack, list(arg)),
3543 newSVOP(OP_METHOD_NAMED, 0, meth)));
3546 /* Fake up the BEGIN {}, which does its thing immediately. */
3548 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3551 append_elem(OP_LINESEQ,
3552 append_elem(OP_LINESEQ,
3553 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3554 newSTATEOP(0, NULL, veop)),
3555 newSTATEOP(0, NULL, imop) ));
3557 /* The "did you use incorrect case?" warning used to be here.
3558 * The problem is that on case-insensitive filesystems one
3559 * might get false positives for "use" (and "require"):
3560 * "use Strict" or "require CARP" will work. This causes
3561 * portability problems for the script: in case-strict
3562 * filesystems the script will stop working.
3564 * The "incorrect case" warning checked whether "use Foo"
3565 * imported "Foo" to your namespace, but that is wrong, too:
3566 * there is no requirement nor promise in the language that
3567 * a Foo.pm should or would contain anything in package "Foo".
3569 * There is very little Configure-wise that can be done, either:
3570 * the case-sensitivity of the build filesystem of Perl does not
3571 * help in guessing the case-sensitivity of the runtime environment.
3574 PL_hints |= HINT_BLOCK_SCOPE;
3575 PL_copline = NOLINE;
3577 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3580 if (!PL_madskills) {
3581 /* FIXME - don't allocate pegop if !PL_madskills */
3590 =head1 Embedding Functions
3592 =for apidoc load_module
3594 Loads the module whose name is pointed to by the string part of name.
3595 Note that the actual module name, not its filename, should be given.
3596 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3597 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3598 (or 0 for no flags). ver, if specified, provides version semantics
3599 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3600 arguments can be used to specify arguments to the module's import()
3601 method, similar to C<use Foo::Bar VERSION LIST>.
3606 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3609 va_start(args, ver);
3610 vload_module(flags, name, ver, &args);
3614 #ifdef PERL_IMPLICIT_CONTEXT
3616 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3620 va_start(args, ver);
3621 vload_module(flags, name, ver, &args);
3627 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3632 OP * const modname = newSVOP(OP_CONST, 0, name);
3633 modname->op_private |= OPpCONST_BARE;
3635 veop = newSVOP(OP_CONST, 0, ver);
3639 if (flags & PERL_LOADMOD_NOIMPORT) {
3640 imop = sawparens(newNULLLIST());
3642 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3643 imop = va_arg(*args, OP*);
3648 sv = va_arg(*args, SV*);
3650 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3651 sv = va_arg(*args, SV*);
3655 const line_t ocopline = PL_copline;
3656 COP * const ocurcop = PL_curcop;
3657 const int oexpect = PL_expect;
3659 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3660 veop, modname, imop);
3661 PL_expect = oexpect;
3662 PL_copline = ocopline;
3663 PL_curcop = ocurcop;
3668 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3674 if (!force_builtin) {
3675 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3676 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3677 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3678 gv = gvp ? *gvp : NULL;
3682 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3683 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3684 append_elem(OP_LIST, term,
3685 scalar(newUNOP(OP_RV2CV, 0,
3686 newGVOP(OP_GV, 0, gv))))));
3689 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3695 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3697 return newBINOP(OP_LSLICE, flags,
3698 list(force_list(subscript)),
3699 list(force_list(listval)) );
3703 S_is_list_assignment(pTHX_ register const OP *o)
3708 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3709 o = cUNOPo->op_first;
3711 if (o->op_type == OP_COND_EXPR) {
3712 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3713 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3718 yyerror("Assignment to both a list and a scalar");
3722 if (o->op_type == OP_LIST &&
3723 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3724 o->op_private & OPpLVAL_INTRO)
3727 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3728 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3729 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3732 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3735 if (o->op_type == OP_RV2SV)
3742 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3748 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3749 return newLOGOP(optype, 0,
3750 mod(scalar(left), optype),
3751 newUNOP(OP_SASSIGN, 0, scalar(right)));
3754 return newBINOP(optype, OPf_STACKED,
3755 mod(scalar(left), optype), scalar(right));
3759 if (is_list_assignment(left)) {
3763 /* Grandfathering $[ assignment here. Bletch.*/
3764 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3765 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3766 left = mod(left, OP_AASSIGN);
3769 else if (left->op_type == OP_CONST) {
3771 /* Result of assignment is always 1 (or we'd be dead already) */
3772 return newSVOP(OP_CONST, 0, newSViv(1));
3774 curop = list(force_list(left));
3775 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3776 o->op_private = (U8)(0 | (flags >> 8));
3778 /* PL_generation sorcery:
3779 * an assignment like ($a,$b) = ($c,$d) is easier than
3780 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3781 * To detect whether there are common vars, the global var
3782 * PL_generation is incremented for each assign op we compile.
3783 * Then, while compiling the assign op, we run through all the
3784 * variables on both sides of the assignment, setting a spare slot
3785 * in each of them to PL_generation. If any of them already have
3786 * that value, we know we've got commonality. We could use a
3787 * single bit marker, but then we'd have to make 2 passes, first
3788 * to clear the flag, then to test and set it. To find somewhere
3789 * to store these values, evil chicanery is done with SvCUR().
3792 if (!(left->op_private & OPpLVAL_INTRO)) {
3795 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3796 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3797 if (curop->op_type == OP_GV) {
3798 GV *gv = cGVOPx_gv(curop);
3800 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3802 GvASSIGN_GENERATION_set(gv, PL_generation);
3804 else if (curop->op_type == OP_PADSV ||
3805 curop->op_type == OP_PADAV ||
3806 curop->op_type == OP_PADHV ||
3807 curop->op_type == OP_PADANY)
3809 if (PAD_COMPNAME_GEN(curop->op_targ)
3810 == (STRLEN)PL_generation)
3812 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3815 else if (curop->op_type == OP_RV2CV)
3817 else if (curop->op_type == OP_RV2SV ||
3818 curop->op_type == OP_RV2AV ||
3819 curop->op_type == OP_RV2HV ||
3820 curop->op_type == OP_RV2GV) {
3821 if (lastop->op_type != OP_GV) /* funny deref? */
3824 else if (curop->op_type == OP_PUSHRE) {
3825 if (((PMOP*)curop)->op_pmreplroot) {
3827 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3828 ((PMOP*)curop)->op_pmreplroot));
3830 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3833 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3835 GvASSIGN_GENERATION_set(gv, PL_generation);
3836 GvASSIGN_GENERATION_set(gv, PL_generation);
3845 o->op_private |= OPpASSIGN_COMMON;
3847 if (right && right->op_type == OP_SPLIT) {
3849 if ((tmpop = ((LISTOP*)right)->op_first) &&
3850 tmpop->op_type == OP_PUSHRE)
3852 PMOP * const pm = (PMOP*)tmpop;
3853 if (left->op_type == OP_RV2AV &&
3854 !(left->op_private & OPpLVAL_INTRO) &&
3855 !(o->op_private & OPpASSIGN_COMMON) )
3857 tmpop = ((UNOP*)left)->op_first;
3858 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3860 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3861 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3863 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3864 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3866 pm->op_pmflags |= PMf_ONCE;
3867 tmpop = cUNOPo->op_first; /* to list (nulled) */
3868 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3869 tmpop->op_sibling = NULL; /* don't free split */
3870 right->op_next = tmpop->op_next; /* fix starting loc */
3872 op_getmad(o,right,'R'); /* blow off assign */
3874 op_free(o); /* blow off assign */
3876 right->op_flags &= ~OPf_WANT;
3877 /* "I don't know and I don't care." */
3882 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3883 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3885 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3887 sv_setiv(sv, PL_modcount+1);
3895 right = newOP(OP_UNDEF, 0);
3896 if (right->op_type == OP_READLINE) {
3897 right->op_flags |= OPf_STACKED;
3898 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3901 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3902 o = newBINOP(OP_SASSIGN, flags,
3903 scalar(right), mod(scalar(left), OP_SASSIGN) );
3909 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3910 o->op_private |= OPpCONST_ARYBASE;
3917 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3920 const U32 seq = intro_my();
3923 NewOp(1101, cop, 1, COP);
3924 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3925 cop->op_type = OP_DBSTATE;
3926 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3929 cop->op_type = OP_NEXTSTATE;
3930 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3932 cop->op_flags = (U8)flags;
3933 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3935 cop->op_private |= NATIVE_HINTS;
3937 PL_compiling.op_private = cop->op_private;
3938 cop->op_next = (OP*)cop;
3941 cop->cop_label = label;
3942 PL_hints |= HINT_BLOCK_SCOPE;
3945 cop->cop_arybase = PL_curcop->cop_arybase;
3946 if (specialWARN(PL_curcop->cop_warnings))
3947 cop->cop_warnings = PL_curcop->cop_warnings ;
3949 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3950 if (specialCopIO(PL_curcop->cop_io))
3951 cop->cop_io = PL_curcop->cop_io;
3953 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3954 cop->cop_hints = PL_curcop->cop_hints;
3955 if (cop->cop_hints) {
3956 cop->cop_hints->refcounted_he_refcnt++;
3959 if (PL_copline == NOLINE)
3960 CopLINE_set(cop, CopLINE(PL_curcop));
3962 CopLINE_set(cop, PL_copline);
3963 PL_copline = NOLINE;
3966 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3968 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3970 CopSTASH_set(cop, PL_curstash);
3972 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3973 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3974 if (svp && *svp != &PL_sv_undef ) {
3975 (void)SvIOK_on(*svp);
3976 SvIV_set(*svp, PTR2IV(cop));
3980 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3985 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3988 return new_logop(type, flags, &first, &other);
3992 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3997 OP *first = *firstp;
3998 OP * const other = *otherp;
4000 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4001 return newBINOP(type, flags, scalar(first), scalar(other));
4003 scalarboolean(first);
4004 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4005 if (first->op_type == OP_NOT
4006 && (first->op_flags & OPf_SPECIAL)
4007 && (first->op_flags & OPf_KIDS)) {
4008 if (type == OP_AND || type == OP_OR) {
4014 first = *firstp = cUNOPo->op_first;
4016 first->op_next = o->op_next;
4017 cUNOPo->op_first = NULL;
4019 op_getmad(o,first,'O');
4025 if (first->op_type == OP_CONST) {
4026 if (first->op_private & OPpCONST_STRICT)
4027 no_bareword_allowed(first);
4028 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4029 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4030 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4031 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4032 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4034 if (other->op_type == OP_CONST)
4035 other->op_private |= OPpCONST_SHORTCIRCUIT;
4037 OP *newop = newUNOP(OP_NULL, 0, other);
4038 op_getmad(first, newop, '1');
4039 newop->op_targ = type; /* set "was" field */
4046 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4047 const OP *o2 = other;
4048 if ( ! (o2->op_type == OP_LIST
4049 && (( o2 = cUNOPx(o2)->op_first))
4050 && o2->op_type == OP_PUSHMARK
4051 && (( o2 = o2->op_sibling)) )
4054 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4055 || o2->op_type == OP_PADHV)
4056 && o2->op_private & OPpLVAL_INTRO
4057 && ckWARN(WARN_DEPRECATED))
4059 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4060 "Deprecated use of my() in false conditional");
4064 if (first->op_type == OP_CONST)
4065 first->op_private |= OPpCONST_SHORTCIRCUIT;
4067 first = newUNOP(OP_NULL, 0, first);
4068 op_getmad(other, first, '2');
4069 first->op_targ = type; /* set "was" field */
4076 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4077 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4079 const OP * const k1 = ((UNOP*)first)->op_first;
4080 const OP * const k2 = k1->op_sibling;
4082 switch (first->op_type)
4085 if (k2 && k2->op_type == OP_READLINE
4086 && (k2->op_flags & OPf_STACKED)
4087 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4089 warnop = k2->op_type;
4094 if (k1->op_type == OP_READDIR
4095 || k1->op_type == OP_GLOB
4096 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4097 || k1->op_type == OP_EACH)
4099 warnop = ((k1->op_type == OP_NULL)
4100 ? (OPCODE)k1->op_targ : k1->op_type);
4105 const line_t oldline = CopLINE(PL_curcop);
4106 CopLINE_set(PL_curcop, PL_copline);
4107 Perl_warner(aTHX_ packWARN(WARN_MISC),
4108 "Value of %s%s can be \"0\"; test with defined()",
4110 ((warnop == OP_READLINE || warnop == OP_GLOB)
4111 ? " construct" : "() operator"));
4112 CopLINE_set(PL_curcop, oldline);
4119 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4120 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4122 NewOp(1101, logop, 1, LOGOP);
4124 logop->op_type = (OPCODE)type;
4125 logop->op_ppaddr = PL_ppaddr[type];
4126 logop->op_first = first;
4127 logop->op_flags = (U8)(flags | OPf_KIDS);
4128 logop->op_other = LINKLIST(other);
4129 logop->op_private = (U8)(1 | (flags >> 8));
4131 /* establish postfix order */
4132 logop->op_next = LINKLIST(first);
4133 first->op_next = (OP*)logop;
4134 first->op_sibling = other;
4136 CHECKOP(type,logop);
4138 o = newUNOP(OP_NULL, 0, (OP*)logop);
4145 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4153 return newLOGOP(OP_AND, 0, first, trueop);
4155 return newLOGOP(OP_OR, 0, first, falseop);
4157 scalarboolean(first);
4158 if (first->op_type == OP_CONST) {
4159 if (first->op_private & OPpCONST_BARE &&
4160 first->op_private & OPpCONST_STRICT) {
4161 no_bareword_allowed(first);
4163 if (SvTRUE(((SVOP*)first)->op_sv)) {
4166 trueop = newUNOP(OP_NULL, 0, trueop);
4167 op_getmad(first,trueop,'C');
4168 op_getmad(falseop,trueop,'e');
4170 /* FIXME for MAD - should there be an ELSE here? */
4180 falseop = newUNOP(OP_NULL, 0, falseop);
4181 op_getmad(first,falseop,'C');
4182 op_getmad(trueop,falseop,'t');
4184 /* FIXME for MAD - should there be an ELSE here? */
4192 NewOp(1101, logop, 1, LOGOP);
4193 logop->op_type = OP_COND_EXPR;
4194 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4195 logop->op_first = first;
4196 logop->op_flags = (U8)(flags | OPf_KIDS);
4197 logop->op_private = (U8)(1 | (flags >> 8));
4198 logop->op_other = LINKLIST(trueop);
4199 logop->op_next = LINKLIST(falseop);
4201 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4204 /* establish postfix order */
4205 start = LINKLIST(first);
4206 first->op_next = (OP*)logop;
4208 first->op_sibling = trueop;
4209 trueop->op_sibling = falseop;
4210 o = newUNOP(OP_NULL, 0, (OP*)logop);
4212 trueop->op_next = falseop->op_next = o;
4219 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4228 NewOp(1101, range, 1, LOGOP);
4230 range->op_type = OP_RANGE;
4231 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4232 range->op_first = left;
4233 range->op_flags = OPf_KIDS;
4234 leftstart = LINKLIST(left);
4235 range->op_other = LINKLIST(right);
4236 range->op_private = (U8)(1 | (flags >> 8));
4238 left->op_sibling = right;
4240 range->op_next = (OP*)range;
4241 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4242 flop = newUNOP(OP_FLOP, 0, flip);
4243 o = newUNOP(OP_NULL, 0, flop);
4245 range->op_next = leftstart;
4247 left->op_next = flip;
4248 right->op_next = flop;
4250 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4251 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4252 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4253 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4255 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4256 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4259 if (!flip->op_private || !flop->op_private)
4260 linklist(o); /* blow off optimizer unless constant */
4266 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4271 const bool once = block && block->op_flags & OPf_SPECIAL &&
4272 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4274 PERL_UNUSED_ARG(debuggable);
4277 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4278 return block; /* do {} while 0 does once */
4279 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4280 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4281 expr = newUNOP(OP_DEFINED, 0,
4282 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4283 } else if (expr->op_flags & OPf_KIDS) {
4284 const OP * const k1 = ((UNOP*)expr)->op_first;
4285 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4286 switch (expr->op_type) {
4288 if (k2 && k2->op_type == OP_READLINE
4289 && (k2->op_flags & OPf_STACKED)
4290 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4291 expr = newUNOP(OP_DEFINED, 0, expr);
4295 if (k1 && (k1->op_type == OP_READDIR
4296 || k1->op_type == OP_GLOB
4297 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4298 || k1->op_type == OP_EACH))
4299 expr = newUNOP(OP_DEFINED, 0, expr);
4305 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4306 * op, in listop. This is wrong. [perl #27024] */
4308 block = newOP(OP_NULL, 0);
4309 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4310 o = new_logop(OP_AND, 0, &expr, &listop);
4313 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4315 if (once && o != listop)
4316 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4319 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4321 o->op_flags |= flags;
4323 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4328 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4329 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4338 PERL_UNUSED_ARG(debuggable);
4341 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4342 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4343 expr = newUNOP(OP_DEFINED, 0,
4344 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4345 } else if (expr->op_flags & OPf_KIDS) {
4346 const OP * const k1 = ((UNOP*)expr)->op_first;
4347 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4348 switch (expr->op_type) {
4350 if (k2 && k2->op_type == OP_READLINE
4351 && (k2->op_flags & OPf_STACKED)
4352 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4353 expr = newUNOP(OP_DEFINED, 0, expr);
4357 if (k1 && (k1->op_type == OP_READDIR
4358 || k1->op_type == OP_GLOB
4359 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4360 || k1->op_type == OP_EACH))
4361 expr = newUNOP(OP_DEFINED, 0, expr);
4368 block = newOP(OP_NULL, 0);
4369 else if (cont || has_my) {
4370 block = scope(block);
4374 next = LINKLIST(cont);
4377 OP * const unstack = newOP(OP_UNSTACK, 0);
4380 cont = append_elem(OP_LINESEQ, cont, unstack);
4383 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4384 redo = LINKLIST(listop);
4387 PL_copline = (line_t)whileline;
4389 o = new_logop(OP_AND, 0, &expr, &listop);
4390 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4391 op_free(expr); /* oops, it's a while (0) */
4393 return NULL; /* listop already freed by new_logop */
4396 ((LISTOP*)listop)->op_last->op_next =
4397 (o == listop ? redo : LINKLIST(o));
4403 NewOp(1101,loop,1,LOOP);
4404 loop->op_type = OP_ENTERLOOP;
4405 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4406 loop->op_private = 0;
4407 loop->op_next = (OP*)loop;
4410 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4412 loop->op_redoop = redo;
4413 loop->op_lastop = o;
4414 o->op_private |= loopflags;
4417 loop->op_nextop = next;
4419 loop->op_nextop = o;
4421 o->op_flags |= flags;
4422 o->op_private |= (flags >> 8);
4427 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4432 PADOFFSET padoff = 0;
4438 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4439 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4440 sv->op_type = OP_RV2GV;
4441 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4442 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4443 iterpflags |= OPpITER_DEF;
4445 else if (sv->op_type == OP_PADSV) { /* private variable */
4446 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4447 padoff = sv->op_targ;
4456 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4457 padoff = sv->op_targ;
4462 iterflags |= OPf_SPECIAL;
4468 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4469 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4470 iterpflags |= OPpITER_DEF;
4473 const I32 offset = pad_findmy("$_");
4474 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4475 sv = newGVOP(OP_GV, 0, PL_defgv);
4480 iterpflags |= OPpITER_DEF;
4482 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4483 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4484 iterflags |= OPf_STACKED;
4486 else if (expr->op_type == OP_NULL &&
4487 (expr->op_flags & OPf_KIDS) &&
4488 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4490 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4491 * set the STACKED flag to indicate that these values are to be
4492 * treated as min/max values by 'pp_iterinit'.
4494 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4495 LOGOP* const range = (LOGOP*) flip->op_first;
4496 OP* const left = range->op_first;
4497 OP* const right = left->op_sibling;
4500 range->op_flags &= ~OPf_KIDS;
4501 range->op_first = NULL;
4503 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4504 listop->op_first->op_next = range->op_next;
4505 left->op_next = range->op_other;
4506 right->op_next = (OP*)listop;
4507 listop->op_next = listop->op_first;
4510 op_getmad(expr,(OP*)listop,'O');
4514 expr = (OP*)(listop);
4516 iterflags |= OPf_STACKED;
4519 expr = mod(force_list(expr), OP_GREPSTART);
4522 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4523 append_elem(OP_LIST, expr, scalar(sv))));
4524 assert(!loop->op_next);
4525 /* for my $x () sets OPpLVAL_INTRO;
4526 * for our $x () sets OPpOUR_INTRO */
4527 loop->op_private = (U8)iterpflags;
4528 #ifdef PL_OP_SLAB_ALLOC
4531 NewOp(1234,tmp,1,LOOP);
4532 Copy(loop,tmp,1,LISTOP);
4537 Renew(loop, 1, LOOP);
4539 loop->op_targ = padoff;
4540 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4542 op_getmad(madsv, (OP*)loop, 'v');
4543 PL_copline = forline;
4544 return newSTATEOP(0, label, wop);
4548 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4553 if (type != OP_GOTO || label->op_type == OP_CONST) {
4554 /* "last()" means "last" */
4555 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4556 o = newOP(type, OPf_SPECIAL);
4558 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4559 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4563 op_getmad(label,o,'L');
4569 /* Check whether it's going to be a goto &function */
4570 if (label->op_type == OP_ENTERSUB
4571 && !(label->op_flags & OPf_STACKED))
4572 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4573 o = newUNOP(type, OPf_STACKED, label);
4575 PL_hints |= HINT_BLOCK_SCOPE;
4579 /* if the condition is a literal array or hash
4580 (or @{ ... } etc), make a reference to it.
4583 S_ref_array_or_hash(pTHX_ OP *cond)
4586 && (cond->op_type == OP_RV2AV
4587 || cond->op_type == OP_PADAV
4588 || cond->op_type == OP_RV2HV
4589 || cond->op_type == OP_PADHV))
4591 return newUNOP(OP_REFGEN,
4592 0, mod(cond, OP_REFGEN));
4598 /* These construct the optree fragments representing given()
4601 entergiven and enterwhen are LOGOPs; the op_other pointer
4602 points up to the associated leave op. We need this so we
4603 can put it in the context and make break/continue work.
4604 (Also, of course, pp_enterwhen will jump straight to
4605 op_other if the match fails.)
4610 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4611 I32 enter_opcode, I32 leave_opcode,
4612 PADOFFSET entertarg)
4618 NewOp(1101, enterop, 1, LOGOP);
4619 enterop->op_type = enter_opcode;
4620 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4621 enterop->op_flags = (U8) OPf_KIDS;
4622 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4623 enterop->op_private = 0;
4625 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4628 enterop->op_first = scalar(cond);
4629 cond->op_sibling = block;
4631 o->op_next = LINKLIST(cond);
4632 cond->op_next = (OP *) enterop;
4635 /* This is a default {} block */
4636 enterop->op_first = block;
4637 enterop->op_flags |= OPf_SPECIAL;
4639 o->op_next = (OP *) enterop;
4642 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4643 entergiven and enterwhen both
4646 enterop->op_next = LINKLIST(block);
4647 block->op_next = enterop->op_other = o;
4652 /* Does this look like a boolean operation? For these purposes
4653 a boolean operation is:
4654 - a subroutine call [*]
4655 - a logical connective
4656 - a comparison operator
4657 - a filetest operator, with the exception of -s -M -A -C
4658 - defined(), exists() or eof()
4659 - /$re/ or $foo =~ /$re/
4661 [*] possibly surprising
4665 S_looks_like_bool(pTHX_ const OP *o)
4668 switch(o->op_type) {
4670 return looks_like_bool(cLOGOPo->op_first);
4674 looks_like_bool(cLOGOPo->op_first)
4675 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4679 case OP_NOT: case OP_XOR:
4680 /* Note that OP_DOR is not here */
4682 case OP_EQ: case OP_NE: case OP_LT:
4683 case OP_GT: case OP_LE: case OP_GE:
4685 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4686 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4688 case OP_SEQ: case OP_SNE: case OP_SLT:
4689 case OP_SGT: case OP_SLE: case OP_SGE:
4693 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4694 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4695 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4696 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4697 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4698 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4699 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4700 case OP_FTTEXT: case OP_FTBINARY:
4702 case OP_DEFINED: case OP_EXISTS:
4703 case OP_MATCH: case OP_EOF:
4708 /* Detect comparisons that have been optimized away */
4709 if (cSVOPo->op_sv == &PL_sv_yes
4710 || cSVOPo->op_sv == &PL_sv_no)
4721 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4725 return newGIVWHENOP(
4726 ref_array_or_hash(cond),
4728 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4732 /* If cond is null, this is a default {} block */
4734 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4736 const bool cond_llb = (!cond || looks_like_bool(cond));
4742 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4744 scalar(ref_array_or_hash(cond)));
4747 return newGIVWHENOP(
4749 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4750 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4754 =for apidoc cv_undef
4756 Clear out all the active components of a CV. This can happen either
4757 by an explicit C<undef &foo>, or by the reference count going to zero.
4758 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4759 children can still follow the full lexical scope chain.
4765 Perl_cv_undef(pTHX_ CV *cv)
4769 if (CvFILE(cv) && !CvISXSUB(cv)) {
4770 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4771 Safefree(CvFILE(cv));
4776 if (!CvISXSUB(cv) && CvROOT(cv)) {
4777 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4778 Perl_croak(aTHX_ "Can't undef active subroutine");
4781 PAD_SAVE_SETNULLPAD();
4783 op_free(CvROOT(cv));
4788 SvPOK_off((SV*)cv); /* forget prototype */
4793 /* remove CvOUTSIDE unless this is an undef rather than a free */
4794 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4795 if (!CvWEAKOUTSIDE(cv))
4796 SvREFCNT_dec(CvOUTSIDE(cv));
4797 CvOUTSIDE(cv) = NULL;
4800 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4803 if (CvISXSUB(cv) && CvXSUB(cv)) {
4806 /* delete all flags except WEAKOUTSIDE */
4807 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4811 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4813 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4814 SV* const msg = sv_newmortal();
4818 gv_efullname3(name = sv_newmortal(), gv, NULL);
4819 sv_setpv(msg, "Prototype mismatch:");
4821 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4823 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4825 sv_catpvs(msg, ": none");
4826 sv_catpvs(msg, " vs ");
4828 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4830 sv_catpvs(msg, "none");
4831 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4835 static void const_sv_xsub(pTHX_ CV* cv);
4839 =head1 Optree Manipulation Functions
4841 =for apidoc cv_const_sv
4843 If C<cv> is a constant sub eligible for inlining. returns the constant
4844 value returned by the sub. Otherwise, returns NULL.
4846 Constant subs can be created with C<newCONSTSUB> or as described in
4847 L<perlsub/"Constant Functions">.
4852 Perl_cv_const_sv(pTHX_ CV *cv)
4854 PERL_UNUSED_CONTEXT;
4857 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4859 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4862 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4863 * Can be called in 3 ways:
4866 * look for a single OP_CONST with attached value: return the value
4868 * cv && CvCLONE(cv) && !CvCONST(cv)
4870 * examine the clone prototype, and if contains only a single
4871 * OP_CONST referencing a pad const, or a single PADSV referencing
4872 * an outer lexical, return a non-zero value to indicate the CV is
4873 * a candidate for "constizing" at clone time
4877 * We have just cloned an anon prototype that was marked as a const
4878 * candidiate. Try to grab the current value, and in the case of
4879 * PADSV, ignore it if it has multiple references. Return the value.
4883 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4891 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4892 o = cLISTOPo->op_first->op_sibling;
4894 for (; o; o = o->op_next) {
4895 const OPCODE type = o->op_type;
4897 if (sv && o->op_next == o)
4899 if (o->op_next != o) {
4900 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4902 if (type == OP_DBSTATE)
4905 if (type == OP_LEAVESUB || type == OP_RETURN)
4909 if (type == OP_CONST && cSVOPo->op_sv)
4911 else if (cv && type == OP_CONST) {
4912 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4916 else if (cv && type == OP_PADSV) {
4917 if (CvCONST(cv)) { /* newly cloned anon */
4918 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4919 /* the candidate should have 1 ref from this pad and 1 ref
4920 * from the parent */
4921 if (!sv || SvREFCNT(sv) != 2)
4928 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4929 sv = &PL_sv_undef; /* an arbitrary non-null value */
4944 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4947 /* This would be the return value, but the return cannot be reached. */
4948 OP* pegop = newOP(OP_NULL, 0);
4951 PERL_UNUSED_ARG(floor);
4961 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4963 NORETURN_FUNCTION_END;
4968 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4970 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4974 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4981 register CV *cv = NULL;
4983 /* If the subroutine has no body, no attributes, and no builtin attributes
4984 then it's just a sub declaration, and we may be able to get away with
4985 storing with a placeholder scalar in the symbol table, rather than a
4986 full GV and CV. If anything is present then it will take a full CV to
4988 const I32 gv_fetch_flags
4989 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4991 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4992 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4995 assert(proto->op_type == OP_CONST);
4996 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5001 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5002 SV * const sv = sv_newmortal();
5003 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5004 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5005 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5006 aname = SvPVX_const(sv);
5011 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5012 : gv_fetchpv(aname ? aname
5013 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5014 gv_fetch_flags, SVt_PVCV);
5016 if (!PL_madskills) {
5025 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5026 maximum a prototype before. */
5027 if (SvTYPE(gv) > SVt_NULL) {
5028 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5029 && ckWARN_d(WARN_PROTOTYPE))
5031 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5033 cv_ckproto((CV*)gv, NULL, ps);
5036 sv_setpvn((SV*)gv, ps, ps_len);
5038 sv_setiv((SV*)gv, -1);
5039 SvREFCNT_dec(PL_compcv);
5040 cv = PL_compcv = NULL;
5041 PL_sub_generation++;
5045 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5047 #ifdef GV_UNIQUE_CHECK
5048 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5049 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5053 if (!block || !ps || *ps || attrs
5054 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5056 || block->op_type == OP_NULL
5061 const_sv = op_const_sv(block, NULL);
5064 const bool exists = CvROOT(cv) || CvXSUB(cv);
5066 #ifdef GV_UNIQUE_CHECK
5067 if (exists && GvUNIQUE(gv)) {
5068 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5072 /* if the subroutine doesn't exist and wasn't pre-declared
5073 * with a prototype, assume it will be AUTOLOADed,
5074 * skipping the prototype check
5076 if (exists || SvPOK(cv))
5077 cv_ckproto(cv, gv, ps);
5078 /* already defined (or promised)? */
5079 if (exists || GvASSUMECV(gv)) {
5082 || block->op_type == OP_NULL
5085 if (CvFLAGS(PL_compcv)) {
5086 /* might have had built-in attrs applied */
5087 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5089 /* just a "sub foo;" when &foo is already defined */
5090 SAVEFREESV(PL_compcv);
5095 && block->op_type != OP_NULL
5098 if (ckWARN(WARN_REDEFINE)
5100 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5102 const line_t oldline = CopLINE(PL_curcop);
5103 if (PL_copline != NOLINE)
5104 CopLINE_set(PL_curcop, PL_copline);
5105 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5106 CvCONST(cv) ? "Constant subroutine %s redefined"
5107 : "Subroutine %s redefined", name);
5108 CopLINE_set(PL_curcop, oldline);
5111 if (!PL_minus_c) /* keep old one around for madskills */
5114 /* (PL_madskills unset in used file.) */
5122 SvREFCNT_inc_void_NN(const_sv);
5124 assert(!CvROOT(cv) && !CvCONST(cv));
5125 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5126 CvXSUBANY(cv).any_ptr = const_sv;
5127 CvXSUB(cv) = const_sv_xsub;
5133 cv = newCONSTSUB(NULL, name, const_sv);
5135 PL_sub_generation++;
5139 SvREFCNT_dec(PL_compcv);
5147 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5148 * before we clobber PL_compcv.
5152 || block->op_type == OP_NULL
5156 /* Might have had built-in attributes applied -- propagate them. */
5157 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5158 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5159 stash = GvSTASH(CvGV(cv));
5160 else if (CvSTASH(cv))
5161 stash = CvSTASH(cv);
5163 stash = PL_curstash;
5166 /* possibly about to re-define existing subr -- ignore old cv */
5167 rcv = (SV*)PL_compcv;
5168 if (name && GvSTASH(gv))
5169 stash = GvSTASH(gv);
5171 stash = PL_curstash;
5173 apply_attrs(stash, rcv, attrs, FALSE);
5175 if (cv) { /* must reuse cv if autoloaded */
5182 || block->op_type == OP_NULL) && !PL_madskills
5185 /* got here with just attrs -- work done, so bug out */
5186 SAVEFREESV(PL_compcv);
5189 /* transfer PL_compcv to cv */
5191 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5192 if (!CvWEAKOUTSIDE(cv))
5193 SvREFCNT_dec(CvOUTSIDE(cv));
5194 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5195 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5196 CvOUTSIDE(PL_compcv) = 0;
5197 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5198 CvPADLIST(PL_compcv) = 0;
5199 /* inner references to PL_compcv must be fixed up ... */
5200 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5201 /* ... before we throw it away */
5202 SvREFCNT_dec(PL_compcv);
5204 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5205 ++PL_sub_generation;
5212 if (strEQ(name, "import")) {
5213 PL_formfeed = (SV*)cv;
5214 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5218 PL_sub_generation++;
5222 CvFILE_set_from_cop(cv, PL_curcop);
5223 CvSTASH(cv) = PL_curstash;
5226 sv_setpvn((SV*)cv, ps, ps_len);
5228 if (PL_error_count) {
5232 const char *s = strrchr(name, ':');
5234 if (strEQ(s, "BEGIN")) {
5235 const char not_safe[] =
5236 "BEGIN not safe after errors--compilation aborted";
5237 if (PL_in_eval & EVAL_KEEPERR)
5238 Perl_croak(aTHX_ not_safe);
5240 /* force display of errors found but not reported */
5241 sv_catpv(ERRSV, not_safe);
5242 Perl_croak(aTHX_ "%"SVf, ERRSV);
5252 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5253 mod(scalarseq(block), OP_LEAVESUBLV));
5256 /* This makes sub {}; work as expected. */
5257 if (block->op_type == OP_STUB) {
5258 OP* newblock = newSTATEOP(0, NULL, 0);
5260 op_getmad(block,newblock,'B');
5266 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5268 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5269 OpREFCNT_set(CvROOT(cv), 1);
5270 CvSTART(cv) = LINKLIST(CvROOT(cv));
5271 CvROOT(cv)->op_next = 0;
5272 CALL_PEEP(CvSTART(cv));
5274 /* now that optimizer has done its work, adjust pad values */
5276 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5279 assert(!CvCONST(cv));
5280 if (ps && !*ps && op_const_sv(block, cv))
5284 if (name || aname) {
5286 const char * const tname = (name ? name : aname);
5288 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5289 SV * const sv = newSV(0);
5290 SV * const tmpstr = sv_newmortal();
5291 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5292 GV_ADDMULTI, SVt_PVHV);
5295 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5297 (long)PL_subline, (long)CopLINE(PL_curcop));
5298 gv_efullname3(tmpstr, gv, NULL);
5299 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5300 hv = GvHVn(db_postponed);
5301 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5302 CV * const pcv = GvCV(db_postponed);
5308 call_sv((SV*)pcv, G_DISCARD);
5313 if ((s = strrchr(tname,':')))
5318 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5321 if (strEQ(s, "BEGIN") && !PL_error_count) {
5322 const I32 oldscope = PL_scopestack_ix;
5324 SAVECOPFILE(&PL_compiling);
5325 SAVECOPLINE(&PL_compiling);
5328 PL_beginav = newAV();
5329 DEBUG_x( dump_sub(gv) );
5330 av_push(PL_beginav, (SV*)cv);
5331 GvCV(gv) = 0; /* cv has been hijacked */
5332 call_list(oldscope, PL_beginav);
5334 PL_curcop = &PL_compiling;
5335 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5338 else if (strEQ(s, "END") && !PL_error_count) {
5341 DEBUG_x( dump_sub(gv) );
5342 av_unshift(PL_endav, 1);
5343 av_store(PL_endav, 0, (SV*)cv);
5344 GvCV(gv) = 0; /* cv has been hijacked */
5346 else if (strEQ(s, "CHECK") && !PL_error_count) {
5348 PL_checkav = newAV();
5349 DEBUG_x( dump_sub(gv) );
5350 if (PL_main_start && ckWARN(WARN_VOID))
5351 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5352 av_unshift(PL_checkav, 1);
5353 av_store(PL_checkav, 0, (SV*)cv);
5354 GvCV(gv) = 0; /* cv has been hijacked */
5356 else if (strEQ(s, "INIT") && !PL_error_count) {
5358 PL_initav = newAV();
5359 DEBUG_x( dump_sub(gv) );
5360 if (PL_main_start && ckWARN(WARN_VOID))
5361 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5362 av_push(PL_initav, (SV*)cv);
5363 GvCV(gv) = 0; /* cv has been hijacked */
5368 PL_copline = NOLINE;
5373 /* XXX unsafe for threads if eval_owner isn't held */
5375 =for apidoc newCONSTSUB
5377 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5378 eligible for inlining at compile-time.
5384 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5391 SAVECOPLINE(PL_curcop);
5392 CopLINE_set(PL_curcop, PL_copline);
5395 PL_hints &= ~HINT_BLOCK_SCOPE;
5398 SAVESPTR(PL_curstash);
5399 SAVECOPSTASH(PL_curcop);
5400 PL_curstash = stash;
5401 CopSTASH_set(PL_curcop,stash);
5404 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
5405 CvXSUBANY(cv).any_ptr = sv;
5407 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5411 CopSTASH_free(PL_curcop);
5419 =for apidoc U||newXS
5421 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5427 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5430 GV * const gv = gv_fetchpv(name ? name :
5431 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5432 GV_ADDMULTI, SVt_PVCV);
5436 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5438 if ((cv = (name ? GvCV(gv) : NULL))) {
5440 /* just a cached method */
5444 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5445 /* already defined (or promised) */
5446 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5447 if (ckWARN(WARN_REDEFINE)) {
5448 GV * const gvcv = CvGV(cv);
5450 HV * const stash = GvSTASH(gvcv);
5452 const char *redefined_name = HvNAME_get(stash);
5453 if ( strEQ(redefined_name,"autouse") ) {
5454 const line_t oldline = CopLINE(PL_curcop);
5455 if (PL_copline != NOLINE)
5456 CopLINE_set(PL_curcop, PL_copline);
5457 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5458 CvCONST(cv) ? "Constant subroutine %s redefined"
5459 : "Subroutine %s redefined"
5461 CopLINE_set(PL_curcop, oldline);
5471 if (cv) /* must reuse cv if autoloaded */
5475 sv_upgrade((SV *)cv, SVt_PVCV);
5479 PL_sub_generation++;
5483 (void)gv_fetchfile(filename);
5484 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5485 an external constant string */
5487 CvXSUB(cv) = subaddr;
5490 const char *s = strrchr(name,':');
5496 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5499 if (strEQ(s, "BEGIN")) {
5501 PL_beginav = newAV();
5502 av_push(PL_beginav, (SV*)cv);
5503 GvCV(gv) = 0; /* cv has been hijacked */
5505 else if (strEQ(s, "END")) {
5508 av_unshift(PL_endav, 1);
5509 av_store(PL_endav, 0, (SV*)cv);
5510 GvCV(gv) = 0; /* cv has been hijacked */
5512 else if (strEQ(s, "CHECK")) {
5514 PL_checkav = newAV();
5515 if (PL_main_start && ckWARN(WARN_VOID))
5516 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5517 av_unshift(PL_checkav, 1);
5518 av_store(PL_checkav, 0, (SV*)cv);
5519 GvCV(gv) = 0; /* cv has been hijacked */
5521 else if (strEQ(s, "INIT")) {
5523 PL_initav = newAV();
5524 if (PL_main_start && ckWARN(WARN_VOID))
5525 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5526 av_push(PL_initav, (SV*)cv);
5527 GvCV(gv) = 0; /* cv has been hijacked */
5542 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5547 OP* pegop = newOP(OP_NULL, 0);
5551 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5552 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5554 #ifdef GV_UNIQUE_CHECK
5556 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5560 if ((cv = GvFORM(gv))) {
5561 if (ckWARN(WARN_REDEFINE)) {
5562 const line_t oldline = CopLINE(PL_curcop);
5563 if (PL_copline != NOLINE)
5564 CopLINE_set(PL_curcop, PL_copline);
5565 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5566 o ? "Format %"SVf" redefined"
5567 : "Format STDOUT redefined" ,cSVOPo->op_sv);
5568 CopLINE_set(PL_curcop, oldline);
5575 CvFILE_set_from_cop(cv, PL_curcop);
5578 pad_tidy(padtidy_FORMAT);
5579 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5580 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5581 OpREFCNT_set(CvROOT(cv), 1);
5582 CvSTART(cv) = LINKLIST(CvROOT(cv));
5583 CvROOT(cv)->op_next = 0;
5584 CALL_PEEP(CvSTART(cv));
5586 op_getmad(o,pegop,'n');
5587 op_getmad_weak(block, pegop, 'b');
5591 PL_copline = NOLINE;
5599 Perl_newANONLIST(pTHX_ OP *o)
5601 return newUNOP(OP_REFGEN, 0,
5602 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5606 Perl_newANONHASH(pTHX_ OP *o)
5608 return newUNOP(OP_REFGEN, 0,
5609 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5613 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5615 return newANONATTRSUB(floor, proto, NULL, block);
5619 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5621 return newUNOP(OP_REFGEN, 0,
5622 newSVOP(OP_ANONCODE, 0,
5623 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5627 Perl_oopsAV(pTHX_ OP *o)
5630 switch (o->op_type) {
5632 o->op_type = OP_PADAV;
5633 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5634 return ref(o, OP_RV2AV);
5637 o->op_type = OP_RV2AV;
5638 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5643 if (ckWARN_d(WARN_INTERNAL))
5644 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5651 Perl_oopsHV(pTHX_ OP *o)
5654 switch (o->op_type) {
5657 o->op_type = OP_PADHV;
5658 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5659 return ref(o, OP_RV2HV);
5663 o->op_type = OP_RV2HV;
5664 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5669 if (ckWARN_d(WARN_INTERNAL))
5670 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5677 Perl_newAVREF(pTHX_ OP *o)
5680 if (o->op_type == OP_PADANY) {
5681 o->op_type = OP_PADAV;
5682 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5685 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5686 && ckWARN(WARN_DEPRECATED)) {
5687 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5688 "Using an array as a reference is deprecated");
5690 return newUNOP(OP_RV2AV, 0, scalar(o));
5694 Perl_newGVREF(pTHX_ I32 type, OP *o)
5696 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5697 return newUNOP(OP_NULL, 0, o);
5698 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5702 Perl_newHVREF(pTHX_ OP *o)
5705 if (o->op_type == OP_PADANY) {
5706 o->op_type = OP_PADHV;
5707 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5710 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5711 && ckWARN(WARN_DEPRECATED)) {
5712 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5713 "Using a hash as a reference is deprecated");
5715 return newUNOP(OP_RV2HV, 0, scalar(o));
5719 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5721 return newUNOP(OP_RV2CV, flags, scalar(o));
5725 Perl_newSVREF(pTHX_ OP *o)
5728 if (o->op_type == OP_PADANY) {
5729 o->op_type = OP_PADSV;
5730 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5733 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5734 o->op_flags |= OPpDONE_SVREF;
5737 return newUNOP(OP_RV2SV, 0, scalar(o));
5740 /* Check routines. See the comments at the top of this file for details
5741 * on when these are called */
5744 Perl_ck_anoncode(pTHX_ OP *o)
5746 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5748 cSVOPo->op_sv = NULL;
5753 Perl_ck_bitop(pTHX_ OP *o)
5756 #define OP_IS_NUMCOMPARE(op) \
5757 ((op) == OP_LT || (op) == OP_I_LT || \
5758 (op) == OP_GT || (op) == OP_I_GT || \
5759 (op) == OP_LE || (op) == OP_I_LE || \
5760 (op) == OP_GE || (op) == OP_I_GE || \
5761 (op) == OP_EQ || (op) == OP_I_EQ || \
5762 (op) == OP_NE || (op) == OP_I_NE || \
5763 (op) == OP_NCMP || (op) == OP_I_NCMP)
5764 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5765 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5766 && (o->op_type == OP_BIT_OR
5767 || o->op_type == OP_BIT_AND
5768 || o->op_type == OP_BIT_XOR))
5770 const OP * const left = cBINOPo->op_first;
5771 const OP * const right = left->op_sibling;
5772 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5773 (left->op_flags & OPf_PARENS) == 0) ||
5774 (OP_IS_NUMCOMPARE(right->op_type) &&
5775 (right->op_flags & OPf_PARENS) == 0))
5776 if (ckWARN(WARN_PRECEDENCE))
5777 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5778 "Possible precedence problem on bitwise %c operator",
5779 o->op_type == OP_BIT_OR ? '|'
5780 : o->op_type == OP_BIT_AND ? '&' : '^'
5787 Perl_ck_concat(pTHX_ OP *o)
5789 const OP * const kid = cUNOPo->op_first;
5790 PERL_UNUSED_CONTEXT;
5791 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5792 !(kUNOP->op_first->op_flags & OPf_MOD))
5793 o->op_flags |= OPf_STACKED;
5798 Perl_ck_spair(pTHX_ OP *o)
5801 if (o->op_flags & OPf_KIDS) {
5804 const OPCODE type = o->op_type;
5805 o = modkids(ck_fun(o), type);
5806 kid = cUNOPo->op_first;
5807 newop = kUNOP->op_first->op_sibling;
5809 (newop->op_sibling ||
5810 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5811 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5812 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5817 op_getmad(kUNOP->op_first,newop,'K');
5819 op_free(kUNOP->op_first);
5821 kUNOP->op_first = newop;
5823 o->op_ppaddr = PL_ppaddr[++o->op_type];
5828 Perl_ck_delete(pTHX_ OP *o)
5832 if (o->op_flags & OPf_KIDS) {
5833 OP * const kid = cUNOPo->op_first;
5834 switch (kid->op_type) {
5836 o->op_flags |= OPf_SPECIAL;
5839 o->op_private |= OPpSLICE;
5842 o->op_flags |= OPf_SPECIAL;
5847 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5856 Perl_ck_die(pTHX_ OP *o)
5859 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5865 Perl_ck_eof(pTHX_ OP *o)
5869 if (o->op_flags & OPf_KIDS) {
5870 if (cLISTOPo->op_first->op_type == OP_STUB) {
5872 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5874 op_getmad(o,newop,'O');
5886 Perl_ck_eval(pTHX_ OP *o)
5889 PL_hints |= HINT_BLOCK_SCOPE;
5890 if (o->op_flags & OPf_KIDS) {
5891 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5894 o->op_flags &= ~OPf_KIDS;
5897 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5903 cUNOPo->op_first = 0;
5908 NewOp(1101, enter, 1, LOGOP);
5909 enter->op_type = OP_ENTERTRY;
5910 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5911 enter->op_private = 0;
5913 /* establish postfix order */
5914 enter->op_next = (OP*)enter;
5916 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5917 o->op_type = OP_LEAVETRY;
5918 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5919 enter->op_other = o;
5920 op_getmad(oldo,o,'O');
5934 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5935 op_getmad(oldo,o,'O');
5937 o->op_targ = (PADOFFSET)PL_hints;
5938 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5939 /* Store a copy of %^H that pp_entereval can pick up */
5940 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5941 cUNOPo->op_first->op_sibling = hhop;
5942 o->op_private |= OPpEVAL_HAS_HH;
5948 Perl_ck_exit(pTHX_ OP *o)
5951 HV * const table = GvHV(PL_hintgv);
5953 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5954 if (svp && *svp && SvTRUE(*svp))
5955 o->op_private |= OPpEXIT_VMSISH;
5957 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5963 Perl_ck_exec(pTHX_ OP *o)
5965 if (o->op_flags & OPf_STACKED) {
5968 kid = cUNOPo->op_first->op_sibling;
5969 if (kid->op_type == OP_RV2GV)
5978 Perl_ck_exists(pTHX_ OP *o)
5982 if (o->op_flags & OPf_KIDS) {
5983 OP * const kid = cUNOPo->op_first;
5984 if (kid->op_type == OP_ENTERSUB) {
5985 (void) ref(kid, o->op_type);
5986 if (kid->op_type != OP_RV2CV && !PL_error_count)
5987 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5989 o->op_private |= OPpEXISTS_SUB;
5991 else if (kid->op_type == OP_AELEM)
5992 o->op_flags |= OPf_SPECIAL;
5993 else if (kid->op_type != OP_HELEM)
5994 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6002 Perl_ck_rvconst(pTHX_ register OP *o)
6005 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6007 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6008 if (o->op_type == OP_RV2CV)
6009 o->op_private &= ~1;
6011 if (kid->op_type == OP_CONST) {
6014 SV * const kidsv = kid->op_sv;
6016 /* Is it a constant from cv_const_sv()? */
6017 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6018 SV * const rsv = SvRV(kidsv);
6019 const int svtype = SvTYPE(rsv);
6020 const char *badtype = NULL;
6022 switch (o->op_type) {
6024 if (svtype > SVt_PVMG)
6025 badtype = "a SCALAR";
6028 if (svtype != SVt_PVAV)
6029 badtype = "an ARRAY";
6032 if (svtype != SVt_PVHV)
6036 if (svtype != SVt_PVCV)
6041 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6044 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6045 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6046 /* If this is an access to a stash, disable "strict refs", because
6047 * stashes aren't auto-vivified at compile-time (unless we store
6048 * symbols in them), and we don't want to produce a run-time
6049 * stricture error when auto-vivifying the stash. */
6050 const char *s = SvPV_nolen(kidsv);
6051 const STRLEN l = SvCUR(kidsv);
6052 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6053 o->op_private &= ~HINT_STRICT_REFS;
6055 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6056 const char *badthing;
6057 switch (o->op_type) {
6059 badthing = "a SCALAR";
6062 badthing = "an ARRAY";
6065 badthing = "a HASH";
6073 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6077 * This is a little tricky. We only want to add the symbol if we
6078 * didn't add it in the lexer. Otherwise we get duplicate strict
6079 * warnings. But if we didn't add it in the lexer, we must at
6080 * least pretend like we wanted to add it even if it existed before,
6081 * or we get possible typo warnings. OPpCONST_ENTERED says
6082 * whether the lexer already added THIS instance of this symbol.
6084 iscv = (o->op_type == OP_RV2CV) * 2;
6086 gv = gv_fetchsv(kidsv,
6087 iscv | !(kid->op_private & OPpCONST_ENTERED),
6090 : o->op_type == OP_RV2SV
6092 : o->op_type == OP_RV2AV
6094 : o->op_type == OP_RV2HV
6097 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6099 kid->op_type = OP_GV;
6100 SvREFCNT_dec(kid->op_sv);
6102 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6103 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6104 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6106 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6108 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6110 kid->op_private = 0;
6111 kid->op_ppaddr = PL_ppaddr[OP_GV];
6118 Perl_ck_ftst(pTHX_ OP *o)
6121 const I32 type = o->op_type;
6123 if (o->op_flags & OPf_REF) {
6126 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6127 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6129 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6130 OP * const newop = newGVOP(type, OPf_REF,
6131 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6133 op_getmad(o,newop,'O');
6139 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6140 o->op_private |= OPpFT_ACCESS;
6141 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
6142 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
6143 o->op_private |= OPpFT_STACKED;
6151 if (type == OP_FTTTY)
6152 o = newGVOP(type, OPf_REF, PL_stdingv);
6154 o = newUNOP(type, 0, newDEFSVOP());
6155 op_getmad(oldo,o,'O');
6161 Perl_ck_fun(pTHX_ OP *o)
6164 const int type = o->op_type;
6165 register I32 oa = PL_opargs[type] >> OASHIFT;
6167 if (o->op_flags & OPf_STACKED) {
6168 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6171 return no_fh_allowed(o);
6174 if (o->op_flags & OPf_KIDS) {
6175 OP **tokid = &cLISTOPo->op_first;
6176 register OP *kid = cLISTOPo->op_first;
6180 if (kid->op_type == OP_PUSHMARK ||
6181 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6183 tokid = &kid->op_sibling;
6184 kid = kid->op_sibling;
6186 if (!kid && PL_opargs[type] & OA_DEFGV)
6187 *tokid = kid = newDEFSVOP();
6191 sibl = kid->op_sibling;
6193 if (!sibl && kid->op_type == OP_STUB) {
6200 /* list seen where single (scalar) arg expected? */
6201 if (numargs == 1 && !(oa >> 4)
6202 && kid->op_type == OP_LIST && type != OP_SCALAR)
6204 return too_many_arguments(o,PL_op_desc[type]);
6217 if ((type == OP_PUSH || type == OP_UNSHIFT)
6218 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6219 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6220 "Useless use of %s with no values",
6223 if (kid->op_type == OP_CONST &&
6224 (kid->op_private & OPpCONST_BARE))
6226 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6227 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6228 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6229 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6230 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6231 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6233 op_getmad(kid,newop,'K');
6238 kid->op_sibling = sibl;
6241 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6242 bad_type(numargs, "array", PL_op_desc[type], kid);
6246 if (kid->op_type == OP_CONST &&
6247 (kid->op_private & OPpCONST_BARE))
6249 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6250 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6251 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6252 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6253 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6254 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6256 op_getmad(kid,newop,'K');
6261 kid->op_sibling = sibl;
6264 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6265 bad_type(numargs, "hash", PL_op_desc[type], kid);
6270 OP * const newop = newUNOP(OP_NULL, 0, kid);
6271 kid->op_sibling = 0;
6273 newop->op_next = newop;
6275 kid->op_sibling = sibl;
6280 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6281 if (kid->op_type == OP_CONST &&
6282 (kid->op_private & OPpCONST_BARE))
6284 OP * const newop = newGVOP(OP_GV, 0,
6285 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6286 if (!(o->op_private & 1) && /* if not unop */
6287 kid == cLISTOPo->op_last)
6288 cLISTOPo->op_last = newop;
6290 op_getmad(kid,newop,'K');
6296 else if (kid->op_type == OP_READLINE) {
6297 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6298 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6301 I32 flags = OPf_SPECIAL;
6305 /* is this op a FH constructor? */
6306 if (is_handle_constructor(o,numargs)) {
6307 const char *name = NULL;
6311 /* Set a flag to tell rv2gv to vivify
6312 * need to "prove" flag does not mean something
6313 * else already - NI-S 1999/05/07
6316 if (kid->op_type == OP_PADSV) {
6317 name = PAD_COMPNAME_PV(kid->op_targ);
6318 /* SvCUR of a pad namesv can't be trusted
6319 * (see PL_generation), so calc its length
6325 else if (kid->op_type == OP_RV2SV
6326 && kUNOP->op_first->op_type == OP_GV)
6328 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6330 len = GvNAMELEN(gv);
6332 else if (kid->op_type == OP_AELEM
6333 || kid->op_type == OP_HELEM)
6335 OP *op = ((BINOP*)kid)->op_first;
6339 const char * const a =
6340 kid->op_type == OP_AELEM ?
6342 if (((op->op_type == OP_RV2AV) ||
6343 (op->op_type == OP_RV2HV)) &&
6344 (op = ((UNOP*)op)->op_first) &&
6345 (op->op_type == OP_GV)) {
6346 /* packagevar $a[] or $h{} */
6347 GV * const gv = cGVOPx_gv(op);
6355 else if (op->op_type == OP_PADAV
6356 || op->op_type == OP_PADHV) {
6357 /* lexicalvar $a[] or $h{} */
6358 const char * const padname =
6359 PAD_COMPNAME_PV(op->op_targ);
6368 name = SvPV_const(tmpstr, len);
6373 name = "__ANONIO__";
6380 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6381 namesv = PAD_SVl(targ);
6382 SvUPGRADE(namesv, SVt_PV);
6384 sv_setpvn(namesv, "$", 1);
6385 sv_catpvn(namesv, name, len);
6388 kid->op_sibling = 0;
6389 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6390 kid->op_targ = targ;
6391 kid->op_private |= priv;
6393 kid->op_sibling = sibl;
6399 mod(scalar(kid), type);
6403 tokid = &kid->op_sibling;
6404 kid = kid->op_sibling;
6407 if (kid && kid->op_type != OP_STUB)
6408 return too_many_arguments(o,OP_DESC(o));
6409 o->op_private |= numargs;
6411 /* FIXME - should the numargs move as for the PERL_MAD case? */
6412 o->op_private |= numargs;
6414 return too_many_arguments(o,OP_DESC(o));
6418 else if (PL_opargs[type] & OA_DEFGV) {
6420 OP *newop = newUNOP(type, 0, newDEFSVOP());
6421 op_getmad(o,newop,'O');
6424 /* Ordering of these two is important to keep f_map.t passing. */
6426 return newUNOP(type, 0, newDEFSVOP());
6431 while (oa & OA_OPTIONAL)
6433 if (oa && oa != OA_LIST)
6434 return too_few_arguments(o,OP_DESC(o));
6440 Perl_ck_glob(pTHX_ OP *o)
6446 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6447 append_elem(OP_GLOB, o, newDEFSVOP());
6449 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6450 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6452 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6455 #if !defined(PERL_EXTERNAL_GLOB)
6456 /* XXX this can be tightened up and made more failsafe. */
6457 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6460 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6461 newSVpvs("File::Glob"), NULL, NULL, NULL);
6462 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6463 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6464 GvCV(gv) = GvCV(glob_gv);
6465 SvREFCNT_inc_void((SV*)GvCV(gv));
6466 GvIMPORTED_CV_on(gv);
6469 #endif /* PERL_EXTERNAL_GLOB */
6471 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6472 append_elem(OP_GLOB, o,
6473 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6474 o->op_type = OP_LIST;
6475 o->op_ppaddr = PL_ppaddr[OP_LIST];
6476 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6477 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6478 cLISTOPo->op_first->op_targ = 0;
6479 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6480 append_elem(OP_LIST, o,
6481 scalar(newUNOP(OP_RV2CV, 0,
6482 newGVOP(OP_GV, 0, gv)))));
6483 o = newUNOP(OP_NULL, 0, ck_subr(o));
6484 o->op_targ = OP_GLOB; /* hint at what it used to be */
6487 gv = newGVgen("main");
6489 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6495 Perl_ck_grep(pTHX_ OP *o)
6500 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6503 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6504 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6506 if (o->op_flags & OPf_STACKED) {
6509 kid = cLISTOPo->op_first->op_sibling;
6510 if (!cUNOPx(kid)->op_next)
6511 Perl_croak(aTHX_ "panic: ck_grep");
6512 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6515 NewOp(1101, gwop, 1, LOGOP);
6516 kid->op_next = (OP*)gwop;
6517 o->op_flags &= ~OPf_STACKED;
6519 kid = cLISTOPo->op_first->op_sibling;
6520 if (type == OP_MAPWHILE)
6527 kid = cLISTOPo->op_first->op_sibling;
6528 if (kid->op_type != OP_NULL)
6529 Perl_croak(aTHX_ "panic: ck_grep");
6530 kid = kUNOP->op_first;
6533 NewOp(1101, gwop, 1, LOGOP);
6534 gwop->op_type = type;
6535 gwop->op_ppaddr = PL_ppaddr[type];
6536 gwop->op_first = listkids(o);
6537 gwop->op_flags |= OPf_KIDS;
6538 gwop->op_other = LINKLIST(kid);
6539 kid->op_next = (OP*)gwop;
6540 offset = pad_findmy("$_");
6541 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6542 o->op_private = gwop->op_private = 0;
6543 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6546 o->op_private = gwop->op_private = OPpGREP_LEX;
6547 gwop->op_targ = o->op_targ = offset;
6550 kid = cLISTOPo->op_first->op_sibling;
6551 if (!kid || !kid->op_sibling)
6552 return too_few_arguments(o,OP_DESC(o));
6553 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6554 mod(kid, OP_GREPSTART);
6560 Perl_ck_index(pTHX_ OP *o)
6562 if (o->op_flags & OPf_KIDS) {
6563 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6565 kid = kid->op_sibling; /* get past "big" */
6566 if (kid && kid->op_type == OP_CONST)
6567 fbm_compile(((SVOP*)kid)->op_sv, 0);
6573 Perl_ck_lengthconst(pTHX_ OP *o)
6575 /* XXX length optimization goes here */
6580 Perl_ck_lfun(pTHX_ OP *o)
6582 const OPCODE type = o->op_type;
6583 return modkids(ck_fun(o), type);
6587 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6589 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6590 switch (cUNOPo->op_first->op_type) {
6592 /* This is needed for
6593 if (defined %stash::)
6594 to work. Do not break Tk.
6596 break; /* Globals via GV can be undef */
6598 case OP_AASSIGN: /* Is this a good idea? */
6599 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6600 "defined(@array) is deprecated");
6601 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6602 "\t(Maybe you should just omit the defined()?)\n");
6605 /* This is needed for
6606 if (defined %stash::)
6607 to work. Do not break Tk.
6609 break; /* Globals via GV can be undef */
6611 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6612 "defined(%%hash) is deprecated");
6613 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6614 "\t(Maybe you should just omit the defined()?)\n");
6625 Perl_ck_rfun(pTHX_ OP *o)
6627 const OPCODE type = o->op_type;
6628 return refkids(ck_fun(o), type);
6632 Perl_ck_listiob(pTHX_ OP *o)
6636 kid = cLISTOPo->op_first;
6639 kid = cLISTOPo->op_first;
6641 if (kid->op_type == OP_PUSHMARK)
6642 kid = kid->op_sibling;
6643 if (kid && o->op_flags & OPf_STACKED)
6644 kid = kid->op_sibling;
6645 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6646 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6647 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6648 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6649 cLISTOPo->op_first->op_sibling = kid;
6650 cLISTOPo->op_last = kid;
6651 kid = kid->op_sibling;
6656 append_elem(o->op_type, o, newDEFSVOP());
6662 Perl_ck_say(pTHX_ OP *o)
6665 o->op_type = OP_PRINT;
6666 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6667 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6672 Perl_ck_smartmatch(pTHX_ OP *o)
6675 if (0 == (o->op_flags & OPf_SPECIAL)) {
6676 OP *first = cBINOPo->op_first;
6677 OP *second = first->op_sibling;
6679 /* Implicitly take a reference to an array or hash */
6680 first->op_sibling = NULL;
6681 first = cBINOPo->op_first = ref_array_or_hash(first);
6682 second = first->op_sibling = ref_array_or_hash(second);
6684 /* Implicitly take a reference to a regular expression */
6685 if (first->op_type == OP_MATCH) {
6686 first->op_type = OP_QR;
6687 first->op_ppaddr = PL_ppaddr[OP_QR];
6689 if (second->op_type == OP_MATCH) {
6690 second->op_type = OP_QR;
6691 second->op_ppaddr = PL_ppaddr[OP_QR];
6700 Perl_ck_sassign(pTHX_ OP *o)
6702 OP *kid = cLISTOPo->op_first;
6703 /* has a disposable target? */
6704 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6705 && !(kid->op_flags & OPf_STACKED)
6706 /* Cannot steal the second time! */
6707 && !(kid->op_private & OPpTARGET_MY))
6709 OP * const kkid = kid->op_sibling;
6711 /* Can just relocate the target. */
6712 if (kkid && kkid->op_type == OP_PADSV
6713 && !(kkid->op_private & OPpLVAL_INTRO))
6715 kid->op_targ = kkid->op_targ;
6717 /* Now we do not need PADSV and SASSIGN. */
6718 kid->op_sibling = o->op_sibling; /* NULL */
6719 cLISTOPo->op_first = NULL;
6721 op_getmad(o,kid,'O');
6722 op_getmad(kkid,kid,'M');
6727 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6735 Perl_ck_match(pTHX_ OP *o)
6738 if (o->op_type != OP_QR && PL_compcv) {
6739 const I32 offset = pad_findmy("$_");
6740 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6741 o->op_targ = offset;
6742 o->op_private |= OPpTARGET_MY;
6745 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6746 o->op_private |= OPpRUNTIME;
6751 Perl_ck_method(pTHX_ OP *o)
6753 OP * const kid = cUNOPo->op_first;
6754 if (kid->op_type == OP_CONST) {
6755 SV* sv = kSVOP->op_sv;
6756 const char * const method = SvPVX_const(sv);
6757 if (!(strchr(method, ':') || strchr(method, '\''))) {
6759 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6760 sv = newSVpvn_share(method, SvCUR(sv), 0);
6763 kSVOP->op_sv = NULL;
6765 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6767 op_getmad(o,cmop,'O');
6778 Perl_ck_null(pTHX_ OP *o)
6780 PERL_UNUSED_CONTEXT;
6785 Perl_ck_open(pTHX_ OP *o)
6788 HV * const table = GvHV(PL_hintgv);
6790 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6792 const I32 mode = mode_from_discipline(*svp);
6793 if (mode & O_BINARY)
6794 o->op_private |= OPpOPEN_IN_RAW;
6795 else if (mode & O_TEXT)
6796 o->op_private |= OPpOPEN_IN_CRLF;
6799 svp = hv_fetchs(table, "open_OUT", FALSE);
6801 const I32 mode = mode_from_discipline(*svp);
6802 if (mode & O_BINARY)
6803 o->op_private |= OPpOPEN_OUT_RAW;
6804 else if (mode & O_TEXT)
6805 o->op_private |= OPpOPEN_OUT_CRLF;
6808 if (o->op_type == OP_BACKTICK)
6811 /* In case of three-arg dup open remove strictness
6812 * from the last arg if it is a bareword. */
6813 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6814 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6818 if ((last->op_type == OP_CONST) && /* The bareword. */
6819 (last->op_private & OPpCONST_BARE) &&
6820 (last->op_private & OPpCONST_STRICT) &&
6821 (oa = first->op_sibling) && /* The fh. */
6822 (oa = oa->op_sibling) && /* The mode. */
6823 (oa->op_type == OP_CONST) &&
6824 SvPOK(((SVOP*)oa)->op_sv) &&
6825 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6826 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6827 (last == oa->op_sibling)) /* The bareword. */
6828 last->op_private &= ~OPpCONST_STRICT;
6834 Perl_ck_repeat(pTHX_ OP *o)
6836 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6837 o->op_private |= OPpREPEAT_DOLIST;
6838 cBINOPo->op_first = force_list(cBINOPo->op_first);
6846 Perl_ck_require(pTHX_ OP *o)
6851 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6852 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6854 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6855 SV * const sv = kid->op_sv;
6856 U32 was_readonly = SvREADONLY(sv);
6861 sv_force_normal_flags(sv, 0);
6862 assert(!SvREADONLY(sv));
6869 for (s = SvPVX(sv); *s; s++) {
6870 if (*s == ':' && s[1] == ':') {
6871 const STRLEN len = strlen(s+2)+1;
6873 Move(s+2, s+1, len, char);
6874 SvCUR_set(sv, SvCUR(sv) - 1);
6877 sv_catpvs(sv, ".pm");
6878 SvFLAGS(sv) |= was_readonly;
6882 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6883 /* handle override, if any */
6884 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6885 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6886 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6887 gv = gvp ? *gvp : NULL;
6891 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6892 OP * const kid = cUNOPo->op_first;
6895 cUNOPo->op_first = 0;
6899 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6900 append_elem(OP_LIST, kid,
6901 scalar(newUNOP(OP_RV2CV, 0,
6904 op_getmad(o,newop,'O');
6912 Perl_ck_return(pTHX_ OP *o)
6915 if (CvLVALUE(PL_compcv)) {
6917 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6918 mod(kid, OP_LEAVESUBLV);
6924 Perl_ck_select(pTHX_ OP *o)
6928 if (o->op_flags & OPf_KIDS) {
6929 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6930 if (kid && kid->op_sibling) {
6931 o->op_type = OP_SSELECT;
6932 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6934 return fold_constants(o);
6938 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6939 if (kid && kid->op_type == OP_RV2GV)
6940 kid->op_private &= ~HINT_STRICT_REFS;
6945 Perl_ck_shift(pTHX_ OP *o)
6948 const I32 type = o->op_type;
6950 if (!(o->op_flags & OPf_KIDS)) {
6952 /* FIXME - this can be refactored to reduce code in #ifdefs */
6954 OP * const oldo = o;
6958 argop = newUNOP(OP_RV2AV, 0,
6959 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6961 o = newUNOP(type, 0, scalar(argop));
6962 op_getmad(oldo,o,'O');
6965 return newUNOP(type, 0, scalar(argop));
6968 return scalar(modkids(ck_fun(o), type));
6972 Perl_ck_sort(pTHX_ OP *o)
6977 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6979 HV * const hinthv = GvHV(PL_hintgv);
6981 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6983 const I32 sorthints = (I32)SvIV(*svp);
6984 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6985 o->op_private |= OPpSORT_QSORT;
6986 if ((sorthints & HINT_SORT_STABLE) != 0)
6987 o->op_private |= OPpSORT_STABLE;
6992 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6994 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6995 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6997 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6999 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7001 if (kid->op_type == OP_SCOPE) {
7005 else if (kid->op_type == OP_LEAVE) {
7006 if (o->op_type == OP_SORT) {
7007 op_null(kid); /* wipe out leave */
7010 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7011 if (k->op_next == kid)
7013 /* don't descend into loops */
7014 else if (k->op_type == OP_ENTERLOOP
7015 || k->op_type == OP_ENTERITER)
7017 k = cLOOPx(k)->op_lastop;
7022 kid->op_next = 0; /* just disconnect the leave */
7023 k = kLISTOP->op_first;
7028 if (o->op_type == OP_SORT) {
7029 /* provide scalar context for comparison function/block */
7035 o->op_flags |= OPf_SPECIAL;
7037 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7040 firstkid = firstkid->op_sibling;
7043 /* provide list context for arguments */
7044 if (o->op_type == OP_SORT)
7051 S_simplify_sort(pTHX_ OP *o)
7054 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7059 if (!(o->op_flags & OPf_STACKED))
7061 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7062 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7063 kid = kUNOP->op_first; /* get past null */
7064 if (kid->op_type != OP_SCOPE)
7066 kid = kLISTOP->op_last; /* get past scope */
7067 switch(kid->op_type) {
7075 k = kid; /* remember this node*/
7076 if (kBINOP->op_first->op_type != OP_RV2SV)
7078 kid = kBINOP->op_first; /* get past cmp */
7079 if (kUNOP->op_first->op_type != OP_GV)
7081 kid = kUNOP->op_first; /* get past rv2sv */
7083 if (GvSTASH(gv) != PL_curstash)
7085 gvname = GvNAME(gv);
7086 if (*gvname == 'a' && gvname[1] == '\0')
7088 else if (*gvname == 'b' && gvname[1] == '\0')
7093 kid = k; /* back to cmp */
7094 if (kBINOP->op_last->op_type != OP_RV2SV)
7096 kid = kBINOP->op_last; /* down to 2nd arg */
7097 if (kUNOP->op_first->op_type != OP_GV)
7099 kid = kUNOP->op_first; /* get past rv2sv */
7101 if (GvSTASH(gv) != PL_curstash)
7103 gvname = GvNAME(gv);
7105 ? !(*gvname == 'a' && gvname[1] == '\0')
7106 : !(*gvname == 'b' && gvname[1] == '\0'))
7108 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7110 o->op_private |= OPpSORT_DESCEND;
7111 if (k->op_type == OP_NCMP)
7112 o->op_private |= OPpSORT_NUMERIC;
7113 if (k->op_type == OP_I_NCMP)
7114 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7115 kid = cLISTOPo->op_first->op_sibling;
7116 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7118 op_getmad(kid,o,'S'); /* then delete it */
7120 op_free(kid); /* then delete it */
7125 Perl_ck_split(pTHX_ OP *o)
7130 if (o->op_flags & OPf_STACKED)
7131 return no_fh_allowed(o);
7133 kid = cLISTOPo->op_first;
7134 if (kid->op_type != OP_NULL)
7135 Perl_croak(aTHX_ "panic: ck_split");
7136 kid = kid->op_sibling;
7137 op_free(cLISTOPo->op_first);
7138 cLISTOPo->op_first = kid;
7140 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7141 cLISTOPo->op_last = kid; /* There was only one element previously */
7144 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7145 OP * const sibl = kid->op_sibling;
7146 kid->op_sibling = 0;
7147 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7148 if (cLISTOPo->op_first == cLISTOPo->op_last)
7149 cLISTOPo->op_last = kid;
7150 cLISTOPo->op_first = kid;
7151 kid->op_sibling = sibl;
7154 kid->op_type = OP_PUSHRE;
7155 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7157 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7158 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7159 "Use of /g modifier is meaningless in split");
7162 if (!kid->op_sibling)
7163 append_elem(OP_SPLIT, o, newDEFSVOP());
7165 kid = kid->op_sibling;
7168 if (!kid->op_sibling)
7169 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7171 kid = kid->op_sibling;
7174 if (kid->op_sibling)
7175 return too_many_arguments(o,OP_DESC(o));
7181 Perl_ck_join(pTHX_ OP *o)
7183 const OP * const kid = cLISTOPo->op_first->op_sibling;
7184 if (kid && kid->op_type == OP_MATCH) {
7185 if (ckWARN(WARN_SYNTAX)) {
7186 const REGEXP *re = PM_GETRE(kPMOP);
7187 const char *pmstr = re ? re->precomp : "STRING";
7188 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7189 "/%s/ should probably be written as \"%s\"",
7197 Perl_ck_subr(pTHX_ OP *o)
7200 OP *prev = ((cUNOPo->op_first->op_sibling)
7201 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7202 OP *o2 = prev->op_sibling;
7209 I32 contextclass = 0;
7213 o->op_private |= OPpENTERSUB_HASTARG;
7214 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7215 if (cvop->op_type == OP_RV2CV) {
7217 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7218 op_null(cvop); /* disable rv2cv */
7219 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7220 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7221 GV *gv = cGVOPx_gv(tmpop);
7224 tmpop->op_private |= OPpEARLY_CV;
7227 namegv = CvANON(cv) ? gv : CvGV(cv);
7228 proto = SvPV_nolen((SV*)cv);
7230 if (CvASSERTION(cv)) {
7231 if (PL_hints & HINT_ASSERTING) {
7232 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7233 o->op_private |= OPpENTERSUB_DB;
7237 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7238 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7239 "Impossible to activate assertion call");
7246 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7247 if (o2->op_type == OP_CONST)
7248 o2->op_private &= ~OPpCONST_STRICT;
7249 else if (o2->op_type == OP_LIST) {
7250 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7251 if (sib && sib->op_type == OP_CONST)
7252 sib->op_private &= ~OPpCONST_STRICT;
7255 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7256 if (PERLDB_SUB && PL_curstash != PL_debstash)
7257 o->op_private |= OPpENTERSUB_DB;
7258 while (o2 != cvop) {
7260 if (PL_madskills && o2->op_type == OP_NULL)
7261 o3 = ((UNOP*)o2)->op_first;
7267 return too_many_arguments(o, gv_ename(namegv));
7285 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7287 arg == 1 ? "block or sub {}" : "sub {}",
7288 gv_ename(namegv), o3);
7291 /* '*' allows any scalar type, including bareword */
7294 if (o3->op_type == OP_RV2GV)
7295 goto wrapref; /* autoconvert GLOB -> GLOBref */
7296 else if (o3->op_type == OP_CONST)
7297 o3->op_private &= ~OPpCONST_STRICT;
7298 else if (o3->op_type == OP_ENTERSUB) {
7299 /* accidental subroutine, revert to bareword */
7300 OP *gvop = ((UNOP*)o3)->op_first;
7301 if (gvop && gvop->op_type == OP_NULL) {
7302 gvop = ((UNOP*)gvop)->op_first;
7304 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7307 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7308 (gvop = ((UNOP*)gvop)->op_first) &&
7309 gvop->op_type == OP_GV)
7311 GV * const gv = cGVOPx_gv(gvop);
7312 OP * const sibling = o2->op_sibling;
7313 SV * const n = newSVpvs("");
7315 OP * const oldo2 = o2;
7319 gv_fullname4(n, gv, "", FALSE);
7320 o2 = newSVOP(OP_CONST, 0, n);
7321 op_getmad(oldo2,o2,'O');
7322 prev->op_sibling = o2;
7323 o2->op_sibling = sibling;
7339 if (contextclass++ == 0) {
7340 e = strchr(proto, ']');
7341 if (!e || e == proto)
7350 /* XXX We shouldn't be modifying proto, so we can const proto */
7355 while (*--p != '[');
7356 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
7357 gv_ename(namegv), o3);
7363 if (o3->op_type == OP_RV2GV)
7366 bad_type(arg, "symbol", gv_ename(namegv), o3);
7369 if (o3->op_type == OP_ENTERSUB)
7372 bad_type(arg, "subroutine entry", gv_ename(namegv),
7376 if (o3->op_type == OP_RV2SV ||
7377 o3->op_type == OP_PADSV ||
7378 o3->op_type == OP_HELEM ||
7379 o3->op_type == OP_AELEM ||
7380 o3->op_type == OP_THREADSV)
7383 bad_type(arg, "scalar", gv_ename(namegv), o3);
7386 if (o3->op_type == OP_RV2AV ||
7387 o3->op_type == OP_PADAV)
7390 bad_type(arg, "array", gv_ename(namegv), o3);
7393 if (o3->op_type == OP_RV2HV ||
7394 o3->op_type == OP_PADHV)
7397 bad_type(arg, "hash", gv_ename(namegv), o3);
7402 OP* const sib = kid->op_sibling;
7403 kid->op_sibling = 0;
7404 o2 = newUNOP(OP_REFGEN, 0, kid);
7405 o2->op_sibling = sib;
7406 prev->op_sibling = o2;
7408 if (contextclass && e) {
7423 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7424 gv_ename(namegv), cv);
7429 mod(o2, OP_ENTERSUB);
7431 o2 = o2->op_sibling;
7433 if (proto && !optional &&
7434 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
7435 return too_few_arguments(o, gv_ename(namegv));
7438 OP * const oldo = o;
7442 o=newSVOP(OP_CONST, 0, newSViv(0));
7443 op_getmad(oldo,o,'O');
7449 Perl_ck_svconst(pTHX_ OP *o)
7451 PERL_UNUSED_CONTEXT;
7452 SvREADONLY_on(cSVOPo->op_sv);
7457 Perl_ck_chdir(pTHX_ OP *o)
7459 if (o->op_flags & OPf_KIDS) {
7460 SVOP *kid = (SVOP*)cUNOPo->op_first;
7462 if (kid && kid->op_type == OP_CONST &&
7463 (kid->op_private & OPpCONST_BARE))
7465 o->op_flags |= OPf_SPECIAL;
7466 kid->op_private &= ~OPpCONST_STRICT;
7473 Perl_ck_trunc(pTHX_ OP *o)
7475 if (o->op_flags & OPf_KIDS) {
7476 SVOP *kid = (SVOP*)cUNOPo->op_first;
7478 if (kid->op_type == OP_NULL)
7479 kid = (SVOP*)kid->op_sibling;
7480 if (kid && kid->op_type == OP_CONST &&
7481 (kid->op_private & OPpCONST_BARE))
7483 o->op_flags |= OPf_SPECIAL;
7484 kid->op_private &= ~OPpCONST_STRICT;
7491 Perl_ck_unpack(pTHX_ OP *o)
7493 OP *kid = cLISTOPo->op_first;
7494 if (kid->op_sibling) {
7495 kid = kid->op_sibling;
7496 if (!kid->op_sibling)
7497 kid->op_sibling = newDEFSVOP();
7503 Perl_ck_substr(pTHX_ OP *o)
7506 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7507 OP *kid = cLISTOPo->op_first;
7509 if (kid->op_type == OP_NULL)
7510 kid = kid->op_sibling;
7512 kid->op_flags |= OPf_MOD;
7518 /* A peephole optimizer. We visit the ops in the order they're to execute.
7519 * See the comments at the top of this file for more details about when
7520 * peep() is called */
7523 Perl_peep(pTHX_ register OP *o)
7526 register OP* oldop = NULL;
7528 if (!o || o->op_opt)
7532 SAVEVPTR(PL_curcop);
7533 for (; o; o = o->op_next) {
7537 switch (o->op_type) {
7541 PL_curcop = ((COP*)o); /* for warnings */
7546 if (cSVOPo->op_private & OPpCONST_STRICT)
7547 no_bareword_allowed(o);
7549 case OP_METHOD_NAMED:
7550 /* Relocate sv to the pad for thread safety.
7551 * Despite being a "constant", the SV is written to,
7552 * for reference counts, sv_upgrade() etc. */
7554 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7555 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7556 /* If op_sv is already a PADTMP then it is being used by
7557 * some pad, so make a copy. */
7558 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7559 SvREADONLY_on(PAD_SVl(ix));
7560 SvREFCNT_dec(cSVOPo->op_sv);
7562 else if (o->op_type == OP_CONST
7563 && cSVOPo->op_sv == &PL_sv_undef) {
7564 /* PL_sv_undef is hack - it's unsafe to store it in the
7565 AV that is the pad, because av_fetch treats values of
7566 PL_sv_undef as a "free" AV entry and will merrily
7567 replace them with a new SV, causing pad_alloc to think
7568 that this pad slot is free. (When, clearly, it is not)
7570 SvOK_off(PAD_SVl(ix));
7571 SvPADTMP_on(PAD_SVl(ix));
7572 SvREADONLY_on(PAD_SVl(ix));
7575 SvREFCNT_dec(PAD_SVl(ix));
7576 SvPADTMP_on(cSVOPo->op_sv);
7577 PAD_SETSV(ix, cSVOPo->op_sv);
7578 /* XXX I don't know how this isn't readonly already. */
7579 SvREADONLY_on(PAD_SVl(ix));
7581 cSVOPo->op_sv = NULL;
7589 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7590 if (o->op_next->op_private & OPpTARGET_MY) {
7591 if (o->op_flags & OPf_STACKED) /* chained concats */
7592 goto ignore_optimization;
7594 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7595 o->op_targ = o->op_next->op_targ;
7596 o->op_next->op_targ = 0;
7597 o->op_private |= OPpTARGET_MY;
7600 op_null(o->op_next);
7602 ignore_optimization:
7606 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7608 break; /* Scalar stub must produce undef. List stub is noop */
7612 if (o->op_targ == OP_NEXTSTATE
7613 || o->op_targ == OP_DBSTATE
7614 || o->op_targ == OP_SETSTATE)
7616 PL_curcop = ((COP*)o);
7618 /* XXX: We avoid setting op_seq here to prevent later calls
7619 to peep() from mistakenly concluding that optimisation
7620 has already occurred. This doesn't fix the real problem,
7621 though (See 20010220.007). AMS 20010719 */
7622 /* op_seq functionality is now replaced by op_opt */
7623 if (oldop && o->op_next) {
7624 oldop->op_next = o->op_next;
7632 if (oldop && o->op_next) {
7633 oldop->op_next = o->op_next;
7641 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7642 OP* const pop = (o->op_type == OP_PADAV) ?
7643 o->op_next : o->op_next->op_next;
7645 if (pop && pop->op_type == OP_CONST &&
7646 ((PL_op = pop->op_next)) &&
7647 pop->op_next->op_type == OP_AELEM &&
7648 !(pop->op_next->op_private &
7649 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7650 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7655 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7656 no_bareword_allowed(pop);
7657 if (o->op_type == OP_GV)
7658 op_null(o->op_next);
7659 op_null(pop->op_next);
7661 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7662 o->op_next = pop->op_next->op_next;
7663 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7664 o->op_private = (U8)i;
7665 if (o->op_type == OP_GV) {
7670 o->op_flags |= OPf_SPECIAL;
7671 o->op_type = OP_AELEMFAST;
7677 if (o->op_next->op_type == OP_RV2SV) {
7678 if (!(o->op_next->op_private & OPpDEREF)) {
7679 op_null(o->op_next);
7680 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7682 o->op_next = o->op_next->op_next;
7683 o->op_type = OP_GVSV;
7684 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7687 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7688 GV * const gv = cGVOPo_gv;
7689 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7690 /* XXX could check prototype here instead of just carping */
7691 SV * const sv = sv_newmortal();
7692 gv_efullname3(sv, gv, NULL);
7693 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7694 "%"SVf"() called too early to check prototype",
7698 else if (o->op_next->op_type == OP_READLINE
7699 && o->op_next->op_next->op_type == OP_CONCAT
7700 && (o->op_next->op_next->op_flags & OPf_STACKED))
7702 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7703 o->op_type = OP_RCATLINE;
7704 o->op_flags |= OPf_STACKED;
7705 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7706 op_null(o->op_next->op_next);
7707 op_null(o->op_next);
7724 while (cLOGOP->op_other->op_type == OP_NULL)
7725 cLOGOP->op_other = cLOGOP->op_other->op_next;
7726 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7732 while (cLOOP->op_redoop->op_type == OP_NULL)
7733 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7734 peep(cLOOP->op_redoop);
7735 while (cLOOP->op_nextop->op_type == OP_NULL)
7736 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7737 peep(cLOOP->op_nextop);
7738 while (cLOOP->op_lastop->op_type == OP_NULL)
7739 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7740 peep(cLOOP->op_lastop);
7747 while (cPMOP->op_pmreplstart &&
7748 cPMOP->op_pmreplstart->op_type == OP_NULL)
7749 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7750 peep(cPMOP->op_pmreplstart);
7755 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7756 && ckWARN(WARN_SYNTAX))
7758 if (o->op_next->op_sibling &&
7759 o->op_next->op_sibling->op_type != OP_EXIT &&
7760 o->op_next->op_sibling->op_type != OP_WARN &&
7761 o->op_next->op_sibling->op_type != OP_DIE) {
7762 const line_t oldline = CopLINE(PL_curcop);
7764 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7765 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7766 "Statement unlikely to be reached");
7767 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7768 "\t(Maybe you meant system() when you said exec()?)\n");
7769 CopLINE_set(PL_curcop, oldline);
7779 const char *key = NULL;
7784 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7787 /* Make the CONST have a shared SV */
7788 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7789 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7790 key = SvPV_const(sv, keylen);
7791 lexname = newSVpvn_share(key,
7792 SvUTF8(sv) ? -(I32)keylen : keylen,
7798 if ((o->op_private & (OPpLVAL_INTRO)))
7801 rop = (UNOP*)((BINOP*)o)->op_first;
7802 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7804 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7805 if (!SvPAD_TYPED(lexname))
7807 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7808 if (!fields || !GvHV(*fields))
7810 key = SvPV_const(*svp, keylen);
7811 if (!hv_fetch(GvHV(*fields), key,
7812 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7814 Perl_croak(aTHX_ "No such class field \"%s\" "
7815 "in variable %s of type %s",
7816 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7829 SVOP *first_key_op, *key_op;
7831 if ((o->op_private & (OPpLVAL_INTRO))
7832 /* I bet there's always a pushmark... */
7833 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7834 /* hmmm, no optimization if list contains only one key. */
7836 rop = (UNOP*)((LISTOP*)o)->op_last;
7837 if (rop->op_type != OP_RV2HV)
7839 if (rop->op_first->op_type == OP_PADSV)
7840 /* @$hash{qw(keys here)} */
7841 rop = (UNOP*)rop->op_first;
7843 /* @{$hash}{qw(keys here)} */
7844 if (rop->op_first->op_type == OP_SCOPE
7845 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7847 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7853 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7854 if (!SvPAD_TYPED(lexname))
7856 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7857 if (!fields || !GvHV(*fields))
7859 /* Again guessing that the pushmark can be jumped over.... */
7860 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7861 ->op_first->op_sibling;
7862 for (key_op = first_key_op; key_op;
7863 key_op = (SVOP*)key_op->op_sibling) {
7864 if (key_op->op_type != OP_CONST)
7866 svp = cSVOPx_svp(key_op);
7867 key = SvPV_const(*svp, keylen);
7868 if (!hv_fetch(GvHV(*fields), key,
7869 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7871 Perl_croak(aTHX_ "No such class field \"%s\" "
7872 "in variable %s of type %s",
7873 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7880 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7884 /* check that RHS of sort is a single plain array */
7885 OP *oright = cUNOPo->op_first;
7886 if (!oright || oright->op_type != OP_PUSHMARK)
7889 /* reverse sort ... can be optimised. */
7890 if (!cUNOPo->op_sibling) {
7891 /* Nothing follows us on the list. */
7892 OP * const reverse = o->op_next;
7894 if (reverse->op_type == OP_REVERSE &&
7895 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7896 OP * const pushmark = cUNOPx(reverse)->op_first;
7897 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7898 && (cUNOPx(pushmark)->op_sibling == o)) {
7899 /* reverse -> pushmark -> sort */
7900 o->op_private |= OPpSORT_REVERSE;
7902 pushmark->op_next = oright->op_next;
7908 /* make @a = sort @a act in-place */
7912 oright = cUNOPx(oright)->op_sibling;
7915 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7916 oright = cUNOPx(oright)->op_sibling;
7920 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7921 || oright->op_next != o
7922 || (oright->op_private & OPpLVAL_INTRO)
7926 /* o2 follows the chain of op_nexts through the LHS of the
7927 * assign (if any) to the aassign op itself */
7929 if (!o2 || o2->op_type != OP_NULL)
7932 if (!o2 || o2->op_type != OP_PUSHMARK)
7935 if (o2 && o2->op_type == OP_GV)
7938 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7939 || (o2->op_private & OPpLVAL_INTRO)
7944 if (!o2 || o2->op_type != OP_NULL)
7947 if (!o2 || o2->op_type != OP_AASSIGN
7948 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7951 /* check that the sort is the first arg on RHS of assign */
7953 o2 = cUNOPx(o2)->op_first;
7954 if (!o2 || o2->op_type != OP_NULL)
7956 o2 = cUNOPx(o2)->op_first;
7957 if (!o2 || o2->op_type != OP_PUSHMARK)
7959 if (o2->op_sibling != o)
7962 /* check the array is the same on both sides */
7963 if (oleft->op_type == OP_RV2AV) {
7964 if (oright->op_type != OP_RV2AV
7965 || !cUNOPx(oright)->op_first
7966 || cUNOPx(oright)->op_first->op_type != OP_GV
7967 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7968 cGVOPx_gv(cUNOPx(oright)->op_first)
7972 else if (oright->op_type != OP_PADAV
7973 || oright->op_targ != oleft->op_targ
7977 /* transfer MODishness etc from LHS arg to RHS arg */
7978 oright->op_flags = oleft->op_flags;
7979 o->op_private |= OPpSORT_INPLACE;
7981 /* excise push->gv->rv2av->null->aassign */
7982 o2 = o->op_next->op_next;
7983 op_null(o2); /* PUSHMARK */
7985 if (o2->op_type == OP_GV) {
7986 op_null(o2); /* GV */
7989 op_null(o2); /* RV2AV or PADAV */
7990 o2 = o2->op_next->op_next;
7991 op_null(o2); /* AASSIGN */
7993 o->op_next = o2->op_next;
7999 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8001 LISTOP *enter, *exlist;
8004 enter = (LISTOP *) o->op_next;
8007 if (enter->op_type == OP_NULL) {
8008 enter = (LISTOP *) enter->op_next;
8012 /* for $a (...) will have OP_GV then OP_RV2GV here.
8013 for (...) just has an OP_GV. */
8014 if (enter->op_type == OP_GV) {
8015 gvop = (OP *) enter;
8016 enter = (LISTOP *) enter->op_next;
8019 if (enter->op_type == OP_RV2GV) {
8020 enter = (LISTOP *) enter->op_next;
8026 if (enter->op_type != OP_ENTERITER)
8029 iter = enter->op_next;
8030 if (!iter || iter->op_type != OP_ITER)
8033 expushmark = enter->op_first;
8034 if (!expushmark || expushmark->op_type != OP_NULL
8035 || expushmark->op_targ != OP_PUSHMARK)
8038 exlist = (LISTOP *) expushmark->op_sibling;
8039 if (!exlist || exlist->op_type != OP_NULL
8040 || exlist->op_targ != OP_LIST)
8043 if (exlist->op_last != o) {
8044 /* Mmm. Was expecting to point back to this op. */
8047 theirmark = exlist->op_first;
8048 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8051 if (theirmark->op_sibling != o) {
8052 /* There's something between the mark and the reverse, eg
8053 for (1, reverse (...))
8058 ourmark = ((LISTOP *)o)->op_first;
8059 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8062 ourlast = ((LISTOP *)o)->op_last;
8063 if (!ourlast || ourlast->op_next != o)
8066 rv2av = ourmark->op_sibling;
8067 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8068 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8069 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8070 /* We're just reversing a single array. */
8071 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8072 enter->op_flags |= OPf_STACKED;
8075 /* We don't have control over who points to theirmark, so sacrifice
8077 theirmark->op_next = ourmark->op_next;
8078 theirmark->op_flags = ourmark->op_flags;
8079 ourlast->op_next = gvop ? gvop : (OP *) enter;
8082 enter->op_private |= OPpITER_REVERSED;
8083 iter->op_private |= OPpITER_REVERSED;
8090 UNOP *refgen, *rv2cv;
8093 /* I do not understand this, but if o->op_opt isn't set to 1,
8094 various tests in ext/B/t/bytecode.t fail with no readily
8100 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8103 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8106 rv2gv = ((BINOP *)o)->op_last;
8107 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8110 refgen = (UNOP *)((BINOP *)o)->op_first;
8112 if (!refgen || refgen->op_type != OP_REFGEN)
8115 exlist = (LISTOP *)refgen->op_first;
8116 if (!exlist || exlist->op_type != OP_NULL
8117 || exlist->op_targ != OP_LIST)
8120 if (exlist->op_first->op_type != OP_PUSHMARK)
8123 rv2cv = (UNOP*)exlist->op_last;
8125 if (rv2cv->op_type != OP_RV2CV)
8128 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8129 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8130 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8132 o->op_private |= OPpASSIGN_CV_TO_GV;
8133 rv2gv->op_private |= OPpDONT_INIT_GV;
8134 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8150 Perl_custom_op_name(pTHX_ const OP* o)
8153 const IV index = PTR2IV(o->op_ppaddr);
8157 if (!PL_custom_op_names) /* This probably shouldn't happen */
8158 return (char *)PL_op_name[OP_CUSTOM];
8160 keysv = sv_2mortal(newSViv(index));
8162 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8164 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8166 return SvPV_nolen(HeVAL(he));
8170 Perl_custom_op_desc(pTHX_ const OP* o)
8173 const IV index = PTR2IV(o->op_ppaddr);
8177 if (!PL_custom_op_descs)
8178 return (char *)PL_op_desc[OP_CUSTOM];
8180 keysv = sv_2mortal(newSViv(index));
8182 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8184 return (char *)PL_op_desc[OP_CUSTOM];
8186 return SvPV_nolen(HeVAL(he));
8191 /* Efficient sub that returns a constant scalar value. */
8193 const_sv_xsub(pTHX_ CV* cv)
8200 Perl_croak(aTHX_ "usage: %s::%s()",
8201 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8205 ST(0) = (SV*)XSANY.any_ptr;
8211 * c-indentation-style: bsd
8213 * indent-tabs-mode: t
8216 * ex: set ts=8 sts=4 sw=4 noet: