3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 * const * const ptr = (I32 **) op;
132 I32 * const slab = ptr[-1];
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, Nullch);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
201 qerror(Perl_mess(aTHX_
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
206 /* "register" allocation */
209 Perl_allocmy(pTHX_ char *name)
213 /* complain about "my $<special_var>" etc etc */
214 if (!(PL_in_my == KEY_our ||
216 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
217 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
219 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
220 /* 1999-02-27 mjd@plover.com */
222 p = strchr(name, '\0');
223 /* The next block assumes the buffer is at least 205 chars
224 long. At present, it's always at least 256 chars. */
226 strcpy(name+200, "...");
232 /* Move everything else down one character */
233 for (; p-name > 2; p--)
235 name[2] = toCTRL(name[1]);
238 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
241 /* check for duplicate declaration */
243 (bool)(PL_in_my == KEY_our),
244 (PL_curstash ? PL_curstash : PL_defstash)
247 if (PL_in_my_stash && *name != '$') {
248 yyerror(Perl_form(aTHX_
249 "Can't declare class for non-scalar %s in \"%s\"",
250 name, PL_in_my == KEY_our ? "our" : "my"));
253 /* allocate a spare slot and store the name in that slot */
255 off = pad_add_name(name,
258 /* $_ is always in main::, even with our */
259 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
270 Perl_op_free(pTHX_ OP *o)
276 if (!o || o->op_static)
279 if (o->op_private & OPpREFCOUNTED) {
280 switch (o->op_type) {
288 refcnt = OpREFCNT_dec(o);
298 if (o->op_flags & OPf_KIDS) {
299 register OP *kid, *nextkid;
300 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
301 nextkid = kid->op_sibling; /* Get before next freeing kid */
307 type = (OPCODE)o->op_targ;
309 /* COP* is not cleared by op_clear() so that we may track line
310 * numbers etc even after null() */
311 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
316 #ifdef DEBUG_LEAKING_SCALARS
323 Perl_op_clear(pTHX_ OP *o)
327 switch (o->op_type) {
328 case OP_NULL: /* Was holding old type, if any. */
329 case OP_ENTEREVAL: /* Was holding hints. */
333 if (!(o->op_flags & OPf_REF)
334 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
340 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
341 /* not an OP_PADAV replacement */
343 if (cPADOPo->op_padix > 0) {
344 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
345 * may still exist on the pad */
346 pad_swipe(cPADOPo->op_padix, TRUE);
347 cPADOPo->op_padix = 0;
350 SvREFCNT_dec(cSVOPo->op_sv);
351 cSVOPo->op_sv = Nullsv;
355 case OP_METHOD_NAMED:
357 SvREFCNT_dec(cSVOPo->op_sv);
358 cSVOPo->op_sv = Nullsv;
361 Even if op_clear does a pad_free for the target of the op,
362 pad_free doesn't actually remove the sv that exists in the pad;
363 instead it lives on. This results in that it could be reused as
364 a target later on when the pad was reallocated.
367 pad_swipe(o->op_targ,1);
376 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
380 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
381 SvREFCNT_dec(cSVOPo->op_sv);
382 cSVOPo->op_sv = Nullsv;
385 Safefree(cPVOPo->op_pv);
386 cPVOPo->op_pv = Nullch;
390 op_free(cPMOPo->op_pmreplroot);
394 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
395 /* No GvIN_PAD_off here, because other references may still
396 * exist on the pad */
397 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
400 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
407 HV * const pmstash = PmopSTASH(cPMOPo);
408 if (pmstash && SvREFCNT(pmstash)) {
409 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
411 PMOP *pmop = (PMOP*) mg->mg_obj;
412 PMOP *lastpmop = NULL;
414 if (cPMOPo == pmop) {
416 lastpmop->op_pmnext = pmop->op_pmnext;
418 mg->mg_obj = (SV*) pmop->op_pmnext;
422 pmop = pmop->op_pmnext;
426 PmopSTASH_free(cPMOPo);
428 cPMOPo->op_pmreplroot = Nullop;
429 /* we use the "SAFE" version of the PM_ macros here
430 * since sv_clean_all might release some PMOPs
431 * after PL_regex_padav has been cleared
432 * and the clearing of PL_regex_padav needs to
433 * happen before sv_clean_all
435 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
436 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
438 if(PL_regex_pad) { /* We could be in destruction */
439 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
440 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
441 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
448 if (o->op_targ > 0) {
449 pad_free(o->op_targ);
455 S_cop_free(pTHX_ COP* cop)
457 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
460 if (! specialWARN(cop->cop_warnings))
461 SvREFCNT_dec(cop->cop_warnings);
462 if (! specialCopIO(cop->cop_io)) {
466 char *s = SvPV(cop->cop_io,len);
467 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
470 SvREFCNT_dec(cop->cop_io);
476 Perl_op_null(pTHX_ OP *o)
479 if (o->op_type == OP_NULL)
482 o->op_targ = o->op_type;
483 o->op_type = OP_NULL;
484 o->op_ppaddr = PL_ppaddr[OP_NULL];
488 Perl_op_refcnt_lock(pTHX)
495 Perl_op_refcnt_unlock(pTHX)
501 /* Contextualizers */
503 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
506 Perl_linklist(pTHX_ OP *o)
512 /* establish postfix order */
513 if (cUNOPo->op_first) {
515 o->op_next = LINKLIST(cUNOPo->op_first);
516 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
518 kid->op_next = LINKLIST(kid->op_sibling);
530 Perl_scalarkids(pTHX_ OP *o)
532 if (o && o->op_flags & OPf_KIDS) {
534 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
541 S_scalarboolean(pTHX_ OP *o)
543 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
544 if (ckWARN(WARN_SYNTAX)) {
545 const line_t oldline = CopLINE(PL_curcop);
547 if (PL_copline != NOLINE)
548 CopLINE_set(PL_curcop, PL_copline);
549 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
550 CopLINE_set(PL_curcop, oldline);
557 Perl_scalar(pTHX_ OP *o)
562 /* assumes no premature commitment */
563 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
564 || o->op_type == OP_RETURN)
569 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
571 switch (o->op_type) {
573 scalar(cBINOPo->op_first);
578 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
582 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
583 if (!kPMOP->op_pmreplroot)
584 deprecate_old("implicit split to @_");
592 if (o->op_flags & OPf_KIDS) {
593 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
599 kid = cLISTOPo->op_first;
601 while ((kid = kid->op_sibling)) {
607 WITH_THR(PL_curcop = &PL_compiling);
612 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
618 WITH_THR(PL_curcop = &PL_compiling);
621 if (ckWARN(WARN_VOID))
622 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
628 Perl_scalarvoid(pTHX_ OP *o)
632 const char* useless = 0;
636 if (o->op_type == OP_NEXTSTATE
637 || o->op_type == OP_SETSTATE
638 || o->op_type == OP_DBSTATE
639 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
640 || o->op_targ == OP_SETSTATE
641 || o->op_targ == OP_DBSTATE)))
642 PL_curcop = (COP*)o; /* for warning below */
644 /* assumes no premature commitment */
645 want = o->op_flags & OPf_WANT;
646 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
647 || o->op_type == OP_RETURN)
652 if ((o->op_private & OPpTARGET_MY)
653 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
655 return scalar(o); /* As if inside SASSIGN */
658 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
660 switch (o->op_type) {
662 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
666 if (o->op_flags & OPf_STACKED)
670 if (o->op_private == 4)
742 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
743 useless = OP_DESC(o);
747 kid = cUNOPo->op_first;
748 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
749 kid->op_type != OP_TRANS) {
752 useless = "negative pattern binding (!~)";
759 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
760 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
761 useless = "a variable";
766 if (cSVOPo->op_private & OPpCONST_STRICT)
767 no_bareword_allowed(o);
769 if (ckWARN(WARN_VOID)) {
770 useless = "a constant";
771 /* don't warn on optimised away booleans, eg
772 * use constant Foo, 5; Foo || print; */
773 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
775 /* the constants 0 and 1 are permitted as they are
776 conventionally used as dummies in constructs like
777 1 while some_condition_with_side_effects; */
778 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
780 else if (SvPOK(sv)) {
781 /* perl4's way of mixing documentation and code
782 (before the invention of POD) was based on a
783 trick to mix nroff and perl code. The trick was
784 built upon these three nroff macros being used in
785 void context. The pink camel has the details in
786 the script wrapman near page 319. */
787 if (strnEQ(SvPVX_const(sv), "di", 2) ||
788 strnEQ(SvPVX_const(sv), "ds", 2) ||
789 strnEQ(SvPVX_const(sv), "ig", 2))
794 op_null(o); /* don't execute or even remember it */
798 o->op_type = OP_PREINC; /* pre-increment is faster */
799 o->op_ppaddr = PL_ppaddr[OP_PREINC];
803 o->op_type = OP_PREDEC; /* pre-decrement is faster */
804 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
808 o->op_type = OP_I_PREINC; /* pre-increment is faster */
809 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
813 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
814 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
821 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
826 if (o->op_flags & OPf_STACKED)
833 if (!(o->op_flags & OPf_KIDS))
842 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
849 /* all requires must return a boolean value */
850 o->op_flags &= ~OPf_WANT;
855 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
856 if (!kPMOP->op_pmreplroot)
857 deprecate_old("implicit split to @_");
861 if (useless && ckWARN(WARN_VOID))
862 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
867 Perl_listkids(pTHX_ OP *o)
869 if (o && o->op_flags & OPf_KIDS) {
871 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
878 Perl_list(pTHX_ OP *o)
883 /* assumes no premature commitment */
884 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
885 || o->op_type == OP_RETURN)
890 if ((o->op_private & OPpTARGET_MY)
891 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
893 return o; /* As if inside SASSIGN */
896 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
898 switch (o->op_type) {
901 list(cBINOPo->op_first);
906 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
914 if (!(o->op_flags & OPf_KIDS))
916 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
917 list(cBINOPo->op_first);
918 return gen_constant_list(o);
925 kid = cLISTOPo->op_first;
927 while ((kid = kid->op_sibling)) {
933 WITH_THR(PL_curcop = &PL_compiling);
937 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
943 WITH_THR(PL_curcop = &PL_compiling);
946 /* all requires must return a boolean value */
947 o->op_flags &= ~OPf_WANT;
954 Perl_scalarseq(pTHX_ OP *o)
957 if (o->op_type == OP_LINESEQ ||
958 o->op_type == OP_SCOPE ||
959 o->op_type == OP_LEAVE ||
960 o->op_type == OP_LEAVETRY)
963 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
964 if (kid->op_sibling) {
968 PL_curcop = &PL_compiling;
970 o->op_flags &= ~OPf_PARENS;
971 if (PL_hints & HINT_BLOCK_SCOPE)
972 o->op_flags |= OPf_PARENS;
975 o = newOP(OP_STUB, 0);
980 S_modkids(pTHX_ OP *o, I32 type)
982 if (o && o->op_flags & OPf_KIDS) {
984 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
990 /* Propagate lvalue ("modifiable") context to an op and it's children.
991 * 'type' represents the context type, roughly based on the type of op that
992 * would do the modifying, although local() is represented by OP_NULL.
993 * It's responsible for detecting things that can't be modified, flag
994 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
995 * might have to vivify a reference in $x), and so on.
997 * For example, "$a+1 = 2" would cause mod() to be called with o being
998 * OP_ADD and type being OP_SASSIGN, and would output an error.
1002 Perl_mod(pTHX_ OP *o, I32 type)
1006 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1009 if (!o || PL_error_count)
1012 if ((o->op_private & OPpTARGET_MY)
1013 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1018 switch (o->op_type) {
1024 if (!(o->op_private & (OPpCONST_ARYBASE)))
1026 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1027 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1031 SAVEI32(PL_compiling.cop_arybase);
1032 PL_compiling.cop_arybase = 0;
1034 else if (type == OP_REFGEN)
1037 Perl_croak(aTHX_ "That use of $[ is unsupported");
1040 if (o->op_flags & OPf_PARENS)
1044 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1045 !(o->op_flags & OPf_STACKED)) {
1046 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1047 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1048 assert(cUNOPo->op_first->op_type == OP_NULL);
1049 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1052 else if (o->op_private & OPpENTERSUB_NOMOD)
1054 else { /* lvalue subroutine call */
1055 o->op_private |= OPpLVAL_INTRO;
1056 PL_modcount = RETURN_UNLIMITED_NUMBER;
1057 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1058 /* Backward compatibility mode: */
1059 o->op_private |= OPpENTERSUB_INARGS;
1062 else { /* Compile-time error message: */
1063 OP *kid = cUNOPo->op_first;
1067 if (kid->op_type == OP_PUSHMARK)
1069 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1071 "panic: unexpected lvalue entersub "
1072 "args: type/targ %ld:%"UVuf,
1073 (long)kid->op_type, (UV)kid->op_targ);
1074 kid = kLISTOP->op_first;
1076 while (kid->op_sibling)
1077 kid = kid->op_sibling;
1078 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1080 if (kid->op_type == OP_METHOD_NAMED
1081 || kid->op_type == OP_METHOD)
1085 NewOp(1101, newop, 1, UNOP);
1086 newop->op_type = OP_RV2CV;
1087 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1088 newop->op_first = Nullop;
1089 newop->op_next = (OP*)newop;
1090 kid->op_sibling = (OP*)newop;
1091 newop->op_private |= OPpLVAL_INTRO;
1095 if (kid->op_type != OP_RV2CV)
1097 "panic: unexpected lvalue entersub "
1098 "entry via type/targ %ld:%"UVuf,
1099 (long)kid->op_type, (UV)kid->op_targ);
1100 kid->op_private |= OPpLVAL_INTRO;
1101 break; /* Postpone until runtime */
1105 kid = kUNOP->op_first;
1106 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1107 kid = kUNOP->op_first;
1108 if (kid->op_type == OP_NULL)
1110 "Unexpected constant lvalue entersub "
1111 "entry via type/targ %ld:%"UVuf,
1112 (long)kid->op_type, (UV)kid->op_targ);
1113 if (kid->op_type != OP_GV) {
1114 /* Restore RV2CV to check lvalueness */
1116 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1117 okid->op_next = kid->op_next;
1118 kid->op_next = okid;
1121 okid->op_next = Nullop;
1122 okid->op_type = OP_RV2CV;
1124 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1125 okid->op_private |= OPpLVAL_INTRO;
1129 cv = GvCV(kGVOP_gv);
1139 /* grep, foreach, subcalls, refgen */
1140 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1142 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1143 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1145 : (o->op_type == OP_ENTERSUB
1146 ? "non-lvalue subroutine call"
1148 type ? PL_op_desc[type] : "local"));
1162 case OP_RIGHT_SHIFT:
1171 if (!(o->op_flags & OPf_STACKED))
1178 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1184 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1185 PL_modcount = RETURN_UNLIMITED_NUMBER;
1186 return o; /* Treat \(@foo) like ordinary list. */
1190 if (scalar_mod_type(o, type))
1192 ref(cUNOPo->op_first, o->op_type);
1196 if (type == OP_LEAVESUBLV)
1197 o->op_private |= OPpMAYBE_LVSUB;
1203 PL_modcount = RETURN_UNLIMITED_NUMBER;
1206 ref(cUNOPo->op_first, o->op_type);
1211 PL_hints |= HINT_BLOCK_SCOPE;
1226 PL_modcount = RETURN_UNLIMITED_NUMBER;
1227 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1228 return o; /* Treat \(@foo) like ordinary list. */
1229 if (scalar_mod_type(o, type))
1231 if (type == OP_LEAVESUBLV)
1232 o->op_private |= OPpMAYBE_LVSUB;
1236 if (!type) /* local() */
1237 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1238 PAD_COMPNAME_PV(o->op_targ));
1246 if (type != OP_SASSIGN)
1250 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1255 if (type == OP_LEAVESUBLV)
1256 o->op_private |= OPpMAYBE_LVSUB;
1258 pad_free(o->op_targ);
1259 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1260 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1261 if (o->op_flags & OPf_KIDS)
1262 mod(cBINOPo->op_first->op_sibling, type);
1267 ref(cBINOPo->op_first, o->op_type);
1268 if (type == OP_ENTERSUB &&
1269 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1270 o->op_private |= OPpLVAL_DEFER;
1271 if (type == OP_LEAVESUBLV)
1272 o->op_private |= OPpMAYBE_LVSUB;
1282 if (o->op_flags & OPf_KIDS)
1283 mod(cLISTOPo->op_last, type);
1288 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1290 else if (!(o->op_flags & OPf_KIDS))
1292 if (o->op_targ != OP_LIST) {
1293 mod(cBINOPo->op_first, type);
1299 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1304 if (type != OP_LEAVESUBLV)
1306 break; /* mod()ing was handled by ck_return() */
1309 /* [20011101.069] File test operators interpret OPf_REF to mean that
1310 their argument is a filehandle; thus \stat(".") should not set
1312 if (type == OP_REFGEN &&
1313 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1316 if (type != OP_LEAVESUBLV)
1317 o->op_flags |= OPf_MOD;
1319 if (type == OP_AASSIGN || type == OP_SASSIGN)
1320 o->op_flags |= OPf_SPECIAL|OPf_REF;
1321 else if (!type) { /* local() */
1324 o->op_private |= OPpLVAL_INTRO;
1325 o->op_flags &= ~OPf_SPECIAL;
1326 PL_hints |= HINT_BLOCK_SCOPE;
1331 if (ckWARN(WARN_SYNTAX)) {
1332 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1333 "Useless localization of %s", OP_DESC(o));
1337 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1338 && type != OP_LEAVESUBLV)
1339 o->op_flags |= OPf_REF;
1344 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1348 if (o->op_type == OP_RV2GV)
1372 case OP_RIGHT_SHIFT:
1391 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1393 switch (o->op_type) {
1401 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1414 Perl_refkids(pTHX_ OP *o, I32 type)
1416 if (o && o->op_flags & OPf_KIDS) {
1418 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1425 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1430 if (!o || PL_error_count)
1433 switch (o->op_type) {
1435 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1436 !(o->op_flags & OPf_STACKED)) {
1437 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1438 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1439 assert(cUNOPo->op_first->op_type == OP_NULL);
1440 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1441 o->op_flags |= OPf_SPECIAL;
1446 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1447 doref(kid, type, set_op_ref);
1450 if (type == OP_DEFINED)
1451 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1452 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1455 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1456 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1457 : type == OP_RV2HV ? OPpDEREF_HV
1459 o->op_flags |= OPf_MOD;
1464 o->op_flags |= OPf_MOD; /* XXX ??? */
1470 o->op_flags |= OPf_REF;
1473 if (type == OP_DEFINED)
1474 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1475 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1481 o->op_flags |= OPf_REF;
1486 if (!(o->op_flags & OPf_KIDS))
1488 doref(cBINOPo->op_first, type, set_op_ref);
1492 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1493 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1494 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1495 : type == OP_RV2HV ? OPpDEREF_HV
1497 o->op_flags |= OPf_MOD;
1507 if (!(o->op_flags & OPf_KIDS))
1509 doref(cLISTOPo->op_last, type, set_op_ref);
1519 S_dup_attrlist(pTHX_ OP *o)
1523 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1524 * where the first kid is OP_PUSHMARK and the remaining ones
1525 * are OP_CONST. We need to push the OP_CONST values.
1527 if (o->op_type == OP_CONST)
1528 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1530 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1531 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1532 if (o->op_type == OP_CONST)
1533 rop = append_elem(OP_LIST, rop,
1534 newSVOP(OP_CONST, o->op_flags,
1535 SvREFCNT_inc(cSVOPo->op_sv)));
1542 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1547 /* fake up C<use attributes $pkg,$rv,@attrs> */
1548 ENTER; /* need to protect against side-effects of 'use' */
1550 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1552 #define ATTRSMODULE "attributes"
1553 #define ATTRSMODULE_PM "attributes.pm"
1556 /* Don't force the C<use> if we don't need it. */
1557 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1558 sizeof(ATTRSMODULE_PM)-1, 0);
1559 if (svp && *svp != &PL_sv_undef)
1560 ; /* already in %INC */
1562 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1563 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1567 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1568 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1570 prepend_elem(OP_LIST,
1571 newSVOP(OP_CONST, 0, stashsv),
1572 prepend_elem(OP_LIST,
1573 newSVOP(OP_CONST, 0,
1575 dup_attrlist(attrs))));
1581 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1583 OP *pack, *imop, *arg;
1589 assert(target->op_type == OP_PADSV ||
1590 target->op_type == OP_PADHV ||
1591 target->op_type == OP_PADAV);
1593 /* Ensure that attributes.pm is loaded. */
1594 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1596 /* Need package name for method call. */
1597 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1599 /* Build up the real arg-list. */
1600 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1602 arg = newOP(OP_PADSV, 0);
1603 arg->op_targ = target->op_targ;
1604 arg = prepend_elem(OP_LIST,
1605 newSVOP(OP_CONST, 0, stashsv),
1606 prepend_elem(OP_LIST,
1607 newUNOP(OP_REFGEN, 0,
1608 mod(arg, OP_REFGEN)),
1609 dup_attrlist(attrs)));
1611 /* Fake up a method call to import */
1612 meth = newSVpvn_share("import", 6, 0);
1613 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1614 append_elem(OP_LIST,
1615 prepend_elem(OP_LIST, pack, list(arg)),
1616 newSVOP(OP_METHOD_NAMED, 0, meth)));
1617 imop->op_private |= OPpENTERSUB_NOMOD;
1619 /* Combine the ops. */
1620 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1624 =notfor apidoc apply_attrs_string
1626 Attempts to apply a list of attributes specified by the C<attrstr> and
1627 C<len> arguments to the subroutine identified by the C<cv> argument which
1628 is expected to be associated with the package identified by the C<stashpv>
1629 argument (see L<attributes>). It gets this wrong, though, in that it
1630 does not correctly identify the boundaries of the individual attribute
1631 specifications within C<attrstr>. This is not really intended for the
1632 public API, but has to be listed here for systems such as AIX which
1633 need an explicit export list for symbols. (It's called from XS code
1634 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1635 to respect attribute syntax properly would be welcome.
1641 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1642 const char *attrstr, STRLEN len)
1647 len = strlen(attrstr);
1651 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1653 const char * const sstr = attrstr;
1654 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1655 attrs = append_elem(OP_LIST, attrs,
1656 newSVOP(OP_CONST, 0,
1657 newSVpvn(sstr, attrstr-sstr)));
1661 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1662 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1663 Nullsv, prepend_elem(OP_LIST,
1664 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1665 prepend_elem(OP_LIST,
1666 newSVOP(OP_CONST, 0,
1672 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1676 if (!o || PL_error_count)
1680 if (type == OP_LIST) {
1682 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1683 my_kid(kid, attrs, imopsp);
1684 } else if (type == OP_UNDEF) {
1686 } else if (type == OP_RV2SV || /* "our" declaration */
1688 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1689 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1690 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1691 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1693 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1695 PL_in_my_stash = Nullhv;
1696 apply_attrs(GvSTASH(gv),
1697 (type == OP_RV2SV ? GvSV(gv) :
1698 type == OP_RV2AV ? (SV*)GvAV(gv) :
1699 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1702 o->op_private |= OPpOUR_INTRO;
1705 else if (type != OP_PADSV &&
1708 type != OP_PUSHMARK)
1710 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1712 PL_in_my == KEY_our ? "our" : "my"));
1715 else if (attrs && type != OP_PUSHMARK) {
1719 PL_in_my_stash = Nullhv;
1721 /* check for C<my Dog $spot> when deciding package */
1722 stash = PAD_COMPNAME_TYPE(o->op_targ);
1724 stash = PL_curstash;
1725 apply_attrs_my(stash, o, attrs, imopsp);
1727 o->op_flags |= OPf_MOD;
1728 o->op_private |= OPpLVAL_INTRO;
1733 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1736 int maybe_scalar = 0;
1738 /* [perl #17376]: this appears to be premature, and results in code such as
1739 C< our(%x); > executing in list mode rather than void mode */
1741 if (o->op_flags & OPf_PARENS)
1750 o = my_kid(o, attrs, &rops);
1752 if (maybe_scalar && o->op_type == OP_PADSV) {
1753 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1754 o->op_private |= OPpLVAL_INTRO;
1757 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1760 PL_in_my_stash = Nullhv;
1765 Perl_my(pTHX_ OP *o)
1767 return my_attrs(o, Nullop);
1771 Perl_sawparens(pTHX_ OP *o)
1774 o->op_flags |= OPf_PARENS;
1779 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1784 if ( (left->op_type == OP_RV2AV ||
1785 left->op_type == OP_RV2HV ||
1786 left->op_type == OP_PADAV ||
1787 left->op_type == OP_PADHV)
1788 && ckWARN(WARN_MISC))
1790 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1791 right->op_type == OP_TRANS)
1792 ? right->op_type : OP_MATCH];
1793 const char * const sample = ((left->op_type == OP_RV2AV ||
1794 left->op_type == OP_PADAV)
1795 ? "@array" : "%hash");
1796 Perl_warner(aTHX_ packWARN(WARN_MISC),
1797 "Applying %s to %s will act on scalar(%s)",
1798 desc, sample, sample);
1801 if (right->op_type == OP_CONST &&
1802 cSVOPx(right)->op_private & OPpCONST_BARE &&
1803 cSVOPx(right)->op_private & OPpCONST_STRICT)
1805 no_bareword_allowed(right);
1808 ismatchop = right->op_type == OP_MATCH ||
1809 right->op_type == OP_SUBST ||
1810 right->op_type == OP_TRANS;
1811 if (ismatchop && right->op_private & OPpTARGET_MY) {
1813 right->op_private &= ~OPpTARGET_MY;
1815 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1816 right->op_flags |= OPf_STACKED;
1817 if (right->op_type != OP_MATCH &&
1818 ! (right->op_type == OP_TRANS &&
1819 right->op_private & OPpTRANS_IDENTICAL))
1820 left = mod(left, right->op_type);
1821 if (right->op_type == OP_TRANS)
1822 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1824 o = prepend_elem(right->op_type, scalar(left), right);
1826 return newUNOP(OP_NOT, 0, scalar(o));
1830 return bind_match(type, left,
1831 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1835 Perl_invert(pTHX_ OP *o)
1839 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1840 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1844 Perl_scope(pTHX_ OP *o)
1848 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1849 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1850 o->op_type = OP_LEAVE;
1851 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1853 else if (o->op_type == OP_LINESEQ) {
1855 o->op_type = OP_SCOPE;
1856 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1857 kid = ((LISTOP*)o)->op_first;
1858 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1861 /* The following deals with things like 'do {1 for 1}' */
1862 kid = kid->op_sibling;
1864 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1869 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1875 Perl_block_start(pTHX_ int full)
1877 const int retval = PL_savestack_ix;
1878 pad_block_start(full);
1880 PL_hints &= ~HINT_BLOCK_SCOPE;
1881 SAVESPTR(PL_compiling.cop_warnings);
1882 if (! specialWARN(PL_compiling.cop_warnings)) {
1883 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1884 SAVEFREESV(PL_compiling.cop_warnings) ;
1886 SAVESPTR(PL_compiling.cop_io);
1887 if (! specialCopIO(PL_compiling.cop_io)) {
1888 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1889 SAVEFREESV(PL_compiling.cop_io) ;
1895 Perl_block_end(pTHX_ I32 floor, OP *seq)
1897 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1898 OP* const retval = scalarseq(seq);
1900 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1902 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1910 const I32 offset = pad_findmy("$_");
1911 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1912 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1915 OP * const o = newOP(OP_PADSV, 0);
1916 o->op_targ = offset;
1922 Perl_newPROG(pTHX_ OP *o)
1927 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1928 ((PL_in_eval & EVAL_KEEPERR)
1929 ? OPf_SPECIAL : 0), o);
1930 PL_eval_start = linklist(PL_eval_root);
1931 PL_eval_root->op_private |= OPpREFCOUNTED;
1932 OpREFCNT_set(PL_eval_root, 1);
1933 PL_eval_root->op_next = 0;
1934 CALL_PEEP(PL_eval_start);
1937 if (o->op_type == OP_STUB) {
1938 PL_comppad_name = 0;
1943 PL_main_root = scope(sawparens(scalarvoid(o)));
1944 PL_curcop = &PL_compiling;
1945 PL_main_start = LINKLIST(PL_main_root);
1946 PL_main_root->op_private |= OPpREFCOUNTED;
1947 OpREFCNT_set(PL_main_root, 1);
1948 PL_main_root->op_next = 0;
1949 CALL_PEEP(PL_main_start);
1952 /* Register with debugger */
1954 CV * const cv = get_cv("DB::postponed", FALSE);
1958 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1960 call_sv((SV*)cv, G_DISCARD);
1967 Perl_localize(pTHX_ OP *o, I32 lex)
1969 if (o->op_flags & OPf_PARENS)
1970 /* [perl #17376]: this appears to be premature, and results in code such as
1971 C< our(%x); > executing in list mode rather than void mode */
1978 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
1979 && ckWARN(WARN_PARENTHESIS))
1981 char *s = PL_bufptr;
1984 /* some heuristics to detect a potential error */
1985 while (*s && (strchr(", \t\n", *s)))
1989 if (*s && strchr("@$%*", *s) && *++s
1990 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1993 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1995 while (*s && (strchr(", \t\n", *s)))
2001 if (sigil && (*s == ';' || *s == '=')) {
2002 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2003 "Parentheses missing around \"%s\" list",
2004 lex ? (PL_in_my == KEY_our ? "our" : "my")
2012 o = mod(o, OP_NULL); /* a bit kludgey */
2014 PL_in_my_stash = Nullhv;
2019 Perl_jmaybe(pTHX_ OP *o)
2021 if (o->op_type == OP_LIST) {
2023 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2024 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2030 Perl_fold_constants(pTHX_ register OP *o)
2034 I32 type = o->op_type;
2037 if (PL_opargs[type] & OA_RETSCALAR)
2039 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2040 o->op_targ = pad_alloc(type, SVs_PADTMP);
2042 /* integerize op, unless it happens to be C<-foo>.
2043 * XXX should pp_i_negate() do magic string negation instead? */
2044 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2045 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2046 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2048 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2051 if (!(PL_opargs[type] & OA_FOLDCONST))
2056 /* XXX might want a ck_negate() for this */
2057 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2069 /* XXX what about the numeric ops? */
2070 if (PL_hints & HINT_LOCALE)
2075 goto nope; /* Don't try to run w/ errors */
2077 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2078 if ((curop->op_type != OP_CONST ||
2079 (curop->op_private & OPpCONST_BARE)) &&
2080 curop->op_type != OP_LIST &&
2081 curop->op_type != OP_SCALAR &&
2082 curop->op_type != OP_NULL &&
2083 curop->op_type != OP_PUSHMARK)
2089 curop = LINKLIST(o);
2093 sv = *(PL_stack_sp--);
2094 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2095 pad_swipe(o->op_targ, FALSE);
2096 else if (SvTEMP(sv)) { /* grab mortal temp? */
2097 (void)SvREFCNT_inc(sv);
2101 if (type == OP_RV2GV)
2102 return newGVOP(OP_GV, 0, (GV*)sv);
2103 return newSVOP(OP_CONST, 0, sv);
2110 Perl_gen_constant_list(pTHX_ register OP *o)
2114 const I32 oldtmps_floor = PL_tmps_floor;
2118 return o; /* Don't attempt to run with errors */
2120 PL_op = curop = LINKLIST(o);
2127 PL_tmps_floor = oldtmps_floor;
2129 o->op_type = OP_RV2AV;
2130 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2131 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2132 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2133 o->op_opt = 0; /* needs to be revisited in peep() */
2134 curop = ((UNOP*)o)->op_first;
2135 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2142 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2145 if (!o || o->op_type != OP_LIST)
2146 o = newLISTOP(OP_LIST, 0, o, Nullop);
2148 o->op_flags &= ~OPf_WANT;
2150 if (!(PL_opargs[type] & OA_MARK))
2151 op_null(cLISTOPo->op_first);
2153 o->op_type = (OPCODE)type;
2154 o->op_ppaddr = PL_ppaddr[type];
2155 o->op_flags |= flags;
2157 o = CHECKOP(type, o);
2158 if (o->op_type != (unsigned)type)
2161 return fold_constants(o);
2164 /* List constructors */
2167 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2175 if (first->op_type != (unsigned)type
2176 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2178 return newLISTOP(type, 0, first, last);
2181 if (first->op_flags & OPf_KIDS)
2182 ((LISTOP*)first)->op_last->op_sibling = last;
2184 first->op_flags |= OPf_KIDS;
2185 ((LISTOP*)first)->op_first = last;
2187 ((LISTOP*)first)->op_last = last;
2192 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2200 if (first->op_type != (unsigned)type)
2201 return prepend_elem(type, (OP*)first, (OP*)last);
2203 if (last->op_type != (unsigned)type)
2204 return append_elem(type, (OP*)first, (OP*)last);
2206 first->op_last->op_sibling = last->op_first;
2207 first->op_last = last->op_last;
2208 first->op_flags |= (last->op_flags & OPf_KIDS);
2216 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2224 if (last->op_type == (unsigned)type) {
2225 if (type == OP_LIST) { /* already a PUSHMARK there */
2226 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2227 ((LISTOP*)last)->op_first->op_sibling = first;
2228 if (!(first->op_flags & OPf_PARENS))
2229 last->op_flags &= ~OPf_PARENS;
2232 if (!(last->op_flags & OPf_KIDS)) {
2233 ((LISTOP*)last)->op_last = first;
2234 last->op_flags |= OPf_KIDS;
2236 first->op_sibling = ((LISTOP*)last)->op_first;
2237 ((LISTOP*)last)->op_first = first;
2239 last->op_flags |= OPf_KIDS;
2243 return newLISTOP(type, 0, first, last);
2249 Perl_newNULLLIST(pTHX)
2251 return newOP(OP_STUB, 0);
2255 Perl_force_list(pTHX_ OP *o)
2257 if (!o || o->op_type != OP_LIST)
2258 o = newLISTOP(OP_LIST, 0, o, Nullop);
2264 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2269 NewOp(1101, listop, 1, LISTOP);
2271 listop->op_type = (OPCODE)type;
2272 listop->op_ppaddr = PL_ppaddr[type];
2275 listop->op_flags = (U8)flags;
2279 else if (!first && last)
2282 first->op_sibling = last;
2283 listop->op_first = first;
2284 listop->op_last = last;
2285 if (type == OP_LIST) {
2286 OP* const pushop = newOP(OP_PUSHMARK, 0);
2287 pushop->op_sibling = first;
2288 listop->op_first = pushop;
2289 listop->op_flags |= OPf_KIDS;
2291 listop->op_last = pushop;
2294 return CHECKOP(type, listop);
2298 Perl_newOP(pTHX_ I32 type, I32 flags)
2302 NewOp(1101, o, 1, OP);
2303 o->op_type = (OPCODE)type;
2304 o->op_ppaddr = PL_ppaddr[type];
2305 o->op_flags = (U8)flags;
2308 o->op_private = (U8)(0 | (flags >> 8));
2309 if (PL_opargs[type] & OA_RETSCALAR)
2311 if (PL_opargs[type] & OA_TARGET)
2312 o->op_targ = pad_alloc(type, SVs_PADTMP);
2313 return CHECKOP(type, o);
2317 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2323 first = newOP(OP_STUB, 0);
2324 if (PL_opargs[type] & OA_MARK)
2325 first = force_list(first);
2327 NewOp(1101, unop, 1, UNOP);
2328 unop->op_type = (OPCODE)type;
2329 unop->op_ppaddr = PL_ppaddr[type];
2330 unop->op_first = first;
2331 unop->op_flags = (U8)(flags | OPf_KIDS);
2332 unop->op_private = (U8)(1 | (flags >> 8));
2333 unop = (UNOP*) CHECKOP(type, unop);
2337 return fold_constants((OP *) unop);
2341 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2345 NewOp(1101, binop, 1, BINOP);
2348 first = newOP(OP_NULL, 0);
2350 binop->op_type = (OPCODE)type;
2351 binop->op_ppaddr = PL_ppaddr[type];
2352 binop->op_first = first;
2353 binop->op_flags = (U8)(flags | OPf_KIDS);
2356 binop->op_private = (U8)(1 | (flags >> 8));
2359 binop->op_private = (U8)(2 | (flags >> 8));
2360 first->op_sibling = last;
2363 binop = (BINOP*)CHECKOP(type, binop);
2364 if (binop->op_next || binop->op_type != (OPCODE)type)
2367 binop->op_last = binop->op_first->op_sibling;
2369 return fold_constants((OP *)binop);
2372 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2373 static int uvcompare(const void *a, const void *b)
2375 if (*((const UV *)a) < (*(const UV *)b))
2377 if (*((const UV *)a) > (*(const UV *)b))
2379 if (*((const UV *)a+1) < (*(const UV *)b+1))
2381 if (*((const UV *)a+1) > (*(const UV *)b+1))
2387 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2389 SV * const tstr = ((SVOP*)expr)->op_sv;
2390 SV * const rstr = ((SVOP*)repl)->op_sv;
2393 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2394 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2398 register short *tbl;
2400 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2401 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2402 I32 del = o->op_private & OPpTRANS_DELETE;
2403 PL_hints |= HINT_BLOCK_SCOPE;
2406 o->op_private |= OPpTRANS_FROM_UTF;
2409 o->op_private |= OPpTRANS_TO_UTF;
2411 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2412 SV* const listsv = newSVpvn("# comment\n",10);
2414 const U8* tend = t + tlen;
2415 const U8* rend = r + rlen;
2429 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2430 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2436 t = tsave = bytes_to_utf8(t, &len);
2439 if (!to_utf && rlen) {
2441 r = rsave = bytes_to_utf8(r, &len);
2445 /* There are several snags with this code on EBCDIC:
2446 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2447 2. scan_const() in toke.c has encoded chars in native encoding which makes
2448 ranges at least in EBCDIC 0..255 range the bottom odd.
2452 U8 tmpbuf[UTF8_MAXBYTES+1];
2455 Newx(cp, 2*tlen, UV);
2457 transv = newSVpvn("",0);
2459 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2461 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2463 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2467 cp[2*i+1] = cp[2*i];
2471 qsort(cp, i, 2*sizeof(UV), uvcompare);
2472 for (j = 0; j < i; j++) {
2474 diff = val - nextmin;
2476 t = uvuni_to_utf8(tmpbuf,nextmin);
2477 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2479 U8 range_mark = UTF_TO_NATIVE(0xff);
2480 t = uvuni_to_utf8(tmpbuf, val - 1);
2481 sv_catpvn(transv, (char *)&range_mark, 1);
2482 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2489 t = uvuni_to_utf8(tmpbuf,nextmin);
2490 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2492 U8 range_mark = UTF_TO_NATIVE(0xff);
2493 sv_catpvn(transv, (char *)&range_mark, 1);
2495 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2496 UNICODE_ALLOW_SUPER);
2497 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2498 t = (const U8*)SvPVX_const(transv);
2499 tlen = SvCUR(transv);
2503 else if (!rlen && !del) {
2504 r = t; rlen = tlen; rend = tend;
2507 if ((!rlen && !del) || t == r ||
2508 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2510 o->op_private |= OPpTRANS_IDENTICAL;
2514 while (t < tend || tfirst <= tlast) {
2515 /* see if we need more "t" chars */
2516 if (tfirst > tlast) {
2517 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2519 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2521 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2528 /* now see if we need more "r" chars */
2529 if (rfirst > rlast) {
2531 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2533 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2535 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2544 rfirst = rlast = 0xffffffff;
2548 /* now see which range will peter our first, if either. */
2549 tdiff = tlast - tfirst;
2550 rdiff = rlast - rfirst;
2557 if (rfirst == 0xffffffff) {
2558 diff = tdiff; /* oops, pretend rdiff is infinite */
2560 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2561 (long)tfirst, (long)tlast);
2563 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2567 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2568 (long)tfirst, (long)(tfirst + diff),
2571 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2572 (long)tfirst, (long)rfirst);
2574 if (rfirst + diff > max)
2575 max = rfirst + diff;
2577 grows = (tfirst < rfirst &&
2578 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2590 else if (max > 0xff)
2595 Safefree(cPVOPo->op_pv);
2596 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2597 SvREFCNT_dec(listsv);
2599 SvREFCNT_dec(transv);
2601 if (!del && havefinal && rlen)
2602 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2603 newSVuv((UV)final), 0);
2606 o->op_private |= OPpTRANS_GROWS;
2618 tbl = (short*)cPVOPo->op_pv;
2620 Zero(tbl, 256, short);
2621 for (i = 0; i < (I32)tlen; i++)
2623 for (i = 0, j = 0; i < 256; i++) {
2625 if (j >= (I32)rlen) {
2634 if (i < 128 && r[j] >= 128)
2644 o->op_private |= OPpTRANS_IDENTICAL;
2646 else if (j >= (I32)rlen)
2649 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2650 tbl[0x100] = (short)(rlen - j);
2651 for (i=0; i < (I32)rlen - j; i++)
2652 tbl[0x101+i] = r[j+i];
2656 if (!rlen && !del) {
2659 o->op_private |= OPpTRANS_IDENTICAL;
2661 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2662 o->op_private |= OPpTRANS_IDENTICAL;
2664 for (i = 0; i < 256; i++)
2666 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2667 if (j >= (I32)rlen) {
2669 if (tbl[t[i]] == -1)
2675 if (tbl[t[i]] == -1) {
2676 if (t[i] < 128 && r[j] >= 128)
2683 o->op_private |= OPpTRANS_GROWS;
2691 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2696 NewOp(1101, pmop, 1, PMOP);
2697 pmop->op_type = (OPCODE)type;
2698 pmop->op_ppaddr = PL_ppaddr[type];
2699 pmop->op_flags = (U8)flags;
2700 pmop->op_private = (U8)(0 | (flags >> 8));
2702 if (PL_hints & HINT_RE_TAINT)
2703 pmop->op_pmpermflags |= PMf_RETAINT;
2704 if (PL_hints & HINT_LOCALE)
2705 pmop->op_pmpermflags |= PMf_LOCALE;
2706 pmop->op_pmflags = pmop->op_pmpermflags;
2709 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2710 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2711 pmop->op_pmoffset = SvIV(repointer);
2712 SvREPADTMP_off(repointer);
2713 sv_setiv(repointer,0);
2715 SV * const repointer = newSViv(0);
2716 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2717 pmop->op_pmoffset = av_len(PL_regex_padav);
2718 PL_regex_pad = AvARRAY(PL_regex_padav);
2722 /* link into pm list */
2723 if (type != OP_TRANS && PL_curstash) {
2724 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2727 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2729 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2730 mg->mg_obj = (SV*)pmop;
2731 PmopSTASH_set(pmop,PL_curstash);
2734 return CHECKOP(type, pmop);
2737 /* Given some sort of match op o, and an expression expr containing a
2738 * pattern, either compile expr into a regex and attach it to o (if it's
2739 * constant), or convert expr into a runtime regcomp op sequence (if it's
2742 * isreg indicates that the pattern is part of a regex construct, eg
2743 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2744 * split "pattern", which aren't. In the former case, expr will be a list
2745 * if the pattern contains more than one term (eg /a$b/) or if it contains
2746 * a replacement, ie s/// or tr///.
2750 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2755 I32 repl_has_vars = 0;
2759 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2760 /* last element in list is the replacement; pop it */
2762 repl = cLISTOPx(expr)->op_last;
2763 kid = cLISTOPx(expr)->op_first;
2764 while (kid->op_sibling != repl)
2765 kid = kid->op_sibling;
2766 kid->op_sibling = Nullop;
2767 cLISTOPx(expr)->op_last = kid;
2770 if (isreg && expr->op_type == OP_LIST &&
2771 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2773 /* convert single element list to element */
2775 expr = cLISTOPx(oe)->op_first->op_sibling;
2776 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2777 cLISTOPx(oe)->op_last = Nullop;
2781 if (o->op_type == OP_TRANS) {
2782 return pmtrans(o, expr, repl);
2785 reglist = isreg && expr->op_type == OP_LIST;
2789 PL_hints |= HINT_BLOCK_SCOPE;
2792 if (expr->op_type == OP_CONST) {
2794 SV *pat = ((SVOP*)expr)->op_sv;
2795 const char *p = SvPV_const(pat, plen);
2796 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2797 U32 was_readonly = SvREADONLY(pat);
2801 sv_force_normal_flags(pat, 0);
2802 assert(!SvREADONLY(pat));
2805 SvREADONLY_off(pat);
2809 sv_setpvn(pat, "\\s+", 3);
2811 SvFLAGS(pat) |= was_readonly;
2813 p = SvPV_const(pat, plen);
2814 pm->op_pmflags |= PMf_SKIPWHITE;
2817 pm->op_pmdynflags |= PMdf_UTF8;
2818 /* FIXME - can we make this function take const char * args? */
2819 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2820 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2821 pm->op_pmflags |= PMf_WHITE;
2825 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2826 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2828 : OP_REGCMAYBE),0,expr);
2830 NewOp(1101, rcop, 1, LOGOP);
2831 rcop->op_type = OP_REGCOMP;
2832 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2833 rcop->op_first = scalar(expr);
2834 rcop->op_flags |= OPf_KIDS
2835 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2836 | (reglist ? OPf_STACKED : 0);
2837 rcop->op_private = 1;
2840 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2842 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2845 /* establish postfix order */
2846 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2848 rcop->op_next = expr;
2849 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2852 rcop->op_next = LINKLIST(expr);
2853 expr->op_next = (OP*)rcop;
2856 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2861 if (pm->op_pmflags & PMf_EVAL) {
2863 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2864 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2866 else if (repl->op_type == OP_CONST)
2870 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2871 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2872 if (curop->op_type == OP_GV) {
2873 GV *gv = cGVOPx_gv(curop);
2875 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2878 else if (curop->op_type == OP_RV2CV)
2880 else if (curop->op_type == OP_RV2SV ||
2881 curop->op_type == OP_RV2AV ||
2882 curop->op_type == OP_RV2HV ||
2883 curop->op_type == OP_RV2GV) {
2884 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2887 else if (curop->op_type == OP_PADSV ||
2888 curop->op_type == OP_PADAV ||
2889 curop->op_type == OP_PADHV ||
2890 curop->op_type == OP_PADANY) {
2893 else if (curop->op_type == OP_PUSHRE)
2894 ; /* Okay here, dangerous in newASSIGNOP */
2904 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2905 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2906 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2907 prepend_elem(o->op_type, scalar(repl), o);
2910 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2911 pm->op_pmflags |= PMf_MAYBE_CONST;
2912 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2914 NewOp(1101, rcop, 1, LOGOP);
2915 rcop->op_type = OP_SUBSTCONT;
2916 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2917 rcop->op_first = scalar(repl);
2918 rcop->op_flags |= OPf_KIDS;
2919 rcop->op_private = 1;
2922 /* establish postfix order */
2923 rcop->op_next = LINKLIST(repl);
2924 repl->op_next = (OP*)rcop;
2926 pm->op_pmreplroot = scalar((OP*)rcop);
2927 pm->op_pmreplstart = LINKLIST(rcop);
2936 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2940 NewOp(1101, svop, 1, SVOP);
2941 svop->op_type = (OPCODE)type;
2942 svop->op_ppaddr = PL_ppaddr[type];
2944 svop->op_next = (OP*)svop;
2945 svop->op_flags = (U8)flags;
2946 if (PL_opargs[type] & OA_RETSCALAR)
2948 if (PL_opargs[type] & OA_TARGET)
2949 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2950 return CHECKOP(type, svop);
2954 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2958 NewOp(1101, padop, 1, PADOP);
2959 padop->op_type = (OPCODE)type;
2960 padop->op_ppaddr = PL_ppaddr[type];
2961 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2962 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2963 PAD_SETSV(padop->op_padix, sv);
2966 padop->op_next = (OP*)padop;
2967 padop->op_flags = (U8)flags;
2968 if (PL_opargs[type] & OA_RETSCALAR)
2970 if (PL_opargs[type] & OA_TARGET)
2971 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2972 return CHECKOP(type, padop);
2976 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2982 return newPADOP(type, flags, SvREFCNT_inc(gv));
2984 return newSVOP(type, flags, SvREFCNT_inc(gv));
2989 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2993 NewOp(1101, pvop, 1, PVOP);
2994 pvop->op_type = (OPCODE)type;
2995 pvop->op_ppaddr = PL_ppaddr[type];
2997 pvop->op_next = (OP*)pvop;
2998 pvop->op_flags = (U8)flags;
2999 if (PL_opargs[type] & OA_RETSCALAR)
3001 if (PL_opargs[type] & OA_TARGET)
3002 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3003 return CHECKOP(type, pvop);
3007 Perl_package(pTHX_ OP *o)
3012 save_hptr(&PL_curstash);
3013 save_item(PL_curstname);
3015 name = SvPV_const(cSVOPo->op_sv, len);
3016 PL_curstash = gv_stashpvn(name, len, TRUE);
3017 sv_setpvn(PL_curstname, name, len);
3020 PL_hints |= HINT_BLOCK_SCOPE;
3021 PL_copline = NOLINE;
3026 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3032 if (idop->op_type != OP_CONST)
3033 Perl_croak(aTHX_ "Module name must be constant");
3038 SV * const vesv = ((SVOP*)version)->op_sv;
3040 if (!arg && !SvNIOKp(vesv)) {
3047 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3048 Perl_croak(aTHX_ "Version number must be constant number");
3050 /* Make copy of idop so we don't free it twice */
3051 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3053 /* Fake up a method call to VERSION */
3054 meth = newSVpvn_share("VERSION", 7, 0);
3055 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3056 append_elem(OP_LIST,
3057 prepend_elem(OP_LIST, pack, list(version)),
3058 newSVOP(OP_METHOD_NAMED, 0, meth)));
3062 /* Fake up an import/unimport */
3063 if (arg && arg->op_type == OP_STUB)
3064 imop = arg; /* no import on explicit () */
3065 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3066 imop = Nullop; /* use 5.0; */
3068 idop->op_private |= OPpCONST_NOVER;
3073 /* Make copy of idop so we don't free it twice */
3074 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3076 /* Fake up a method call to import/unimport */
3078 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3079 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3080 append_elem(OP_LIST,
3081 prepend_elem(OP_LIST, pack, list(arg)),
3082 newSVOP(OP_METHOD_NAMED, 0, meth)));
3085 /* Fake up the BEGIN {}, which does its thing immediately. */
3087 newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3090 append_elem(OP_LINESEQ,
3091 append_elem(OP_LINESEQ,
3092 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3093 newSTATEOP(0, Nullch, veop)),
3094 newSTATEOP(0, Nullch, imop) ));
3096 /* The "did you use incorrect case?" warning used to be here.
3097 * The problem is that on case-insensitive filesystems one
3098 * might get false positives for "use" (and "require"):
3099 * "use Strict" or "require CARP" will work. This causes
3100 * portability problems for the script: in case-strict
3101 * filesystems the script will stop working.
3103 * The "incorrect case" warning checked whether "use Foo"
3104 * imported "Foo" to your namespace, but that is wrong, too:
3105 * there is no requirement nor promise in the language that
3106 * a Foo.pm should or would contain anything in package "Foo".
3108 * There is very little Configure-wise that can be done, either:
3109 * the case-sensitivity of the build filesystem of Perl does not
3110 * help in guessing the case-sensitivity of the runtime environment.
3113 PL_hints |= HINT_BLOCK_SCOPE;
3114 PL_copline = NOLINE;
3116 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3120 =head1 Embedding Functions
3122 =for apidoc load_module
3124 Loads the module whose name is pointed to by the string part of name.
3125 Note that the actual module name, not its filename, should be given.
3126 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3127 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3128 (or 0 for no flags). ver, if specified, provides version semantics
3129 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3130 arguments can be used to specify arguments to the module's import()
3131 method, similar to C<use Foo::Bar VERSION LIST>.
3136 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3139 va_start(args, ver);
3140 vload_module(flags, name, ver, &args);
3144 #ifdef PERL_IMPLICIT_CONTEXT
3146 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3150 va_start(args, ver);
3151 vload_module(flags, name, ver, &args);
3157 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3161 OP * const modname = newSVOP(OP_CONST, 0, name);
3162 modname->op_private |= OPpCONST_BARE;
3164 veop = newSVOP(OP_CONST, 0, ver);
3168 if (flags & PERL_LOADMOD_NOIMPORT) {
3169 imop = sawparens(newNULLLIST());
3171 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3172 imop = va_arg(*args, OP*);
3177 sv = va_arg(*args, SV*);
3179 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3180 sv = va_arg(*args, SV*);
3184 const line_t ocopline = PL_copline;
3185 COP * const ocurcop = PL_curcop;
3186 const int oexpect = PL_expect;
3188 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3189 veop, modname, imop);
3190 PL_expect = oexpect;
3191 PL_copline = ocopline;
3192 PL_curcop = ocurcop;
3197 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3202 if (!force_builtin) {
3203 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3204 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3205 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3206 gv = gvp ? *gvp : Nullgv;
3210 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3211 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3212 append_elem(OP_LIST, term,
3213 scalar(newUNOP(OP_RV2CV, 0,
3218 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3224 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3226 return newBINOP(OP_LSLICE, flags,
3227 list(force_list(subscript)),
3228 list(force_list(listval)) );
3232 S_is_list_assignment(pTHX_ register const OP *o)
3237 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3238 o = cUNOPo->op_first;
3240 if (o->op_type == OP_COND_EXPR) {
3241 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3242 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3247 yyerror("Assignment to both a list and a scalar");
3251 if (o->op_type == OP_LIST &&
3252 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3253 o->op_private & OPpLVAL_INTRO)
3256 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3257 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3258 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3261 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3264 if (o->op_type == OP_RV2SV)
3271 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3276 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3277 return newLOGOP(optype, 0,
3278 mod(scalar(left), optype),
3279 newUNOP(OP_SASSIGN, 0, scalar(right)));
3282 return newBINOP(optype, OPf_STACKED,
3283 mod(scalar(left), optype), scalar(right));
3287 if (is_list_assignment(left)) {
3291 /* Grandfathering $[ assignment here. Bletch.*/
3292 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3293 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3294 left = mod(left, OP_AASSIGN);
3297 else if (left->op_type == OP_CONST) {
3298 /* Result of assignment is always 1 (or we'd be dead already) */
3299 return newSVOP(OP_CONST, 0, newSViv(1));
3301 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3302 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3303 && right->op_type == OP_STUB
3304 && (left->op_private & OPpLVAL_INTRO))
3307 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3310 curop = list(force_list(left));
3311 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3312 o->op_private = (U8)(0 | (flags >> 8));
3314 /* PL_generation sorcery:
3315 * an assignment like ($a,$b) = ($c,$d) is easier than
3316 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3317 * To detect whether there are common vars, the global var
3318 * PL_generation is incremented for each assign op we compile.
3319 * Then, while compiling the assign op, we run through all the
3320 * variables on both sides of the assignment, setting a spare slot
3321 * in each of them to PL_generation. If any of them already have
3322 * that value, we know we've got commonality. We could use a
3323 * single bit marker, but then we'd have to make 2 passes, first
3324 * to clear the flag, then to test and set it. To find somewhere
3325 * to store these values, evil chicanery is done with SvCUR().
3328 if (!(left->op_private & OPpLVAL_INTRO)) {
3331 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3332 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3333 if (curop->op_type == OP_GV) {
3334 GV *gv = cGVOPx_gv(curop);
3335 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3337 SvCUR_set(gv, PL_generation);
3339 else if (curop->op_type == OP_PADSV ||
3340 curop->op_type == OP_PADAV ||
3341 curop->op_type == OP_PADHV ||
3342 curop->op_type == OP_PADANY)
3344 if (PAD_COMPNAME_GEN(curop->op_targ)
3345 == (STRLEN)PL_generation)
3347 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3350 else if (curop->op_type == OP_RV2CV)
3352 else if (curop->op_type == OP_RV2SV ||
3353 curop->op_type == OP_RV2AV ||
3354 curop->op_type == OP_RV2HV ||
3355 curop->op_type == OP_RV2GV) {
3356 if (lastop->op_type != OP_GV) /* funny deref? */
3359 else if (curop->op_type == OP_PUSHRE) {
3360 if (((PMOP*)curop)->op_pmreplroot) {
3362 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3363 ((PMOP*)curop)->op_pmreplroot));
3365 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3367 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3369 SvCUR_set(gv, PL_generation);
3378 o->op_private |= OPpASSIGN_COMMON;
3380 if (right && right->op_type == OP_SPLIT) {
3382 if ((tmpop = ((LISTOP*)right)->op_first) &&
3383 tmpop->op_type == OP_PUSHRE)
3385 PMOP * const pm = (PMOP*)tmpop;
3386 if (left->op_type == OP_RV2AV &&
3387 !(left->op_private & OPpLVAL_INTRO) &&
3388 !(o->op_private & OPpASSIGN_COMMON) )
3390 tmpop = ((UNOP*)left)->op_first;
3391 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3393 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3394 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3396 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3397 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3399 pm->op_pmflags |= PMf_ONCE;
3400 tmpop = cUNOPo->op_first; /* to list (nulled) */
3401 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3402 tmpop->op_sibling = Nullop; /* don't free split */
3403 right->op_next = tmpop->op_next; /* fix starting loc */
3404 op_free(o); /* blow off assign */
3405 right->op_flags &= ~OPf_WANT;
3406 /* "I don't know and I don't care." */
3411 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3412 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3414 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3416 sv_setiv(sv, PL_modcount+1);
3424 right = newOP(OP_UNDEF, 0);
3425 if (right->op_type == OP_READLINE) {
3426 right->op_flags |= OPf_STACKED;
3427 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3430 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3431 o = newBINOP(OP_SASSIGN, flags,
3432 scalar(right), mod(scalar(left), OP_SASSIGN) );
3436 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3443 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3446 const U32 seq = intro_my();
3449 NewOp(1101, cop, 1, COP);
3450 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3451 cop->op_type = OP_DBSTATE;
3452 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3455 cop->op_type = OP_NEXTSTATE;
3456 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3458 cop->op_flags = (U8)flags;
3459 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3461 cop->op_private |= NATIVE_HINTS;
3463 PL_compiling.op_private = cop->op_private;
3464 cop->op_next = (OP*)cop;
3467 cop->cop_label = label;
3468 PL_hints |= HINT_BLOCK_SCOPE;
3471 cop->cop_arybase = PL_curcop->cop_arybase;
3472 if (specialWARN(PL_curcop->cop_warnings))
3473 cop->cop_warnings = PL_curcop->cop_warnings ;
3475 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3476 if (specialCopIO(PL_curcop->cop_io))
3477 cop->cop_io = PL_curcop->cop_io;
3479 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3482 if (PL_copline == NOLINE)
3483 CopLINE_set(cop, CopLINE(PL_curcop));
3485 CopLINE_set(cop, PL_copline);
3486 PL_copline = NOLINE;
3489 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3491 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3493 CopSTASH_set(cop, PL_curstash);
3495 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3496 SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3497 if (svp && *svp != &PL_sv_undef ) {
3498 (void)SvIOK_on(*svp);
3499 SvIV_set(*svp, PTR2IV(cop));
3503 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3508 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3511 return new_logop(type, flags, &first, &other);
3515 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3520 OP *first = *firstp;
3521 OP * const other = *otherp;
3523 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3524 return newBINOP(type, flags, scalar(first), scalar(other));
3526 scalarboolean(first);
3527 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3528 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3529 if (type == OP_AND || type == OP_OR) {
3535 first = *firstp = cUNOPo->op_first;
3537 first->op_next = o->op_next;
3538 cUNOPo->op_first = Nullop;
3542 if (first->op_type == OP_CONST) {
3543 if (first->op_private & OPpCONST_STRICT)
3544 no_bareword_allowed(first);
3545 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3546 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3547 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3548 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3549 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3552 if (other->op_type == OP_CONST)
3553 other->op_private |= OPpCONST_SHORTCIRCUIT;
3557 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3558 const OP *o2 = other;
3559 if ( ! (o2->op_type == OP_LIST
3560 && (( o2 = cUNOPx(o2)->op_first))
3561 && o2->op_type == OP_PUSHMARK
3562 && (( o2 = o2->op_sibling)) )
3565 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3566 || o2->op_type == OP_PADHV)
3567 && o2->op_private & OPpLVAL_INTRO
3568 && ckWARN(WARN_DEPRECATED))
3570 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3571 "Deprecated use of my() in false conditional");
3576 if (first->op_type == OP_CONST)
3577 first->op_private |= OPpCONST_SHORTCIRCUIT;
3581 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3582 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3584 const OP * const k1 = ((UNOP*)first)->op_first;
3585 const OP * const k2 = k1->op_sibling;
3587 switch (first->op_type)
3590 if (k2 && k2->op_type == OP_READLINE
3591 && (k2->op_flags & OPf_STACKED)
3592 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3594 warnop = k2->op_type;
3599 if (k1->op_type == OP_READDIR
3600 || k1->op_type == OP_GLOB
3601 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3602 || k1->op_type == OP_EACH)
3604 warnop = ((k1->op_type == OP_NULL)
3605 ? (OPCODE)k1->op_targ : k1->op_type);
3610 const line_t oldline = CopLINE(PL_curcop);
3611 CopLINE_set(PL_curcop, PL_copline);
3612 Perl_warner(aTHX_ packWARN(WARN_MISC),
3613 "Value of %s%s can be \"0\"; test with defined()",
3615 ((warnop == OP_READLINE || warnop == OP_GLOB)
3616 ? " construct" : "() operator"));
3617 CopLINE_set(PL_curcop, oldline);
3624 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3625 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3627 NewOp(1101, logop, 1, LOGOP);
3629 logop->op_type = (OPCODE)type;
3630 logop->op_ppaddr = PL_ppaddr[type];
3631 logop->op_first = first;
3632 logop->op_flags = (U8)(flags | OPf_KIDS);
3633 logop->op_other = LINKLIST(other);
3634 logop->op_private = (U8)(1 | (flags >> 8));
3636 /* establish postfix order */
3637 logop->op_next = LINKLIST(first);
3638 first->op_next = (OP*)logop;
3639 first->op_sibling = other;
3641 CHECKOP(type,logop);
3643 o = newUNOP(OP_NULL, 0, (OP*)logop);
3650 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3658 return newLOGOP(OP_AND, 0, first, trueop);
3660 return newLOGOP(OP_OR, 0, first, falseop);
3662 scalarboolean(first);
3663 if (first->op_type == OP_CONST) {
3664 if (first->op_private & OPpCONST_BARE &&
3665 first->op_private & OPpCONST_STRICT) {
3666 no_bareword_allowed(first);
3668 if (SvTRUE(((SVOP*)first)->op_sv)) {
3679 NewOp(1101, logop, 1, LOGOP);
3680 logop->op_type = OP_COND_EXPR;
3681 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3682 logop->op_first = first;
3683 logop->op_flags = (U8)(flags | OPf_KIDS);
3684 logop->op_private = (U8)(1 | (flags >> 8));
3685 logop->op_other = LINKLIST(trueop);
3686 logop->op_next = LINKLIST(falseop);
3688 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3691 /* establish postfix order */
3692 start = LINKLIST(first);
3693 first->op_next = (OP*)logop;
3695 first->op_sibling = trueop;
3696 trueop->op_sibling = falseop;
3697 o = newUNOP(OP_NULL, 0, (OP*)logop);
3699 trueop->op_next = falseop->op_next = o;
3706 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3715 NewOp(1101, range, 1, LOGOP);
3717 range->op_type = OP_RANGE;
3718 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3719 range->op_first = left;
3720 range->op_flags = OPf_KIDS;
3721 leftstart = LINKLIST(left);
3722 range->op_other = LINKLIST(right);
3723 range->op_private = (U8)(1 | (flags >> 8));
3725 left->op_sibling = right;
3727 range->op_next = (OP*)range;
3728 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3729 flop = newUNOP(OP_FLOP, 0, flip);
3730 o = newUNOP(OP_NULL, 0, flop);
3732 range->op_next = leftstart;
3734 left->op_next = flip;
3735 right->op_next = flop;
3737 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3738 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3739 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3740 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3742 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3743 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3746 if (!flip->op_private || !flop->op_private)
3747 linklist(o); /* blow off optimizer unless constant */
3753 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3757 const bool once = block && block->op_flags & OPf_SPECIAL &&
3758 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3760 PERL_UNUSED_ARG(debuggable);
3763 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3764 return block; /* do {} while 0 does once */
3765 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3766 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3767 expr = newUNOP(OP_DEFINED, 0,
3768 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3769 } else if (expr->op_flags & OPf_KIDS) {
3770 const OP * const k1 = ((UNOP*)expr)->op_first;
3771 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3772 switch (expr->op_type) {
3774 if (k2 && k2->op_type == OP_READLINE
3775 && (k2->op_flags & OPf_STACKED)
3776 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3777 expr = newUNOP(OP_DEFINED, 0, expr);
3781 if (k1->op_type == OP_READDIR
3782 || k1->op_type == OP_GLOB
3783 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3784 || k1->op_type == OP_EACH)
3785 expr = newUNOP(OP_DEFINED, 0, expr);
3791 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3792 * op, in listop. This is wrong. [perl #27024] */
3794 block = newOP(OP_NULL, 0);
3795 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3796 o = new_logop(OP_AND, 0, &expr, &listop);
3799 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3801 if (once && o != listop)
3802 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3805 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3807 o->op_flags |= flags;
3809 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3814 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3815 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3824 PERL_UNUSED_ARG(debuggable);
3827 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3828 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3829 expr = newUNOP(OP_DEFINED, 0,
3830 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3831 } else if (expr->op_flags & OPf_KIDS) {
3832 const OP * const k1 = ((UNOP*)expr)->op_first;
3833 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3834 switch (expr->op_type) {
3836 if (k2 && k2->op_type == OP_READLINE
3837 && (k2->op_flags & OPf_STACKED)
3838 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3839 expr = newUNOP(OP_DEFINED, 0, expr);
3843 if (k1->op_type == OP_READDIR
3844 || k1->op_type == OP_GLOB
3845 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3846 || k1->op_type == OP_EACH)
3847 expr = newUNOP(OP_DEFINED, 0, expr);
3854 block = newOP(OP_NULL, 0);
3855 else if (cont || has_my) {
3856 block = scope(block);
3860 next = LINKLIST(cont);
3863 OP * const unstack = newOP(OP_UNSTACK, 0);
3866 cont = append_elem(OP_LINESEQ, cont, unstack);
3869 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3870 redo = LINKLIST(listop);
3873 PL_copline = (line_t)whileline;
3875 o = new_logop(OP_AND, 0, &expr, &listop);
3876 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3877 op_free(expr); /* oops, it's a while (0) */
3879 return Nullop; /* listop already freed by new_logop */
3882 ((LISTOP*)listop)->op_last->op_next =
3883 (o == listop ? redo : LINKLIST(o));
3889 NewOp(1101,loop,1,LOOP);
3890 loop->op_type = OP_ENTERLOOP;
3891 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3892 loop->op_private = 0;
3893 loop->op_next = (OP*)loop;
3896 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3898 loop->op_redoop = redo;
3899 loop->op_lastop = o;
3900 o->op_private |= loopflags;
3903 loop->op_nextop = next;
3905 loop->op_nextop = o;
3907 o->op_flags |= flags;
3908 o->op_private |= (flags >> 8);
3913 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3918 PADOFFSET padoff = 0;
3923 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3924 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3925 sv->op_type = OP_RV2GV;
3926 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3928 else if (sv->op_type == OP_PADSV) { /* private variable */
3929 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3930 padoff = sv->op_targ;
3935 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3936 padoff = sv->op_targ;
3938 iterflags |= OPf_SPECIAL;
3943 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3946 const I32 offset = pad_findmy("$_");
3947 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3948 sv = newGVOP(OP_GV, 0, PL_defgv);
3954 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3955 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3956 iterflags |= OPf_STACKED;
3958 else if (expr->op_type == OP_NULL &&
3959 (expr->op_flags & OPf_KIDS) &&
3960 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3962 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3963 * set the STACKED flag to indicate that these values are to be
3964 * treated as min/max values by 'pp_iterinit'.
3966 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3967 LOGOP* const range = (LOGOP*) flip->op_first;
3968 OP* const left = range->op_first;
3969 OP* const right = left->op_sibling;
3972 range->op_flags &= ~OPf_KIDS;
3973 range->op_first = Nullop;
3975 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3976 listop->op_first->op_next = range->op_next;
3977 left->op_next = range->op_other;
3978 right->op_next = (OP*)listop;
3979 listop->op_next = listop->op_first;
3982 expr = (OP*)(listop);
3984 iterflags |= OPf_STACKED;
3987 expr = mod(force_list(expr), OP_GREPSTART);
3990 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3991 append_elem(OP_LIST, expr, scalar(sv))));
3992 assert(!loop->op_next);
3993 /* for my $x () sets OPpLVAL_INTRO;
3994 * for our $x () sets OPpOUR_INTRO */
3995 loop->op_private = (U8)iterpflags;
3996 #ifdef PL_OP_SLAB_ALLOC
3999 NewOp(1234,tmp,1,LOOP);
4000 Copy(loop,tmp,1,LISTOP);
4005 Renew(loop, 1, LOOP);
4007 loop->op_targ = padoff;
4008 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4009 PL_copline = forline;
4010 return newSTATEOP(0, label, wop);
4014 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4018 if (type != OP_GOTO || label->op_type == OP_CONST) {
4019 /* "last()" means "last" */
4020 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4021 o = newOP(type, OPf_SPECIAL);
4023 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4024 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4030 /* Check whether it's going to be a goto &function */
4031 if (label->op_type == OP_ENTERSUB
4032 && !(label->op_flags & OPf_STACKED))
4033 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4034 o = newUNOP(type, OPf_STACKED, label);
4036 PL_hints |= HINT_BLOCK_SCOPE;
4041 =for apidoc cv_undef
4043 Clear out all the active components of a CV. This can happen either
4044 by an explicit C<undef &foo>, or by the reference count going to zero.
4045 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4046 children can still follow the full lexical scope chain.
4052 Perl_cv_undef(pTHX_ CV *cv)
4056 if (CvFILE(cv) && !CvXSUB(cv)) {
4057 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4058 Safefree(CvFILE(cv));
4063 if (!CvXSUB(cv) && CvROOT(cv)) {
4065 Perl_croak(aTHX_ "Can't undef active subroutine");
4068 PAD_SAVE_SETNULLPAD();
4070 op_free(CvROOT(cv));
4071 CvROOT(cv) = Nullop;
4072 CvSTART(cv) = Nullop;
4075 SvPOK_off((SV*)cv); /* forget prototype */
4080 /* remove CvOUTSIDE unless this is an undef rather than a free */
4081 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4082 if (!CvWEAKOUTSIDE(cv))
4083 SvREFCNT_dec(CvOUTSIDE(cv));
4084 CvOUTSIDE(cv) = Nullcv;
4087 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4093 /* delete all flags except WEAKOUTSIDE */
4094 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4098 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4100 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4101 SV* const msg = sv_newmortal();
4105 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4106 sv_setpv(msg, "Prototype mismatch:");
4108 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4110 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4112 Perl_sv_catpv(aTHX_ msg, ": none");
4113 sv_catpv(msg, " vs ");
4115 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4117 sv_catpv(msg, "none");
4118 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4122 static void const_sv_xsub(pTHX_ CV* cv);
4126 =head1 Optree Manipulation Functions
4128 =for apidoc cv_const_sv
4130 If C<cv> is a constant sub eligible for inlining. returns the constant
4131 value returned by the sub. Otherwise, returns NULL.
4133 Constant subs can be created with C<newCONSTSUB> or as described in
4134 L<perlsub/"Constant Functions">.
4139 Perl_cv_const_sv(pTHX_ CV *cv)
4141 if (!cv || !CvCONST(cv))
4143 return (SV*)CvXSUBANY(cv).any_ptr;
4146 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4147 * Can be called in 3 ways:
4150 * look for a single OP_CONST with attached value: return the value
4152 * cv && CvCLONE(cv) && !CvCONST(cv)
4154 * examine the clone prototype, and if contains only a single
4155 * OP_CONST referencing a pad const, or a single PADSV referencing
4156 * an outer lexical, return a non-zero value to indicate the CV is
4157 * a candidate for "constizing" at clone time
4161 * We have just cloned an anon prototype that was marked as a const
4162 * candidiate. Try to grab the current value, and in the case of
4163 * PADSV, ignore it if it has multiple references. Return the value.
4167 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4174 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4175 o = cLISTOPo->op_first->op_sibling;
4177 for (; o; o = o->op_next) {
4178 const OPCODE type = o->op_type;
4180 if (sv && o->op_next == o)
4182 if (o->op_next != o) {
4183 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4185 if (type == OP_DBSTATE)
4188 if (type == OP_LEAVESUB || type == OP_RETURN)
4192 if (type == OP_CONST && cSVOPo->op_sv)
4194 else if (cv && type == OP_CONST) {
4195 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4199 else if (cv && type == OP_PADSV) {
4200 if (CvCONST(cv)) { /* newly cloned anon */
4201 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4202 /* the candidate should have 1 ref from this pad and 1 ref
4203 * from the parent */
4204 if (!sv || SvREFCNT(sv) != 2)
4211 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4212 sv = &PL_sv_undef; /* an arbitrary non-null value */
4223 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4225 PERL_UNUSED_ARG(floor);
4235 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4239 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4241 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4245 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4256 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4259 assert(proto->op_type == OP_CONST);
4260 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4265 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4266 SV * const sv = sv_newmortal();
4267 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4268 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4269 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4270 aname = SvPVX_const(sv);
4275 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4276 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4277 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4278 : gv_fetchpv(aname ? aname
4279 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4280 gv_fetch_flags, SVt_PVCV);
4289 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4290 maximum a prototype before. */
4291 if (SvTYPE(gv) > SVt_NULL) {
4292 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4293 && ckWARN_d(WARN_PROTOTYPE))
4295 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4297 cv_ckproto((CV*)gv, NULL, ps);
4300 sv_setpvn((SV*)gv, ps, ps_len);
4302 sv_setiv((SV*)gv, -1);
4303 SvREFCNT_dec(PL_compcv);
4304 cv = PL_compcv = NULL;
4305 PL_sub_generation++;
4309 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4311 #ifdef GV_UNIQUE_CHECK
4312 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4313 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4317 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4320 const_sv = op_const_sv(block, Nullcv);
4323 const bool exists = CvROOT(cv) || CvXSUB(cv);
4325 #ifdef GV_UNIQUE_CHECK
4326 if (exists && GvUNIQUE(gv)) {
4327 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4331 /* if the subroutine doesn't exist and wasn't pre-declared
4332 * with a prototype, assume it will be AUTOLOADed,
4333 * skipping the prototype check
4335 if (exists || SvPOK(cv))
4336 cv_ckproto(cv, gv, ps);
4337 /* already defined (or promised)? */
4338 if (exists || GvASSUMECV(gv)) {
4339 if (!block && !attrs) {
4340 if (CvFLAGS(PL_compcv)) {
4341 /* might have had built-in attrs applied */
4342 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4344 /* just a "sub foo;" when &foo is already defined */
4345 SAVEFREESV(PL_compcv);
4349 if (ckWARN(WARN_REDEFINE)
4351 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4353 const line_t oldline = CopLINE(PL_curcop);
4354 if (PL_copline != NOLINE)
4355 CopLINE_set(PL_curcop, PL_copline);
4356 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4357 CvCONST(cv) ? "Constant subroutine %s redefined"
4358 : "Subroutine %s redefined", name);
4359 CopLINE_set(PL_curcop, oldline);
4367 (void)SvREFCNT_inc(const_sv);
4369 assert(!CvROOT(cv) && !CvCONST(cv));
4370 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4371 CvXSUBANY(cv).any_ptr = const_sv;
4372 CvXSUB(cv) = const_sv_xsub;
4377 cv = newCONSTSUB(NULL, name, const_sv);
4380 SvREFCNT_dec(PL_compcv);
4382 PL_sub_generation++;
4389 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4390 * before we clobber PL_compcv.
4394 /* Might have had built-in attributes applied -- propagate them. */
4395 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4396 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4397 stash = GvSTASH(CvGV(cv));
4398 else if (CvSTASH(cv))
4399 stash = CvSTASH(cv);
4401 stash = PL_curstash;
4404 /* possibly about to re-define existing subr -- ignore old cv */
4405 rcv = (SV*)PL_compcv;
4406 if (name && GvSTASH(gv))
4407 stash = GvSTASH(gv);
4409 stash = PL_curstash;
4411 apply_attrs(stash, rcv, attrs, FALSE);
4413 if (cv) { /* must reuse cv if autoloaded */
4415 /* got here with just attrs -- work done, so bug out */
4416 SAVEFREESV(PL_compcv);
4419 /* transfer PL_compcv to cv */
4421 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4422 if (!CvWEAKOUTSIDE(cv))
4423 SvREFCNT_dec(CvOUTSIDE(cv));
4424 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4425 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4426 CvOUTSIDE(PL_compcv) = 0;
4427 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4428 CvPADLIST(PL_compcv) = 0;
4429 /* inner references to PL_compcv must be fixed up ... */
4430 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4431 /* ... before we throw it away */
4432 SvREFCNT_dec(PL_compcv);
4434 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4435 ++PL_sub_generation;
4442 PL_sub_generation++;
4446 CvFILE_set_from_cop(cv, PL_curcop);
4447 CvSTASH(cv) = PL_curstash;
4450 sv_setpvn((SV*)cv, ps, ps_len);
4452 if (PL_error_count) {
4456 const char *s = strrchr(name, ':');
4458 if (strEQ(s, "BEGIN")) {
4459 const char not_safe[] =
4460 "BEGIN not safe after errors--compilation aborted";
4461 if (PL_in_eval & EVAL_KEEPERR)
4462 Perl_croak(aTHX_ not_safe);
4464 /* force display of errors found but not reported */
4465 sv_catpv(ERRSV, not_safe);
4466 Perl_croak(aTHX_ "%"SVf, ERRSV);
4475 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4476 mod(scalarseq(block), OP_LEAVESUBLV));
4479 /* This makes sub {}; work as expected. */
4480 if (block->op_type == OP_STUB) {
4482 block = newSTATEOP(0, Nullch, 0);
4484 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4486 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4487 OpREFCNT_set(CvROOT(cv), 1);
4488 CvSTART(cv) = LINKLIST(CvROOT(cv));
4489 CvROOT(cv)->op_next = 0;
4490 CALL_PEEP(CvSTART(cv));
4492 /* now that optimizer has done its work, adjust pad values */
4494 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4497 assert(!CvCONST(cv));
4498 if (ps && !*ps && op_const_sv(block, cv))
4502 if (name || aname) {
4504 const char *tname = (name ? name : aname);
4506 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4507 SV * const sv = NEWSV(0,0);
4508 SV * const tmpstr = sv_newmortal();
4509 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4512 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4514 (long)PL_subline, (long)CopLINE(PL_curcop));
4515 gv_efullname3(tmpstr, gv, Nullch);
4516 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4517 hv = GvHVn(db_postponed);
4518 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4519 CV * const pcv = GvCV(db_postponed);
4525 call_sv((SV*)pcv, G_DISCARD);
4530 if ((s = strrchr(tname,':')))
4535 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4538 if (strEQ(s, "BEGIN") && !PL_error_count) {
4539 const I32 oldscope = PL_scopestack_ix;
4541 SAVECOPFILE(&PL_compiling);
4542 SAVECOPLINE(&PL_compiling);
4545 PL_beginav = newAV();
4546 DEBUG_x( dump_sub(gv) );
4547 av_push(PL_beginav, (SV*)cv);
4548 GvCV(gv) = 0; /* cv has been hijacked */
4549 call_list(oldscope, PL_beginav);
4551 PL_curcop = &PL_compiling;
4552 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4555 else if (strEQ(s, "END") && !PL_error_count) {
4558 DEBUG_x( dump_sub(gv) );
4559 av_unshift(PL_endav, 1);
4560 av_store(PL_endav, 0, (SV*)cv);
4561 GvCV(gv) = 0; /* cv has been hijacked */
4563 else if (strEQ(s, "CHECK") && !PL_error_count) {
4565 PL_checkav = newAV();
4566 DEBUG_x( dump_sub(gv) );
4567 if (PL_main_start && ckWARN(WARN_VOID))
4568 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4569 av_unshift(PL_checkav, 1);
4570 av_store(PL_checkav, 0, (SV*)cv);
4571 GvCV(gv) = 0; /* cv has been hijacked */
4573 else if (strEQ(s, "INIT") && !PL_error_count) {
4575 PL_initav = newAV();
4576 DEBUG_x( dump_sub(gv) );
4577 if (PL_main_start && ckWARN(WARN_VOID))
4578 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4579 av_push(PL_initav, (SV*)cv);
4580 GvCV(gv) = 0; /* cv has been hijacked */
4585 PL_copline = NOLINE;
4590 /* XXX unsafe for threads if eval_owner isn't held */
4592 =for apidoc newCONSTSUB
4594 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4595 eligible for inlining at compile-time.
4601 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4608 SAVECOPLINE(PL_curcop);
4609 CopLINE_set(PL_curcop, PL_copline);
4612 PL_hints &= ~HINT_BLOCK_SCOPE;
4615 SAVESPTR(PL_curstash);
4616 SAVECOPSTASH(PL_curcop);
4617 PL_curstash = stash;
4618 CopSTASH_set(PL_curcop,stash);
4621 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4622 CvXSUBANY(cv).any_ptr = sv;
4624 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4627 CopSTASH_free(PL_curcop);
4635 =for apidoc U||newXS
4637 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4643 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4645 GV * const gv = gv_fetchpv(name ? name :
4646 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4647 GV_ADDMULTI, SVt_PVCV);
4651 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4653 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4655 /* just a cached method */
4659 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4660 /* already defined (or promised) */
4661 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4662 if (ckWARN(WARN_REDEFINE)) {
4663 GV * const gvcv = CvGV(cv);
4665 HV * const stash = GvSTASH(gvcv);
4667 const char *name = HvNAME_get(stash);
4668 if ( strEQ(name,"autouse") ) {
4669 const line_t oldline = CopLINE(PL_curcop);
4670 if (PL_copline != NOLINE)
4671 CopLINE_set(PL_curcop, PL_copline);
4672 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4673 CvCONST(cv) ? "Constant subroutine %s redefined"
4674 : "Subroutine %s redefined"
4676 CopLINE_set(PL_curcop, oldline);
4686 if (cv) /* must reuse cv if autoloaded */
4689 cv = (CV*)NEWSV(1105,0);
4690 sv_upgrade((SV *)cv, SVt_PVCV);
4694 PL_sub_generation++;
4698 (void)gv_fetchfile(filename);
4699 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4700 an external constant string */
4701 CvXSUB(cv) = subaddr;
4704 const char *s = strrchr(name,':');
4710 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4713 if (strEQ(s, "BEGIN")) {
4715 PL_beginav = newAV();
4716 av_push(PL_beginav, (SV*)cv);
4717 GvCV(gv) = 0; /* cv has been hijacked */
4719 else if (strEQ(s, "END")) {
4722 av_unshift(PL_endav, 1);
4723 av_store(PL_endav, 0, (SV*)cv);
4724 GvCV(gv) = 0; /* cv has been hijacked */
4726 else if (strEQ(s, "CHECK")) {
4728 PL_checkav = newAV();
4729 if (PL_main_start && ckWARN(WARN_VOID))
4730 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4731 av_unshift(PL_checkav, 1);
4732 av_store(PL_checkav, 0, (SV*)cv);
4733 GvCV(gv) = 0; /* cv has been hijacked */
4735 else if (strEQ(s, "INIT")) {
4737 PL_initav = newAV();
4738 if (PL_main_start && ckWARN(WARN_VOID))
4739 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4740 av_push(PL_initav, (SV*)cv);
4741 GvCV(gv) = 0; /* cv has been hijacked */
4752 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4758 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4760 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4762 #ifdef GV_UNIQUE_CHECK
4764 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4768 if ((cv = GvFORM(gv))) {
4769 if (ckWARN(WARN_REDEFINE)) {
4770 const line_t oldline = CopLINE(PL_curcop);
4771 if (PL_copline != NOLINE)
4772 CopLINE_set(PL_curcop, PL_copline);
4773 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4774 o ? "Format %"SVf" redefined"
4775 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4776 CopLINE_set(PL_curcop, oldline);
4783 CvFILE_set_from_cop(cv, PL_curcop);
4786 pad_tidy(padtidy_FORMAT);
4787 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4788 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4789 OpREFCNT_set(CvROOT(cv), 1);
4790 CvSTART(cv) = LINKLIST(CvROOT(cv));
4791 CvROOT(cv)->op_next = 0;
4792 CALL_PEEP(CvSTART(cv));
4794 PL_copline = NOLINE;
4799 Perl_newANONLIST(pTHX_ OP *o)
4801 return newUNOP(OP_REFGEN, 0,
4802 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4806 Perl_newANONHASH(pTHX_ OP *o)
4808 return newUNOP(OP_REFGEN, 0,
4809 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4813 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4815 return newANONATTRSUB(floor, proto, Nullop, block);
4819 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4821 return newUNOP(OP_REFGEN, 0,
4822 newSVOP(OP_ANONCODE, 0,
4823 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4827 Perl_oopsAV(pTHX_ OP *o)
4830 switch (o->op_type) {
4832 o->op_type = OP_PADAV;
4833 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4834 return ref(o, OP_RV2AV);
4837 o->op_type = OP_RV2AV;
4838 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4843 if (ckWARN_d(WARN_INTERNAL))
4844 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4851 Perl_oopsHV(pTHX_ OP *o)
4854 switch (o->op_type) {
4857 o->op_type = OP_PADHV;
4858 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4859 return ref(o, OP_RV2HV);
4863 o->op_type = OP_RV2HV;
4864 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4869 if (ckWARN_d(WARN_INTERNAL))
4870 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4877 Perl_newAVREF(pTHX_ OP *o)
4880 if (o->op_type == OP_PADANY) {
4881 o->op_type = OP_PADAV;
4882 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4885 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4886 && ckWARN(WARN_DEPRECATED)) {
4887 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4888 "Using an array as a reference is deprecated");
4890 return newUNOP(OP_RV2AV, 0, scalar(o));
4894 Perl_newGVREF(pTHX_ I32 type, OP *o)
4896 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4897 return newUNOP(OP_NULL, 0, o);
4898 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4902 Perl_newHVREF(pTHX_ OP *o)
4905 if (o->op_type == OP_PADANY) {
4906 o->op_type = OP_PADHV;
4907 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4910 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4911 && ckWARN(WARN_DEPRECATED)) {
4912 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4913 "Using a hash as a reference is deprecated");
4915 return newUNOP(OP_RV2HV, 0, scalar(o));
4919 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4921 return newUNOP(OP_RV2CV, flags, scalar(o));
4925 Perl_newSVREF(pTHX_ OP *o)
4928 if (o->op_type == OP_PADANY) {
4929 o->op_type = OP_PADSV;
4930 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4933 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4934 o->op_flags |= OPpDONE_SVREF;
4937 return newUNOP(OP_RV2SV, 0, scalar(o));
4940 /* Check routines. See the comments at the top of this file for details
4941 * on when these are called */
4944 Perl_ck_anoncode(pTHX_ OP *o)
4946 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4947 cSVOPo->op_sv = Nullsv;
4952 Perl_ck_bitop(pTHX_ OP *o)
4954 #define OP_IS_NUMCOMPARE(op) \
4955 ((op) == OP_LT || (op) == OP_I_LT || \
4956 (op) == OP_GT || (op) == OP_I_GT || \
4957 (op) == OP_LE || (op) == OP_I_LE || \
4958 (op) == OP_GE || (op) == OP_I_GE || \
4959 (op) == OP_EQ || (op) == OP_I_EQ || \
4960 (op) == OP_NE || (op) == OP_I_NE || \
4961 (op) == OP_NCMP || (op) == OP_I_NCMP)
4962 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4963 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4964 && (o->op_type == OP_BIT_OR
4965 || o->op_type == OP_BIT_AND
4966 || o->op_type == OP_BIT_XOR))
4968 const OP * const left = cBINOPo->op_first;
4969 const OP * const right = left->op_sibling;
4970 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4971 (left->op_flags & OPf_PARENS) == 0) ||
4972 (OP_IS_NUMCOMPARE(right->op_type) &&
4973 (right->op_flags & OPf_PARENS) == 0))
4974 if (ckWARN(WARN_PRECEDENCE))
4975 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4976 "Possible precedence problem on bitwise %c operator",
4977 o->op_type == OP_BIT_OR ? '|'
4978 : o->op_type == OP_BIT_AND ? '&' : '^'
4985 Perl_ck_concat(pTHX_ OP *o)
4987 const OP *kid = cUNOPo->op_first;
4988 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4989 !(kUNOP->op_first->op_flags & OPf_MOD))
4990 o->op_flags |= OPf_STACKED;
4995 Perl_ck_spair(pTHX_ OP *o)
4998 if (o->op_flags & OPf_KIDS) {
5001 const OPCODE type = o->op_type;
5002 o = modkids(ck_fun(o), type);
5003 kid = cUNOPo->op_first;
5004 newop = kUNOP->op_first->op_sibling;
5006 (newop->op_sibling ||
5007 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5008 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5009 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5013 op_free(kUNOP->op_first);
5014 kUNOP->op_first = newop;
5016 o->op_ppaddr = PL_ppaddr[++o->op_type];
5021 Perl_ck_delete(pTHX_ OP *o)
5025 if (o->op_flags & OPf_KIDS) {
5026 OP * const kid = cUNOPo->op_first;
5027 switch (kid->op_type) {
5029 o->op_flags |= OPf_SPECIAL;
5032 o->op_private |= OPpSLICE;
5035 o->op_flags |= OPf_SPECIAL;
5040 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5049 Perl_ck_die(pTHX_ OP *o)
5052 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5058 Perl_ck_eof(pTHX_ OP *o)
5060 const I32 type = o->op_type;
5062 if (o->op_flags & OPf_KIDS) {
5063 if (cLISTOPo->op_first->op_type == OP_STUB) {
5065 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5073 Perl_ck_eval(pTHX_ OP *o)
5076 PL_hints |= HINT_BLOCK_SCOPE;
5077 if (o->op_flags & OPf_KIDS) {
5078 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5081 o->op_flags &= ~OPf_KIDS;
5084 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5087 cUNOPo->op_first = 0;
5090 NewOp(1101, enter, 1, LOGOP);
5091 enter->op_type = OP_ENTERTRY;
5092 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5093 enter->op_private = 0;
5095 /* establish postfix order */
5096 enter->op_next = (OP*)enter;
5098 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5099 o->op_type = OP_LEAVETRY;
5100 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5101 enter->op_other = o;
5111 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5113 o->op_targ = (PADOFFSET)PL_hints;
5118 Perl_ck_exit(pTHX_ OP *o)
5121 HV * const table = GvHV(PL_hintgv);
5123 SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5124 if (svp && *svp && SvTRUE(*svp))
5125 o->op_private |= OPpEXIT_VMSISH;
5127 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5133 Perl_ck_exec(pTHX_ OP *o)
5135 if (o->op_flags & OPf_STACKED) {
5138 kid = cUNOPo->op_first->op_sibling;
5139 if (kid->op_type == OP_RV2GV)
5148 Perl_ck_exists(pTHX_ OP *o)
5151 if (o->op_flags & OPf_KIDS) {
5152 OP * const kid = cUNOPo->op_first;
5153 if (kid->op_type == OP_ENTERSUB) {
5154 (void) ref(kid, o->op_type);
5155 if (kid->op_type != OP_RV2CV && !PL_error_count)
5156 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5158 o->op_private |= OPpEXISTS_SUB;
5160 else if (kid->op_type == OP_AELEM)
5161 o->op_flags |= OPf_SPECIAL;
5162 else if (kid->op_type != OP_HELEM)
5163 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5171 Perl_ck_rvconst(pTHX_ register OP *o)
5174 SVOP *kid = (SVOP*)cUNOPo->op_first;
5176 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5177 if (kid->op_type == OP_CONST) {
5180 SV * const kidsv = kid->op_sv;
5182 /* Is it a constant from cv_const_sv()? */
5183 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5184 SV *rsv = SvRV(kidsv);
5185 const int svtype = SvTYPE(rsv);
5186 const char *badtype = Nullch;
5188 switch (o->op_type) {
5190 if (svtype > SVt_PVMG)
5191 badtype = "a SCALAR";
5194 if (svtype != SVt_PVAV)
5195 badtype = "an ARRAY";
5198 if (svtype != SVt_PVHV)
5202 if (svtype != SVt_PVCV)
5207 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5210 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5211 const char *badthing = Nullch;
5212 switch (o->op_type) {
5214 badthing = "a SCALAR";
5217 badthing = "an ARRAY";
5220 badthing = "a HASH";
5225 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5229 * This is a little tricky. We only want to add the symbol if we
5230 * didn't add it in the lexer. Otherwise we get duplicate strict
5231 * warnings. But if we didn't add it in the lexer, we must at
5232 * least pretend like we wanted to add it even if it existed before,
5233 * or we get possible typo warnings. OPpCONST_ENTERED says
5234 * whether the lexer already added THIS instance of this symbol.
5236 iscv = (o->op_type == OP_RV2CV) * 2;
5238 gv = gv_fetchsv(kidsv,
5239 iscv | !(kid->op_private & OPpCONST_ENTERED),
5242 : o->op_type == OP_RV2SV
5244 : o->op_type == OP_RV2AV
5246 : o->op_type == OP_RV2HV
5249 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5251 kid->op_type = OP_GV;
5252 SvREFCNT_dec(kid->op_sv);
5254 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5255 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5256 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5258 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5260 kid->op_sv = SvREFCNT_inc(gv);
5262 kid->op_private = 0;
5263 kid->op_ppaddr = PL_ppaddr[OP_GV];
5270 Perl_ck_ftst(pTHX_ OP *o)
5273 const I32 type = o->op_type;
5275 if (o->op_flags & OPf_REF) {
5278 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5279 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5281 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5282 OP * const newop = newGVOP(type, OPf_REF,
5283 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5289 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5290 OP_IS_FILETEST_ACCESS(o))
5291 o->op_private |= OPpFT_ACCESS;
5293 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5294 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5295 o->op_private |= OPpFT_STACKED;
5299 if (type == OP_FTTTY)
5300 o = newGVOP(type, OPf_REF, PL_stdingv);
5302 o = newUNOP(type, 0, newDEFSVOP());
5308 Perl_ck_fun(pTHX_ OP *o)
5310 const int type = o->op_type;
5311 register I32 oa = PL_opargs[type] >> OASHIFT;
5313 if (o->op_flags & OPf_STACKED) {
5314 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5317 return no_fh_allowed(o);
5320 if (o->op_flags & OPf_KIDS) {
5321 OP **tokid = &cLISTOPo->op_first;
5322 register OP *kid = cLISTOPo->op_first;
5326 if (kid->op_type == OP_PUSHMARK ||
5327 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5329 tokid = &kid->op_sibling;
5330 kid = kid->op_sibling;
5332 if (!kid && PL_opargs[type] & OA_DEFGV)
5333 *tokid = kid = newDEFSVOP();
5337 sibl = kid->op_sibling;
5340 /* list seen where single (scalar) arg expected? */
5341 if (numargs == 1 && !(oa >> 4)
5342 && kid->op_type == OP_LIST && type != OP_SCALAR)
5344 return too_many_arguments(o,PL_op_desc[type]);
5357 if ((type == OP_PUSH || type == OP_UNSHIFT)
5358 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5359 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5360 "Useless use of %s with no values",
5363 if (kid->op_type == OP_CONST &&
5364 (kid->op_private & OPpCONST_BARE))
5366 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5367 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5368 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5369 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5370 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5371 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5374 kid->op_sibling = sibl;
5377 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5378 bad_type(numargs, "array", PL_op_desc[type], kid);
5382 if (kid->op_type == OP_CONST &&
5383 (kid->op_private & OPpCONST_BARE))
5385 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5386 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5387 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5388 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5389 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5390 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5393 kid->op_sibling = sibl;
5396 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5397 bad_type(numargs, "hash", PL_op_desc[type], kid);
5402 OP * const newop = newUNOP(OP_NULL, 0, kid);
5403 kid->op_sibling = 0;
5405 newop->op_next = newop;
5407 kid->op_sibling = sibl;
5412 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5413 if (kid->op_type == OP_CONST &&
5414 (kid->op_private & OPpCONST_BARE))
5416 OP *newop = newGVOP(OP_GV, 0,
5417 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5418 if (!(o->op_private & 1) && /* if not unop */
5419 kid == cLISTOPo->op_last)
5420 cLISTOPo->op_last = newop;
5424 else if (kid->op_type == OP_READLINE) {
5425 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5426 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5429 I32 flags = OPf_SPECIAL;
5433 /* is this op a FH constructor? */
5434 if (is_handle_constructor(o,numargs)) {
5435 const char *name = Nullch;
5439 /* Set a flag to tell rv2gv to vivify
5440 * need to "prove" flag does not mean something
5441 * else already - NI-S 1999/05/07
5444 if (kid->op_type == OP_PADSV) {
5445 name = PAD_COMPNAME_PV(kid->op_targ);
5446 /* SvCUR of a pad namesv can't be trusted
5447 * (see PL_generation), so calc its length
5453 else if (kid->op_type == OP_RV2SV
5454 && kUNOP->op_first->op_type == OP_GV)
5456 GV *gv = cGVOPx_gv(kUNOP->op_first);
5458 len = GvNAMELEN(gv);
5460 else if (kid->op_type == OP_AELEM
5461 || kid->op_type == OP_HELEM)
5463 OP *op = ((BINOP*)kid)->op_first;
5466 SV *tmpstr = Nullsv;
5467 const char * const a =
5468 kid->op_type == OP_AELEM ?
5470 if (((op->op_type == OP_RV2AV) ||
5471 (op->op_type == OP_RV2HV)) &&
5472 (op = ((UNOP*)op)->op_first) &&
5473 (op->op_type == OP_GV)) {
5474 /* packagevar $a[] or $h{} */
5475 GV * const gv = cGVOPx_gv(op);
5483 else if (op->op_type == OP_PADAV
5484 || op->op_type == OP_PADHV) {
5485 /* lexicalvar $a[] or $h{} */
5486 const char * const padname =
5487 PAD_COMPNAME_PV(op->op_targ);
5496 name = SvPV_const(tmpstr, len);
5501 name = "__ANONIO__";
5508 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5509 namesv = PAD_SVl(targ);
5510 SvUPGRADE(namesv, SVt_PV);
5512 sv_setpvn(namesv, "$", 1);
5513 sv_catpvn(namesv, name, len);
5516 kid->op_sibling = 0;
5517 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5518 kid->op_targ = targ;
5519 kid->op_private |= priv;
5521 kid->op_sibling = sibl;
5527 mod(scalar(kid), type);
5531 tokid = &kid->op_sibling;
5532 kid = kid->op_sibling;
5534 o->op_private |= numargs;
5536 return too_many_arguments(o,OP_DESC(o));
5539 else if (PL_opargs[type] & OA_DEFGV) {
5541 return newUNOP(type, 0, newDEFSVOP());
5545 while (oa & OA_OPTIONAL)
5547 if (oa && oa != OA_LIST)
5548 return too_few_arguments(o,OP_DESC(o));
5554 Perl_ck_glob(pTHX_ OP *o)
5560 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5561 append_elem(OP_GLOB, o, newDEFSVOP());
5563 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5564 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5566 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5569 #if !defined(PERL_EXTERNAL_GLOB)
5570 /* XXX this can be tightened up and made more failsafe. */
5571 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5574 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5575 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5576 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5577 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5578 GvCV(gv) = GvCV(glob_gv);
5579 (void)SvREFCNT_inc((SV*)GvCV(gv));
5580 GvIMPORTED_CV_on(gv);
5583 #endif /* PERL_EXTERNAL_GLOB */
5585 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5586 append_elem(OP_GLOB, o,
5587 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5588 o->op_type = OP_LIST;
5589 o->op_ppaddr = PL_ppaddr[OP_LIST];
5590 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5591 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5592 cLISTOPo->op_first->op_targ = 0;
5593 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5594 append_elem(OP_LIST, o,
5595 scalar(newUNOP(OP_RV2CV, 0,
5596 newGVOP(OP_GV, 0, gv)))));
5597 o = newUNOP(OP_NULL, 0, ck_subr(o));
5598 o->op_targ = OP_GLOB; /* hint at what it used to be */
5601 gv = newGVgen("main");
5603 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5609 Perl_ck_grep(pTHX_ OP *o)
5614 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5617 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5618 NewOp(1101, gwop, 1, LOGOP);
5620 if (o->op_flags & OPf_STACKED) {
5623 kid = cLISTOPo->op_first->op_sibling;
5624 if (!cUNOPx(kid)->op_next)
5625 Perl_croak(aTHX_ "panic: ck_grep");
5626 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5629 kid->op_next = (OP*)gwop;
5630 o->op_flags &= ~OPf_STACKED;
5632 kid = cLISTOPo->op_first->op_sibling;
5633 if (type == OP_MAPWHILE)
5640 kid = cLISTOPo->op_first->op_sibling;
5641 if (kid->op_type != OP_NULL)
5642 Perl_croak(aTHX_ "panic: ck_grep");
5643 kid = kUNOP->op_first;
5645 gwop->op_type = type;
5646 gwop->op_ppaddr = PL_ppaddr[type];
5647 gwop->op_first = listkids(o);
5648 gwop->op_flags |= OPf_KIDS;
5649 gwop->op_other = LINKLIST(kid);
5650 kid->op_next = (OP*)gwop;
5651 offset = pad_findmy("$_");
5652 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5653 o->op_private = gwop->op_private = 0;
5654 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5657 o->op_private = gwop->op_private = OPpGREP_LEX;
5658 gwop->op_targ = o->op_targ = offset;
5661 kid = cLISTOPo->op_first->op_sibling;
5662 if (!kid || !kid->op_sibling)
5663 return too_few_arguments(o,OP_DESC(o));
5664 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5665 mod(kid, OP_GREPSTART);
5671 Perl_ck_index(pTHX_ OP *o)
5673 if (o->op_flags & OPf_KIDS) {
5674 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5676 kid = kid->op_sibling; /* get past "big" */
5677 if (kid && kid->op_type == OP_CONST)
5678 fbm_compile(((SVOP*)kid)->op_sv, 0);
5684 Perl_ck_lengthconst(pTHX_ OP *o)
5686 /* XXX length optimization goes here */
5691 Perl_ck_lfun(pTHX_ OP *o)
5693 const OPCODE type = o->op_type;
5694 return modkids(ck_fun(o), type);
5698 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5700 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5701 switch (cUNOPo->op_first->op_type) {
5703 /* This is needed for
5704 if (defined %stash::)
5705 to work. Do not break Tk.
5707 break; /* Globals via GV can be undef */
5709 case OP_AASSIGN: /* Is this a good idea? */
5710 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5711 "defined(@array) is deprecated");
5712 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5713 "\t(Maybe you should just omit the defined()?)\n");
5716 /* This is needed for
5717 if (defined %stash::)
5718 to work. Do not break Tk.
5720 break; /* Globals via GV can be undef */
5722 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5723 "defined(%%hash) is deprecated");
5724 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5725 "\t(Maybe you should just omit the defined()?)\n");
5736 Perl_ck_rfun(pTHX_ OP *o)
5738 const OPCODE type = o->op_type;
5739 return refkids(ck_fun(o), type);
5743 Perl_ck_listiob(pTHX_ OP *o)
5747 kid = cLISTOPo->op_first;
5750 kid = cLISTOPo->op_first;
5752 if (kid->op_type == OP_PUSHMARK)
5753 kid = kid->op_sibling;
5754 if (kid && o->op_flags & OPf_STACKED)
5755 kid = kid->op_sibling;
5756 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5757 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5758 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5759 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5760 cLISTOPo->op_first->op_sibling = kid;
5761 cLISTOPo->op_last = kid;
5762 kid = kid->op_sibling;
5767 append_elem(o->op_type, o, newDEFSVOP());
5773 Perl_ck_sassign(pTHX_ OP *o)
5775 OP *kid = cLISTOPo->op_first;
5776 /* has a disposable target? */
5777 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5778 && !(kid->op_flags & OPf_STACKED)
5779 /* Cannot steal the second time! */
5780 && !(kid->op_private & OPpTARGET_MY))
5782 OP * const kkid = kid->op_sibling;
5784 /* Can just relocate the target. */
5785 if (kkid && kkid->op_type == OP_PADSV
5786 && !(kkid->op_private & OPpLVAL_INTRO))
5788 kid->op_targ = kkid->op_targ;
5790 /* Now we do not need PADSV and SASSIGN. */
5791 kid->op_sibling = o->op_sibling; /* NULL */
5792 cLISTOPo->op_first = NULL;
5795 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5799 /* optimise C<my $x = undef> to C<my $x> */
5800 if (kid->op_type == OP_UNDEF) {
5801 OP * const kkid = kid->op_sibling;
5802 if (kkid && kkid->op_type == OP_PADSV
5803 && (kkid->op_private & OPpLVAL_INTRO))
5805 cLISTOPo->op_first = NULL;
5806 kid->op_sibling = NULL;
5816 Perl_ck_match(pTHX_ OP *o)
5818 if (o->op_type != OP_QR) {
5819 const I32 offset = pad_findmy("$_");
5820 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5821 o->op_targ = offset;
5822 o->op_private |= OPpTARGET_MY;
5825 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5826 o->op_private |= OPpRUNTIME;
5831 Perl_ck_method(pTHX_ OP *o)
5833 OP * const kid = cUNOPo->op_first;
5834 if (kid->op_type == OP_CONST) {
5835 SV* sv = kSVOP->op_sv;
5836 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5838 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5839 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5842 kSVOP->op_sv = Nullsv;
5844 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5853 Perl_ck_null(pTHX_ OP *o)
5859 Perl_ck_open(pTHX_ OP *o)
5861 HV * const table = GvHV(PL_hintgv);
5863 SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
5865 const I32 mode = mode_from_discipline(*svp);
5866 if (mode & O_BINARY)
5867 o->op_private |= OPpOPEN_IN_RAW;
5868 else if (mode & O_TEXT)
5869 o->op_private |= OPpOPEN_IN_CRLF;
5872 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5874 const I32 mode = mode_from_discipline(*svp);
5875 if (mode & O_BINARY)
5876 o->op_private |= OPpOPEN_OUT_RAW;
5877 else if (mode & O_TEXT)
5878 o->op_private |= OPpOPEN_OUT_CRLF;
5881 if (o->op_type == OP_BACKTICK)
5884 /* In case of three-arg dup open remove strictness
5885 * from the last arg if it is a bareword. */
5886 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
5887 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
5891 if ((last->op_type == OP_CONST) && /* The bareword. */
5892 (last->op_private & OPpCONST_BARE) &&
5893 (last->op_private & OPpCONST_STRICT) &&
5894 (oa = first->op_sibling) && /* The fh. */
5895 (oa = oa->op_sibling) && /* The mode. */
5896 (oa->op_type == OP_CONST) &&
5897 SvPOK(((SVOP*)oa)->op_sv) &&
5898 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5899 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5900 (last == oa->op_sibling)) /* The bareword. */
5901 last->op_private &= ~OPpCONST_STRICT;
5907 Perl_ck_repeat(pTHX_ OP *o)
5909 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5910 o->op_private |= OPpREPEAT_DOLIST;
5911 cBINOPo->op_first = force_list(cBINOPo->op_first);
5919 Perl_ck_require(pTHX_ OP *o)
5923 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5924 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5926 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5927 SV * const sv = kid->op_sv;
5928 U32 was_readonly = SvREADONLY(sv);
5933 sv_force_normal_flags(sv, 0);
5934 assert(!SvREADONLY(sv));
5941 for (s = SvPVX(sv); *s; s++) {
5942 if (*s == ':' && s[1] == ':') {
5944 Move(s+2, s+1, strlen(s+2)+1, char);
5945 SvCUR_set(sv, SvCUR(sv) - 1);
5948 sv_catpvn(sv, ".pm", 3);
5949 SvFLAGS(sv) |= was_readonly;
5953 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
5954 /* handle override, if any */
5955 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5956 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5957 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
5958 gv = gvp ? *gvp : Nullgv;
5962 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5963 OP * const kid = cUNOPo->op_first;
5964 cUNOPo->op_first = 0;
5966 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5967 append_elem(OP_LIST, kid,
5968 scalar(newUNOP(OP_RV2CV, 0,
5977 Perl_ck_return(pTHX_ OP *o)
5979 if (CvLVALUE(PL_compcv)) {
5981 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5982 mod(kid, OP_LEAVESUBLV);
5988 Perl_ck_select(pTHX_ OP *o)
5992 if (o->op_flags & OPf_KIDS) {
5993 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5994 if (kid && kid->op_sibling) {
5995 o->op_type = OP_SSELECT;
5996 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5998 return fold_constants(o);
6002 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6003 if (kid && kid->op_type == OP_RV2GV)
6004 kid->op_private &= ~HINT_STRICT_REFS;
6009 Perl_ck_shift(pTHX_ OP *o)
6011 const I32 type = o->op_type;
6013 if (!(o->op_flags & OPf_KIDS)) {
6017 argop = newUNOP(OP_RV2AV, 0,
6018 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6019 return newUNOP(type, 0, scalar(argop));
6021 return scalar(modkids(ck_fun(o), type));
6025 Perl_ck_sort(pTHX_ OP *o)
6029 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6031 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6032 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6034 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6036 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6038 if (kid->op_type == OP_SCOPE) {
6042 else if (kid->op_type == OP_LEAVE) {
6043 if (o->op_type == OP_SORT) {
6044 op_null(kid); /* wipe out leave */
6047 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6048 if (k->op_next == kid)
6050 /* don't descend into loops */
6051 else if (k->op_type == OP_ENTERLOOP
6052 || k->op_type == OP_ENTERITER)
6054 k = cLOOPx(k)->op_lastop;
6059 kid->op_next = 0; /* just disconnect the leave */
6060 k = kLISTOP->op_first;
6065 if (o->op_type == OP_SORT) {
6066 /* provide scalar context for comparison function/block */
6072 o->op_flags |= OPf_SPECIAL;
6074 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6077 firstkid = firstkid->op_sibling;
6080 /* provide list context for arguments */
6081 if (o->op_type == OP_SORT)
6088 S_simplify_sort(pTHX_ OP *o)
6090 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6095 if (!(o->op_flags & OPf_STACKED))
6097 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6098 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6099 kid = kUNOP->op_first; /* get past null */
6100 if (kid->op_type != OP_SCOPE)
6102 kid = kLISTOP->op_last; /* get past scope */
6103 switch(kid->op_type) {
6111 k = kid; /* remember this node*/
6112 if (kBINOP->op_first->op_type != OP_RV2SV)
6114 kid = kBINOP->op_first; /* get past cmp */
6115 if (kUNOP->op_first->op_type != OP_GV)
6117 kid = kUNOP->op_first; /* get past rv2sv */
6119 if (GvSTASH(gv) != PL_curstash)
6121 gvname = GvNAME(gv);
6122 if (*gvname == 'a' && gvname[1] == '\0')
6124 else if (*gvname == 'b' && gvname[1] == '\0')
6129 kid = k; /* back to cmp */
6130 if (kBINOP->op_last->op_type != OP_RV2SV)
6132 kid = kBINOP->op_last; /* down to 2nd arg */
6133 if (kUNOP->op_first->op_type != OP_GV)
6135 kid = kUNOP->op_first; /* get past rv2sv */
6137 if (GvSTASH(gv) != PL_curstash)
6139 gvname = GvNAME(gv);
6141 ? !(*gvname == 'a' && gvname[1] == '\0')
6142 : !(*gvname == 'b' && gvname[1] == '\0'))
6144 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6146 o->op_private |= OPpSORT_DESCEND;
6147 if (k->op_type == OP_NCMP)
6148 o->op_private |= OPpSORT_NUMERIC;
6149 if (k->op_type == OP_I_NCMP)
6150 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6151 kid = cLISTOPo->op_first->op_sibling;
6152 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6153 op_free(kid); /* then delete it */
6157 Perl_ck_split(pTHX_ OP *o)
6162 if (o->op_flags & OPf_STACKED)
6163 return no_fh_allowed(o);
6165 kid = cLISTOPo->op_first;
6166 if (kid->op_type != OP_NULL)
6167 Perl_croak(aTHX_ "panic: ck_split");
6168 kid = kid->op_sibling;
6169 op_free(cLISTOPo->op_first);
6170 cLISTOPo->op_first = kid;
6172 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6173 cLISTOPo->op_last = kid; /* There was only one element previously */
6176 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6177 OP * const sibl = kid->op_sibling;
6178 kid->op_sibling = 0;
6179 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6180 if (cLISTOPo->op_first == cLISTOPo->op_last)
6181 cLISTOPo->op_last = kid;
6182 cLISTOPo->op_first = kid;
6183 kid->op_sibling = sibl;
6186 kid->op_type = OP_PUSHRE;
6187 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6189 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6190 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6191 "Use of /g modifier is meaningless in split");
6194 if (!kid->op_sibling)
6195 append_elem(OP_SPLIT, o, newDEFSVOP());
6197 kid = kid->op_sibling;
6200 if (!kid->op_sibling)
6201 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6203 kid = kid->op_sibling;
6206 if (kid->op_sibling)
6207 return too_many_arguments(o,OP_DESC(o));
6213 Perl_ck_join(pTHX_ OP *o)
6215 const OP * const kid = cLISTOPo->op_first->op_sibling;
6216 if (kid && kid->op_type == OP_MATCH) {
6217 if (ckWARN(WARN_SYNTAX)) {
6218 const REGEXP *re = PM_GETRE(kPMOP);
6219 const char *pmstr = re ? re->precomp : "STRING";
6220 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6221 "/%s/ should probably be written as \"%s\"",
6229 Perl_ck_subr(pTHX_ OP *o)
6231 OP *prev = ((cUNOPo->op_first->op_sibling)
6232 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6233 OP *o2 = prev->op_sibling;
6240 I32 contextclass = 0;
6244 o->op_private |= OPpENTERSUB_HASTARG;
6245 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6246 if (cvop->op_type == OP_RV2CV) {
6248 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6249 op_null(cvop); /* disable rv2cv */
6250 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6251 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6252 GV *gv = cGVOPx_gv(tmpop);
6255 tmpop->op_private |= OPpEARLY_CV;
6258 namegv = CvANON(cv) ? gv : CvGV(cv);
6259 proto = SvPV_nolen((SV*)cv);
6261 if (CvASSERTION(cv)) {
6262 if (PL_hints & HINT_ASSERTING) {
6263 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6264 o->op_private |= OPpENTERSUB_DB;
6268 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6269 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6270 "Impossible to activate assertion call");
6277 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6278 if (o2->op_type == OP_CONST)
6279 o2->op_private &= ~OPpCONST_STRICT;
6280 else if (o2->op_type == OP_LIST) {
6281 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6282 if (o && o->op_type == OP_CONST)
6283 o->op_private &= ~OPpCONST_STRICT;
6286 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6287 if (PERLDB_SUB && PL_curstash != PL_debstash)
6288 o->op_private |= OPpENTERSUB_DB;
6289 while (o2 != cvop) {
6293 return too_many_arguments(o, gv_ename(namegv));
6311 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6313 arg == 1 ? "block or sub {}" : "sub {}",
6314 gv_ename(namegv), o2);
6317 /* '*' allows any scalar type, including bareword */
6320 if (o2->op_type == OP_RV2GV)
6321 goto wrapref; /* autoconvert GLOB -> GLOBref */
6322 else if (o2->op_type == OP_CONST)
6323 o2->op_private &= ~OPpCONST_STRICT;
6324 else if (o2->op_type == OP_ENTERSUB) {
6325 /* accidental subroutine, revert to bareword */
6326 OP *gvop = ((UNOP*)o2)->op_first;
6327 if (gvop && gvop->op_type == OP_NULL) {
6328 gvop = ((UNOP*)gvop)->op_first;
6330 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6333 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6334 (gvop = ((UNOP*)gvop)->op_first) &&
6335 gvop->op_type == OP_GV)
6337 GV * const gv = cGVOPx_gv(gvop);
6338 OP * const sibling = o2->op_sibling;
6339 SV * const n = newSVpvn("",0);
6341 gv_fullname4(n, gv, "", FALSE);
6342 o2 = newSVOP(OP_CONST, 0, n);
6343 prev->op_sibling = o2;
6344 o2->op_sibling = sibling;
6360 if (contextclass++ == 0) {
6361 e = strchr(proto, ']');
6362 if (!e || e == proto)
6375 while (*--p != '[');
6376 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6377 gv_ename(namegv), o2);
6383 if (o2->op_type == OP_RV2GV)
6386 bad_type(arg, "symbol", gv_ename(namegv), o2);
6389 if (o2->op_type == OP_ENTERSUB)
6392 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6395 if (o2->op_type == OP_RV2SV ||
6396 o2->op_type == OP_PADSV ||
6397 o2->op_type == OP_HELEM ||
6398 o2->op_type == OP_AELEM ||
6399 o2->op_type == OP_THREADSV)
6402 bad_type(arg, "scalar", gv_ename(namegv), o2);
6405 if (o2->op_type == OP_RV2AV ||
6406 o2->op_type == OP_PADAV)
6409 bad_type(arg, "array", gv_ename(namegv), o2);
6412 if (o2->op_type == OP_RV2HV ||
6413 o2->op_type == OP_PADHV)
6416 bad_type(arg, "hash", gv_ename(namegv), o2);
6421 OP* const sib = kid->op_sibling;
6422 kid->op_sibling = 0;
6423 o2 = newUNOP(OP_REFGEN, 0, kid);
6424 o2->op_sibling = sib;
6425 prev->op_sibling = o2;
6427 if (contextclass && e) {
6442 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6443 gv_ename(namegv), cv);
6448 mod(o2, OP_ENTERSUB);
6450 o2 = o2->op_sibling;
6452 if (proto && !optional &&
6453 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6454 return too_few_arguments(o, gv_ename(namegv));
6457 o=newSVOP(OP_CONST, 0, newSViv(0));
6463 Perl_ck_svconst(pTHX_ OP *o)
6465 SvREADONLY_on(cSVOPo->op_sv);
6470 Perl_ck_trunc(pTHX_ OP *o)
6472 if (o->op_flags & OPf_KIDS) {
6473 SVOP *kid = (SVOP*)cUNOPo->op_first;
6475 if (kid->op_type == OP_NULL)
6476 kid = (SVOP*)kid->op_sibling;
6477 if (kid && kid->op_type == OP_CONST &&
6478 (kid->op_private & OPpCONST_BARE))
6480 o->op_flags |= OPf_SPECIAL;
6481 kid->op_private &= ~OPpCONST_STRICT;
6488 Perl_ck_unpack(pTHX_ OP *o)
6490 OP *kid = cLISTOPo->op_first;
6491 if (kid->op_sibling) {
6492 kid = kid->op_sibling;
6493 if (!kid->op_sibling)
6494 kid->op_sibling = newDEFSVOP();
6500 Perl_ck_substr(pTHX_ OP *o)
6503 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6504 OP *kid = cLISTOPo->op_first;
6506 if (kid->op_type == OP_NULL)
6507 kid = kid->op_sibling;
6509 kid->op_flags |= OPf_MOD;
6515 /* A peephole optimizer. We visit the ops in the order they're to execute.
6516 * See the comments at the top of this file for more details about when
6517 * peep() is called */
6520 Perl_peep(pTHX_ register OP *o)
6523 register OP* oldop = 0;
6525 if (!o || o->op_opt)
6529 SAVEVPTR(PL_curcop);
6530 for (; o; o = o->op_next) {
6534 switch (o->op_type) {
6538 PL_curcop = ((COP*)o); /* for warnings */
6543 if (cSVOPo->op_private & OPpCONST_STRICT)
6544 no_bareword_allowed(o);
6546 case OP_METHOD_NAMED:
6547 /* Relocate sv to the pad for thread safety.
6548 * Despite being a "constant", the SV is written to,
6549 * for reference counts, sv_upgrade() etc. */
6551 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6552 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6553 /* If op_sv is already a PADTMP then it is being used by
6554 * some pad, so make a copy. */
6555 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6556 SvREADONLY_on(PAD_SVl(ix));
6557 SvREFCNT_dec(cSVOPo->op_sv);
6560 SvREFCNT_dec(PAD_SVl(ix));
6561 SvPADTMP_on(cSVOPo->op_sv);
6562 PAD_SETSV(ix, cSVOPo->op_sv);
6563 /* XXX I don't know how this isn't readonly already. */
6564 SvREADONLY_on(PAD_SVl(ix));
6566 cSVOPo->op_sv = Nullsv;
6574 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6575 if (o->op_next->op_private & OPpTARGET_MY) {
6576 if (o->op_flags & OPf_STACKED) /* chained concats */
6577 goto ignore_optimization;
6579 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6580 o->op_targ = o->op_next->op_targ;
6581 o->op_next->op_targ = 0;
6582 o->op_private |= OPpTARGET_MY;
6585 op_null(o->op_next);
6587 ignore_optimization:
6591 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6593 break; /* Scalar stub must produce undef. List stub is noop */
6597 if (o->op_targ == OP_NEXTSTATE
6598 || o->op_targ == OP_DBSTATE
6599 || o->op_targ == OP_SETSTATE)
6601 PL_curcop = ((COP*)o);
6603 /* XXX: We avoid setting op_seq here to prevent later calls
6604 to peep() from mistakenly concluding that optimisation
6605 has already occurred. This doesn't fix the real problem,
6606 though (See 20010220.007). AMS 20010719 */
6607 /* op_seq functionality is now replaced by op_opt */
6608 if (oldop && o->op_next) {
6609 oldop->op_next = o->op_next;
6617 if (oldop && o->op_next) {
6618 oldop->op_next = o->op_next;
6626 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6627 OP* pop = (o->op_type == OP_PADAV) ?
6628 o->op_next : o->op_next->op_next;
6630 if (pop && pop->op_type == OP_CONST &&
6631 ((PL_op = pop->op_next)) &&
6632 pop->op_next->op_type == OP_AELEM &&
6633 !(pop->op_next->op_private &
6634 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6635 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6640 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6641 no_bareword_allowed(pop);
6642 if (o->op_type == OP_GV)
6643 op_null(o->op_next);
6644 op_null(pop->op_next);
6646 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6647 o->op_next = pop->op_next->op_next;
6648 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6649 o->op_private = (U8)i;
6650 if (o->op_type == OP_GV) {
6655 o->op_flags |= OPf_SPECIAL;
6656 o->op_type = OP_AELEMFAST;
6662 if (o->op_next->op_type == OP_RV2SV) {
6663 if (!(o->op_next->op_private & OPpDEREF)) {
6664 op_null(o->op_next);
6665 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6667 o->op_next = o->op_next->op_next;
6668 o->op_type = OP_GVSV;
6669 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6672 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6673 GV * const gv = cGVOPo_gv;
6674 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6675 /* XXX could check prototype here instead of just carping */
6676 SV * const sv = sv_newmortal();
6677 gv_efullname3(sv, gv, Nullch);
6678 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6679 "%"SVf"() called too early to check prototype",
6683 else if (o->op_next->op_type == OP_READLINE
6684 && o->op_next->op_next->op_type == OP_CONCAT
6685 && (o->op_next->op_next->op_flags & OPf_STACKED))
6687 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6688 o->op_type = OP_RCATLINE;
6689 o->op_flags |= OPf_STACKED;
6690 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6691 op_null(o->op_next->op_next);
6692 op_null(o->op_next);
6709 while (cLOGOP->op_other->op_type == OP_NULL)
6710 cLOGOP->op_other = cLOGOP->op_other->op_next;
6711 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6717 while (cLOOP->op_redoop->op_type == OP_NULL)
6718 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6719 peep(cLOOP->op_redoop);
6720 while (cLOOP->op_nextop->op_type == OP_NULL)
6721 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6722 peep(cLOOP->op_nextop);
6723 while (cLOOP->op_lastop->op_type == OP_NULL)
6724 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6725 peep(cLOOP->op_lastop);
6732 while (cPMOP->op_pmreplstart &&
6733 cPMOP->op_pmreplstart->op_type == OP_NULL)
6734 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6735 peep(cPMOP->op_pmreplstart);
6740 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6741 && ckWARN(WARN_SYNTAX))
6743 if (o->op_next->op_sibling &&
6744 o->op_next->op_sibling->op_type != OP_EXIT &&
6745 o->op_next->op_sibling->op_type != OP_WARN &&
6746 o->op_next->op_sibling->op_type != OP_DIE) {
6747 const line_t oldline = CopLINE(PL_curcop);
6749 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6750 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6751 "Statement unlikely to be reached");
6752 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6753 "\t(Maybe you meant system() when you said exec()?)\n");
6754 CopLINE_set(PL_curcop, oldline);
6764 const char *key = NULL;
6769 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6772 /* Make the CONST have a shared SV */
6773 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6774 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6775 key = SvPV_const(sv, keylen);
6776 lexname = newSVpvn_share(key,
6777 SvUTF8(sv) ? -(I32)keylen : keylen,
6783 if ((o->op_private & (OPpLVAL_INTRO)))
6786 rop = (UNOP*)((BINOP*)o)->op_first;
6787 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6789 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6790 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6792 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6793 if (!fields || !GvHV(*fields))
6795 key = SvPV_const(*svp, keylen);
6796 if (!hv_fetch(GvHV(*fields), key,
6797 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6799 Perl_croak(aTHX_ "No such class field \"%s\" "
6800 "in variable %s of type %s",
6801 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
6814 SVOP *first_key_op, *key_op;
6816 if ((o->op_private & (OPpLVAL_INTRO))
6817 /* I bet there's always a pushmark... */
6818 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6819 /* hmmm, no optimization if list contains only one key. */
6821 rop = (UNOP*)((LISTOP*)o)->op_last;
6822 if (rop->op_type != OP_RV2HV)
6824 if (rop->op_first->op_type == OP_PADSV)
6825 /* @$hash{qw(keys here)} */
6826 rop = (UNOP*)rop->op_first;
6828 /* @{$hash}{qw(keys here)} */
6829 if (rop->op_first->op_type == OP_SCOPE
6830 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6832 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6838 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6839 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6841 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6842 if (!fields || !GvHV(*fields))
6844 /* Again guessing that the pushmark can be jumped over.... */
6845 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6846 ->op_first->op_sibling;
6847 for (key_op = first_key_op; key_op;
6848 key_op = (SVOP*)key_op->op_sibling) {
6849 if (key_op->op_type != OP_CONST)
6851 svp = cSVOPx_svp(key_op);
6852 key = SvPV_const(*svp, keylen);
6853 if (!hv_fetch(GvHV(*fields), key,
6854 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6856 Perl_croak(aTHX_ "No such class field \"%s\" "
6857 "in variable %s of type %s",
6858 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6865 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6869 /* check that RHS of sort is a single plain array */
6870 OP *oright = cUNOPo->op_first;
6871 if (!oright || oright->op_type != OP_PUSHMARK)
6874 /* reverse sort ... can be optimised. */
6875 if (!cUNOPo->op_sibling) {
6876 /* Nothing follows us on the list. */
6877 OP * const reverse = o->op_next;
6879 if (reverse->op_type == OP_REVERSE &&
6880 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6881 OP * const pushmark = cUNOPx(reverse)->op_first;
6882 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6883 && (cUNOPx(pushmark)->op_sibling == o)) {
6884 /* reverse -> pushmark -> sort */
6885 o->op_private |= OPpSORT_REVERSE;
6887 pushmark->op_next = oright->op_next;
6893 /* make @a = sort @a act in-place */
6897 oright = cUNOPx(oright)->op_sibling;
6900 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6901 oright = cUNOPx(oright)->op_sibling;
6905 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6906 || oright->op_next != o
6907 || (oright->op_private & OPpLVAL_INTRO)
6911 /* o2 follows the chain of op_nexts through the LHS of the
6912 * assign (if any) to the aassign op itself */
6914 if (!o2 || o2->op_type != OP_NULL)
6917 if (!o2 || o2->op_type != OP_PUSHMARK)
6920 if (o2 && o2->op_type == OP_GV)
6923 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6924 || (o2->op_private & OPpLVAL_INTRO)
6929 if (!o2 || o2->op_type != OP_NULL)
6932 if (!o2 || o2->op_type != OP_AASSIGN
6933 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6936 /* check that the sort is the first arg on RHS of assign */
6938 o2 = cUNOPx(o2)->op_first;
6939 if (!o2 || o2->op_type != OP_NULL)
6941 o2 = cUNOPx(o2)->op_first;
6942 if (!o2 || o2->op_type != OP_PUSHMARK)
6944 if (o2->op_sibling != o)
6947 /* check the array is the same on both sides */
6948 if (oleft->op_type == OP_RV2AV) {
6949 if (oright->op_type != OP_RV2AV
6950 || !cUNOPx(oright)->op_first
6951 || cUNOPx(oright)->op_first->op_type != OP_GV
6952 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6953 cGVOPx_gv(cUNOPx(oright)->op_first)
6957 else if (oright->op_type != OP_PADAV
6958 || oright->op_targ != oleft->op_targ
6962 /* transfer MODishness etc from LHS arg to RHS arg */
6963 oright->op_flags = oleft->op_flags;
6964 o->op_private |= OPpSORT_INPLACE;
6966 /* excise push->gv->rv2av->null->aassign */
6967 o2 = o->op_next->op_next;
6968 op_null(o2); /* PUSHMARK */
6970 if (o2->op_type == OP_GV) {
6971 op_null(o2); /* GV */
6974 op_null(o2); /* RV2AV or PADAV */
6975 o2 = o2->op_next->op_next;
6976 op_null(o2); /* AASSIGN */
6978 o->op_next = o2->op_next;
6984 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6986 LISTOP *enter, *exlist;
6989 enter = (LISTOP *) o->op_next;
6992 if (enter->op_type == OP_NULL) {
6993 enter = (LISTOP *) enter->op_next;
6997 /* for $a (...) will have OP_GV then OP_RV2GV here.
6998 for (...) just has an OP_GV. */
6999 if (enter->op_type == OP_GV) {
7000 gvop = (OP *) enter;
7001 enter = (LISTOP *) enter->op_next;
7004 if (enter->op_type == OP_RV2GV) {
7005 enter = (LISTOP *) enter->op_next;
7011 if (enter->op_type != OP_ENTERITER)
7014 iter = enter->op_next;
7015 if (!iter || iter->op_type != OP_ITER)
7018 expushmark = enter->op_first;
7019 if (!expushmark || expushmark->op_type != OP_NULL
7020 || expushmark->op_targ != OP_PUSHMARK)
7023 exlist = (LISTOP *) expushmark->op_sibling;
7024 if (!exlist || exlist->op_type != OP_NULL
7025 || exlist->op_targ != OP_LIST)
7028 if (exlist->op_last != o) {
7029 /* Mmm. Was expecting to point back to this op. */
7032 theirmark = exlist->op_first;
7033 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7036 if (theirmark->op_sibling != o) {
7037 /* There's something between the mark and the reverse, eg
7038 for (1, reverse (...))
7043 ourmark = ((LISTOP *)o)->op_first;
7044 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7047 ourlast = ((LISTOP *)o)->op_last;
7048 if (!ourlast || ourlast->op_next != o)
7051 rv2av = ourmark->op_sibling;
7052 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7053 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7054 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7055 /* We're just reversing a single array. */
7056 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7057 enter->op_flags |= OPf_STACKED;
7060 /* We don't have control over who points to theirmark, so sacrifice
7062 theirmark->op_next = ourmark->op_next;
7063 theirmark->op_flags = ourmark->op_flags;
7064 ourlast->op_next = gvop ? gvop : (OP *) enter;
7067 enter->op_private |= OPpITER_REVERSED;
7068 iter->op_private |= OPpITER_REVERSED;
7083 Perl_custom_op_name(pTHX_ const OP* o)
7085 const IV index = PTR2IV(o->op_ppaddr);
7089 if (!PL_custom_op_names) /* This probably shouldn't happen */
7090 return (char *)PL_op_name[OP_CUSTOM];
7092 keysv = sv_2mortal(newSViv(index));
7094 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7096 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7098 return SvPV_nolen(HeVAL(he));
7102 Perl_custom_op_desc(pTHX_ const OP* o)
7104 const IV index = PTR2IV(o->op_ppaddr);
7108 if (!PL_custom_op_descs)
7109 return (char *)PL_op_desc[OP_CUSTOM];
7111 keysv = sv_2mortal(newSViv(index));
7113 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7115 return (char *)PL_op_desc[OP_CUSTOM];
7117 return SvPV_nolen(HeVAL(he));
7122 /* Efficient sub that returns a constant scalar value. */
7124 const_sv_xsub(pTHX_ CV* cv)
7129 Perl_croak(aTHX_ "usage: %s::%s()",
7130 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7134 ST(0) = (SV*)XSANY.any_ptr;
7140 * c-indentation-style: bsd
7142 * indent-tabs-mode: t
7145 * ex: set ts=8 sts=4 sw=4 noet: