3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints> on the save stack, so that it
95 will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifndef PERL_SLAB_SIZE
108 #define PERL_SLAB_SIZE 2048
112 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
115 * To make incrementing use count easy PL_OpSlab is an I32 *
116 * To make inserting the link to slab PL_OpPtr is I32 **
117 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
118 * Add an overhead for pointer to slab and round up as a number of pointers
120 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
121 if ((PL_OpSpace -= sz) < 0) {
122 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
126 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
127 /* We reserve the 0'th I32 sized chunk as a use count */
128 PL_OpSlab = (I32 *) PL_OpPtr;
129 /* Reduce size by the use count word, and by the size we need.
130 * Latter is to mimic the '-=' in the if() above
132 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
133 /* Allocation pointer starts at the top.
134 Theory: because we build leaves before trunk allocating at end
135 means that at run time access is cache friendly upward
137 PL_OpPtr += PERL_SLAB_SIZE;
139 assert( PL_OpSpace >= 0 );
140 /* Move the allocation pointer down */
142 assert( PL_OpPtr > (I32 **) PL_OpSlab );
143 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
144 (*PL_OpSlab)++; /* Increment use count of slab */
145 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
146 assert( *PL_OpSlab > 0 );
147 return (void *)(PL_OpPtr + 1);
151 Perl_Slab_Free(pTHX_ void *op)
153 I32 * const * const ptr = (I32 **) op;
154 I32 * const slab = ptr[-1];
155 assert( ptr-1 > (I32 **) slab );
156 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
158 if (--(*slab) == 0) {
160 # define PerlMemShared PerlMem
163 PerlMemShared_free(slab);
164 if (slab == PL_OpSlab) {
171 * In the following definition, the ", (OP*)0" is just to make the compiler
172 * think the expression is of the right type: croak actually does a Siglongjmp.
174 #define CHECKOP(type,o) \
175 ((PL_op_mask && PL_op_mask[type]) \
176 ? ( op_free((OP*)o), \
177 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
179 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
181 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
184 S_gv_ename(pTHX_ GV *gv)
186 SV* const tmpsv = sv_newmortal();
187 gv_efullname3(tmpsv, gv, NULL);
188 return SvPV_nolen_const(tmpsv);
192 S_no_fh_allowed(pTHX_ OP *o)
194 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
200 S_too_few_arguments(pTHX_ OP *o, const char *name)
202 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
207 S_too_many_arguments(pTHX_ OP *o, const char *name)
209 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
214 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
216 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
217 (int)n, name, t, OP_DESC(kid)));
221 S_no_bareword_allowed(pTHX_ const OP *o)
224 return; /* various ok barewords are hidden in extra OP_NULL */
225 qerror(Perl_mess(aTHX_
226 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
230 /* "register" allocation */
233 Perl_allocmy(pTHX_ char *name)
237 const bool is_our = (PL_in_my == KEY_our);
239 /* complain about "my $<special_var>" etc etc */
243 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
244 (name[1] == '_' && (*name == '$' || name[2]))))
246 /* name[2] is true if strlen(name) > 2 */
247 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
248 /* 1999-02-27 mjd@plover.com */
250 p = strchr(name, '\0');
251 /* The next block assumes the buffer is at least 205 chars
252 long. At present, it's always at least 256 chars. */
253 if (p - name > 200) {
255 strlcpy(name + 200, "...", 4);
257 strcpy(name + 200, "...");
264 /* Move everything else down one character */
265 for (; p-name > 2; p--)
267 name[2] = toCTRL(name[1]);
270 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
273 /* check for duplicate declaration */
274 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
276 if (PL_in_my_stash && *name != '$') {
277 yyerror(Perl_form(aTHX_
278 "Can't declare class for non-scalar %s in \"%s\"",
280 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
283 /* allocate a spare slot and store the name in that slot */
285 off = pad_add_name(name,
288 /* $_ is always in main::, even with our */
289 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
293 PL_in_my == KEY_state
301 Perl_op_free(pTHX_ OP *o)
306 if (!o || o->op_static)
310 if (o->op_private & OPpREFCOUNTED) {
321 refcnt = OpREFCNT_dec(o);
332 if (o->op_flags & OPf_KIDS) {
333 register OP *kid, *nextkid;
334 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
335 nextkid = kid->op_sibling; /* Get before next freeing kid */
340 type = (OPCODE)o->op_targ;
342 /* COP* is not cleared by op_clear() so that we may track line
343 * numbers etc even after null() */
344 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
349 #ifdef DEBUG_LEAKING_SCALARS
356 Perl_op_clear(pTHX_ OP *o)
361 /* if (o->op_madprop && o->op_madprop->mad_next)
363 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
364 "modification of a read only value" for a reason I can't fathom why.
365 It's the "" stringification of $_, where $_ was set to '' in a foreach
366 loop, but it defies simplification into a small test case.
367 However, commenting them out has caused ext/List/Util/t/weak.t to fail
370 mad_free(o->op_madprop);
376 switch (o->op_type) {
377 case OP_NULL: /* Was holding old type, if any. */
378 if (PL_madskills && o->op_targ != OP_NULL) {
379 o->op_type = o->op_targ;
383 case OP_ENTEREVAL: /* Was holding hints. */
387 if (!(o->op_flags & OPf_REF)
388 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
394 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
395 /* not an OP_PADAV replacement */
397 if (cPADOPo->op_padix > 0) {
398 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
399 * may still exist on the pad */
400 pad_swipe(cPADOPo->op_padix, TRUE);
401 cPADOPo->op_padix = 0;
404 SvREFCNT_dec(cSVOPo->op_sv);
405 cSVOPo->op_sv = NULL;
409 case OP_METHOD_NAMED:
411 SvREFCNT_dec(cSVOPo->op_sv);
412 cSVOPo->op_sv = NULL;
415 Even if op_clear does a pad_free for the target of the op,
416 pad_free doesn't actually remove the sv that exists in the pad;
417 instead it lives on. This results in that it could be reused as
418 a target later on when the pad was reallocated.
421 pad_swipe(o->op_targ,1);
430 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
434 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
435 SvREFCNT_dec(cSVOPo->op_sv);
436 cSVOPo->op_sv = NULL;
439 Safefree(cPVOPo->op_pv);
440 cPVOPo->op_pv = NULL;
444 op_free(cPMOPo->op_pmreplroot);
448 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
449 /* No GvIN_PAD_off here, because other references may still
450 * exist on the pad */
451 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
454 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
461 HV * const pmstash = PmopSTASH(cPMOPo);
462 if (pmstash && !SvIS_FREED(pmstash)) {
463 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
465 PMOP *pmop = (PMOP*) mg->mg_obj;
466 PMOP *lastpmop = NULL;
468 if (cPMOPo == pmop) {
470 lastpmop->op_pmnext = pmop->op_pmnext;
472 mg->mg_obj = (SV*) pmop->op_pmnext;
476 pmop = pmop->op_pmnext;
480 PmopSTASH_free(cPMOPo);
482 cPMOPo->op_pmreplroot = NULL;
483 /* we use the "SAFE" version of the PM_ macros here
484 * since sv_clean_all might release some PMOPs
485 * after PL_regex_padav has been cleared
486 * and the clearing of PL_regex_padav needs to
487 * happen before sv_clean_all
489 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
490 PM_SETRE_SAFE(cPMOPo, NULL);
492 if(PL_regex_pad) { /* We could be in destruction */
493 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
494 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
495 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
502 if (o->op_targ > 0) {
503 pad_free(o->op_targ);
509 S_cop_free(pTHX_ COP* cop)
511 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
514 if (! specialWARN(cop->cop_warnings))
515 PerlMemShared_free(cop->cop_warnings);
516 if (! specialCopIO(cop->cop_io)) {
520 SvREFCNT_dec(cop->cop_io);
523 Perl_refcounted_he_free(aTHX_ cop->cop_hints);
527 Perl_op_null(pTHX_ OP *o)
530 if (o->op_type == OP_NULL)
534 o->op_targ = o->op_type;
535 o->op_type = OP_NULL;
536 o->op_ppaddr = PL_ppaddr[OP_NULL];
540 Perl_op_refcnt_lock(pTHX)
548 Perl_op_refcnt_unlock(pTHX)
555 /* Contextualizers */
557 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
560 Perl_linklist(pTHX_ OP *o)
567 /* establish postfix order */
568 first = cUNOPo->op_first;
571 o->op_next = LINKLIST(first);
574 if (kid->op_sibling) {
575 kid->op_next = LINKLIST(kid->op_sibling);
576 kid = kid->op_sibling;
590 Perl_scalarkids(pTHX_ OP *o)
592 if (o && o->op_flags & OPf_KIDS) {
594 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
601 S_scalarboolean(pTHX_ OP *o)
604 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
605 if (ckWARN(WARN_SYNTAX)) {
606 const line_t oldline = CopLINE(PL_curcop);
608 if (PL_copline != NOLINE)
609 CopLINE_set(PL_curcop, PL_copline);
610 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
611 CopLINE_set(PL_curcop, oldline);
618 Perl_scalar(pTHX_ OP *o)
623 /* assumes no premature commitment */
624 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
625 || o->op_type == OP_RETURN)
630 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
632 switch (o->op_type) {
634 scalar(cBINOPo->op_first);
639 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
643 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
644 if (!kPMOP->op_pmreplroot)
645 deprecate_old("implicit split to @_");
653 if (o->op_flags & OPf_KIDS) {
654 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
660 kid = cLISTOPo->op_first;
662 while ((kid = kid->op_sibling)) {
668 WITH_THR(PL_curcop = &PL_compiling);
673 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
679 WITH_THR(PL_curcop = &PL_compiling);
682 if (ckWARN(WARN_VOID))
683 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
689 Perl_scalarvoid(pTHX_ OP *o)
693 const char* useless = NULL;
697 /* trailing mad null ops don't count as "there" for void processing */
699 o->op_type != OP_NULL &&
701 o->op_sibling->op_type == OP_NULL)
704 for (sib = o->op_sibling;
705 sib && sib->op_type == OP_NULL;
706 sib = sib->op_sibling) ;
712 if (o->op_type == OP_NEXTSTATE
713 || o->op_type == OP_SETSTATE
714 || o->op_type == OP_DBSTATE
715 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
716 || o->op_targ == OP_SETSTATE
717 || o->op_targ == OP_DBSTATE)))
718 PL_curcop = (COP*)o; /* for warning below */
720 /* assumes no premature commitment */
721 want = o->op_flags & OPf_WANT;
722 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
723 || o->op_type == OP_RETURN)
728 if ((o->op_private & OPpTARGET_MY)
729 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
731 return scalar(o); /* As if inside SASSIGN */
734 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
736 switch (o->op_type) {
738 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
742 if (o->op_flags & OPf_STACKED)
746 if (o->op_private == 4)
818 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
819 useless = OP_DESC(o);
823 kid = cUNOPo->op_first;
824 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
825 kid->op_type != OP_TRANS) {
828 useless = "negative pattern binding (!~)";
835 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
836 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
837 useless = "a variable";
842 if (cSVOPo->op_private & OPpCONST_STRICT)
843 no_bareword_allowed(o);
845 if (ckWARN(WARN_VOID)) {
846 useless = "a constant";
847 if (o->op_private & OPpCONST_ARYBASE)
849 /* don't warn on optimised away booleans, eg
850 * use constant Foo, 5; Foo || print; */
851 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
853 /* the constants 0 and 1 are permitted as they are
854 conventionally used as dummies in constructs like
855 1 while some_condition_with_side_effects; */
856 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
858 else if (SvPOK(sv)) {
859 /* perl4's way of mixing documentation and code
860 (before the invention of POD) was based on a
861 trick to mix nroff and perl code. The trick was
862 built upon these three nroff macros being used in
863 void context. The pink camel has the details in
864 the script wrapman near page 319. */
865 const char * const maybe_macro = SvPVX_const(sv);
866 if (strnEQ(maybe_macro, "di", 2) ||
867 strnEQ(maybe_macro, "ds", 2) ||
868 strnEQ(maybe_macro, "ig", 2))
873 op_null(o); /* don't execute or even remember it */
877 o->op_type = OP_PREINC; /* pre-increment is faster */
878 o->op_ppaddr = PL_ppaddr[OP_PREINC];
882 o->op_type = OP_PREDEC; /* pre-decrement is faster */
883 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
887 o->op_type = OP_I_PREINC; /* pre-increment is faster */
888 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
892 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
893 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
902 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
907 if (o->op_flags & OPf_STACKED)
914 if (!(o->op_flags & OPf_KIDS))
925 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
932 /* all requires must return a boolean value */
933 o->op_flags &= ~OPf_WANT;
938 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
939 if (!kPMOP->op_pmreplroot)
940 deprecate_old("implicit split to @_");
944 if (useless && ckWARN(WARN_VOID))
945 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
950 Perl_listkids(pTHX_ OP *o)
952 if (o && o->op_flags & OPf_KIDS) {
954 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
961 Perl_list(pTHX_ OP *o)
966 /* assumes no premature commitment */
967 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
968 || o->op_type == OP_RETURN)
973 if ((o->op_private & OPpTARGET_MY)
974 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
976 return o; /* As if inside SASSIGN */
979 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
981 switch (o->op_type) {
984 list(cBINOPo->op_first);
989 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
997 if (!(o->op_flags & OPf_KIDS))
999 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1000 list(cBINOPo->op_first);
1001 return gen_constant_list(o);
1008 kid = cLISTOPo->op_first;
1010 while ((kid = kid->op_sibling)) {
1011 if (kid->op_sibling)
1016 WITH_THR(PL_curcop = &PL_compiling);
1020 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1021 if (kid->op_sibling)
1026 WITH_THR(PL_curcop = &PL_compiling);
1029 /* all requires must return a boolean value */
1030 o->op_flags &= ~OPf_WANT;
1037 Perl_scalarseq(pTHX_ OP *o)
1041 const OPCODE type = o->op_type;
1043 if (type == OP_LINESEQ || type == OP_SCOPE ||
1044 type == OP_LEAVE || type == OP_LEAVETRY)
1047 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1048 if (kid->op_sibling) {
1052 PL_curcop = &PL_compiling;
1054 o->op_flags &= ~OPf_PARENS;
1055 if (PL_hints & HINT_BLOCK_SCOPE)
1056 o->op_flags |= OPf_PARENS;
1059 o = newOP(OP_STUB, 0);
1064 S_modkids(pTHX_ OP *o, I32 type)
1066 if (o && o->op_flags & OPf_KIDS) {
1068 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1074 /* Propagate lvalue ("modifiable") context to an op and its children.
1075 * 'type' represents the context type, roughly based on the type of op that
1076 * would do the modifying, although local() is represented by OP_NULL.
1077 * It's responsible for detecting things that can't be modified, flag
1078 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1079 * might have to vivify a reference in $x), and so on.
1081 * For example, "$a+1 = 2" would cause mod() to be called with o being
1082 * OP_ADD and type being OP_SASSIGN, and would output an error.
1086 Perl_mod(pTHX_ OP *o, I32 type)
1090 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1093 if (!o || PL_error_count)
1096 if ((o->op_private & OPpTARGET_MY)
1097 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1102 switch (o->op_type) {
1108 if (!(o->op_private & OPpCONST_ARYBASE))
1111 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1112 CopARYBASE_set(&PL_compiling,
1113 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1117 SAVECOPARYBASE(&PL_compiling);
1118 CopARYBASE_set(&PL_compiling, 0);
1120 else if (type == OP_REFGEN)
1123 Perl_croak(aTHX_ "That use of $[ is unsupported");
1126 if (o->op_flags & OPf_PARENS || PL_madskills)
1130 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1131 !(o->op_flags & OPf_STACKED)) {
1132 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1133 /* The default is to set op_private to the number of children,
1134 which for a UNOP such as RV2CV is always 1. And w're using
1135 the bit for a flag in RV2CV, so we need it clear. */
1136 o->op_private &= ~1;
1137 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1138 assert(cUNOPo->op_first->op_type == OP_NULL);
1139 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1142 else if (o->op_private & OPpENTERSUB_NOMOD)
1144 else { /* lvalue subroutine call */
1145 o->op_private |= OPpLVAL_INTRO;
1146 PL_modcount = RETURN_UNLIMITED_NUMBER;
1147 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1148 /* Backward compatibility mode: */
1149 o->op_private |= OPpENTERSUB_INARGS;
1152 else { /* Compile-time error message: */
1153 OP *kid = cUNOPo->op_first;
1157 if (kid->op_type != OP_PUSHMARK) {
1158 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1160 "panic: unexpected lvalue entersub "
1161 "args: type/targ %ld:%"UVuf,
1162 (long)kid->op_type, (UV)kid->op_targ);
1163 kid = kLISTOP->op_first;
1165 while (kid->op_sibling)
1166 kid = kid->op_sibling;
1167 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1169 if (kid->op_type == OP_METHOD_NAMED
1170 || kid->op_type == OP_METHOD)
1174 NewOp(1101, newop, 1, UNOP);
1175 newop->op_type = OP_RV2CV;
1176 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1177 newop->op_first = NULL;
1178 newop->op_next = (OP*)newop;
1179 kid->op_sibling = (OP*)newop;
1180 newop->op_private |= OPpLVAL_INTRO;
1181 newop->op_private &= ~1;
1185 if (kid->op_type != OP_RV2CV)
1187 "panic: unexpected lvalue entersub "
1188 "entry via type/targ %ld:%"UVuf,
1189 (long)kid->op_type, (UV)kid->op_targ);
1190 kid->op_private |= OPpLVAL_INTRO;
1191 break; /* Postpone until runtime */
1195 kid = kUNOP->op_first;
1196 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1197 kid = kUNOP->op_first;
1198 if (kid->op_type == OP_NULL)
1200 "Unexpected constant lvalue entersub "
1201 "entry via type/targ %ld:%"UVuf,
1202 (long)kid->op_type, (UV)kid->op_targ);
1203 if (kid->op_type != OP_GV) {
1204 /* Restore RV2CV to check lvalueness */
1206 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1207 okid->op_next = kid->op_next;
1208 kid->op_next = okid;
1211 okid->op_next = NULL;
1212 okid->op_type = OP_RV2CV;
1214 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1215 okid->op_private |= OPpLVAL_INTRO;
1216 okid->op_private &= ~1;
1220 cv = GvCV(kGVOP_gv);
1230 /* grep, foreach, subcalls, refgen */
1231 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1233 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1234 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1236 : (o->op_type == OP_ENTERSUB
1237 ? "non-lvalue subroutine call"
1239 type ? PL_op_desc[type] : "local"));
1253 case OP_RIGHT_SHIFT:
1262 if (!(o->op_flags & OPf_STACKED))
1269 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1275 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1276 PL_modcount = RETURN_UNLIMITED_NUMBER;
1277 return o; /* Treat \(@foo) like ordinary list. */
1281 if (scalar_mod_type(o, type))
1283 ref(cUNOPo->op_first, o->op_type);
1287 if (type == OP_LEAVESUBLV)
1288 o->op_private |= OPpMAYBE_LVSUB;
1294 PL_modcount = RETURN_UNLIMITED_NUMBER;
1297 ref(cUNOPo->op_first, o->op_type);
1302 PL_hints |= HINT_BLOCK_SCOPE;
1317 PL_modcount = RETURN_UNLIMITED_NUMBER;
1318 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1319 return o; /* Treat \(@foo) like ordinary list. */
1320 if (scalar_mod_type(o, type))
1322 if (type == OP_LEAVESUBLV)
1323 o->op_private |= OPpMAYBE_LVSUB;
1327 if (!type) /* local() */
1328 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1329 PAD_COMPNAME_PV(o->op_targ));
1337 if (type != OP_SASSIGN)
1341 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1346 if (type == OP_LEAVESUBLV)
1347 o->op_private |= OPpMAYBE_LVSUB;
1349 pad_free(o->op_targ);
1350 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1351 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1352 if (o->op_flags & OPf_KIDS)
1353 mod(cBINOPo->op_first->op_sibling, type);
1358 ref(cBINOPo->op_first, o->op_type);
1359 if (type == OP_ENTERSUB &&
1360 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1361 o->op_private |= OPpLVAL_DEFER;
1362 if (type == OP_LEAVESUBLV)
1363 o->op_private |= OPpMAYBE_LVSUB;
1373 if (o->op_flags & OPf_KIDS)
1374 mod(cLISTOPo->op_last, type);
1379 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1381 else if (!(o->op_flags & OPf_KIDS))
1383 if (o->op_targ != OP_LIST) {
1384 mod(cBINOPo->op_first, type);
1390 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1395 if (type != OP_LEAVESUBLV)
1397 break; /* mod()ing was handled by ck_return() */
1400 /* [20011101.069] File test operators interpret OPf_REF to mean that
1401 their argument is a filehandle; thus \stat(".") should not set
1403 if (type == OP_REFGEN &&
1404 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1407 if (type != OP_LEAVESUBLV)
1408 o->op_flags |= OPf_MOD;
1410 if (type == OP_AASSIGN || type == OP_SASSIGN)
1411 o->op_flags |= OPf_SPECIAL|OPf_REF;
1412 else if (!type) { /* local() */
1415 o->op_private |= OPpLVAL_INTRO;
1416 o->op_flags &= ~OPf_SPECIAL;
1417 PL_hints |= HINT_BLOCK_SCOPE;
1422 if (ckWARN(WARN_SYNTAX)) {
1423 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1424 "Useless localization of %s", OP_DESC(o));
1428 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1429 && type != OP_LEAVESUBLV)
1430 o->op_flags |= OPf_REF;
1435 S_scalar_mod_type(const OP *o, I32 type)
1439 if (o->op_type == OP_RV2GV)
1463 case OP_RIGHT_SHIFT:
1482 S_is_handle_constructor(const OP *o, I32 numargs)
1484 switch (o->op_type) {
1492 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1505 Perl_refkids(pTHX_ OP *o, I32 type)
1507 if (o && o->op_flags & OPf_KIDS) {
1509 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1516 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1521 if (!o || PL_error_count)
1524 switch (o->op_type) {
1526 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1527 !(o->op_flags & OPf_STACKED)) {
1528 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1529 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1530 assert(cUNOPo->op_first->op_type == OP_NULL);
1531 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1532 o->op_flags |= OPf_SPECIAL;
1533 o->op_private &= ~1;
1538 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1539 doref(kid, type, set_op_ref);
1542 if (type == OP_DEFINED)
1543 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1544 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1547 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1548 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1549 : type == OP_RV2HV ? OPpDEREF_HV
1551 o->op_flags |= OPf_MOD;
1556 o->op_flags |= OPf_MOD; /* XXX ??? */
1562 o->op_flags |= OPf_REF;
1565 if (type == OP_DEFINED)
1566 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1567 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1573 o->op_flags |= OPf_REF;
1578 if (!(o->op_flags & OPf_KIDS))
1580 doref(cBINOPo->op_first, type, set_op_ref);
1584 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1585 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1586 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1587 : type == OP_RV2HV ? OPpDEREF_HV
1589 o->op_flags |= OPf_MOD;
1599 if (!(o->op_flags & OPf_KIDS))
1601 doref(cLISTOPo->op_last, type, set_op_ref);
1611 S_dup_attrlist(pTHX_ OP *o)
1616 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1617 * where the first kid is OP_PUSHMARK and the remaining ones
1618 * are OP_CONST. We need to push the OP_CONST values.
1620 if (o->op_type == OP_CONST)
1621 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1623 else if (o->op_type == OP_NULL)
1627 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1629 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1630 if (o->op_type == OP_CONST)
1631 rop = append_elem(OP_LIST, rop,
1632 newSVOP(OP_CONST, o->op_flags,
1633 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1640 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1645 /* fake up C<use attributes $pkg,$rv,@attrs> */
1646 ENTER; /* need to protect against side-effects of 'use' */
1648 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1650 #define ATTRSMODULE "attributes"
1651 #define ATTRSMODULE_PM "attributes.pm"
1654 /* Don't force the C<use> if we don't need it. */
1655 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1656 if (svp && *svp != &PL_sv_undef)
1657 NOOP; /* already in %INC */
1659 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1660 newSVpvs(ATTRSMODULE), NULL);
1663 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1664 newSVpvs(ATTRSMODULE),
1666 prepend_elem(OP_LIST,
1667 newSVOP(OP_CONST, 0, stashsv),
1668 prepend_elem(OP_LIST,
1669 newSVOP(OP_CONST, 0,
1671 dup_attrlist(attrs))));
1677 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1680 OP *pack, *imop, *arg;
1686 assert(target->op_type == OP_PADSV ||
1687 target->op_type == OP_PADHV ||
1688 target->op_type == OP_PADAV);
1690 /* Ensure that attributes.pm is loaded. */
1691 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1693 /* Need package name for method call. */
1694 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1696 /* Build up the real arg-list. */
1697 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1699 arg = newOP(OP_PADSV, 0);
1700 arg->op_targ = target->op_targ;
1701 arg = prepend_elem(OP_LIST,
1702 newSVOP(OP_CONST, 0, stashsv),
1703 prepend_elem(OP_LIST,
1704 newUNOP(OP_REFGEN, 0,
1705 mod(arg, OP_REFGEN)),
1706 dup_attrlist(attrs)));
1708 /* Fake up a method call to import */
1709 meth = newSVpvs_share("import");
1710 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1711 append_elem(OP_LIST,
1712 prepend_elem(OP_LIST, pack, list(arg)),
1713 newSVOP(OP_METHOD_NAMED, 0, meth)));
1714 imop->op_private |= OPpENTERSUB_NOMOD;
1716 /* Combine the ops. */
1717 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1721 =notfor apidoc apply_attrs_string
1723 Attempts to apply a list of attributes specified by the C<attrstr> and
1724 C<len> arguments to the subroutine identified by the C<cv> argument which
1725 is expected to be associated with the package identified by the C<stashpv>
1726 argument (see L<attributes>). It gets this wrong, though, in that it
1727 does not correctly identify the boundaries of the individual attribute
1728 specifications within C<attrstr>. This is not really intended for the
1729 public API, but has to be listed here for systems such as AIX which
1730 need an explicit export list for symbols. (It's called from XS code
1731 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1732 to respect attribute syntax properly would be welcome.
1738 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1739 const char *attrstr, STRLEN len)
1744 len = strlen(attrstr);
1748 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1750 const char * const sstr = attrstr;
1751 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1752 attrs = append_elem(OP_LIST, attrs,
1753 newSVOP(OP_CONST, 0,
1754 newSVpvn(sstr, attrstr-sstr)));
1758 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1759 newSVpvs(ATTRSMODULE),
1760 NULL, prepend_elem(OP_LIST,
1761 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1762 prepend_elem(OP_LIST,
1763 newSVOP(OP_CONST, 0,
1769 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1774 if (!o || PL_error_count)
1778 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1779 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1783 if (type == OP_LIST) {
1785 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1786 my_kid(kid, attrs, imopsp);
1787 } else if (type == OP_UNDEF
1793 } else if (type == OP_RV2SV || /* "our" declaration */
1795 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1796 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1797 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1799 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1801 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1803 PL_in_my_stash = NULL;
1804 apply_attrs(GvSTASH(gv),
1805 (type == OP_RV2SV ? GvSV(gv) :
1806 type == OP_RV2AV ? (SV*)GvAV(gv) :
1807 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1810 o->op_private |= OPpOUR_INTRO;
1813 else if (type != OP_PADSV &&
1816 type != OP_PUSHMARK)
1818 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1820 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1823 else if (attrs && type != OP_PUSHMARK) {
1827 PL_in_my_stash = NULL;
1829 /* check for C<my Dog $spot> when deciding package */
1830 stash = PAD_COMPNAME_TYPE(o->op_targ);
1832 stash = PL_curstash;
1833 apply_attrs_my(stash, o, attrs, imopsp);
1835 o->op_flags |= OPf_MOD;
1836 o->op_private |= OPpLVAL_INTRO;
1837 if (PL_in_my == KEY_state)
1838 o->op_private |= OPpPAD_STATE;
1843 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1847 int maybe_scalar = 0;
1849 /* [perl #17376]: this appears to be premature, and results in code such as
1850 C< our(%x); > executing in list mode rather than void mode */
1852 if (o->op_flags & OPf_PARENS)
1862 o = my_kid(o, attrs, &rops);
1864 if (maybe_scalar && o->op_type == OP_PADSV) {
1865 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1866 o->op_private |= OPpLVAL_INTRO;
1869 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1872 PL_in_my_stash = NULL;
1877 Perl_my(pTHX_ OP *o)
1879 return my_attrs(o, NULL);
1883 Perl_sawparens(pTHX_ OP *o)
1885 PERL_UNUSED_CONTEXT;
1887 o->op_flags |= OPf_PARENS;
1892 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1896 const OPCODE ltype = left->op_type;
1897 const OPCODE rtype = right->op_type;
1899 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1900 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
1902 const char * const desc
1903 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1904 ? rtype : OP_MATCH];
1905 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1906 ? "@array" : "%hash");
1907 Perl_warner(aTHX_ packWARN(WARN_MISC),
1908 "Applying %s to %s will act on scalar(%s)",
1909 desc, sample, sample);
1912 if (rtype == OP_CONST &&
1913 cSVOPx(right)->op_private & OPpCONST_BARE &&
1914 cSVOPx(right)->op_private & OPpCONST_STRICT)
1916 no_bareword_allowed(right);
1919 ismatchop = rtype == OP_MATCH ||
1920 rtype == OP_SUBST ||
1922 if (ismatchop && right->op_private & OPpTARGET_MY) {
1924 right->op_private &= ~OPpTARGET_MY;
1926 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1929 right->op_flags |= OPf_STACKED;
1930 if (rtype != OP_MATCH &&
1931 ! (rtype == OP_TRANS &&
1932 right->op_private & OPpTRANS_IDENTICAL))
1933 newleft = mod(left, rtype);
1936 if (right->op_type == OP_TRANS)
1937 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
1939 o = prepend_elem(rtype, scalar(newleft), right);
1941 return newUNOP(OP_NOT, 0, scalar(o));
1945 return bind_match(type, left,
1946 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1950 Perl_invert(pTHX_ OP *o)
1954 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1958 Perl_scope(pTHX_ OP *o)
1962 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1963 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1964 o->op_type = OP_LEAVE;
1965 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1967 else if (o->op_type == OP_LINESEQ) {
1969 o->op_type = OP_SCOPE;
1970 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1971 kid = ((LISTOP*)o)->op_first;
1972 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1975 /* The following deals with things like 'do {1 for 1}' */
1976 kid = kid->op_sibling;
1978 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1983 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1989 Perl_block_start(pTHX_ int full)
1992 const int retval = PL_savestack_ix;
1993 pad_block_start(full);
1995 PL_hints &= ~HINT_BLOCK_SCOPE;
1996 SAVECOMPILEWARNINGS();
1997 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1998 SAVESPTR(PL_compiling.cop_io);
1999 if (! specialCopIO(PL_compiling.cop_io)) {
2000 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2001 SAVEFREESV(PL_compiling.cop_io) ;
2007 Perl_block_end(pTHX_ I32 floor, OP *seq)
2010 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2011 OP* const retval = scalarseq(seq);
2013 CopHINTS_set(&PL_compiling, PL_hints);
2015 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2024 const PADOFFSET offset = pad_findmy("$_");
2025 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2026 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2029 OP * const o = newOP(OP_PADSV, 0);
2030 o->op_targ = offset;
2036 Perl_newPROG(pTHX_ OP *o)
2042 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2043 ((PL_in_eval & EVAL_KEEPERR)
2044 ? OPf_SPECIAL : 0), o);
2045 PL_eval_start = linklist(PL_eval_root);
2046 PL_eval_root->op_private |= OPpREFCOUNTED;
2047 OpREFCNT_set(PL_eval_root, 1);
2048 PL_eval_root->op_next = 0;
2049 CALL_PEEP(PL_eval_start);
2052 if (o->op_type == OP_STUB) {
2053 PL_comppad_name = 0;
2058 PL_main_root = scope(sawparens(scalarvoid(o)));
2059 PL_curcop = &PL_compiling;
2060 PL_main_start = LINKLIST(PL_main_root);
2061 PL_main_root->op_private |= OPpREFCOUNTED;
2062 OpREFCNT_set(PL_main_root, 1);
2063 PL_main_root->op_next = 0;
2064 CALL_PEEP(PL_main_start);
2067 /* Register with debugger */
2069 CV * const cv = get_cv("DB::postponed", FALSE);
2073 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2075 call_sv((SV*)cv, G_DISCARD);
2082 Perl_localize(pTHX_ OP *o, I32 lex)
2085 if (o->op_flags & OPf_PARENS)
2086 /* [perl #17376]: this appears to be premature, and results in code such as
2087 C< our(%x); > executing in list mode rather than void mode */
2094 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2095 && ckWARN(WARN_PARENTHESIS))
2097 char *s = PL_bufptr;
2100 /* some heuristics to detect a potential error */
2101 while (*s && (strchr(", \t\n", *s)))
2105 if (*s && strchr("@$%*", *s) && *++s
2106 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2109 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2111 while (*s && (strchr(", \t\n", *s)))
2117 if (sigil && (*s == ';' || *s == '=')) {
2118 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2119 "Parentheses missing around \"%s\" list",
2120 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2128 o = mod(o, OP_NULL); /* a bit kludgey */
2130 PL_in_my_stash = NULL;
2135 Perl_jmaybe(pTHX_ OP *o)
2137 if (o->op_type == OP_LIST) {
2139 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2140 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2146 Perl_fold_constants(pTHX_ register OP *o)
2151 I32 type = o->op_type;
2158 if (PL_opargs[type] & OA_RETSCALAR)
2160 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2161 o->op_targ = pad_alloc(type, SVs_PADTMP);
2163 /* integerize op, unless it happens to be C<-foo>.
2164 * XXX should pp_i_negate() do magic string negation instead? */
2165 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2166 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2167 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2169 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2172 if (!(PL_opargs[type] & OA_FOLDCONST))
2177 /* XXX might want a ck_negate() for this */
2178 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2189 /* XXX what about the numeric ops? */
2190 if (PL_hints & HINT_LOCALE)
2195 goto nope; /* Don't try to run w/ errors */
2197 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2198 const OPCODE type = curop->op_type;
2199 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2201 type != OP_SCALAR &&
2203 type != OP_PUSHMARK)
2209 curop = LINKLIST(o);
2210 old_next = o->op_next;
2214 oldscope = PL_scopestack_ix;
2215 create_eval_scope(G_FAKINGEVAL);
2222 sv = *(PL_stack_sp--);
2223 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2224 pad_swipe(o->op_targ, FALSE);
2225 else if (SvTEMP(sv)) { /* grab mortal temp? */
2226 SvREFCNT_inc_simple_void(sv);
2231 /* Something tried to die. Abandon constant folding. */
2232 /* Pretend the error never happened. */
2233 sv_setpvn(ERRSV,"",0);
2234 o->op_next = old_next;
2238 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2239 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2244 if (PL_scopestack_ix > oldscope)
2245 delete_eval_scope();
2254 if (type == OP_RV2GV)
2255 newop = newGVOP(OP_GV, 0, (GV*)sv);
2257 newop = newSVOP(OP_CONST, 0, sv);
2258 op_getmad(o,newop,'f');
2266 Perl_gen_constant_list(pTHX_ register OP *o)
2270 const I32 oldtmps_floor = PL_tmps_floor;
2274 return o; /* Don't attempt to run with errors */
2276 PL_op = curop = LINKLIST(o);
2283 PL_tmps_floor = oldtmps_floor;
2285 o->op_type = OP_RV2AV;
2286 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2287 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2288 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2289 o->op_opt = 0; /* needs to be revisited in peep() */
2290 curop = ((UNOP*)o)->op_first;
2291 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2293 op_getmad(curop,o,'O');
2302 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2305 if (!o || o->op_type != OP_LIST)
2306 o = newLISTOP(OP_LIST, 0, o, NULL);
2308 o->op_flags &= ~OPf_WANT;
2310 if (!(PL_opargs[type] & OA_MARK))
2311 op_null(cLISTOPo->op_first);
2313 o->op_type = (OPCODE)type;
2314 o->op_ppaddr = PL_ppaddr[type];
2315 o->op_flags |= flags;
2317 o = CHECKOP(type, o);
2318 if (o->op_type != (unsigned)type)
2321 return fold_constants(o);
2324 /* List constructors */
2327 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2335 if (first->op_type != (unsigned)type
2336 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2338 return newLISTOP(type, 0, first, last);
2341 if (first->op_flags & OPf_KIDS)
2342 ((LISTOP*)first)->op_last->op_sibling = last;
2344 first->op_flags |= OPf_KIDS;
2345 ((LISTOP*)first)->op_first = last;
2347 ((LISTOP*)first)->op_last = last;
2352 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2360 if (first->op_type != (unsigned)type)
2361 return prepend_elem(type, (OP*)first, (OP*)last);
2363 if (last->op_type != (unsigned)type)
2364 return append_elem(type, (OP*)first, (OP*)last);
2366 first->op_last->op_sibling = last->op_first;
2367 first->op_last = last->op_last;
2368 first->op_flags |= (last->op_flags & OPf_KIDS);
2371 if (last->op_first && first->op_madprop) {
2372 MADPROP *mp = last->op_first->op_madprop;
2374 while (mp->mad_next)
2376 mp->mad_next = first->op_madprop;
2379 last->op_first->op_madprop = first->op_madprop;
2382 first->op_madprop = last->op_madprop;
2383 last->op_madprop = 0;
2392 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2400 if (last->op_type == (unsigned)type) {
2401 if (type == OP_LIST) { /* already a PUSHMARK there */
2402 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2403 ((LISTOP*)last)->op_first->op_sibling = first;
2404 if (!(first->op_flags & OPf_PARENS))
2405 last->op_flags &= ~OPf_PARENS;
2408 if (!(last->op_flags & OPf_KIDS)) {
2409 ((LISTOP*)last)->op_last = first;
2410 last->op_flags |= OPf_KIDS;
2412 first->op_sibling = ((LISTOP*)last)->op_first;
2413 ((LISTOP*)last)->op_first = first;
2415 last->op_flags |= OPf_KIDS;
2419 return newLISTOP(type, 0, first, last);
2427 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2430 Newxz(tk, 1, TOKEN);
2431 tk->tk_type = (OPCODE)optype;
2432 tk->tk_type = 12345;
2434 tk->tk_mad = madprop;
2439 Perl_token_free(pTHX_ TOKEN* tk)
2441 if (tk->tk_type != 12345)
2443 mad_free(tk->tk_mad);
2448 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2452 if (tk->tk_type != 12345) {
2453 Perl_warner(aTHX_ packWARN(WARN_MISC),
2454 "Invalid TOKEN object ignored");
2461 /* faked up qw list? */
2463 tm->mad_type == MAD_SV &&
2464 SvPVX((SV*)tm->mad_val)[0] == 'q')
2471 /* pretend constant fold didn't happen? */
2472 if (mp->mad_key == 'f' &&
2473 (o->op_type == OP_CONST ||
2474 o->op_type == OP_GV) )
2476 token_getmad(tk,(OP*)mp->mad_val,slot);
2490 if (mp->mad_key == 'X')
2491 mp->mad_key = slot; /* just change the first one */
2501 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2510 /* pretend constant fold didn't happen? */
2511 if (mp->mad_key == 'f' &&
2512 (o->op_type == OP_CONST ||
2513 o->op_type == OP_GV) )
2515 op_getmad(from,(OP*)mp->mad_val,slot);
2522 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2525 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2531 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2540 /* pretend constant fold didn't happen? */
2541 if (mp->mad_key == 'f' &&
2542 (o->op_type == OP_CONST ||
2543 o->op_type == OP_GV) )
2545 op_getmad(from,(OP*)mp->mad_val,slot);
2552 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2555 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2559 PerlIO_printf(PerlIO_stderr(),
2560 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2566 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2584 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2588 addmad(tm, &(o->op_madprop), slot);
2592 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2613 Perl_newMADsv(pTHX_ char key, SV* sv)
2615 return newMADPROP(key, MAD_SV, sv, 0);
2619 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2622 Newxz(mp, 1, MADPROP);
2625 mp->mad_vlen = vlen;
2626 mp->mad_type = type;
2628 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2633 Perl_mad_free(pTHX_ MADPROP* mp)
2635 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2639 mad_free(mp->mad_next);
2640 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2641 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2642 switch (mp->mad_type) {
2646 Safefree((char*)mp->mad_val);
2649 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2650 op_free((OP*)mp->mad_val);
2653 sv_free((SV*)mp->mad_val);
2656 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2665 Perl_newNULLLIST(pTHX)
2667 return newOP(OP_STUB, 0);
2671 Perl_force_list(pTHX_ OP *o)
2673 if (!o || o->op_type != OP_LIST)
2674 o = newLISTOP(OP_LIST, 0, o, NULL);
2680 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2685 NewOp(1101, listop, 1, LISTOP);
2687 listop->op_type = (OPCODE)type;
2688 listop->op_ppaddr = PL_ppaddr[type];
2691 listop->op_flags = (U8)flags;
2695 else if (!first && last)
2698 first->op_sibling = last;
2699 listop->op_first = first;
2700 listop->op_last = last;
2701 if (type == OP_LIST) {
2702 OP* const pushop = newOP(OP_PUSHMARK, 0);
2703 pushop->op_sibling = first;
2704 listop->op_first = pushop;
2705 listop->op_flags |= OPf_KIDS;
2707 listop->op_last = pushop;
2710 return CHECKOP(type, listop);
2714 Perl_newOP(pTHX_ I32 type, I32 flags)
2718 NewOp(1101, o, 1, OP);
2719 o->op_type = (OPCODE)type;
2720 o->op_ppaddr = PL_ppaddr[type];
2721 o->op_flags = (U8)flags;
2724 o->op_private = (U8)(0 | (flags >> 8));
2725 if (PL_opargs[type] & OA_RETSCALAR)
2727 if (PL_opargs[type] & OA_TARGET)
2728 o->op_targ = pad_alloc(type, SVs_PADTMP);
2729 return CHECKOP(type, o);
2733 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2739 first = newOP(OP_STUB, 0);
2740 if (PL_opargs[type] & OA_MARK)
2741 first = force_list(first);
2743 NewOp(1101, unop, 1, UNOP);
2744 unop->op_type = (OPCODE)type;
2745 unop->op_ppaddr = PL_ppaddr[type];
2746 unop->op_first = first;
2747 unop->op_flags = (U8)(flags | OPf_KIDS);
2748 unop->op_private = (U8)(1 | (flags >> 8));
2749 unop = (UNOP*) CHECKOP(type, unop);
2753 return fold_constants((OP *) unop);
2757 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2761 NewOp(1101, binop, 1, BINOP);
2764 first = newOP(OP_NULL, 0);
2766 binop->op_type = (OPCODE)type;
2767 binop->op_ppaddr = PL_ppaddr[type];
2768 binop->op_first = first;
2769 binop->op_flags = (U8)(flags | OPf_KIDS);
2772 binop->op_private = (U8)(1 | (flags >> 8));
2775 binop->op_private = (U8)(2 | (flags >> 8));
2776 first->op_sibling = last;
2779 binop = (BINOP*)CHECKOP(type, binop);
2780 if (binop->op_next || binop->op_type != (OPCODE)type)
2783 binop->op_last = binop->op_first->op_sibling;
2785 return fold_constants((OP *)binop);
2788 static int uvcompare(const void *a, const void *b)
2789 __attribute__nonnull__(1)
2790 __attribute__nonnull__(2)
2791 __attribute__pure__;
2792 static int uvcompare(const void *a, const void *b)
2794 if (*((const UV *)a) < (*(const UV *)b))
2796 if (*((const UV *)a) > (*(const UV *)b))
2798 if (*((const UV *)a+1) < (*(const UV *)b+1))
2800 if (*((const UV *)a+1) > (*(const UV *)b+1))
2806 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2809 SV * const tstr = ((SVOP*)expr)->op_sv;
2810 SV * const rstr = ((SVOP*)repl)->op_sv;
2813 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2814 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2818 register short *tbl;
2820 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2821 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2822 I32 del = o->op_private & OPpTRANS_DELETE;
2823 PL_hints |= HINT_BLOCK_SCOPE;
2826 o->op_private |= OPpTRANS_FROM_UTF;
2829 o->op_private |= OPpTRANS_TO_UTF;
2831 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2832 SV* const listsv = newSVpvs("# comment\n");
2834 const U8* tend = t + tlen;
2835 const U8* rend = r + rlen;
2849 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2850 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2853 const U32 flags = UTF8_ALLOW_DEFAULT;
2857 t = tsave = bytes_to_utf8(t, &len);
2860 if (!to_utf && rlen) {
2862 r = rsave = bytes_to_utf8(r, &len);
2866 /* There are several snags with this code on EBCDIC:
2867 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2868 2. scan_const() in toke.c has encoded chars in native encoding which makes
2869 ranges at least in EBCDIC 0..255 range the bottom odd.
2873 U8 tmpbuf[UTF8_MAXBYTES+1];
2876 Newx(cp, 2*tlen, UV);
2878 transv = newSVpvs("");
2880 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2882 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2884 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2888 cp[2*i+1] = cp[2*i];
2892 qsort(cp, i, 2*sizeof(UV), uvcompare);
2893 for (j = 0; j < i; j++) {
2895 diff = val - nextmin;
2897 t = uvuni_to_utf8(tmpbuf,nextmin);
2898 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2900 U8 range_mark = UTF_TO_NATIVE(0xff);
2901 t = uvuni_to_utf8(tmpbuf, val - 1);
2902 sv_catpvn(transv, (char *)&range_mark, 1);
2903 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2910 t = uvuni_to_utf8(tmpbuf,nextmin);
2911 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2913 U8 range_mark = UTF_TO_NATIVE(0xff);
2914 sv_catpvn(transv, (char *)&range_mark, 1);
2916 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2917 UNICODE_ALLOW_SUPER);
2918 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2919 t = (const U8*)SvPVX_const(transv);
2920 tlen = SvCUR(transv);
2924 else if (!rlen && !del) {
2925 r = t; rlen = tlen; rend = tend;
2928 if ((!rlen && !del) || t == r ||
2929 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2931 o->op_private |= OPpTRANS_IDENTICAL;
2935 while (t < tend || tfirst <= tlast) {
2936 /* see if we need more "t" chars */
2937 if (tfirst > tlast) {
2938 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2940 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2942 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2949 /* now see if we need more "r" chars */
2950 if (rfirst > rlast) {
2952 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2954 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2956 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2965 rfirst = rlast = 0xffffffff;
2969 /* now see which range will peter our first, if either. */
2970 tdiff = tlast - tfirst;
2971 rdiff = rlast - rfirst;
2978 if (rfirst == 0xffffffff) {
2979 diff = tdiff; /* oops, pretend rdiff is infinite */
2981 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2982 (long)tfirst, (long)tlast);
2984 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2988 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2989 (long)tfirst, (long)(tfirst + diff),
2992 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2993 (long)tfirst, (long)rfirst);
2995 if (rfirst + diff > max)
2996 max = rfirst + diff;
2998 grows = (tfirst < rfirst &&
2999 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3011 else if (max > 0xff)
3016 Safefree(cPVOPo->op_pv);
3017 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3018 SvREFCNT_dec(listsv);
3019 SvREFCNT_dec(transv);
3021 if (!del && havefinal && rlen)
3022 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3023 newSVuv((UV)final), 0);
3026 o->op_private |= OPpTRANS_GROWS;
3032 op_getmad(expr,o,'e');
3033 op_getmad(repl,o,'r');
3041 tbl = (short*)cPVOPo->op_pv;
3043 Zero(tbl, 256, short);
3044 for (i = 0; i < (I32)tlen; i++)
3046 for (i = 0, j = 0; i < 256; i++) {
3048 if (j >= (I32)rlen) {
3057 if (i < 128 && r[j] >= 128)
3067 o->op_private |= OPpTRANS_IDENTICAL;
3069 else if (j >= (I32)rlen)
3072 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3073 tbl[0x100] = (short)(rlen - j);
3074 for (i=0; i < (I32)rlen - j; i++)
3075 tbl[0x101+i] = r[j+i];
3079 if (!rlen && !del) {
3082 o->op_private |= OPpTRANS_IDENTICAL;
3084 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3085 o->op_private |= OPpTRANS_IDENTICAL;
3087 for (i = 0; i < 256; i++)
3089 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3090 if (j >= (I32)rlen) {
3092 if (tbl[t[i]] == -1)
3098 if (tbl[t[i]] == -1) {
3099 if (t[i] < 128 && r[j] >= 128)
3106 o->op_private |= OPpTRANS_GROWS;
3108 op_getmad(expr,o,'e');
3109 op_getmad(repl,o,'r');
3119 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3124 NewOp(1101, pmop, 1, PMOP);
3125 pmop->op_type = (OPCODE)type;
3126 pmop->op_ppaddr = PL_ppaddr[type];
3127 pmop->op_flags = (U8)flags;
3128 pmop->op_private = (U8)(0 | (flags >> 8));
3130 if (PL_hints & HINT_RE_TAINT)
3131 pmop->op_pmpermflags |= PMf_RETAINT;
3132 if (PL_hints & HINT_LOCALE)
3133 pmop->op_pmpermflags |= PMf_LOCALE;
3134 pmop->op_pmflags = pmop->op_pmpermflags;
3137 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3138 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3139 pmop->op_pmoffset = SvIV(repointer);
3140 SvREPADTMP_off(repointer);
3141 sv_setiv(repointer,0);
3143 SV * const repointer = newSViv(0);
3144 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3145 pmop->op_pmoffset = av_len(PL_regex_padav);
3146 PL_regex_pad = AvARRAY(PL_regex_padav);
3150 /* link into pm list */
3151 if (type != OP_TRANS && PL_curstash) {
3152 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3155 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3157 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3158 mg->mg_obj = (SV*)pmop;
3159 PmopSTASH_set(pmop,PL_curstash);
3162 return CHECKOP(type, pmop);
3165 /* Given some sort of match op o, and an expression expr containing a
3166 * pattern, either compile expr into a regex and attach it to o (if it's
3167 * constant), or convert expr into a runtime regcomp op sequence (if it's
3170 * isreg indicates that the pattern is part of a regex construct, eg
3171 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3172 * split "pattern", which aren't. In the former case, expr will be a list
3173 * if the pattern contains more than one term (eg /a$b/) or if it contains
3174 * a replacement, ie s/// or tr///.
3178 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3183 I32 repl_has_vars = 0;
3187 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3188 /* last element in list is the replacement; pop it */
3190 repl = cLISTOPx(expr)->op_last;
3191 kid = cLISTOPx(expr)->op_first;
3192 while (kid->op_sibling != repl)
3193 kid = kid->op_sibling;
3194 kid->op_sibling = NULL;
3195 cLISTOPx(expr)->op_last = kid;
3198 if (isreg && expr->op_type == OP_LIST &&
3199 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3201 /* convert single element list to element */
3202 OP* const oe = expr;
3203 expr = cLISTOPx(oe)->op_first->op_sibling;
3204 cLISTOPx(oe)->op_first->op_sibling = NULL;
3205 cLISTOPx(oe)->op_last = NULL;
3209 if (o->op_type == OP_TRANS) {
3210 return pmtrans(o, expr, repl);
3213 reglist = isreg && expr->op_type == OP_LIST;
3217 PL_hints |= HINT_BLOCK_SCOPE;
3220 if (expr->op_type == OP_CONST) {
3222 SV * const pat = ((SVOP*)expr)->op_sv;
3223 const char *p = SvPV_const(pat, plen);
3224 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3225 U32 was_readonly = SvREADONLY(pat);
3229 sv_force_normal_flags(pat, 0);
3230 assert(!SvREADONLY(pat));
3233 SvREADONLY_off(pat);
3237 sv_setpvn(pat, "\\s+", 3);
3239 SvFLAGS(pat) |= was_readonly;
3241 p = SvPV_const(pat, plen);
3242 pm->op_pmflags |= PMf_SKIPWHITE;
3245 pm->op_pmdynflags |= PMdf_UTF8;
3246 /* FIXME - can we make this function take const char * args? */
3247 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3248 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3249 pm->op_pmflags |= PMf_WHITE;
3251 op_getmad(expr,(OP*)pm,'e');
3257 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3258 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3260 : OP_REGCMAYBE),0,expr);
3262 NewOp(1101, rcop, 1, LOGOP);
3263 rcop->op_type = OP_REGCOMP;
3264 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3265 rcop->op_first = scalar(expr);
3266 rcop->op_flags |= OPf_KIDS
3267 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3268 | (reglist ? OPf_STACKED : 0);
3269 rcop->op_private = 1;
3272 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3274 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3277 /* establish postfix order */
3278 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3280 rcop->op_next = expr;
3281 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3284 rcop->op_next = LINKLIST(expr);
3285 expr->op_next = (OP*)rcop;
3288 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3293 if (pm->op_pmflags & PMf_EVAL) {
3295 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3296 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3298 else if (repl->op_type == OP_CONST)
3302 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3303 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3304 if (curop->op_type == OP_GV) {
3305 GV * const gv = cGVOPx_gv(curop);
3307 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3310 else if (curop->op_type == OP_RV2CV)
3312 else if (curop->op_type == OP_RV2SV ||
3313 curop->op_type == OP_RV2AV ||
3314 curop->op_type == OP_RV2HV ||
3315 curop->op_type == OP_RV2GV) {
3316 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3319 else if (curop->op_type == OP_PADSV ||
3320 curop->op_type == OP_PADAV ||
3321 curop->op_type == OP_PADHV ||
3322 curop->op_type == OP_PADANY) {
3325 else if (curop->op_type == OP_PUSHRE)
3326 NOOP; /* Okay here, dangerous in newASSIGNOP */
3336 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3337 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3338 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3339 prepend_elem(o->op_type, scalar(repl), o);
3342 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3343 pm->op_pmflags |= PMf_MAYBE_CONST;
3344 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3346 NewOp(1101, rcop, 1, LOGOP);
3347 rcop->op_type = OP_SUBSTCONT;
3348 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3349 rcop->op_first = scalar(repl);
3350 rcop->op_flags |= OPf_KIDS;
3351 rcop->op_private = 1;
3354 /* establish postfix order */
3355 rcop->op_next = LINKLIST(repl);
3356 repl->op_next = (OP*)rcop;
3358 pm->op_pmreplroot = scalar((OP*)rcop);
3359 pm->op_pmreplstart = LINKLIST(rcop);
3368 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3372 NewOp(1101, svop, 1, SVOP);
3373 svop->op_type = (OPCODE)type;
3374 svop->op_ppaddr = PL_ppaddr[type];
3376 svop->op_next = (OP*)svop;
3377 svop->op_flags = (U8)flags;
3378 if (PL_opargs[type] & OA_RETSCALAR)
3380 if (PL_opargs[type] & OA_TARGET)
3381 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3382 return CHECKOP(type, svop);
3386 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3390 NewOp(1101, padop, 1, PADOP);
3391 padop->op_type = (OPCODE)type;
3392 padop->op_ppaddr = PL_ppaddr[type];
3393 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3394 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3395 PAD_SETSV(padop->op_padix, sv);
3398 padop->op_next = (OP*)padop;
3399 padop->op_flags = (U8)flags;
3400 if (PL_opargs[type] & OA_RETSCALAR)
3402 if (PL_opargs[type] & OA_TARGET)
3403 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3404 return CHECKOP(type, padop);
3408 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3414 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3416 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3421 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3425 NewOp(1101, pvop, 1, PVOP);
3426 pvop->op_type = (OPCODE)type;
3427 pvop->op_ppaddr = PL_ppaddr[type];
3429 pvop->op_next = (OP*)pvop;
3430 pvop->op_flags = (U8)flags;
3431 if (PL_opargs[type] & OA_RETSCALAR)
3433 if (PL_opargs[type] & OA_TARGET)
3434 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3435 return CHECKOP(type, pvop);
3443 Perl_package(pTHX_ OP *o)
3452 save_hptr(&PL_curstash);
3453 save_item(PL_curstname);
3455 name = SvPV_const(cSVOPo->op_sv, len);
3456 PL_curstash = gv_stashpvn(name, len, TRUE);
3457 sv_setpvn(PL_curstname, name, len);
3459 PL_hints |= HINT_BLOCK_SCOPE;
3460 PL_copline = NOLINE;
3466 if (!PL_madskills) {
3471 pegop = newOP(OP_NULL,0);
3472 op_getmad(o,pegop,'P');
3482 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3489 OP *pegop = newOP(OP_NULL,0);
3492 if (idop->op_type != OP_CONST)
3493 Perl_croak(aTHX_ "Module name must be constant");
3496 op_getmad(idop,pegop,'U');
3501 SV * const vesv = ((SVOP*)version)->op_sv;
3504 op_getmad(version,pegop,'V');
3505 if (!arg && !SvNIOKp(vesv)) {
3512 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3513 Perl_croak(aTHX_ "Version number must be constant number");
3515 /* Make copy of idop so we don't free it twice */
3516 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3518 /* Fake up a method call to VERSION */
3519 meth = newSVpvs_share("VERSION");
3520 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3521 append_elem(OP_LIST,
3522 prepend_elem(OP_LIST, pack, list(version)),
3523 newSVOP(OP_METHOD_NAMED, 0, meth)));
3527 /* Fake up an import/unimport */
3528 if (arg && arg->op_type == OP_STUB) {
3530 op_getmad(arg,pegop,'S');
3531 imop = arg; /* no import on explicit () */
3533 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3534 imop = NULL; /* use 5.0; */
3536 idop->op_private |= OPpCONST_NOVER;
3542 op_getmad(arg,pegop,'A');
3544 /* Make copy of idop so we don't free it twice */
3545 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3547 /* Fake up a method call to import/unimport */
3549 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3550 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3551 append_elem(OP_LIST,
3552 prepend_elem(OP_LIST, pack, list(arg)),
3553 newSVOP(OP_METHOD_NAMED, 0, meth)));
3556 /* Fake up the BEGIN {}, which does its thing immediately. */
3558 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3561 append_elem(OP_LINESEQ,
3562 append_elem(OP_LINESEQ,
3563 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3564 newSTATEOP(0, NULL, veop)),
3565 newSTATEOP(0, NULL, imop) ));
3567 /* The "did you use incorrect case?" warning used to be here.
3568 * The problem is that on case-insensitive filesystems one
3569 * might get false positives for "use" (and "require"):
3570 * "use Strict" or "require CARP" will work. This causes
3571 * portability problems for the script: in case-strict
3572 * filesystems the script will stop working.
3574 * The "incorrect case" warning checked whether "use Foo"
3575 * imported "Foo" to your namespace, but that is wrong, too:
3576 * there is no requirement nor promise in the language that
3577 * a Foo.pm should or would contain anything in package "Foo".
3579 * There is very little Configure-wise that can be done, either:
3580 * the case-sensitivity of the build filesystem of Perl does not
3581 * help in guessing the case-sensitivity of the runtime environment.
3584 PL_hints |= HINT_BLOCK_SCOPE;
3585 PL_copline = NOLINE;
3587 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3590 if (!PL_madskills) {
3591 /* FIXME - don't allocate pegop if !PL_madskills */
3600 =head1 Embedding Functions
3602 =for apidoc load_module
3604 Loads the module whose name is pointed to by the string part of name.
3605 Note that the actual module name, not its filename, should be given.
3606 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3607 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3608 (or 0 for no flags). ver, if specified, provides version semantics
3609 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3610 arguments can be used to specify arguments to the module's import()
3611 method, similar to C<use Foo::Bar VERSION LIST>.
3616 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3619 va_start(args, ver);
3620 vload_module(flags, name, ver, &args);
3624 #ifdef PERL_IMPLICIT_CONTEXT
3626 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3630 va_start(args, ver);
3631 vload_module(flags, name, ver, &args);
3637 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3642 OP * const modname = newSVOP(OP_CONST, 0, name);
3643 modname->op_private |= OPpCONST_BARE;
3645 veop = newSVOP(OP_CONST, 0, ver);
3649 if (flags & PERL_LOADMOD_NOIMPORT) {
3650 imop = sawparens(newNULLLIST());
3652 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3653 imop = va_arg(*args, OP*);
3658 sv = va_arg(*args, SV*);
3660 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3661 sv = va_arg(*args, SV*);
3665 const line_t ocopline = PL_copline;
3666 COP * const ocurcop = PL_curcop;
3667 const int oexpect = PL_expect;
3669 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3670 veop, modname, imop);
3671 PL_expect = oexpect;
3672 PL_copline = ocopline;
3673 PL_curcop = ocurcop;
3678 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3684 if (!force_builtin) {
3685 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3686 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3687 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3688 gv = gvp ? *gvp : NULL;
3692 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3693 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3694 append_elem(OP_LIST, term,
3695 scalar(newUNOP(OP_RV2CV, 0,
3696 newGVOP(OP_GV, 0, gv))))));
3699 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3705 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3707 return newBINOP(OP_LSLICE, flags,
3708 list(force_list(subscript)),
3709 list(force_list(listval)) );
3713 S_is_list_assignment(pTHX_ register const OP *o)
3721 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3722 o = cUNOPo->op_first;
3724 flags = o->op_flags;
3726 if (type == OP_COND_EXPR) {
3727 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3728 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3733 yyerror("Assignment to both a list and a scalar");
3737 if (type == OP_LIST &&
3738 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3739 o->op_private & OPpLVAL_INTRO)
3742 if (type == OP_LIST || flags & OPf_PARENS ||
3743 type == OP_RV2AV || type == OP_RV2HV ||
3744 type == OP_ASLICE || type == OP_HSLICE)
3747 if (type == OP_PADAV || type == OP_PADHV)
3750 if (type == OP_RV2SV)
3757 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3763 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3764 return newLOGOP(optype, 0,
3765 mod(scalar(left), optype),
3766 newUNOP(OP_SASSIGN, 0, scalar(right)));
3769 return newBINOP(optype, OPf_STACKED,
3770 mod(scalar(left), optype), scalar(right));
3774 if (is_list_assignment(left)) {
3778 /* Grandfathering $[ assignment here. Bletch.*/
3779 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3780 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3781 left = mod(left, OP_AASSIGN);
3784 else if (left->op_type == OP_CONST) {
3786 /* Result of assignment is always 1 (or we'd be dead already) */
3787 return newSVOP(OP_CONST, 0, newSViv(1));
3789 curop = list(force_list(left));
3790 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3791 o->op_private = (U8)(0 | (flags >> 8));
3793 /* PL_generation sorcery:
3794 * an assignment like ($a,$b) = ($c,$d) is easier than
3795 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3796 * To detect whether there are common vars, the global var
3797 * PL_generation is incremented for each assign op we compile.
3798 * Then, while compiling the assign op, we run through all the
3799 * variables on both sides of the assignment, setting a spare slot
3800 * in each of them to PL_generation. If any of them already have
3801 * that value, we know we've got commonality. We could use a
3802 * single bit marker, but then we'd have to make 2 passes, first
3803 * to clear the flag, then to test and set it. To find somewhere
3804 * to store these values, evil chicanery is done with SvCUR().
3807 if (!(left->op_private & OPpLVAL_INTRO)) {
3810 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3811 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3812 if (curop->op_type == OP_GV) {
3813 GV *gv = cGVOPx_gv(curop);
3815 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3817 GvASSIGN_GENERATION_set(gv, PL_generation);
3819 else if (curop->op_type == OP_PADSV ||
3820 curop->op_type == OP_PADAV ||
3821 curop->op_type == OP_PADHV ||
3822 curop->op_type == OP_PADANY)
3824 if (PAD_COMPNAME_GEN(curop->op_targ)
3825 == (STRLEN)PL_generation)
3827 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3830 else if (curop->op_type == OP_RV2CV)
3832 else if (curop->op_type == OP_RV2SV ||
3833 curop->op_type == OP_RV2AV ||
3834 curop->op_type == OP_RV2HV ||
3835 curop->op_type == OP_RV2GV) {
3836 if (lastop->op_type != OP_GV) /* funny deref? */
3839 else if (curop->op_type == OP_PUSHRE) {
3840 if (((PMOP*)curop)->op_pmreplroot) {
3842 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3843 ((PMOP*)curop)->op_pmreplroot));
3845 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3848 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3850 GvASSIGN_GENERATION_set(gv, PL_generation);
3851 GvASSIGN_GENERATION_set(gv, PL_generation);
3860 o->op_private |= OPpASSIGN_COMMON;
3862 if (right && right->op_type == OP_SPLIT) {
3863 OP* tmpop = ((LISTOP*)right)->op_first;
3864 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3865 PMOP * const pm = (PMOP*)tmpop;
3866 if (left->op_type == OP_RV2AV &&
3867 !(left->op_private & OPpLVAL_INTRO) &&
3868 !(o->op_private & OPpASSIGN_COMMON) )
3870 tmpop = ((UNOP*)left)->op_first;
3871 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3873 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3874 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3876 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3877 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3879 pm->op_pmflags |= PMf_ONCE;
3880 tmpop = cUNOPo->op_first; /* to list (nulled) */
3881 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3882 tmpop->op_sibling = NULL; /* don't free split */
3883 right->op_next = tmpop->op_next; /* fix starting loc */
3885 op_getmad(o,right,'R'); /* blow off assign */
3887 op_free(o); /* blow off assign */
3889 right->op_flags &= ~OPf_WANT;
3890 /* "I don't know and I don't care." */
3895 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3896 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3898 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3900 sv_setiv(sv, PL_modcount+1);
3908 right = newOP(OP_UNDEF, 0);
3909 if (right->op_type == OP_READLINE) {
3910 right->op_flags |= OPf_STACKED;
3911 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3914 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3915 o = newBINOP(OP_SASSIGN, flags,
3916 scalar(right), mod(scalar(left), OP_SASSIGN) );
3922 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3923 o->op_private |= OPpCONST_ARYBASE;
3930 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3933 const U32 seq = intro_my();
3936 NewOp(1101, cop, 1, COP);
3937 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3938 cop->op_type = OP_DBSTATE;
3939 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3942 cop->op_type = OP_NEXTSTATE;
3943 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3945 cop->op_flags = (U8)flags;
3946 CopHINTS_set(cop, PL_hints);
3948 cop->op_private |= NATIVE_HINTS;
3950 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3951 cop->op_next = (OP*)cop;
3954 cop->cop_label = label;
3955 PL_hints |= HINT_BLOCK_SCOPE;
3958 CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
3959 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3960 if (specialCopIO(PL_curcop->cop_io))
3961 cop->cop_io = PL_curcop->cop_io;
3963 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3964 cop->cop_hints = PL_curcop->cop_hints;
3965 if (cop->cop_hints) {
3967 cop->cop_hints->refcounted_he_refcnt++;
3968 HINTS_REFCNT_UNLOCK;
3971 if (PL_copline == NOLINE)
3972 CopLINE_set(cop, CopLINE(PL_curcop));
3974 CopLINE_set(cop, PL_copline);
3975 PL_copline = NOLINE;
3978 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3980 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3982 CopSTASH_set(cop, PL_curstash);
3984 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3985 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3986 if (svp && *svp != &PL_sv_undef ) {
3987 (void)SvIOK_on(*svp);
3988 SvIV_set(*svp, PTR2IV(cop));
3992 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3997 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4000 return new_logop(type, flags, &first, &other);
4004 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4009 OP *first = *firstp;
4010 OP * const other = *otherp;
4012 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4013 return newBINOP(type, flags, scalar(first), scalar(other));
4015 scalarboolean(first);
4016 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4017 if (first->op_type == OP_NOT
4018 && (first->op_flags & OPf_SPECIAL)
4019 && (first->op_flags & OPf_KIDS)) {
4020 if (type == OP_AND || type == OP_OR) {
4026 first = *firstp = cUNOPo->op_first;
4028 first->op_next = o->op_next;
4029 cUNOPo->op_first = NULL;
4031 op_getmad(o,first,'O');
4037 if (first->op_type == OP_CONST) {
4038 if (first->op_private & OPpCONST_STRICT)
4039 no_bareword_allowed(first);
4040 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4041 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4042 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4043 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4044 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4046 if (other->op_type == OP_CONST)
4047 other->op_private |= OPpCONST_SHORTCIRCUIT;
4049 OP *newop = newUNOP(OP_NULL, 0, other);
4050 op_getmad(first, newop, '1');
4051 newop->op_targ = type; /* set "was" field */
4058 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4059 const OP *o2 = other;
4060 if ( ! (o2->op_type == OP_LIST
4061 && (( o2 = cUNOPx(o2)->op_first))
4062 && o2->op_type == OP_PUSHMARK
4063 && (( o2 = o2->op_sibling)) )
4066 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4067 || o2->op_type == OP_PADHV)
4068 && o2->op_private & OPpLVAL_INTRO
4069 && ckWARN(WARN_DEPRECATED))
4071 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4072 "Deprecated use of my() in false conditional");
4076 if (first->op_type == OP_CONST)
4077 first->op_private |= OPpCONST_SHORTCIRCUIT;
4079 first = newUNOP(OP_NULL, 0, first);
4080 op_getmad(other, first, '2');
4081 first->op_targ = type; /* set "was" field */
4088 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4089 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4091 const OP * const k1 = ((UNOP*)first)->op_first;
4092 const OP * const k2 = k1->op_sibling;
4094 switch (first->op_type)
4097 if (k2 && k2->op_type == OP_READLINE
4098 && (k2->op_flags & OPf_STACKED)
4099 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4101 warnop = k2->op_type;
4106 if (k1->op_type == OP_READDIR
4107 || k1->op_type == OP_GLOB
4108 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4109 || k1->op_type == OP_EACH)
4111 warnop = ((k1->op_type == OP_NULL)
4112 ? (OPCODE)k1->op_targ : k1->op_type);
4117 const line_t oldline = CopLINE(PL_curcop);
4118 CopLINE_set(PL_curcop, PL_copline);
4119 Perl_warner(aTHX_ packWARN(WARN_MISC),
4120 "Value of %s%s can be \"0\"; test with defined()",
4122 ((warnop == OP_READLINE || warnop == OP_GLOB)
4123 ? " construct" : "() operator"));
4124 CopLINE_set(PL_curcop, oldline);
4131 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4132 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4134 NewOp(1101, logop, 1, LOGOP);
4136 logop->op_type = (OPCODE)type;
4137 logop->op_ppaddr = PL_ppaddr[type];
4138 logop->op_first = first;
4139 logop->op_flags = (U8)(flags | OPf_KIDS);
4140 logop->op_other = LINKLIST(other);
4141 logop->op_private = (U8)(1 | (flags >> 8));
4143 /* establish postfix order */
4144 logop->op_next = LINKLIST(first);
4145 first->op_next = (OP*)logop;
4146 first->op_sibling = other;
4148 CHECKOP(type,logop);
4150 o = newUNOP(OP_NULL, 0, (OP*)logop);
4157 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4165 return newLOGOP(OP_AND, 0, first, trueop);
4167 return newLOGOP(OP_OR, 0, first, falseop);
4169 scalarboolean(first);
4170 if (first->op_type == OP_CONST) {
4171 if (first->op_private & OPpCONST_BARE &&
4172 first->op_private & OPpCONST_STRICT) {
4173 no_bareword_allowed(first);
4175 if (SvTRUE(((SVOP*)first)->op_sv)) {
4178 trueop = newUNOP(OP_NULL, 0, trueop);
4179 op_getmad(first,trueop,'C');
4180 op_getmad(falseop,trueop,'e');
4182 /* FIXME for MAD - should there be an ELSE here? */
4192 falseop = newUNOP(OP_NULL, 0, falseop);
4193 op_getmad(first,falseop,'C');
4194 op_getmad(trueop,falseop,'t');
4196 /* FIXME for MAD - should there be an ELSE here? */
4204 NewOp(1101, logop, 1, LOGOP);
4205 logop->op_type = OP_COND_EXPR;
4206 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4207 logop->op_first = first;
4208 logop->op_flags = (U8)(flags | OPf_KIDS);
4209 logop->op_private = (U8)(1 | (flags >> 8));
4210 logop->op_other = LINKLIST(trueop);
4211 logop->op_next = LINKLIST(falseop);
4213 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4216 /* establish postfix order */
4217 start = LINKLIST(first);
4218 first->op_next = (OP*)logop;
4220 first->op_sibling = trueop;
4221 trueop->op_sibling = falseop;
4222 o = newUNOP(OP_NULL, 0, (OP*)logop);
4224 trueop->op_next = falseop->op_next = o;
4231 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4240 NewOp(1101, range, 1, LOGOP);
4242 range->op_type = OP_RANGE;
4243 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4244 range->op_first = left;
4245 range->op_flags = OPf_KIDS;
4246 leftstart = LINKLIST(left);
4247 range->op_other = LINKLIST(right);
4248 range->op_private = (U8)(1 | (flags >> 8));
4250 left->op_sibling = right;
4252 range->op_next = (OP*)range;
4253 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4254 flop = newUNOP(OP_FLOP, 0, flip);
4255 o = newUNOP(OP_NULL, 0, flop);
4257 range->op_next = leftstart;
4259 left->op_next = flip;
4260 right->op_next = flop;
4262 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4263 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4264 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4265 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4267 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4268 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4271 if (!flip->op_private || !flop->op_private)
4272 linklist(o); /* blow off optimizer unless constant */
4278 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4283 const bool once = block && block->op_flags & OPf_SPECIAL &&
4284 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4286 PERL_UNUSED_ARG(debuggable);
4289 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4290 return block; /* do {} while 0 does once */
4291 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4292 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4293 expr = newUNOP(OP_DEFINED, 0,
4294 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4295 } else if (expr->op_flags & OPf_KIDS) {
4296 const OP * const k1 = ((UNOP*)expr)->op_first;
4297 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4298 switch (expr->op_type) {
4300 if (k2 && k2->op_type == OP_READLINE
4301 && (k2->op_flags & OPf_STACKED)
4302 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4303 expr = newUNOP(OP_DEFINED, 0, expr);
4307 if (k1 && (k1->op_type == OP_READDIR
4308 || k1->op_type == OP_GLOB
4309 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4310 || k1->op_type == OP_EACH))
4311 expr = newUNOP(OP_DEFINED, 0, expr);
4317 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4318 * op, in listop. This is wrong. [perl #27024] */
4320 block = newOP(OP_NULL, 0);
4321 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4322 o = new_logop(OP_AND, 0, &expr, &listop);
4325 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4327 if (once && o != listop)
4328 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4331 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4333 o->op_flags |= flags;
4335 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4340 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4341 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4350 PERL_UNUSED_ARG(debuggable);
4353 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4354 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4355 expr = newUNOP(OP_DEFINED, 0,
4356 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4357 } else if (expr->op_flags & OPf_KIDS) {
4358 const OP * const k1 = ((UNOP*)expr)->op_first;
4359 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4360 switch (expr->op_type) {
4362 if (k2 && k2->op_type == OP_READLINE
4363 && (k2->op_flags & OPf_STACKED)
4364 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4365 expr = newUNOP(OP_DEFINED, 0, expr);
4369 if (k1 && (k1->op_type == OP_READDIR
4370 || k1->op_type == OP_GLOB
4371 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4372 || k1->op_type == OP_EACH))
4373 expr = newUNOP(OP_DEFINED, 0, expr);
4380 block = newOP(OP_NULL, 0);
4381 else if (cont || has_my) {
4382 block = scope(block);
4386 next = LINKLIST(cont);
4389 OP * const unstack = newOP(OP_UNSTACK, 0);
4392 cont = append_elem(OP_LINESEQ, cont, unstack);
4396 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4398 redo = LINKLIST(listop);
4401 PL_copline = (line_t)whileline;
4403 o = new_logop(OP_AND, 0, &expr, &listop);
4404 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4405 op_free(expr); /* oops, it's a while (0) */
4407 return NULL; /* listop already freed by new_logop */
4410 ((LISTOP*)listop)->op_last->op_next =
4411 (o == listop ? redo : LINKLIST(o));
4417 NewOp(1101,loop,1,LOOP);
4418 loop->op_type = OP_ENTERLOOP;
4419 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4420 loop->op_private = 0;
4421 loop->op_next = (OP*)loop;
4424 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4426 loop->op_redoop = redo;
4427 loop->op_lastop = o;
4428 o->op_private |= loopflags;
4431 loop->op_nextop = next;
4433 loop->op_nextop = o;
4435 o->op_flags |= flags;
4436 o->op_private |= (flags >> 8);
4441 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4446 PADOFFSET padoff = 0;
4452 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4453 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4454 sv->op_type = OP_RV2GV;
4455 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4456 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4457 iterpflags |= OPpITER_DEF;
4459 else if (sv->op_type == OP_PADSV) { /* private variable */
4460 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4461 padoff = sv->op_targ;
4470 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4471 padoff = sv->op_targ;
4476 iterflags |= OPf_SPECIAL;
4482 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4483 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4484 iterpflags |= OPpITER_DEF;
4487 const PADOFFSET offset = pad_findmy("$_");
4488 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4489 sv = newGVOP(OP_GV, 0, PL_defgv);
4494 iterpflags |= OPpITER_DEF;
4496 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4497 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4498 iterflags |= OPf_STACKED;
4500 else if (expr->op_type == OP_NULL &&
4501 (expr->op_flags & OPf_KIDS) &&
4502 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4504 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4505 * set the STACKED flag to indicate that these values are to be
4506 * treated as min/max values by 'pp_iterinit'.
4508 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4509 LOGOP* const range = (LOGOP*) flip->op_first;
4510 OP* const left = range->op_first;
4511 OP* const right = left->op_sibling;
4514 range->op_flags &= ~OPf_KIDS;
4515 range->op_first = NULL;
4517 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4518 listop->op_first->op_next = range->op_next;
4519 left->op_next = range->op_other;
4520 right->op_next = (OP*)listop;
4521 listop->op_next = listop->op_first;
4524 op_getmad(expr,(OP*)listop,'O');
4528 expr = (OP*)(listop);
4530 iterflags |= OPf_STACKED;
4533 expr = mod(force_list(expr), OP_GREPSTART);
4536 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4537 append_elem(OP_LIST, expr, scalar(sv))));
4538 assert(!loop->op_next);
4539 /* for my $x () sets OPpLVAL_INTRO;
4540 * for our $x () sets OPpOUR_INTRO */
4541 loop->op_private = (U8)iterpflags;
4542 #ifdef PL_OP_SLAB_ALLOC
4545 NewOp(1234,tmp,1,LOOP);
4546 Copy(loop,tmp,1,LISTOP);
4551 loop = PerlMemShared_realloc(loop, sizeof(LOOP));
4553 loop->op_targ = padoff;
4554 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4556 op_getmad(madsv, (OP*)loop, 'v');
4557 PL_copline = forline;
4558 return newSTATEOP(0, label, wop);
4562 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4567 if (type != OP_GOTO || label->op_type == OP_CONST) {
4568 /* "last()" means "last" */
4569 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4570 o = newOP(type, OPf_SPECIAL);
4572 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4573 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4577 op_getmad(label,o,'L');
4583 /* Check whether it's going to be a goto &function */
4584 if (label->op_type == OP_ENTERSUB
4585 && !(label->op_flags & OPf_STACKED))
4586 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4587 o = newUNOP(type, OPf_STACKED, label);
4589 PL_hints |= HINT_BLOCK_SCOPE;
4593 /* if the condition is a literal array or hash
4594 (or @{ ... } etc), make a reference to it.
4597 S_ref_array_or_hash(pTHX_ OP *cond)
4600 && (cond->op_type == OP_RV2AV
4601 || cond->op_type == OP_PADAV
4602 || cond->op_type == OP_RV2HV
4603 || cond->op_type == OP_PADHV))
4605 return newUNOP(OP_REFGEN,
4606 0, mod(cond, OP_REFGEN));
4612 /* These construct the optree fragments representing given()
4615 entergiven and enterwhen are LOGOPs; the op_other pointer
4616 points up to the associated leave op. We need this so we
4617 can put it in the context and make break/continue work.
4618 (Also, of course, pp_enterwhen will jump straight to
4619 op_other if the match fails.)
4624 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4625 I32 enter_opcode, I32 leave_opcode,
4626 PADOFFSET entertarg)
4632 NewOp(1101, enterop, 1, LOGOP);
4633 enterop->op_type = enter_opcode;
4634 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4635 enterop->op_flags = (U8) OPf_KIDS;
4636 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4637 enterop->op_private = 0;
4639 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4642 enterop->op_first = scalar(cond);
4643 cond->op_sibling = block;
4645 o->op_next = LINKLIST(cond);
4646 cond->op_next = (OP *) enterop;
4649 /* This is a default {} block */
4650 enterop->op_first = block;
4651 enterop->op_flags |= OPf_SPECIAL;
4653 o->op_next = (OP *) enterop;
4656 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4657 entergiven and enterwhen both
4660 enterop->op_next = LINKLIST(block);
4661 block->op_next = enterop->op_other = o;
4666 /* Does this look like a boolean operation? For these purposes
4667 a boolean operation is:
4668 - a subroutine call [*]
4669 - a logical connective
4670 - a comparison operator
4671 - a filetest operator, with the exception of -s -M -A -C
4672 - defined(), exists() or eof()
4673 - /$re/ or $foo =~ /$re/
4675 [*] possibly surprising
4679 S_looks_like_bool(pTHX_ const OP *o)
4682 switch(o->op_type) {
4684 return looks_like_bool(cLOGOPo->op_first);
4688 looks_like_bool(cLOGOPo->op_first)
4689 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4693 case OP_NOT: case OP_XOR:
4694 /* Note that OP_DOR is not here */
4696 case OP_EQ: case OP_NE: case OP_LT:
4697 case OP_GT: case OP_LE: case OP_GE:
4699 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4700 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4702 case OP_SEQ: case OP_SNE: case OP_SLT:
4703 case OP_SGT: case OP_SLE: case OP_SGE:
4707 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4708 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4709 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4710 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4711 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4712 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4713 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4714 case OP_FTTEXT: case OP_FTBINARY:
4716 case OP_DEFINED: case OP_EXISTS:
4717 case OP_MATCH: case OP_EOF:
4722 /* Detect comparisons that have been optimized away */
4723 if (cSVOPo->op_sv == &PL_sv_yes
4724 || cSVOPo->op_sv == &PL_sv_no)
4735 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4739 return newGIVWHENOP(
4740 ref_array_or_hash(cond),
4742 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4746 /* If cond is null, this is a default {} block */
4748 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4750 const bool cond_llb = (!cond || looks_like_bool(cond));
4756 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4758 scalar(ref_array_or_hash(cond)));
4761 return newGIVWHENOP(
4763 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4764 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4768 =for apidoc cv_undef
4770 Clear out all the active components of a CV. This can happen either
4771 by an explicit C<undef &foo>, or by the reference count going to zero.
4772 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4773 children can still follow the full lexical scope chain.
4779 Perl_cv_undef(pTHX_ CV *cv)
4783 if (CvFILE(cv) && !CvISXSUB(cv)) {
4784 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4785 Safefree(CvFILE(cv));
4790 if (!CvISXSUB(cv) && CvROOT(cv)) {
4791 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4792 Perl_croak(aTHX_ "Can't undef active subroutine");
4795 PAD_SAVE_SETNULLPAD();
4797 op_free(CvROOT(cv));
4802 SvPOK_off((SV*)cv); /* forget prototype */
4807 /* remove CvOUTSIDE unless this is an undef rather than a free */
4808 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4809 if (!CvWEAKOUTSIDE(cv))
4810 SvREFCNT_dec(CvOUTSIDE(cv));
4811 CvOUTSIDE(cv) = NULL;
4814 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4817 if (CvISXSUB(cv) && CvXSUB(cv)) {
4820 /* delete all flags except WEAKOUTSIDE */
4821 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4825 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4828 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4829 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4830 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4831 || (p && (len != SvCUR(cv) /* Not the same length. */
4832 || memNE(p, SvPVX_const(cv), len))))
4833 && ckWARN_d(WARN_PROTOTYPE)) {
4834 SV* const msg = sv_newmortal();
4838 gv_efullname3(name = sv_newmortal(), gv, NULL);
4839 sv_setpv(msg, "Prototype mismatch:");
4841 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4843 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4845 sv_catpvs(msg, ": none");
4846 sv_catpvs(msg, " vs ");
4848 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4850 sv_catpvs(msg, "none");
4851 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4855 static void const_sv_xsub(pTHX_ CV* cv);
4859 =head1 Optree Manipulation Functions
4861 =for apidoc cv_const_sv
4863 If C<cv> is a constant sub eligible for inlining. returns the constant
4864 value returned by the sub. Otherwise, returns NULL.
4866 Constant subs can be created with C<newCONSTSUB> or as described in
4867 L<perlsub/"Constant Functions">.
4872 Perl_cv_const_sv(pTHX_ CV *cv)
4874 PERL_UNUSED_CONTEXT;
4877 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4879 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4882 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4883 * Can be called in 3 ways:
4886 * look for a single OP_CONST with attached value: return the value
4888 * cv && CvCLONE(cv) && !CvCONST(cv)
4890 * examine the clone prototype, and if contains only a single
4891 * OP_CONST referencing a pad const, or a single PADSV referencing
4892 * an outer lexical, return a non-zero value to indicate the CV is
4893 * a candidate for "constizing" at clone time
4897 * We have just cloned an anon prototype that was marked as a const
4898 * candidiate. Try to grab the current value, and in the case of
4899 * PADSV, ignore it if it has multiple references. Return the value.
4903 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4911 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4912 o = cLISTOPo->op_first->op_sibling;
4914 for (; o; o = o->op_next) {
4915 const OPCODE type = o->op_type;
4917 if (sv && o->op_next == o)
4919 if (o->op_next != o) {
4920 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4922 if (type == OP_DBSTATE)
4925 if (type == OP_LEAVESUB || type == OP_RETURN)
4929 if (type == OP_CONST && cSVOPo->op_sv)
4931 else if (cv && type == OP_CONST) {
4932 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4936 else if (cv && type == OP_PADSV) {
4937 if (CvCONST(cv)) { /* newly cloned anon */
4938 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4939 /* the candidate should have 1 ref from this pad and 1 ref
4940 * from the parent */
4941 if (!sv || SvREFCNT(sv) != 2)
4948 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4949 sv = &PL_sv_undef; /* an arbitrary non-null value */
4964 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4967 /* This would be the return value, but the return cannot be reached. */
4968 OP* pegop = newOP(OP_NULL, 0);
4971 PERL_UNUSED_ARG(floor);
4981 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4983 NORETURN_FUNCTION_END;
4988 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4990 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4994 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5001 register CV *cv = NULL;
5003 /* If the subroutine has no body, no attributes, and no builtin attributes
5004 then it's just a sub declaration, and we may be able to get away with
5005 storing with a placeholder scalar in the symbol table, rather than a
5006 full GV and CV. If anything is present then it will take a full CV to
5008 const I32 gv_fetch_flags
5009 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5011 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5012 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5015 assert(proto->op_type == OP_CONST);
5016 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5021 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5022 SV * const sv = sv_newmortal();
5023 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5024 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5025 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5026 aname = SvPVX_const(sv);
5031 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5032 : gv_fetchpv(aname ? aname
5033 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5034 gv_fetch_flags, SVt_PVCV);
5036 if (!PL_madskills) {
5045 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5046 maximum a prototype before. */
5047 if (SvTYPE(gv) > SVt_NULL) {
5048 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5049 && ckWARN_d(WARN_PROTOTYPE))
5051 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5053 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5056 sv_setpvn((SV*)gv, ps, ps_len);
5058 sv_setiv((SV*)gv, -1);
5059 SvREFCNT_dec(PL_compcv);
5060 cv = PL_compcv = NULL;
5061 PL_sub_generation++;
5065 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5067 #ifdef GV_UNIQUE_CHECK
5068 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5069 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5073 if (!block || !ps || *ps || attrs
5074 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5076 || block->op_type == OP_NULL
5081 const_sv = op_const_sv(block, NULL);
5084 const bool exists = CvROOT(cv) || CvXSUB(cv);
5086 #ifdef GV_UNIQUE_CHECK
5087 if (exists && GvUNIQUE(gv)) {
5088 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5092 /* if the subroutine doesn't exist and wasn't pre-declared
5093 * with a prototype, assume it will be AUTOLOADed,
5094 * skipping the prototype check
5096 if (exists || SvPOK(cv))
5097 cv_ckproto_len(cv, gv, ps, ps_len);
5098 /* already defined (or promised)? */
5099 if (exists || GvASSUMECV(gv)) {
5102 || block->op_type == OP_NULL
5105 if (CvFLAGS(PL_compcv)) {
5106 /* might have had built-in attrs applied */
5107 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5109 /* just a "sub foo;" when &foo is already defined */
5110 SAVEFREESV(PL_compcv);
5115 && block->op_type != OP_NULL
5118 if (ckWARN(WARN_REDEFINE)
5120 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5122 const line_t oldline = CopLINE(PL_curcop);
5123 if (PL_copline != NOLINE)
5124 CopLINE_set(PL_curcop, PL_copline);
5125 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5126 CvCONST(cv) ? "Constant subroutine %s redefined"
5127 : "Subroutine %s redefined", name);
5128 CopLINE_set(PL_curcop, oldline);
5131 if (!PL_minus_c) /* keep old one around for madskills */
5134 /* (PL_madskills unset in used file.) */
5142 SvREFCNT_inc_simple_void_NN(const_sv);
5144 assert(!CvROOT(cv) && !CvCONST(cv));
5145 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5146 CvXSUBANY(cv).any_ptr = const_sv;
5147 CvXSUB(cv) = const_sv_xsub;
5153 cv = newCONSTSUB(NULL, name, const_sv);
5155 PL_sub_generation++;
5159 SvREFCNT_dec(PL_compcv);
5167 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5168 * before we clobber PL_compcv.
5172 || block->op_type == OP_NULL
5176 /* Might have had built-in attributes applied -- propagate them. */
5177 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5178 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5179 stash = GvSTASH(CvGV(cv));
5180 else if (CvSTASH(cv))
5181 stash = CvSTASH(cv);
5183 stash = PL_curstash;
5186 /* possibly about to re-define existing subr -- ignore old cv */
5187 rcv = (SV*)PL_compcv;
5188 if (name && GvSTASH(gv))
5189 stash = GvSTASH(gv);
5191 stash = PL_curstash;
5193 apply_attrs(stash, rcv, attrs, FALSE);
5195 if (cv) { /* must reuse cv if autoloaded */
5202 || block->op_type == OP_NULL) && !PL_madskills
5205 /* got here with just attrs -- work done, so bug out */
5206 SAVEFREESV(PL_compcv);
5209 /* transfer PL_compcv to cv */
5211 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5212 if (!CvWEAKOUTSIDE(cv))
5213 SvREFCNT_dec(CvOUTSIDE(cv));
5214 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5215 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5216 CvOUTSIDE(PL_compcv) = 0;
5217 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5218 CvPADLIST(PL_compcv) = 0;
5219 /* inner references to PL_compcv must be fixed up ... */
5220 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5221 /* ... before we throw it away */
5222 SvREFCNT_dec(PL_compcv);
5224 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5225 ++PL_sub_generation;
5232 if (strEQ(name, "import")) {
5233 PL_formfeed = (SV*)cv;
5234 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5238 PL_sub_generation++;
5242 CvFILE_set_from_cop(cv, PL_curcop);
5243 CvSTASH(cv) = PL_curstash;
5246 sv_setpvn((SV*)cv, ps, ps_len);
5248 if (PL_error_count) {
5252 const char *s = strrchr(name, ':');
5254 if (strEQ(s, "BEGIN")) {
5255 const char not_safe[] =
5256 "BEGIN not safe after errors--compilation aborted";
5257 if (PL_in_eval & EVAL_KEEPERR)
5258 Perl_croak(aTHX_ not_safe);
5260 /* force display of errors found but not reported */
5261 sv_catpv(ERRSV, not_safe);
5262 Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
5272 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5273 mod(scalarseq(block), OP_LEAVESUBLV));
5276 /* This makes sub {}; work as expected. */
5277 if (block->op_type == OP_STUB) {
5278 OP* const newblock = newSTATEOP(0, NULL, 0);
5280 op_getmad(block,newblock,'B');
5286 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5288 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5289 OpREFCNT_set(CvROOT(cv), 1);
5290 CvSTART(cv) = LINKLIST(CvROOT(cv));
5291 CvROOT(cv)->op_next = 0;
5292 CALL_PEEP(CvSTART(cv));
5294 /* now that optimizer has done its work, adjust pad values */
5296 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5299 assert(!CvCONST(cv));
5300 if (ps && !*ps && op_const_sv(block, cv))
5304 if (name || aname) {
5306 const char * const tname = (name ? name : aname);
5308 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5309 SV * const sv = newSV(0);
5310 SV * const tmpstr = sv_newmortal();
5311 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5312 GV_ADDMULTI, SVt_PVHV);
5315 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5317 (long)PL_subline, (long)CopLINE(PL_curcop));
5318 gv_efullname3(tmpstr, gv, NULL);
5319 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5320 hv = GvHVn(db_postponed);
5321 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5322 CV * const pcv = GvCV(db_postponed);
5328 call_sv((SV*)pcv, G_DISCARD);
5333 if ((s = strrchr(tname,':')))
5338 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5341 if (strEQ(s, "BEGIN") && !PL_error_count) {
5342 const I32 oldscope = PL_scopestack_ix;
5344 SAVECOPFILE(&PL_compiling);
5345 SAVECOPLINE(&PL_compiling);
5348 PL_beginav = newAV();
5349 DEBUG_x( dump_sub(gv) );
5350 av_push(PL_beginav, (SV*)cv);
5351 GvCV(gv) = 0; /* cv has been hijacked */
5352 call_list(oldscope, PL_beginav);
5354 PL_curcop = &PL_compiling;
5355 CopHINTS_set(&PL_compiling, PL_hints);
5358 else if (strEQ(s, "END") && !PL_error_count) {
5361 DEBUG_x( dump_sub(gv) );
5362 av_unshift(PL_endav, 1);
5363 av_store(PL_endav, 0, (SV*)cv);
5364 GvCV(gv) = 0; /* cv has been hijacked */
5366 else if (strEQ(s, "CHECK") && !PL_error_count) {
5368 PL_checkav = newAV();
5369 DEBUG_x( dump_sub(gv) );
5370 if (PL_main_start && ckWARN(WARN_VOID))
5371 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5372 av_unshift(PL_checkav, 1);
5373 av_store(PL_checkav, 0, (SV*)cv);
5374 GvCV(gv) = 0; /* cv has been hijacked */
5376 else if (strEQ(s, "INIT") && !PL_error_count) {
5378 PL_initav = newAV();
5379 DEBUG_x( dump_sub(gv) );
5380 if (PL_main_start && ckWARN(WARN_VOID))
5381 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5382 av_push(PL_initav, (SV*)cv);
5383 GvCV(gv) = 0; /* cv has been hijacked */
5388 PL_copline = NOLINE;
5393 /* XXX unsafe for threads if eval_owner isn't held */
5395 =for apidoc newCONSTSUB
5397 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5398 eligible for inlining at compile-time.
5404 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5409 const char *const temp_p = CopFILE(PL_curcop);
5410 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5412 SV *const temp_sv = CopFILESV(PL_curcop);
5414 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5416 char *const file = savepvn(temp_p, temp_p ? len : 0);
5420 SAVECOPLINE(PL_curcop);
5421 CopLINE_set(PL_curcop, PL_copline);
5424 PL_hints &= ~HINT_BLOCK_SCOPE;
5427 SAVESPTR(PL_curstash);
5428 SAVECOPSTASH(PL_curcop);
5429 PL_curstash = stash;
5430 CopSTASH_set(PL_curcop,stash);
5433 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5434 and so doesn't get free()d. (It's expected to be from the C pre-
5435 processor __FILE__ directive). But we need a dynamically allocated one,
5436 and we need it to get freed. */
5437 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5438 CvXSUBANY(cv).any_ptr = sv;
5443 CopSTASH_free(PL_curcop);
5451 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5452 const char *const filename, const char *const proto,
5455 CV *cv = newXS(name, subaddr, filename);
5457 if (flags & XS_DYNAMIC_FILENAME) {
5458 /* We need to "make arrangements" (ie cheat) to ensure that the
5459 filename lasts as long as the PVCV we just created, but also doesn't
5461 STRLEN filename_len = strlen(filename);
5462 STRLEN proto_and_file_len = filename_len;
5463 char *proto_and_file;
5467 proto_len = strlen(proto);
5468 proto_and_file_len += proto_len;
5470 Newx(proto_and_file, proto_and_file_len + 1, char);
5471 Copy(proto, proto_and_file, proto_len, char);
5472 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5475 proto_and_file = savepvn(filename, filename_len);
5478 /* This gets free()d. :-) */
5479 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5480 SV_HAS_TRAILING_NUL);
5482 /* This gives us the correct prototype, rather than one with the
5483 file name appended. */
5484 SvCUR_set(cv, proto_len);
5488 CvFILE(cv) = proto_and_file + proto_len;
5490 sv_setpv((SV *)cv, proto);
5496 =for apidoc U||newXS
5498 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5499 static storage, as it is used directly as CvFILE(), without a copy being made.
5505 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5508 GV * const gv = gv_fetchpv(name ? name :
5509 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5510 GV_ADDMULTI, SVt_PVCV);
5514 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5516 if ((cv = (name ? GvCV(gv) : NULL))) {
5518 /* just a cached method */
5522 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5523 /* already defined (or promised) */
5524 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5525 if (ckWARN(WARN_REDEFINE)) {
5526 GV * const gvcv = CvGV(cv);
5528 HV * const stash = GvSTASH(gvcv);
5530 const char *redefined_name = HvNAME_get(stash);
5531 if ( strEQ(redefined_name,"autouse") ) {
5532 const line_t oldline = CopLINE(PL_curcop);
5533 if (PL_copline != NOLINE)
5534 CopLINE_set(PL_curcop, PL_copline);
5535 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5536 CvCONST(cv) ? "Constant subroutine %s redefined"
5537 : "Subroutine %s redefined"
5539 CopLINE_set(PL_curcop, oldline);
5549 if (cv) /* must reuse cv if autoloaded */
5553 sv_upgrade((SV *)cv, SVt_PVCV);
5557 PL_sub_generation++;
5561 (void)gv_fetchfile(filename);
5562 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5563 an external constant string */
5565 CvXSUB(cv) = subaddr;
5568 const char *s = strrchr(name,':');
5574 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5577 if (strEQ(s, "BEGIN")) {
5579 PL_beginav = newAV();
5580 av_push(PL_beginav, (SV*)cv);
5581 GvCV(gv) = 0; /* cv has been hijacked */
5583 else if (strEQ(s, "END")) {
5586 av_unshift(PL_endav, 1);
5587 av_store(PL_endav, 0, (SV*)cv);
5588 GvCV(gv) = 0; /* cv has been hijacked */
5590 else if (strEQ(s, "CHECK")) {
5592 PL_checkav = newAV();
5593 if (PL_main_start && ckWARN(WARN_VOID))
5594 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5595 av_unshift(PL_checkav, 1);
5596 av_store(PL_checkav, 0, (SV*)cv);
5597 GvCV(gv) = 0; /* cv has been hijacked */
5599 else if (strEQ(s, "INIT")) {
5601 PL_initav = newAV();
5602 if (PL_main_start && ckWARN(WARN_VOID))
5603 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5604 av_push(PL_initav, (SV*)cv);
5605 GvCV(gv) = 0; /* cv has been hijacked */
5620 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5625 OP* pegop = newOP(OP_NULL, 0);
5629 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5630 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5632 #ifdef GV_UNIQUE_CHECK
5634 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5638 if ((cv = GvFORM(gv))) {
5639 if (ckWARN(WARN_REDEFINE)) {
5640 const line_t oldline = CopLINE(PL_curcop);
5641 if (PL_copline != NOLINE)
5642 CopLINE_set(PL_curcop, PL_copline);
5643 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5644 o ? "Format %"SVf" redefined"
5645 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5646 CopLINE_set(PL_curcop, oldline);
5653 CvFILE_set_from_cop(cv, PL_curcop);
5656 pad_tidy(padtidy_FORMAT);
5657 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5658 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5659 OpREFCNT_set(CvROOT(cv), 1);
5660 CvSTART(cv) = LINKLIST(CvROOT(cv));
5661 CvROOT(cv)->op_next = 0;
5662 CALL_PEEP(CvSTART(cv));
5664 op_getmad(o,pegop,'n');
5665 op_getmad_weak(block, pegop, 'b');
5669 PL_copline = NOLINE;
5677 Perl_newANONLIST(pTHX_ OP *o)
5679 return newUNOP(OP_REFGEN, 0,
5680 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5684 Perl_newANONHASH(pTHX_ OP *o)
5686 return newUNOP(OP_REFGEN, 0,
5687 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5691 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5693 return newANONATTRSUB(floor, proto, NULL, block);
5697 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5699 return newUNOP(OP_REFGEN, 0,
5700 newSVOP(OP_ANONCODE, 0,
5701 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5705 Perl_oopsAV(pTHX_ OP *o)
5708 switch (o->op_type) {
5710 o->op_type = OP_PADAV;
5711 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5712 return ref(o, OP_RV2AV);
5715 o->op_type = OP_RV2AV;
5716 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5721 if (ckWARN_d(WARN_INTERNAL))
5722 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5729 Perl_oopsHV(pTHX_ OP *o)
5732 switch (o->op_type) {
5735 o->op_type = OP_PADHV;
5736 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5737 return ref(o, OP_RV2HV);
5741 o->op_type = OP_RV2HV;
5742 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5747 if (ckWARN_d(WARN_INTERNAL))
5748 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5755 Perl_newAVREF(pTHX_ OP *o)
5758 if (o->op_type == OP_PADANY) {
5759 o->op_type = OP_PADAV;
5760 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5763 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5764 && ckWARN(WARN_DEPRECATED)) {
5765 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5766 "Using an array as a reference is deprecated");
5768 return newUNOP(OP_RV2AV, 0, scalar(o));
5772 Perl_newGVREF(pTHX_ I32 type, OP *o)
5774 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5775 return newUNOP(OP_NULL, 0, o);
5776 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5780 Perl_newHVREF(pTHX_ OP *o)
5783 if (o->op_type == OP_PADANY) {
5784 o->op_type = OP_PADHV;
5785 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5788 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5789 && ckWARN(WARN_DEPRECATED)) {
5790 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5791 "Using a hash as a reference is deprecated");
5793 return newUNOP(OP_RV2HV, 0, scalar(o));
5797 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5799 return newUNOP(OP_RV2CV, flags, scalar(o));
5803 Perl_newSVREF(pTHX_ OP *o)
5806 if (o->op_type == OP_PADANY) {
5807 o->op_type = OP_PADSV;
5808 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5811 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5812 o->op_flags |= OPpDONE_SVREF;
5815 return newUNOP(OP_RV2SV, 0, scalar(o));
5818 /* Check routines. See the comments at the top of this file for details
5819 * on when these are called */
5822 Perl_ck_anoncode(pTHX_ OP *o)
5824 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5826 cSVOPo->op_sv = NULL;
5831 Perl_ck_bitop(pTHX_ OP *o)
5834 #define OP_IS_NUMCOMPARE(op) \
5835 ((op) == OP_LT || (op) == OP_I_LT || \
5836 (op) == OP_GT || (op) == OP_I_GT || \
5837 (op) == OP_LE || (op) == OP_I_LE || \
5838 (op) == OP_GE || (op) == OP_I_GE || \
5839 (op) == OP_EQ || (op) == OP_I_EQ || \
5840 (op) == OP_NE || (op) == OP_I_NE || \
5841 (op) == OP_NCMP || (op) == OP_I_NCMP)
5842 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5843 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5844 && (o->op_type == OP_BIT_OR
5845 || o->op_type == OP_BIT_AND
5846 || o->op_type == OP_BIT_XOR))
5848 const OP * const left = cBINOPo->op_first;
5849 const OP * const right = left->op_sibling;
5850 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5851 (left->op_flags & OPf_PARENS) == 0) ||
5852 (OP_IS_NUMCOMPARE(right->op_type) &&
5853 (right->op_flags & OPf_PARENS) == 0))
5854 if (ckWARN(WARN_PRECEDENCE))
5855 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5856 "Possible precedence problem on bitwise %c operator",
5857 o->op_type == OP_BIT_OR ? '|'
5858 : o->op_type == OP_BIT_AND ? '&' : '^'
5865 Perl_ck_concat(pTHX_ OP *o)
5867 const OP * const kid = cUNOPo->op_first;
5868 PERL_UNUSED_CONTEXT;
5869 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5870 !(kUNOP->op_first->op_flags & OPf_MOD))
5871 o->op_flags |= OPf_STACKED;
5876 Perl_ck_spair(pTHX_ OP *o)
5879 if (o->op_flags & OPf_KIDS) {
5882 const OPCODE type = o->op_type;
5883 o = modkids(ck_fun(o), type);
5884 kid = cUNOPo->op_first;
5885 newop = kUNOP->op_first->op_sibling;
5887 const OPCODE type = newop->op_type;
5888 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5889 type == OP_PADAV || type == OP_PADHV ||
5890 type == OP_RV2AV || type == OP_RV2HV)
5894 op_getmad(kUNOP->op_first,newop,'K');
5896 op_free(kUNOP->op_first);
5898 kUNOP->op_first = newop;
5900 o->op_ppaddr = PL_ppaddr[++o->op_type];
5905 Perl_ck_delete(pTHX_ OP *o)
5909 if (o->op_flags & OPf_KIDS) {
5910 OP * const kid = cUNOPo->op_first;
5911 switch (kid->op_type) {
5913 o->op_flags |= OPf_SPECIAL;
5916 o->op_private |= OPpSLICE;
5919 o->op_flags |= OPf_SPECIAL;
5924 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5933 Perl_ck_die(pTHX_ OP *o)
5936 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5942 Perl_ck_eof(pTHX_ OP *o)
5946 if (o->op_flags & OPf_KIDS) {
5947 if (cLISTOPo->op_first->op_type == OP_STUB) {
5949 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5951 op_getmad(o,newop,'O');
5963 Perl_ck_eval(pTHX_ OP *o)
5966 PL_hints |= HINT_BLOCK_SCOPE;
5967 if (o->op_flags & OPf_KIDS) {
5968 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5971 o->op_flags &= ~OPf_KIDS;
5974 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5980 cUNOPo->op_first = 0;
5985 NewOp(1101, enter, 1, LOGOP);
5986 enter->op_type = OP_ENTERTRY;
5987 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5988 enter->op_private = 0;
5990 /* establish postfix order */
5991 enter->op_next = (OP*)enter;
5993 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5994 o->op_type = OP_LEAVETRY;
5995 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5996 enter->op_other = o;
5997 op_getmad(oldo,o,'O');
6011 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6012 op_getmad(oldo,o,'O');
6014 o->op_targ = (PADOFFSET)PL_hints;
6015 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6016 /* Store a copy of %^H that pp_entereval can pick up */
6017 OP *hhop = newSVOP(OP_CONST, 0,
6018 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6019 cUNOPo->op_first->op_sibling = hhop;
6020 o->op_private |= OPpEVAL_HAS_HH;
6026 Perl_ck_exit(pTHX_ OP *o)
6029 HV * const table = GvHV(PL_hintgv);
6031 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6032 if (svp && *svp && SvTRUE(*svp))
6033 o->op_private |= OPpEXIT_VMSISH;
6035 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6041 Perl_ck_exec(pTHX_ OP *o)
6043 if (o->op_flags & OPf_STACKED) {
6046 kid = cUNOPo->op_first->op_sibling;
6047 if (kid->op_type == OP_RV2GV)
6056 Perl_ck_exists(pTHX_ OP *o)
6060 if (o->op_flags & OPf_KIDS) {
6061 OP * const kid = cUNOPo->op_first;
6062 if (kid->op_type == OP_ENTERSUB) {
6063 (void) ref(kid, o->op_type);
6064 if (kid->op_type != OP_RV2CV && !PL_error_count)
6065 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6067 o->op_private |= OPpEXISTS_SUB;
6069 else if (kid->op_type == OP_AELEM)
6070 o->op_flags |= OPf_SPECIAL;
6071 else if (kid->op_type != OP_HELEM)
6072 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6080 Perl_ck_rvconst(pTHX_ register OP *o)
6083 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6085 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6086 if (o->op_type == OP_RV2CV)
6087 o->op_private &= ~1;
6089 if (kid->op_type == OP_CONST) {
6092 SV * const kidsv = kid->op_sv;
6094 /* Is it a constant from cv_const_sv()? */
6095 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6096 SV * const rsv = SvRV(kidsv);
6097 const int svtype = SvTYPE(rsv);
6098 const char *badtype = NULL;
6100 switch (o->op_type) {
6102 if (svtype > SVt_PVMG)
6103 badtype = "a SCALAR";
6106 if (svtype != SVt_PVAV)
6107 badtype = "an ARRAY";
6110 if (svtype != SVt_PVHV)
6114 if (svtype != SVt_PVCV)
6119 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6122 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6123 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6124 /* If this is an access to a stash, disable "strict refs", because
6125 * stashes aren't auto-vivified at compile-time (unless we store
6126 * symbols in them), and we don't want to produce a run-time
6127 * stricture error when auto-vivifying the stash. */
6128 const char *s = SvPV_nolen(kidsv);
6129 const STRLEN l = SvCUR(kidsv);
6130 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6131 o->op_private &= ~HINT_STRICT_REFS;
6133 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6134 const char *badthing;
6135 switch (o->op_type) {
6137 badthing = "a SCALAR";
6140 badthing = "an ARRAY";
6143 badthing = "a HASH";
6151 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6152 (void*)kidsv, badthing);
6155 * This is a little tricky. We only want to add the symbol if we
6156 * didn't add it in the lexer. Otherwise we get duplicate strict
6157 * warnings. But if we didn't add it in the lexer, we must at
6158 * least pretend like we wanted to add it even if it existed before,
6159 * or we get possible typo warnings. OPpCONST_ENTERED says
6160 * whether the lexer already added THIS instance of this symbol.
6162 iscv = (o->op_type == OP_RV2CV) * 2;
6164 gv = gv_fetchsv(kidsv,
6165 iscv | !(kid->op_private & OPpCONST_ENTERED),
6168 : o->op_type == OP_RV2SV
6170 : o->op_type == OP_RV2AV
6172 : o->op_type == OP_RV2HV
6175 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6177 kid->op_type = OP_GV;
6178 SvREFCNT_dec(kid->op_sv);
6180 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6181 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6182 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6184 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6186 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6188 kid->op_private = 0;
6189 kid->op_ppaddr = PL_ppaddr[OP_GV];
6196 Perl_ck_ftst(pTHX_ OP *o)
6199 const I32 type = o->op_type;
6201 if (o->op_flags & OPf_REF) {
6204 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6205 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6206 const OPCODE kidtype = kid->op_type;
6208 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6209 OP * const newop = newGVOP(type, OPf_REF,
6210 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6212 op_getmad(o,newop,'O');
6218 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6219 o->op_private |= OPpFT_ACCESS;
6220 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6221 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6222 o->op_private |= OPpFT_STACKED;
6230 if (type == OP_FTTTY)
6231 o = newGVOP(type, OPf_REF, PL_stdingv);
6233 o = newUNOP(type, 0, newDEFSVOP());
6234 op_getmad(oldo,o,'O');
6240 Perl_ck_fun(pTHX_ OP *o)
6243 const int type = o->op_type;
6244 register I32 oa = PL_opargs[type] >> OASHIFT;
6246 if (o->op_flags & OPf_STACKED) {
6247 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6250 return no_fh_allowed(o);
6253 if (o->op_flags & OPf_KIDS) {
6254 OP **tokid = &cLISTOPo->op_first;
6255 register OP *kid = cLISTOPo->op_first;
6259 if (kid->op_type == OP_PUSHMARK ||
6260 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6262 tokid = &kid->op_sibling;
6263 kid = kid->op_sibling;
6265 if (!kid && PL_opargs[type] & OA_DEFGV)
6266 *tokid = kid = newDEFSVOP();
6270 sibl = kid->op_sibling;
6272 if (!sibl && kid->op_type == OP_STUB) {
6279 /* list seen where single (scalar) arg expected? */
6280 if (numargs == 1 && !(oa >> 4)
6281 && kid->op_type == OP_LIST && type != OP_SCALAR)
6283 return too_many_arguments(o,PL_op_desc[type]);
6296 if ((type == OP_PUSH || type == OP_UNSHIFT)
6297 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6298 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6299 "Useless use of %s with no values",
6302 if (kid->op_type == OP_CONST &&
6303 (kid->op_private & OPpCONST_BARE))
6305 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6306 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6307 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6308 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6309 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6310 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6312 op_getmad(kid,newop,'K');
6317 kid->op_sibling = sibl;
6320 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6321 bad_type(numargs, "array", PL_op_desc[type], kid);
6325 if (kid->op_type == OP_CONST &&
6326 (kid->op_private & OPpCONST_BARE))
6328 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6329 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6330 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6331 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6332 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6333 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6335 op_getmad(kid,newop,'K');
6340 kid->op_sibling = sibl;
6343 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6344 bad_type(numargs, "hash", PL_op_desc[type], kid);
6349 OP * const newop = newUNOP(OP_NULL, 0, kid);
6350 kid->op_sibling = 0;
6352 newop->op_next = newop;
6354 kid->op_sibling = sibl;
6359 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6360 if (kid->op_type == OP_CONST &&
6361 (kid->op_private & OPpCONST_BARE))
6363 OP * const newop = newGVOP(OP_GV, 0,
6364 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6365 if (!(o->op_private & 1) && /* if not unop */
6366 kid == cLISTOPo->op_last)
6367 cLISTOPo->op_last = newop;
6369 op_getmad(kid,newop,'K');
6375 else if (kid->op_type == OP_READLINE) {
6376 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6377 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6380 I32 flags = OPf_SPECIAL;
6384 /* is this op a FH constructor? */
6385 if (is_handle_constructor(o,numargs)) {
6386 const char *name = NULL;
6390 /* Set a flag to tell rv2gv to vivify
6391 * need to "prove" flag does not mean something
6392 * else already - NI-S 1999/05/07
6395 if (kid->op_type == OP_PADSV) {
6396 name = PAD_COMPNAME_PV(kid->op_targ);
6397 /* SvCUR of a pad namesv can't be trusted
6398 * (see PL_generation), so calc its length
6404 else if (kid->op_type == OP_RV2SV
6405 && kUNOP->op_first->op_type == OP_GV)
6407 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6409 len = GvNAMELEN(gv);
6411 else if (kid->op_type == OP_AELEM
6412 || kid->op_type == OP_HELEM)
6414 OP *op = ((BINOP*)kid)->op_first;
6418 const char * const a =
6419 kid->op_type == OP_AELEM ?
6421 if (((op->op_type == OP_RV2AV) ||
6422 (op->op_type == OP_RV2HV)) &&
6423 (op = ((UNOP*)op)->op_first) &&
6424 (op->op_type == OP_GV)) {
6425 /* packagevar $a[] or $h{} */
6426 GV * const gv = cGVOPx_gv(op);
6434 else if (op->op_type == OP_PADAV
6435 || op->op_type == OP_PADHV) {
6436 /* lexicalvar $a[] or $h{} */
6437 const char * const padname =
6438 PAD_COMPNAME_PV(op->op_targ);
6447 name = SvPV_const(tmpstr, len);
6452 name = "__ANONIO__";
6459 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6460 namesv = PAD_SVl(targ);
6461 SvUPGRADE(namesv, SVt_PV);
6463 sv_setpvn(namesv, "$", 1);
6464 sv_catpvn(namesv, name, len);
6467 kid->op_sibling = 0;
6468 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6469 kid->op_targ = targ;
6470 kid->op_private |= priv;
6472 kid->op_sibling = sibl;
6478 mod(scalar(kid), type);
6482 tokid = &kid->op_sibling;
6483 kid = kid->op_sibling;
6486 if (kid && kid->op_type != OP_STUB)
6487 return too_many_arguments(o,OP_DESC(o));
6488 o->op_private |= numargs;
6490 /* FIXME - should the numargs move as for the PERL_MAD case? */
6491 o->op_private |= numargs;
6493 return too_many_arguments(o,OP_DESC(o));
6497 else if (PL_opargs[type] & OA_DEFGV) {
6499 OP *newop = newUNOP(type, 0, newDEFSVOP());
6500 op_getmad(o,newop,'O');
6503 /* Ordering of these two is important to keep f_map.t passing. */
6505 return newUNOP(type, 0, newDEFSVOP());
6510 while (oa & OA_OPTIONAL)
6512 if (oa && oa != OA_LIST)
6513 return too_few_arguments(o,OP_DESC(o));
6519 Perl_ck_glob(pTHX_ OP *o)
6525 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6526 append_elem(OP_GLOB, o, newDEFSVOP());
6528 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6529 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6531 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6534 #if !defined(PERL_EXTERNAL_GLOB)
6535 /* XXX this can be tightened up and made more failsafe. */
6536 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6539 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6540 newSVpvs("File::Glob"), NULL, NULL, NULL);
6541 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6542 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6543 GvCV(gv) = GvCV(glob_gv);
6544 SvREFCNT_inc_void((SV*)GvCV(gv));
6545 GvIMPORTED_CV_on(gv);
6548 #endif /* PERL_EXTERNAL_GLOB */
6550 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6551 append_elem(OP_GLOB, o,
6552 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6553 o->op_type = OP_LIST;
6554 o->op_ppaddr = PL_ppaddr[OP_LIST];
6555 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6556 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6557 cLISTOPo->op_first->op_targ = 0;
6558 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6559 append_elem(OP_LIST, o,
6560 scalar(newUNOP(OP_RV2CV, 0,
6561 newGVOP(OP_GV, 0, gv)))));
6562 o = newUNOP(OP_NULL, 0, ck_subr(o));
6563 o->op_targ = OP_GLOB; /* hint at what it used to be */
6566 gv = newGVgen("main");
6568 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6574 Perl_ck_grep(pTHX_ OP *o)
6579 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6582 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6583 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6585 if (o->op_flags & OPf_STACKED) {
6588 kid = cLISTOPo->op_first->op_sibling;
6589 if (!cUNOPx(kid)->op_next)
6590 Perl_croak(aTHX_ "panic: ck_grep");
6591 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6594 NewOp(1101, gwop, 1, LOGOP);
6595 kid->op_next = (OP*)gwop;
6596 o->op_flags &= ~OPf_STACKED;
6598 kid = cLISTOPo->op_first->op_sibling;
6599 if (type == OP_MAPWHILE)
6606 kid = cLISTOPo->op_first->op_sibling;
6607 if (kid->op_type != OP_NULL)
6608 Perl_croak(aTHX_ "panic: ck_grep");
6609 kid = kUNOP->op_first;
6612 NewOp(1101, gwop, 1, LOGOP);
6613 gwop->op_type = type;
6614 gwop->op_ppaddr = PL_ppaddr[type];
6615 gwop->op_first = listkids(o);
6616 gwop->op_flags |= OPf_KIDS;
6617 gwop->op_other = LINKLIST(kid);
6618 kid->op_next = (OP*)gwop;
6619 offset = pad_findmy("$_");
6620 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6621 o->op_private = gwop->op_private = 0;
6622 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6625 o->op_private = gwop->op_private = OPpGREP_LEX;
6626 gwop->op_targ = o->op_targ = offset;
6629 kid = cLISTOPo->op_first->op_sibling;
6630 if (!kid || !kid->op_sibling)
6631 return too_few_arguments(o,OP_DESC(o));
6632 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6633 mod(kid, OP_GREPSTART);
6639 Perl_ck_index(pTHX_ OP *o)
6641 if (o->op_flags & OPf_KIDS) {
6642 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6644 kid = kid->op_sibling; /* get past "big" */
6645 if (kid && kid->op_type == OP_CONST)
6646 fbm_compile(((SVOP*)kid)->op_sv, 0);
6652 Perl_ck_lengthconst(pTHX_ OP *o)
6654 /* XXX length optimization goes here */
6659 Perl_ck_lfun(pTHX_ OP *o)
6661 const OPCODE type = o->op_type;
6662 return modkids(ck_fun(o), type);
6666 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6668 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6669 switch (cUNOPo->op_first->op_type) {
6671 /* This is needed for
6672 if (defined %stash::)
6673 to work. Do not break Tk.
6675 break; /* Globals via GV can be undef */
6677 case OP_AASSIGN: /* Is this a good idea? */
6678 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6679 "defined(@array) is deprecated");
6680 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6681 "\t(Maybe you should just omit the defined()?)\n");
6684 /* This is needed for
6685 if (defined %stash::)
6686 to work. Do not break Tk.
6688 break; /* Globals via GV can be undef */
6690 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6691 "defined(%%hash) is deprecated");
6692 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6693 "\t(Maybe you should just omit the defined()?)\n");
6704 Perl_ck_rfun(pTHX_ OP *o)
6706 const OPCODE type = o->op_type;
6707 return refkids(ck_fun(o), type);
6711 Perl_ck_listiob(pTHX_ OP *o)
6715 kid = cLISTOPo->op_first;
6718 kid = cLISTOPo->op_first;
6720 if (kid->op_type == OP_PUSHMARK)
6721 kid = kid->op_sibling;
6722 if (kid && o->op_flags & OPf_STACKED)
6723 kid = kid->op_sibling;
6724 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6725 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6726 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6727 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6728 cLISTOPo->op_first->op_sibling = kid;
6729 cLISTOPo->op_last = kid;
6730 kid = kid->op_sibling;
6735 append_elem(o->op_type, o, newDEFSVOP());
6741 Perl_ck_say(pTHX_ OP *o)
6744 o->op_type = OP_PRINT;
6745 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6746 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6751 Perl_ck_smartmatch(pTHX_ OP *o)
6754 if (0 == (o->op_flags & OPf_SPECIAL)) {
6755 OP *first = cBINOPo->op_first;
6756 OP *second = first->op_sibling;
6758 /* Implicitly take a reference to an array or hash */
6759 first->op_sibling = NULL;
6760 first = cBINOPo->op_first = ref_array_or_hash(first);
6761 second = first->op_sibling = ref_array_or_hash(second);
6763 /* Implicitly take a reference to a regular expression */
6764 if (first->op_type == OP_MATCH) {
6765 first->op_type = OP_QR;
6766 first->op_ppaddr = PL_ppaddr[OP_QR];
6768 if (second->op_type == OP_MATCH) {
6769 second->op_type = OP_QR;
6770 second->op_ppaddr = PL_ppaddr[OP_QR];
6779 Perl_ck_sassign(pTHX_ OP *o)
6781 OP * const kid = cLISTOPo->op_first;
6782 /* has a disposable target? */
6783 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6784 && !(kid->op_flags & OPf_STACKED)
6785 /* Cannot steal the second time! */
6786 && !(kid->op_private & OPpTARGET_MY))
6788 OP * const kkid = kid->op_sibling;
6790 /* Can just relocate the target. */
6791 if (kkid && kkid->op_type == OP_PADSV
6792 && !(kkid->op_private & OPpLVAL_INTRO))
6794 kid->op_targ = kkid->op_targ;
6796 /* Now we do not need PADSV and SASSIGN. */
6797 kid->op_sibling = o->op_sibling; /* NULL */
6798 cLISTOPo->op_first = NULL;
6800 op_getmad(o,kid,'O');
6801 op_getmad(kkid,kid,'M');
6806 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6810 if (kid->op_sibling) {
6811 OP *kkid = kid->op_sibling;
6812 if (kkid->op_type == OP_PADSV
6813 && (kkid->op_private & OPpLVAL_INTRO)
6814 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6815 o->op_private |= OPpASSIGN_STATE;
6816 /* hijacking PADSTALE for uninitialized state variables */
6817 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6824 Perl_ck_match(pTHX_ OP *o)
6827 if (o->op_type != OP_QR && PL_compcv) {
6828 const PADOFFSET offset = pad_findmy("$_");
6829 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6830 o->op_targ = offset;
6831 o->op_private |= OPpTARGET_MY;
6834 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6835 o->op_private |= OPpRUNTIME;
6840 Perl_ck_method(pTHX_ OP *o)
6842 OP * const kid = cUNOPo->op_first;
6843 if (kid->op_type == OP_CONST) {
6844 SV* sv = kSVOP->op_sv;
6845 const char * const method = SvPVX_const(sv);
6846 if (!(strchr(method, ':') || strchr(method, '\''))) {
6848 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6849 sv = newSVpvn_share(method, SvCUR(sv), 0);
6852 kSVOP->op_sv = NULL;
6854 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6856 op_getmad(o,cmop,'O');
6867 Perl_ck_null(pTHX_ OP *o)
6869 PERL_UNUSED_CONTEXT;
6874 Perl_ck_open(pTHX_ OP *o)
6877 HV * const table = GvHV(PL_hintgv);
6879 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6881 const I32 mode = mode_from_discipline(*svp);
6882 if (mode & O_BINARY)
6883 o->op_private |= OPpOPEN_IN_RAW;
6884 else if (mode & O_TEXT)
6885 o->op_private |= OPpOPEN_IN_CRLF;
6888 svp = hv_fetchs(table, "open_OUT", FALSE);
6890 const I32 mode = mode_from_discipline(*svp);
6891 if (mode & O_BINARY)
6892 o->op_private |= OPpOPEN_OUT_RAW;
6893 else if (mode & O_TEXT)
6894 o->op_private |= OPpOPEN_OUT_CRLF;
6897 if (o->op_type == OP_BACKTICK)
6900 /* In case of three-arg dup open remove strictness
6901 * from the last arg if it is a bareword. */
6902 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6903 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6907 if ((last->op_type == OP_CONST) && /* The bareword. */
6908 (last->op_private & OPpCONST_BARE) &&
6909 (last->op_private & OPpCONST_STRICT) &&
6910 (oa = first->op_sibling) && /* The fh. */
6911 (oa = oa->op_sibling) && /* The mode. */
6912 (oa->op_type == OP_CONST) &&
6913 SvPOK(((SVOP*)oa)->op_sv) &&
6914 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6915 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6916 (last == oa->op_sibling)) /* The bareword. */
6917 last->op_private &= ~OPpCONST_STRICT;
6923 Perl_ck_repeat(pTHX_ OP *o)
6925 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6926 o->op_private |= OPpREPEAT_DOLIST;
6927 cBINOPo->op_first = force_list(cBINOPo->op_first);
6935 Perl_ck_require(pTHX_ OP *o)
6940 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6941 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6943 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6944 SV * const sv = kid->op_sv;
6945 U32 was_readonly = SvREADONLY(sv);
6950 sv_force_normal_flags(sv, 0);
6951 assert(!SvREADONLY(sv));
6958 for (s = SvPVX(sv); *s; s++) {
6959 if (*s == ':' && s[1] == ':') {
6960 const STRLEN len = strlen(s+2)+1;
6962 Move(s+2, s+1, len, char);
6963 SvCUR_set(sv, SvCUR(sv) - 1);
6966 sv_catpvs(sv, ".pm");
6967 SvFLAGS(sv) |= was_readonly;
6971 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6972 /* handle override, if any */
6973 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6974 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6975 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6976 gv = gvp ? *gvp : NULL;
6980 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6981 OP * const kid = cUNOPo->op_first;
6984 cUNOPo->op_first = 0;
6988 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6989 append_elem(OP_LIST, kid,
6990 scalar(newUNOP(OP_RV2CV, 0,
6993 op_getmad(o,newop,'O');
7001 Perl_ck_return(pTHX_ OP *o)
7004 if (CvLVALUE(PL_compcv)) {
7006 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7007 mod(kid, OP_LEAVESUBLV);
7013 Perl_ck_select(pTHX_ OP *o)
7017 if (o->op_flags & OPf_KIDS) {
7018 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7019 if (kid && kid->op_sibling) {
7020 o->op_type = OP_SSELECT;
7021 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7023 return fold_constants(o);
7027 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7028 if (kid && kid->op_type == OP_RV2GV)
7029 kid->op_private &= ~HINT_STRICT_REFS;
7034 Perl_ck_shift(pTHX_ OP *o)
7037 const I32 type = o->op_type;
7039 if (!(o->op_flags & OPf_KIDS)) {
7041 /* FIXME - this can be refactored to reduce code in #ifdefs */
7043 OP * const oldo = o;
7047 argop = newUNOP(OP_RV2AV, 0,
7048 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7050 o = newUNOP(type, 0, scalar(argop));
7051 op_getmad(oldo,o,'O');
7054 return newUNOP(type, 0, scalar(argop));
7057 return scalar(modkids(ck_fun(o), type));
7061 Perl_ck_sort(pTHX_ OP *o)
7066 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7067 HV * const hinthv = GvHV(PL_hintgv);
7069 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7071 const I32 sorthints = (I32)SvIV(*svp);
7072 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7073 o->op_private |= OPpSORT_QSORT;
7074 if ((sorthints & HINT_SORT_STABLE) != 0)
7075 o->op_private |= OPpSORT_STABLE;
7080 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7082 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7083 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7085 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7087 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7089 if (kid->op_type == OP_SCOPE) {
7093 else if (kid->op_type == OP_LEAVE) {
7094 if (o->op_type == OP_SORT) {
7095 op_null(kid); /* wipe out leave */
7098 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7099 if (k->op_next == kid)
7101 /* don't descend into loops */
7102 else if (k->op_type == OP_ENTERLOOP
7103 || k->op_type == OP_ENTERITER)
7105 k = cLOOPx(k)->op_lastop;
7110 kid->op_next = 0; /* just disconnect the leave */
7111 k = kLISTOP->op_first;
7116 if (o->op_type == OP_SORT) {
7117 /* provide scalar context for comparison function/block */
7123 o->op_flags |= OPf_SPECIAL;
7125 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7128 firstkid = firstkid->op_sibling;
7131 /* provide list context for arguments */
7132 if (o->op_type == OP_SORT)
7139 S_simplify_sort(pTHX_ OP *o)
7142 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7147 if (!(o->op_flags & OPf_STACKED))
7149 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7150 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7151 kid = kUNOP->op_first; /* get past null */
7152 if (kid->op_type != OP_SCOPE)
7154 kid = kLISTOP->op_last; /* get past scope */
7155 switch(kid->op_type) {
7163 k = kid; /* remember this node*/
7164 if (kBINOP->op_first->op_type != OP_RV2SV)
7166 kid = kBINOP->op_first; /* get past cmp */
7167 if (kUNOP->op_first->op_type != OP_GV)
7169 kid = kUNOP->op_first; /* get past rv2sv */
7171 if (GvSTASH(gv) != PL_curstash)
7173 gvname = GvNAME(gv);
7174 if (*gvname == 'a' && gvname[1] == '\0')
7176 else if (*gvname == 'b' && gvname[1] == '\0')
7181 kid = k; /* back to cmp */
7182 if (kBINOP->op_last->op_type != OP_RV2SV)
7184 kid = kBINOP->op_last; /* down to 2nd arg */
7185 if (kUNOP->op_first->op_type != OP_GV)
7187 kid = kUNOP->op_first; /* get past rv2sv */
7189 if (GvSTASH(gv) != PL_curstash)
7191 gvname = GvNAME(gv);
7193 ? !(*gvname == 'a' && gvname[1] == '\0')
7194 : !(*gvname == 'b' && gvname[1] == '\0'))
7196 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7198 o->op_private |= OPpSORT_DESCEND;
7199 if (k->op_type == OP_NCMP)
7200 o->op_private |= OPpSORT_NUMERIC;
7201 if (k->op_type == OP_I_NCMP)
7202 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7203 kid = cLISTOPo->op_first->op_sibling;
7204 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7206 op_getmad(kid,o,'S'); /* then delete it */
7208 op_free(kid); /* then delete it */
7213 Perl_ck_split(pTHX_ OP *o)
7218 if (o->op_flags & OPf_STACKED)
7219 return no_fh_allowed(o);
7221 kid = cLISTOPo->op_first;
7222 if (kid->op_type != OP_NULL)
7223 Perl_croak(aTHX_ "panic: ck_split");
7224 kid = kid->op_sibling;
7225 op_free(cLISTOPo->op_first);
7226 cLISTOPo->op_first = kid;
7228 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7229 cLISTOPo->op_last = kid; /* There was only one element previously */
7232 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7233 OP * const sibl = kid->op_sibling;
7234 kid->op_sibling = 0;
7235 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7236 if (cLISTOPo->op_first == cLISTOPo->op_last)
7237 cLISTOPo->op_last = kid;
7238 cLISTOPo->op_first = kid;
7239 kid->op_sibling = sibl;
7242 kid->op_type = OP_PUSHRE;
7243 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7245 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7246 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7247 "Use of /g modifier is meaningless in split");
7250 if (!kid->op_sibling)
7251 append_elem(OP_SPLIT, o, newDEFSVOP());
7253 kid = kid->op_sibling;
7256 if (!kid->op_sibling)
7257 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7258 assert(kid->op_sibling);
7260 kid = kid->op_sibling;
7263 if (kid->op_sibling)
7264 return too_many_arguments(o,OP_DESC(o));
7270 Perl_ck_join(pTHX_ OP *o)
7272 const OP * const kid = cLISTOPo->op_first->op_sibling;
7273 if (kid && kid->op_type == OP_MATCH) {
7274 if (ckWARN(WARN_SYNTAX)) {
7275 const REGEXP *re = PM_GETRE(kPMOP);
7276 const char *pmstr = re ? re->precomp : "STRING";
7277 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7278 "/%s/ should probably be written as \"%s\"",
7286 Perl_ck_subr(pTHX_ OP *o)
7289 OP *prev = ((cUNOPo->op_first->op_sibling)
7290 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7291 OP *o2 = prev->op_sibling;
7293 const char *proto = NULL;
7294 const char *proto_end = NULL;
7299 I32 contextclass = 0;
7303 o->op_private |= OPpENTERSUB_HASTARG;
7304 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7305 if (cvop->op_type == OP_RV2CV) {
7307 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7308 op_null(cvop); /* disable rv2cv */
7309 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7310 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7311 GV *gv = cGVOPx_gv(tmpop);
7314 tmpop->op_private |= OPpEARLY_CV;
7318 namegv = CvANON(cv) ? gv : CvGV(cv);
7319 proto = SvPV((SV*)cv, len);
7320 proto_end = proto + len;
7322 if (CvASSERTION(cv)) {
7323 if (PL_hints & HINT_ASSERTING) {
7324 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7325 o->op_private |= OPpENTERSUB_DB;
7329 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7330 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7331 "Impossible to activate assertion call");
7338 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7339 if (o2->op_type == OP_CONST)
7340 o2->op_private &= ~OPpCONST_STRICT;
7341 else if (o2->op_type == OP_LIST) {
7342 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7343 if (sib && sib->op_type == OP_CONST)
7344 sib->op_private &= ~OPpCONST_STRICT;
7347 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7348 if (PERLDB_SUB && PL_curstash != PL_debstash)
7349 o->op_private |= OPpENTERSUB_DB;
7350 while (o2 != cvop) {
7352 if (PL_madskills && o2->op_type == OP_NULL)
7353 o3 = ((UNOP*)o2)->op_first;
7357 if (proto >= proto_end)
7358 return too_many_arguments(o, gv_ename(namegv));
7378 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7380 arg == 1 ? "block or sub {}" : "sub {}",
7381 gv_ename(namegv), o3);
7384 /* '*' allows any scalar type, including bareword */
7387 if (o3->op_type == OP_RV2GV)
7388 goto wrapref; /* autoconvert GLOB -> GLOBref */
7389 else if (o3->op_type == OP_CONST)
7390 o3->op_private &= ~OPpCONST_STRICT;
7391 else if (o3->op_type == OP_ENTERSUB) {
7392 /* accidental subroutine, revert to bareword */
7393 OP *gvop = ((UNOP*)o3)->op_first;
7394 if (gvop && gvop->op_type == OP_NULL) {
7395 gvop = ((UNOP*)gvop)->op_first;
7397 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7400 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7401 (gvop = ((UNOP*)gvop)->op_first) &&
7402 gvop->op_type == OP_GV)
7404 GV * const gv = cGVOPx_gv(gvop);
7405 OP * const sibling = o2->op_sibling;
7406 SV * const n = newSVpvs("");
7408 OP * const oldo2 = o2;
7412 gv_fullname4(n, gv, "", FALSE);
7413 o2 = newSVOP(OP_CONST, 0, n);
7414 op_getmad(oldo2,o2,'O');
7415 prev->op_sibling = o2;
7416 o2->op_sibling = sibling;
7432 if (contextclass++ == 0) {
7433 e = strchr(proto, ']');
7434 if (!e || e == proto)
7443 const char *p = proto;
7444 const char *const end = proto;
7446 while (*--p != '[');
7447 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7449 gv_ename(namegv), o3);
7454 if (o3->op_type == OP_RV2GV)
7457 bad_type(arg, "symbol", gv_ename(namegv), o3);
7460 if (o3->op_type == OP_ENTERSUB)
7463 bad_type(arg, "subroutine entry", gv_ename(namegv),
7467 if (o3->op_type == OP_RV2SV ||
7468 o3->op_type == OP_PADSV ||
7469 o3->op_type == OP_HELEM ||
7470 o3->op_type == OP_AELEM ||
7471 o3->op_type == OP_THREADSV)
7474 bad_type(arg, "scalar", gv_ename(namegv), o3);
7477 if (o3->op_type == OP_RV2AV ||
7478 o3->op_type == OP_PADAV)
7481 bad_type(arg, "array", gv_ename(namegv), o3);
7484 if (o3->op_type == OP_RV2HV ||
7485 o3->op_type == OP_PADHV)
7488 bad_type(arg, "hash", gv_ename(namegv), o3);
7493 OP* const sib = kid->op_sibling;
7494 kid->op_sibling = 0;
7495 o2 = newUNOP(OP_REFGEN, 0, kid);
7496 o2->op_sibling = sib;
7497 prev->op_sibling = o2;
7499 if (contextclass && e) {
7514 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7515 gv_ename(namegv), (void*)cv);
7520 mod(o2, OP_ENTERSUB);
7522 o2 = o2->op_sibling;
7524 if (proto && !optional && proto_end > proto &&
7525 (*proto != '@' && *proto != '%' && *proto != ';'))
7526 return too_few_arguments(o, gv_ename(namegv));
7529 OP * const oldo = o;
7533 o=newSVOP(OP_CONST, 0, newSViv(0));
7534 op_getmad(oldo,o,'O');
7540 Perl_ck_svconst(pTHX_ OP *o)
7542 PERL_UNUSED_CONTEXT;
7543 SvREADONLY_on(cSVOPo->op_sv);
7548 Perl_ck_chdir(pTHX_ OP *o)
7550 if (o->op_flags & OPf_KIDS) {
7551 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7553 if (kid && kid->op_type == OP_CONST &&
7554 (kid->op_private & OPpCONST_BARE))
7556 o->op_flags |= OPf_SPECIAL;
7557 kid->op_private &= ~OPpCONST_STRICT;
7564 Perl_ck_trunc(pTHX_ OP *o)
7566 if (o->op_flags & OPf_KIDS) {
7567 SVOP *kid = (SVOP*)cUNOPo->op_first;
7569 if (kid->op_type == OP_NULL)
7570 kid = (SVOP*)kid->op_sibling;
7571 if (kid && kid->op_type == OP_CONST &&
7572 (kid->op_private & OPpCONST_BARE))
7574 o->op_flags |= OPf_SPECIAL;
7575 kid->op_private &= ~OPpCONST_STRICT;
7582 Perl_ck_unpack(pTHX_ OP *o)
7584 OP *kid = cLISTOPo->op_first;
7585 if (kid->op_sibling) {
7586 kid = kid->op_sibling;
7587 if (!kid->op_sibling)
7588 kid->op_sibling = newDEFSVOP();
7594 Perl_ck_substr(pTHX_ OP *o)
7597 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7598 OP *kid = cLISTOPo->op_first;
7600 if (kid->op_type == OP_NULL)
7601 kid = kid->op_sibling;
7603 kid->op_flags |= OPf_MOD;
7609 /* A peephole optimizer. We visit the ops in the order they're to execute.
7610 * See the comments at the top of this file for more details about when
7611 * peep() is called */
7614 Perl_peep(pTHX_ register OP *o)
7617 register OP* oldop = NULL;
7619 if (!o || o->op_opt)
7623 SAVEVPTR(PL_curcop);
7624 for (; o; o = o->op_next) {
7628 switch (o->op_type) {
7632 PL_curcop = ((COP*)o); /* for warnings */
7637 if (cSVOPo->op_private & OPpCONST_STRICT)
7638 no_bareword_allowed(o);
7640 case OP_METHOD_NAMED:
7641 /* Relocate sv to the pad for thread safety.
7642 * Despite being a "constant", the SV is written to,
7643 * for reference counts, sv_upgrade() etc. */
7645 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7646 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7647 /* If op_sv is already a PADTMP then it is being used by
7648 * some pad, so make a copy. */
7649 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7650 SvREADONLY_on(PAD_SVl(ix));
7651 SvREFCNT_dec(cSVOPo->op_sv);
7653 else if (o->op_type == OP_CONST
7654 && cSVOPo->op_sv == &PL_sv_undef) {
7655 /* PL_sv_undef is hack - it's unsafe to store it in the
7656 AV that is the pad, because av_fetch treats values of
7657 PL_sv_undef as a "free" AV entry and will merrily
7658 replace them with a new SV, causing pad_alloc to think
7659 that this pad slot is free. (When, clearly, it is not)
7661 SvOK_off(PAD_SVl(ix));
7662 SvPADTMP_on(PAD_SVl(ix));
7663 SvREADONLY_on(PAD_SVl(ix));
7666 SvREFCNT_dec(PAD_SVl(ix));
7667 SvPADTMP_on(cSVOPo->op_sv);
7668 PAD_SETSV(ix, cSVOPo->op_sv);
7669 /* XXX I don't know how this isn't readonly already. */
7670 SvREADONLY_on(PAD_SVl(ix));
7672 cSVOPo->op_sv = NULL;
7680 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7681 if (o->op_next->op_private & OPpTARGET_MY) {
7682 if (o->op_flags & OPf_STACKED) /* chained concats */
7683 goto ignore_optimization;
7685 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7686 o->op_targ = o->op_next->op_targ;
7687 o->op_next->op_targ = 0;
7688 o->op_private |= OPpTARGET_MY;
7691 op_null(o->op_next);
7693 ignore_optimization:
7697 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7699 break; /* Scalar stub must produce undef. List stub is noop */
7703 if (o->op_targ == OP_NEXTSTATE
7704 || o->op_targ == OP_DBSTATE
7705 || o->op_targ == OP_SETSTATE)
7707 PL_curcop = ((COP*)o);
7709 /* XXX: We avoid setting op_seq here to prevent later calls
7710 to peep() from mistakenly concluding that optimisation
7711 has already occurred. This doesn't fix the real problem,
7712 though (See 20010220.007). AMS 20010719 */
7713 /* op_seq functionality is now replaced by op_opt */
7714 if (oldop && o->op_next) {
7715 oldop->op_next = o->op_next;
7723 if (oldop && o->op_next) {
7724 oldop->op_next = o->op_next;
7732 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7733 OP* const pop = (o->op_type == OP_PADAV) ?
7734 o->op_next : o->op_next->op_next;
7736 if (pop && pop->op_type == OP_CONST &&
7737 ((PL_op = pop->op_next)) &&
7738 pop->op_next->op_type == OP_AELEM &&
7739 !(pop->op_next->op_private &
7740 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7741 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7746 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7747 no_bareword_allowed(pop);
7748 if (o->op_type == OP_GV)
7749 op_null(o->op_next);
7750 op_null(pop->op_next);
7752 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7753 o->op_next = pop->op_next->op_next;
7754 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7755 o->op_private = (U8)i;
7756 if (o->op_type == OP_GV) {
7761 o->op_flags |= OPf_SPECIAL;
7762 o->op_type = OP_AELEMFAST;
7768 if (o->op_next->op_type == OP_RV2SV) {
7769 if (!(o->op_next->op_private & OPpDEREF)) {
7770 op_null(o->op_next);
7771 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7773 o->op_next = o->op_next->op_next;
7774 o->op_type = OP_GVSV;
7775 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7778 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7779 GV * const gv = cGVOPo_gv;
7780 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7781 /* XXX could check prototype here instead of just carping */
7782 SV * const sv = sv_newmortal();
7783 gv_efullname3(sv, gv, NULL);
7784 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7785 "%"SVf"() called too early to check prototype",
7789 else if (o->op_next->op_type == OP_READLINE
7790 && o->op_next->op_next->op_type == OP_CONCAT
7791 && (o->op_next->op_next->op_flags & OPf_STACKED))
7793 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7794 o->op_type = OP_RCATLINE;
7795 o->op_flags |= OPf_STACKED;
7796 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7797 op_null(o->op_next->op_next);
7798 op_null(o->op_next);
7815 while (cLOGOP->op_other->op_type == OP_NULL)
7816 cLOGOP->op_other = cLOGOP->op_other->op_next;
7817 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7823 while (cLOOP->op_redoop->op_type == OP_NULL)
7824 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7825 peep(cLOOP->op_redoop);
7826 while (cLOOP->op_nextop->op_type == OP_NULL)
7827 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7828 peep(cLOOP->op_nextop);
7829 while (cLOOP->op_lastop->op_type == OP_NULL)
7830 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7831 peep(cLOOP->op_lastop);
7838 while (cPMOP->op_pmreplstart &&
7839 cPMOP->op_pmreplstart->op_type == OP_NULL)
7840 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7841 peep(cPMOP->op_pmreplstart);
7846 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7847 && ckWARN(WARN_SYNTAX))
7849 if (o->op_next->op_sibling) {
7850 const OPCODE type = o->op_next->op_sibling->op_type;
7851 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7852 const line_t oldline = CopLINE(PL_curcop);
7853 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7854 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7855 "Statement unlikely to be reached");
7856 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7857 "\t(Maybe you meant system() when you said exec()?)\n");
7858 CopLINE_set(PL_curcop, oldline);
7869 const char *key = NULL;
7874 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7877 /* Make the CONST have a shared SV */
7878 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7879 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7880 key = SvPV_const(sv, keylen);
7881 lexname = newSVpvn_share(key,
7882 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7888 if ((o->op_private & (OPpLVAL_INTRO)))
7891 rop = (UNOP*)((BINOP*)o)->op_first;
7892 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7894 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7895 if (!SvPAD_TYPED(lexname))
7897 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7898 if (!fields || !GvHV(*fields))
7900 key = SvPV_const(*svp, keylen);
7901 if (!hv_fetch(GvHV(*fields), key,
7902 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7904 Perl_croak(aTHX_ "No such class field \"%s\" "
7905 "in variable %s of type %s",
7906 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7919 SVOP *first_key_op, *key_op;
7921 if ((o->op_private & (OPpLVAL_INTRO))
7922 /* I bet there's always a pushmark... */
7923 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7924 /* hmmm, no optimization if list contains only one key. */
7926 rop = (UNOP*)((LISTOP*)o)->op_last;
7927 if (rop->op_type != OP_RV2HV)
7929 if (rop->op_first->op_type == OP_PADSV)
7930 /* @$hash{qw(keys here)} */
7931 rop = (UNOP*)rop->op_first;
7933 /* @{$hash}{qw(keys here)} */
7934 if (rop->op_first->op_type == OP_SCOPE
7935 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7937 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7943 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7944 if (!SvPAD_TYPED(lexname))
7946 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7947 if (!fields || !GvHV(*fields))
7949 /* Again guessing that the pushmark can be jumped over.... */
7950 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7951 ->op_first->op_sibling;
7952 for (key_op = first_key_op; key_op;
7953 key_op = (SVOP*)key_op->op_sibling) {
7954 if (key_op->op_type != OP_CONST)
7956 svp = cSVOPx_svp(key_op);
7957 key = SvPV_const(*svp, keylen);
7958 if (!hv_fetch(GvHV(*fields), key,
7959 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7961 Perl_croak(aTHX_ "No such class field \"%s\" "
7962 "in variable %s of type %s",
7963 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7970 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7974 /* check that RHS of sort is a single plain array */
7975 OP *oright = cUNOPo->op_first;
7976 if (!oright || oright->op_type != OP_PUSHMARK)
7979 /* reverse sort ... can be optimised. */
7980 if (!cUNOPo->op_sibling) {
7981 /* Nothing follows us on the list. */
7982 OP * const reverse = o->op_next;
7984 if (reverse->op_type == OP_REVERSE &&
7985 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7986 OP * const pushmark = cUNOPx(reverse)->op_first;
7987 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7988 && (cUNOPx(pushmark)->op_sibling == o)) {
7989 /* reverse -> pushmark -> sort */
7990 o->op_private |= OPpSORT_REVERSE;
7992 pushmark->op_next = oright->op_next;
7998 /* make @a = sort @a act in-place */
8002 oright = cUNOPx(oright)->op_sibling;
8005 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8006 oright = cUNOPx(oright)->op_sibling;
8010 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8011 || oright->op_next != o
8012 || (oright->op_private & OPpLVAL_INTRO)
8016 /* o2 follows the chain of op_nexts through the LHS of the
8017 * assign (if any) to the aassign op itself */
8019 if (!o2 || o2->op_type != OP_NULL)
8022 if (!o2 || o2->op_type != OP_PUSHMARK)
8025 if (o2 && o2->op_type == OP_GV)
8028 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8029 || (o2->op_private & OPpLVAL_INTRO)
8034 if (!o2 || o2->op_type != OP_NULL)
8037 if (!o2 || o2->op_type != OP_AASSIGN
8038 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8041 /* check that the sort is the first arg on RHS of assign */
8043 o2 = cUNOPx(o2)->op_first;
8044 if (!o2 || o2->op_type != OP_NULL)
8046 o2 = cUNOPx(o2)->op_first;
8047 if (!o2 || o2->op_type != OP_PUSHMARK)
8049 if (o2->op_sibling != o)
8052 /* check the array is the same on both sides */
8053 if (oleft->op_type == OP_RV2AV) {
8054 if (oright->op_type != OP_RV2AV
8055 || !cUNOPx(oright)->op_first
8056 || cUNOPx(oright)->op_first->op_type != OP_GV
8057 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8058 cGVOPx_gv(cUNOPx(oright)->op_first)
8062 else if (oright->op_type != OP_PADAV
8063 || oright->op_targ != oleft->op_targ
8067 /* transfer MODishness etc from LHS arg to RHS arg */
8068 oright->op_flags = oleft->op_flags;
8069 o->op_private |= OPpSORT_INPLACE;
8071 /* excise push->gv->rv2av->null->aassign */
8072 o2 = o->op_next->op_next;
8073 op_null(o2); /* PUSHMARK */
8075 if (o2->op_type == OP_GV) {
8076 op_null(o2); /* GV */
8079 op_null(o2); /* RV2AV or PADAV */
8080 o2 = o2->op_next->op_next;
8081 op_null(o2); /* AASSIGN */
8083 o->op_next = o2->op_next;
8089 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8091 LISTOP *enter, *exlist;
8094 enter = (LISTOP *) o->op_next;
8097 if (enter->op_type == OP_NULL) {
8098 enter = (LISTOP *) enter->op_next;
8102 /* for $a (...) will have OP_GV then OP_RV2GV here.
8103 for (...) just has an OP_GV. */
8104 if (enter->op_type == OP_GV) {
8105 gvop = (OP *) enter;
8106 enter = (LISTOP *) enter->op_next;
8109 if (enter->op_type == OP_RV2GV) {
8110 enter = (LISTOP *) enter->op_next;
8116 if (enter->op_type != OP_ENTERITER)
8119 iter = enter->op_next;
8120 if (!iter || iter->op_type != OP_ITER)
8123 expushmark = enter->op_first;
8124 if (!expushmark || expushmark->op_type != OP_NULL
8125 || expushmark->op_targ != OP_PUSHMARK)
8128 exlist = (LISTOP *) expushmark->op_sibling;
8129 if (!exlist || exlist->op_type != OP_NULL
8130 || exlist->op_targ != OP_LIST)
8133 if (exlist->op_last != o) {
8134 /* Mmm. Was expecting to point back to this op. */
8137 theirmark = exlist->op_first;
8138 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8141 if (theirmark->op_sibling != o) {
8142 /* There's something between the mark and the reverse, eg
8143 for (1, reverse (...))
8148 ourmark = ((LISTOP *)o)->op_first;
8149 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8152 ourlast = ((LISTOP *)o)->op_last;
8153 if (!ourlast || ourlast->op_next != o)
8156 rv2av = ourmark->op_sibling;
8157 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8158 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8159 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8160 /* We're just reversing a single array. */
8161 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8162 enter->op_flags |= OPf_STACKED;
8165 /* We don't have control over who points to theirmark, so sacrifice
8167 theirmark->op_next = ourmark->op_next;
8168 theirmark->op_flags = ourmark->op_flags;
8169 ourlast->op_next = gvop ? gvop : (OP *) enter;
8172 enter->op_private |= OPpITER_REVERSED;
8173 iter->op_private |= OPpITER_REVERSED;
8180 UNOP *refgen, *rv2cv;
8183 /* I do not understand this, but if o->op_opt isn't set to 1,
8184 various tests in ext/B/t/bytecode.t fail with no readily
8190 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8193 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8196 rv2gv = ((BINOP *)o)->op_last;
8197 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8200 refgen = (UNOP *)((BINOP *)o)->op_first;
8202 if (!refgen || refgen->op_type != OP_REFGEN)
8205 exlist = (LISTOP *)refgen->op_first;
8206 if (!exlist || exlist->op_type != OP_NULL
8207 || exlist->op_targ != OP_LIST)
8210 if (exlist->op_first->op_type != OP_PUSHMARK)
8213 rv2cv = (UNOP*)exlist->op_last;
8215 if (rv2cv->op_type != OP_RV2CV)
8218 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8219 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8220 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8222 o->op_private |= OPpASSIGN_CV_TO_GV;
8223 rv2gv->op_private |= OPpDONT_INIT_GV;
8224 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8240 Perl_custom_op_name(pTHX_ const OP* o)
8243 const IV index = PTR2IV(o->op_ppaddr);
8247 if (!PL_custom_op_names) /* This probably shouldn't happen */
8248 return (char *)PL_op_name[OP_CUSTOM];
8250 keysv = sv_2mortal(newSViv(index));
8252 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8254 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8256 return SvPV_nolen(HeVAL(he));
8260 Perl_custom_op_desc(pTHX_ const OP* o)
8263 const IV index = PTR2IV(o->op_ppaddr);
8267 if (!PL_custom_op_descs)
8268 return (char *)PL_op_desc[OP_CUSTOM];
8270 keysv = sv_2mortal(newSViv(index));
8272 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8274 return (char *)PL_op_desc[OP_CUSTOM];
8276 return SvPV_nolen(HeVAL(he));
8281 /* Efficient sub that returns a constant scalar value. */
8283 const_sv_xsub(pTHX_ CV* cv)
8290 Perl_croak(aTHX_ "usage: %s::%s()",
8291 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8295 ST(0) = (SV*)XSANY.any_ptr;
8301 * c-indentation-style: bsd
8303 * indent-tabs-mode: t
8306 * ex: set ts=8 sts=4 sw=4 noet: