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);
1874 /* XXX kept for BINCOMPAT only */
1876 Perl_save_hints(pTHX)
1878 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1882 Perl_block_start(pTHX_ int full)
1884 const int retval = PL_savestack_ix;
1885 pad_block_start(full);
1887 PL_hints &= ~HINT_BLOCK_SCOPE;
1888 SAVESPTR(PL_compiling.cop_warnings);
1889 if (! specialWARN(PL_compiling.cop_warnings)) {
1890 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1891 SAVEFREESV(PL_compiling.cop_warnings) ;
1893 SAVESPTR(PL_compiling.cop_io);
1894 if (! specialCopIO(PL_compiling.cop_io)) {
1895 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1896 SAVEFREESV(PL_compiling.cop_io) ;
1902 Perl_block_end(pTHX_ I32 floor, OP *seq)
1904 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1905 OP* const retval = scalarseq(seq);
1907 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1909 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1917 const I32 offset = pad_findmy("$_");
1918 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1919 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1922 OP * const o = newOP(OP_PADSV, 0);
1923 o->op_targ = offset;
1929 Perl_newPROG(pTHX_ OP *o)
1934 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1935 ((PL_in_eval & EVAL_KEEPERR)
1936 ? OPf_SPECIAL : 0), o);
1937 PL_eval_start = linklist(PL_eval_root);
1938 PL_eval_root->op_private |= OPpREFCOUNTED;
1939 OpREFCNT_set(PL_eval_root, 1);
1940 PL_eval_root->op_next = 0;
1941 CALL_PEEP(PL_eval_start);
1944 if (o->op_type == OP_STUB) {
1945 PL_comppad_name = 0;
1950 PL_main_root = scope(sawparens(scalarvoid(o)));
1951 PL_curcop = &PL_compiling;
1952 PL_main_start = LINKLIST(PL_main_root);
1953 PL_main_root->op_private |= OPpREFCOUNTED;
1954 OpREFCNT_set(PL_main_root, 1);
1955 PL_main_root->op_next = 0;
1956 CALL_PEEP(PL_main_start);
1959 /* Register with debugger */
1961 CV * const cv = get_cv("DB::postponed", FALSE);
1965 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1967 call_sv((SV*)cv, G_DISCARD);
1974 Perl_localize(pTHX_ OP *o, I32 lex)
1976 if (o->op_flags & OPf_PARENS)
1977 /* [perl #17376]: this appears to be premature, and results in code such as
1978 C< our(%x); > executing in list mode rather than void mode */
1985 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
1986 && ckWARN(WARN_PARENTHESIS))
1988 char *s = PL_bufptr;
1991 /* some heuristics to detect a potential error */
1992 while (*s && (strchr(", \t\n", *s)))
1996 if (*s && strchr("@$%*", *s) && *++s
1997 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2000 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2002 while (*s && (strchr(", \t\n", *s)))
2008 if (sigil && (*s == ';' || *s == '=')) {
2009 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2010 "Parentheses missing around \"%s\" list",
2011 lex ? (PL_in_my == KEY_our ? "our" : "my")
2019 o = mod(o, OP_NULL); /* a bit kludgey */
2021 PL_in_my_stash = Nullhv;
2026 Perl_jmaybe(pTHX_ OP *o)
2028 if (o->op_type == OP_LIST) {
2030 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2031 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2037 Perl_fold_constants(pTHX_ register OP *o)
2041 I32 type = o->op_type;
2044 if (PL_opargs[type] & OA_RETSCALAR)
2046 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2047 o->op_targ = pad_alloc(type, SVs_PADTMP);
2049 /* integerize op, unless it happens to be C<-foo>.
2050 * XXX should pp_i_negate() do magic string negation instead? */
2051 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2052 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2053 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2055 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2058 if (!(PL_opargs[type] & OA_FOLDCONST))
2063 /* XXX might want a ck_negate() for this */
2064 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2076 /* XXX what about the numeric ops? */
2077 if (PL_hints & HINT_LOCALE)
2082 goto nope; /* Don't try to run w/ errors */
2084 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2085 if ((curop->op_type != OP_CONST ||
2086 (curop->op_private & OPpCONST_BARE)) &&
2087 curop->op_type != OP_LIST &&
2088 curop->op_type != OP_SCALAR &&
2089 curop->op_type != OP_NULL &&
2090 curop->op_type != OP_PUSHMARK)
2096 curop = LINKLIST(o);
2100 sv = *(PL_stack_sp--);
2101 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2102 pad_swipe(o->op_targ, FALSE);
2103 else if (SvTEMP(sv)) { /* grab mortal temp? */
2104 (void)SvREFCNT_inc(sv);
2108 if (type == OP_RV2GV)
2109 return newGVOP(OP_GV, 0, (GV*)sv);
2110 return newSVOP(OP_CONST, 0, sv);
2117 Perl_gen_constant_list(pTHX_ register OP *o)
2121 const I32 oldtmps_floor = PL_tmps_floor;
2125 return o; /* Don't attempt to run with errors */
2127 PL_op = curop = LINKLIST(o);
2134 PL_tmps_floor = oldtmps_floor;
2136 o->op_type = OP_RV2AV;
2137 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2138 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2139 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2140 o->op_opt = 0; /* needs to be revisited in peep() */
2141 curop = ((UNOP*)o)->op_first;
2142 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2149 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2152 if (!o || o->op_type != OP_LIST)
2153 o = newLISTOP(OP_LIST, 0, o, Nullop);
2155 o->op_flags &= ~OPf_WANT;
2157 if (!(PL_opargs[type] & OA_MARK))
2158 op_null(cLISTOPo->op_first);
2160 o->op_type = (OPCODE)type;
2161 o->op_ppaddr = PL_ppaddr[type];
2162 o->op_flags |= flags;
2164 o = CHECKOP(type, o);
2165 if (o->op_type != (unsigned)type)
2168 return fold_constants(o);
2171 /* List constructors */
2174 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2182 if (first->op_type != (unsigned)type
2183 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2185 return newLISTOP(type, 0, first, last);
2188 if (first->op_flags & OPf_KIDS)
2189 ((LISTOP*)first)->op_last->op_sibling = last;
2191 first->op_flags |= OPf_KIDS;
2192 ((LISTOP*)first)->op_first = last;
2194 ((LISTOP*)first)->op_last = last;
2199 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2207 if (first->op_type != (unsigned)type)
2208 return prepend_elem(type, (OP*)first, (OP*)last);
2210 if (last->op_type != (unsigned)type)
2211 return append_elem(type, (OP*)first, (OP*)last);
2213 first->op_last->op_sibling = last->op_first;
2214 first->op_last = last->op_last;
2215 first->op_flags |= (last->op_flags & OPf_KIDS);
2223 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2231 if (last->op_type == (unsigned)type) {
2232 if (type == OP_LIST) { /* already a PUSHMARK there */
2233 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2234 ((LISTOP*)last)->op_first->op_sibling = first;
2235 if (!(first->op_flags & OPf_PARENS))
2236 last->op_flags &= ~OPf_PARENS;
2239 if (!(last->op_flags & OPf_KIDS)) {
2240 ((LISTOP*)last)->op_last = first;
2241 last->op_flags |= OPf_KIDS;
2243 first->op_sibling = ((LISTOP*)last)->op_first;
2244 ((LISTOP*)last)->op_first = first;
2246 last->op_flags |= OPf_KIDS;
2250 return newLISTOP(type, 0, first, last);
2256 Perl_newNULLLIST(pTHX)
2258 return newOP(OP_STUB, 0);
2262 Perl_force_list(pTHX_ OP *o)
2264 if (!o || o->op_type != OP_LIST)
2265 o = newLISTOP(OP_LIST, 0, o, Nullop);
2271 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2276 NewOp(1101, listop, 1, LISTOP);
2278 listop->op_type = (OPCODE)type;
2279 listop->op_ppaddr = PL_ppaddr[type];
2282 listop->op_flags = (U8)flags;
2286 else if (!first && last)
2289 first->op_sibling = last;
2290 listop->op_first = first;
2291 listop->op_last = last;
2292 if (type == OP_LIST) {
2293 OP* const pushop = newOP(OP_PUSHMARK, 0);
2294 pushop->op_sibling = first;
2295 listop->op_first = pushop;
2296 listop->op_flags |= OPf_KIDS;
2298 listop->op_last = pushop;
2301 return CHECKOP(type, listop);
2305 Perl_newOP(pTHX_ I32 type, I32 flags)
2309 NewOp(1101, o, 1, OP);
2310 o->op_type = (OPCODE)type;
2311 o->op_ppaddr = PL_ppaddr[type];
2312 o->op_flags = (U8)flags;
2315 o->op_private = (U8)(0 | (flags >> 8));
2316 if (PL_opargs[type] & OA_RETSCALAR)
2318 if (PL_opargs[type] & OA_TARGET)
2319 o->op_targ = pad_alloc(type, SVs_PADTMP);
2320 return CHECKOP(type, o);
2324 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2330 first = newOP(OP_STUB, 0);
2331 if (PL_opargs[type] & OA_MARK)
2332 first = force_list(first);
2334 NewOp(1101, unop, 1, UNOP);
2335 unop->op_type = (OPCODE)type;
2336 unop->op_ppaddr = PL_ppaddr[type];
2337 unop->op_first = first;
2338 unop->op_flags = (U8)(flags | OPf_KIDS);
2339 unop->op_private = (U8)(1 | (flags >> 8));
2340 unop = (UNOP*) CHECKOP(type, unop);
2344 return fold_constants((OP *) unop);
2348 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2352 NewOp(1101, binop, 1, BINOP);
2355 first = newOP(OP_NULL, 0);
2357 binop->op_type = (OPCODE)type;
2358 binop->op_ppaddr = PL_ppaddr[type];
2359 binop->op_first = first;
2360 binop->op_flags = (U8)(flags | OPf_KIDS);
2363 binop->op_private = (U8)(1 | (flags >> 8));
2366 binop->op_private = (U8)(2 | (flags >> 8));
2367 first->op_sibling = last;
2370 binop = (BINOP*)CHECKOP(type, binop);
2371 if (binop->op_next || binop->op_type != (OPCODE)type)
2374 binop->op_last = binop->op_first->op_sibling;
2376 return fold_constants((OP *)binop);
2379 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2380 static int uvcompare(const void *a, const void *b)
2382 if (*((const UV *)a) < (*(const UV *)b))
2384 if (*((const UV *)a) > (*(const UV *)b))
2386 if (*((const UV *)a+1) < (*(const UV *)b+1))
2388 if (*((const UV *)a+1) > (*(const UV *)b+1))
2394 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2396 SV * const tstr = ((SVOP*)expr)->op_sv;
2397 SV * const rstr = ((SVOP*)repl)->op_sv;
2400 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2401 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2405 register short *tbl;
2407 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2408 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2409 I32 del = o->op_private & OPpTRANS_DELETE;
2410 PL_hints |= HINT_BLOCK_SCOPE;
2413 o->op_private |= OPpTRANS_FROM_UTF;
2416 o->op_private |= OPpTRANS_TO_UTF;
2418 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2419 SV* const listsv = newSVpvn("# comment\n",10);
2421 const U8* tend = t + tlen;
2422 const U8* rend = r + rlen;
2436 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2437 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2443 t = tsave = bytes_to_utf8(t, &len);
2446 if (!to_utf && rlen) {
2448 r = rsave = bytes_to_utf8(r, &len);
2452 /* There are several snags with this code on EBCDIC:
2453 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2454 2. scan_const() in toke.c has encoded chars in native encoding which makes
2455 ranges at least in EBCDIC 0..255 range the bottom odd.
2459 U8 tmpbuf[UTF8_MAXBYTES+1];
2462 Newx(cp, 2*tlen, UV);
2464 transv = newSVpvn("",0);
2466 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2468 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2470 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2474 cp[2*i+1] = cp[2*i];
2478 qsort(cp, i, 2*sizeof(UV), uvcompare);
2479 for (j = 0; j < i; j++) {
2481 diff = val - nextmin;
2483 t = uvuni_to_utf8(tmpbuf,nextmin);
2484 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2486 U8 range_mark = UTF_TO_NATIVE(0xff);
2487 t = uvuni_to_utf8(tmpbuf, val - 1);
2488 sv_catpvn(transv, (char *)&range_mark, 1);
2489 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2496 t = uvuni_to_utf8(tmpbuf,nextmin);
2497 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2499 U8 range_mark = UTF_TO_NATIVE(0xff);
2500 sv_catpvn(transv, (char *)&range_mark, 1);
2502 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2503 UNICODE_ALLOW_SUPER);
2504 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2505 t = (const U8*)SvPVX_const(transv);
2506 tlen = SvCUR(transv);
2510 else if (!rlen && !del) {
2511 r = t; rlen = tlen; rend = tend;
2514 if ((!rlen && !del) || t == r ||
2515 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2517 o->op_private |= OPpTRANS_IDENTICAL;
2521 while (t < tend || tfirst <= tlast) {
2522 /* see if we need more "t" chars */
2523 if (tfirst > tlast) {
2524 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2526 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2528 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2535 /* now see if we need more "r" chars */
2536 if (rfirst > rlast) {
2538 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2540 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2542 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2551 rfirst = rlast = 0xffffffff;
2555 /* now see which range will peter our first, if either. */
2556 tdiff = tlast - tfirst;
2557 rdiff = rlast - rfirst;
2564 if (rfirst == 0xffffffff) {
2565 diff = tdiff; /* oops, pretend rdiff is infinite */
2567 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2568 (long)tfirst, (long)tlast);
2570 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2574 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2575 (long)tfirst, (long)(tfirst + diff),
2578 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2579 (long)tfirst, (long)rfirst);
2581 if (rfirst + diff > max)
2582 max = rfirst + diff;
2584 grows = (tfirst < rfirst &&
2585 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2597 else if (max > 0xff)
2602 Safefree(cPVOPo->op_pv);
2603 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2604 SvREFCNT_dec(listsv);
2606 SvREFCNT_dec(transv);
2608 if (!del && havefinal && rlen)
2609 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2610 newSVuv((UV)final), 0);
2613 o->op_private |= OPpTRANS_GROWS;
2625 tbl = (short*)cPVOPo->op_pv;
2627 Zero(tbl, 256, short);
2628 for (i = 0; i < (I32)tlen; i++)
2630 for (i = 0, j = 0; i < 256; i++) {
2632 if (j >= (I32)rlen) {
2641 if (i < 128 && r[j] >= 128)
2651 o->op_private |= OPpTRANS_IDENTICAL;
2653 else if (j >= (I32)rlen)
2656 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2657 tbl[0x100] = (short)(rlen - j);
2658 for (i=0; i < (I32)rlen - j; i++)
2659 tbl[0x101+i] = r[j+i];
2663 if (!rlen && !del) {
2666 o->op_private |= OPpTRANS_IDENTICAL;
2668 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2669 o->op_private |= OPpTRANS_IDENTICAL;
2671 for (i = 0; i < 256; i++)
2673 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2674 if (j >= (I32)rlen) {
2676 if (tbl[t[i]] == -1)
2682 if (tbl[t[i]] == -1) {
2683 if (t[i] < 128 && r[j] >= 128)
2690 o->op_private |= OPpTRANS_GROWS;
2698 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2703 NewOp(1101, pmop, 1, PMOP);
2704 pmop->op_type = (OPCODE)type;
2705 pmop->op_ppaddr = PL_ppaddr[type];
2706 pmop->op_flags = (U8)flags;
2707 pmop->op_private = (U8)(0 | (flags >> 8));
2709 if (PL_hints & HINT_RE_TAINT)
2710 pmop->op_pmpermflags |= PMf_RETAINT;
2711 if (PL_hints & HINT_LOCALE)
2712 pmop->op_pmpermflags |= PMf_LOCALE;
2713 pmop->op_pmflags = pmop->op_pmpermflags;
2716 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2717 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2718 pmop->op_pmoffset = SvIV(repointer);
2719 SvREPADTMP_off(repointer);
2720 sv_setiv(repointer,0);
2722 SV * const repointer = newSViv(0);
2723 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2724 pmop->op_pmoffset = av_len(PL_regex_padav);
2725 PL_regex_pad = AvARRAY(PL_regex_padav);
2729 /* link into pm list */
2730 if (type != OP_TRANS && PL_curstash) {
2731 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2734 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2736 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2737 mg->mg_obj = (SV*)pmop;
2738 PmopSTASH_set(pmop,PL_curstash);
2741 return CHECKOP(type, pmop);
2744 /* Given some sort of match op o, and an expression expr containing a
2745 * pattern, either compile expr into a regex and attach it to o (if it's
2746 * constant), or convert expr into a runtime regcomp op sequence (if it's
2749 * isreg indicates that the pattern is part of a regex construct, eg
2750 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2751 * split "pattern", which aren't. In the former case, expr will be a list
2752 * if the pattern contains more than one term (eg /a$b/) or if it contains
2753 * a replacement, ie s/// or tr///.
2757 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2762 I32 repl_has_vars = 0;
2766 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2767 /* last element in list is the replacement; pop it */
2769 repl = cLISTOPx(expr)->op_last;
2770 kid = cLISTOPx(expr)->op_first;
2771 while (kid->op_sibling != repl)
2772 kid = kid->op_sibling;
2773 kid->op_sibling = Nullop;
2774 cLISTOPx(expr)->op_last = kid;
2777 if (isreg && expr->op_type == OP_LIST &&
2778 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2780 /* convert single element list to element */
2782 expr = cLISTOPx(oe)->op_first->op_sibling;
2783 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2784 cLISTOPx(oe)->op_last = Nullop;
2788 if (o->op_type == OP_TRANS) {
2789 return pmtrans(o, expr, repl);
2792 reglist = isreg && expr->op_type == OP_LIST;
2796 PL_hints |= HINT_BLOCK_SCOPE;
2799 if (expr->op_type == OP_CONST) {
2801 SV *pat = ((SVOP*)expr)->op_sv;
2802 const char *p = SvPV_const(pat, plen);
2803 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2804 U32 was_readonly = SvREADONLY(pat);
2808 sv_force_normal_flags(pat, 0);
2809 assert(!SvREADONLY(pat));
2812 SvREADONLY_off(pat);
2816 sv_setpvn(pat, "\\s+", 3);
2818 SvFLAGS(pat) |= was_readonly;
2820 p = SvPV_const(pat, plen);
2821 pm->op_pmflags |= PMf_SKIPWHITE;
2824 pm->op_pmdynflags |= PMdf_UTF8;
2825 /* FIXME - can we make this function take const char * args? */
2826 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2827 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2828 pm->op_pmflags |= PMf_WHITE;
2832 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2833 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2835 : OP_REGCMAYBE),0,expr);
2837 NewOp(1101, rcop, 1, LOGOP);
2838 rcop->op_type = OP_REGCOMP;
2839 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2840 rcop->op_first = scalar(expr);
2841 rcop->op_flags |= OPf_KIDS
2842 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2843 | (reglist ? OPf_STACKED : 0);
2844 rcop->op_private = 1;
2847 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2849 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2852 /* establish postfix order */
2853 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2855 rcop->op_next = expr;
2856 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2859 rcop->op_next = LINKLIST(expr);
2860 expr->op_next = (OP*)rcop;
2863 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2868 if (pm->op_pmflags & PMf_EVAL) {
2870 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2871 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2873 else if (repl->op_type == OP_CONST)
2877 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2878 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2879 if (curop->op_type == OP_GV) {
2880 GV *gv = cGVOPx_gv(curop);
2882 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2885 else if (curop->op_type == OP_RV2CV)
2887 else if (curop->op_type == OP_RV2SV ||
2888 curop->op_type == OP_RV2AV ||
2889 curop->op_type == OP_RV2HV ||
2890 curop->op_type == OP_RV2GV) {
2891 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2894 else if (curop->op_type == OP_PADSV ||
2895 curop->op_type == OP_PADAV ||
2896 curop->op_type == OP_PADHV ||
2897 curop->op_type == OP_PADANY) {
2900 else if (curop->op_type == OP_PUSHRE)
2901 ; /* Okay here, dangerous in newASSIGNOP */
2911 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2912 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2913 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2914 prepend_elem(o->op_type, scalar(repl), o);
2917 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2918 pm->op_pmflags |= PMf_MAYBE_CONST;
2919 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2921 NewOp(1101, rcop, 1, LOGOP);
2922 rcop->op_type = OP_SUBSTCONT;
2923 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2924 rcop->op_first = scalar(repl);
2925 rcop->op_flags |= OPf_KIDS;
2926 rcop->op_private = 1;
2929 /* establish postfix order */
2930 rcop->op_next = LINKLIST(repl);
2931 repl->op_next = (OP*)rcop;
2933 pm->op_pmreplroot = scalar((OP*)rcop);
2934 pm->op_pmreplstart = LINKLIST(rcop);
2943 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2947 NewOp(1101, svop, 1, SVOP);
2948 svop->op_type = (OPCODE)type;
2949 svop->op_ppaddr = PL_ppaddr[type];
2951 svop->op_next = (OP*)svop;
2952 svop->op_flags = (U8)flags;
2953 if (PL_opargs[type] & OA_RETSCALAR)
2955 if (PL_opargs[type] & OA_TARGET)
2956 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2957 return CHECKOP(type, svop);
2961 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2965 NewOp(1101, padop, 1, PADOP);
2966 padop->op_type = (OPCODE)type;
2967 padop->op_ppaddr = PL_ppaddr[type];
2968 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2969 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2970 PAD_SETSV(padop->op_padix, sv);
2973 padop->op_next = (OP*)padop;
2974 padop->op_flags = (U8)flags;
2975 if (PL_opargs[type] & OA_RETSCALAR)
2977 if (PL_opargs[type] & OA_TARGET)
2978 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2979 return CHECKOP(type, padop);
2983 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2989 return newPADOP(type, flags, SvREFCNT_inc(gv));
2991 return newSVOP(type, flags, SvREFCNT_inc(gv));
2996 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3000 NewOp(1101, pvop, 1, PVOP);
3001 pvop->op_type = (OPCODE)type;
3002 pvop->op_ppaddr = PL_ppaddr[type];
3004 pvop->op_next = (OP*)pvop;
3005 pvop->op_flags = (U8)flags;
3006 if (PL_opargs[type] & OA_RETSCALAR)
3008 if (PL_opargs[type] & OA_TARGET)
3009 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3010 return CHECKOP(type, pvop);
3014 Perl_package(pTHX_ OP *o)
3019 save_hptr(&PL_curstash);
3020 save_item(PL_curstname);
3022 name = SvPV_const(cSVOPo->op_sv, len);
3023 PL_curstash = gv_stashpvn(name, len, TRUE);
3024 sv_setpvn(PL_curstname, name, len);
3027 PL_hints |= HINT_BLOCK_SCOPE;
3028 PL_copline = NOLINE;
3033 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3039 if (idop->op_type != OP_CONST)
3040 Perl_croak(aTHX_ "Module name must be constant");
3045 SV * const vesv = ((SVOP*)version)->op_sv;
3047 if (!arg && !SvNIOKp(vesv)) {
3054 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3055 Perl_croak(aTHX_ "Version number must be constant number");
3057 /* Make copy of idop so we don't free it twice */
3058 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3060 /* Fake up a method call to VERSION */
3061 meth = newSVpvn_share("VERSION", 7, 0);
3062 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3063 append_elem(OP_LIST,
3064 prepend_elem(OP_LIST, pack, list(version)),
3065 newSVOP(OP_METHOD_NAMED, 0, meth)));
3069 /* Fake up an import/unimport */
3070 if (arg && arg->op_type == OP_STUB)
3071 imop = arg; /* no import on explicit () */
3072 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3073 imop = Nullop; /* use 5.0; */
3075 idop->op_private |= OPpCONST_NOVER;
3080 /* Make copy of idop so we don't free it twice */
3081 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3083 /* Fake up a method call to import/unimport */
3085 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3086 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3087 append_elem(OP_LIST,
3088 prepend_elem(OP_LIST, pack, list(arg)),
3089 newSVOP(OP_METHOD_NAMED, 0, meth)));
3092 /* Fake up the BEGIN {}, which does its thing immediately. */
3094 newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3097 append_elem(OP_LINESEQ,
3098 append_elem(OP_LINESEQ,
3099 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3100 newSTATEOP(0, Nullch, veop)),
3101 newSTATEOP(0, Nullch, imop) ));
3103 /* The "did you use incorrect case?" warning used to be here.
3104 * The problem is that on case-insensitive filesystems one
3105 * might get false positives for "use" (and "require"):
3106 * "use Strict" or "require CARP" will work. This causes
3107 * portability problems for the script: in case-strict
3108 * filesystems the script will stop working.
3110 * The "incorrect case" warning checked whether "use Foo"
3111 * imported "Foo" to your namespace, but that is wrong, too:
3112 * there is no requirement nor promise in the language that
3113 * a Foo.pm should or would contain anything in package "Foo".
3115 * There is very little Configure-wise that can be done, either:
3116 * the case-sensitivity of the build filesystem of Perl does not
3117 * help in guessing the case-sensitivity of the runtime environment.
3120 PL_hints |= HINT_BLOCK_SCOPE;
3121 PL_copline = NOLINE;
3123 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3127 =head1 Embedding Functions
3129 =for apidoc load_module
3131 Loads the module whose name is pointed to by the string part of name.
3132 Note that the actual module name, not its filename, should be given.
3133 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3134 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3135 (or 0 for no flags). ver, if specified, provides version semantics
3136 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3137 arguments can be used to specify arguments to the module's import()
3138 method, similar to C<use Foo::Bar VERSION LIST>.
3143 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3146 va_start(args, ver);
3147 vload_module(flags, name, ver, &args);
3151 #ifdef PERL_IMPLICIT_CONTEXT
3153 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3157 va_start(args, ver);
3158 vload_module(flags, name, ver, &args);
3164 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3168 OP * const modname = newSVOP(OP_CONST, 0, name);
3169 modname->op_private |= OPpCONST_BARE;
3171 veop = newSVOP(OP_CONST, 0, ver);
3175 if (flags & PERL_LOADMOD_NOIMPORT) {
3176 imop = sawparens(newNULLLIST());
3178 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3179 imop = va_arg(*args, OP*);
3184 sv = va_arg(*args, SV*);
3186 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3187 sv = va_arg(*args, SV*);
3191 const line_t ocopline = PL_copline;
3192 COP * const ocurcop = PL_curcop;
3193 const int oexpect = PL_expect;
3195 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3196 veop, modname, imop);
3197 PL_expect = oexpect;
3198 PL_copline = ocopline;
3199 PL_curcop = ocurcop;
3204 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3209 if (!force_builtin) {
3210 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3211 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3212 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3213 gv = gvp ? *gvp : Nullgv;
3217 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3218 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3219 append_elem(OP_LIST, term,
3220 scalar(newUNOP(OP_RV2CV, 0,
3225 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3231 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3233 return newBINOP(OP_LSLICE, flags,
3234 list(force_list(subscript)),
3235 list(force_list(listval)) );
3239 S_is_list_assignment(pTHX_ register const OP *o)
3244 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3245 o = cUNOPo->op_first;
3247 if (o->op_type == OP_COND_EXPR) {
3248 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3249 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3254 yyerror("Assignment to both a list and a scalar");
3258 if (o->op_type == OP_LIST &&
3259 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3260 o->op_private & OPpLVAL_INTRO)
3263 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3264 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3265 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3268 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3271 if (o->op_type == OP_RV2SV)
3278 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3283 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3284 return newLOGOP(optype, 0,
3285 mod(scalar(left), optype),
3286 newUNOP(OP_SASSIGN, 0, scalar(right)));
3289 return newBINOP(optype, OPf_STACKED,
3290 mod(scalar(left), optype), scalar(right));
3294 if (is_list_assignment(left)) {
3298 /* Grandfathering $[ assignment here. Bletch.*/
3299 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3300 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3301 left = mod(left, OP_AASSIGN);
3304 else if (left->op_type == OP_CONST) {
3305 /* Result of assignment is always 1 (or we'd be dead already) */
3306 return newSVOP(OP_CONST, 0, newSViv(1));
3308 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3309 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3310 && right->op_type == OP_STUB
3311 && (left->op_private & OPpLVAL_INTRO))
3314 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3317 curop = list(force_list(left));
3318 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3319 o->op_private = (U8)(0 | (flags >> 8));
3321 /* PL_generation sorcery:
3322 * an assignment like ($a,$b) = ($c,$d) is easier than
3323 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3324 * To detect whether there are common vars, the global var
3325 * PL_generation is incremented for each assign op we compile.
3326 * Then, while compiling the assign op, we run through all the
3327 * variables on both sides of the assignment, setting a spare slot
3328 * in each of them to PL_generation. If any of them already have
3329 * that value, we know we've got commonality. We could use a
3330 * single bit marker, but then we'd have to make 2 passes, first
3331 * to clear the flag, then to test and set it. To find somewhere
3332 * to store these values, evil chicanery is done with SvCUR().
3335 if (!(left->op_private & OPpLVAL_INTRO)) {
3338 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3339 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3340 if (curop->op_type == OP_GV) {
3341 GV *gv = cGVOPx_gv(curop);
3342 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3344 SvCUR_set(gv, PL_generation);
3346 else if (curop->op_type == OP_PADSV ||
3347 curop->op_type == OP_PADAV ||
3348 curop->op_type == OP_PADHV ||
3349 curop->op_type == OP_PADANY)
3351 if (PAD_COMPNAME_GEN(curop->op_targ)
3352 == (STRLEN)PL_generation)
3354 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3357 else if (curop->op_type == OP_RV2CV)
3359 else if (curop->op_type == OP_RV2SV ||
3360 curop->op_type == OP_RV2AV ||
3361 curop->op_type == OP_RV2HV ||
3362 curop->op_type == OP_RV2GV) {
3363 if (lastop->op_type != OP_GV) /* funny deref? */
3366 else if (curop->op_type == OP_PUSHRE) {
3367 if (((PMOP*)curop)->op_pmreplroot) {
3369 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3370 ((PMOP*)curop)->op_pmreplroot));
3372 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3374 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3376 SvCUR_set(gv, PL_generation);
3385 o->op_private |= OPpASSIGN_COMMON;
3387 if (right && right->op_type == OP_SPLIT) {
3389 if ((tmpop = ((LISTOP*)right)->op_first) &&
3390 tmpop->op_type == OP_PUSHRE)
3392 PMOP * const pm = (PMOP*)tmpop;
3393 if (left->op_type == OP_RV2AV &&
3394 !(left->op_private & OPpLVAL_INTRO) &&
3395 !(o->op_private & OPpASSIGN_COMMON) )
3397 tmpop = ((UNOP*)left)->op_first;
3398 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3400 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3401 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3403 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3404 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3406 pm->op_pmflags |= PMf_ONCE;
3407 tmpop = cUNOPo->op_first; /* to list (nulled) */
3408 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3409 tmpop->op_sibling = Nullop; /* don't free split */
3410 right->op_next = tmpop->op_next; /* fix starting loc */
3411 op_free(o); /* blow off assign */
3412 right->op_flags &= ~OPf_WANT;
3413 /* "I don't know and I don't care." */
3418 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3419 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3421 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3423 sv_setiv(sv, PL_modcount+1);
3431 right = newOP(OP_UNDEF, 0);
3432 if (right->op_type == OP_READLINE) {
3433 right->op_flags |= OPf_STACKED;
3434 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3437 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3438 o = newBINOP(OP_SASSIGN, flags,
3439 scalar(right), mod(scalar(left), OP_SASSIGN) );
3443 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3450 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3453 const U32 seq = intro_my();
3456 NewOp(1101, cop, 1, COP);
3457 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3458 cop->op_type = OP_DBSTATE;
3459 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3462 cop->op_type = OP_NEXTSTATE;
3463 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3465 cop->op_flags = (U8)flags;
3466 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3468 cop->op_private |= NATIVE_HINTS;
3470 PL_compiling.op_private = cop->op_private;
3471 cop->op_next = (OP*)cop;
3474 cop->cop_label = label;
3475 PL_hints |= HINT_BLOCK_SCOPE;
3478 cop->cop_arybase = PL_curcop->cop_arybase;
3479 if (specialWARN(PL_curcop->cop_warnings))
3480 cop->cop_warnings = PL_curcop->cop_warnings ;
3482 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3483 if (specialCopIO(PL_curcop->cop_io))
3484 cop->cop_io = PL_curcop->cop_io;
3486 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3489 if (PL_copline == NOLINE)
3490 CopLINE_set(cop, CopLINE(PL_curcop));
3492 CopLINE_set(cop, PL_copline);
3493 PL_copline = NOLINE;
3496 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3498 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3500 CopSTASH_set(cop, PL_curstash);
3502 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3503 SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3504 if (svp && *svp != &PL_sv_undef ) {
3505 (void)SvIOK_on(*svp);
3506 SvIV_set(*svp, PTR2IV(cop));
3510 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3515 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3518 return new_logop(type, flags, &first, &other);
3522 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3527 OP *first = *firstp;
3528 OP * const other = *otherp;
3530 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3531 return newBINOP(type, flags, scalar(first), scalar(other));
3533 scalarboolean(first);
3534 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3535 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3536 if (type == OP_AND || type == OP_OR) {
3542 first = *firstp = cUNOPo->op_first;
3544 first->op_next = o->op_next;
3545 cUNOPo->op_first = Nullop;
3549 if (first->op_type == OP_CONST) {
3550 if (first->op_private & OPpCONST_STRICT)
3551 no_bareword_allowed(first);
3552 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3553 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3554 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3555 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3556 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3559 if (other->op_type == OP_CONST)
3560 other->op_private |= OPpCONST_SHORTCIRCUIT;
3564 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3565 const OP *o2 = other;
3566 if ( ! (o2->op_type == OP_LIST
3567 && (( o2 = cUNOPx(o2)->op_first))
3568 && o2->op_type == OP_PUSHMARK
3569 && (( o2 = o2->op_sibling)) )
3572 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3573 || o2->op_type == OP_PADHV)
3574 && o2->op_private & OPpLVAL_INTRO
3575 && ckWARN(WARN_DEPRECATED))
3577 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3578 "Deprecated use of my() in false conditional");
3583 if (first->op_type == OP_CONST)
3584 first->op_private |= OPpCONST_SHORTCIRCUIT;
3588 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3589 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3591 const OP * const k1 = ((UNOP*)first)->op_first;
3592 const OP * const k2 = k1->op_sibling;
3594 switch (first->op_type)
3597 if (k2 && k2->op_type == OP_READLINE
3598 && (k2->op_flags & OPf_STACKED)
3599 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3601 warnop = k2->op_type;
3606 if (k1->op_type == OP_READDIR
3607 || k1->op_type == OP_GLOB
3608 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3609 || k1->op_type == OP_EACH)
3611 warnop = ((k1->op_type == OP_NULL)
3612 ? (OPCODE)k1->op_targ : k1->op_type);
3617 const line_t oldline = CopLINE(PL_curcop);
3618 CopLINE_set(PL_curcop, PL_copline);
3619 Perl_warner(aTHX_ packWARN(WARN_MISC),
3620 "Value of %s%s can be \"0\"; test with defined()",
3622 ((warnop == OP_READLINE || warnop == OP_GLOB)
3623 ? " construct" : "() operator"));
3624 CopLINE_set(PL_curcop, oldline);
3631 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3632 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3634 NewOp(1101, logop, 1, LOGOP);
3636 logop->op_type = (OPCODE)type;
3637 logop->op_ppaddr = PL_ppaddr[type];
3638 logop->op_first = first;
3639 logop->op_flags = (U8)(flags | OPf_KIDS);
3640 logop->op_other = LINKLIST(other);
3641 logop->op_private = (U8)(1 | (flags >> 8));
3643 /* establish postfix order */
3644 logop->op_next = LINKLIST(first);
3645 first->op_next = (OP*)logop;
3646 first->op_sibling = other;
3648 CHECKOP(type,logop);
3650 o = newUNOP(OP_NULL, 0, (OP*)logop);
3657 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3665 return newLOGOP(OP_AND, 0, first, trueop);
3667 return newLOGOP(OP_OR, 0, first, falseop);
3669 scalarboolean(first);
3670 if (first->op_type == OP_CONST) {
3671 if (first->op_private & OPpCONST_BARE &&
3672 first->op_private & OPpCONST_STRICT) {
3673 no_bareword_allowed(first);
3675 if (SvTRUE(((SVOP*)first)->op_sv)) {
3686 NewOp(1101, logop, 1, LOGOP);
3687 logop->op_type = OP_COND_EXPR;
3688 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3689 logop->op_first = first;
3690 logop->op_flags = (U8)(flags | OPf_KIDS);
3691 logop->op_private = (U8)(1 | (flags >> 8));
3692 logop->op_other = LINKLIST(trueop);
3693 logop->op_next = LINKLIST(falseop);
3695 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3698 /* establish postfix order */
3699 start = LINKLIST(first);
3700 first->op_next = (OP*)logop;
3702 first->op_sibling = trueop;
3703 trueop->op_sibling = falseop;
3704 o = newUNOP(OP_NULL, 0, (OP*)logop);
3706 trueop->op_next = falseop->op_next = o;
3713 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3722 NewOp(1101, range, 1, LOGOP);
3724 range->op_type = OP_RANGE;
3725 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3726 range->op_first = left;
3727 range->op_flags = OPf_KIDS;
3728 leftstart = LINKLIST(left);
3729 range->op_other = LINKLIST(right);
3730 range->op_private = (U8)(1 | (flags >> 8));
3732 left->op_sibling = right;
3734 range->op_next = (OP*)range;
3735 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3736 flop = newUNOP(OP_FLOP, 0, flip);
3737 o = newUNOP(OP_NULL, 0, flop);
3739 range->op_next = leftstart;
3741 left->op_next = flip;
3742 right->op_next = flop;
3744 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3745 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3746 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3747 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3749 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3750 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3753 if (!flip->op_private || !flop->op_private)
3754 linklist(o); /* blow off optimizer unless constant */
3760 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3764 const bool once = block && block->op_flags & OPf_SPECIAL &&
3765 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3767 PERL_UNUSED_ARG(debuggable);
3770 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3771 return block; /* do {} while 0 does once */
3772 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3773 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3774 expr = newUNOP(OP_DEFINED, 0,
3775 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3776 } else if (expr->op_flags & OPf_KIDS) {
3777 const OP * const k1 = ((UNOP*)expr)->op_first;
3778 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3779 switch (expr->op_type) {
3781 if (k2 && k2->op_type == OP_READLINE
3782 && (k2->op_flags & OPf_STACKED)
3783 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3784 expr = newUNOP(OP_DEFINED, 0, expr);
3788 if (k1->op_type == OP_READDIR
3789 || k1->op_type == OP_GLOB
3790 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3791 || k1->op_type == OP_EACH)
3792 expr = newUNOP(OP_DEFINED, 0, expr);
3798 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3799 * op, in listop. This is wrong. [perl #27024] */
3801 block = newOP(OP_NULL, 0);
3802 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3803 o = new_logop(OP_AND, 0, &expr, &listop);
3806 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3808 if (once && o != listop)
3809 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3812 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3814 o->op_flags |= flags;
3816 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3821 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3822 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3831 PERL_UNUSED_ARG(debuggable);
3834 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3835 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3836 expr = newUNOP(OP_DEFINED, 0,
3837 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3838 } else if (expr->op_flags & OPf_KIDS) {
3839 const OP * const k1 = ((UNOP*)expr)->op_first;
3840 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3841 switch (expr->op_type) {
3843 if (k2 && k2->op_type == OP_READLINE
3844 && (k2->op_flags & OPf_STACKED)
3845 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3846 expr = newUNOP(OP_DEFINED, 0, expr);
3850 if (k1->op_type == OP_READDIR
3851 || k1->op_type == OP_GLOB
3852 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3853 || k1->op_type == OP_EACH)
3854 expr = newUNOP(OP_DEFINED, 0, expr);
3861 block = newOP(OP_NULL, 0);
3862 else if (cont || has_my) {
3863 block = scope(block);
3867 next = LINKLIST(cont);
3870 OP * const unstack = newOP(OP_UNSTACK, 0);
3873 cont = append_elem(OP_LINESEQ, cont, unstack);
3876 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3877 redo = LINKLIST(listop);
3880 PL_copline = (line_t)whileline;
3882 o = new_logop(OP_AND, 0, &expr, &listop);
3883 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3884 op_free(expr); /* oops, it's a while (0) */
3886 return Nullop; /* listop already freed by new_logop */
3889 ((LISTOP*)listop)->op_last->op_next =
3890 (o == listop ? redo : LINKLIST(o));
3896 NewOp(1101,loop,1,LOOP);
3897 loop->op_type = OP_ENTERLOOP;
3898 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3899 loop->op_private = 0;
3900 loop->op_next = (OP*)loop;
3903 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3905 loop->op_redoop = redo;
3906 loop->op_lastop = o;
3907 o->op_private |= loopflags;
3910 loop->op_nextop = next;
3912 loop->op_nextop = o;
3914 o->op_flags |= flags;
3915 o->op_private |= (flags >> 8);
3920 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3925 PADOFFSET padoff = 0;
3930 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3931 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3932 sv->op_type = OP_RV2GV;
3933 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3935 else if (sv->op_type == OP_PADSV) { /* private variable */
3936 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3937 padoff = sv->op_targ;
3942 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3943 padoff = sv->op_targ;
3945 iterflags |= OPf_SPECIAL;
3950 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3953 const I32 offset = pad_findmy("$_");
3954 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3955 sv = newGVOP(OP_GV, 0, PL_defgv);
3961 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3962 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3963 iterflags |= OPf_STACKED;
3965 else if (expr->op_type == OP_NULL &&
3966 (expr->op_flags & OPf_KIDS) &&
3967 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3969 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3970 * set the STACKED flag to indicate that these values are to be
3971 * treated as min/max values by 'pp_iterinit'.
3973 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3974 LOGOP* const range = (LOGOP*) flip->op_first;
3975 OP* const left = range->op_first;
3976 OP* const right = left->op_sibling;
3979 range->op_flags &= ~OPf_KIDS;
3980 range->op_first = Nullop;
3982 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3983 listop->op_first->op_next = range->op_next;
3984 left->op_next = range->op_other;
3985 right->op_next = (OP*)listop;
3986 listop->op_next = listop->op_first;
3989 expr = (OP*)(listop);
3991 iterflags |= OPf_STACKED;
3994 expr = mod(force_list(expr), OP_GREPSTART);
3997 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3998 append_elem(OP_LIST, expr, scalar(sv))));
3999 assert(!loop->op_next);
4000 /* for my $x () sets OPpLVAL_INTRO;
4001 * for our $x () sets OPpOUR_INTRO */
4002 loop->op_private = (U8)iterpflags;
4003 #ifdef PL_OP_SLAB_ALLOC
4006 NewOp(1234,tmp,1,LOOP);
4007 Copy(loop,tmp,1,LISTOP);
4012 Renew(loop, 1, LOOP);
4014 loop->op_targ = padoff;
4015 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4016 PL_copline = forline;
4017 return newSTATEOP(0, label, wop);
4021 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4025 if (type != OP_GOTO || label->op_type == OP_CONST) {
4026 /* "last()" means "last" */
4027 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4028 o = newOP(type, OPf_SPECIAL);
4030 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4031 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4037 /* Check whether it's going to be a goto &function */
4038 if (label->op_type == OP_ENTERSUB
4039 && !(label->op_flags & OPf_STACKED))
4040 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4041 o = newUNOP(type, OPf_STACKED, label);
4043 PL_hints |= HINT_BLOCK_SCOPE;
4048 =for apidoc cv_undef
4050 Clear out all the active components of a CV. This can happen either
4051 by an explicit C<undef &foo>, or by the reference count going to zero.
4052 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4053 children can still follow the full lexical scope chain.
4059 Perl_cv_undef(pTHX_ CV *cv)
4063 if (CvFILE(cv) && !CvXSUB(cv)) {
4064 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4065 Safefree(CvFILE(cv));
4070 if (!CvXSUB(cv) && CvROOT(cv)) {
4072 Perl_croak(aTHX_ "Can't undef active subroutine");
4075 PAD_SAVE_SETNULLPAD();
4077 op_free(CvROOT(cv));
4078 CvROOT(cv) = Nullop;
4079 CvSTART(cv) = Nullop;
4082 SvPOK_off((SV*)cv); /* forget prototype */
4087 /* remove CvOUTSIDE unless this is an undef rather than a free */
4088 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4089 if (!CvWEAKOUTSIDE(cv))
4090 SvREFCNT_dec(CvOUTSIDE(cv));
4091 CvOUTSIDE(cv) = Nullcv;
4094 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4100 /* delete all flags except WEAKOUTSIDE */
4101 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4105 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4107 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4108 SV* const msg = sv_newmortal();
4112 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4113 sv_setpv(msg, "Prototype mismatch:");
4115 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4117 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4119 Perl_sv_catpv(aTHX_ msg, ": none");
4120 sv_catpv(msg, " vs ");
4122 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4124 sv_catpv(msg, "none");
4125 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4129 static void const_sv_xsub(pTHX_ CV* cv);
4133 =head1 Optree Manipulation Functions
4135 =for apidoc cv_const_sv
4137 If C<cv> is a constant sub eligible for inlining. returns the constant
4138 value returned by the sub. Otherwise, returns NULL.
4140 Constant subs can be created with C<newCONSTSUB> or as described in
4141 L<perlsub/"Constant Functions">.
4146 Perl_cv_const_sv(pTHX_ CV *cv)
4148 if (!cv || !CvCONST(cv))
4150 return (SV*)CvXSUBANY(cv).any_ptr;
4153 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4154 * Can be called in 3 ways:
4157 * look for a single OP_CONST with attached value: return the value
4159 * cv && CvCLONE(cv) && !CvCONST(cv)
4161 * examine the clone prototype, and if contains only a single
4162 * OP_CONST referencing a pad const, or a single PADSV referencing
4163 * an outer lexical, return a non-zero value to indicate the CV is
4164 * a candidate for "constizing" at clone time
4168 * We have just cloned an anon prototype that was marked as a const
4169 * candidiate. Try to grab the current value, and in the case of
4170 * PADSV, ignore it if it has multiple references. Return the value.
4174 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4181 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4182 o = cLISTOPo->op_first->op_sibling;
4184 for (; o; o = o->op_next) {
4185 const OPCODE type = o->op_type;
4187 if (sv && o->op_next == o)
4189 if (o->op_next != o) {
4190 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4192 if (type == OP_DBSTATE)
4195 if (type == OP_LEAVESUB || type == OP_RETURN)
4199 if (type == OP_CONST && cSVOPo->op_sv)
4201 else if (cv && type == OP_CONST) {
4202 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4206 else if (cv && type == OP_PADSV) {
4207 if (CvCONST(cv)) { /* newly cloned anon */
4208 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4209 /* the candidate should have 1 ref from this pad and 1 ref
4210 * from the parent */
4211 if (!sv || SvREFCNT(sv) != 2)
4218 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4219 sv = &PL_sv_undef; /* an arbitrary non-null value */
4230 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4232 PERL_UNUSED_ARG(floor);
4242 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4246 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4248 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4252 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4263 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4266 assert(proto->op_type == OP_CONST);
4267 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4272 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4273 SV * const sv = sv_newmortal();
4274 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4275 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4276 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4277 aname = SvPVX_const(sv);
4282 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4283 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4284 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4285 : gv_fetchpv(aname ? aname
4286 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4287 gv_fetch_flags, SVt_PVCV);
4296 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4297 maximum a prototype before. */
4298 if (SvTYPE(gv) > SVt_NULL) {
4299 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4300 && ckWARN_d(WARN_PROTOTYPE))
4302 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4304 cv_ckproto((CV*)gv, NULL, ps);
4307 sv_setpvn((SV*)gv, ps, ps_len);
4309 sv_setiv((SV*)gv, -1);
4310 SvREFCNT_dec(PL_compcv);
4311 cv = PL_compcv = NULL;
4312 PL_sub_generation++;
4316 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4318 #ifdef GV_UNIQUE_CHECK
4319 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4320 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4324 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4327 const_sv = op_const_sv(block, Nullcv);
4330 const bool exists = CvROOT(cv) || CvXSUB(cv);
4332 #ifdef GV_UNIQUE_CHECK
4333 if (exists && GvUNIQUE(gv)) {
4334 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4338 /* if the subroutine doesn't exist and wasn't pre-declared
4339 * with a prototype, assume it will be AUTOLOADed,
4340 * skipping the prototype check
4342 if (exists || SvPOK(cv))
4343 cv_ckproto(cv, gv, ps);
4344 /* already defined (or promised)? */
4345 if (exists || GvASSUMECV(gv)) {
4346 if (!block && !attrs) {
4347 if (CvFLAGS(PL_compcv)) {
4348 /* might have had built-in attrs applied */
4349 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4351 /* just a "sub foo;" when &foo is already defined */
4352 SAVEFREESV(PL_compcv);
4355 /* ahem, death to those who redefine active sort subs */
4356 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4357 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4359 if (ckWARN(WARN_REDEFINE)
4361 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4363 const line_t oldline = CopLINE(PL_curcop);
4364 if (PL_copline != NOLINE)
4365 CopLINE_set(PL_curcop, PL_copline);
4366 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4367 CvCONST(cv) ? "Constant subroutine %s redefined"
4368 : "Subroutine %s redefined", name);
4369 CopLINE_set(PL_curcop, oldline);
4377 (void)SvREFCNT_inc(const_sv);
4379 assert(!CvROOT(cv) && !CvCONST(cv));
4380 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4381 CvXSUBANY(cv).any_ptr = const_sv;
4382 CvXSUB(cv) = const_sv_xsub;
4387 cv = newCONSTSUB(NULL, name, const_sv);
4390 SvREFCNT_dec(PL_compcv);
4392 PL_sub_generation++;
4399 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4400 * before we clobber PL_compcv.
4404 /* Might have had built-in attributes applied -- propagate them. */
4405 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4406 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4407 stash = GvSTASH(CvGV(cv));
4408 else if (CvSTASH(cv))
4409 stash = CvSTASH(cv);
4411 stash = PL_curstash;
4414 /* possibly about to re-define existing subr -- ignore old cv */
4415 rcv = (SV*)PL_compcv;
4416 if (name && GvSTASH(gv))
4417 stash = GvSTASH(gv);
4419 stash = PL_curstash;
4421 apply_attrs(stash, rcv, attrs, FALSE);
4423 if (cv) { /* must reuse cv if autoloaded */
4425 /* got here with just attrs -- work done, so bug out */
4426 SAVEFREESV(PL_compcv);
4429 /* transfer PL_compcv to cv */
4431 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4432 if (!CvWEAKOUTSIDE(cv))
4433 SvREFCNT_dec(CvOUTSIDE(cv));
4434 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4435 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4436 CvOUTSIDE(PL_compcv) = 0;
4437 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4438 CvPADLIST(PL_compcv) = 0;
4439 /* inner references to PL_compcv must be fixed up ... */
4440 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4441 /* ... before we throw it away */
4442 SvREFCNT_dec(PL_compcv);
4444 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4445 ++PL_sub_generation;
4452 PL_sub_generation++;
4456 CvFILE_set_from_cop(cv, PL_curcop);
4457 CvSTASH(cv) = PL_curstash;
4460 sv_setpvn((SV*)cv, ps, ps_len);
4462 if (PL_error_count) {
4466 const char *s = strrchr(name, ':');
4468 if (strEQ(s, "BEGIN")) {
4469 const char not_safe[] =
4470 "BEGIN not safe after errors--compilation aborted";
4471 if (PL_in_eval & EVAL_KEEPERR)
4472 Perl_croak(aTHX_ not_safe);
4474 /* force display of errors found but not reported */
4475 sv_catpv(ERRSV, not_safe);
4476 Perl_croak(aTHX_ "%"SVf, ERRSV);
4485 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4486 mod(scalarseq(block), OP_LEAVESUBLV));
4489 /* This makes sub {}; work as expected. */
4490 if (block->op_type == OP_STUB) {
4492 block = newSTATEOP(0, Nullch, 0);
4494 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4496 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4497 OpREFCNT_set(CvROOT(cv), 1);
4498 CvSTART(cv) = LINKLIST(CvROOT(cv));
4499 CvROOT(cv)->op_next = 0;
4500 CALL_PEEP(CvSTART(cv));
4502 /* now that optimizer has done its work, adjust pad values */
4504 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4507 assert(!CvCONST(cv));
4508 if (ps && !*ps && op_const_sv(block, cv))
4512 if (name || aname) {
4514 const char *tname = (name ? name : aname);
4516 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4517 SV *sv = NEWSV(0,0);
4518 SV *tmpstr = sv_newmortal();
4519 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4522 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4524 (long)PL_subline, (long)CopLINE(PL_curcop));
4525 gv_efullname3(tmpstr, gv, Nullch);
4526 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4527 hv = GvHVn(db_postponed);
4528 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4529 CV * const pcv = GvCV(db_postponed);
4535 call_sv((SV*)pcv, G_DISCARD);
4540 if ((s = strrchr(tname,':')))
4545 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4548 if (strEQ(s, "BEGIN") && !PL_error_count) {
4549 const I32 oldscope = PL_scopestack_ix;
4551 SAVECOPFILE(&PL_compiling);
4552 SAVECOPLINE(&PL_compiling);
4555 PL_beginav = newAV();
4556 DEBUG_x( dump_sub(gv) );
4557 av_push(PL_beginav, (SV*)cv);
4558 GvCV(gv) = 0; /* cv has been hijacked */
4559 call_list(oldscope, PL_beginav);
4561 PL_curcop = &PL_compiling;
4562 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4565 else if (strEQ(s, "END") && !PL_error_count) {
4568 DEBUG_x( dump_sub(gv) );
4569 av_unshift(PL_endav, 1);
4570 av_store(PL_endav, 0, (SV*)cv);
4571 GvCV(gv) = 0; /* cv has been hijacked */
4573 else if (strEQ(s, "CHECK") && !PL_error_count) {
4575 PL_checkav = 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 CHECK block");
4579 av_unshift(PL_checkav, 1);
4580 av_store(PL_checkav, 0, (SV*)cv);
4581 GvCV(gv) = 0; /* cv has been hijacked */
4583 else if (strEQ(s, "INIT") && !PL_error_count) {
4585 PL_initav = newAV();
4586 DEBUG_x( dump_sub(gv) );
4587 if (PL_main_start && ckWARN(WARN_VOID))
4588 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4589 av_push(PL_initav, (SV*)cv);
4590 GvCV(gv) = 0; /* cv has been hijacked */
4595 PL_copline = NOLINE;
4600 /* XXX unsafe for threads if eval_owner isn't held */
4602 =for apidoc newCONSTSUB
4604 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4605 eligible for inlining at compile-time.
4611 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4618 SAVECOPLINE(PL_curcop);
4619 CopLINE_set(PL_curcop, PL_copline);
4622 PL_hints &= ~HINT_BLOCK_SCOPE;
4625 SAVESPTR(PL_curstash);
4626 SAVECOPSTASH(PL_curcop);
4627 PL_curstash = stash;
4628 CopSTASH_set(PL_curcop,stash);
4631 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4632 CvXSUBANY(cv).any_ptr = sv;
4634 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4637 CopSTASH_free(PL_curcop);
4645 =for apidoc U||newXS
4647 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4653 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4655 GV * const gv = gv_fetchpv(name ? name :
4656 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4657 GV_ADDMULTI, SVt_PVCV);
4661 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4663 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4665 /* just a cached method */
4669 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4670 /* already defined (or promised) */
4671 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4672 if (ckWARN(WARN_REDEFINE)) {
4673 GV * const gvcv = CvGV(cv);
4675 HV * const stash = GvSTASH(gvcv);
4677 const char *name = HvNAME_get(stash);
4678 if ( strEQ(name,"autouse") ) {
4679 const line_t oldline = CopLINE(PL_curcop);
4680 if (PL_copline != NOLINE)
4681 CopLINE_set(PL_curcop, PL_copline);
4682 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4683 CvCONST(cv) ? "Constant subroutine %s redefined"
4684 : "Subroutine %s redefined"
4686 CopLINE_set(PL_curcop, oldline);
4696 if (cv) /* must reuse cv if autoloaded */
4699 cv = (CV*)NEWSV(1105,0);
4700 sv_upgrade((SV *)cv, SVt_PVCV);
4704 PL_sub_generation++;
4708 (void)gv_fetchfile(filename);
4709 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4710 an external constant string */
4711 CvXSUB(cv) = subaddr;
4714 const char *s = strrchr(name,':');
4720 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4723 if (strEQ(s, "BEGIN")) {
4725 PL_beginav = newAV();
4726 av_push(PL_beginav, (SV*)cv);
4727 GvCV(gv) = 0; /* cv has been hijacked */
4729 else if (strEQ(s, "END")) {
4732 av_unshift(PL_endav, 1);
4733 av_store(PL_endav, 0, (SV*)cv);
4734 GvCV(gv) = 0; /* cv has been hijacked */
4736 else if (strEQ(s, "CHECK")) {
4738 PL_checkav = newAV();
4739 if (PL_main_start && ckWARN(WARN_VOID))
4740 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4741 av_unshift(PL_checkav, 1);
4742 av_store(PL_checkav, 0, (SV*)cv);
4743 GvCV(gv) = 0; /* cv has been hijacked */
4745 else if (strEQ(s, "INIT")) {
4747 PL_initav = newAV();
4748 if (PL_main_start && ckWARN(WARN_VOID))
4749 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4750 av_push(PL_initav, (SV*)cv);
4751 GvCV(gv) = 0; /* cv has been hijacked */
4762 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4768 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4770 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4772 #ifdef GV_UNIQUE_CHECK
4774 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4778 if ((cv = GvFORM(gv))) {
4779 if (ckWARN(WARN_REDEFINE)) {
4780 const line_t oldline = CopLINE(PL_curcop);
4781 if (PL_copline != NOLINE)
4782 CopLINE_set(PL_curcop, PL_copline);
4783 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4784 o ? "Format %"SVf" redefined"
4785 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4786 CopLINE_set(PL_curcop, oldline);
4793 CvFILE_set_from_cop(cv, PL_curcop);
4796 pad_tidy(padtidy_FORMAT);
4797 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4798 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4799 OpREFCNT_set(CvROOT(cv), 1);
4800 CvSTART(cv) = LINKLIST(CvROOT(cv));
4801 CvROOT(cv)->op_next = 0;
4802 CALL_PEEP(CvSTART(cv));
4804 PL_copline = NOLINE;
4809 Perl_newANONLIST(pTHX_ OP *o)
4811 return newUNOP(OP_REFGEN, 0,
4812 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4816 Perl_newANONHASH(pTHX_ OP *o)
4818 return newUNOP(OP_REFGEN, 0,
4819 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4823 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4825 return newANONATTRSUB(floor, proto, Nullop, block);
4829 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4831 return newUNOP(OP_REFGEN, 0,
4832 newSVOP(OP_ANONCODE, 0,
4833 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4837 Perl_oopsAV(pTHX_ OP *o)
4840 switch (o->op_type) {
4842 o->op_type = OP_PADAV;
4843 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4844 return ref(o, OP_RV2AV);
4847 o->op_type = OP_RV2AV;
4848 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4853 if (ckWARN_d(WARN_INTERNAL))
4854 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4861 Perl_oopsHV(pTHX_ OP *o)
4864 switch (o->op_type) {
4867 o->op_type = OP_PADHV;
4868 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4869 return ref(o, OP_RV2HV);
4873 o->op_type = OP_RV2HV;
4874 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4879 if (ckWARN_d(WARN_INTERNAL))
4880 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4887 Perl_newAVREF(pTHX_ OP *o)
4890 if (o->op_type == OP_PADANY) {
4891 o->op_type = OP_PADAV;
4892 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4895 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4896 && ckWARN(WARN_DEPRECATED)) {
4897 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4898 "Using an array as a reference is deprecated");
4900 return newUNOP(OP_RV2AV, 0, scalar(o));
4904 Perl_newGVREF(pTHX_ I32 type, OP *o)
4906 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4907 return newUNOP(OP_NULL, 0, o);
4908 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4912 Perl_newHVREF(pTHX_ OP *o)
4915 if (o->op_type == OP_PADANY) {
4916 o->op_type = OP_PADHV;
4917 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4920 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4921 && ckWARN(WARN_DEPRECATED)) {
4922 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4923 "Using a hash as a reference is deprecated");
4925 return newUNOP(OP_RV2HV, 0, scalar(o));
4929 Perl_oopsCV(pTHX_ OP *o)
4931 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4934 NORETURN_FUNCTION_END;
4938 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4940 return newUNOP(OP_RV2CV, flags, scalar(o));
4944 Perl_newSVREF(pTHX_ OP *o)
4947 if (o->op_type == OP_PADANY) {
4948 o->op_type = OP_PADSV;
4949 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4952 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4953 o->op_flags |= OPpDONE_SVREF;
4956 return newUNOP(OP_RV2SV, 0, scalar(o));
4959 /* Check routines. See the comments at the top of this file for details
4960 * on when these are called */
4963 Perl_ck_anoncode(pTHX_ OP *o)
4965 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4966 cSVOPo->op_sv = Nullsv;
4971 Perl_ck_bitop(pTHX_ OP *o)
4973 #define OP_IS_NUMCOMPARE(op) \
4974 ((op) == OP_LT || (op) == OP_I_LT || \
4975 (op) == OP_GT || (op) == OP_I_GT || \
4976 (op) == OP_LE || (op) == OP_I_LE || \
4977 (op) == OP_GE || (op) == OP_I_GE || \
4978 (op) == OP_EQ || (op) == OP_I_EQ || \
4979 (op) == OP_NE || (op) == OP_I_NE || \
4980 (op) == OP_NCMP || (op) == OP_I_NCMP)
4981 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4982 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4983 && (o->op_type == OP_BIT_OR
4984 || o->op_type == OP_BIT_AND
4985 || o->op_type == OP_BIT_XOR))
4987 const OP * const left = cBINOPo->op_first;
4988 const OP * const right = left->op_sibling;
4989 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4990 (left->op_flags & OPf_PARENS) == 0) ||
4991 (OP_IS_NUMCOMPARE(right->op_type) &&
4992 (right->op_flags & OPf_PARENS) == 0))
4993 if (ckWARN(WARN_PRECEDENCE))
4994 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4995 "Possible precedence problem on bitwise %c operator",
4996 o->op_type == OP_BIT_OR ? '|'
4997 : o->op_type == OP_BIT_AND ? '&' : '^'
5004 Perl_ck_concat(pTHX_ OP *o)
5006 const OP *kid = cUNOPo->op_first;
5007 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5008 !(kUNOP->op_first->op_flags & OPf_MOD))
5009 o->op_flags |= OPf_STACKED;
5014 Perl_ck_spair(pTHX_ OP *o)
5017 if (o->op_flags & OPf_KIDS) {
5020 const OPCODE type = o->op_type;
5021 o = modkids(ck_fun(o), type);
5022 kid = cUNOPo->op_first;
5023 newop = kUNOP->op_first->op_sibling;
5025 (newop->op_sibling ||
5026 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5027 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5028 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5032 op_free(kUNOP->op_first);
5033 kUNOP->op_first = newop;
5035 o->op_ppaddr = PL_ppaddr[++o->op_type];
5040 Perl_ck_delete(pTHX_ OP *o)
5044 if (o->op_flags & OPf_KIDS) {
5045 OP * const kid = cUNOPo->op_first;
5046 switch (kid->op_type) {
5048 o->op_flags |= OPf_SPECIAL;
5051 o->op_private |= OPpSLICE;
5054 o->op_flags |= OPf_SPECIAL;
5059 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5068 Perl_ck_die(pTHX_ OP *o)
5071 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5077 Perl_ck_eof(pTHX_ OP *o)
5079 const I32 type = o->op_type;
5081 if (o->op_flags & OPf_KIDS) {
5082 if (cLISTOPo->op_first->op_type == OP_STUB) {
5084 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5092 Perl_ck_eval(pTHX_ OP *o)
5095 PL_hints |= HINT_BLOCK_SCOPE;
5096 if (o->op_flags & OPf_KIDS) {
5097 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5100 o->op_flags &= ~OPf_KIDS;
5103 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5106 cUNOPo->op_first = 0;
5109 NewOp(1101, enter, 1, LOGOP);
5110 enter->op_type = OP_ENTERTRY;
5111 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5112 enter->op_private = 0;
5114 /* establish postfix order */
5115 enter->op_next = (OP*)enter;
5117 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5118 o->op_type = OP_LEAVETRY;
5119 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5120 enter->op_other = o;
5130 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5132 o->op_targ = (PADOFFSET)PL_hints;
5137 Perl_ck_exit(pTHX_ OP *o)
5140 HV * const table = GvHV(PL_hintgv);
5142 SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5143 if (svp && *svp && SvTRUE(*svp))
5144 o->op_private |= OPpEXIT_VMSISH;
5146 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5152 Perl_ck_exec(pTHX_ OP *o)
5154 if (o->op_flags & OPf_STACKED) {
5157 kid = cUNOPo->op_first->op_sibling;
5158 if (kid->op_type == OP_RV2GV)
5167 Perl_ck_exists(pTHX_ OP *o)
5170 if (o->op_flags & OPf_KIDS) {
5171 OP * const kid = cUNOPo->op_first;
5172 if (kid->op_type == OP_ENTERSUB) {
5173 (void) ref(kid, o->op_type);
5174 if (kid->op_type != OP_RV2CV && !PL_error_count)
5175 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5177 o->op_private |= OPpEXISTS_SUB;
5179 else if (kid->op_type == OP_AELEM)
5180 o->op_flags |= OPf_SPECIAL;
5181 else if (kid->op_type != OP_HELEM)
5182 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5190 Perl_ck_rvconst(pTHX_ register OP *o)
5193 SVOP *kid = (SVOP*)cUNOPo->op_first;
5195 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5196 if (kid->op_type == OP_CONST) {
5199 SV * const kidsv = kid->op_sv;
5201 /* Is it a constant from cv_const_sv()? */
5202 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5203 SV *rsv = SvRV(kidsv);
5204 const int svtype = SvTYPE(rsv);
5205 const char *badtype = Nullch;
5207 switch (o->op_type) {
5209 if (svtype > SVt_PVMG)
5210 badtype = "a SCALAR";
5213 if (svtype != SVt_PVAV)
5214 badtype = "an ARRAY";
5217 if (svtype != SVt_PVHV)
5221 if (svtype != SVt_PVCV)
5226 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5229 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5230 const char *badthing = Nullch;
5231 switch (o->op_type) {
5233 badthing = "a SCALAR";
5236 badthing = "an ARRAY";
5239 badthing = "a HASH";
5244 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5248 * This is a little tricky. We only want to add the symbol if we
5249 * didn't add it in the lexer. Otherwise we get duplicate strict
5250 * warnings. But if we didn't add it in the lexer, we must at
5251 * least pretend like we wanted to add it even if it existed before,
5252 * or we get possible typo warnings. OPpCONST_ENTERED says
5253 * whether the lexer already added THIS instance of this symbol.
5255 iscv = (o->op_type == OP_RV2CV) * 2;
5257 gv = gv_fetchsv(kidsv,
5258 iscv | !(kid->op_private & OPpCONST_ENTERED),
5261 : o->op_type == OP_RV2SV
5263 : o->op_type == OP_RV2AV
5265 : o->op_type == OP_RV2HV
5268 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5270 kid->op_type = OP_GV;
5271 SvREFCNT_dec(kid->op_sv);
5273 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5274 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5275 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5277 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5279 kid->op_sv = SvREFCNT_inc(gv);
5281 kid->op_private = 0;
5282 kid->op_ppaddr = PL_ppaddr[OP_GV];
5289 Perl_ck_ftst(pTHX_ OP *o)
5292 const I32 type = o->op_type;
5294 if (o->op_flags & OPf_REF) {
5297 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5298 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5300 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5301 OP * const newop = newGVOP(type, OPf_REF,
5302 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5308 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5309 OP_IS_FILETEST_ACCESS(o))
5310 o->op_private |= OPpFT_ACCESS;
5312 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5313 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5314 o->op_private |= OPpFT_STACKED;
5318 if (type == OP_FTTTY)
5319 o = newGVOP(type, OPf_REF, PL_stdingv);
5321 o = newUNOP(type, 0, newDEFSVOP());
5327 Perl_ck_fun(pTHX_ OP *o)
5329 const int type = o->op_type;
5330 register I32 oa = PL_opargs[type] >> OASHIFT;
5332 if (o->op_flags & OPf_STACKED) {
5333 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5336 return no_fh_allowed(o);
5339 if (o->op_flags & OPf_KIDS) {
5340 OP **tokid = &cLISTOPo->op_first;
5341 register OP *kid = cLISTOPo->op_first;
5345 if (kid->op_type == OP_PUSHMARK ||
5346 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5348 tokid = &kid->op_sibling;
5349 kid = kid->op_sibling;
5351 if (!kid && PL_opargs[type] & OA_DEFGV)
5352 *tokid = kid = newDEFSVOP();
5356 sibl = kid->op_sibling;
5359 /* list seen where single (scalar) arg expected? */
5360 if (numargs == 1 && !(oa >> 4)
5361 && kid->op_type == OP_LIST && type != OP_SCALAR)
5363 return too_many_arguments(o,PL_op_desc[type]);
5376 if ((type == OP_PUSH || type == OP_UNSHIFT)
5377 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5378 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5379 "Useless use of %s with no values",
5382 if (kid->op_type == OP_CONST &&
5383 (kid->op_private & OPpCONST_BARE))
5385 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5386 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5387 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5388 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5389 "Array @%"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_RV2AV && kid->op_type != OP_PADAV)
5397 bad_type(numargs, "array", PL_op_desc[type], kid);
5401 if (kid->op_type == OP_CONST &&
5402 (kid->op_private & OPpCONST_BARE))
5404 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5405 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5406 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5407 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5408 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5409 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5412 kid->op_sibling = sibl;
5415 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5416 bad_type(numargs, "hash", PL_op_desc[type], kid);
5421 OP * const newop = newUNOP(OP_NULL, 0, kid);
5422 kid->op_sibling = 0;
5424 newop->op_next = newop;
5426 kid->op_sibling = sibl;
5431 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5432 if (kid->op_type == OP_CONST &&
5433 (kid->op_private & OPpCONST_BARE))
5435 OP *newop = newGVOP(OP_GV, 0,
5436 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5437 if (!(o->op_private & 1) && /* if not unop */
5438 kid == cLISTOPo->op_last)
5439 cLISTOPo->op_last = newop;
5443 else if (kid->op_type == OP_READLINE) {
5444 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5445 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5448 I32 flags = OPf_SPECIAL;
5452 /* is this op a FH constructor? */
5453 if (is_handle_constructor(o,numargs)) {
5454 const char *name = Nullch;
5458 /* Set a flag to tell rv2gv to vivify
5459 * need to "prove" flag does not mean something
5460 * else already - NI-S 1999/05/07
5463 if (kid->op_type == OP_PADSV) {
5464 name = PAD_COMPNAME_PV(kid->op_targ);
5465 /* SvCUR of a pad namesv can't be trusted
5466 * (see PL_generation), so calc its length
5472 else if (kid->op_type == OP_RV2SV
5473 && kUNOP->op_first->op_type == OP_GV)
5475 GV *gv = cGVOPx_gv(kUNOP->op_first);
5477 len = GvNAMELEN(gv);
5479 else if (kid->op_type == OP_AELEM
5480 || kid->op_type == OP_HELEM)
5482 OP *op = ((BINOP*)kid)->op_first;
5485 SV *tmpstr = Nullsv;
5486 const char * const a =
5487 kid->op_type == OP_AELEM ?
5489 if (((op->op_type == OP_RV2AV) ||
5490 (op->op_type == OP_RV2HV)) &&
5491 (op = ((UNOP*)op)->op_first) &&
5492 (op->op_type == OP_GV)) {
5493 /* packagevar $a[] or $h{} */
5494 GV * const gv = cGVOPx_gv(op);
5502 else if (op->op_type == OP_PADAV
5503 || op->op_type == OP_PADHV) {
5504 /* lexicalvar $a[] or $h{} */
5505 const char * const padname =
5506 PAD_COMPNAME_PV(op->op_targ);
5515 name = SvPV_const(tmpstr, len);
5520 name = "__ANONIO__";
5527 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5528 namesv = PAD_SVl(targ);
5529 SvUPGRADE(namesv, SVt_PV);
5531 sv_setpvn(namesv, "$", 1);
5532 sv_catpvn(namesv, name, len);
5535 kid->op_sibling = 0;
5536 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5537 kid->op_targ = targ;
5538 kid->op_private |= priv;
5540 kid->op_sibling = sibl;
5546 mod(scalar(kid), type);
5550 tokid = &kid->op_sibling;
5551 kid = kid->op_sibling;
5553 o->op_private |= numargs;
5555 return too_many_arguments(o,OP_DESC(o));
5558 else if (PL_opargs[type] & OA_DEFGV) {
5560 return newUNOP(type, 0, newDEFSVOP());
5564 while (oa & OA_OPTIONAL)
5566 if (oa && oa != OA_LIST)
5567 return too_few_arguments(o,OP_DESC(o));
5573 Perl_ck_glob(pTHX_ OP *o)
5579 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5580 append_elem(OP_GLOB, o, newDEFSVOP());
5582 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5583 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5585 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5588 #if !defined(PERL_EXTERNAL_GLOB)
5589 /* XXX this can be tightened up and made more failsafe. */
5590 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5593 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5594 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5595 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5596 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5597 GvCV(gv) = GvCV(glob_gv);
5598 (void)SvREFCNT_inc((SV*)GvCV(gv));
5599 GvIMPORTED_CV_on(gv);
5602 #endif /* PERL_EXTERNAL_GLOB */
5604 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5605 append_elem(OP_GLOB, o,
5606 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5607 o->op_type = OP_LIST;
5608 o->op_ppaddr = PL_ppaddr[OP_LIST];
5609 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5610 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5611 cLISTOPo->op_first->op_targ = 0;
5612 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5613 append_elem(OP_LIST, o,
5614 scalar(newUNOP(OP_RV2CV, 0,
5615 newGVOP(OP_GV, 0, gv)))));
5616 o = newUNOP(OP_NULL, 0, ck_subr(o));
5617 o->op_targ = OP_GLOB; /* hint at what it used to be */
5620 gv = newGVgen("main");
5622 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5628 Perl_ck_grep(pTHX_ OP *o)
5633 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5636 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5637 NewOp(1101, gwop, 1, LOGOP);
5639 if (o->op_flags & OPf_STACKED) {
5642 kid = cLISTOPo->op_first->op_sibling;
5643 if (!cUNOPx(kid)->op_next)
5644 Perl_croak(aTHX_ "panic: ck_grep");
5645 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5648 kid->op_next = (OP*)gwop;
5649 o->op_flags &= ~OPf_STACKED;
5651 kid = cLISTOPo->op_first->op_sibling;
5652 if (type == OP_MAPWHILE)
5659 kid = cLISTOPo->op_first->op_sibling;
5660 if (kid->op_type != OP_NULL)
5661 Perl_croak(aTHX_ "panic: ck_grep");
5662 kid = kUNOP->op_first;
5664 gwop->op_type = type;
5665 gwop->op_ppaddr = PL_ppaddr[type];
5666 gwop->op_first = listkids(o);
5667 gwop->op_flags |= OPf_KIDS;
5668 gwop->op_other = LINKLIST(kid);
5669 kid->op_next = (OP*)gwop;
5670 offset = pad_findmy("$_");
5671 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5672 o->op_private = gwop->op_private = 0;
5673 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5676 o->op_private = gwop->op_private = OPpGREP_LEX;
5677 gwop->op_targ = o->op_targ = offset;
5680 kid = cLISTOPo->op_first->op_sibling;
5681 if (!kid || !kid->op_sibling)
5682 return too_few_arguments(o,OP_DESC(o));
5683 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5684 mod(kid, OP_GREPSTART);
5690 Perl_ck_index(pTHX_ OP *o)
5692 if (o->op_flags & OPf_KIDS) {
5693 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5695 kid = kid->op_sibling; /* get past "big" */
5696 if (kid && kid->op_type == OP_CONST)
5697 fbm_compile(((SVOP*)kid)->op_sv, 0);
5703 Perl_ck_lengthconst(pTHX_ OP *o)
5705 /* XXX length optimization goes here */
5710 Perl_ck_lfun(pTHX_ OP *o)
5712 const OPCODE type = o->op_type;
5713 return modkids(ck_fun(o), type);
5717 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5719 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5720 switch (cUNOPo->op_first->op_type) {
5722 /* This is needed for
5723 if (defined %stash::)
5724 to work. Do not break Tk.
5726 break; /* Globals via GV can be undef */
5728 case OP_AASSIGN: /* Is this a good idea? */
5729 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5730 "defined(@array) is deprecated");
5731 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5732 "\t(Maybe you should just omit the defined()?)\n");
5735 /* This is needed for
5736 if (defined %stash::)
5737 to work. Do not break Tk.
5739 break; /* Globals via GV can be undef */
5741 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5742 "defined(%%hash) is deprecated");
5743 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5744 "\t(Maybe you should just omit the defined()?)\n");
5755 Perl_ck_rfun(pTHX_ OP *o)
5757 const OPCODE type = o->op_type;
5758 return refkids(ck_fun(o), type);
5762 Perl_ck_listiob(pTHX_ OP *o)
5766 kid = cLISTOPo->op_first;
5769 kid = cLISTOPo->op_first;
5771 if (kid->op_type == OP_PUSHMARK)
5772 kid = kid->op_sibling;
5773 if (kid && o->op_flags & OPf_STACKED)
5774 kid = kid->op_sibling;
5775 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5776 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5777 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5778 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5779 cLISTOPo->op_first->op_sibling = kid;
5780 cLISTOPo->op_last = kid;
5781 kid = kid->op_sibling;
5786 append_elem(o->op_type, o, newDEFSVOP());
5792 Perl_ck_sassign(pTHX_ OP *o)
5794 OP *kid = cLISTOPo->op_first;
5795 /* has a disposable target? */
5796 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5797 && !(kid->op_flags & OPf_STACKED)
5798 /* Cannot steal the second time! */
5799 && !(kid->op_private & OPpTARGET_MY))
5801 OP * const kkid = kid->op_sibling;
5803 /* Can just relocate the target. */
5804 if (kkid && kkid->op_type == OP_PADSV
5805 && !(kkid->op_private & OPpLVAL_INTRO))
5807 kid->op_targ = kkid->op_targ;
5809 /* Now we do not need PADSV and SASSIGN. */
5810 kid->op_sibling = o->op_sibling; /* NULL */
5811 cLISTOPo->op_first = NULL;
5814 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5818 /* optimise C<my $x = undef> to C<my $x> */
5819 if (kid->op_type == OP_UNDEF) {
5820 OP * const kkid = kid->op_sibling;
5821 if (kkid && kkid->op_type == OP_PADSV
5822 && (kkid->op_private & OPpLVAL_INTRO))
5824 cLISTOPo->op_first = NULL;
5825 kid->op_sibling = NULL;
5835 Perl_ck_match(pTHX_ OP *o)
5837 if (o->op_type != OP_QR) {
5838 const I32 offset = pad_findmy("$_");
5839 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5840 o->op_targ = offset;
5841 o->op_private |= OPpTARGET_MY;
5844 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5845 o->op_private |= OPpRUNTIME;
5850 Perl_ck_method(pTHX_ OP *o)
5852 OP * const kid = cUNOPo->op_first;
5853 if (kid->op_type == OP_CONST) {
5854 SV* sv = kSVOP->op_sv;
5855 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5857 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5858 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5861 kSVOP->op_sv = Nullsv;
5863 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5872 Perl_ck_null(pTHX_ OP *o)
5878 Perl_ck_open(pTHX_ OP *o)
5880 HV * const table = GvHV(PL_hintgv);
5882 SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
5884 const I32 mode = mode_from_discipline(*svp);
5885 if (mode & O_BINARY)
5886 o->op_private |= OPpOPEN_IN_RAW;
5887 else if (mode & O_TEXT)
5888 o->op_private |= OPpOPEN_IN_CRLF;
5891 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5893 const I32 mode = mode_from_discipline(*svp);
5894 if (mode & O_BINARY)
5895 o->op_private |= OPpOPEN_OUT_RAW;
5896 else if (mode & O_TEXT)
5897 o->op_private |= OPpOPEN_OUT_CRLF;
5900 if (o->op_type == OP_BACKTICK)
5903 /* In case of three-arg dup open remove strictness
5904 * from the last arg if it is a bareword. */
5905 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
5906 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
5910 if ((last->op_type == OP_CONST) && /* The bareword. */
5911 (last->op_private & OPpCONST_BARE) &&
5912 (last->op_private & OPpCONST_STRICT) &&
5913 (oa = first->op_sibling) && /* The fh. */
5914 (oa = oa->op_sibling) && /* The mode. */
5915 (oa->op_type == OP_CONST) &&
5916 SvPOK(((SVOP*)oa)->op_sv) &&
5917 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5918 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5919 (last == oa->op_sibling)) /* The bareword. */
5920 last->op_private &= ~OPpCONST_STRICT;
5926 Perl_ck_repeat(pTHX_ OP *o)
5928 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5929 o->op_private |= OPpREPEAT_DOLIST;
5930 cBINOPo->op_first = force_list(cBINOPo->op_first);
5938 Perl_ck_require(pTHX_ OP *o)
5942 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5943 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5945 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5946 SV * const sv = kid->op_sv;
5947 U32 was_readonly = SvREADONLY(sv);
5952 sv_force_normal_flags(sv, 0);
5953 assert(!SvREADONLY(sv));
5960 for (s = SvPVX(sv); *s; s++) {
5961 if (*s == ':' && s[1] == ':') {
5963 Move(s+2, s+1, strlen(s+2)+1, char);
5964 SvCUR_set(sv, SvCUR(sv) - 1);
5967 sv_catpvn(sv, ".pm", 3);
5968 SvFLAGS(sv) |= was_readonly;
5972 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
5973 /* handle override, if any */
5974 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5975 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5976 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
5977 gv = gvp ? *gvp : Nullgv;
5981 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5982 OP * const kid = cUNOPo->op_first;
5983 cUNOPo->op_first = 0;
5985 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5986 append_elem(OP_LIST, kid,
5987 scalar(newUNOP(OP_RV2CV, 0,
5996 Perl_ck_return(pTHX_ OP *o)
5998 if (CvLVALUE(PL_compcv)) {
6000 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6001 mod(kid, OP_LEAVESUBLV);
6008 Perl_ck_retarget(pTHX_ OP *o)
6010 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6017 Perl_ck_select(pTHX_ OP *o)
6021 if (o->op_flags & OPf_KIDS) {
6022 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6023 if (kid && kid->op_sibling) {
6024 o->op_type = OP_SSELECT;
6025 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6027 return fold_constants(o);
6031 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6032 if (kid && kid->op_type == OP_RV2GV)
6033 kid->op_private &= ~HINT_STRICT_REFS;
6038 Perl_ck_shift(pTHX_ OP *o)
6040 const I32 type = o->op_type;
6042 if (!(o->op_flags & OPf_KIDS)) {
6046 argop = newUNOP(OP_RV2AV, 0,
6047 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6048 return newUNOP(type, 0, scalar(argop));
6050 return scalar(modkids(ck_fun(o), type));
6054 Perl_ck_sort(pTHX_ OP *o)
6058 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6060 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6061 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6063 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6065 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6067 if (kid->op_type == OP_SCOPE) {
6071 else if (kid->op_type == OP_LEAVE) {
6072 if (o->op_type == OP_SORT) {
6073 op_null(kid); /* wipe out leave */
6076 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6077 if (k->op_next == kid)
6079 /* don't descend into loops */
6080 else if (k->op_type == OP_ENTERLOOP
6081 || k->op_type == OP_ENTERITER)
6083 k = cLOOPx(k)->op_lastop;
6088 kid->op_next = 0; /* just disconnect the leave */
6089 k = kLISTOP->op_first;
6094 if (o->op_type == OP_SORT) {
6095 /* provide scalar context for comparison function/block */
6101 o->op_flags |= OPf_SPECIAL;
6103 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6106 firstkid = firstkid->op_sibling;
6109 /* provide list context for arguments */
6110 if (o->op_type == OP_SORT)
6117 S_simplify_sort(pTHX_ OP *o)
6119 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6124 if (!(o->op_flags & OPf_STACKED))
6126 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6127 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6128 kid = kUNOP->op_first; /* get past null */
6129 if (kid->op_type != OP_SCOPE)
6131 kid = kLISTOP->op_last; /* get past scope */
6132 switch(kid->op_type) {
6140 k = kid; /* remember this node*/
6141 if (kBINOP->op_first->op_type != OP_RV2SV)
6143 kid = kBINOP->op_first; /* get past cmp */
6144 if (kUNOP->op_first->op_type != OP_GV)
6146 kid = kUNOP->op_first; /* get past rv2sv */
6148 if (GvSTASH(gv) != PL_curstash)
6150 gvname = GvNAME(gv);
6151 if (*gvname == 'a' && gvname[1] == '\0')
6153 else if (*gvname == 'b' && gvname[1] == '\0')
6158 kid = k; /* back to cmp */
6159 if (kBINOP->op_last->op_type != OP_RV2SV)
6161 kid = kBINOP->op_last; /* down to 2nd arg */
6162 if (kUNOP->op_first->op_type != OP_GV)
6164 kid = kUNOP->op_first; /* get past rv2sv */
6166 if (GvSTASH(gv) != PL_curstash)
6168 gvname = GvNAME(gv);
6170 ? !(*gvname == 'a' && gvname[1] == '\0')
6171 : !(*gvname == 'b' && gvname[1] == '\0'))
6173 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6175 o->op_private |= OPpSORT_DESCEND;
6176 if (k->op_type == OP_NCMP)
6177 o->op_private |= OPpSORT_NUMERIC;
6178 if (k->op_type == OP_I_NCMP)
6179 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6180 kid = cLISTOPo->op_first->op_sibling;
6181 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6182 op_free(kid); /* then delete it */
6186 Perl_ck_split(pTHX_ OP *o)
6191 if (o->op_flags & OPf_STACKED)
6192 return no_fh_allowed(o);
6194 kid = cLISTOPo->op_first;
6195 if (kid->op_type != OP_NULL)
6196 Perl_croak(aTHX_ "panic: ck_split");
6197 kid = kid->op_sibling;
6198 op_free(cLISTOPo->op_first);
6199 cLISTOPo->op_first = kid;
6201 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6202 cLISTOPo->op_last = kid; /* There was only one element previously */
6205 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6206 OP * const sibl = kid->op_sibling;
6207 kid->op_sibling = 0;
6208 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6209 if (cLISTOPo->op_first == cLISTOPo->op_last)
6210 cLISTOPo->op_last = kid;
6211 cLISTOPo->op_first = kid;
6212 kid->op_sibling = sibl;
6215 kid->op_type = OP_PUSHRE;
6216 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6218 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6219 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6220 "Use of /g modifier is meaningless in split");
6223 if (!kid->op_sibling)
6224 append_elem(OP_SPLIT, o, newDEFSVOP());
6226 kid = kid->op_sibling;
6229 if (!kid->op_sibling)
6230 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6232 kid = kid->op_sibling;
6235 if (kid->op_sibling)
6236 return too_many_arguments(o,OP_DESC(o));
6242 Perl_ck_join(pTHX_ OP *o)
6244 const OP * const kid = cLISTOPo->op_first->op_sibling;
6245 if (kid && kid->op_type == OP_MATCH) {
6246 if (ckWARN(WARN_SYNTAX)) {
6247 const REGEXP *re = PM_GETRE(kPMOP);
6248 const char *pmstr = re ? re->precomp : "STRING";
6249 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6250 "/%s/ should probably be written as \"%s\"",
6258 Perl_ck_subr(pTHX_ OP *o)
6260 OP *prev = ((cUNOPo->op_first->op_sibling)
6261 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6262 OP *o2 = prev->op_sibling;
6269 I32 contextclass = 0;
6273 o->op_private |= OPpENTERSUB_HASTARG;
6274 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6275 if (cvop->op_type == OP_RV2CV) {
6277 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6278 op_null(cvop); /* disable rv2cv */
6279 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6280 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6281 GV *gv = cGVOPx_gv(tmpop);
6284 tmpop->op_private |= OPpEARLY_CV;
6287 namegv = CvANON(cv) ? gv : CvGV(cv);
6288 proto = SvPV_nolen((SV*)cv);
6290 if (CvASSERTION(cv)) {
6291 if (PL_hints & HINT_ASSERTING) {
6292 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6293 o->op_private |= OPpENTERSUB_DB;
6297 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6298 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6299 "Impossible to activate assertion call");
6306 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6307 if (o2->op_type == OP_CONST)
6308 o2->op_private &= ~OPpCONST_STRICT;
6309 else if (o2->op_type == OP_LIST) {
6310 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6311 if (o && o->op_type == OP_CONST)
6312 o->op_private &= ~OPpCONST_STRICT;
6315 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6316 if (PERLDB_SUB && PL_curstash != PL_debstash)
6317 o->op_private |= OPpENTERSUB_DB;
6318 while (o2 != cvop) {
6322 return too_many_arguments(o, gv_ename(namegv));
6340 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6342 arg == 1 ? "block or sub {}" : "sub {}",
6343 gv_ename(namegv), o2);
6346 /* '*' allows any scalar type, including bareword */
6349 if (o2->op_type == OP_RV2GV)
6350 goto wrapref; /* autoconvert GLOB -> GLOBref */
6351 else if (o2->op_type == OP_CONST)
6352 o2->op_private &= ~OPpCONST_STRICT;
6353 else if (o2->op_type == OP_ENTERSUB) {
6354 /* accidental subroutine, revert to bareword */
6355 OP *gvop = ((UNOP*)o2)->op_first;
6356 if (gvop && gvop->op_type == OP_NULL) {
6357 gvop = ((UNOP*)gvop)->op_first;
6359 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6362 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6363 (gvop = ((UNOP*)gvop)->op_first) &&
6364 gvop->op_type == OP_GV)
6366 GV * const gv = cGVOPx_gv(gvop);
6367 OP * const sibling = o2->op_sibling;
6368 SV * const n = newSVpvn("",0);
6370 gv_fullname4(n, gv, "", FALSE);
6371 o2 = newSVOP(OP_CONST, 0, n);
6372 prev->op_sibling = o2;
6373 o2->op_sibling = sibling;
6389 if (contextclass++ == 0) {
6390 e = strchr(proto, ']');
6391 if (!e || e == proto)
6404 while (*--p != '[');
6405 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6406 gv_ename(namegv), o2);
6412 if (o2->op_type == OP_RV2GV)
6415 bad_type(arg, "symbol", gv_ename(namegv), o2);
6418 if (o2->op_type == OP_ENTERSUB)
6421 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6424 if (o2->op_type == OP_RV2SV ||
6425 o2->op_type == OP_PADSV ||
6426 o2->op_type == OP_HELEM ||
6427 o2->op_type == OP_AELEM ||
6428 o2->op_type == OP_THREADSV)
6431 bad_type(arg, "scalar", gv_ename(namegv), o2);
6434 if (o2->op_type == OP_RV2AV ||
6435 o2->op_type == OP_PADAV)
6438 bad_type(arg, "array", gv_ename(namegv), o2);
6441 if (o2->op_type == OP_RV2HV ||
6442 o2->op_type == OP_PADHV)
6445 bad_type(arg, "hash", gv_ename(namegv), o2);
6450 OP* const sib = kid->op_sibling;
6451 kid->op_sibling = 0;
6452 o2 = newUNOP(OP_REFGEN, 0, kid);
6453 o2->op_sibling = sib;
6454 prev->op_sibling = o2;
6456 if (contextclass && e) {
6471 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6472 gv_ename(namegv), cv);
6477 mod(o2, OP_ENTERSUB);
6479 o2 = o2->op_sibling;
6481 if (proto && !optional &&
6482 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6483 return too_few_arguments(o, gv_ename(namegv));
6486 o=newSVOP(OP_CONST, 0, newSViv(0));
6492 Perl_ck_svconst(pTHX_ OP *o)
6494 SvREADONLY_on(cSVOPo->op_sv);
6499 Perl_ck_trunc(pTHX_ OP *o)
6501 if (o->op_flags & OPf_KIDS) {
6502 SVOP *kid = (SVOP*)cUNOPo->op_first;
6504 if (kid->op_type == OP_NULL)
6505 kid = (SVOP*)kid->op_sibling;
6506 if (kid && kid->op_type == OP_CONST &&
6507 (kid->op_private & OPpCONST_BARE))
6509 o->op_flags |= OPf_SPECIAL;
6510 kid->op_private &= ~OPpCONST_STRICT;
6517 Perl_ck_unpack(pTHX_ OP *o)
6519 OP *kid = cLISTOPo->op_first;
6520 if (kid->op_sibling) {
6521 kid = kid->op_sibling;
6522 if (!kid->op_sibling)
6523 kid->op_sibling = newDEFSVOP();
6529 Perl_ck_substr(pTHX_ OP *o)
6532 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6533 OP *kid = cLISTOPo->op_first;
6535 if (kid->op_type == OP_NULL)
6536 kid = kid->op_sibling;
6538 kid->op_flags |= OPf_MOD;
6544 /* A peephole optimizer. We visit the ops in the order they're to execute.
6545 * See the comments at the top of this file for more details about when
6546 * peep() is called */
6549 Perl_peep(pTHX_ register OP *o)
6552 register OP* oldop = 0;
6554 if (!o || o->op_opt)
6558 SAVEVPTR(PL_curcop);
6559 for (; o; o = o->op_next) {
6563 switch (o->op_type) {
6567 PL_curcop = ((COP*)o); /* for warnings */
6572 if (cSVOPo->op_private & OPpCONST_STRICT)
6573 no_bareword_allowed(o);
6575 case OP_METHOD_NAMED:
6576 /* Relocate sv to the pad for thread safety.
6577 * Despite being a "constant", the SV is written to,
6578 * for reference counts, sv_upgrade() etc. */
6580 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6581 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6582 /* If op_sv is already a PADTMP then it is being used by
6583 * some pad, so make a copy. */
6584 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6585 SvREADONLY_on(PAD_SVl(ix));
6586 SvREFCNT_dec(cSVOPo->op_sv);
6589 SvREFCNT_dec(PAD_SVl(ix));
6590 SvPADTMP_on(cSVOPo->op_sv);
6591 PAD_SETSV(ix, cSVOPo->op_sv);
6592 /* XXX I don't know how this isn't readonly already. */
6593 SvREADONLY_on(PAD_SVl(ix));
6595 cSVOPo->op_sv = Nullsv;
6603 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6604 if (o->op_next->op_private & OPpTARGET_MY) {
6605 if (o->op_flags & OPf_STACKED) /* chained concats */
6606 goto ignore_optimization;
6608 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6609 o->op_targ = o->op_next->op_targ;
6610 o->op_next->op_targ = 0;
6611 o->op_private |= OPpTARGET_MY;
6614 op_null(o->op_next);
6616 ignore_optimization:
6620 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6622 break; /* Scalar stub must produce undef. List stub is noop */
6626 if (o->op_targ == OP_NEXTSTATE
6627 || o->op_targ == OP_DBSTATE
6628 || o->op_targ == OP_SETSTATE)
6630 PL_curcop = ((COP*)o);
6632 /* XXX: We avoid setting op_seq here to prevent later calls
6633 to peep() from mistakenly concluding that optimisation
6634 has already occurred. This doesn't fix the real problem,
6635 though (See 20010220.007). AMS 20010719 */
6636 /* op_seq functionality is now replaced by op_opt */
6637 if (oldop && o->op_next) {
6638 oldop->op_next = o->op_next;
6646 if (oldop && o->op_next) {
6647 oldop->op_next = o->op_next;
6655 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6656 OP* pop = (o->op_type == OP_PADAV) ?
6657 o->op_next : o->op_next->op_next;
6659 if (pop && pop->op_type == OP_CONST &&
6660 ((PL_op = pop->op_next)) &&
6661 pop->op_next->op_type == OP_AELEM &&
6662 !(pop->op_next->op_private &
6663 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6664 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6669 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6670 no_bareword_allowed(pop);
6671 if (o->op_type == OP_GV)
6672 op_null(o->op_next);
6673 op_null(pop->op_next);
6675 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6676 o->op_next = pop->op_next->op_next;
6677 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6678 o->op_private = (U8)i;
6679 if (o->op_type == OP_GV) {
6684 o->op_flags |= OPf_SPECIAL;
6685 o->op_type = OP_AELEMFAST;
6691 if (o->op_next->op_type == OP_RV2SV) {
6692 if (!(o->op_next->op_private & OPpDEREF)) {
6693 op_null(o->op_next);
6694 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6696 o->op_next = o->op_next->op_next;
6697 o->op_type = OP_GVSV;
6698 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6701 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6702 GV * const gv = cGVOPo_gv;
6703 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6704 /* XXX could check prototype here instead of just carping */
6705 SV * const sv = sv_newmortal();
6706 gv_efullname3(sv, gv, Nullch);
6707 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6708 "%"SVf"() called too early to check prototype",
6712 else if (o->op_next->op_type == OP_READLINE
6713 && o->op_next->op_next->op_type == OP_CONCAT
6714 && (o->op_next->op_next->op_flags & OPf_STACKED))
6716 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6717 o->op_type = OP_RCATLINE;
6718 o->op_flags |= OPf_STACKED;
6719 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6720 op_null(o->op_next->op_next);
6721 op_null(o->op_next);
6738 while (cLOGOP->op_other->op_type == OP_NULL)
6739 cLOGOP->op_other = cLOGOP->op_other->op_next;
6740 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6746 while (cLOOP->op_redoop->op_type == OP_NULL)
6747 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6748 peep(cLOOP->op_redoop);
6749 while (cLOOP->op_nextop->op_type == OP_NULL)
6750 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6751 peep(cLOOP->op_nextop);
6752 while (cLOOP->op_lastop->op_type == OP_NULL)
6753 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6754 peep(cLOOP->op_lastop);
6761 while (cPMOP->op_pmreplstart &&
6762 cPMOP->op_pmreplstart->op_type == OP_NULL)
6763 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6764 peep(cPMOP->op_pmreplstart);
6769 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6770 && ckWARN(WARN_SYNTAX))
6772 if (o->op_next->op_sibling &&
6773 o->op_next->op_sibling->op_type != OP_EXIT &&
6774 o->op_next->op_sibling->op_type != OP_WARN &&
6775 o->op_next->op_sibling->op_type != OP_DIE) {
6776 const line_t oldline = CopLINE(PL_curcop);
6778 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6779 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6780 "Statement unlikely to be reached");
6781 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6782 "\t(Maybe you meant system() when you said exec()?)\n");
6783 CopLINE_set(PL_curcop, oldline);
6793 const char *key = NULL;
6798 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6801 /* Make the CONST have a shared SV */
6802 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6803 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6804 key = SvPV_const(sv, keylen);
6805 lexname = newSVpvn_share(key,
6806 SvUTF8(sv) ? -(I32)keylen : keylen,
6812 if ((o->op_private & (OPpLVAL_INTRO)))
6815 rop = (UNOP*)((BINOP*)o)->op_first;
6816 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6818 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6819 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6821 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6822 if (!fields || !GvHV(*fields))
6824 key = SvPV_const(*svp, keylen);
6825 if (!hv_fetch(GvHV(*fields), key,
6826 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6828 Perl_croak(aTHX_ "No such class field \"%s\" "
6829 "in variable %s of type %s",
6830 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
6843 SVOP *first_key_op, *key_op;
6845 if ((o->op_private & (OPpLVAL_INTRO))
6846 /* I bet there's always a pushmark... */
6847 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6848 /* hmmm, no optimization if list contains only one key. */
6850 rop = (UNOP*)((LISTOP*)o)->op_last;
6851 if (rop->op_type != OP_RV2HV)
6853 if (rop->op_first->op_type == OP_PADSV)
6854 /* @$hash{qw(keys here)} */
6855 rop = (UNOP*)rop->op_first;
6857 /* @{$hash}{qw(keys here)} */
6858 if (rop->op_first->op_type == OP_SCOPE
6859 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6861 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6867 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6868 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6870 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6871 if (!fields || !GvHV(*fields))
6873 /* Again guessing that the pushmark can be jumped over.... */
6874 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6875 ->op_first->op_sibling;
6876 for (key_op = first_key_op; key_op;
6877 key_op = (SVOP*)key_op->op_sibling) {
6878 if (key_op->op_type != OP_CONST)
6880 svp = cSVOPx_svp(key_op);
6881 key = SvPV_const(*svp, keylen);
6882 if (!hv_fetch(GvHV(*fields), key,
6883 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6885 Perl_croak(aTHX_ "No such class field \"%s\" "
6886 "in variable %s of type %s",
6887 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6894 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6898 /* check that RHS of sort is a single plain array */
6899 OP *oright = cUNOPo->op_first;
6900 if (!oright || oright->op_type != OP_PUSHMARK)
6903 /* reverse sort ... can be optimised. */
6904 if (!cUNOPo->op_sibling) {
6905 /* Nothing follows us on the list. */
6906 OP * const reverse = o->op_next;
6908 if (reverse->op_type == OP_REVERSE &&
6909 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6910 OP * const pushmark = cUNOPx(reverse)->op_first;
6911 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6912 && (cUNOPx(pushmark)->op_sibling == o)) {
6913 /* reverse -> pushmark -> sort */
6914 o->op_private |= OPpSORT_REVERSE;
6916 pushmark->op_next = oright->op_next;
6922 /* make @a = sort @a act in-place */
6926 oright = cUNOPx(oright)->op_sibling;
6929 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6930 oright = cUNOPx(oright)->op_sibling;
6934 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6935 || oright->op_next != o
6936 || (oright->op_private & OPpLVAL_INTRO)
6940 /* o2 follows the chain of op_nexts through the LHS of the
6941 * assign (if any) to the aassign op itself */
6943 if (!o2 || o2->op_type != OP_NULL)
6946 if (!o2 || o2->op_type != OP_PUSHMARK)
6949 if (o2 && o2->op_type == OP_GV)
6952 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6953 || (o2->op_private & OPpLVAL_INTRO)
6958 if (!o2 || o2->op_type != OP_NULL)
6961 if (!o2 || o2->op_type != OP_AASSIGN
6962 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6965 /* check that the sort is the first arg on RHS of assign */
6967 o2 = cUNOPx(o2)->op_first;
6968 if (!o2 || o2->op_type != OP_NULL)
6970 o2 = cUNOPx(o2)->op_first;
6971 if (!o2 || o2->op_type != OP_PUSHMARK)
6973 if (o2->op_sibling != o)
6976 /* check the array is the same on both sides */
6977 if (oleft->op_type == OP_RV2AV) {
6978 if (oright->op_type != OP_RV2AV
6979 || !cUNOPx(oright)->op_first
6980 || cUNOPx(oright)->op_first->op_type != OP_GV
6981 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6982 cGVOPx_gv(cUNOPx(oright)->op_first)
6986 else if (oright->op_type != OP_PADAV
6987 || oright->op_targ != oleft->op_targ
6991 /* transfer MODishness etc from LHS arg to RHS arg */
6992 oright->op_flags = oleft->op_flags;
6993 o->op_private |= OPpSORT_INPLACE;
6995 /* excise push->gv->rv2av->null->aassign */
6996 o2 = o->op_next->op_next;
6997 op_null(o2); /* PUSHMARK */
6999 if (o2->op_type == OP_GV) {
7000 op_null(o2); /* GV */
7003 op_null(o2); /* RV2AV or PADAV */
7004 o2 = o2->op_next->op_next;
7005 op_null(o2); /* AASSIGN */
7007 o->op_next = o2->op_next;
7013 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7015 LISTOP *enter, *exlist;
7018 enter = (LISTOP *) o->op_next;
7021 if (enter->op_type == OP_NULL) {
7022 enter = (LISTOP *) enter->op_next;
7026 /* for $a (...) will have OP_GV then OP_RV2GV here.
7027 for (...) just has an OP_GV. */
7028 if (enter->op_type == OP_GV) {
7029 gvop = (OP *) enter;
7030 enter = (LISTOP *) enter->op_next;
7033 if (enter->op_type == OP_RV2GV) {
7034 enter = (LISTOP *) enter->op_next;
7040 if (enter->op_type != OP_ENTERITER)
7043 iter = enter->op_next;
7044 if (!iter || iter->op_type != OP_ITER)
7047 expushmark = enter->op_first;
7048 if (!expushmark || expushmark->op_type != OP_NULL
7049 || expushmark->op_targ != OP_PUSHMARK)
7052 exlist = (LISTOP *) expushmark->op_sibling;
7053 if (!exlist || exlist->op_type != OP_NULL
7054 || exlist->op_targ != OP_LIST)
7057 if (exlist->op_last != o) {
7058 /* Mmm. Was expecting to point back to this op. */
7061 theirmark = exlist->op_first;
7062 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7065 if (theirmark->op_sibling != o) {
7066 /* There's something between the mark and the reverse, eg
7067 for (1, reverse (...))
7072 ourmark = ((LISTOP *)o)->op_first;
7073 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7076 ourlast = ((LISTOP *)o)->op_last;
7077 if (!ourlast || ourlast->op_next != o)
7080 rv2av = ourmark->op_sibling;
7081 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7082 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7083 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7084 /* We're just reversing a single array. */
7085 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7086 enter->op_flags |= OPf_STACKED;
7089 /* We don't have control over who points to theirmark, so sacrifice
7091 theirmark->op_next = ourmark->op_next;
7092 theirmark->op_flags = ourmark->op_flags;
7093 ourlast->op_next = gvop ? gvop : (OP *) enter;
7096 enter->op_private |= OPpITER_REVERSED;
7097 iter->op_private |= OPpITER_REVERSED;
7112 Perl_custom_op_name(pTHX_ const OP* o)
7114 const IV index = PTR2IV(o->op_ppaddr);
7118 if (!PL_custom_op_names) /* This probably shouldn't happen */
7119 return (char *)PL_op_name[OP_CUSTOM];
7121 keysv = sv_2mortal(newSViv(index));
7123 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7125 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7127 return SvPV_nolen(HeVAL(he));
7131 Perl_custom_op_desc(pTHX_ const OP* o)
7133 const IV index = PTR2IV(o->op_ppaddr);
7137 if (!PL_custom_op_descs)
7138 return (char *)PL_op_desc[OP_CUSTOM];
7140 keysv = sv_2mortal(newSViv(index));
7142 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7144 return (char *)PL_op_desc[OP_CUSTOM];
7146 return SvPV_nolen(HeVAL(he));
7151 /* Efficient sub that returns a constant scalar value. */
7153 const_sv_xsub(pTHX_ CV* cv)
7158 Perl_croak(aTHX_ "usage: %s::%s()",
7159 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7163 ST(0) = (SV*)XSANY.any_ptr;
7169 * c-indentation-style: bsd
7171 * indent-tabs-mode: t
7174 * ex: set ts=8 sts=4 sw=4 noet: