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 */
215 !(PL_in_my == KEY_our ||
217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218 (name[1] == '_' && (*name == '$' || name[2]))))
220 /* name[2] is true if strlen(name) > 2 */
221 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
222 /* 1999-02-27 mjd@plover.com */
224 p = strchr(name, '\0');
225 /* The next block assumes the buffer is at least 205 chars
226 long. At present, it's always at least 256 chars. */
228 strcpy(name+200, "...");
234 /* Move everything else down one character */
235 for (; p-name > 2; p--)
237 name[2] = toCTRL(name[1]);
240 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
243 /* check for duplicate declaration */
245 (bool)(PL_in_my == KEY_our),
246 (PL_curstash ? PL_curstash : PL_defstash)
249 if (PL_in_my_stash && *name != '$') {
250 yyerror(Perl_form(aTHX_
251 "Can't declare class for non-scalar %s in \"%s\"",
252 name, PL_in_my == KEY_our ? "our" : "my"));
255 /* allocate a spare slot and store the name in that slot */
257 off = pad_add_name(name,
260 /* $_ is always in main::, even with our */
261 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
272 Perl_op_free(pTHX_ OP *o)
278 if (!o || o->op_static)
281 if (o->op_private & OPpREFCOUNTED) {
282 switch (o->op_type) {
290 refcnt = OpREFCNT_dec(o);
300 if (o->op_flags & OPf_KIDS) {
301 register OP *kid, *nextkid;
302 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
303 nextkid = kid->op_sibling; /* Get before next freeing kid */
309 type = (OPCODE)o->op_targ;
311 /* COP* is not cleared by op_clear() so that we may track line
312 * numbers etc even after null() */
313 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
318 #ifdef DEBUG_LEAKING_SCALARS
325 Perl_op_clear(pTHX_ OP *o)
329 switch (o->op_type) {
330 case OP_NULL: /* Was holding old type, if any. */
331 case OP_ENTEREVAL: /* Was holding hints. */
335 if (!(o->op_flags & OPf_REF)
336 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
342 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
343 /* not an OP_PADAV replacement */
345 if (cPADOPo->op_padix > 0) {
346 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
347 * may still exist on the pad */
348 pad_swipe(cPADOPo->op_padix, TRUE);
349 cPADOPo->op_padix = 0;
352 SvREFCNT_dec(cSVOPo->op_sv);
353 cSVOPo->op_sv = Nullsv;
357 case OP_METHOD_NAMED:
359 SvREFCNT_dec(cSVOPo->op_sv);
360 cSVOPo->op_sv = Nullsv;
363 Even if op_clear does a pad_free for the target of the op,
364 pad_free doesn't actually remove the sv that exists in the pad;
365 instead it lives on. This results in that it could be reused as
366 a target later on when the pad was reallocated.
369 pad_swipe(o->op_targ,1);
378 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
382 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
383 SvREFCNT_dec(cSVOPo->op_sv);
384 cSVOPo->op_sv = Nullsv;
387 Safefree(cPVOPo->op_pv);
388 cPVOPo->op_pv = Nullch;
392 op_free(cPMOPo->op_pmreplroot);
396 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
397 /* No GvIN_PAD_off here, because other references may still
398 * exist on the pad */
399 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
402 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
409 HV * const pmstash = PmopSTASH(cPMOPo);
410 if (pmstash && !SvIS_FREED(pmstash)) {
411 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
413 PMOP *pmop = (PMOP*) mg->mg_obj;
414 PMOP *lastpmop = NULL;
416 if (cPMOPo == pmop) {
418 lastpmop->op_pmnext = pmop->op_pmnext;
420 mg->mg_obj = (SV*) pmop->op_pmnext;
424 pmop = pmop->op_pmnext;
428 PmopSTASH_free(cPMOPo);
430 cPMOPo->op_pmreplroot = Nullop;
431 /* we use the "SAFE" version of the PM_ macros here
432 * since sv_clean_all might release some PMOPs
433 * after PL_regex_padav has been cleared
434 * and the clearing of PL_regex_padav needs to
435 * happen before sv_clean_all
437 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
438 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
440 if(PL_regex_pad) { /* We could be in destruction */
441 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
442 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
443 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
450 if (o->op_targ > 0) {
451 pad_free(o->op_targ);
457 S_cop_free(pTHX_ COP* cop)
459 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
462 if (! specialWARN(cop->cop_warnings))
463 SvREFCNT_dec(cop->cop_warnings);
464 if (! specialCopIO(cop->cop_io)) {
468 char *s = SvPV(cop->cop_io,len);
469 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
472 SvREFCNT_dec(cop->cop_io);
478 Perl_op_null(pTHX_ OP *o)
481 if (o->op_type == OP_NULL)
484 o->op_targ = o->op_type;
485 o->op_type = OP_NULL;
486 o->op_ppaddr = PL_ppaddr[OP_NULL];
490 Perl_op_refcnt_lock(pTHX)
497 Perl_op_refcnt_unlock(pTHX)
503 /* Contextualizers */
505 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
508 Perl_linklist(pTHX_ OP *o)
514 /* establish postfix order */
515 if (cUNOPo->op_first) {
517 o->op_next = LINKLIST(cUNOPo->op_first);
518 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
520 kid->op_next = LINKLIST(kid->op_sibling);
532 Perl_scalarkids(pTHX_ OP *o)
534 if (o && o->op_flags & OPf_KIDS) {
536 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
543 S_scalarboolean(pTHX_ OP *o)
545 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
546 if (ckWARN(WARN_SYNTAX)) {
547 const line_t oldline = CopLINE(PL_curcop);
549 if (PL_copline != NOLINE)
550 CopLINE_set(PL_curcop, PL_copline);
551 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
552 CopLINE_set(PL_curcop, oldline);
559 Perl_scalar(pTHX_ OP *o)
564 /* assumes no premature commitment */
565 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
566 || o->op_type == OP_RETURN)
571 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
573 switch (o->op_type) {
575 scalar(cBINOPo->op_first);
580 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
584 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
585 if (!kPMOP->op_pmreplroot)
586 deprecate_old("implicit split to @_");
594 if (o->op_flags & OPf_KIDS) {
595 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
601 kid = cLISTOPo->op_first;
603 while ((kid = kid->op_sibling)) {
609 WITH_THR(PL_curcop = &PL_compiling);
614 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
620 WITH_THR(PL_curcop = &PL_compiling);
623 if (ckWARN(WARN_VOID))
624 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
630 Perl_scalarvoid(pTHX_ OP *o)
634 const char* useless = 0;
638 if (o->op_type == OP_NEXTSTATE
639 || o->op_type == OP_SETSTATE
640 || o->op_type == OP_DBSTATE
641 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
642 || o->op_targ == OP_SETSTATE
643 || o->op_targ == OP_DBSTATE)))
644 PL_curcop = (COP*)o; /* for warning below */
646 /* assumes no premature commitment */
647 want = o->op_flags & OPf_WANT;
648 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
649 || o->op_type == OP_RETURN)
654 if ((o->op_private & OPpTARGET_MY)
655 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
657 return scalar(o); /* As if inside SASSIGN */
660 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
662 switch (o->op_type) {
664 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
668 if (o->op_flags & OPf_STACKED)
672 if (o->op_private == 4)
744 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
745 useless = OP_DESC(o);
749 kid = cUNOPo->op_first;
750 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
751 kid->op_type != OP_TRANS) {
754 useless = "negative pattern binding (!~)";
761 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
762 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
763 useless = "a variable";
768 if (cSVOPo->op_private & OPpCONST_STRICT)
769 no_bareword_allowed(o);
771 if (ckWARN(WARN_VOID)) {
772 useless = "a constant";
773 /* don't warn on optimised away booleans, eg
774 * use constant Foo, 5; Foo || print; */
775 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
777 /* the constants 0 and 1 are permitted as they are
778 conventionally used as dummies in constructs like
779 1 while some_condition_with_side_effects; */
780 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
782 else if (SvPOK(sv)) {
783 /* perl4's way of mixing documentation and code
784 (before the invention of POD) was based on a
785 trick to mix nroff and perl code. The trick was
786 built upon these three nroff macros being used in
787 void context. The pink camel has the details in
788 the script wrapman near page 319. */
789 if (strnEQ(SvPVX_const(sv), "di", 2) ||
790 strnEQ(SvPVX_const(sv), "ds", 2) ||
791 strnEQ(SvPVX_const(sv), "ig", 2))
796 op_null(o); /* don't execute or even remember it */
800 o->op_type = OP_PREINC; /* pre-increment is faster */
801 o->op_ppaddr = PL_ppaddr[OP_PREINC];
805 o->op_type = OP_PREDEC; /* pre-decrement is faster */
806 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
810 o->op_type = OP_I_PREINC; /* pre-increment is faster */
811 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
815 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
816 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
823 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
828 if (o->op_flags & OPf_STACKED)
835 if (!(o->op_flags & OPf_KIDS))
844 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
851 /* all requires must return a boolean value */
852 o->op_flags &= ~OPf_WANT;
857 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
858 if (!kPMOP->op_pmreplroot)
859 deprecate_old("implicit split to @_");
863 if (useless && ckWARN(WARN_VOID))
864 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
869 Perl_listkids(pTHX_ OP *o)
871 if (o && o->op_flags & OPf_KIDS) {
873 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
880 Perl_list(pTHX_ OP *o)
885 /* assumes no premature commitment */
886 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
887 || o->op_type == OP_RETURN)
892 if ((o->op_private & OPpTARGET_MY)
893 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
895 return o; /* As if inside SASSIGN */
898 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
900 switch (o->op_type) {
903 list(cBINOPo->op_first);
908 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
916 if (!(o->op_flags & OPf_KIDS))
918 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
919 list(cBINOPo->op_first);
920 return gen_constant_list(o);
927 kid = cLISTOPo->op_first;
929 while ((kid = kid->op_sibling)) {
935 WITH_THR(PL_curcop = &PL_compiling);
939 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
945 WITH_THR(PL_curcop = &PL_compiling);
948 /* all requires must return a boolean value */
949 o->op_flags &= ~OPf_WANT;
956 Perl_scalarseq(pTHX_ OP *o)
959 if (o->op_type == OP_LINESEQ ||
960 o->op_type == OP_SCOPE ||
961 o->op_type == OP_LEAVE ||
962 o->op_type == OP_LEAVETRY)
965 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
966 if (kid->op_sibling) {
970 PL_curcop = &PL_compiling;
972 o->op_flags &= ~OPf_PARENS;
973 if (PL_hints & HINT_BLOCK_SCOPE)
974 o->op_flags |= OPf_PARENS;
977 o = newOP(OP_STUB, 0);
982 S_modkids(pTHX_ OP *o, I32 type)
984 if (o && o->op_flags & OPf_KIDS) {
986 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
992 /* Propagate lvalue ("modifiable") context to an op and it's children.
993 * 'type' represents the context type, roughly based on the type of op that
994 * would do the modifying, although local() is represented by OP_NULL.
995 * It's responsible for detecting things that can't be modified, flag
996 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
997 * might have to vivify a reference in $x), and so on.
999 * For example, "$a+1 = 2" would cause mod() to be called with o being
1000 * OP_ADD and type being OP_SASSIGN, and would output an error.
1004 Perl_mod(pTHX_ OP *o, I32 type)
1008 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1011 if (!o || PL_error_count)
1014 if ((o->op_private & OPpTARGET_MY)
1015 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1020 switch (o->op_type) {
1026 if (!(o->op_private & (OPpCONST_ARYBASE)))
1028 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1029 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1033 SAVEI32(PL_compiling.cop_arybase);
1034 PL_compiling.cop_arybase = 0;
1036 else if (type == OP_REFGEN)
1039 Perl_croak(aTHX_ "That use of $[ is unsupported");
1042 if (o->op_flags & OPf_PARENS)
1046 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1047 !(o->op_flags & OPf_STACKED)) {
1048 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1049 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1050 assert(cUNOPo->op_first->op_type == OP_NULL);
1051 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1054 else if (o->op_private & OPpENTERSUB_NOMOD)
1056 else { /* lvalue subroutine call */
1057 o->op_private |= OPpLVAL_INTRO;
1058 PL_modcount = RETURN_UNLIMITED_NUMBER;
1059 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1060 /* Backward compatibility mode: */
1061 o->op_private |= OPpENTERSUB_INARGS;
1064 else { /* Compile-time error message: */
1065 OP *kid = cUNOPo->op_first;
1069 if (kid->op_type == OP_PUSHMARK)
1071 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1073 "panic: unexpected lvalue entersub "
1074 "args: type/targ %ld:%"UVuf,
1075 (long)kid->op_type, (UV)kid->op_targ);
1076 kid = kLISTOP->op_first;
1078 while (kid->op_sibling)
1079 kid = kid->op_sibling;
1080 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1082 if (kid->op_type == OP_METHOD_NAMED
1083 || kid->op_type == OP_METHOD)
1087 NewOp(1101, newop, 1, UNOP);
1088 newop->op_type = OP_RV2CV;
1089 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1090 newop->op_first = Nullop;
1091 newop->op_next = (OP*)newop;
1092 kid->op_sibling = (OP*)newop;
1093 newop->op_private |= OPpLVAL_INTRO;
1097 if (kid->op_type != OP_RV2CV)
1099 "panic: unexpected lvalue entersub "
1100 "entry via type/targ %ld:%"UVuf,
1101 (long)kid->op_type, (UV)kid->op_targ);
1102 kid->op_private |= OPpLVAL_INTRO;
1103 break; /* Postpone until runtime */
1107 kid = kUNOP->op_first;
1108 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1109 kid = kUNOP->op_first;
1110 if (kid->op_type == OP_NULL)
1112 "Unexpected constant lvalue entersub "
1113 "entry via type/targ %ld:%"UVuf,
1114 (long)kid->op_type, (UV)kid->op_targ);
1115 if (kid->op_type != OP_GV) {
1116 /* Restore RV2CV to check lvalueness */
1118 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1119 okid->op_next = kid->op_next;
1120 kid->op_next = okid;
1123 okid->op_next = Nullop;
1124 okid->op_type = OP_RV2CV;
1126 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1127 okid->op_private |= OPpLVAL_INTRO;
1131 cv = GvCV(kGVOP_gv);
1141 /* grep, foreach, subcalls, refgen */
1142 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1144 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1145 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1147 : (o->op_type == OP_ENTERSUB
1148 ? "non-lvalue subroutine call"
1150 type ? PL_op_desc[type] : "local"));
1164 case OP_RIGHT_SHIFT:
1173 if (!(o->op_flags & OPf_STACKED))
1180 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1186 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1187 PL_modcount = RETURN_UNLIMITED_NUMBER;
1188 return o; /* Treat \(@foo) like ordinary list. */
1192 if (scalar_mod_type(o, type))
1194 ref(cUNOPo->op_first, o->op_type);
1198 if (type == OP_LEAVESUBLV)
1199 o->op_private |= OPpMAYBE_LVSUB;
1205 PL_modcount = RETURN_UNLIMITED_NUMBER;
1208 ref(cUNOPo->op_first, o->op_type);
1213 PL_hints |= HINT_BLOCK_SCOPE;
1228 PL_modcount = RETURN_UNLIMITED_NUMBER;
1229 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1230 return o; /* Treat \(@foo) like ordinary list. */
1231 if (scalar_mod_type(o, type))
1233 if (type == OP_LEAVESUBLV)
1234 o->op_private |= OPpMAYBE_LVSUB;
1238 if (!type) /* local() */
1239 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1240 PAD_COMPNAME_PV(o->op_targ));
1248 if (type != OP_SASSIGN)
1252 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1257 if (type == OP_LEAVESUBLV)
1258 o->op_private |= OPpMAYBE_LVSUB;
1260 pad_free(o->op_targ);
1261 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1262 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1263 if (o->op_flags & OPf_KIDS)
1264 mod(cBINOPo->op_first->op_sibling, type);
1269 ref(cBINOPo->op_first, o->op_type);
1270 if (type == OP_ENTERSUB &&
1271 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1272 o->op_private |= OPpLVAL_DEFER;
1273 if (type == OP_LEAVESUBLV)
1274 o->op_private |= OPpMAYBE_LVSUB;
1284 if (o->op_flags & OPf_KIDS)
1285 mod(cLISTOPo->op_last, type);
1290 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1292 else if (!(o->op_flags & OPf_KIDS))
1294 if (o->op_targ != OP_LIST) {
1295 mod(cBINOPo->op_first, type);
1301 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1306 if (type != OP_LEAVESUBLV)
1308 break; /* mod()ing was handled by ck_return() */
1311 /* [20011101.069] File test operators interpret OPf_REF to mean that
1312 their argument is a filehandle; thus \stat(".") should not set
1314 if (type == OP_REFGEN &&
1315 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1318 if (type != OP_LEAVESUBLV)
1319 o->op_flags |= OPf_MOD;
1321 if (type == OP_AASSIGN || type == OP_SASSIGN)
1322 o->op_flags |= OPf_SPECIAL|OPf_REF;
1323 else if (!type) { /* local() */
1326 o->op_private |= OPpLVAL_INTRO;
1327 o->op_flags &= ~OPf_SPECIAL;
1328 PL_hints |= HINT_BLOCK_SCOPE;
1333 if (ckWARN(WARN_SYNTAX)) {
1334 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1335 "Useless localization of %s", OP_DESC(o));
1339 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1340 && type != OP_LEAVESUBLV)
1341 o->op_flags |= OPf_REF;
1346 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1350 if (o->op_type == OP_RV2GV)
1374 case OP_RIGHT_SHIFT:
1393 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1395 switch (o->op_type) {
1403 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1416 Perl_refkids(pTHX_ OP *o, I32 type)
1418 if (o && o->op_flags & OPf_KIDS) {
1420 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1427 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1432 if (!o || PL_error_count)
1435 switch (o->op_type) {
1437 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1438 !(o->op_flags & OPf_STACKED)) {
1439 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1440 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1441 assert(cUNOPo->op_first->op_type == OP_NULL);
1442 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1443 o->op_flags |= OPf_SPECIAL;
1448 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1449 doref(kid, type, set_op_ref);
1452 if (type == OP_DEFINED)
1453 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1454 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1457 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1458 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1459 : type == OP_RV2HV ? OPpDEREF_HV
1461 o->op_flags |= OPf_MOD;
1466 o->op_flags |= OPf_MOD; /* XXX ??? */
1472 o->op_flags |= OPf_REF;
1475 if (type == OP_DEFINED)
1476 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1477 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1483 o->op_flags |= OPf_REF;
1488 if (!(o->op_flags & OPf_KIDS))
1490 doref(cBINOPo->op_first, type, set_op_ref);
1494 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1495 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1496 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1497 : type == OP_RV2HV ? OPpDEREF_HV
1499 o->op_flags |= OPf_MOD;
1509 if (!(o->op_flags & OPf_KIDS))
1511 doref(cLISTOPo->op_last, type, set_op_ref);
1521 S_dup_attrlist(pTHX_ OP *o)
1525 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1526 * where the first kid is OP_PUSHMARK and the remaining ones
1527 * are OP_CONST. We need to push the OP_CONST values.
1529 if (o->op_type == OP_CONST)
1530 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1532 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1533 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1534 if (o->op_type == OP_CONST)
1535 rop = append_elem(OP_LIST, rop,
1536 newSVOP(OP_CONST, o->op_flags,
1537 SvREFCNT_inc(cSVOPo->op_sv)));
1544 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1549 /* fake up C<use attributes $pkg,$rv,@attrs> */
1550 ENTER; /* need to protect against side-effects of 'use' */
1552 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1554 #define ATTRSMODULE "attributes"
1555 #define ATTRSMODULE_PM "attributes.pm"
1558 /* Don't force the C<use> if we don't need it. */
1559 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1560 sizeof(ATTRSMODULE_PM)-1, 0);
1561 if (svp && *svp != &PL_sv_undef)
1562 ; /* already in %INC */
1564 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1565 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1569 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1570 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1572 prepend_elem(OP_LIST,
1573 newSVOP(OP_CONST, 0, stashsv),
1574 prepend_elem(OP_LIST,
1575 newSVOP(OP_CONST, 0,
1577 dup_attrlist(attrs))));
1583 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1585 OP *pack, *imop, *arg;
1591 assert(target->op_type == OP_PADSV ||
1592 target->op_type == OP_PADHV ||
1593 target->op_type == OP_PADAV);
1595 /* Ensure that attributes.pm is loaded. */
1596 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1598 /* Need package name for method call. */
1599 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1601 /* Build up the real arg-list. */
1602 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1604 arg = newOP(OP_PADSV, 0);
1605 arg->op_targ = target->op_targ;
1606 arg = prepend_elem(OP_LIST,
1607 newSVOP(OP_CONST, 0, stashsv),
1608 prepend_elem(OP_LIST,
1609 newUNOP(OP_REFGEN, 0,
1610 mod(arg, OP_REFGEN)),
1611 dup_attrlist(attrs)));
1613 /* Fake up a method call to import */
1614 meth = newSVpvn_share("import", 6, 0);
1615 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1616 append_elem(OP_LIST,
1617 prepend_elem(OP_LIST, pack, list(arg)),
1618 newSVOP(OP_METHOD_NAMED, 0, meth)));
1619 imop->op_private |= OPpENTERSUB_NOMOD;
1621 /* Combine the ops. */
1622 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1626 =notfor apidoc apply_attrs_string
1628 Attempts to apply a list of attributes specified by the C<attrstr> and
1629 C<len> arguments to the subroutine identified by the C<cv> argument which
1630 is expected to be associated with the package identified by the C<stashpv>
1631 argument (see L<attributes>). It gets this wrong, though, in that it
1632 does not correctly identify the boundaries of the individual attribute
1633 specifications within C<attrstr>. This is not really intended for the
1634 public API, but has to be listed here for systems such as AIX which
1635 need an explicit export list for symbols. (It's called from XS code
1636 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1637 to respect attribute syntax properly would be welcome.
1643 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1644 const char *attrstr, STRLEN len)
1649 len = strlen(attrstr);
1653 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1655 const char * const sstr = attrstr;
1656 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1657 attrs = append_elem(OP_LIST, attrs,
1658 newSVOP(OP_CONST, 0,
1659 newSVpvn(sstr, attrstr-sstr)));
1663 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1664 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1665 Nullsv, prepend_elem(OP_LIST,
1666 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1667 prepend_elem(OP_LIST,
1668 newSVOP(OP_CONST, 0,
1674 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1678 if (!o || PL_error_count)
1682 if (type == OP_LIST) {
1684 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1685 my_kid(kid, attrs, imopsp);
1686 } else if (type == OP_UNDEF) {
1688 } else if (type == OP_RV2SV || /* "our" declaration */
1690 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1691 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1692 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1693 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1695 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1697 PL_in_my_stash = Nullhv;
1698 apply_attrs(GvSTASH(gv),
1699 (type == OP_RV2SV ? GvSV(gv) :
1700 type == OP_RV2AV ? (SV*)GvAV(gv) :
1701 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1704 o->op_private |= OPpOUR_INTRO;
1707 else if (type != OP_PADSV &&
1710 type != OP_PUSHMARK)
1712 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1714 PL_in_my == KEY_our ? "our" : "my"));
1717 else if (attrs && type != OP_PUSHMARK) {
1721 PL_in_my_stash = Nullhv;
1723 /* check for C<my Dog $spot> when deciding package */
1724 stash = PAD_COMPNAME_TYPE(o->op_targ);
1726 stash = PL_curstash;
1727 apply_attrs_my(stash, o, attrs, imopsp);
1729 o->op_flags |= OPf_MOD;
1730 o->op_private |= OPpLVAL_INTRO;
1735 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1738 int maybe_scalar = 0;
1740 /* [perl #17376]: this appears to be premature, and results in code such as
1741 C< our(%x); > executing in list mode rather than void mode */
1743 if (o->op_flags & OPf_PARENS)
1752 o = my_kid(o, attrs, &rops);
1754 if (maybe_scalar && o->op_type == OP_PADSV) {
1755 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1756 o->op_private |= OPpLVAL_INTRO;
1759 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1762 PL_in_my_stash = Nullhv;
1767 Perl_my(pTHX_ OP *o)
1769 return my_attrs(o, Nullop);
1773 Perl_sawparens(pTHX_ OP *o)
1776 o->op_flags |= OPf_PARENS;
1781 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1786 if ( (left->op_type == OP_RV2AV ||
1787 left->op_type == OP_RV2HV ||
1788 left->op_type == OP_PADAV ||
1789 left->op_type == OP_PADHV)
1790 && ckWARN(WARN_MISC))
1792 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1793 right->op_type == OP_TRANS)
1794 ? right->op_type : OP_MATCH];
1795 const char * const sample = ((left->op_type == OP_RV2AV ||
1796 left->op_type == OP_PADAV)
1797 ? "@array" : "%hash");
1798 Perl_warner(aTHX_ packWARN(WARN_MISC),
1799 "Applying %s to %s will act on scalar(%s)",
1800 desc, sample, sample);
1803 if (right->op_type == OP_CONST &&
1804 cSVOPx(right)->op_private & OPpCONST_BARE &&
1805 cSVOPx(right)->op_private & OPpCONST_STRICT)
1807 no_bareword_allowed(right);
1810 ismatchop = right->op_type == OP_MATCH ||
1811 right->op_type == OP_SUBST ||
1812 right->op_type == OP_TRANS;
1813 if (ismatchop && right->op_private & OPpTARGET_MY) {
1815 right->op_private &= ~OPpTARGET_MY;
1817 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1818 right->op_flags |= OPf_STACKED;
1819 if (right->op_type != OP_MATCH &&
1820 ! (right->op_type == OP_TRANS &&
1821 right->op_private & OPpTRANS_IDENTICAL))
1822 left = mod(left, right->op_type);
1823 if (right->op_type == OP_TRANS)
1824 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1826 o = prepend_elem(right->op_type, scalar(left), right);
1828 return newUNOP(OP_NOT, 0, scalar(o));
1832 return bind_match(type, left,
1833 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1837 Perl_invert(pTHX_ OP *o)
1841 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1842 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1846 Perl_scope(pTHX_ OP *o)
1850 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1851 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1852 o->op_type = OP_LEAVE;
1853 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1855 else if (o->op_type == OP_LINESEQ) {
1857 o->op_type = OP_SCOPE;
1858 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1859 kid = ((LISTOP*)o)->op_first;
1860 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1863 /* The following deals with things like 'do {1 for 1}' */
1864 kid = kid->op_sibling;
1866 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1871 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1877 Perl_block_start(pTHX_ int full)
1879 const int retval = PL_savestack_ix;
1880 pad_block_start(full);
1882 PL_hints &= ~HINT_BLOCK_SCOPE;
1883 SAVESPTR(PL_compiling.cop_warnings);
1884 if (! specialWARN(PL_compiling.cop_warnings)) {
1885 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1886 SAVEFREESV(PL_compiling.cop_warnings) ;
1888 SAVESPTR(PL_compiling.cop_io);
1889 if (! specialCopIO(PL_compiling.cop_io)) {
1890 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1891 SAVEFREESV(PL_compiling.cop_io) ;
1897 Perl_block_end(pTHX_ I32 floor, OP *seq)
1899 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1900 OP* const retval = scalarseq(seq);
1902 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1904 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1912 const I32 offset = pad_findmy("$_");
1913 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1914 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1917 OP * const o = newOP(OP_PADSV, 0);
1918 o->op_targ = offset;
1924 Perl_newPROG(pTHX_ OP *o)
1929 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1930 ((PL_in_eval & EVAL_KEEPERR)
1931 ? OPf_SPECIAL : 0), o);
1932 PL_eval_start = linklist(PL_eval_root);
1933 PL_eval_root->op_private |= OPpREFCOUNTED;
1934 OpREFCNT_set(PL_eval_root, 1);
1935 PL_eval_root->op_next = 0;
1936 CALL_PEEP(PL_eval_start);
1939 if (o->op_type == OP_STUB) {
1940 PL_comppad_name = 0;
1945 PL_main_root = scope(sawparens(scalarvoid(o)));
1946 PL_curcop = &PL_compiling;
1947 PL_main_start = LINKLIST(PL_main_root);
1948 PL_main_root->op_private |= OPpREFCOUNTED;
1949 OpREFCNT_set(PL_main_root, 1);
1950 PL_main_root->op_next = 0;
1951 CALL_PEEP(PL_main_start);
1954 /* Register with debugger */
1956 CV * const cv = get_cv("DB::postponed", FALSE);
1960 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1962 call_sv((SV*)cv, G_DISCARD);
1969 Perl_localize(pTHX_ OP *o, I32 lex)
1971 if (o->op_flags & OPf_PARENS)
1972 /* [perl #17376]: this appears to be premature, and results in code such as
1973 C< our(%x); > executing in list mode rather than void mode */
1980 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
1981 && ckWARN(WARN_PARENTHESIS))
1983 char *s = PL_bufptr;
1986 /* some heuristics to detect a potential error */
1987 while (*s && (strchr(", \t\n", *s)))
1991 if (*s && strchr("@$%*", *s) && *++s
1992 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1995 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1997 while (*s && (strchr(", \t\n", *s)))
2003 if (sigil && (*s == ';' || *s == '=')) {
2004 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2005 "Parentheses missing around \"%s\" list",
2006 lex ? (PL_in_my == KEY_our ? "our" : "my")
2014 o = mod(o, OP_NULL); /* a bit kludgey */
2016 PL_in_my_stash = Nullhv;
2021 Perl_jmaybe(pTHX_ OP *o)
2023 if (o->op_type == OP_LIST) {
2025 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2026 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2032 Perl_fold_constants(pTHX_ register OP *o)
2036 I32 type = o->op_type;
2039 if (PL_opargs[type] & OA_RETSCALAR)
2041 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2042 o->op_targ = pad_alloc(type, SVs_PADTMP);
2044 /* integerize op, unless it happens to be C<-foo>.
2045 * XXX should pp_i_negate() do magic string negation instead? */
2046 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2047 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2048 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2050 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2053 if (!(PL_opargs[type] & OA_FOLDCONST))
2058 /* XXX might want a ck_negate() for this */
2059 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2071 /* XXX what about the numeric ops? */
2072 if (PL_hints & HINT_LOCALE)
2077 goto nope; /* Don't try to run w/ errors */
2079 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2080 if ((curop->op_type != OP_CONST ||
2081 (curop->op_private & OPpCONST_BARE)) &&
2082 curop->op_type != OP_LIST &&
2083 curop->op_type != OP_SCALAR &&
2084 curop->op_type != OP_NULL &&
2085 curop->op_type != OP_PUSHMARK)
2091 curop = LINKLIST(o);
2095 sv = *(PL_stack_sp--);
2096 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2097 pad_swipe(o->op_targ, FALSE);
2098 else if (SvTEMP(sv)) { /* grab mortal temp? */
2099 (void)SvREFCNT_inc(sv);
2103 if (type == OP_RV2GV)
2104 return newGVOP(OP_GV, 0, (GV*)sv);
2105 return newSVOP(OP_CONST, 0, sv);
2112 Perl_gen_constant_list(pTHX_ register OP *o)
2116 const I32 oldtmps_floor = PL_tmps_floor;
2120 return o; /* Don't attempt to run with errors */
2122 PL_op = curop = LINKLIST(o);
2129 PL_tmps_floor = oldtmps_floor;
2131 o->op_type = OP_RV2AV;
2132 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2133 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2134 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2135 o->op_opt = 0; /* needs to be revisited in peep() */
2136 curop = ((UNOP*)o)->op_first;
2137 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2144 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2147 if (!o || o->op_type != OP_LIST)
2148 o = newLISTOP(OP_LIST, 0, o, Nullop);
2150 o->op_flags &= ~OPf_WANT;
2152 if (!(PL_opargs[type] & OA_MARK))
2153 op_null(cLISTOPo->op_first);
2155 o->op_type = (OPCODE)type;
2156 o->op_ppaddr = PL_ppaddr[type];
2157 o->op_flags |= flags;
2159 o = CHECKOP(type, o);
2160 if (o->op_type != (unsigned)type)
2163 return fold_constants(o);
2166 /* List constructors */
2169 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2177 if (first->op_type != (unsigned)type
2178 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2180 return newLISTOP(type, 0, first, last);
2183 if (first->op_flags & OPf_KIDS)
2184 ((LISTOP*)first)->op_last->op_sibling = last;
2186 first->op_flags |= OPf_KIDS;
2187 ((LISTOP*)first)->op_first = last;
2189 ((LISTOP*)first)->op_last = last;
2194 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2202 if (first->op_type != (unsigned)type)
2203 return prepend_elem(type, (OP*)first, (OP*)last);
2205 if (last->op_type != (unsigned)type)
2206 return append_elem(type, (OP*)first, (OP*)last);
2208 first->op_last->op_sibling = last->op_first;
2209 first->op_last = last->op_last;
2210 first->op_flags |= (last->op_flags & OPf_KIDS);
2218 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2226 if (last->op_type == (unsigned)type) {
2227 if (type == OP_LIST) { /* already a PUSHMARK there */
2228 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2229 ((LISTOP*)last)->op_first->op_sibling = first;
2230 if (!(first->op_flags & OPf_PARENS))
2231 last->op_flags &= ~OPf_PARENS;
2234 if (!(last->op_flags & OPf_KIDS)) {
2235 ((LISTOP*)last)->op_last = first;
2236 last->op_flags |= OPf_KIDS;
2238 first->op_sibling = ((LISTOP*)last)->op_first;
2239 ((LISTOP*)last)->op_first = first;
2241 last->op_flags |= OPf_KIDS;
2245 return newLISTOP(type, 0, first, last);
2251 Perl_newNULLLIST(pTHX)
2253 return newOP(OP_STUB, 0);
2257 Perl_force_list(pTHX_ OP *o)
2259 if (!o || o->op_type != OP_LIST)
2260 o = newLISTOP(OP_LIST, 0, o, Nullop);
2266 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2271 NewOp(1101, listop, 1, LISTOP);
2273 listop->op_type = (OPCODE)type;
2274 listop->op_ppaddr = PL_ppaddr[type];
2277 listop->op_flags = (U8)flags;
2281 else if (!first && last)
2284 first->op_sibling = last;
2285 listop->op_first = first;
2286 listop->op_last = last;
2287 if (type == OP_LIST) {
2288 OP* const pushop = newOP(OP_PUSHMARK, 0);
2289 pushop->op_sibling = first;
2290 listop->op_first = pushop;
2291 listop->op_flags |= OPf_KIDS;
2293 listop->op_last = pushop;
2296 return CHECKOP(type, listop);
2300 Perl_newOP(pTHX_ I32 type, I32 flags)
2304 NewOp(1101, o, 1, OP);
2305 o->op_type = (OPCODE)type;
2306 o->op_ppaddr = PL_ppaddr[type];
2307 o->op_flags = (U8)flags;
2310 o->op_private = (U8)(0 | (flags >> 8));
2311 if (PL_opargs[type] & OA_RETSCALAR)
2313 if (PL_opargs[type] & OA_TARGET)
2314 o->op_targ = pad_alloc(type, SVs_PADTMP);
2315 return CHECKOP(type, o);
2319 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2325 first = newOP(OP_STUB, 0);
2326 if (PL_opargs[type] & OA_MARK)
2327 first = force_list(first);
2329 NewOp(1101, unop, 1, UNOP);
2330 unop->op_type = (OPCODE)type;
2331 unop->op_ppaddr = PL_ppaddr[type];
2332 unop->op_first = first;
2333 unop->op_flags = (U8)(flags | OPf_KIDS);
2334 unop->op_private = (U8)(1 | (flags >> 8));
2335 unop = (UNOP*) CHECKOP(type, unop);
2339 return fold_constants((OP *) unop);
2343 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2347 NewOp(1101, binop, 1, BINOP);
2350 first = newOP(OP_NULL, 0);
2352 binop->op_type = (OPCODE)type;
2353 binop->op_ppaddr = PL_ppaddr[type];
2354 binop->op_first = first;
2355 binop->op_flags = (U8)(flags | OPf_KIDS);
2358 binop->op_private = (U8)(1 | (flags >> 8));
2361 binop->op_private = (U8)(2 | (flags >> 8));
2362 first->op_sibling = last;
2365 binop = (BINOP*)CHECKOP(type, binop);
2366 if (binop->op_next || binop->op_type != (OPCODE)type)
2369 binop->op_last = binop->op_first->op_sibling;
2371 return fold_constants((OP *)binop);
2374 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2375 static int uvcompare(const void *a, const void *b)
2377 if (*((const UV *)a) < (*(const UV *)b))
2379 if (*((const UV *)a) > (*(const UV *)b))
2381 if (*((const UV *)a+1) < (*(const UV *)b+1))
2383 if (*((const UV *)a+1) > (*(const UV *)b+1))
2389 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2391 SV * const tstr = ((SVOP*)expr)->op_sv;
2392 SV * const rstr = ((SVOP*)repl)->op_sv;
2395 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2396 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2400 register short *tbl;
2402 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2403 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2404 I32 del = o->op_private & OPpTRANS_DELETE;
2405 PL_hints |= HINT_BLOCK_SCOPE;
2408 o->op_private |= OPpTRANS_FROM_UTF;
2411 o->op_private |= OPpTRANS_TO_UTF;
2413 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2414 SV* const listsv = newSVpvn("# comment\n",10);
2416 const U8* tend = t + tlen;
2417 const U8* rend = r + rlen;
2431 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2432 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2438 t = tsave = bytes_to_utf8(t, &len);
2441 if (!to_utf && rlen) {
2443 r = rsave = bytes_to_utf8(r, &len);
2447 /* There are several snags with this code on EBCDIC:
2448 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2449 2. scan_const() in toke.c has encoded chars in native encoding which makes
2450 ranges at least in EBCDIC 0..255 range the bottom odd.
2454 U8 tmpbuf[UTF8_MAXBYTES+1];
2457 Newx(cp, 2*tlen, UV);
2459 transv = newSVpvn("",0);
2461 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2463 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2465 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2469 cp[2*i+1] = cp[2*i];
2473 qsort(cp, i, 2*sizeof(UV), uvcompare);
2474 for (j = 0; j < i; j++) {
2476 diff = val - nextmin;
2478 t = uvuni_to_utf8(tmpbuf,nextmin);
2479 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2481 U8 range_mark = UTF_TO_NATIVE(0xff);
2482 t = uvuni_to_utf8(tmpbuf, val - 1);
2483 sv_catpvn(transv, (char *)&range_mark, 1);
2484 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2491 t = uvuni_to_utf8(tmpbuf,nextmin);
2492 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2494 U8 range_mark = UTF_TO_NATIVE(0xff);
2495 sv_catpvn(transv, (char *)&range_mark, 1);
2497 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2498 UNICODE_ALLOW_SUPER);
2499 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2500 t = (const U8*)SvPVX_const(transv);
2501 tlen = SvCUR(transv);
2505 else if (!rlen && !del) {
2506 r = t; rlen = tlen; rend = tend;
2509 if ((!rlen && !del) || t == r ||
2510 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2512 o->op_private |= OPpTRANS_IDENTICAL;
2516 while (t < tend || tfirst <= tlast) {
2517 /* see if we need more "t" chars */
2518 if (tfirst > tlast) {
2519 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2521 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2523 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2530 /* now see if we need more "r" chars */
2531 if (rfirst > rlast) {
2533 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2535 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2537 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2546 rfirst = rlast = 0xffffffff;
2550 /* now see which range will peter our first, if either. */
2551 tdiff = tlast - tfirst;
2552 rdiff = rlast - rfirst;
2559 if (rfirst == 0xffffffff) {
2560 diff = tdiff; /* oops, pretend rdiff is infinite */
2562 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2563 (long)tfirst, (long)tlast);
2565 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2569 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2570 (long)tfirst, (long)(tfirst + diff),
2573 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2574 (long)tfirst, (long)rfirst);
2576 if (rfirst + diff > max)
2577 max = rfirst + diff;
2579 grows = (tfirst < rfirst &&
2580 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2592 else if (max > 0xff)
2597 Safefree(cPVOPo->op_pv);
2598 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2599 SvREFCNT_dec(listsv);
2601 SvREFCNT_dec(transv);
2603 if (!del && havefinal && rlen)
2604 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2605 newSVuv((UV)final), 0);
2608 o->op_private |= OPpTRANS_GROWS;
2620 tbl = (short*)cPVOPo->op_pv;
2622 Zero(tbl, 256, short);
2623 for (i = 0; i < (I32)tlen; i++)
2625 for (i = 0, j = 0; i < 256; i++) {
2627 if (j >= (I32)rlen) {
2636 if (i < 128 && r[j] >= 128)
2646 o->op_private |= OPpTRANS_IDENTICAL;
2648 else if (j >= (I32)rlen)
2651 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2652 tbl[0x100] = (short)(rlen - j);
2653 for (i=0; i < (I32)rlen - j; i++)
2654 tbl[0x101+i] = r[j+i];
2658 if (!rlen && !del) {
2661 o->op_private |= OPpTRANS_IDENTICAL;
2663 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2664 o->op_private |= OPpTRANS_IDENTICAL;
2666 for (i = 0; i < 256; i++)
2668 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2669 if (j >= (I32)rlen) {
2671 if (tbl[t[i]] == -1)
2677 if (tbl[t[i]] == -1) {
2678 if (t[i] < 128 && r[j] >= 128)
2685 o->op_private |= OPpTRANS_GROWS;
2693 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2698 NewOp(1101, pmop, 1, PMOP);
2699 pmop->op_type = (OPCODE)type;
2700 pmop->op_ppaddr = PL_ppaddr[type];
2701 pmop->op_flags = (U8)flags;
2702 pmop->op_private = (U8)(0 | (flags >> 8));
2704 if (PL_hints & HINT_RE_TAINT)
2705 pmop->op_pmpermflags |= PMf_RETAINT;
2706 if (PL_hints & HINT_LOCALE)
2707 pmop->op_pmpermflags |= PMf_LOCALE;
2708 pmop->op_pmflags = pmop->op_pmpermflags;
2711 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2712 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2713 pmop->op_pmoffset = SvIV(repointer);
2714 SvREPADTMP_off(repointer);
2715 sv_setiv(repointer,0);
2717 SV * const repointer = newSViv(0);
2718 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2719 pmop->op_pmoffset = av_len(PL_regex_padav);
2720 PL_regex_pad = AvARRAY(PL_regex_padav);
2724 /* link into pm list */
2725 if (type != OP_TRANS && PL_curstash) {
2726 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2729 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2731 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2732 mg->mg_obj = (SV*)pmop;
2733 PmopSTASH_set(pmop,PL_curstash);
2736 return CHECKOP(type, pmop);
2739 /* Given some sort of match op o, and an expression expr containing a
2740 * pattern, either compile expr into a regex and attach it to o (if it's
2741 * constant), or convert expr into a runtime regcomp op sequence (if it's
2744 * isreg indicates that the pattern is part of a regex construct, eg
2745 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2746 * split "pattern", which aren't. In the former case, expr will be a list
2747 * if the pattern contains more than one term (eg /a$b/) or if it contains
2748 * a replacement, ie s/// or tr///.
2752 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2757 I32 repl_has_vars = 0;
2761 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2762 /* last element in list is the replacement; pop it */
2764 repl = cLISTOPx(expr)->op_last;
2765 kid = cLISTOPx(expr)->op_first;
2766 while (kid->op_sibling != repl)
2767 kid = kid->op_sibling;
2768 kid->op_sibling = Nullop;
2769 cLISTOPx(expr)->op_last = kid;
2772 if (isreg && expr->op_type == OP_LIST &&
2773 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2775 /* convert single element list to element */
2777 expr = cLISTOPx(oe)->op_first->op_sibling;
2778 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2779 cLISTOPx(oe)->op_last = Nullop;
2783 if (o->op_type == OP_TRANS) {
2784 return pmtrans(o, expr, repl);
2787 reglist = isreg && expr->op_type == OP_LIST;
2791 PL_hints |= HINT_BLOCK_SCOPE;
2794 if (expr->op_type == OP_CONST) {
2796 SV *pat = ((SVOP*)expr)->op_sv;
2797 const char *p = SvPV_const(pat, plen);
2798 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2799 U32 was_readonly = SvREADONLY(pat);
2803 sv_force_normal_flags(pat, 0);
2804 assert(!SvREADONLY(pat));
2807 SvREADONLY_off(pat);
2811 sv_setpvn(pat, "\\s+", 3);
2813 SvFLAGS(pat) |= was_readonly;
2815 p = SvPV_const(pat, plen);
2816 pm->op_pmflags |= PMf_SKIPWHITE;
2819 pm->op_pmdynflags |= PMdf_UTF8;
2820 /* FIXME - can we make this function take const char * args? */
2821 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2822 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2823 pm->op_pmflags |= PMf_WHITE;
2827 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2828 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2830 : OP_REGCMAYBE),0,expr);
2832 NewOp(1101, rcop, 1, LOGOP);
2833 rcop->op_type = OP_REGCOMP;
2834 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2835 rcop->op_first = scalar(expr);
2836 rcop->op_flags |= OPf_KIDS
2837 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2838 | (reglist ? OPf_STACKED : 0);
2839 rcop->op_private = 1;
2842 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2844 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2847 /* establish postfix order */
2848 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2850 rcop->op_next = expr;
2851 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2854 rcop->op_next = LINKLIST(expr);
2855 expr->op_next = (OP*)rcop;
2858 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2863 if (pm->op_pmflags & PMf_EVAL) {
2865 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2866 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2868 else if (repl->op_type == OP_CONST)
2872 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2873 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2874 if (curop->op_type == OP_GV) {
2875 GV *gv = cGVOPx_gv(curop);
2877 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2880 else if (curop->op_type == OP_RV2CV)
2882 else if (curop->op_type == OP_RV2SV ||
2883 curop->op_type == OP_RV2AV ||
2884 curop->op_type == OP_RV2HV ||
2885 curop->op_type == OP_RV2GV) {
2886 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2889 else if (curop->op_type == OP_PADSV ||
2890 curop->op_type == OP_PADAV ||
2891 curop->op_type == OP_PADHV ||
2892 curop->op_type == OP_PADANY) {
2895 else if (curop->op_type == OP_PUSHRE)
2896 ; /* Okay here, dangerous in newASSIGNOP */
2906 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2907 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2908 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2909 prepend_elem(o->op_type, scalar(repl), o);
2912 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2913 pm->op_pmflags |= PMf_MAYBE_CONST;
2914 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2916 NewOp(1101, rcop, 1, LOGOP);
2917 rcop->op_type = OP_SUBSTCONT;
2918 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2919 rcop->op_first = scalar(repl);
2920 rcop->op_flags |= OPf_KIDS;
2921 rcop->op_private = 1;
2924 /* establish postfix order */
2925 rcop->op_next = LINKLIST(repl);
2926 repl->op_next = (OP*)rcop;
2928 pm->op_pmreplroot = scalar((OP*)rcop);
2929 pm->op_pmreplstart = LINKLIST(rcop);
2938 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2942 NewOp(1101, svop, 1, SVOP);
2943 svop->op_type = (OPCODE)type;
2944 svop->op_ppaddr = PL_ppaddr[type];
2946 svop->op_next = (OP*)svop;
2947 svop->op_flags = (U8)flags;
2948 if (PL_opargs[type] & OA_RETSCALAR)
2950 if (PL_opargs[type] & OA_TARGET)
2951 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2952 return CHECKOP(type, svop);
2956 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2960 NewOp(1101, padop, 1, PADOP);
2961 padop->op_type = (OPCODE)type;
2962 padop->op_ppaddr = PL_ppaddr[type];
2963 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2964 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2965 PAD_SETSV(padop->op_padix, sv);
2968 padop->op_next = (OP*)padop;
2969 padop->op_flags = (U8)flags;
2970 if (PL_opargs[type] & OA_RETSCALAR)
2972 if (PL_opargs[type] & OA_TARGET)
2973 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2974 return CHECKOP(type, padop);
2978 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2984 return newPADOP(type, flags, SvREFCNT_inc(gv));
2986 return newSVOP(type, flags, SvREFCNT_inc(gv));
2991 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2995 NewOp(1101, pvop, 1, PVOP);
2996 pvop->op_type = (OPCODE)type;
2997 pvop->op_ppaddr = PL_ppaddr[type];
2999 pvop->op_next = (OP*)pvop;
3000 pvop->op_flags = (U8)flags;
3001 if (PL_opargs[type] & OA_RETSCALAR)
3003 if (PL_opargs[type] & OA_TARGET)
3004 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3005 return CHECKOP(type, pvop);
3009 Perl_package(pTHX_ OP *o)
3014 save_hptr(&PL_curstash);
3015 save_item(PL_curstname);
3017 name = SvPV_const(cSVOPo->op_sv, len);
3018 PL_curstash = gv_stashpvn(name, len, TRUE);
3019 sv_setpvn(PL_curstname, name, len);
3022 PL_hints |= HINT_BLOCK_SCOPE;
3023 PL_copline = NOLINE;
3028 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3034 if (idop->op_type != OP_CONST)
3035 Perl_croak(aTHX_ "Module name must be constant");
3040 SV * const vesv = ((SVOP*)version)->op_sv;
3042 if (!arg && !SvNIOKp(vesv)) {
3049 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3050 Perl_croak(aTHX_ "Version number must be constant number");
3052 /* Make copy of idop so we don't free it twice */
3053 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3055 /* Fake up a method call to VERSION */
3056 meth = newSVpvn_share("VERSION", 7, 0);
3057 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3058 append_elem(OP_LIST,
3059 prepend_elem(OP_LIST, pack, list(version)),
3060 newSVOP(OP_METHOD_NAMED, 0, meth)));
3064 /* Fake up an import/unimport */
3065 if (arg && arg->op_type == OP_STUB)
3066 imop = arg; /* no import on explicit () */
3067 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3068 imop = Nullop; /* use 5.0; */
3070 idop->op_private |= OPpCONST_NOVER;
3075 /* Make copy of idop so we don't free it twice */
3076 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3078 /* Fake up a method call to import/unimport */
3080 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3081 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3082 append_elem(OP_LIST,
3083 prepend_elem(OP_LIST, pack, list(arg)),
3084 newSVOP(OP_METHOD_NAMED, 0, meth)));
3087 /* Fake up the BEGIN {}, which does its thing immediately. */
3089 newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3092 append_elem(OP_LINESEQ,
3093 append_elem(OP_LINESEQ,
3094 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3095 newSTATEOP(0, Nullch, veop)),
3096 newSTATEOP(0, Nullch, imop) ));
3098 /* The "did you use incorrect case?" warning used to be here.
3099 * The problem is that on case-insensitive filesystems one
3100 * might get false positives for "use" (and "require"):
3101 * "use Strict" or "require CARP" will work. This causes
3102 * portability problems for the script: in case-strict
3103 * filesystems the script will stop working.
3105 * The "incorrect case" warning checked whether "use Foo"
3106 * imported "Foo" to your namespace, but that is wrong, too:
3107 * there is no requirement nor promise in the language that
3108 * a Foo.pm should or would contain anything in package "Foo".
3110 * There is very little Configure-wise that can be done, either:
3111 * the case-sensitivity of the build filesystem of Perl does not
3112 * help in guessing the case-sensitivity of the runtime environment.
3115 PL_hints |= HINT_BLOCK_SCOPE;
3116 PL_copline = NOLINE;
3118 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3122 =head1 Embedding Functions
3124 =for apidoc load_module
3126 Loads the module whose name is pointed to by the string part of name.
3127 Note that the actual module name, not its filename, should be given.
3128 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3129 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3130 (or 0 for no flags). ver, if specified, provides version semantics
3131 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3132 arguments can be used to specify arguments to the module's import()
3133 method, similar to C<use Foo::Bar VERSION LIST>.
3138 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3141 va_start(args, ver);
3142 vload_module(flags, name, ver, &args);
3146 #ifdef PERL_IMPLICIT_CONTEXT
3148 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3152 va_start(args, ver);
3153 vload_module(flags, name, ver, &args);
3159 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3163 OP * const modname = newSVOP(OP_CONST, 0, name);
3164 modname->op_private |= OPpCONST_BARE;
3166 veop = newSVOP(OP_CONST, 0, ver);
3170 if (flags & PERL_LOADMOD_NOIMPORT) {
3171 imop = sawparens(newNULLLIST());
3173 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3174 imop = va_arg(*args, OP*);
3179 sv = va_arg(*args, SV*);
3181 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3182 sv = va_arg(*args, SV*);
3186 const line_t ocopline = PL_copline;
3187 COP * const ocurcop = PL_curcop;
3188 const int oexpect = PL_expect;
3190 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3191 veop, modname, imop);
3192 PL_expect = oexpect;
3193 PL_copline = ocopline;
3194 PL_curcop = ocurcop;
3199 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3204 if (!force_builtin) {
3205 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3206 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3207 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3208 gv = gvp ? *gvp : Nullgv;
3212 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3213 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3214 append_elem(OP_LIST, term,
3215 scalar(newUNOP(OP_RV2CV, 0,
3220 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3226 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3228 return newBINOP(OP_LSLICE, flags,
3229 list(force_list(subscript)),
3230 list(force_list(listval)) );
3234 S_is_list_assignment(pTHX_ register const OP *o)
3239 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3240 o = cUNOPo->op_first;
3242 if (o->op_type == OP_COND_EXPR) {
3243 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3244 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3249 yyerror("Assignment to both a list and a scalar");
3253 if (o->op_type == OP_LIST &&
3254 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3255 o->op_private & OPpLVAL_INTRO)
3258 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3259 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3260 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3263 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3266 if (o->op_type == OP_RV2SV)
3273 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3278 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3279 return newLOGOP(optype, 0,
3280 mod(scalar(left), optype),
3281 newUNOP(OP_SASSIGN, 0, scalar(right)));
3284 return newBINOP(optype, OPf_STACKED,
3285 mod(scalar(left), optype), scalar(right));
3289 if (is_list_assignment(left)) {
3293 /* Grandfathering $[ assignment here. Bletch.*/
3294 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3295 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3296 left = mod(left, OP_AASSIGN);
3299 else if (left->op_type == OP_CONST) {
3300 /* Result of assignment is always 1 (or we'd be dead already) */
3301 return newSVOP(OP_CONST, 0, newSViv(1));
3303 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3304 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3305 && right->op_type == OP_STUB
3306 && (left->op_private & OPpLVAL_INTRO))
3309 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3312 curop = list(force_list(left));
3313 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3314 o->op_private = (U8)(0 | (flags >> 8));
3316 /* PL_generation sorcery:
3317 * an assignment like ($a,$b) = ($c,$d) is easier than
3318 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3319 * To detect whether there are common vars, the global var
3320 * PL_generation is incremented for each assign op we compile.
3321 * Then, while compiling the assign op, we run through all the
3322 * variables on both sides of the assignment, setting a spare slot
3323 * in each of them to PL_generation. If any of them already have
3324 * that value, we know we've got commonality. We could use a
3325 * single bit marker, but then we'd have to make 2 passes, first
3326 * to clear the flag, then to test and set it. To find somewhere
3327 * to store these values, evil chicanery is done with SvCUR().
3330 if (!(left->op_private & OPpLVAL_INTRO)) {
3333 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3334 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3335 if (curop->op_type == OP_GV) {
3336 GV *gv = cGVOPx_gv(curop);
3337 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3339 SvCUR_set(gv, PL_generation);
3341 else if (curop->op_type == OP_PADSV ||
3342 curop->op_type == OP_PADAV ||
3343 curop->op_type == OP_PADHV ||
3344 curop->op_type == OP_PADANY)
3346 if (PAD_COMPNAME_GEN(curop->op_targ)
3347 == (STRLEN)PL_generation)
3349 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3352 else if (curop->op_type == OP_RV2CV)
3354 else if (curop->op_type == OP_RV2SV ||
3355 curop->op_type == OP_RV2AV ||
3356 curop->op_type == OP_RV2HV ||
3357 curop->op_type == OP_RV2GV) {
3358 if (lastop->op_type != OP_GV) /* funny deref? */
3361 else if (curop->op_type == OP_PUSHRE) {
3362 if (((PMOP*)curop)->op_pmreplroot) {
3364 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3365 ((PMOP*)curop)->op_pmreplroot));
3367 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3369 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3371 SvCUR_set(gv, PL_generation);
3380 o->op_private |= OPpASSIGN_COMMON;
3382 if (right && right->op_type == OP_SPLIT) {
3384 if ((tmpop = ((LISTOP*)right)->op_first) &&
3385 tmpop->op_type == OP_PUSHRE)
3387 PMOP * const pm = (PMOP*)tmpop;
3388 if (left->op_type == OP_RV2AV &&
3389 !(left->op_private & OPpLVAL_INTRO) &&
3390 !(o->op_private & OPpASSIGN_COMMON) )
3392 tmpop = ((UNOP*)left)->op_first;
3393 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3395 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3396 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3398 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3399 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3401 pm->op_pmflags |= PMf_ONCE;
3402 tmpop = cUNOPo->op_first; /* to list (nulled) */
3403 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3404 tmpop->op_sibling = Nullop; /* don't free split */
3405 right->op_next = tmpop->op_next; /* fix starting loc */
3406 op_free(o); /* blow off assign */
3407 right->op_flags &= ~OPf_WANT;
3408 /* "I don't know and I don't care." */
3413 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3414 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3416 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3418 sv_setiv(sv, PL_modcount+1);
3426 right = newOP(OP_UNDEF, 0);
3427 if (right->op_type == OP_READLINE) {
3428 right->op_flags |= OPf_STACKED;
3429 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3432 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3433 o = newBINOP(OP_SASSIGN, flags,
3434 scalar(right), mod(scalar(left), OP_SASSIGN) );
3438 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3445 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3448 const U32 seq = intro_my();
3451 NewOp(1101, cop, 1, COP);
3452 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3453 cop->op_type = OP_DBSTATE;
3454 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3457 cop->op_type = OP_NEXTSTATE;
3458 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3460 cop->op_flags = (U8)flags;
3461 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3463 cop->op_private |= NATIVE_HINTS;
3465 PL_compiling.op_private = cop->op_private;
3466 cop->op_next = (OP*)cop;
3469 cop->cop_label = label;
3470 PL_hints |= HINT_BLOCK_SCOPE;
3473 cop->cop_arybase = PL_curcop->cop_arybase;
3474 if (specialWARN(PL_curcop->cop_warnings))
3475 cop->cop_warnings = PL_curcop->cop_warnings ;
3477 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3478 if (specialCopIO(PL_curcop->cop_io))
3479 cop->cop_io = PL_curcop->cop_io;
3481 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3484 if (PL_copline == NOLINE)
3485 CopLINE_set(cop, CopLINE(PL_curcop));
3487 CopLINE_set(cop, PL_copline);
3488 PL_copline = NOLINE;
3491 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3493 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3495 CopSTASH_set(cop, PL_curstash);
3497 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3498 SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3499 if (svp && *svp != &PL_sv_undef ) {
3500 (void)SvIOK_on(*svp);
3501 SvIV_set(*svp, PTR2IV(cop));
3505 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3510 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3513 return new_logop(type, flags, &first, &other);
3517 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3522 OP *first = *firstp;
3523 OP * const other = *otherp;
3525 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3526 return newBINOP(type, flags, scalar(first), scalar(other));
3528 scalarboolean(first);
3529 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3530 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3531 if (type == OP_AND || type == OP_OR) {
3537 first = *firstp = cUNOPo->op_first;
3539 first->op_next = o->op_next;
3540 cUNOPo->op_first = Nullop;
3544 if (first->op_type == OP_CONST) {
3545 if (first->op_private & OPpCONST_STRICT)
3546 no_bareword_allowed(first);
3547 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3548 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3549 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3550 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3551 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3554 if (other->op_type == OP_CONST)
3555 other->op_private |= OPpCONST_SHORTCIRCUIT;
3559 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3560 const OP *o2 = other;
3561 if ( ! (o2->op_type == OP_LIST
3562 && (( o2 = cUNOPx(o2)->op_first))
3563 && o2->op_type == OP_PUSHMARK
3564 && (( o2 = o2->op_sibling)) )
3567 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3568 || o2->op_type == OP_PADHV)
3569 && o2->op_private & OPpLVAL_INTRO
3570 && ckWARN(WARN_DEPRECATED))
3572 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3573 "Deprecated use of my() in false conditional");
3578 if (first->op_type == OP_CONST)
3579 first->op_private |= OPpCONST_SHORTCIRCUIT;
3583 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3584 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3586 const OP * const k1 = ((UNOP*)first)->op_first;
3587 const OP * const k2 = k1->op_sibling;
3589 switch (first->op_type)
3592 if (k2 && k2->op_type == OP_READLINE
3593 && (k2->op_flags & OPf_STACKED)
3594 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3596 warnop = k2->op_type;
3601 if (k1->op_type == OP_READDIR
3602 || k1->op_type == OP_GLOB
3603 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3604 || k1->op_type == OP_EACH)
3606 warnop = ((k1->op_type == OP_NULL)
3607 ? (OPCODE)k1->op_targ : k1->op_type);
3612 const line_t oldline = CopLINE(PL_curcop);
3613 CopLINE_set(PL_curcop, PL_copline);
3614 Perl_warner(aTHX_ packWARN(WARN_MISC),
3615 "Value of %s%s can be \"0\"; test with defined()",
3617 ((warnop == OP_READLINE || warnop == OP_GLOB)
3618 ? " construct" : "() operator"));
3619 CopLINE_set(PL_curcop, oldline);
3626 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3627 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3629 NewOp(1101, logop, 1, LOGOP);
3631 logop->op_type = (OPCODE)type;
3632 logop->op_ppaddr = PL_ppaddr[type];
3633 logop->op_first = first;
3634 logop->op_flags = (U8)(flags | OPf_KIDS);
3635 logop->op_other = LINKLIST(other);
3636 logop->op_private = (U8)(1 | (flags >> 8));
3638 /* establish postfix order */
3639 logop->op_next = LINKLIST(first);
3640 first->op_next = (OP*)logop;
3641 first->op_sibling = other;
3643 CHECKOP(type,logop);
3645 o = newUNOP(OP_NULL, 0, (OP*)logop);
3652 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3660 return newLOGOP(OP_AND, 0, first, trueop);
3662 return newLOGOP(OP_OR, 0, first, falseop);
3664 scalarboolean(first);
3665 if (first->op_type == OP_CONST) {
3666 if (first->op_private & OPpCONST_BARE &&
3667 first->op_private & OPpCONST_STRICT) {
3668 no_bareword_allowed(first);
3670 if (SvTRUE(((SVOP*)first)->op_sv)) {
3681 NewOp(1101, logop, 1, LOGOP);
3682 logop->op_type = OP_COND_EXPR;
3683 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3684 logop->op_first = first;
3685 logop->op_flags = (U8)(flags | OPf_KIDS);
3686 logop->op_private = (U8)(1 | (flags >> 8));
3687 logop->op_other = LINKLIST(trueop);
3688 logop->op_next = LINKLIST(falseop);
3690 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3693 /* establish postfix order */
3694 start = LINKLIST(first);
3695 first->op_next = (OP*)logop;
3697 first->op_sibling = trueop;
3698 trueop->op_sibling = falseop;
3699 o = newUNOP(OP_NULL, 0, (OP*)logop);
3701 trueop->op_next = falseop->op_next = o;
3708 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3717 NewOp(1101, range, 1, LOGOP);
3719 range->op_type = OP_RANGE;
3720 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3721 range->op_first = left;
3722 range->op_flags = OPf_KIDS;
3723 leftstart = LINKLIST(left);
3724 range->op_other = LINKLIST(right);
3725 range->op_private = (U8)(1 | (flags >> 8));
3727 left->op_sibling = right;
3729 range->op_next = (OP*)range;
3730 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3731 flop = newUNOP(OP_FLOP, 0, flip);
3732 o = newUNOP(OP_NULL, 0, flop);
3734 range->op_next = leftstart;
3736 left->op_next = flip;
3737 right->op_next = flop;
3739 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3740 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3741 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3742 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3744 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3745 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3748 if (!flip->op_private || !flop->op_private)
3749 linklist(o); /* blow off optimizer unless constant */
3755 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3759 const bool once = block && block->op_flags & OPf_SPECIAL &&
3760 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3762 PERL_UNUSED_ARG(debuggable);
3765 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3766 return block; /* do {} while 0 does once */
3767 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3768 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3769 expr = newUNOP(OP_DEFINED, 0,
3770 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3771 } else if (expr->op_flags & OPf_KIDS) {
3772 const OP * const k1 = ((UNOP*)expr)->op_first;
3773 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3774 switch (expr->op_type) {
3776 if (k2 && k2->op_type == OP_READLINE
3777 && (k2->op_flags & OPf_STACKED)
3778 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3779 expr = newUNOP(OP_DEFINED, 0, expr);
3783 if (k1->op_type == OP_READDIR
3784 || k1->op_type == OP_GLOB
3785 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3786 || k1->op_type == OP_EACH)
3787 expr = newUNOP(OP_DEFINED, 0, expr);
3793 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3794 * op, in listop. This is wrong. [perl #27024] */
3796 block = newOP(OP_NULL, 0);
3797 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3798 o = new_logop(OP_AND, 0, &expr, &listop);
3801 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3803 if (once && o != listop)
3804 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3807 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3809 o->op_flags |= flags;
3811 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3816 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3817 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3826 PERL_UNUSED_ARG(debuggable);
3829 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3830 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3831 expr = newUNOP(OP_DEFINED, 0,
3832 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3833 } else if (expr->op_flags & OPf_KIDS) {
3834 const OP * const k1 = ((UNOP*)expr)->op_first;
3835 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3836 switch (expr->op_type) {
3838 if (k2 && k2->op_type == OP_READLINE
3839 && (k2->op_flags & OPf_STACKED)
3840 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3841 expr = newUNOP(OP_DEFINED, 0, expr);
3845 if (k1->op_type == OP_READDIR
3846 || k1->op_type == OP_GLOB
3847 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3848 || k1->op_type == OP_EACH)
3849 expr = newUNOP(OP_DEFINED, 0, expr);
3856 block = newOP(OP_NULL, 0);
3857 else if (cont || has_my) {
3858 block = scope(block);
3862 next = LINKLIST(cont);
3865 OP * const unstack = newOP(OP_UNSTACK, 0);
3868 cont = append_elem(OP_LINESEQ, cont, unstack);
3871 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3872 redo = LINKLIST(listop);
3875 PL_copline = (line_t)whileline;
3877 o = new_logop(OP_AND, 0, &expr, &listop);
3878 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3879 op_free(expr); /* oops, it's a while (0) */
3881 return Nullop; /* listop already freed by new_logop */
3884 ((LISTOP*)listop)->op_last->op_next =
3885 (o == listop ? redo : LINKLIST(o));
3891 NewOp(1101,loop,1,LOOP);
3892 loop->op_type = OP_ENTERLOOP;
3893 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3894 loop->op_private = 0;
3895 loop->op_next = (OP*)loop;
3898 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3900 loop->op_redoop = redo;
3901 loop->op_lastop = o;
3902 o->op_private |= loopflags;
3905 loop->op_nextop = next;
3907 loop->op_nextop = o;
3909 o->op_flags |= flags;
3910 o->op_private |= (flags >> 8);
3915 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3920 PADOFFSET padoff = 0;
3925 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3926 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3927 sv->op_type = OP_RV2GV;
3928 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3930 else if (sv->op_type == OP_PADSV) { /* private variable */
3931 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3932 padoff = sv->op_targ;
3937 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3938 padoff = sv->op_targ;
3940 iterflags |= OPf_SPECIAL;
3945 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3948 const I32 offset = pad_findmy("$_");
3949 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3950 sv = newGVOP(OP_GV, 0, PL_defgv);
3956 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3957 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3958 iterflags |= OPf_STACKED;
3960 else if (expr->op_type == OP_NULL &&
3961 (expr->op_flags & OPf_KIDS) &&
3962 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3964 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3965 * set the STACKED flag to indicate that these values are to be
3966 * treated as min/max values by 'pp_iterinit'.
3968 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3969 LOGOP* const range = (LOGOP*) flip->op_first;
3970 OP* const left = range->op_first;
3971 OP* const right = left->op_sibling;
3974 range->op_flags &= ~OPf_KIDS;
3975 range->op_first = Nullop;
3977 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3978 listop->op_first->op_next = range->op_next;
3979 left->op_next = range->op_other;
3980 right->op_next = (OP*)listop;
3981 listop->op_next = listop->op_first;
3984 expr = (OP*)(listop);
3986 iterflags |= OPf_STACKED;
3989 expr = mod(force_list(expr), OP_GREPSTART);
3992 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3993 append_elem(OP_LIST, expr, scalar(sv))));
3994 assert(!loop->op_next);
3995 /* for my $x () sets OPpLVAL_INTRO;
3996 * for our $x () sets OPpOUR_INTRO */
3997 loop->op_private = (U8)iterpflags;
3998 #ifdef PL_OP_SLAB_ALLOC
4001 NewOp(1234,tmp,1,LOOP);
4002 Copy(loop,tmp,1,LISTOP);
4007 Renew(loop, 1, LOOP);
4009 loop->op_targ = padoff;
4010 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4011 PL_copline = forline;
4012 return newSTATEOP(0, label, wop);
4016 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4020 if (type != OP_GOTO || label->op_type == OP_CONST) {
4021 /* "last()" means "last" */
4022 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4023 o = newOP(type, OPf_SPECIAL);
4025 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4026 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4032 /* Check whether it's going to be a goto &function */
4033 if (label->op_type == OP_ENTERSUB
4034 && !(label->op_flags & OPf_STACKED))
4035 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4036 o = newUNOP(type, OPf_STACKED, label);
4038 PL_hints |= HINT_BLOCK_SCOPE;
4043 =for apidoc cv_undef
4045 Clear out all the active components of a CV. This can happen either
4046 by an explicit C<undef &foo>, or by the reference count going to zero.
4047 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4048 children can still follow the full lexical scope chain.
4054 Perl_cv_undef(pTHX_ CV *cv)
4058 if (CvFILE(cv) && !CvXSUB(cv)) {
4059 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4060 Safefree(CvFILE(cv));
4065 if (!CvXSUB(cv) && CvROOT(cv)) {
4067 Perl_croak(aTHX_ "Can't undef active subroutine");
4070 PAD_SAVE_SETNULLPAD();
4072 op_free(CvROOT(cv));
4073 CvROOT(cv) = Nullop;
4074 CvSTART(cv) = Nullop;
4077 SvPOK_off((SV*)cv); /* forget prototype */
4082 /* remove CvOUTSIDE unless this is an undef rather than a free */
4083 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4084 if (!CvWEAKOUTSIDE(cv))
4085 SvREFCNT_dec(CvOUTSIDE(cv));
4086 CvOUTSIDE(cv) = Nullcv;
4089 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4095 /* delete all flags except WEAKOUTSIDE */
4096 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4100 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4102 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4103 SV* const msg = sv_newmortal();
4107 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4108 sv_setpv(msg, "Prototype mismatch:");
4110 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4112 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4114 Perl_sv_catpv(aTHX_ msg, ": none");
4115 sv_catpv(msg, " vs ");
4117 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4119 sv_catpv(msg, "none");
4120 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4124 static void const_sv_xsub(pTHX_ CV* cv);
4128 =head1 Optree Manipulation Functions
4130 =for apidoc cv_const_sv
4132 If C<cv> is a constant sub eligible for inlining. returns the constant
4133 value returned by the sub. Otherwise, returns NULL.
4135 Constant subs can be created with C<newCONSTSUB> or as described in
4136 L<perlsub/"Constant Functions">.
4141 Perl_cv_const_sv(pTHX_ CV *cv)
4143 if (!cv || !CvCONST(cv))
4145 return (SV*)CvXSUBANY(cv).any_ptr;
4148 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4149 * Can be called in 3 ways:
4152 * look for a single OP_CONST with attached value: return the value
4154 * cv && CvCLONE(cv) && !CvCONST(cv)
4156 * examine the clone prototype, and if contains only a single
4157 * OP_CONST referencing a pad const, or a single PADSV referencing
4158 * an outer lexical, return a non-zero value to indicate the CV is
4159 * a candidate for "constizing" at clone time
4163 * We have just cloned an anon prototype that was marked as a const
4164 * candidiate. Try to grab the current value, and in the case of
4165 * PADSV, ignore it if it has multiple references. Return the value.
4169 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4176 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4177 o = cLISTOPo->op_first->op_sibling;
4179 for (; o; o = o->op_next) {
4180 const OPCODE type = o->op_type;
4182 if (sv && o->op_next == o)
4184 if (o->op_next != o) {
4185 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4187 if (type == OP_DBSTATE)
4190 if (type == OP_LEAVESUB || type == OP_RETURN)
4194 if (type == OP_CONST && cSVOPo->op_sv)
4196 else if (cv && type == OP_CONST) {
4197 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4201 else if (cv && type == OP_PADSV) {
4202 if (CvCONST(cv)) { /* newly cloned anon */
4203 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4204 /* the candidate should have 1 ref from this pad and 1 ref
4205 * from the parent */
4206 if (!sv || SvREFCNT(sv) != 2)
4213 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4214 sv = &PL_sv_undef; /* an arbitrary non-null value */
4225 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4227 PERL_UNUSED_ARG(floor);
4237 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4241 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4243 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4247 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4258 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4261 assert(proto->op_type == OP_CONST);
4262 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4267 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4268 SV * const sv = sv_newmortal();
4269 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4270 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4271 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4272 aname = SvPVX_const(sv);
4277 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4278 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4279 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4280 : gv_fetchpv(aname ? aname
4281 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4282 gv_fetch_flags, SVt_PVCV);
4291 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4292 maximum a prototype before. */
4293 if (SvTYPE(gv) > SVt_NULL) {
4294 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4295 && ckWARN_d(WARN_PROTOTYPE))
4297 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4299 cv_ckproto((CV*)gv, NULL, ps);
4302 sv_setpvn((SV*)gv, ps, ps_len);
4304 sv_setiv((SV*)gv, -1);
4305 SvREFCNT_dec(PL_compcv);
4306 cv = PL_compcv = NULL;
4307 PL_sub_generation++;
4311 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4313 #ifdef GV_UNIQUE_CHECK
4314 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4315 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4319 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4322 const_sv = op_const_sv(block, Nullcv);
4325 const bool exists = CvROOT(cv) || CvXSUB(cv);
4327 #ifdef GV_UNIQUE_CHECK
4328 if (exists && GvUNIQUE(gv)) {
4329 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4333 /* if the subroutine doesn't exist and wasn't pre-declared
4334 * with a prototype, assume it will be AUTOLOADed,
4335 * skipping the prototype check
4337 if (exists || SvPOK(cv))
4338 cv_ckproto(cv, gv, ps);
4339 /* already defined (or promised)? */
4340 if (exists || GvASSUMECV(gv)) {
4341 if (!block && !attrs) {
4342 if (CvFLAGS(PL_compcv)) {
4343 /* might have had built-in attrs applied */
4344 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4346 /* just a "sub foo;" when &foo is already defined */
4347 SAVEFREESV(PL_compcv);
4351 if (ckWARN(WARN_REDEFINE)
4353 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4355 const line_t oldline = CopLINE(PL_curcop);
4356 if (PL_copline != NOLINE)
4357 CopLINE_set(PL_curcop, PL_copline);
4358 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4359 CvCONST(cv) ? "Constant subroutine %s redefined"
4360 : "Subroutine %s redefined", name);
4361 CopLINE_set(PL_curcop, oldline);
4369 (void)SvREFCNT_inc(const_sv);
4371 assert(!CvROOT(cv) && !CvCONST(cv));
4372 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4373 CvXSUBANY(cv).any_ptr = const_sv;
4374 CvXSUB(cv) = const_sv_xsub;
4379 cv = newCONSTSUB(NULL, name, const_sv);
4382 SvREFCNT_dec(PL_compcv);
4384 PL_sub_generation++;
4391 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4392 * before we clobber PL_compcv.
4396 /* Might have had built-in attributes applied -- propagate them. */
4397 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4398 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4399 stash = GvSTASH(CvGV(cv));
4400 else if (CvSTASH(cv))
4401 stash = CvSTASH(cv);
4403 stash = PL_curstash;
4406 /* possibly about to re-define existing subr -- ignore old cv */
4407 rcv = (SV*)PL_compcv;
4408 if (name && GvSTASH(gv))
4409 stash = GvSTASH(gv);
4411 stash = PL_curstash;
4413 apply_attrs(stash, rcv, attrs, FALSE);
4415 if (cv) { /* must reuse cv if autoloaded */
4417 /* got here with just attrs -- work done, so bug out */
4418 SAVEFREESV(PL_compcv);
4421 /* transfer PL_compcv to cv */
4423 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4424 if (!CvWEAKOUTSIDE(cv))
4425 SvREFCNT_dec(CvOUTSIDE(cv));
4426 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4427 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4428 CvOUTSIDE(PL_compcv) = 0;
4429 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4430 CvPADLIST(PL_compcv) = 0;
4431 /* inner references to PL_compcv must be fixed up ... */
4432 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4433 /* ... before we throw it away */
4434 SvREFCNT_dec(PL_compcv);
4436 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4437 ++PL_sub_generation;
4444 PL_sub_generation++;
4448 CvFILE_set_from_cop(cv, PL_curcop);
4449 CvSTASH(cv) = PL_curstash;
4452 sv_setpvn((SV*)cv, ps, ps_len);
4454 if (PL_error_count) {
4458 const char *s = strrchr(name, ':');
4460 if (strEQ(s, "BEGIN")) {
4461 const char not_safe[] =
4462 "BEGIN not safe after errors--compilation aborted";
4463 if (PL_in_eval & EVAL_KEEPERR)
4464 Perl_croak(aTHX_ not_safe);
4466 /* force display of errors found but not reported */
4467 sv_catpv(ERRSV, not_safe);
4468 Perl_croak(aTHX_ "%"SVf, ERRSV);
4477 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4478 mod(scalarseq(block), OP_LEAVESUBLV));
4481 /* This makes sub {}; work as expected. */
4482 if (block->op_type == OP_STUB) {
4484 block = newSTATEOP(0, Nullch, 0);
4486 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4488 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4489 OpREFCNT_set(CvROOT(cv), 1);
4490 CvSTART(cv) = LINKLIST(CvROOT(cv));
4491 CvROOT(cv)->op_next = 0;
4492 CALL_PEEP(CvSTART(cv));
4494 /* now that optimizer has done its work, adjust pad values */
4496 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4499 assert(!CvCONST(cv));
4500 if (ps && !*ps && op_const_sv(block, cv))
4504 if (name || aname) {
4506 const char *tname = (name ? name : aname);
4508 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4509 SV * const sv = NEWSV(0,0);
4510 SV * const tmpstr = sv_newmortal();
4511 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4514 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4516 (long)PL_subline, (long)CopLINE(PL_curcop));
4517 gv_efullname3(tmpstr, gv, Nullch);
4518 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4519 hv = GvHVn(db_postponed);
4520 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4521 CV * const pcv = GvCV(db_postponed);
4527 call_sv((SV*)pcv, G_DISCARD);
4532 if ((s = strrchr(tname,':')))
4537 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4540 if (strEQ(s, "BEGIN") && !PL_error_count) {
4542 const I32 oldscope = PL_scopestack_ix;
4544 PUSHSTACKi(PERLSI_REQUIRE);
4545 SAVECOPFILE(&PL_compiling);
4546 SAVECOPLINE(&PL_compiling);
4549 PL_beginav = newAV();
4550 DEBUG_x( dump_sub(gv) );
4551 av_push(PL_beginav, (SV*)cv);
4552 GvCV(gv) = 0; /* cv has been hijacked */
4553 call_list(oldscope, PL_beginav);
4555 PL_curcop = &PL_compiling;
4556 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4560 else if (strEQ(s, "END") && !PL_error_count) {
4563 DEBUG_x( dump_sub(gv) );
4564 av_unshift(PL_endav, 1);
4565 av_store(PL_endav, 0, (SV*)cv);
4566 GvCV(gv) = 0; /* cv has been hijacked */
4568 else if (strEQ(s, "CHECK") && !PL_error_count) {
4570 PL_checkav = newAV();
4571 DEBUG_x( dump_sub(gv) );
4572 if (PL_main_start && ckWARN(WARN_VOID))
4573 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4574 av_unshift(PL_checkav, 1);
4575 av_store(PL_checkav, 0, (SV*)cv);
4576 GvCV(gv) = 0; /* cv has been hijacked */
4578 else if (strEQ(s, "INIT") && !PL_error_count) {
4580 PL_initav = newAV();
4581 DEBUG_x( dump_sub(gv) );
4582 if (PL_main_start && ckWARN(WARN_VOID))
4583 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4584 av_push(PL_initav, (SV*)cv);
4585 GvCV(gv) = 0; /* cv has been hijacked */
4590 PL_copline = NOLINE;
4595 /* XXX unsafe for threads if eval_owner isn't held */
4597 =for apidoc newCONSTSUB
4599 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4600 eligible for inlining at compile-time.
4606 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4613 SAVECOPLINE(PL_curcop);
4614 CopLINE_set(PL_curcop, PL_copline);
4617 PL_hints &= ~HINT_BLOCK_SCOPE;
4620 SAVESPTR(PL_curstash);
4621 SAVECOPSTASH(PL_curcop);
4622 PL_curstash = stash;
4623 CopSTASH_set(PL_curcop,stash);
4626 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4627 CvXSUBANY(cv).any_ptr = sv;
4629 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4632 CopSTASH_free(PL_curcop);
4640 =for apidoc U||newXS
4642 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4648 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4650 GV * const gv = gv_fetchpv(name ? name :
4651 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4652 GV_ADDMULTI, SVt_PVCV);
4656 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4658 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4660 /* just a cached method */
4664 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4665 /* already defined (or promised) */
4666 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4667 if (ckWARN(WARN_REDEFINE)) {
4668 GV * const gvcv = CvGV(cv);
4670 HV * const stash = GvSTASH(gvcv);
4672 const char *name = HvNAME_get(stash);
4673 if ( strEQ(name,"autouse") ) {
4674 const line_t oldline = CopLINE(PL_curcop);
4675 if (PL_copline != NOLINE)
4676 CopLINE_set(PL_curcop, PL_copline);
4677 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4678 CvCONST(cv) ? "Constant subroutine %s redefined"
4679 : "Subroutine %s redefined"
4681 CopLINE_set(PL_curcop, oldline);
4691 if (cv) /* must reuse cv if autoloaded */
4694 cv = (CV*)NEWSV(1105,0);
4695 sv_upgrade((SV *)cv, SVt_PVCV);
4699 PL_sub_generation++;
4703 (void)gv_fetchfile(filename);
4704 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4705 an external constant string */
4706 CvXSUB(cv) = subaddr;
4709 const char *s = strrchr(name,':');
4715 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4718 if (strEQ(s, "BEGIN")) {
4720 PL_beginav = newAV();
4721 av_push(PL_beginav, (SV*)cv);
4722 GvCV(gv) = 0; /* cv has been hijacked */
4724 else if (strEQ(s, "END")) {
4727 av_unshift(PL_endav, 1);
4728 av_store(PL_endav, 0, (SV*)cv);
4729 GvCV(gv) = 0; /* cv has been hijacked */
4731 else if (strEQ(s, "CHECK")) {
4733 PL_checkav = newAV();
4734 if (PL_main_start && ckWARN(WARN_VOID))
4735 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4736 av_unshift(PL_checkav, 1);
4737 av_store(PL_checkav, 0, (SV*)cv);
4738 GvCV(gv) = 0; /* cv has been hijacked */
4740 else if (strEQ(s, "INIT")) {
4742 PL_initav = newAV();
4743 if (PL_main_start && ckWARN(WARN_VOID))
4744 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4745 av_push(PL_initav, (SV*)cv);
4746 GvCV(gv) = 0; /* cv has been hijacked */
4757 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4763 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4765 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4767 #ifdef GV_UNIQUE_CHECK
4769 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4773 if ((cv = GvFORM(gv))) {
4774 if (ckWARN(WARN_REDEFINE)) {
4775 const line_t oldline = CopLINE(PL_curcop);
4776 if (PL_copline != NOLINE)
4777 CopLINE_set(PL_curcop, PL_copline);
4778 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4779 o ? "Format %"SVf" redefined"
4780 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4781 CopLINE_set(PL_curcop, oldline);
4788 CvFILE_set_from_cop(cv, PL_curcop);
4791 pad_tidy(padtidy_FORMAT);
4792 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4793 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4794 OpREFCNT_set(CvROOT(cv), 1);
4795 CvSTART(cv) = LINKLIST(CvROOT(cv));
4796 CvROOT(cv)->op_next = 0;
4797 CALL_PEEP(CvSTART(cv));
4799 PL_copline = NOLINE;
4804 Perl_newANONLIST(pTHX_ OP *o)
4806 return newUNOP(OP_REFGEN, 0,
4807 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4811 Perl_newANONHASH(pTHX_ OP *o)
4813 return newUNOP(OP_REFGEN, 0,
4814 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4818 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4820 return newANONATTRSUB(floor, proto, Nullop, block);
4824 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4826 return newUNOP(OP_REFGEN, 0,
4827 newSVOP(OP_ANONCODE, 0,
4828 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4832 Perl_oopsAV(pTHX_ OP *o)
4835 switch (o->op_type) {
4837 o->op_type = OP_PADAV;
4838 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4839 return ref(o, OP_RV2AV);
4842 o->op_type = OP_RV2AV;
4843 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4848 if (ckWARN_d(WARN_INTERNAL))
4849 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4856 Perl_oopsHV(pTHX_ OP *o)
4859 switch (o->op_type) {
4862 o->op_type = OP_PADHV;
4863 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4864 return ref(o, OP_RV2HV);
4868 o->op_type = OP_RV2HV;
4869 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4874 if (ckWARN_d(WARN_INTERNAL))
4875 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4882 Perl_newAVREF(pTHX_ OP *o)
4885 if (o->op_type == OP_PADANY) {
4886 o->op_type = OP_PADAV;
4887 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4890 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4891 && ckWARN(WARN_DEPRECATED)) {
4892 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4893 "Using an array as a reference is deprecated");
4895 return newUNOP(OP_RV2AV, 0, scalar(o));
4899 Perl_newGVREF(pTHX_ I32 type, OP *o)
4901 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4902 return newUNOP(OP_NULL, 0, o);
4903 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4907 Perl_newHVREF(pTHX_ OP *o)
4910 if (o->op_type == OP_PADANY) {
4911 o->op_type = OP_PADHV;
4912 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4915 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4916 && ckWARN(WARN_DEPRECATED)) {
4917 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4918 "Using a hash as a reference is deprecated");
4920 return newUNOP(OP_RV2HV, 0, scalar(o));
4924 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4926 return newUNOP(OP_RV2CV, flags, scalar(o));
4930 Perl_newSVREF(pTHX_ OP *o)
4933 if (o->op_type == OP_PADANY) {
4934 o->op_type = OP_PADSV;
4935 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4938 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4939 o->op_flags |= OPpDONE_SVREF;
4942 return newUNOP(OP_RV2SV, 0, scalar(o));
4945 /* Check routines. See the comments at the top of this file for details
4946 * on when these are called */
4949 Perl_ck_anoncode(pTHX_ OP *o)
4951 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4952 cSVOPo->op_sv = Nullsv;
4957 Perl_ck_bitop(pTHX_ OP *o)
4959 #define OP_IS_NUMCOMPARE(op) \
4960 ((op) == OP_LT || (op) == OP_I_LT || \
4961 (op) == OP_GT || (op) == OP_I_GT || \
4962 (op) == OP_LE || (op) == OP_I_LE || \
4963 (op) == OP_GE || (op) == OP_I_GE || \
4964 (op) == OP_EQ || (op) == OP_I_EQ || \
4965 (op) == OP_NE || (op) == OP_I_NE || \
4966 (op) == OP_NCMP || (op) == OP_I_NCMP)
4967 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4968 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4969 && (o->op_type == OP_BIT_OR
4970 || o->op_type == OP_BIT_AND
4971 || o->op_type == OP_BIT_XOR))
4973 const OP * const left = cBINOPo->op_first;
4974 const OP * const right = left->op_sibling;
4975 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4976 (left->op_flags & OPf_PARENS) == 0) ||
4977 (OP_IS_NUMCOMPARE(right->op_type) &&
4978 (right->op_flags & OPf_PARENS) == 0))
4979 if (ckWARN(WARN_PRECEDENCE))
4980 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4981 "Possible precedence problem on bitwise %c operator",
4982 o->op_type == OP_BIT_OR ? '|'
4983 : o->op_type == OP_BIT_AND ? '&' : '^'
4990 Perl_ck_concat(pTHX_ OP *o)
4992 const OP *kid = cUNOPo->op_first;
4993 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4994 !(kUNOP->op_first->op_flags & OPf_MOD))
4995 o->op_flags |= OPf_STACKED;
5000 Perl_ck_spair(pTHX_ OP *o)
5003 if (o->op_flags & OPf_KIDS) {
5006 const OPCODE type = o->op_type;
5007 o = modkids(ck_fun(o), type);
5008 kid = cUNOPo->op_first;
5009 newop = kUNOP->op_first->op_sibling;
5011 (newop->op_sibling ||
5012 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5013 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5014 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5018 op_free(kUNOP->op_first);
5019 kUNOP->op_first = newop;
5021 o->op_ppaddr = PL_ppaddr[++o->op_type];
5026 Perl_ck_delete(pTHX_ OP *o)
5030 if (o->op_flags & OPf_KIDS) {
5031 OP * const kid = cUNOPo->op_first;
5032 switch (kid->op_type) {
5034 o->op_flags |= OPf_SPECIAL;
5037 o->op_private |= OPpSLICE;
5040 o->op_flags |= OPf_SPECIAL;
5045 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5054 Perl_ck_die(pTHX_ OP *o)
5057 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5063 Perl_ck_eof(pTHX_ OP *o)
5065 const I32 type = o->op_type;
5067 if (o->op_flags & OPf_KIDS) {
5068 if (cLISTOPo->op_first->op_type == OP_STUB) {
5070 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5078 Perl_ck_eval(pTHX_ OP *o)
5081 PL_hints |= HINT_BLOCK_SCOPE;
5082 if (o->op_flags & OPf_KIDS) {
5083 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5086 o->op_flags &= ~OPf_KIDS;
5089 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5092 cUNOPo->op_first = 0;
5095 NewOp(1101, enter, 1, LOGOP);
5096 enter->op_type = OP_ENTERTRY;
5097 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5098 enter->op_private = 0;
5100 /* establish postfix order */
5101 enter->op_next = (OP*)enter;
5103 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5104 o->op_type = OP_LEAVETRY;
5105 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5106 enter->op_other = o;
5116 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5118 o->op_targ = (PADOFFSET)PL_hints;
5123 Perl_ck_exit(pTHX_ OP *o)
5126 HV * const table = GvHV(PL_hintgv);
5128 SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5129 if (svp && *svp && SvTRUE(*svp))
5130 o->op_private |= OPpEXIT_VMSISH;
5132 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5138 Perl_ck_exec(pTHX_ OP *o)
5140 if (o->op_flags & OPf_STACKED) {
5143 kid = cUNOPo->op_first->op_sibling;
5144 if (kid->op_type == OP_RV2GV)
5153 Perl_ck_exists(pTHX_ OP *o)
5156 if (o->op_flags & OPf_KIDS) {
5157 OP * const kid = cUNOPo->op_first;
5158 if (kid->op_type == OP_ENTERSUB) {
5159 (void) ref(kid, o->op_type);
5160 if (kid->op_type != OP_RV2CV && !PL_error_count)
5161 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5163 o->op_private |= OPpEXISTS_SUB;
5165 else if (kid->op_type == OP_AELEM)
5166 o->op_flags |= OPf_SPECIAL;
5167 else if (kid->op_type != OP_HELEM)
5168 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5176 Perl_ck_rvconst(pTHX_ register OP *o)
5179 SVOP *kid = (SVOP*)cUNOPo->op_first;
5181 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5182 if (kid->op_type == OP_CONST) {
5185 SV * const kidsv = kid->op_sv;
5187 /* Is it a constant from cv_const_sv()? */
5188 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5189 SV *rsv = SvRV(kidsv);
5190 const int svtype = SvTYPE(rsv);
5191 const char *badtype = Nullch;
5193 switch (o->op_type) {
5195 if (svtype > SVt_PVMG)
5196 badtype = "a SCALAR";
5199 if (svtype != SVt_PVAV)
5200 badtype = "an ARRAY";
5203 if (svtype != SVt_PVHV)
5207 if (svtype != SVt_PVCV)
5212 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5215 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5216 const char *badthing = Nullch;
5217 switch (o->op_type) {
5219 badthing = "a SCALAR";
5222 badthing = "an ARRAY";
5225 badthing = "a HASH";
5230 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5234 * This is a little tricky. We only want to add the symbol if we
5235 * didn't add it in the lexer. Otherwise we get duplicate strict
5236 * warnings. But if we didn't add it in the lexer, we must at
5237 * least pretend like we wanted to add it even if it existed before,
5238 * or we get possible typo warnings. OPpCONST_ENTERED says
5239 * whether the lexer already added THIS instance of this symbol.
5241 iscv = (o->op_type == OP_RV2CV) * 2;
5243 gv = gv_fetchsv(kidsv,
5244 iscv | !(kid->op_private & OPpCONST_ENTERED),
5247 : o->op_type == OP_RV2SV
5249 : o->op_type == OP_RV2AV
5251 : o->op_type == OP_RV2HV
5254 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5256 kid->op_type = OP_GV;
5257 SvREFCNT_dec(kid->op_sv);
5259 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5260 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5261 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5263 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5265 kid->op_sv = SvREFCNT_inc(gv);
5267 kid->op_private = 0;
5268 kid->op_ppaddr = PL_ppaddr[OP_GV];
5275 Perl_ck_ftst(pTHX_ OP *o)
5278 const I32 type = o->op_type;
5280 if (o->op_flags & OPf_REF) {
5283 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5284 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5286 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5287 OP * const newop = newGVOP(type, OPf_REF,
5288 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5294 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5295 OP_IS_FILETEST_ACCESS(o))
5296 o->op_private |= OPpFT_ACCESS;
5298 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5299 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5300 o->op_private |= OPpFT_STACKED;
5304 if (type == OP_FTTTY)
5305 o = newGVOP(type, OPf_REF, PL_stdingv);
5307 o = newUNOP(type, 0, newDEFSVOP());
5313 Perl_ck_fun(pTHX_ OP *o)
5315 const int type = o->op_type;
5316 register I32 oa = PL_opargs[type] >> OASHIFT;
5318 if (o->op_flags & OPf_STACKED) {
5319 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5322 return no_fh_allowed(o);
5325 if (o->op_flags & OPf_KIDS) {
5326 OP **tokid = &cLISTOPo->op_first;
5327 register OP *kid = cLISTOPo->op_first;
5331 if (kid->op_type == OP_PUSHMARK ||
5332 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5334 tokid = &kid->op_sibling;
5335 kid = kid->op_sibling;
5337 if (!kid && PL_opargs[type] & OA_DEFGV)
5338 *tokid = kid = newDEFSVOP();
5342 sibl = kid->op_sibling;
5345 /* list seen where single (scalar) arg expected? */
5346 if (numargs == 1 && !(oa >> 4)
5347 && kid->op_type == OP_LIST && type != OP_SCALAR)
5349 return too_many_arguments(o,PL_op_desc[type]);
5362 if ((type == OP_PUSH || type == OP_UNSHIFT)
5363 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5364 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5365 "Useless use of %s with no values",
5368 if (kid->op_type == OP_CONST &&
5369 (kid->op_private & OPpCONST_BARE))
5371 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5372 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5373 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5374 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5375 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5376 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5379 kid->op_sibling = sibl;
5382 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5383 bad_type(numargs, "array", PL_op_desc[type], kid);
5387 if (kid->op_type == OP_CONST &&
5388 (kid->op_private & OPpCONST_BARE))
5390 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5391 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5392 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5393 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5394 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5395 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5398 kid->op_sibling = sibl;
5401 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5402 bad_type(numargs, "hash", PL_op_desc[type], kid);
5407 OP * const newop = newUNOP(OP_NULL, 0, kid);
5408 kid->op_sibling = 0;
5410 newop->op_next = newop;
5412 kid->op_sibling = sibl;
5417 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5418 if (kid->op_type == OP_CONST &&
5419 (kid->op_private & OPpCONST_BARE))
5421 OP *newop = newGVOP(OP_GV, 0,
5422 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5423 if (!(o->op_private & 1) && /* if not unop */
5424 kid == cLISTOPo->op_last)
5425 cLISTOPo->op_last = newop;
5429 else if (kid->op_type == OP_READLINE) {
5430 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5431 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5434 I32 flags = OPf_SPECIAL;
5438 /* is this op a FH constructor? */
5439 if (is_handle_constructor(o,numargs)) {
5440 const char *name = Nullch;
5444 /* Set a flag to tell rv2gv to vivify
5445 * need to "prove" flag does not mean something
5446 * else already - NI-S 1999/05/07
5449 if (kid->op_type == OP_PADSV) {
5450 name = PAD_COMPNAME_PV(kid->op_targ);
5451 /* SvCUR of a pad namesv can't be trusted
5452 * (see PL_generation), so calc its length
5458 else if (kid->op_type == OP_RV2SV
5459 && kUNOP->op_first->op_type == OP_GV)
5461 GV *gv = cGVOPx_gv(kUNOP->op_first);
5463 len = GvNAMELEN(gv);
5465 else if (kid->op_type == OP_AELEM
5466 || kid->op_type == OP_HELEM)
5468 OP *op = ((BINOP*)kid)->op_first;
5471 SV *tmpstr = Nullsv;
5472 const char * const a =
5473 kid->op_type == OP_AELEM ?
5475 if (((op->op_type == OP_RV2AV) ||
5476 (op->op_type == OP_RV2HV)) &&
5477 (op = ((UNOP*)op)->op_first) &&
5478 (op->op_type == OP_GV)) {
5479 /* packagevar $a[] or $h{} */
5480 GV * const gv = cGVOPx_gv(op);
5488 else if (op->op_type == OP_PADAV
5489 || op->op_type == OP_PADHV) {
5490 /* lexicalvar $a[] or $h{} */
5491 const char * const padname =
5492 PAD_COMPNAME_PV(op->op_targ);
5501 name = SvPV_const(tmpstr, len);
5506 name = "__ANONIO__";
5513 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5514 namesv = PAD_SVl(targ);
5515 SvUPGRADE(namesv, SVt_PV);
5517 sv_setpvn(namesv, "$", 1);
5518 sv_catpvn(namesv, name, len);
5521 kid->op_sibling = 0;
5522 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5523 kid->op_targ = targ;
5524 kid->op_private |= priv;
5526 kid->op_sibling = sibl;
5532 mod(scalar(kid), type);
5536 tokid = &kid->op_sibling;
5537 kid = kid->op_sibling;
5539 o->op_private |= numargs;
5541 return too_many_arguments(o,OP_DESC(o));
5544 else if (PL_opargs[type] & OA_DEFGV) {
5546 return newUNOP(type, 0, newDEFSVOP());
5550 while (oa & OA_OPTIONAL)
5552 if (oa && oa != OA_LIST)
5553 return too_few_arguments(o,OP_DESC(o));
5559 Perl_ck_glob(pTHX_ OP *o)
5565 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5566 append_elem(OP_GLOB, o, newDEFSVOP());
5568 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5569 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5571 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5574 #if !defined(PERL_EXTERNAL_GLOB)
5575 /* XXX this can be tightened up and made more failsafe. */
5576 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5579 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5580 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5581 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5582 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5583 GvCV(gv) = GvCV(glob_gv);
5584 (void)SvREFCNT_inc((SV*)GvCV(gv));
5585 GvIMPORTED_CV_on(gv);
5588 #endif /* PERL_EXTERNAL_GLOB */
5590 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5591 append_elem(OP_GLOB, o,
5592 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5593 o->op_type = OP_LIST;
5594 o->op_ppaddr = PL_ppaddr[OP_LIST];
5595 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5596 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5597 cLISTOPo->op_first->op_targ = 0;
5598 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5599 append_elem(OP_LIST, o,
5600 scalar(newUNOP(OP_RV2CV, 0,
5601 newGVOP(OP_GV, 0, gv)))));
5602 o = newUNOP(OP_NULL, 0, ck_subr(o));
5603 o->op_targ = OP_GLOB; /* hint at what it used to be */
5606 gv = newGVgen("main");
5608 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5614 Perl_ck_grep(pTHX_ OP *o)
5619 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5622 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5623 NewOp(1101, gwop, 1, LOGOP);
5625 if (o->op_flags & OPf_STACKED) {
5628 kid = cLISTOPo->op_first->op_sibling;
5629 if (!cUNOPx(kid)->op_next)
5630 Perl_croak(aTHX_ "panic: ck_grep");
5631 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5634 kid->op_next = (OP*)gwop;
5635 o->op_flags &= ~OPf_STACKED;
5637 kid = cLISTOPo->op_first->op_sibling;
5638 if (type == OP_MAPWHILE)
5645 kid = cLISTOPo->op_first->op_sibling;
5646 if (kid->op_type != OP_NULL)
5647 Perl_croak(aTHX_ "panic: ck_grep");
5648 kid = kUNOP->op_first;
5650 gwop->op_type = type;
5651 gwop->op_ppaddr = PL_ppaddr[type];
5652 gwop->op_first = listkids(o);
5653 gwop->op_flags |= OPf_KIDS;
5654 gwop->op_other = LINKLIST(kid);
5655 kid->op_next = (OP*)gwop;
5656 offset = pad_findmy("$_");
5657 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5658 o->op_private = gwop->op_private = 0;
5659 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5662 o->op_private = gwop->op_private = OPpGREP_LEX;
5663 gwop->op_targ = o->op_targ = offset;
5666 kid = cLISTOPo->op_first->op_sibling;
5667 if (!kid || !kid->op_sibling)
5668 return too_few_arguments(o,OP_DESC(o));
5669 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5670 mod(kid, OP_GREPSTART);
5676 Perl_ck_index(pTHX_ OP *o)
5678 if (o->op_flags & OPf_KIDS) {
5679 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5681 kid = kid->op_sibling; /* get past "big" */
5682 if (kid && kid->op_type == OP_CONST)
5683 fbm_compile(((SVOP*)kid)->op_sv, 0);
5689 Perl_ck_lengthconst(pTHX_ OP *o)
5691 /* XXX length optimization goes here */
5696 Perl_ck_lfun(pTHX_ OP *o)
5698 const OPCODE type = o->op_type;
5699 return modkids(ck_fun(o), type);
5703 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5705 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5706 switch (cUNOPo->op_first->op_type) {
5708 /* This is needed for
5709 if (defined %stash::)
5710 to work. Do not break Tk.
5712 break; /* Globals via GV can be undef */
5714 case OP_AASSIGN: /* Is this a good idea? */
5715 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5716 "defined(@array) is deprecated");
5717 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5718 "\t(Maybe you should just omit the defined()?)\n");
5721 /* This is needed for
5722 if (defined %stash::)
5723 to work. Do not break Tk.
5725 break; /* Globals via GV can be undef */
5727 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5728 "defined(%%hash) is deprecated");
5729 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5730 "\t(Maybe you should just omit the defined()?)\n");
5741 Perl_ck_rfun(pTHX_ OP *o)
5743 const OPCODE type = o->op_type;
5744 return refkids(ck_fun(o), type);
5748 Perl_ck_listiob(pTHX_ OP *o)
5752 kid = cLISTOPo->op_first;
5755 kid = cLISTOPo->op_first;
5757 if (kid->op_type == OP_PUSHMARK)
5758 kid = kid->op_sibling;
5759 if (kid && o->op_flags & OPf_STACKED)
5760 kid = kid->op_sibling;
5761 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5762 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5763 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5764 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5765 cLISTOPo->op_first->op_sibling = kid;
5766 cLISTOPo->op_last = kid;
5767 kid = kid->op_sibling;
5772 append_elem(o->op_type, o, newDEFSVOP());
5778 Perl_ck_sassign(pTHX_ OP *o)
5780 OP *kid = cLISTOPo->op_first;
5781 /* has a disposable target? */
5782 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5783 && !(kid->op_flags & OPf_STACKED)
5784 /* Cannot steal the second time! */
5785 && !(kid->op_private & OPpTARGET_MY))
5787 OP * const kkid = kid->op_sibling;
5789 /* Can just relocate the target. */
5790 if (kkid && kkid->op_type == OP_PADSV
5791 && !(kkid->op_private & OPpLVAL_INTRO))
5793 kid->op_targ = kkid->op_targ;
5795 /* Now we do not need PADSV and SASSIGN. */
5796 kid->op_sibling = o->op_sibling; /* NULL */
5797 cLISTOPo->op_first = NULL;
5800 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5804 /* optimise C<my $x = undef> to C<my $x> */
5805 if (kid->op_type == OP_UNDEF) {
5806 OP * const kkid = kid->op_sibling;
5807 if (kkid && kkid->op_type == OP_PADSV
5808 && (kkid->op_private & OPpLVAL_INTRO))
5810 cLISTOPo->op_first = NULL;
5811 kid->op_sibling = NULL;
5821 Perl_ck_match(pTHX_ OP *o)
5823 if (o->op_type != OP_QR) {
5824 const I32 offset = pad_findmy("$_");
5825 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5826 o->op_targ = offset;
5827 o->op_private |= OPpTARGET_MY;
5830 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5831 o->op_private |= OPpRUNTIME;
5836 Perl_ck_method(pTHX_ OP *o)
5838 OP * const kid = cUNOPo->op_first;
5839 if (kid->op_type == OP_CONST) {
5840 SV* sv = kSVOP->op_sv;
5841 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5843 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5844 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5847 kSVOP->op_sv = Nullsv;
5849 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5858 Perl_ck_null(pTHX_ OP *o)
5864 Perl_ck_open(pTHX_ OP *o)
5866 HV * const table = GvHV(PL_hintgv);
5868 SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
5870 const I32 mode = mode_from_discipline(*svp);
5871 if (mode & O_BINARY)
5872 o->op_private |= OPpOPEN_IN_RAW;
5873 else if (mode & O_TEXT)
5874 o->op_private |= OPpOPEN_IN_CRLF;
5877 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5879 const I32 mode = mode_from_discipline(*svp);
5880 if (mode & O_BINARY)
5881 o->op_private |= OPpOPEN_OUT_RAW;
5882 else if (mode & O_TEXT)
5883 o->op_private |= OPpOPEN_OUT_CRLF;
5886 if (o->op_type == OP_BACKTICK)
5889 /* In case of three-arg dup open remove strictness
5890 * from the last arg if it is a bareword. */
5891 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
5892 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
5896 if ((last->op_type == OP_CONST) && /* The bareword. */
5897 (last->op_private & OPpCONST_BARE) &&
5898 (last->op_private & OPpCONST_STRICT) &&
5899 (oa = first->op_sibling) && /* The fh. */
5900 (oa = oa->op_sibling) && /* The mode. */
5901 (oa->op_type == OP_CONST) &&
5902 SvPOK(((SVOP*)oa)->op_sv) &&
5903 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5904 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5905 (last == oa->op_sibling)) /* The bareword. */
5906 last->op_private &= ~OPpCONST_STRICT;
5912 Perl_ck_repeat(pTHX_ OP *o)
5914 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5915 o->op_private |= OPpREPEAT_DOLIST;
5916 cBINOPo->op_first = force_list(cBINOPo->op_first);
5924 Perl_ck_require(pTHX_ OP *o)
5928 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5929 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5931 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5932 SV * const sv = kid->op_sv;
5933 U32 was_readonly = SvREADONLY(sv);
5938 sv_force_normal_flags(sv, 0);
5939 assert(!SvREADONLY(sv));
5946 for (s = SvPVX(sv); *s; s++) {
5947 if (*s == ':' && s[1] == ':') {
5948 const STRLEN len = strlen(s+2)+1;
5950 Move(s+2, s+1, len, char);
5951 SvCUR_set(sv, SvCUR(sv) - 1);
5954 sv_catpvn(sv, ".pm", 3);
5955 SvFLAGS(sv) |= was_readonly;
5959 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
5960 /* handle override, if any */
5961 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5962 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5963 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
5964 gv = gvp ? *gvp : Nullgv;
5968 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5969 OP * const kid = cUNOPo->op_first;
5970 cUNOPo->op_first = 0;
5972 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5973 append_elem(OP_LIST, kid,
5974 scalar(newUNOP(OP_RV2CV, 0,
5983 Perl_ck_return(pTHX_ OP *o)
5985 if (CvLVALUE(PL_compcv)) {
5987 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5988 mod(kid, OP_LEAVESUBLV);
5994 Perl_ck_select(pTHX_ OP *o)
5998 if (o->op_flags & OPf_KIDS) {
5999 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6000 if (kid && kid->op_sibling) {
6001 o->op_type = OP_SSELECT;
6002 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6004 return fold_constants(o);
6008 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6009 if (kid && kid->op_type == OP_RV2GV)
6010 kid->op_private &= ~HINT_STRICT_REFS;
6015 Perl_ck_shift(pTHX_ OP *o)
6017 const I32 type = o->op_type;
6019 if (!(o->op_flags & OPf_KIDS)) {
6023 argop = newUNOP(OP_RV2AV, 0,
6024 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6025 return newUNOP(type, 0, scalar(argop));
6027 return scalar(modkids(ck_fun(o), type));
6031 Perl_ck_sort(pTHX_ OP *o)
6035 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6037 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6038 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6040 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6042 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6044 if (kid->op_type == OP_SCOPE) {
6048 else if (kid->op_type == OP_LEAVE) {
6049 if (o->op_type == OP_SORT) {
6050 op_null(kid); /* wipe out leave */
6053 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6054 if (k->op_next == kid)
6056 /* don't descend into loops */
6057 else if (k->op_type == OP_ENTERLOOP
6058 || k->op_type == OP_ENTERITER)
6060 k = cLOOPx(k)->op_lastop;
6065 kid->op_next = 0; /* just disconnect the leave */
6066 k = kLISTOP->op_first;
6071 if (o->op_type == OP_SORT) {
6072 /* provide scalar context for comparison function/block */
6078 o->op_flags |= OPf_SPECIAL;
6080 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6083 firstkid = firstkid->op_sibling;
6086 /* provide list context for arguments */
6087 if (o->op_type == OP_SORT)
6094 S_simplify_sort(pTHX_ OP *o)
6096 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6101 if (!(o->op_flags & OPf_STACKED))
6103 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6104 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6105 kid = kUNOP->op_first; /* get past null */
6106 if (kid->op_type != OP_SCOPE)
6108 kid = kLISTOP->op_last; /* get past scope */
6109 switch(kid->op_type) {
6117 k = kid; /* remember this node*/
6118 if (kBINOP->op_first->op_type != OP_RV2SV)
6120 kid = kBINOP->op_first; /* get past cmp */
6121 if (kUNOP->op_first->op_type != OP_GV)
6123 kid = kUNOP->op_first; /* get past rv2sv */
6125 if (GvSTASH(gv) != PL_curstash)
6127 gvname = GvNAME(gv);
6128 if (*gvname == 'a' && gvname[1] == '\0')
6130 else if (*gvname == 'b' && gvname[1] == '\0')
6135 kid = k; /* back to cmp */
6136 if (kBINOP->op_last->op_type != OP_RV2SV)
6138 kid = kBINOP->op_last; /* down to 2nd arg */
6139 if (kUNOP->op_first->op_type != OP_GV)
6141 kid = kUNOP->op_first; /* get past rv2sv */
6143 if (GvSTASH(gv) != PL_curstash)
6145 gvname = GvNAME(gv);
6147 ? !(*gvname == 'a' && gvname[1] == '\0')
6148 : !(*gvname == 'b' && gvname[1] == '\0'))
6150 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6152 o->op_private |= OPpSORT_DESCEND;
6153 if (k->op_type == OP_NCMP)
6154 o->op_private |= OPpSORT_NUMERIC;
6155 if (k->op_type == OP_I_NCMP)
6156 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6157 kid = cLISTOPo->op_first->op_sibling;
6158 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6159 op_free(kid); /* then delete it */
6163 Perl_ck_split(pTHX_ OP *o)
6168 if (o->op_flags & OPf_STACKED)
6169 return no_fh_allowed(o);
6171 kid = cLISTOPo->op_first;
6172 if (kid->op_type != OP_NULL)
6173 Perl_croak(aTHX_ "panic: ck_split");
6174 kid = kid->op_sibling;
6175 op_free(cLISTOPo->op_first);
6176 cLISTOPo->op_first = kid;
6178 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6179 cLISTOPo->op_last = kid; /* There was only one element previously */
6182 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6183 OP * const sibl = kid->op_sibling;
6184 kid->op_sibling = 0;
6185 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6186 if (cLISTOPo->op_first == cLISTOPo->op_last)
6187 cLISTOPo->op_last = kid;
6188 cLISTOPo->op_first = kid;
6189 kid->op_sibling = sibl;
6192 kid->op_type = OP_PUSHRE;
6193 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6195 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6196 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6197 "Use of /g modifier is meaningless in split");
6200 if (!kid->op_sibling)
6201 append_elem(OP_SPLIT, o, newDEFSVOP());
6203 kid = kid->op_sibling;
6206 if (!kid->op_sibling)
6207 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6209 kid = kid->op_sibling;
6212 if (kid->op_sibling)
6213 return too_many_arguments(o,OP_DESC(o));
6219 Perl_ck_join(pTHX_ OP *o)
6221 const OP * const kid = cLISTOPo->op_first->op_sibling;
6222 if (kid && kid->op_type == OP_MATCH) {
6223 if (ckWARN(WARN_SYNTAX)) {
6224 const REGEXP *re = PM_GETRE(kPMOP);
6225 const char *pmstr = re ? re->precomp : "STRING";
6226 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6227 "/%s/ should probably be written as \"%s\"",
6235 Perl_ck_subr(pTHX_ OP *o)
6237 OP *prev = ((cUNOPo->op_first->op_sibling)
6238 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6239 OP *o2 = prev->op_sibling;
6246 I32 contextclass = 0;
6250 o->op_private |= OPpENTERSUB_HASTARG;
6251 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6252 if (cvop->op_type == OP_RV2CV) {
6254 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6255 op_null(cvop); /* disable rv2cv */
6256 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6257 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6258 GV *gv = cGVOPx_gv(tmpop);
6261 tmpop->op_private |= OPpEARLY_CV;
6264 namegv = CvANON(cv) ? gv : CvGV(cv);
6265 proto = SvPV_nolen((SV*)cv);
6267 if (CvASSERTION(cv)) {
6268 if (PL_hints & HINT_ASSERTING) {
6269 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6270 o->op_private |= OPpENTERSUB_DB;
6274 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6275 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6276 "Impossible to activate assertion call");
6283 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6284 if (o2->op_type == OP_CONST)
6285 o2->op_private &= ~OPpCONST_STRICT;
6286 else if (o2->op_type == OP_LIST) {
6287 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6288 if (o && o->op_type == OP_CONST)
6289 o->op_private &= ~OPpCONST_STRICT;
6292 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6293 if (PERLDB_SUB && PL_curstash != PL_debstash)
6294 o->op_private |= OPpENTERSUB_DB;
6295 while (o2 != cvop) {
6299 return too_many_arguments(o, gv_ename(namegv));
6317 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6319 arg == 1 ? "block or sub {}" : "sub {}",
6320 gv_ename(namegv), o2);
6323 /* '*' allows any scalar type, including bareword */
6326 if (o2->op_type == OP_RV2GV)
6327 goto wrapref; /* autoconvert GLOB -> GLOBref */
6328 else if (o2->op_type == OP_CONST)
6329 o2->op_private &= ~OPpCONST_STRICT;
6330 else if (o2->op_type == OP_ENTERSUB) {
6331 /* accidental subroutine, revert to bareword */
6332 OP *gvop = ((UNOP*)o2)->op_first;
6333 if (gvop && gvop->op_type == OP_NULL) {
6334 gvop = ((UNOP*)gvop)->op_first;
6336 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6339 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6340 (gvop = ((UNOP*)gvop)->op_first) &&
6341 gvop->op_type == OP_GV)
6343 GV * const gv = cGVOPx_gv(gvop);
6344 OP * const sibling = o2->op_sibling;
6345 SV * const n = newSVpvn("",0);
6347 gv_fullname4(n, gv, "", FALSE);
6348 o2 = newSVOP(OP_CONST, 0, n);
6349 prev->op_sibling = o2;
6350 o2->op_sibling = sibling;
6366 if (contextclass++ == 0) {
6367 e = strchr(proto, ']');
6368 if (!e || e == proto)
6381 while (*--p != '[');
6382 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6383 gv_ename(namegv), o2);
6389 if (o2->op_type == OP_RV2GV)
6392 bad_type(arg, "symbol", gv_ename(namegv), o2);
6395 if (o2->op_type == OP_ENTERSUB)
6398 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6401 if (o2->op_type == OP_RV2SV ||
6402 o2->op_type == OP_PADSV ||
6403 o2->op_type == OP_HELEM ||
6404 o2->op_type == OP_AELEM ||
6405 o2->op_type == OP_THREADSV)
6408 bad_type(arg, "scalar", gv_ename(namegv), o2);
6411 if (o2->op_type == OP_RV2AV ||
6412 o2->op_type == OP_PADAV)
6415 bad_type(arg, "array", gv_ename(namegv), o2);
6418 if (o2->op_type == OP_RV2HV ||
6419 o2->op_type == OP_PADHV)
6422 bad_type(arg, "hash", gv_ename(namegv), o2);
6427 OP* const sib = kid->op_sibling;
6428 kid->op_sibling = 0;
6429 o2 = newUNOP(OP_REFGEN, 0, kid);
6430 o2->op_sibling = sib;
6431 prev->op_sibling = o2;
6433 if (contextclass && e) {
6448 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6449 gv_ename(namegv), cv);
6454 mod(o2, OP_ENTERSUB);
6456 o2 = o2->op_sibling;
6458 if (proto && !optional &&
6459 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6460 return too_few_arguments(o, gv_ename(namegv));
6463 o=newSVOP(OP_CONST, 0, newSViv(0));
6469 Perl_ck_svconst(pTHX_ OP *o)
6471 SvREADONLY_on(cSVOPo->op_sv);
6476 Perl_ck_trunc(pTHX_ OP *o)
6478 if (o->op_flags & OPf_KIDS) {
6479 SVOP *kid = (SVOP*)cUNOPo->op_first;
6481 if (kid->op_type == OP_NULL)
6482 kid = (SVOP*)kid->op_sibling;
6483 if (kid && kid->op_type == OP_CONST &&
6484 (kid->op_private & OPpCONST_BARE))
6486 o->op_flags |= OPf_SPECIAL;
6487 kid->op_private &= ~OPpCONST_STRICT;
6494 Perl_ck_unpack(pTHX_ OP *o)
6496 OP *kid = cLISTOPo->op_first;
6497 if (kid->op_sibling) {
6498 kid = kid->op_sibling;
6499 if (!kid->op_sibling)
6500 kid->op_sibling = newDEFSVOP();
6506 Perl_ck_substr(pTHX_ OP *o)
6509 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6510 OP *kid = cLISTOPo->op_first;
6512 if (kid->op_type == OP_NULL)
6513 kid = kid->op_sibling;
6515 kid->op_flags |= OPf_MOD;
6521 /* A peephole optimizer. We visit the ops in the order they're to execute.
6522 * See the comments at the top of this file for more details about when
6523 * peep() is called */
6526 Perl_peep(pTHX_ register OP *o)
6529 register OP* oldop = 0;
6531 if (!o || o->op_opt)
6535 SAVEVPTR(PL_curcop);
6536 for (; o; o = o->op_next) {
6540 switch (o->op_type) {
6544 PL_curcop = ((COP*)o); /* for warnings */
6549 if (cSVOPo->op_private & OPpCONST_STRICT)
6550 no_bareword_allowed(o);
6552 case OP_METHOD_NAMED:
6553 /* Relocate sv to the pad for thread safety.
6554 * Despite being a "constant", the SV is written to,
6555 * for reference counts, sv_upgrade() etc. */
6557 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6558 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6559 /* If op_sv is already a PADTMP then it is being used by
6560 * some pad, so make a copy. */
6561 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6562 SvREADONLY_on(PAD_SVl(ix));
6563 SvREFCNT_dec(cSVOPo->op_sv);
6566 SvREFCNT_dec(PAD_SVl(ix));
6567 SvPADTMP_on(cSVOPo->op_sv);
6568 PAD_SETSV(ix, cSVOPo->op_sv);
6569 /* XXX I don't know how this isn't readonly already. */
6570 SvREADONLY_on(PAD_SVl(ix));
6572 cSVOPo->op_sv = Nullsv;
6580 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6581 if (o->op_next->op_private & OPpTARGET_MY) {
6582 if (o->op_flags & OPf_STACKED) /* chained concats */
6583 goto ignore_optimization;
6585 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6586 o->op_targ = o->op_next->op_targ;
6587 o->op_next->op_targ = 0;
6588 o->op_private |= OPpTARGET_MY;
6591 op_null(o->op_next);
6593 ignore_optimization:
6597 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6599 break; /* Scalar stub must produce undef. List stub is noop */
6603 if (o->op_targ == OP_NEXTSTATE
6604 || o->op_targ == OP_DBSTATE
6605 || o->op_targ == OP_SETSTATE)
6607 PL_curcop = ((COP*)o);
6609 /* XXX: We avoid setting op_seq here to prevent later calls
6610 to peep() from mistakenly concluding that optimisation
6611 has already occurred. This doesn't fix the real problem,
6612 though (See 20010220.007). AMS 20010719 */
6613 /* op_seq functionality is now replaced by op_opt */
6614 if (oldop && o->op_next) {
6615 oldop->op_next = o->op_next;
6623 if (oldop && o->op_next) {
6624 oldop->op_next = o->op_next;
6632 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6633 OP* pop = (o->op_type == OP_PADAV) ?
6634 o->op_next : o->op_next->op_next;
6636 if (pop && pop->op_type == OP_CONST &&
6637 ((PL_op = pop->op_next)) &&
6638 pop->op_next->op_type == OP_AELEM &&
6639 !(pop->op_next->op_private &
6640 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6641 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6646 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6647 no_bareword_allowed(pop);
6648 if (o->op_type == OP_GV)
6649 op_null(o->op_next);
6650 op_null(pop->op_next);
6652 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6653 o->op_next = pop->op_next->op_next;
6654 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6655 o->op_private = (U8)i;
6656 if (o->op_type == OP_GV) {
6661 o->op_flags |= OPf_SPECIAL;
6662 o->op_type = OP_AELEMFAST;
6668 if (o->op_next->op_type == OP_RV2SV) {
6669 if (!(o->op_next->op_private & OPpDEREF)) {
6670 op_null(o->op_next);
6671 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6673 o->op_next = o->op_next->op_next;
6674 o->op_type = OP_GVSV;
6675 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6678 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6679 GV * const gv = cGVOPo_gv;
6680 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6681 /* XXX could check prototype here instead of just carping */
6682 SV * const sv = sv_newmortal();
6683 gv_efullname3(sv, gv, Nullch);
6684 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6685 "%"SVf"() called too early to check prototype",
6689 else if (o->op_next->op_type == OP_READLINE
6690 && o->op_next->op_next->op_type == OP_CONCAT
6691 && (o->op_next->op_next->op_flags & OPf_STACKED))
6693 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6694 o->op_type = OP_RCATLINE;
6695 o->op_flags |= OPf_STACKED;
6696 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6697 op_null(o->op_next->op_next);
6698 op_null(o->op_next);
6715 while (cLOGOP->op_other->op_type == OP_NULL)
6716 cLOGOP->op_other = cLOGOP->op_other->op_next;
6717 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6723 while (cLOOP->op_redoop->op_type == OP_NULL)
6724 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6725 peep(cLOOP->op_redoop);
6726 while (cLOOP->op_nextop->op_type == OP_NULL)
6727 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6728 peep(cLOOP->op_nextop);
6729 while (cLOOP->op_lastop->op_type == OP_NULL)
6730 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6731 peep(cLOOP->op_lastop);
6738 while (cPMOP->op_pmreplstart &&
6739 cPMOP->op_pmreplstart->op_type == OP_NULL)
6740 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6741 peep(cPMOP->op_pmreplstart);
6746 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6747 && ckWARN(WARN_SYNTAX))
6749 if (o->op_next->op_sibling &&
6750 o->op_next->op_sibling->op_type != OP_EXIT &&
6751 o->op_next->op_sibling->op_type != OP_WARN &&
6752 o->op_next->op_sibling->op_type != OP_DIE) {
6753 const line_t oldline = CopLINE(PL_curcop);
6755 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6756 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6757 "Statement unlikely to be reached");
6758 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6759 "\t(Maybe you meant system() when you said exec()?)\n");
6760 CopLINE_set(PL_curcop, oldline);
6770 const char *key = NULL;
6775 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6778 /* Make the CONST have a shared SV */
6779 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6780 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6781 key = SvPV_const(sv, keylen);
6782 lexname = newSVpvn_share(key,
6783 SvUTF8(sv) ? -(I32)keylen : keylen,
6789 if ((o->op_private & (OPpLVAL_INTRO)))
6792 rop = (UNOP*)((BINOP*)o)->op_first;
6793 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6795 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6796 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6798 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6799 if (!fields || !GvHV(*fields))
6801 key = SvPV_const(*svp, keylen);
6802 if (!hv_fetch(GvHV(*fields), key,
6803 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6805 Perl_croak(aTHX_ "No such class field \"%s\" "
6806 "in variable %s of type %s",
6807 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
6820 SVOP *first_key_op, *key_op;
6822 if ((o->op_private & (OPpLVAL_INTRO))
6823 /* I bet there's always a pushmark... */
6824 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6825 /* hmmm, no optimization if list contains only one key. */
6827 rop = (UNOP*)((LISTOP*)o)->op_last;
6828 if (rop->op_type != OP_RV2HV)
6830 if (rop->op_first->op_type == OP_PADSV)
6831 /* @$hash{qw(keys here)} */
6832 rop = (UNOP*)rop->op_first;
6834 /* @{$hash}{qw(keys here)} */
6835 if (rop->op_first->op_type == OP_SCOPE
6836 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6838 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6844 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6845 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6847 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6848 if (!fields || !GvHV(*fields))
6850 /* Again guessing that the pushmark can be jumped over.... */
6851 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6852 ->op_first->op_sibling;
6853 for (key_op = first_key_op; key_op;
6854 key_op = (SVOP*)key_op->op_sibling) {
6855 if (key_op->op_type != OP_CONST)
6857 svp = cSVOPx_svp(key_op);
6858 key = SvPV_const(*svp, keylen);
6859 if (!hv_fetch(GvHV(*fields), key,
6860 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6862 Perl_croak(aTHX_ "No such class field \"%s\" "
6863 "in variable %s of type %s",
6864 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6871 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6875 /* check that RHS of sort is a single plain array */
6876 OP *oright = cUNOPo->op_first;
6877 if (!oright || oright->op_type != OP_PUSHMARK)
6880 /* reverse sort ... can be optimised. */
6881 if (!cUNOPo->op_sibling) {
6882 /* Nothing follows us on the list. */
6883 OP * const reverse = o->op_next;
6885 if (reverse->op_type == OP_REVERSE &&
6886 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6887 OP * const pushmark = cUNOPx(reverse)->op_first;
6888 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6889 && (cUNOPx(pushmark)->op_sibling == o)) {
6890 /* reverse -> pushmark -> sort */
6891 o->op_private |= OPpSORT_REVERSE;
6893 pushmark->op_next = oright->op_next;
6899 /* make @a = sort @a act in-place */
6903 oright = cUNOPx(oright)->op_sibling;
6906 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6907 oright = cUNOPx(oright)->op_sibling;
6911 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6912 || oright->op_next != o
6913 || (oright->op_private & OPpLVAL_INTRO)
6917 /* o2 follows the chain of op_nexts through the LHS of the
6918 * assign (if any) to the aassign op itself */
6920 if (!o2 || o2->op_type != OP_NULL)
6923 if (!o2 || o2->op_type != OP_PUSHMARK)
6926 if (o2 && o2->op_type == OP_GV)
6929 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6930 || (o2->op_private & OPpLVAL_INTRO)
6935 if (!o2 || o2->op_type != OP_NULL)
6938 if (!o2 || o2->op_type != OP_AASSIGN
6939 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6942 /* check that the sort is the first arg on RHS of assign */
6944 o2 = cUNOPx(o2)->op_first;
6945 if (!o2 || o2->op_type != OP_NULL)
6947 o2 = cUNOPx(o2)->op_first;
6948 if (!o2 || o2->op_type != OP_PUSHMARK)
6950 if (o2->op_sibling != o)
6953 /* check the array is the same on both sides */
6954 if (oleft->op_type == OP_RV2AV) {
6955 if (oright->op_type != OP_RV2AV
6956 || !cUNOPx(oright)->op_first
6957 || cUNOPx(oright)->op_first->op_type != OP_GV
6958 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6959 cGVOPx_gv(cUNOPx(oright)->op_first)
6963 else if (oright->op_type != OP_PADAV
6964 || oright->op_targ != oleft->op_targ
6968 /* transfer MODishness etc from LHS arg to RHS arg */
6969 oright->op_flags = oleft->op_flags;
6970 o->op_private |= OPpSORT_INPLACE;
6972 /* excise push->gv->rv2av->null->aassign */
6973 o2 = o->op_next->op_next;
6974 op_null(o2); /* PUSHMARK */
6976 if (o2->op_type == OP_GV) {
6977 op_null(o2); /* GV */
6980 op_null(o2); /* RV2AV or PADAV */
6981 o2 = o2->op_next->op_next;
6982 op_null(o2); /* AASSIGN */
6984 o->op_next = o2->op_next;
6990 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6992 LISTOP *enter, *exlist;
6995 enter = (LISTOP *) o->op_next;
6998 if (enter->op_type == OP_NULL) {
6999 enter = (LISTOP *) enter->op_next;
7003 /* for $a (...) will have OP_GV then OP_RV2GV here.
7004 for (...) just has an OP_GV. */
7005 if (enter->op_type == OP_GV) {
7006 gvop = (OP *) enter;
7007 enter = (LISTOP *) enter->op_next;
7010 if (enter->op_type == OP_RV2GV) {
7011 enter = (LISTOP *) enter->op_next;
7017 if (enter->op_type != OP_ENTERITER)
7020 iter = enter->op_next;
7021 if (!iter || iter->op_type != OP_ITER)
7024 expushmark = enter->op_first;
7025 if (!expushmark || expushmark->op_type != OP_NULL
7026 || expushmark->op_targ != OP_PUSHMARK)
7029 exlist = (LISTOP *) expushmark->op_sibling;
7030 if (!exlist || exlist->op_type != OP_NULL
7031 || exlist->op_targ != OP_LIST)
7034 if (exlist->op_last != o) {
7035 /* Mmm. Was expecting to point back to this op. */
7038 theirmark = exlist->op_first;
7039 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7042 if (theirmark->op_sibling != o) {
7043 /* There's something between the mark and the reverse, eg
7044 for (1, reverse (...))
7049 ourmark = ((LISTOP *)o)->op_first;
7050 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7053 ourlast = ((LISTOP *)o)->op_last;
7054 if (!ourlast || ourlast->op_next != o)
7057 rv2av = ourmark->op_sibling;
7058 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7059 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7060 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7061 /* We're just reversing a single array. */
7062 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7063 enter->op_flags |= OPf_STACKED;
7066 /* We don't have control over who points to theirmark, so sacrifice
7068 theirmark->op_next = ourmark->op_next;
7069 theirmark->op_flags = ourmark->op_flags;
7070 ourlast->op_next = gvop ? gvop : (OP *) enter;
7073 enter->op_private |= OPpITER_REVERSED;
7074 iter->op_private |= OPpITER_REVERSED;
7089 Perl_custom_op_name(pTHX_ const OP* o)
7091 const IV index = PTR2IV(o->op_ppaddr);
7095 if (!PL_custom_op_names) /* This probably shouldn't happen */
7096 return (char *)PL_op_name[OP_CUSTOM];
7098 keysv = sv_2mortal(newSViv(index));
7100 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7102 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7104 return SvPV_nolen(HeVAL(he));
7108 Perl_custom_op_desc(pTHX_ const OP* o)
7110 const IV index = PTR2IV(o->op_ppaddr);
7114 if (!PL_custom_op_descs)
7115 return (char *)PL_op_desc[OP_CUSTOM];
7117 keysv = sv_2mortal(newSViv(index));
7119 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7121 return (char *)PL_op_desc[OP_CUSTOM];
7123 return SvPV_nolen(HeVAL(he));
7128 /* Efficient sub that returns a constant scalar value. */
7130 const_sv_xsub(pTHX_ CV* cv)
7135 Perl_croak(aTHX_ "usage: %s::%s()",
7136 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7140 ST(0) = (SV*)XSANY.any_ptr;
7146 * c-indentation-style: bsd
7148 * indent-tabs-mode: t
7151 * ex: set ts=8 sts=4 sw=4 noet: