3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints> on the save stack, so that it
95 will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifndef PERL_SLAB_SIZE
108 #define PERL_SLAB_SIZE 2048
112 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
115 * To make incrementing use count easy PL_OpSlab is an I32 *
116 * To make inserting the link to slab PL_OpPtr is I32 **
117 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
118 * Add an overhead for pointer to slab and round up as a number of pointers
120 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
121 if ((PL_OpSpace -= sz) < 0) {
122 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
126 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
127 /* We reserve the 0'th I32 sized chunk as a use count */
128 PL_OpSlab = (I32 *) PL_OpPtr;
129 /* Reduce size by the use count word, and by the size we need.
130 * Latter is to mimic the '-=' in the if() above
132 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
133 /* Allocation pointer starts at the top.
134 Theory: because we build leaves before trunk allocating at end
135 means that at run time access is cache friendly upward
137 PL_OpPtr += PERL_SLAB_SIZE;
139 assert( PL_OpSpace >= 0 );
140 /* Move the allocation pointer down */
142 assert( PL_OpPtr > (I32 **) PL_OpSlab );
143 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
144 (*PL_OpSlab)++; /* Increment use count of slab */
145 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
146 assert( *PL_OpSlab > 0 );
147 return (void *)(PL_OpPtr + 1);
151 Perl_Slab_Free(pTHX_ void *op)
153 I32 * const * const ptr = (I32 **) op;
154 I32 * const slab = ptr[-1];
155 assert( ptr-1 > (I32 **) slab );
156 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
158 if (--(*slab) == 0) {
160 # define PerlMemShared PerlMem
163 PerlMemShared_free(slab);
164 if (slab == PL_OpSlab) {
171 * In the following definition, the ", (OP*)0" is just to make the compiler
172 * think the expression is of the right type: croak actually does a Siglongjmp.
174 #define CHECKOP(type,o) \
175 ((PL_op_mask && PL_op_mask[type]) \
176 ? ( op_free((OP*)o), \
177 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
179 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
181 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
184 S_gv_ename(pTHX_ GV *gv)
186 SV* const tmpsv = sv_newmortal();
187 gv_efullname3(tmpsv, gv, NULL);
188 return SvPV_nolen_const(tmpsv);
192 S_no_fh_allowed(pTHX_ OP *o)
194 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
200 S_too_few_arguments(pTHX_ OP *o, const char *name)
202 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
207 S_too_many_arguments(pTHX_ OP *o, const char *name)
209 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
214 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
216 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
217 (int)n, name, t, OP_DESC(kid)));
221 S_no_bareword_allowed(pTHX_ const OP *o)
224 return; /* various ok barewords are hidden in extra OP_NULL */
225 qerror(Perl_mess(aTHX_
226 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
230 /* "register" allocation */
233 Perl_allocmy(pTHX_ char *name)
237 const bool is_our = (PL_in_my == KEY_our);
239 /* complain about "my $<special_var>" etc etc */
243 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
244 (name[1] == '_' && (*name == '$' || name[2]))))
246 /* name[2] is true if strlen(name) > 2 */
247 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
248 /* 1999-02-27 mjd@plover.com */
250 p = strchr(name, '\0');
251 /* The next block assumes the buffer is at least 205 chars
252 long. At present, it's always at least 256 chars. */
254 strcpy(name+200, "...");
260 /* Move everything else down one character */
261 for (; p-name > 2; p--)
263 name[2] = toCTRL(name[1]);
266 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
269 /* check for duplicate declaration */
270 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
272 if (PL_in_my_stash && *name != '$') {
273 yyerror(Perl_form(aTHX_
274 "Can't declare class for non-scalar %s in \"%s\"",
275 name, is_our ? "our" : "my"));
278 /* allocate a spare slot and store the name in that slot */
280 off = pad_add_name(name,
283 /* $_ is always in main::, even with our */
284 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
295 Perl_op_free(pTHX_ OP *o)
300 if (!o || o->op_static)
304 if (o->op_private & OPpREFCOUNTED) {
315 refcnt = OpREFCNT_dec(o);
326 if (o->op_flags & OPf_KIDS) {
327 register OP *kid, *nextkid;
328 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
329 nextkid = kid->op_sibling; /* Get before next freeing kid */
334 type = (OPCODE)o->op_targ;
336 /* COP* is not cleared by op_clear() so that we may track line
337 * numbers etc even after null() */
338 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
343 #ifdef DEBUG_LEAKING_SCALARS
350 Perl_op_clear(pTHX_ OP *o)
355 /* if (o->op_madprop && o->op_madprop->mad_next)
357 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
358 "modification of a read only value" for a reason I can't fathom why.
359 It's the "" stringification of $_, where $_ was set to '' in a foreach
360 loop, but it defies simplification into a small test case.
361 However, commenting them out has caused ext/List/Util/t/weak.t to fail
364 mad_free(o->op_madprop);
370 switch (o->op_type) {
371 case OP_NULL: /* Was holding old type, if any. */
372 if (PL_madskills && o->op_targ != OP_NULL) {
373 o->op_type = o->op_targ;
377 case OP_ENTEREVAL: /* Was holding hints. */
381 if (!(o->op_flags & OPf_REF)
382 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
388 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
389 /* not an OP_PADAV replacement */
391 if (cPADOPo->op_padix > 0) {
392 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
393 * may still exist on the pad */
394 pad_swipe(cPADOPo->op_padix, TRUE);
395 cPADOPo->op_padix = 0;
398 SvREFCNT_dec(cSVOPo->op_sv);
399 cSVOPo->op_sv = NULL;
403 case OP_METHOD_NAMED:
405 SvREFCNT_dec(cSVOPo->op_sv);
406 cSVOPo->op_sv = NULL;
409 Even if op_clear does a pad_free for the target of the op,
410 pad_free doesn't actually remove the sv that exists in the pad;
411 instead it lives on. This results in that it could be reused as
412 a target later on when the pad was reallocated.
415 pad_swipe(o->op_targ,1);
424 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
428 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
429 SvREFCNT_dec(cSVOPo->op_sv);
430 cSVOPo->op_sv = NULL;
433 Safefree(cPVOPo->op_pv);
434 cPVOPo->op_pv = NULL;
438 op_free(cPMOPo->op_pmreplroot);
442 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
443 /* No GvIN_PAD_off here, because other references may still
444 * exist on the pad */
445 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
448 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
455 HV * const pmstash = PmopSTASH(cPMOPo);
456 if (pmstash && !SvIS_FREED(pmstash)) {
457 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
459 PMOP *pmop = (PMOP*) mg->mg_obj;
460 PMOP *lastpmop = NULL;
462 if (cPMOPo == pmop) {
464 lastpmop->op_pmnext = pmop->op_pmnext;
466 mg->mg_obj = (SV*) pmop->op_pmnext;
470 pmop = pmop->op_pmnext;
474 PmopSTASH_free(cPMOPo);
476 cPMOPo->op_pmreplroot = NULL;
477 /* we use the "SAFE" version of the PM_ macros here
478 * since sv_clean_all might release some PMOPs
479 * after PL_regex_padav has been cleared
480 * and the clearing of PL_regex_padav needs to
481 * happen before sv_clean_all
483 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
484 PM_SETRE_SAFE(cPMOPo, NULL);
486 if(PL_regex_pad) { /* We could be in destruction */
487 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
488 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
489 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
496 if (o->op_targ > 0) {
497 pad_free(o->op_targ);
503 S_cop_free(pTHX_ COP* cop)
505 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
508 if (! specialWARN(cop->cop_warnings))
509 PerlMemShared_free(cop->cop_warnings);
510 if (! specialCopIO(cop->cop_io)) {
514 SvREFCNT_dec(cop->cop_io);
517 Perl_refcounted_he_free(aTHX_ cop->cop_hints);
521 Perl_op_null(pTHX_ OP *o)
524 if (o->op_type == OP_NULL)
528 o->op_targ = o->op_type;
529 o->op_type = OP_NULL;
530 o->op_ppaddr = PL_ppaddr[OP_NULL];
534 Perl_op_refcnt_lock(pTHX)
542 Perl_op_refcnt_unlock(pTHX)
549 /* Contextualizers */
551 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
554 Perl_linklist(pTHX_ OP *o)
561 /* establish postfix order */
562 first = cUNOPo->op_first;
565 o->op_next = LINKLIST(first);
568 if (kid->op_sibling) {
569 kid->op_next = LINKLIST(kid->op_sibling);
570 kid = kid->op_sibling;
584 Perl_scalarkids(pTHX_ OP *o)
586 if (o && o->op_flags & OPf_KIDS) {
588 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
595 S_scalarboolean(pTHX_ OP *o)
598 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
599 if (ckWARN(WARN_SYNTAX)) {
600 const line_t oldline = CopLINE(PL_curcop);
602 if (PL_copline != NOLINE)
603 CopLINE_set(PL_curcop, PL_copline);
604 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
605 CopLINE_set(PL_curcop, oldline);
612 Perl_scalar(pTHX_ OP *o)
617 /* assumes no premature commitment */
618 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
619 || o->op_type == OP_RETURN)
624 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
626 switch (o->op_type) {
628 scalar(cBINOPo->op_first);
633 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
637 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
638 if (!kPMOP->op_pmreplroot)
639 deprecate_old("implicit split to @_");
647 if (o->op_flags & OPf_KIDS) {
648 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
654 kid = cLISTOPo->op_first;
656 while ((kid = kid->op_sibling)) {
662 WITH_THR(PL_curcop = &PL_compiling);
667 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
673 WITH_THR(PL_curcop = &PL_compiling);
676 if (ckWARN(WARN_VOID))
677 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
683 Perl_scalarvoid(pTHX_ OP *o)
687 const char* useless = NULL;
691 /* trailing mad null ops don't count as "there" for void processing */
693 o->op_type != OP_NULL &&
695 o->op_sibling->op_type == OP_NULL)
698 for (sib = o->op_sibling;
699 sib && sib->op_type == OP_NULL;
700 sib = sib->op_sibling) ;
706 if (o->op_type == OP_NEXTSTATE
707 || o->op_type == OP_SETSTATE
708 || o->op_type == OP_DBSTATE
709 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
710 || o->op_targ == OP_SETSTATE
711 || o->op_targ == OP_DBSTATE)))
712 PL_curcop = (COP*)o; /* for warning below */
714 /* assumes no premature commitment */
715 want = o->op_flags & OPf_WANT;
716 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
717 || o->op_type == OP_RETURN)
722 if ((o->op_private & OPpTARGET_MY)
723 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
725 return scalar(o); /* As if inside SASSIGN */
728 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
730 switch (o->op_type) {
732 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
736 if (o->op_flags & OPf_STACKED)
740 if (o->op_private == 4)
812 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
813 useless = OP_DESC(o);
817 kid = cUNOPo->op_first;
818 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
819 kid->op_type != OP_TRANS) {
822 useless = "negative pattern binding (!~)";
829 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
830 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
831 useless = "a variable";
836 if (cSVOPo->op_private & OPpCONST_STRICT)
837 no_bareword_allowed(o);
839 if (ckWARN(WARN_VOID)) {
840 useless = "a constant";
841 if (o->op_private & OPpCONST_ARYBASE)
843 /* don't warn on optimised away booleans, eg
844 * use constant Foo, 5; Foo || print; */
845 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
847 /* the constants 0 and 1 are permitted as they are
848 conventionally used as dummies in constructs like
849 1 while some_condition_with_side_effects; */
850 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
852 else if (SvPOK(sv)) {
853 /* perl4's way of mixing documentation and code
854 (before the invention of POD) was based on a
855 trick to mix nroff and perl code. The trick was
856 built upon these three nroff macros being used in
857 void context. The pink camel has the details in
858 the script wrapman near page 319. */
859 const char * const maybe_macro = SvPVX_const(sv);
860 if (strnEQ(maybe_macro, "di", 2) ||
861 strnEQ(maybe_macro, "ds", 2) ||
862 strnEQ(maybe_macro, "ig", 2))
867 op_null(o); /* don't execute or even remember it */
871 o->op_type = OP_PREINC; /* pre-increment is faster */
872 o->op_ppaddr = PL_ppaddr[OP_PREINC];
876 o->op_type = OP_PREDEC; /* pre-decrement is faster */
877 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
881 o->op_type = OP_I_PREINC; /* pre-increment is faster */
882 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
886 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
887 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
896 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
901 if (o->op_flags & OPf_STACKED)
908 if (!(o->op_flags & OPf_KIDS))
919 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
926 /* all requires must return a boolean value */
927 o->op_flags &= ~OPf_WANT;
932 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
933 if (!kPMOP->op_pmreplroot)
934 deprecate_old("implicit split to @_");
938 if (useless && ckWARN(WARN_VOID))
939 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
944 Perl_listkids(pTHX_ OP *o)
946 if (o && o->op_flags & OPf_KIDS) {
948 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
955 Perl_list(pTHX_ OP *o)
960 /* assumes no premature commitment */
961 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
962 || o->op_type == OP_RETURN)
967 if ((o->op_private & OPpTARGET_MY)
968 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
970 return o; /* As if inside SASSIGN */
973 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
975 switch (o->op_type) {
978 list(cBINOPo->op_first);
983 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
991 if (!(o->op_flags & OPf_KIDS))
993 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
994 list(cBINOPo->op_first);
995 return gen_constant_list(o);
1002 kid = cLISTOPo->op_first;
1004 while ((kid = kid->op_sibling)) {
1005 if (kid->op_sibling)
1010 WITH_THR(PL_curcop = &PL_compiling);
1014 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1015 if (kid->op_sibling)
1020 WITH_THR(PL_curcop = &PL_compiling);
1023 /* all requires must return a boolean value */
1024 o->op_flags &= ~OPf_WANT;
1031 Perl_scalarseq(pTHX_ OP *o)
1035 if (o->op_type == OP_LINESEQ ||
1036 o->op_type == OP_SCOPE ||
1037 o->op_type == OP_LEAVE ||
1038 o->op_type == OP_LEAVETRY)
1041 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1042 if (kid->op_sibling) {
1046 PL_curcop = &PL_compiling;
1048 o->op_flags &= ~OPf_PARENS;
1049 if (PL_hints & HINT_BLOCK_SCOPE)
1050 o->op_flags |= OPf_PARENS;
1053 o = newOP(OP_STUB, 0);
1058 S_modkids(pTHX_ OP *o, I32 type)
1060 if (o && o->op_flags & OPf_KIDS) {
1062 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1068 /* Propagate lvalue ("modifiable") context to an op and its children.
1069 * 'type' represents the context type, roughly based on the type of op that
1070 * would do the modifying, although local() is represented by OP_NULL.
1071 * It's responsible for detecting things that can't be modified, flag
1072 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1073 * might have to vivify a reference in $x), and so on.
1075 * For example, "$a+1 = 2" would cause mod() to be called with o being
1076 * OP_ADD and type being OP_SASSIGN, and would output an error.
1080 Perl_mod(pTHX_ OP *o, I32 type)
1084 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1087 if (!o || PL_error_count)
1090 if ((o->op_private & OPpTARGET_MY)
1091 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1096 switch (o->op_type) {
1102 if (!(o->op_private & OPpCONST_ARYBASE))
1105 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1106 CopARYBASE_set(&PL_compiling,
1107 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1111 SAVECOPARYBASE(&PL_compiling);
1112 CopARYBASE_set(&PL_compiling, 0);
1114 else if (type == OP_REFGEN)
1117 Perl_croak(aTHX_ "That use of $[ is unsupported");
1120 if (o->op_flags & OPf_PARENS || PL_madskills)
1124 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1125 !(o->op_flags & OPf_STACKED)) {
1126 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1127 /* The default is to set op_private to the number of children,
1128 which for a UNOP such as RV2CV is always 1. And w're using
1129 the bit for a flag in RV2CV, so we need it clear. */
1130 o->op_private &= ~1;
1131 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1132 assert(cUNOPo->op_first->op_type == OP_NULL);
1133 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1136 else if (o->op_private & OPpENTERSUB_NOMOD)
1138 else { /* lvalue subroutine call */
1139 o->op_private |= OPpLVAL_INTRO;
1140 PL_modcount = RETURN_UNLIMITED_NUMBER;
1141 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1142 /* Backward compatibility mode: */
1143 o->op_private |= OPpENTERSUB_INARGS;
1146 else { /* Compile-time error message: */
1147 OP *kid = cUNOPo->op_first;
1151 if (kid->op_type == OP_PUSHMARK)
1153 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1155 "panic: unexpected lvalue entersub "
1156 "args: type/targ %ld:%"UVuf,
1157 (long)kid->op_type, (UV)kid->op_targ);
1158 kid = kLISTOP->op_first;
1160 while (kid->op_sibling)
1161 kid = kid->op_sibling;
1162 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1164 if (kid->op_type == OP_METHOD_NAMED
1165 || kid->op_type == OP_METHOD)
1169 NewOp(1101, newop, 1, UNOP);
1170 newop->op_type = OP_RV2CV;
1171 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1172 newop->op_first = NULL;
1173 newop->op_next = (OP*)newop;
1174 kid->op_sibling = (OP*)newop;
1175 newop->op_private |= OPpLVAL_INTRO;
1176 newop->op_private &= ~1;
1180 if (kid->op_type != OP_RV2CV)
1182 "panic: unexpected lvalue entersub "
1183 "entry via type/targ %ld:%"UVuf,
1184 (long)kid->op_type, (UV)kid->op_targ);
1185 kid->op_private |= OPpLVAL_INTRO;
1186 break; /* Postpone until runtime */
1190 kid = kUNOP->op_first;
1191 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1192 kid = kUNOP->op_first;
1193 if (kid->op_type == OP_NULL)
1195 "Unexpected constant lvalue entersub "
1196 "entry via type/targ %ld:%"UVuf,
1197 (long)kid->op_type, (UV)kid->op_targ);
1198 if (kid->op_type != OP_GV) {
1199 /* Restore RV2CV to check lvalueness */
1201 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1202 okid->op_next = kid->op_next;
1203 kid->op_next = okid;
1206 okid->op_next = NULL;
1207 okid->op_type = OP_RV2CV;
1209 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1210 okid->op_private |= OPpLVAL_INTRO;
1211 okid->op_private &= ~1;
1215 cv = GvCV(kGVOP_gv);
1225 /* grep, foreach, subcalls, refgen */
1226 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1228 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1229 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1231 : (o->op_type == OP_ENTERSUB
1232 ? "non-lvalue subroutine call"
1234 type ? PL_op_desc[type] : "local"));
1248 case OP_RIGHT_SHIFT:
1257 if (!(o->op_flags & OPf_STACKED))
1264 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1270 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1271 PL_modcount = RETURN_UNLIMITED_NUMBER;
1272 return o; /* Treat \(@foo) like ordinary list. */
1276 if (scalar_mod_type(o, type))
1278 ref(cUNOPo->op_first, o->op_type);
1282 if (type == OP_LEAVESUBLV)
1283 o->op_private |= OPpMAYBE_LVSUB;
1289 PL_modcount = RETURN_UNLIMITED_NUMBER;
1292 ref(cUNOPo->op_first, o->op_type);
1297 PL_hints |= HINT_BLOCK_SCOPE;
1312 PL_modcount = RETURN_UNLIMITED_NUMBER;
1313 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1314 return o; /* Treat \(@foo) like ordinary list. */
1315 if (scalar_mod_type(o, type))
1317 if (type == OP_LEAVESUBLV)
1318 o->op_private |= OPpMAYBE_LVSUB;
1322 if (!type) /* local() */
1323 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1324 PAD_COMPNAME_PV(o->op_targ));
1332 if (type != OP_SASSIGN)
1336 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1341 if (type == OP_LEAVESUBLV)
1342 o->op_private |= OPpMAYBE_LVSUB;
1344 pad_free(o->op_targ);
1345 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1346 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1347 if (o->op_flags & OPf_KIDS)
1348 mod(cBINOPo->op_first->op_sibling, type);
1353 ref(cBINOPo->op_first, o->op_type);
1354 if (type == OP_ENTERSUB &&
1355 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1356 o->op_private |= OPpLVAL_DEFER;
1357 if (type == OP_LEAVESUBLV)
1358 o->op_private |= OPpMAYBE_LVSUB;
1368 if (o->op_flags & OPf_KIDS)
1369 mod(cLISTOPo->op_last, type);
1374 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1376 else if (!(o->op_flags & OPf_KIDS))
1378 if (o->op_targ != OP_LIST) {
1379 mod(cBINOPo->op_first, type);
1385 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1390 if (type != OP_LEAVESUBLV)
1392 break; /* mod()ing was handled by ck_return() */
1395 /* [20011101.069] File test operators interpret OPf_REF to mean that
1396 their argument is a filehandle; thus \stat(".") should not set
1398 if (type == OP_REFGEN &&
1399 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1402 if (type != OP_LEAVESUBLV)
1403 o->op_flags |= OPf_MOD;
1405 if (type == OP_AASSIGN || type == OP_SASSIGN)
1406 o->op_flags |= OPf_SPECIAL|OPf_REF;
1407 else if (!type) { /* local() */
1410 o->op_private |= OPpLVAL_INTRO;
1411 o->op_flags &= ~OPf_SPECIAL;
1412 PL_hints |= HINT_BLOCK_SCOPE;
1417 if (ckWARN(WARN_SYNTAX)) {
1418 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1419 "Useless localization of %s", OP_DESC(o));
1423 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1424 && type != OP_LEAVESUBLV)
1425 o->op_flags |= OPf_REF;
1430 S_scalar_mod_type(const OP *o, I32 type)
1434 if (o->op_type == OP_RV2GV)
1458 case OP_RIGHT_SHIFT:
1477 S_is_handle_constructor(const OP *o, I32 numargs)
1479 switch (o->op_type) {
1487 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1500 Perl_refkids(pTHX_ OP *o, I32 type)
1502 if (o && o->op_flags & OPf_KIDS) {
1504 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1511 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1516 if (!o || PL_error_count)
1519 switch (o->op_type) {
1521 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1522 !(o->op_flags & OPf_STACKED)) {
1523 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1524 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1525 assert(cUNOPo->op_first->op_type == OP_NULL);
1526 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1527 o->op_flags |= OPf_SPECIAL;
1528 o->op_private &= ~1;
1533 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1534 doref(kid, type, set_op_ref);
1537 if (type == OP_DEFINED)
1538 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1539 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1542 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1543 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1544 : type == OP_RV2HV ? OPpDEREF_HV
1546 o->op_flags |= OPf_MOD;
1551 o->op_flags |= OPf_MOD; /* XXX ??? */
1557 o->op_flags |= OPf_REF;
1560 if (type == OP_DEFINED)
1561 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1562 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1568 o->op_flags |= OPf_REF;
1573 if (!(o->op_flags & OPf_KIDS))
1575 doref(cBINOPo->op_first, type, set_op_ref);
1579 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1580 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1581 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1582 : type == OP_RV2HV ? OPpDEREF_HV
1584 o->op_flags |= OPf_MOD;
1594 if (!(o->op_flags & OPf_KIDS))
1596 doref(cLISTOPo->op_last, type, set_op_ref);
1606 S_dup_attrlist(pTHX_ OP *o)
1611 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1612 * where the first kid is OP_PUSHMARK and the remaining ones
1613 * are OP_CONST. We need to push the OP_CONST values.
1615 if (o->op_type == OP_CONST)
1616 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1618 else if (o->op_type == OP_NULL)
1622 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1624 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1625 if (o->op_type == OP_CONST)
1626 rop = append_elem(OP_LIST, rop,
1627 newSVOP(OP_CONST, o->op_flags,
1628 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1635 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1640 /* fake up C<use attributes $pkg,$rv,@attrs> */
1641 ENTER; /* need to protect against side-effects of 'use' */
1643 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1645 #define ATTRSMODULE "attributes"
1646 #define ATTRSMODULE_PM "attributes.pm"
1649 /* Don't force the C<use> if we don't need it. */
1650 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1651 if (svp && *svp != &PL_sv_undef)
1652 /*EMPTY*/; /* already in %INC */
1654 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1655 newSVpvs(ATTRSMODULE), NULL);
1658 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1659 newSVpvs(ATTRSMODULE),
1661 prepend_elem(OP_LIST,
1662 newSVOP(OP_CONST, 0, stashsv),
1663 prepend_elem(OP_LIST,
1664 newSVOP(OP_CONST, 0,
1666 dup_attrlist(attrs))));
1672 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1675 OP *pack, *imop, *arg;
1681 assert(target->op_type == OP_PADSV ||
1682 target->op_type == OP_PADHV ||
1683 target->op_type == OP_PADAV);
1685 /* Ensure that attributes.pm is loaded. */
1686 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1688 /* Need package name for method call. */
1689 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1691 /* Build up the real arg-list. */
1692 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1694 arg = newOP(OP_PADSV, 0);
1695 arg->op_targ = target->op_targ;
1696 arg = prepend_elem(OP_LIST,
1697 newSVOP(OP_CONST, 0, stashsv),
1698 prepend_elem(OP_LIST,
1699 newUNOP(OP_REFGEN, 0,
1700 mod(arg, OP_REFGEN)),
1701 dup_attrlist(attrs)));
1703 /* Fake up a method call to import */
1704 meth = newSVpvs_share("import");
1705 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1706 append_elem(OP_LIST,
1707 prepend_elem(OP_LIST, pack, list(arg)),
1708 newSVOP(OP_METHOD_NAMED, 0, meth)));
1709 imop->op_private |= OPpENTERSUB_NOMOD;
1711 /* Combine the ops. */
1712 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1716 =notfor apidoc apply_attrs_string
1718 Attempts to apply a list of attributes specified by the C<attrstr> and
1719 C<len> arguments to the subroutine identified by the C<cv> argument which
1720 is expected to be associated with the package identified by the C<stashpv>
1721 argument (see L<attributes>). It gets this wrong, though, in that it
1722 does not correctly identify the boundaries of the individual attribute
1723 specifications within C<attrstr>. This is not really intended for the
1724 public API, but has to be listed here for systems such as AIX which
1725 need an explicit export list for symbols. (It's called from XS code
1726 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1727 to respect attribute syntax properly would be welcome.
1733 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1734 const char *attrstr, STRLEN len)
1739 len = strlen(attrstr);
1743 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1745 const char * const sstr = attrstr;
1746 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1747 attrs = append_elem(OP_LIST, attrs,
1748 newSVOP(OP_CONST, 0,
1749 newSVpvn(sstr, attrstr-sstr)));
1753 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1754 newSVpvs(ATTRSMODULE),
1755 NULL, prepend_elem(OP_LIST,
1756 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1757 prepend_elem(OP_LIST,
1758 newSVOP(OP_CONST, 0,
1764 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1769 if (!o || PL_error_count)
1773 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1774 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1778 if (type == OP_LIST) {
1780 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1781 my_kid(kid, attrs, imopsp);
1782 } else if (type == OP_UNDEF
1788 } else if (type == OP_RV2SV || /* "our" declaration */
1790 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1791 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1792 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1793 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1795 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1797 PL_in_my_stash = NULL;
1798 apply_attrs(GvSTASH(gv),
1799 (type == OP_RV2SV ? GvSV(gv) :
1800 type == OP_RV2AV ? (SV*)GvAV(gv) :
1801 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1804 o->op_private |= OPpOUR_INTRO;
1807 else if (type != OP_PADSV &&
1810 type != OP_PUSHMARK)
1812 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1814 PL_in_my == KEY_our ? "our" : "my"));
1817 else if (attrs && type != OP_PUSHMARK) {
1821 PL_in_my_stash = NULL;
1823 /* check for C<my Dog $spot> when deciding package */
1824 stash = PAD_COMPNAME_TYPE(o->op_targ);
1826 stash = PL_curstash;
1827 apply_attrs_my(stash, o, attrs, imopsp);
1829 o->op_flags |= OPf_MOD;
1830 o->op_private |= OPpLVAL_INTRO;
1835 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1839 int maybe_scalar = 0;
1841 /* [perl #17376]: this appears to be premature, and results in code such as
1842 C< our(%x); > executing in list mode rather than void mode */
1844 if (o->op_flags & OPf_PARENS)
1854 o = my_kid(o, attrs, &rops);
1856 if (maybe_scalar && o->op_type == OP_PADSV) {
1857 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1858 o->op_private |= OPpLVAL_INTRO;
1861 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1864 PL_in_my_stash = NULL;
1869 Perl_my(pTHX_ OP *o)
1871 return my_attrs(o, NULL);
1875 Perl_sawparens(pTHX_ OP *o)
1877 PERL_UNUSED_CONTEXT;
1879 o->op_flags |= OPf_PARENS;
1884 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1889 if ( (left->op_type == OP_RV2AV ||
1890 left->op_type == OP_RV2HV ||
1891 left->op_type == OP_PADAV ||
1892 left->op_type == OP_PADHV)
1893 && ckWARN(WARN_MISC))
1895 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1896 right->op_type == OP_TRANS)
1897 ? right->op_type : OP_MATCH];
1898 const char * const sample = ((left->op_type == OP_RV2AV ||
1899 left->op_type == OP_PADAV)
1900 ? "@array" : "%hash");
1901 Perl_warner(aTHX_ packWARN(WARN_MISC),
1902 "Applying %s to %s will act on scalar(%s)",
1903 desc, sample, sample);
1906 if (right->op_type == OP_CONST &&
1907 cSVOPx(right)->op_private & OPpCONST_BARE &&
1908 cSVOPx(right)->op_private & OPpCONST_STRICT)
1910 no_bareword_allowed(right);
1913 ismatchop = right->op_type == OP_MATCH ||
1914 right->op_type == OP_SUBST ||
1915 right->op_type == OP_TRANS;
1916 if (ismatchop && right->op_private & OPpTARGET_MY) {
1918 right->op_private &= ~OPpTARGET_MY;
1920 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1921 right->op_flags |= OPf_STACKED;
1922 if (right->op_type != OP_MATCH &&
1923 ! (right->op_type == OP_TRANS &&
1924 right->op_private & OPpTRANS_IDENTICAL))
1925 left = mod(left, right->op_type);
1926 if (right->op_type == OP_TRANS)
1927 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1929 o = prepend_elem(right->op_type, scalar(left), right);
1931 return newUNOP(OP_NOT, 0, scalar(o));
1935 return bind_match(type, left,
1936 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1940 Perl_invert(pTHX_ OP *o)
1944 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1948 Perl_scope(pTHX_ OP *o)
1952 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1953 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1954 o->op_type = OP_LEAVE;
1955 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1957 else if (o->op_type == OP_LINESEQ) {
1959 o->op_type = OP_SCOPE;
1960 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1961 kid = ((LISTOP*)o)->op_first;
1962 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1965 /* The following deals with things like 'do {1 for 1}' */
1966 kid = kid->op_sibling;
1968 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1973 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1979 Perl_block_start(pTHX_ int full)
1982 const int retval = PL_savestack_ix;
1983 pad_block_start(full);
1985 PL_hints &= ~HINT_BLOCK_SCOPE;
1986 SAVECOPWARNINGS(&PL_compiling);
1987 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1988 SAVESPTR(PL_compiling.cop_io);
1989 if (! specialCopIO(PL_compiling.cop_io)) {
1990 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1991 SAVEFREESV(PL_compiling.cop_io) ;
1997 Perl_block_end(pTHX_ I32 floor, OP *seq)
2000 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2001 OP* const retval = scalarseq(seq);
2003 CopHINTS_set(&PL_compiling, PL_hints);
2005 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2014 const I32 offset = pad_findmy("$_");
2015 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2016 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2019 OP * const o = newOP(OP_PADSV, 0);
2020 o->op_targ = offset;
2026 Perl_newPROG(pTHX_ OP *o)
2032 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2033 ((PL_in_eval & EVAL_KEEPERR)
2034 ? OPf_SPECIAL : 0), o);
2035 PL_eval_start = linklist(PL_eval_root);
2036 PL_eval_root->op_private |= OPpREFCOUNTED;
2037 OpREFCNT_set(PL_eval_root, 1);
2038 PL_eval_root->op_next = 0;
2039 CALL_PEEP(PL_eval_start);
2042 if (o->op_type == OP_STUB) {
2043 PL_comppad_name = 0;
2048 PL_main_root = scope(sawparens(scalarvoid(o)));
2049 PL_curcop = &PL_compiling;
2050 PL_main_start = LINKLIST(PL_main_root);
2051 PL_main_root->op_private |= OPpREFCOUNTED;
2052 OpREFCNT_set(PL_main_root, 1);
2053 PL_main_root->op_next = 0;
2054 CALL_PEEP(PL_main_start);
2057 /* Register with debugger */
2059 CV * const cv = get_cv("DB::postponed", FALSE);
2063 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2065 call_sv((SV*)cv, G_DISCARD);
2072 Perl_localize(pTHX_ OP *o, I32 lex)
2075 if (o->op_flags & OPf_PARENS)
2076 /* [perl #17376]: this appears to be premature, and results in code such as
2077 C< our(%x); > executing in list mode rather than void mode */
2084 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2085 && ckWARN(WARN_PARENTHESIS))
2087 char *s = PL_bufptr;
2090 /* some heuristics to detect a potential error */
2091 while (*s && (strchr(", \t\n", *s)))
2095 if (*s && strchr("@$%*", *s) && *++s
2096 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2099 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2101 while (*s && (strchr(", \t\n", *s)))
2107 if (sigil && (*s == ';' || *s == '=')) {
2108 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2109 "Parentheses missing around \"%s\" list",
2110 lex ? (PL_in_my == KEY_our ? "our" : "my")
2118 o = mod(o, OP_NULL); /* a bit kludgey */
2120 PL_in_my_stash = NULL;
2125 Perl_jmaybe(pTHX_ OP *o)
2127 if (o->op_type == OP_LIST) {
2129 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2130 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2136 Perl_fold_constants(pTHX_ register OP *o)
2141 I32 type = o->op_type;
2148 if (PL_opargs[type] & OA_RETSCALAR)
2150 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2151 o->op_targ = pad_alloc(type, SVs_PADTMP);
2153 /* integerize op, unless it happens to be C<-foo>.
2154 * XXX should pp_i_negate() do magic string negation instead? */
2155 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2156 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2157 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2159 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2162 if (!(PL_opargs[type] & OA_FOLDCONST))
2167 /* XXX might want a ck_negate() for this */
2168 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2179 /* XXX what about the numeric ops? */
2180 if (PL_hints & HINT_LOCALE)
2185 goto nope; /* Don't try to run w/ errors */
2187 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2188 if ((curop->op_type != OP_CONST ||
2189 (curop->op_private & OPpCONST_BARE)) &&
2190 curop->op_type != OP_LIST &&
2191 curop->op_type != OP_SCALAR &&
2192 curop->op_type != OP_NULL &&
2193 curop->op_type != OP_PUSHMARK)
2199 curop = LINKLIST(o);
2200 old_next = o->op_next;
2204 oldscope = PL_scopestack_ix;
2205 create_eval_scope(G_FAKINGEVAL);
2212 sv = *(PL_stack_sp--);
2213 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2214 pad_swipe(o->op_targ, FALSE);
2215 else if (SvTEMP(sv)) { /* grab mortal temp? */
2216 SvREFCNT_inc_simple_void(sv);
2221 /* Something tried to die. Abandon constant folding. */
2222 /* Pretend the error never happened. */
2223 sv_setpvn(ERRSV,"",0);
2224 o->op_next = old_next;
2228 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2229 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2234 if (PL_scopestack_ix > oldscope)
2235 delete_eval_scope();
2244 if (type == OP_RV2GV)
2245 newop = newGVOP(OP_GV, 0, (GV*)sv);
2247 newop = newSVOP(OP_CONST, 0, sv);
2248 op_getmad(o,newop,'f');
2256 Perl_gen_constant_list(pTHX_ register OP *o)
2260 const I32 oldtmps_floor = PL_tmps_floor;
2264 return o; /* Don't attempt to run with errors */
2266 PL_op = curop = LINKLIST(o);
2273 PL_tmps_floor = oldtmps_floor;
2275 o->op_type = OP_RV2AV;
2276 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2277 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2278 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2279 o->op_opt = 0; /* needs to be revisited in peep() */
2280 curop = ((UNOP*)o)->op_first;
2281 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2283 op_getmad(curop,o,'O');
2292 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2295 if (!o || o->op_type != OP_LIST)
2296 o = newLISTOP(OP_LIST, 0, o, NULL);
2298 o->op_flags &= ~OPf_WANT;
2300 if (!(PL_opargs[type] & OA_MARK))
2301 op_null(cLISTOPo->op_first);
2303 o->op_type = (OPCODE)type;
2304 o->op_ppaddr = PL_ppaddr[type];
2305 o->op_flags |= flags;
2307 o = CHECKOP(type, o);
2308 if (o->op_type != (unsigned)type)
2311 return fold_constants(o);
2314 /* List constructors */
2317 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2325 if (first->op_type != (unsigned)type
2326 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2328 return newLISTOP(type, 0, first, last);
2331 if (first->op_flags & OPf_KIDS)
2332 ((LISTOP*)first)->op_last->op_sibling = last;
2334 first->op_flags |= OPf_KIDS;
2335 ((LISTOP*)first)->op_first = last;
2337 ((LISTOP*)first)->op_last = last;
2342 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2350 if (first->op_type != (unsigned)type)
2351 return prepend_elem(type, (OP*)first, (OP*)last);
2353 if (last->op_type != (unsigned)type)
2354 return append_elem(type, (OP*)first, (OP*)last);
2356 first->op_last->op_sibling = last->op_first;
2357 first->op_last = last->op_last;
2358 first->op_flags |= (last->op_flags & OPf_KIDS);
2361 if (last->op_first && first->op_madprop) {
2362 MADPROP *mp = last->op_first->op_madprop;
2364 while (mp->mad_next)
2366 mp->mad_next = first->op_madprop;
2369 last->op_first->op_madprop = first->op_madprop;
2372 first->op_madprop = last->op_madprop;
2373 last->op_madprop = 0;
2382 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2390 if (last->op_type == (unsigned)type) {
2391 if (type == OP_LIST) { /* already a PUSHMARK there */
2392 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2393 ((LISTOP*)last)->op_first->op_sibling = first;
2394 if (!(first->op_flags & OPf_PARENS))
2395 last->op_flags &= ~OPf_PARENS;
2398 if (!(last->op_flags & OPf_KIDS)) {
2399 ((LISTOP*)last)->op_last = first;
2400 last->op_flags |= OPf_KIDS;
2402 first->op_sibling = ((LISTOP*)last)->op_first;
2403 ((LISTOP*)last)->op_first = first;
2405 last->op_flags |= OPf_KIDS;
2409 return newLISTOP(type, 0, first, last);
2417 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2420 Newxz(tk, 1, TOKEN);
2421 tk->tk_type = (OPCODE)optype;
2422 tk->tk_type = 12345;
2424 tk->tk_mad = madprop;
2429 Perl_token_free(pTHX_ TOKEN* tk)
2431 if (tk->tk_type != 12345)
2433 mad_free(tk->tk_mad);
2438 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2442 if (tk->tk_type != 12345) {
2443 Perl_warner(aTHX_ packWARN(WARN_MISC),
2444 "Invalid TOKEN object ignored");
2451 /* faked up qw list? */
2453 tm->mad_type == MAD_SV &&
2454 SvPVX((SV*)tm->mad_val)[0] == 'q')
2461 /* pretend constant fold didn't happen? */
2462 if (mp->mad_key == 'f' &&
2463 (o->op_type == OP_CONST ||
2464 o->op_type == OP_GV) )
2466 token_getmad(tk,(OP*)mp->mad_val,slot);
2480 if (mp->mad_key == 'X')
2481 mp->mad_key = slot; /* just change the first one */
2491 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2500 /* pretend constant fold didn't happen? */
2501 if (mp->mad_key == 'f' &&
2502 (o->op_type == OP_CONST ||
2503 o->op_type == OP_GV) )
2505 op_getmad(from,(OP*)mp->mad_val,slot);
2512 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2515 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2521 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2530 /* pretend constant fold didn't happen? */
2531 if (mp->mad_key == 'f' &&
2532 (o->op_type == OP_CONST ||
2533 o->op_type == OP_GV) )
2535 op_getmad(from,(OP*)mp->mad_val,slot);
2542 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2545 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2549 PerlIO_printf(PerlIO_stderr(),
2550 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2556 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2574 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2578 addmad(tm, &(o->op_madprop), slot);
2582 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2603 Perl_newMADsv(pTHX_ char key, SV* sv)
2605 return newMADPROP(key, MAD_SV, sv, 0);
2609 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2612 Newxz(mp, 1, MADPROP);
2615 mp->mad_vlen = vlen;
2616 mp->mad_type = type;
2618 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2623 Perl_mad_free(pTHX_ MADPROP* mp)
2625 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2629 mad_free(mp->mad_next);
2630 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2631 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2632 switch (mp->mad_type) {
2636 Safefree((char*)mp->mad_val);
2639 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2640 op_free((OP*)mp->mad_val);
2643 sv_free((SV*)mp->mad_val);
2646 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2655 Perl_newNULLLIST(pTHX)
2657 return newOP(OP_STUB, 0);
2661 Perl_force_list(pTHX_ OP *o)
2663 if (!o || o->op_type != OP_LIST)
2664 o = newLISTOP(OP_LIST, 0, o, NULL);
2670 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2675 NewOp(1101, listop, 1, LISTOP);
2677 listop->op_type = (OPCODE)type;
2678 listop->op_ppaddr = PL_ppaddr[type];
2681 listop->op_flags = (U8)flags;
2685 else if (!first && last)
2688 first->op_sibling = last;
2689 listop->op_first = first;
2690 listop->op_last = last;
2691 if (type == OP_LIST) {
2692 OP* const pushop = newOP(OP_PUSHMARK, 0);
2693 pushop->op_sibling = first;
2694 listop->op_first = pushop;
2695 listop->op_flags |= OPf_KIDS;
2697 listop->op_last = pushop;
2700 return CHECKOP(type, listop);
2704 Perl_newOP(pTHX_ I32 type, I32 flags)
2708 NewOp(1101, o, 1, OP);
2709 o->op_type = (OPCODE)type;
2710 o->op_ppaddr = PL_ppaddr[type];
2711 o->op_flags = (U8)flags;
2714 o->op_private = (U8)(0 | (flags >> 8));
2715 if (PL_opargs[type] & OA_RETSCALAR)
2717 if (PL_opargs[type] & OA_TARGET)
2718 o->op_targ = pad_alloc(type, SVs_PADTMP);
2719 return CHECKOP(type, o);
2723 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2729 first = newOP(OP_STUB, 0);
2730 if (PL_opargs[type] & OA_MARK)
2731 first = force_list(first);
2733 NewOp(1101, unop, 1, UNOP);
2734 unop->op_type = (OPCODE)type;
2735 unop->op_ppaddr = PL_ppaddr[type];
2736 unop->op_first = first;
2737 unop->op_flags = (U8)(flags | OPf_KIDS);
2738 unop->op_private = (U8)(1 | (flags >> 8));
2739 unop = (UNOP*) CHECKOP(type, unop);
2743 return fold_constants((OP *) unop);
2747 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2751 NewOp(1101, binop, 1, BINOP);
2754 first = newOP(OP_NULL, 0);
2756 binop->op_type = (OPCODE)type;
2757 binop->op_ppaddr = PL_ppaddr[type];
2758 binop->op_first = first;
2759 binop->op_flags = (U8)(flags | OPf_KIDS);
2762 binop->op_private = (U8)(1 | (flags >> 8));
2765 binop->op_private = (U8)(2 | (flags >> 8));
2766 first->op_sibling = last;
2769 binop = (BINOP*)CHECKOP(type, binop);
2770 if (binop->op_next || binop->op_type != (OPCODE)type)
2773 binop->op_last = binop->op_first->op_sibling;
2775 return fold_constants((OP *)binop);
2778 static int uvcompare(const void *a, const void *b)
2779 __attribute__nonnull__(1)
2780 __attribute__nonnull__(2)
2781 __attribute__pure__;
2782 static int uvcompare(const void *a, const void *b)
2784 if (*((const UV *)a) < (*(const UV *)b))
2786 if (*((const UV *)a) > (*(const UV *)b))
2788 if (*((const UV *)a+1) < (*(const UV *)b+1))
2790 if (*((const UV *)a+1) > (*(const UV *)b+1))
2796 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2799 SV * const tstr = ((SVOP*)expr)->op_sv;
2800 SV * const rstr = ((SVOP*)repl)->op_sv;
2803 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2804 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2808 register short *tbl;
2810 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2811 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2812 I32 del = o->op_private & OPpTRANS_DELETE;
2813 PL_hints |= HINT_BLOCK_SCOPE;
2816 o->op_private |= OPpTRANS_FROM_UTF;
2819 o->op_private |= OPpTRANS_TO_UTF;
2821 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2822 SV* const listsv = newSVpvs("# comment\n");
2824 const U8* tend = t + tlen;
2825 const U8* rend = r + rlen;
2839 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2840 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2843 const U32 flags = UTF8_ALLOW_DEFAULT;
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, flags);
2872 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2874 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
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, flags);
2930 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2932 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2939 /* now see if we need more "r" chars */
2940 if (rfirst > rlast) {
2942 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2944 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2946 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
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(CopARYBASE_get(&PL_compiling)));
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 CopHINTS_set(cop, PL_hints);
3935 cop->op_private |= NATIVE_HINTS;
3937 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3938 cop->op_next = (OP*)cop;
3941 cop->cop_label = label;
3942 PL_hints |= HINT_BLOCK_SCOPE;
3945 CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
3946 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3947 if (specialCopIO(PL_curcop->cop_io))
3948 cop->cop_io = PL_curcop->cop_io;
3950 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3951 cop->cop_hints = PL_curcop->cop_hints;
3952 if (cop->cop_hints) {
3954 cop->cop_hints->refcounted_he_refcnt++;
3955 HINTS_REFCNT_UNLOCK;
3958 if (PL_copline == NOLINE)
3959 CopLINE_set(cop, CopLINE(PL_curcop));
3961 CopLINE_set(cop, PL_copline);
3962 PL_copline = NOLINE;
3965 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3967 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3969 CopSTASH_set(cop, PL_curstash);
3971 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3972 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3973 if (svp && *svp != &PL_sv_undef ) {
3974 (void)SvIOK_on(*svp);
3975 SvIV_set(*svp, PTR2IV(cop));
3979 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3984 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3987 return new_logop(type, flags, &first, &other);
3991 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3996 OP *first = *firstp;
3997 OP * const other = *otherp;
3999 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4000 return newBINOP(type, flags, scalar(first), scalar(other));
4002 scalarboolean(first);
4003 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4004 if (first->op_type == OP_NOT
4005 && (first->op_flags & OPf_SPECIAL)
4006 && (first->op_flags & OPf_KIDS)) {
4007 if (type == OP_AND || type == OP_OR) {
4013 first = *firstp = cUNOPo->op_first;
4015 first->op_next = o->op_next;
4016 cUNOPo->op_first = NULL;
4018 op_getmad(o,first,'O');
4024 if (first->op_type == OP_CONST) {
4025 if (first->op_private & OPpCONST_STRICT)
4026 no_bareword_allowed(first);
4027 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4028 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4029 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4030 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4031 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4033 if (other->op_type == OP_CONST)
4034 other->op_private |= OPpCONST_SHORTCIRCUIT;
4036 OP *newop = newUNOP(OP_NULL, 0, other);
4037 op_getmad(first, newop, '1');
4038 newop->op_targ = type; /* set "was" field */
4045 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4046 const OP *o2 = other;
4047 if ( ! (o2->op_type == OP_LIST
4048 && (( o2 = cUNOPx(o2)->op_first))
4049 && o2->op_type == OP_PUSHMARK
4050 && (( o2 = o2->op_sibling)) )
4053 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4054 || o2->op_type == OP_PADHV)
4055 && o2->op_private & OPpLVAL_INTRO
4056 && ckWARN(WARN_DEPRECATED))
4058 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4059 "Deprecated use of my() in false conditional");
4063 if (first->op_type == OP_CONST)
4064 first->op_private |= OPpCONST_SHORTCIRCUIT;
4066 first = newUNOP(OP_NULL, 0, first);
4067 op_getmad(other, first, '2');
4068 first->op_targ = type; /* set "was" field */
4075 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4076 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4078 const OP * const k1 = ((UNOP*)first)->op_first;
4079 const OP * const k2 = k1->op_sibling;
4081 switch (first->op_type)
4084 if (k2 && k2->op_type == OP_READLINE
4085 && (k2->op_flags & OPf_STACKED)
4086 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4088 warnop = k2->op_type;
4093 if (k1->op_type == OP_READDIR
4094 || k1->op_type == OP_GLOB
4095 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4096 || k1->op_type == OP_EACH)
4098 warnop = ((k1->op_type == OP_NULL)
4099 ? (OPCODE)k1->op_targ : k1->op_type);
4104 const line_t oldline = CopLINE(PL_curcop);
4105 CopLINE_set(PL_curcop, PL_copline);
4106 Perl_warner(aTHX_ packWARN(WARN_MISC),
4107 "Value of %s%s can be \"0\"; test with defined()",
4109 ((warnop == OP_READLINE || warnop == OP_GLOB)
4110 ? " construct" : "() operator"));
4111 CopLINE_set(PL_curcop, oldline);
4118 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4119 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4121 NewOp(1101, logop, 1, LOGOP);
4123 logop->op_type = (OPCODE)type;
4124 logop->op_ppaddr = PL_ppaddr[type];
4125 logop->op_first = first;
4126 logop->op_flags = (U8)(flags | OPf_KIDS);
4127 logop->op_other = LINKLIST(other);
4128 logop->op_private = (U8)(1 | (flags >> 8));
4130 /* establish postfix order */
4131 logop->op_next = LINKLIST(first);
4132 first->op_next = (OP*)logop;
4133 first->op_sibling = other;
4135 CHECKOP(type,logop);
4137 o = newUNOP(OP_NULL, 0, (OP*)logop);
4144 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4152 return newLOGOP(OP_AND, 0, first, trueop);
4154 return newLOGOP(OP_OR, 0, first, falseop);
4156 scalarboolean(first);
4157 if (first->op_type == OP_CONST) {
4158 if (first->op_private & OPpCONST_BARE &&
4159 first->op_private & OPpCONST_STRICT) {
4160 no_bareword_allowed(first);
4162 if (SvTRUE(((SVOP*)first)->op_sv)) {
4165 trueop = newUNOP(OP_NULL, 0, trueop);
4166 op_getmad(first,trueop,'C');
4167 op_getmad(falseop,trueop,'e');
4169 /* FIXME for MAD - should there be an ELSE here? */
4179 falseop = newUNOP(OP_NULL, 0, falseop);
4180 op_getmad(first,falseop,'C');
4181 op_getmad(trueop,falseop,'t');
4183 /* FIXME for MAD - should there be an ELSE here? */
4191 NewOp(1101, logop, 1, LOGOP);
4192 logop->op_type = OP_COND_EXPR;
4193 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4194 logop->op_first = first;
4195 logop->op_flags = (U8)(flags | OPf_KIDS);
4196 logop->op_private = (U8)(1 | (flags >> 8));
4197 logop->op_other = LINKLIST(trueop);
4198 logop->op_next = LINKLIST(falseop);
4200 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4203 /* establish postfix order */
4204 start = LINKLIST(first);
4205 first->op_next = (OP*)logop;
4207 first->op_sibling = trueop;
4208 trueop->op_sibling = falseop;
4209 o = newUNOP(OP_NULL, 0, (OP*)logop);
4211 trueop->op_next = falseop->op_next = o;
4218 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4227 NewOp(1101, range, 1, LOGOP);
4229 range->op_type = OP_RANGE;
4230 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4231 range->op_first = left;
4232 range->op_flags = OPf_KIDS;
4233 leftstart = LINKLIST(left);
4234 range->op_other = LINKLIST(right);
4235 range->op_private = (U8)(1 | (flags >> 8));
4237 left->op_sibling = right;
4239 range->op_next = (OP*)range;
4240 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4241 flop = newUNOP(OP_FLOP, 0, flip);
4242 o = newUNOP(OP_NULL, 0, flop);
4244 range->op_next = leftstart;
4246 left->op_next = flip;
4247 right->op_next = flop;
4249 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4250 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4251 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4252 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4254 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4255 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4258 if (!flip->op_private || !flop->op_private)
4259 linklist(o); /* blow off optimizer unless constant */
4265 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4270 const bool once = block && block->op_flags & OPf_SPECIAL &&
4271 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4273 PERL_UNUSED_ARG(debuggable);
4276 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4277 return block; /* do {} while 0 does once */
4278 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4279 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4280 expr = newUNOP(OP_DEFINED, 0,
4281 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4282 } else if (expr->op_flags & OPf_KIDS) {
4283 const OP * const k1 = ((UNOP*)expr)->op_first;
4284 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4285 switch (expr->op_type) {
4287 if (k2 && k2->op_type == OP_READLINE
4288 && (k2->op_flags & OPf_STACKED)
4289 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4290 expr = newUNOP(OP_DEFINED, 0, expr);
4294 if (k1 && (k1->op_type == OP_READDIR
4295 || k1->op_type == OP_GLOB
4296 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4297 || k1->op_type == OP_EACH))
4298 expr = newUNOP(OP_DEFINED, 0, expr);
4304 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4305 * op, in listop. This is wrong. [perl #27024] */
4307 block = newOP(OP_NULL, 0);
4308 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4309 o = new_logop(OP_AND, 0, &expr, &listop);
4312 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4314 if (once && o != listop)
4315 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4318 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4320 o->op_flags |= flags;
4322 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4327 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4328 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4337 PERL_UNUSED_ARG(debuggable);
4340 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4341 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4342 expr = newUNOP(OP_DEFINED, 0,
4343 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4344 } else if (expr->op_flags & OPf_KIDS) {
4345 const OP * const k1 = ((UNOP*)expr)->op_first;
4346 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4347 switch (expr->op_type) {
4349 if (k2 && k2->op_type == OP_READLINE
4350 && (k2->op_flags & OPf_STACKED)
4351 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4352 expr = newUNOP(OP_DEFINED, 0, expr);
4356 if (k1 && (k1->op_type == OP_READDIR
4357 || k1->op_type == OP_GLOB
4358 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4359 || k1->op_type == OP_EACH))
4360 expr = newUNOP(OP_DEFINED, 0, expr);
4367 block = newOP(OP_NULL, 0);
4368 else if (cont || has_my) {
4369 block = scope(block);
4373 next = LINKLIST(cont);
4376 OP * const unstack = newOP(OP_UNSTACK, 0);
4379 cont = append_elem(OP_LINESEQ, cont, unstack);
4382 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4383 redo = LINKLIST(listop);
4386 PL_copline = (line_t)whileline;
4388 o = new_logop(OP_AND, 0, &expr, &listop);
4389 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4390 op_free(expr); /* oops, it's a while (0) */
4392 return NULL; /* listop already freed by new_logop */
4395 ((LISTOP*)listop)->op_last->op_next =
4396 (o == listop ? redo : LINKLIST(o));
4402 NewOp(1101,loop,1,LOOP);
4403 loop->op_type = OP_ENTERLOOP;
4404 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4405 loop->op_private = 0;
4406 loop->op_next = (OP*)loop;
4409 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4411 loop->op_redoop = redo;
4412 loop->op_lastop = o;
4413 o->op_private |= loopflags;
4416 loop->op_nextop = next;
4418 loop->op_nextop = o;
4420 o->op_flags |= flags;
4421 o->op_private |= (flags >> 8);
4426 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4431 PADOFFSET padoff = 0;
4437 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4438 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4439 sv->op_type = OP_RV2GV;
4440 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4441 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4442 iterpflags |= OPpITER_DEF;
4444 else if (sv->op_type == OP_PADSV) { /* private variable */
4445 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4446 padoff = sv->op_targ;
4455 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4456 padoff = sv->op_targ;
4461 iterflags |= OPf_SPECIAL;
4467 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4468 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4469 iterpflags |= OPpITER_DEF;
4472 const I32 offset = pad_findmy("$_");
4473 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4474 sv = newGVOP(OP_GV, 0, PL_defgv);
4479 iterpflags |= OPpITER_DEF;
4481 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4482 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4483 iterflags |= OPf_STACKED;
4485 else if (expr->op_type == OP_NULL &&
4486 (expr->op_flags & OPf_KIDS) &&
4487 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4489 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4490 * set the STACKED flag to indicate that these values are to be
4491 * treated as min/max values by 'pp_iterinit'.
4493 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4494 LOGOP* const range = (LOGOP*) flip->op_first;
4495 OP* const left = range->op_first;
4496 OP* const right = left->op_sibling;
4499 range->op_flags &= ~OPf_KIDS;
4500 range->op_first = NULL;
4502 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4503 listop->op_first->op_next = range->op_next;
4504 left->op_next = range->op_other;
4505 right->op_next = (OP*)listop;
4506 listop->op_next = listop->op_first;
4509 op_getmad(expr,(OP*)listop,'O');
4513 expr = (OP*)(listop);
4515 iterflags |= OPf_STACKED;
4518 expr = mod(force_list(expr), OP_GREPSTART);
4521 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4522 append_elem(OP_LIST, expr, scalar(sv))));
4523 assert(!loop->op_next);
4524 /* for my $x () sets OPpLVAL_INTRO;
4525 * for our $x () sets OPpOUR_INTRO */
4526 loop->op_private = (U8)iterpflags;
4527 #ifdef PL_OP_SLAB_ALLOC
4530 NewOp(1234,tmp,1,LOOP);
4531 Copy(loop,tmp,1,LISTOP);
4536 loop = PerlMemShared_realloc(loop, sizeof(LOOP));
4538 loop->op_targ = padoff;
4539 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4541 op_getmad(madsv, (OP*)loop, 'v');
4542 PL_copline = forline;
4543 return newSTATEOP(0, label, wop);
4547 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4552 if (type != OP_GOTO || label->op_type == OP_CONST) {
4553 /* "last()" means "last" */
4554 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4555 o = newOP(type, OPf_SPECIAL);
4557 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4558 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4562 op_getmad(label,o,'L');
4568 /* Check whether it's going to be a goto &function */
4569 if (label->op_type == OP_ENTERSUB
4570 && !(label->op_flags & OPf_STACKED))
4571 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4572 o = newUNOP(type, OPf_STACKED, label);
4574 PL_hints |= HINT_BLOCK_SCOPE;
4578 /* if the condition is a literal array or hash
4579 (or @{ ... } etc), make a reference to it.
4582 S_ref_array_or_hash(pTHX_ OP *cond)
4585 && (cond->op_type == OP_RV2AV
4586 || cond->op_type == OP_PADAV
4587 || cond->op_type == OP_RV2HV
4588 || cond->op_type == OP_PADHV))
4590 return newUNOP(OP_REFGEN,
4591 0, mod(cond, OP_REFGEN));
4597 /* These construct the optree fragments representing given()
4600 entergiven and enterwhen are LOGOPs; the op_other pointer
4601 points up to the associated leave op. We need this so we
4602 can put it in the context and make break/continue work.
4603 (Also, of course, pp_enterwhen will jump straight to
4604 op_other if the match fails.)
4609 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4610 I32 enter_opcode, I32 leave_opcode,
4611 PADOFFSET entertarg)
4617 NewOp(1101, enterop, 1, LOGOP);
4618 enterop->op_type = enter_opcode;
4619 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4620 enterop->op_flags = (U8) OPf_KIDS;
4621 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4622 enterop->op_private = 0;
4624 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4627 enterop->op_first = scalar(cond);
4628 cond->op_sibling = block;
4630 o->op_next = LINKLIST(cond);
4631 cond->op_next = (OP *) enterop;
4634 /* This is a default {} block */
4635 enterop->op_first = block;
4636 enterop->op_flags |= OPf_SPECIAL;
4638 o->op_next = (OP *) enterop;
4641 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4642 entergiven and enterwhen both
4645 enterop->op_next = LINKLIST(block);
4646 block->op_next = enterop->op_other = o;
4651 /* Does this look like a boolean operation? For these purposes
4652 a boolean operation is:
4653 - a subroutine call [*]
4654 - a logical connective
4655 - a comparison operator
4656 - a filetest operator, with the exception of -s -M -A -C
4657 - defined(), exists() or eof()
4658 - /$re/ or $foo =~ /$re/
4660 [*] possibly surprising
4664 S_looks_like_bool(pTHX_ const OP *o)
4667 switch(o->op_type) {
4669 return looks_like_bool(cLOGOPo->op_first);
4673 looks_like_bool(cLOGOPo->op_first)
4674 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4678 case OP_NOT: case OP_XOR:
4679 /* Note that OP_DOR is not here */
4681 case OP_EQ: case OP_NE: case OP_LT:
4682 case OP_GT: case OP_LE: case OP_GE:
4684 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4685 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4687 case OP_SEQ: case OP_SNE: case OP_SLT:
4688 case OP_SGT: case OP_SLE: case OP_SGE:
4692 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4693 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4694 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4695 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4696 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4697 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4698 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4699 case OP_FTTEXT: case OP_FTBINARY:
4701 case OP_DEFINED: case OP_EXISTS:
4702 case OP_MATCH: case OP_EOF:
4707 /* Detect comparisons that have been optimized away */
4708 if (cSVOPo->op_sv == &PL_sv_yes
4709 || cSVOPo->op_sv == &PL_sv_no)
4720 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4724 return newGIVWHENOP(
4725 ref_array_or_hash(cond),
4727 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4731 /* If cond is null, this is a default {} block */
4733 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4735 const bool cond_llb = (!cond || looks_like_bool(cond));
4741 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4743 scalar(ref_array_or_hash(cond)));
4746 return newGIVWHENOP(
4748 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4749 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4753 =for apidoc cv_undef
4755 Clear out all the active components of a CV. This can happen either
4756 by an explicit C<undef &foo>, or by the reference count going to zero.
4757 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4758 children can still follow the full lexical scope chain.
4764 Perl_cv_undef(pTHX_ CV *cv)
4768 if (CvFILE(cv) && !CvISXSUB(cv)) {
4769 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4770 Safefree(CvFILE(cv));
4775 if (!CvISXSUB(cv) && CvROOT(cv)) {
4776 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4777 Perl_croak(aTHX_ "Can't undef active subroutine");
4780 PAD_SAVE_SETNULLPAD();
4782 op_free(CvROOT(cv));
4787 SvPOK_off((SV*)cv); /* forget prototype */
4792 /* remove CvOUTSIDE unless this is an undef rather than a free */
4793 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4794 if (!CvWEAKOUTSIDE(cv))
4795 SvREFCNT_dec(CvOUTSIDE(cv));
4796 CvOUTSIDE(cv) = NULL;
4799 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4802 if (CvISXSUB(cv) && CvXSUB(cv)) {
4805 /* delete all flags except WEAKOUTSIDE */
4806 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4810 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4812 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4813 SV* const msg = sv_newmortal();
4817 gv_efullname3(name = sv_newmortal(), gv, NULL);
4818 sv_setpv(msg, "Prototype mismatch:");
4820 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4822 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4824 sv_catpvs(msg, ": none");
4825 sv_catpvs(msg, " vs ");
4827 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4829 sv_catpvs(msg, "none");
4830 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4834 static void const_sv_xsub(pTHX_ CV* cv);
4838 =head1 Optree Manipulation Functions
4840 =for apidoc cv_const_sv
4842 If C<cv> is a constant sub eligible for inlining. returns the constant
4843 value returned by the sub. Otherwise, returns NULL.
4845 Constant subs can be created with C<newCONSTSUB> or as described in
4846 L<perlsub/"Constant Functions">.
4851 Perl_cv_const_sv(pTHX_ CV *cv)
4853 PERL_UNUSED_CONTEXT;