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;
2070 /* XXX what about the numeric ops? */
2071 if (PL_hints & HINT_LOCALE)
2076 goto nope; /* Don't try to run w/ errors */
2078 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2079 if ((curop->op_type != OP_CONST ||
2080 (curop->op_private & OPpCONST_BARE)) &&
2081 curop->op_type != OP_LIST &&
2082 curop->op_type != OP_SCALAR &&
2083 curop->op_type != OP_NULL &&
2084 curop->op_type != OP_PUSHMARK)
2090 curop = LINKLIST(o);
2094 sv = *(PL_stack_sp--);
2095 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2096 pad_swipe(o->op_targ, FALSE);
2097 else if (SvTEMP(sv)) { /* grab mortal temp? */
2098 (void)SvREFCNT_inc(sv);
2102 if (type == OP_RV2GV)
2103 return newGVOP(OP_GV, 0, (GV*)sv);
2104 return newSVOP(OP_CONST, 0, sv);
2111 Perl_gen_constant_list(pTHX_ register OP *o)
2115 const I32 oldtmps_floor = PL_tmps_floor;
2119 return o; /* Don't attempt to run with errors */
2121 PL_op = curop = LINKLIST(o);
2128 PL_tmps_floor = oldtmps_floor;
2130 o->op_type = OP_RV2AV;
2131 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2132 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2133 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2134 o->op_opt = 0; /* needs to be revisited in peep() */
2135 curop = ((UNOP*)o)->op_first;
2136 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2143 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2146 if (!o || o->op_type != OP_LIST)
2147 o = newLISTOP(OP_LIST, 0, o, Nullop);
2149 o->op_flags &= ~OPf_WANT;
2151 if (!(PL_opargs[type] & OA_MARK))
2152 op_null(cLISTOPo->op_first);
2154 o->op_type = (OPCODE)type;
2155 o->op_ppaddr = PL_ppaddr[type];
2156 o->op_flags |= flags;
2158 o = CHECKOP(type, o);
2159 if (o->op_type != (unsigned)type)
2162 return fold_constants(o);
2165 /* List constructors */
2168 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2176 if (first->op_type != (unsigned)type
2177 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2179 return newLISTOP(type, 0, first, last);
2182 if (first->op_flags & OPf_KIDS)
2183 ((LISTOP*)first)->op_last->op_sibling = last;
2185 first->op_flags |= OPf_KIDS;
2186 ((LISTOP*)first)->op_first = last;
2188 ((LISTOP*)first)->op_last = last;
2193 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2201 if (first->op_type != (unsigned)type)
2202 return prepend_elem(type, (OP*)first, (OP*)last);
2204 if (last->op_type != (unsigned)type)
2205 return append_elem(type, (OP*)first, (OP*)last);
2207 first->op_last->op_sibling = last->op_first;
2208 first->op_last = last->op_last;
2209 first->op_flags |= (last->op_flags & OPf_KIDS);
2217 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2225 if (last->op_type == (unsigned)type) {
2226 if (type == OP_LIST) { /* already a PUSHMARK there */
2227 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2228 ((LISTOP*)last)->op_first->op_sibling = first;
2229 if (!(first->op_flags & OPf_PARENS))
2230 last->op_flags &= ~OPf_PARENS;
2233 if (!(last->op_flags & OPf_KIDS)) {
2234 ((LISTOP*)last)->op_last = first;
2235 last->op_flags |= OPf_KIDS;
2237 first->op_sibling = ((LISTOP*)last)->op_first;
2238 ((LISTOP*)last)->op_first = first;
2240 last->op_flags |= OPf_KIDS;
2244 return newLISTOP(type, 0, first, last);
2250 Perl_newNULLLIST(pTHX)
2252 return newOP(OP_STUB, 0);
2256 Perl_force_list(pTHX_ OP *o)
2258 if (!o || o->op_type != OP_LIST)
2259 o = newLISTOP(OP_LIST, 0, o, Nullop);
2265 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2270 NewOp(1101, listop, 1, LISTOP);
2272 listop->op_type = (OPCODE)type;
2273 listop->op_ppaddr = PL_ppaddr[type];
2276 listop->op_flags = (U8)flags;
2280 else if (!first && last)
2283 first->op_sibling = last;
2284 listop->op_first = first;
2285 listop->op_last = last;
2286 if (type == OP_LIST) {
2287 OP* const pushop = newOP(OP_PUSHMARK, 0);
2288 pushop->op_sibling = first;
2289 listop->op_first = pushop;
2290 listop->op_flags |= OPf_KIDS;
2292 listop->op_last = pushop;
2295 return CHECKOP(type, listop);
2299 Perl_newOP(pTHX_ I32 type, I32 flags)
2303 NewOp(1101, o, 1, OP);
2304 o->op_type = (OPCODE)type;
2305 o->op_ppaddr = PL_ppaddr[type];
2306 o->op_flags = (U8)flags;
2309 o->op_private = (U8)(0 | (flags >> 8));
2310 if (PL_opargs[type] & OA_RETSCALAR)
2312 if (PL_opargs[type] & OA_TARGET)
2313 o->op_targ = pad_alloc(type, SVs_PADTMP);
2314 return CHECKOP(type, o);
2318 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2324 first = newOP(OP_STUB, 0);
2325 if (PL_opargs[type] & OA_MARK)
2326 first = force_list(first);
2328 NewOp(1101, unop, 1, UNOP);
2329 unop->op_type = (OPCODE)type;
2330 unop->op_ppaddr = PL_ppaddr[type];
2331 unop->op_first = first;
2332 unop->op_flags = (U8)(flags | OPf_KIDS);
2333 unop->op_private = (U8)(1 | (flags >> 8));
2334 unop = (UNOP*) CHECKOP(type, unop);
2338 return fold_constants((OP *) unop);
2342 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2346 NewOp(1101, binop, 1, BINOP);
2349 first = newOP(OP_NULL, 0);
2351 binop->op_type = (OPCODE)type;
2352 binop->op_ppaddr = PL_ppaddr[type];
2353 binop->op_first = first;
2354 binop->op_flags = (U8)(flags | OPf_KIDS);
2357 binop->op_private = (U8)(1 | (flags >> 8));
2360 binop->op_private = (U8)(2 | (flags >> 8));
2361 first->op_sibling = last;
2364 binop = (BINOP*)CHECKOP(type, binop);
2365 if (binop->op_next || binop->op_type != (OPCODE)type)
2368 binop->op_last = binop->op_first->op_sibling;
2370 return fold_constants((OP *)binop);
2373 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2374 static int uvcompare(const void *a, const void *b)
2376 if (*((const UV *)a) < (*(const UV *)b))
2378 if (*((const UV *)a) > (*(const UV *)b))
2380 if (*((const UV *)a+1) < (*(const UV *)b+1))
2382 if (*((const UV *)a+1) > (*(const UV *)b+1))
2388 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2390 SV * const tstr = ((SVOP*)expr)->op_sv;
2391 SV * const rstr = ((SVOP*)repl)->op_sv;
2394 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2395 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2399 register short *tbl;
2401 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2402 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2403 I32 del = o->op_private & OPpTRANS_DELETE;
2404 PL_hints |= HINT_BLOCK_SCOPE;
2407 o->op_private |= OPpTRANS_FROM_UTF;
2410 o->op_private |= OPpTRANS_TO_UTF;
2412 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2413 SV* const listsv = newSVpvn("# comment\n",10);
2415 const U8* tend = t + tlen;
2416 const U8* rend = r + rlen;
2430 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2431 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2437 t = tsave = bytes_to_utf8(t, &len);
2440 if (!to_utf && rlen) {
2442 r = rsave = bytes_to_utf8(r, &len);
2446 /* There are several snags with this code on EBCDIC:
2447 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2448 2. scan_const() in toke.c has encoded chars in native encoding which makes
2449 ranges at least in EBCDIC 0..255 range the bottom odd.
2453 U8 tmpbuf[UTF8_MAXBYTES+1];
2456 Newx(cp, 2*tlen, UV);
2458 transv = newSVpvn("",0);
2460 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2462 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2464 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2468 cp[2*i+1] = cp[2*i];
2472 qsort(cp, i, 2*sizeof(UV), uvcompare);
2473 for (j = 0; j < i; j++) {
2475 diff = val - nextmin;
2477 t = uvuni_to_utf8(tmpbuf,nextmin);
2478 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2480 U8 range_mark = UTF_TO_NATIVE(0xff);
2481 t = uvuni_to_utf8(tmpbuf, val - 1);
2482 sv_catpvn(transv, (char *)&range_mark, 1);
2483 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2490 t = uvuni_to_utf8(tmpbuf,nextmin);
2491 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2493 U8 range_mark = UTF_TO_NATIVE(0xff);
2494 sv_catpvn(transv, (char *)&range_mark, 1);
2496 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2497 UNICODE_ALLOW_SUPER);
2498 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2499 t = (const U8*)SvPVX_const(transv);
2500 tlen = SvCUR(transv);
2504 else if (!rlen && !del) {
2505 r = t; rlen = tlen; rend = tend;
2508 if ((!rlen && !del) || t == r ||
2509 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2511 o->op_private |= OPpTRANS_IDENTICAL;
2515 while (t < tend || tfirst <= tlast) {
2516 /* see if we need more "t" chars */
2517 if (tfirst > tlast) {
2518 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2520 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2522 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2529 /* now see if we need more "r" chars */
2530 if (rfirst > rlast) {
2532 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2534 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2536 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2545 rfirst = rlast = 0xffffffff;
2549 /* now see which range will peter our first, if either. */
2550 tdiff = tlast - tfirst;
2551 rdiff = rlast - rfirst;
2558 if (rfirst == 0xffffffff) {
2559 diff = tdiff; /* oops, pretend rdiff is infinite */
2561 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2562 (long)tfirst, (long)tlast);
2564 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2568 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2569 (long)tfirst, (long)(tfirst + diff),
2572 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2573 (long)tfirst, (long)rfirst);
2575 if (rfirst + diff > max)
2576 max = rfirst + diff;
2578 grows = (tfirst < rfirst &&
2579 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2591 else if (max > 0xff)
2596 Safefree(cPVOPo->op_pv);
2597 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2598 SvREFCNT_dec(listsv);
2600 SvREFCNT_dec(transv);
2602 if (!del && havefinal && rlen)
2603 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2604 newSVuv((UV)final), 0);
2607 o->op_private |= OPpTRANS_GROWS;
2619 tbl = (short*)cPVOPo->op_pv;
2621 Zero(tbl, 256, short);
2622 for (i = 0; i < (I32)tlen; i++)
2624 for (i = 0, j = 0; i < 256; i++) {
2626 if (j >= (I32)rlen) {
2635 if (i < 128 && r[j] >= 128)
2645 o->op_private |= OPpTRANS_IDENTICAL;
2647 else if (j >= (I32)rlen)
2650 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2651 tbl[0x100] = (short)(rlen - j);
2652 for (i=0; i < (I32)rlen - j; i++)
2653 tbl[0x101+i] = r[j+i];
2657 if (!rlen && !del) {
2660 o->op_private |= OPpTRANS_IDENTICAL;
2662 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2663 o->op_private |= OPpTRANS_IDENTICAL;
2665 for (i = 0; i < 256; i++)
2667 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2668 if (j >= (I32)rlen) {
2670 if (tbl[t[i]] == -1)
2676 if (tbl[t[i]] == -1) {
2677 if (t[i] < 128 && r[j] >= 128)
2684 o->op_private |= OPpTRANS_GROWS;
2692 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2697 NewOp(1101, pmop, 1, PMOP);
2698 pmop->op_type = (OPCODE)type;
2699 pmop->op_ppaddr = PL_ppaddr[type];
2700 pmop->op_flags = (U8)flags;
2701 pmop->op_private = (U8)(0 | (flags >> 8));
2703 if (PL_hints & HINT_RE_TAINT)
2704 pmop->op_pmpermflags |= PMf_RETAINT;
2705 if (PL_hints & HINT_LOCALE)
2706 pmop->op_pmpermflags |= PMf_LOCALE;
2707 pmop->op_pmflags = pmop->op_pmpermflags;
2710 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2711 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2712 pmop->op_pmoffset = SvIV(repointer);
2713 SvREPADTMP_off(repointer);
2714 sv_setiv(repointer,0);
2716 SV * const repointer = newSViv(0);
2717 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2718 pmop->op_pmoffset = av_len(PL_regex_padav);
2719 PL_regex_pad = AvARRAY(PL_regex_padav);
2723 /* link into pm list */
2724 if (type != OP_TRANS && PL_curstash) {
2725 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2728 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2730 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2731 mg->mg_obj = (SV*)pmop;
2732 PmopSTASH_set(pmop,PL_curstash);
2735 return CHECKOP(type, pmop);
2738 /* Given some sort of match op o, and an expression expr containing a
2739 * pattern, either compile expr into a regex and attach it to o (if it's
2740 * constant), or convert expr into a runtime regcomp op sequence (if it's
2743 * isreg indicates that the pattern is part of a regex construct, eg
2744 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2745 * split "pattern", which aren't. In the former case, expr will be a list
2746 * if the pattern contains more than one term (eg /a$b/) or if it contains
2747 * a replacement, ie s/// or tr///.
2751 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2756 I32 repl_has_vars = 0;
2760 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2761 /* last element in list is the replacement; pop it */
2763 repl = cLISTOPx(expr)->op_last;
2764 kid = cLISTOPx(expr)->op_first;
2765 while (kid->op_sibling != repl)
2766 kid = kid->op_sibling;
2767 kid->op_sibling = Nullop;
2768 cLISTOPx(expr)->op_last = kid;
2771 if (isreg && expr->op_type == OP_LIST &&
2772 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2774 /* convert single element list to element */
2776 expr = cLISTOPx(oe)->op_first->op_sibling;
2777 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2778 cLISTOPx(oe)->op_last = Nullop;
2782 if (o->op_type == OP_TRANS) {
2783 return pmtrans(o, expr, repl);
2786 reglist = isreg && expr->op_type == OP_LIST;
2790 PL_hints |= HINT_BLOCK_SCOPE;
2793 if (expr->op_type == OP_CONST) {
2795 SV *pat = ((SVOP*)expr)->op_sv;
2796 const char *p = SvPV_const(pat, plen);
2797 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2798 U32 was_readonly = SvREADONLY(pat);
2802 sv_force_normal_flags(pat, 0);
2803 assert(!SvREADONLY(pat));
2806 SvREADONLY_off(pat);
2810 sv_setpvn(pat, "\\s+", 3);
2812 SvFLAGS(pat) |= was_readonly;
2814 p = SvPV_const(pat, plen);
2815 pm->op_pmflags |= PMf_SKIPWHITE;
2818 pm->op_pmdynflags |= PMdf_UTF8;
2819 /* FIXME - can we make this function take const char * args? */
2820 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2821 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2822 pm->op_pmflags |= PMf_WHITE;
2826 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2827 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2829 : OP_REGCMAYBE),0,expr);
2831 NewOp(1101, rcop, 1, LOGOP);
2832 rcop->op_type = OP_REGCOMP;
2833 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2834 rcop->op_first = scalar(expr);
2835 rcop->op_flags |= OPf_KIDS
2836 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2837 | (reglist ? OPf_STACKED : 0);
2838 rcop->op_private = 1;
2841 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2843 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2846 /* establish postfix order */
2847 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2849 rcop->op_next = expr;
2850 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2853 rcop->op_next = LINKLIST(expr);
2854 expr->op_next = (OP*)rcop;
2857 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2862 if (pm->op_pmflags & PMf_EVAL) {
2864 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2865 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2867 else if (repl->op_type == OP_CONST)
2871 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2872 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2873 if (curop->op_type == OP_GV) {
2874 GV *gv = cGVOPx_gv(curop);
2876 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2879 else if (curop->op_type == OP_RV2CV)
2881 else if (curop->op_type == OP_RV2SV ||
2882 curop->op_type == OP_RV2AV ||
2883 curop->op_type == OP_RV2HV ||
2884 curop->op_type == OP_RV2GV) {
2885 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2888 else if (curop->op_type == OP_PADSV ||
2889 curop->op_type == OP_PADAV ||
2890 curop->op_type == OP_PADHV ||
2891 curop->op_type == OP_PADANY) {
2894 else if (curop->op_type == OP_PUSHRE)
2895 ; /* Okay here, dangerous in newASSIGNOP */
2905 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2906 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2907 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2908 prepend_elem(o->op_type, scalar(repl), o);
2911 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2912 pm->op_pmflags |= PMf_MAYBE_CONST;
2913 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2915 NewOp(1101, rcop, 1, LOGOP);
2916 rcop->op_type = OP_SUBSTCONT;
2917 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2918 rcop->op_first = scalar(repl);
2919 rcop->op_flags |= OPf_KIDS;
2920 rcop->op_private = 1;
2923 /* establish postfix order */
2924 rcop->op_next = LINKLIST(repl);
2925 repl->op_next = (OP*)rcop;
2927 pm->op_pmreplroot = scalar((OP*)rcop);
2928 pm->op_pmreplstart = LINKLIST(rcop);
2937 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2941 NewOp(1101, svop, 1, SVOP);
2942 svop->op_type = (OPCODE)type;
2943 svop->op_ppaddr = PL_ppaddr[type];
2945 svop->op_next = (OP*)svop;
2946 svop->op_flags = (U8)flags;
2947 if (PL_opargs[type] & OA_RETSCALAR)
2949 if (PL_opargs[type] & OA_TARGET)
2950 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2951 return CHECKOP(type, svop);
2955 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2959 NewOp(1101, padop, 1, PADOP);
2960 padop->op_type = (OPCODE)type;
2961 padop->op_ppaddr = PL_ppaddr[type];
2962 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2963 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2964 PAD_SETSV(padop->op_padix, sv);
2967 padop->op_next = (OP*)padop;
2968 padop->op_flags = (U8)flags;
2969 if (PL_opargs[type] & OA_RETSCALAR)
2971 if (PL_opargs[type] & OA_TARGET)
2972 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2973 return CHECKOP(type, padop);
2977 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2983 return newPADOP(type, flags, SvREFCNT_inc(gv));
2985 return newSVOP(type, flags, SvREFCNT_inc(gv));
2990 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2994 NewOp(1101, pvop, 1, PVOP);
2995 pvop->op_type = (OPCODE)type;
2996 pvop->op_ppaddr = PL_ppaddr[type];
2998 pvop->op_next = (OP*)pvop;
2999 pvop->op_flags = (U8)flags;
3000 if (PL_opargs[type] & OA_RETSCALAR)
3002 if (PL_opargs[type] & OA_TARGET)
3003 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3004 return CHECKOP(type, pvop);
3008 Perl_package(pTHX_ OP *o)
3013 save_hptr(&PL_curstash);
3014 save_item(PL_curstname);
3016 name = SvPV_const(cSVOPo->op_sv, len);
3017 PL_curstash = gv_stashpvn(name, len, TRUE);
3018 sv_setpvn(PL_curstname, name, len);
3021 PL_hints |= HINT_BLOCK_SCOPE;
3022 PL_copline = NOLINE;
3027 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3033 if (idop->op_type != OP_CONST)
3034 Perl_croak(aTHX_ "Module name must be constant");
3039 SV * const vesv = ((SVOP*)version)->op_sv;
3041 if (!arg && !SvNIOKp(vesv)) {
3048 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3049 Perl_croak(aTHX_ "Version number must be constant number");
3051 /* Make copy of idop so we don't free it twice */
3052 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3054 /* Fake up a method call to VERSION */
3055 meth = newSVpvn_share("VERSION", 7, 0);
3056 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3057 append_elem(OP_LIST,
3058 prepend_elem(OP_LIST, pack, list(version)),
3059 newSVOP(OP_METHOD_NAMED, 0, meth)));
3063 /* Fake up an import/unimport */
3064 if (arg && arg->op_type == OP_STUB)
3065 imop = arg; /* no import on explicit () */
3066 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3067 imop = Nullop; /* use 5.0; */
3069 idop->op_private |= OPpCONST_NOVER;
3074 /* Make copy of idop so we don't free it twice */
3075 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3077 /* Fake up a method call to import/unimport */
3079 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3080 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3081 append_elem(OP_LIST,
3082 prepend_elem(OP_LIST, pack, list(arg)),
3083 newSVOP(OP_METHOD_NAMED, 0, meth)));
3086 /* Fake up the BEGIN {}, which does its thing immediately. */
3088 newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3091 append_elem(OP_LINESEQ,
3092 append_elem(OP_LINESEQ,
3093 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3094 newSTATEOP(0, Nullch, veop)),
3095 newSTATEOP(0, Nullch, imop) ));
3097 /* The "did you use incorrect case?" warning used to be here.
3098 * The problem is that on case-insensitive filesystems one
3099 * might get false positives for "use" (and "require"):
3100 * "use Strict" or "require CARP" will work. This causes
3101 * portability problems for the script: in case-strict
3102 * filesystems the script will stop working.
3104 * The "incorrect case" warning checked whether "use Foo"
3105 * imported "Foo" to your namespace, but that is wrong, too:
3106 * there is no requirement nor promise in the language that
3107 * a Foo.pm should or would contain anything in package "Foo".
3109 * There is very little Configure-wise that can be done, either:
3110 * the case-sensitivity of the build filesystem of Perl does not
3111 * help in guessing the case-sensitivity of the runtime environment.
3114 PL_hints |= HINT_BLOCK_SCOPE;
3115 PL_copline = NOLINE;
3117 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3121 =head1 Embedding Functions
3123 =for apidoc load_module
3125 Loads the module whose name is pointed to by the string part of name.
3126 Note that the actual module name, not its filename, should be given.
3127 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3128 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3129 (or 0 for no flags). ver, if specified, provides version semantics
3130 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3131 arguments can be used to specify arguments to the module's import()
3132 method, similar to C<use Foo::Bar VERSION LIST>.
3137 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3140 va_start(args, ver);
3141 vload_module(flags, name, ver, &args);
3145 #ifdef PERL_IMPLICIT_CONTEXT
3147 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3151 va_start(args, ver);
3152 vload_module(flags, name, ver, &args);
3158 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3162 OP * const modname = newSVOP(OP_CONST, 0, name);
3163 modname->op_private |= OPpCONST_BARE;
3165 veop = newSVOP(OP_CONST, 0, ver);
3169 if (flags & PERL_LOADMOD_NOIMPORT) {
3170 imop = sawparens(newNULLLIST());
3172 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3173 imop = va_arg(*args, OP*);
3178 sv = va_arg(*args, SV*);
3180 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3181 sv = va_arg(*args, SV*);
3185 const line_t ocopline = PL_copline;
3186 COP * const ocurcop = PL_curcop;
3187 const int oexpect = PL_expect;
3189 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3190 veop, modname, imop);
3191 PL_expect = oexpect;
3192 PL_copline = ocopline;
3193 PL_curcop = ocurcop;
3198 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3203 if (!force_builtin) {
3204 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3205 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3206 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3207 gv = gvp ? *gvp : Nullgv;
3211 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3212 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3213 append_elem(OP_LIST, term,
3214 scalar(newUNOP(OP_RV2CV, 0,
3219 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3225 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3227 return newBINOP(OP_LSLICE, flags,
3228 list(force_list(subscript)),
3229 list(force_list(listval)) );
3233 S_is_list_assignment(pTHX_ register const OP *o)
3238 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3239 o = cUNOPo->op_first;
3241 if (o->op_type == OP_COND_EXPR) {
3242 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3243 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3248 yyerror("Assignment to both a list and a scalar");
3252 if (o->op_type == OP_LIST &&
3253 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3254 o->op_private & OPpLVAL_INTRO)
3257 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3258 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3259 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3262 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3265 if (o->op_type == OP_RV2SV)
3272 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3277 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3278 return newLOGOP(optype, 0,
3279 mod(scalar(left), optype),
3280 newUNOP(OP_SASSIGN, 0, scalar(right)));
3283 return newBINOP(optype, OPf_STACKED,
3284 mod(scalar(left), optype), scalar(right));
3288 if (is_list_assignment(left)) {
3292 /* Grandfathering $[ assignment here. Bletch.*/
3293 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3294 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3295 left = mod(left, OP_AASSIGN);
3298 else if (left->op_type == OP_CONST) {
3299 /* Result of assignment is always 1 (or we'd be dead already) */
3300 return newSVOP(OP_CONST, 0, newSViv(1));
3302 curop = list(force_list(left));
3303 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3304 o->op_private = (U8)(0 | (flags >> 8));
3306 /* PL_generation sorcery:
3307 * an assignment like ($a,$b) = ($c,$d) is easier than
3308 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3309 * To detect whether there are common vars, the global var
3310 * PL_generation is incremented for each assign op we compile.
3311 * Then, while compiling the assign op, we run through all the
3312 * variables on both sides of the assignment, setting a spare slot
3313 * in each of them to PL_generation. If any of them already have
3314 * that value, we know we've got commonality. We could use a
3315 * single bit marker, but then we'd have to make 2 passes, first
3316 * to clear the flag, then to test and set it. To find somewhere
3317 * to store these values, evil chicanery is done with SvCUR().
3320 if (!(left->op_private & OPpLVAL_INTRO)) {
3323 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3324 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3325 if (curop->op_type == OP_GV) {
3326 GV *gv = cGVOPx_gv(curop);
3327 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3329 SvCUR_set(gv, PL_generation);
3331 else if (curop->op_type == OP_PADSV ||
3332 curop->op_type == OP_PADAV ||
3333 curop->op_type == OP_PADHV ||
3334 curop->op_type == OP_PADANY)
3336 if (PAD_COMPNAME_GEN(curop->op_targ)
3337 == (STRLEN)PL_generation)
3339 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3342 else if (curop->op_type == OP_RV2CV)
3344 else if (curop->op_type == OP_RV2SV ||
3345 curop->op_type == OP_RV2AV ||
3346 curop->op_type == OP_RV2HV ||
3347 curop->op_type == OP_RV2GV) {
3348 if (lastop->op_type != OP_GV) /* funny deref? */
3351 else if (curop->op_type == OP_PUSHRE) {
3352 if (((PMOP*)curop)->op_pmreplroot) {
3354 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3355 ((PMOP*)curop)->op_pmreplroot));
3357 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3359 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3361 SvCUR_set(gv, PL_generation);
3370 o->op_private |= OPpASSIGN_COMMON;
3372 if (right && right->op_type == OP_SPLIT) {
3374 if ((tmpop = ((LISTOP*)right)->op_first) &&
3375 tmpop->op_type == OP_PUSHRE)
3377 PMOP * const pm = (PMOP*)tmpop;
3378 if (left->op_type == OP_RV2AV &&
3379 !(left->op_private & OPpLVAL_INTRO) &&
3380 !(o->op_private & OPpASSIGN_COMMON) )
3382 tmpop = ((UNOP*)left)->op_first;
3383 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3385 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3386 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3388 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3389 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3391 pm->op_pmflags |= PMf_ONCE;
3392 tmpop = cUNOPo->op_first; /* to list (nulled) */
3393 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3394 tmpop->op_sibling = Nullop; /* don't free split */
3395 right->op_next = tmpop->op_next; /* fix starting loc */
3396 op_free(o); /* blow off assign */
3397 right->op_flags &= ~OPf_WANT;
3398 /* "I don't know and I don't care." */
3403 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3404 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3406 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3408 sv_setiv(sv, PL_modcount+1);
3416 right = newOP(OP_UNDEF, 0);
3417 if (right->op_type == OP_READLINE) {
3418 right->op_flags |= OPf_STACKED;
3419 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3422 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3423 o = newBINOP(OP_SASSIGN, flags,
3424 scalar(right), mod(scalar(left), OP_SASSIGN) );
3428 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3435 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3438 const U32 seq = intro_my();
3441 NewOp(1101, cop, 1, COP);
3442 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3443 cop->op_type = OP_DBSTATE;
3444 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3447 cop->op_type = OP_NEXTSTATE;
3448 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3450 cop->op_flags = (U8)flags;
3451 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3453 cop->op_private |= NATIVE_HINTS;
3455 PL_compiling.op_private = cop->op_private;
3456 cop->op_next = (OP*)cop;
3459 cop->cop_label = label;
3460 PL_hints |= HINT_BLOCK_SCOPE;
3463 cop->cop_arybase = PL_curcop->cop_arybase;
3464 if (specialWARN(PL_curcop->cop_warnings))
3465 cop->cop_warnings = PL_curcop->cop_warnings ;
3467 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3468 if (specialCopIO(PL_curcop->cop_io))
3469 cop->cop_io = PL_curcop->cop_io;
3471 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3474 if (PL_copline == NOLINE)
3475 CopLINE_set(cop, CopLINE(PL_curcop));
3477 CopLINE_set(cop, PL_copline);
3478 PL_copline = NOLINE;
3481 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3483 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3485 CopSTASH_set(cop, PL_curstash);
3487 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3488 SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3489 if (svp && *svp != &PL_sv_undef ) {
3490 (void)SvIOK_on(*svp);
3491 SvIV_set(*svp, PTR2IV(cop));
3495 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3500 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3503 return new_logop(type, flags, &first, &other);
3507 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3512 OP *first = *firstp;
3513 OP * const other = *otherp;
3515 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3516 return newBINOP(type, flags, scalar(first), scalar(other));
3518 scalarboolean(first);
3519 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3520 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3521 if (type == OP_AND || type == OP_OR) {
3527 first = *firstp = cUNOPo->op_first;
3529 first->op_next = o->op_next;
3530 cUNOPo->op_first = Nullop;
3534 if (first->op_type == OP_CONST) {
3535 if (first->op_private & OPpCONST_STRICT)
3536 no_bareword_allowed(first);
3537 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3538 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3539 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3540 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3541 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3544 if (other->op_type == OP_CONST)
3545 other->op_private |= OPpCONST_SHORTCIRCUIT;
3549 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3550 const OP *o2 = other;
3551 if ( ! (o2->op_type == OP_LIST
3552 && (( o2 = cUNOPx(o2)->op_first))
3553 && o2->op_type == OP_PUSHMARK
3554 && (( o2 = o2->op_sibling)) )
3557 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3558 || o2->op_type == OP_PADHV)
3559 && o2->op_private & OPpLVAL_INTRO
3560 && ckWARN(WARN_DEPRECATED))
3562 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3563 "Deprecated use of my() in false conditional");
3568 if (first->op_type == OP_CONST)
3569 first->op_private |= OPpCONST_SHORTCIRCUIT;
3573 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3574 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3576 const OP * const k1 = ((UNOP*)first)->op_first;
3577 const OP * const k2 = k1->op_sibling;
3579 switch (first->op_type)
3582 if (k2 && k2->op_type == OP_READLINE
3583 && (k2->op_flags & OPf_STACKED)
3584 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3586 warnop = k2->op_type;
3591 if (k1->op_type == OP_READDIR
3592 || k1->op_type == OP_GLOB
3593 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3594 || k1->op_type == OP_EACH)
3596 warnop = ((k1->op_type == OP_NULL)
3597 ? (OPCODE)k1->op_targ : k1->op_type);
3602 const line_t oldline = CopLINE(PL_curcop);
3603 CopLINE_set(PL_curcop, PL_copline);
3604 Perl_warner(aTHX_ packWARN(WARN_MISC),
3605 "Value of %s%s can be \"0\"; test with defined()",
3607 ((warnop == OP_READLINE || warnop == OP_GLOB)
3608 ? " construct" : "() operator"));
3609 CopLINE_set(PL_curcop, oldline);
3616 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3617 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3619 NewOp(1101, logop, 1, LOGOP);
3621 logop->op_type = (OPCODE)type;
3622 logop->op_ppaddr = PL_ppaddr[type];
3623 logop->op_first = first;
3624 logop->op_flags = (U8)(flags | OPf_KIDS);
3625 logop->op_other = LINKLIST(other);
3626 logop->op_private = (U8)(1 | (flags >> 8));
3628 /* establish postfix order */
3629 logop->op_next = LINKLIST(first);
3630 first->op_next = (OP*)logop;
3631 first->op_sibling = other;
3633 CHECKOP(type,logop);
3635 o = newUNOP(OP_NULL, 0, (OP*)logop);
3642 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3650 return newLOGOP(OP_AND, 0, first, trueop);
3652 return newLOGOP(OP_OR, 0, first, falseop);
3654 scalarboolean(first);
3655 if (first->op_type == OP_CONST) {
3656 if (first->op_private & OPpCONST_BARE &&
3657 first->op_private & OPpCONST_STRICT) {
3658 no_bareword_allowed(first);
3660 if (SvTRUE(((SVOP*)first)->op_sv)) {
3671 NewOp(1101, logop, 1, LOGOP);
3672 logop->op_type = OP_COND_EXPR;
3673 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3674 logop->op_first = first;
3675 logop->op_flags = (U8)(flags | OPf_KIDS);
3676 logop->op_private = (U8)(1 | (flags >> 8));
3677 logop->op_other = LINKLIST(trueop);
3678 logop->op_next = LINKLIST(falseop);
3680 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3683 /* establish postfix order */
3684 start = LINKLIST(first);
3685 first->op_next = (OP*)logop;
3687 first->op_sibling = trueop;
3688 trueop->op_sibling = falseop;
3689 o = newUNOP(OP_NULL, 0, (OP*)logop);
3691 trueop->op_next = falseop->op_next = o;
3698 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3707 NewOp(1101, range, 1, LOGOP);
3709 range->op_type = OP_RANGE;
3710 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3711 range->op_first = left;
3712 range->op_flags = OPf_KIDS;
3713 leftstart = LINKLIST(left);
3714 range->op_other = LINKLIST(right);
3715 range->op_private = (U8)(1 | (flags >> 8));
3717 left->op_sibling = right;
3719 range->op_next = (OP*)range;
3720 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3721 flop = newUNOP(OP_FLOP, 0, flip);
3722 o = newUNOP(OP_NULL, 0, flop);
3724 range->op_next = leftstart;
3726 left->op_next = flip;
3727 right->op_next = flop;
3729 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3730 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3731 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3732 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3734 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3735 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3738 if (!flip->op_private || !flop->op_private)
3739 linklist(o); /* blow off optimizer unless constant */
3745 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3749 const bool once = block && block->op_flags & OPf_SPECIAL &&
3750 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3752 PERL_UNUSED_ARG(debuggable);
3755 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3756 return block; /* do {} while 0 does once */
3757 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3758 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3759 expr = newUNOP(OP_DEFINED, 0,
3760 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3761 } else if (expr->op_flags & OPf_KIDS) {
3762 const OP * const k1 = ((UNOP*)expr)->op_first;
3763 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3764 switch (expr->op_type) {
3766 if (k2 && k2->op_type == OP_READLINE
3767 && (k2->op_flags & OPf_STACKED)
3768 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3769 expr = newUNOP(OP_DEFINED, 0, expr);
3773 if (k1->op_type == OP_READDIR
3774 || k1->op_type == OP_GLOB
3775 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3776 || k1->op_type == OP_EACH)
3777 expr = newUNOP(OP_DEFINED, 0, expr);
3783 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3784 * op, in listop. This is wrong. [perl #27024] */
3786 block = newOP(OP_NULL, 0);
3787 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3788 o = new_logop(OP_AND, 0, &expr, &listop);
3791 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3793 if (once && o != listop)
3794 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3797 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3799 o->op_flags |= flags;
3801 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3806 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3807 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3816 PERL_UNUSED_ARG(debuggable);
3819 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3820 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3821 expr = newUNOP(OP_DEFINED, 0,
3822 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3823 } else if (expr->op_flags & OPf_KIDS) {
3824 const OP * const k1 = ((UNOP*)expr)->op_first;
3825 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3826 switch (expr->op_type) {
3828 if (k2 && k2->op_type == OP_READLINE
3829 && (k2->op_flags & OPf_STACKED)
3830 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3831 expr = newUNOP(OP_DEFINED, 0, expr);
3835 if (k1->op_type == OP_READDIR
3836 || k1->op_type == OP_GLOB
3837 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3838 || k1->op_type == OP_EACH)
3839 expr = newUNOP(OP_DEFINED, 0, expr);
3846 block = newOP(OP_NULL, 0);
3847 else if (cont || has_my) {
3848 block = scope(block);
3852 next = LINKLIST(cont);
3855 OP * const unstack = newOP(OP_UNSTACK, 0);
3858 cont = append_elem(OP_LINESEQ, cont, unstack);
3861 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3862 redo = LINKLIST(listop);
3865 PL_copline = (line_t)whileline;
3867 o = new_logop(OP_AND, 0, &expr, &listop);
3868 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3869 op_free(expr); /* oops, it's a while (0) */
3871 return Nullop; /* listop already freed by new_logop */
3874 ((LISTOP*)listop)->op_last->op_next =
3875 (o == listop ? redo : LINKLIST(o));
3881 NewOp(1101,loop,1,LOOP);
3882 loop->op_type = OP_ENTERLOOP;
3883 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3884 loop->op_private = 0;
3885 loop->op_next = (OP*)loop;
3888 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3890 loop->op_redoop = redo;
3891 loop->op_lastop = o;
3892 o->op_private |= loopflags;
3895 loop->op_nextop = next;
3897 loop->op_nextop = o;
3899 o->op_flags |= flags;
3900 o->op_private |= (flags >> 8);
3905 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3910 PADOFFSET padoff = 0;
3915 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3916 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3917 sv->op_type = OP_RV2GV;
3918 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3920 else if (sv->op_type == OP_PADSV) { /* private variable */
3921 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3922 padoff = sv->op_targ;
3927 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3928 padoff = sv->op_targ;
3930 iterflags |= OPf_SPECIAL;
3935 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3938 const I32 offset = pad_findmy("$_");
3939 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3940 sv = newGVOP(OP_GV, 0, PL_defgv);
3946 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3947 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3948 iterflags |= OPf_STACKED;
3950 else if (expr->op_type == OP_NULL &&
3951 (expr->op_flags & OPf_KIDS) &&
3952 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3954 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3955 * set the STACKED flag to indicate that these values are to be
3956 * treated as min/max values by 'pp_iterinit'.
3958 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3959 LOGOP* const range = (LOGOP*) flip->op_first;
3960 OP* const left = range->op_first;
3961 OP* const right = left->op_sibling;
3964 range->op_flags &= ~OPf_KIDS;
3965 range->op_first = Nullop;
3967 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3968 listop->op_first->op_next = range->op_next;
3969 left->op_next = range->op_other;
3970 right->op_next = (OP*)listop;
3971 listop->op_next = listop->op_first;
3974 expr = (OP*)(listop);
3976 iterflags |= OPf_STACKED;
3979 expr = mod(force_list(expr), OP_GREPSTART);
3982 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3983 append_elem(OP_LIST, expr, scalar(sv))));
3984 assert(!loop->op_next);
3985 /* for my $x () sets OPpLVAL_INTRO;
3986 * for our $x () sets OPpOUR_INTRO */
3987 loop->op_private = (U8)iterpflags;
3988 #ifdef PL_OP_SLAB_ALLOC
3991 NewOp(1234,tmp,1,LOOP);
3992 Copy(loop,tmp,1,LISTOP);
3997 Renew(loop, 1, LOOP);
3999 loop->op_targ = padoff;
4000 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4001 PL_copline = forline;
4002 return newSTATEOP(0, label, wop);
4006 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4010 if (type != OP_GOTO || label->op_type == OP_CONST) {
4011 /* "last()" means "last" */
4012 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4013 o = newOP(type, OPf_SPECIAL);
4015 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4016 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4022 /* Check whether it's going to be a goto &function */
4023 if (label->op_type == OP_ENTERSUB
4024 && !(label->op_flags & OPf_STACKED))
4025 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4026 o = newUNOP(type, OPf_STACKED, label);
4028 PL_hints |= HINT_BLOCK_SCOPE;
4033 =for apidoc cv_undef
4035 Clear out all the active components of a CV. This can happen either
4036 by an explicit C<undef &foo>, or by the reference count going to zero.
4037 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4038 children can still follow the full lexical scope chain.
4044 Perl_cv_undef(pTHX_ CV *cv)
4048 if (CvFILE(cv) && !CvXSUB(cv)) {
4049 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4050 Safefree(CvFILE(cv));
4055 if (!CvXSUB(cv) && CvROOT(cv)) {
4057 Perl_croak(aTHX_ "Can't undef active subroutine");
4060 PAD_SAVE_SETNULLPAD();
4062 op_free(CvROOT(cv));
4063 CvROOT(cv) = Nullop;
4064 CvSTART(cv) = Nullop;
4067 SvPOK_off((SV*)cv); /* forget prototype */
4072 /* remove CvOUTSIDE unless this is an undef rather than a free */
4073 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4074 if (!CvWEAKOUTSIDE(cv))
4075 SvREFCNT_dec(CvOUTSIDE(cv));
4076 CvOUTSIDE(cv) = Nullcv;
4079 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4085 /* delete all flags except WEAKOUTSIDE */
4086 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4090 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4092 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4093 SV* const msg = sv_newmortal();
4097 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4098 sv_setpv(msg, "Prototype mismatch:");
4100 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4102 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4104 Perl_sv_catpv(aTHX_ msg, ": none");
4105 sv_catpv(msg, " vs ");
4107 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4109 sv_catpv(msg, "none");
4110 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4114 static void const_sv_xsub(pTHX_ CV* cv);
4118 =head1 Optree Manipulation Functions
4120 =for apidoc cv_const_sv
4122 If C<cv> is a constant sub eligible for inlining. returns the constant
4123 value returned by the sub. Otherwise, returns NULL.
4125 Constant subs can be created with C<newCONSTSUB> or as described in
4126 L<perlsub/"Constant Functions">.
4131 Perl_cv_const_sv(pTHX_ CV *cv)
4133 if (!cv || !CvCONST(cv))
4135 return (SV*)CvXSUBANY(cv).any_ptr;
4138 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4139 * Can be called in 3 ways:
4142 * look for a single OP_CONST with attached value: return the value
4144 * cv && CvCLONE(cv) && !CvCONST(cv)
4146 * examine the clone prototype, and if contains only a single
4147 * OP_CONST referencing a pad const, or a single PADSV referencing
4148 * an outer lexical, return a non-zero value to indicate the CV is
4149 * a candidate for "constizing" at clone time
4153 * We have just cloned an anon prototype that was marked as a const
4154 * candidiate. Try to grab the current value, and in the case of
4155 * PADSV, ignore it if it has multiple references. Return the value.
4159 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4166 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4167 o = cLISTOPo->op_first->op_sibling;
4169 for (; o; o = o->op_next) {
4170 const OPCODE type = o->op_type;
4172 if (sv && o->op_next == o)
4174 if (o->op_next != o) {
4175 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4177 if (type == OP_DBSTATE)
4180 if (type == OP_LEAVESUB || type == OP_RETURN)
4184 if (type == OP_CONST && cSVOPo->op_sv)
4186 else if (cv && type == OP_CONST) {
4187 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4191 else if (cv && type == OP_PADSV) {
4192 if (CvCONST(cv)) { /* newly cloned anon */
4193 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4194 /* the candidate should have 1 ref from this pad and 1 ref
4195 * from the parent */
4196 if (!sv || SvREFCNT(sv) != 2)
4203 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4204 sv = &PL_sv_undef; /* an arbitrary non-null value */
4215 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4217 PERL_UNUSED_ARG(floor);
4227 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4231 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4233 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4237 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4248 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4251 assert(proto->op_type == OP_CONST);
4252 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4257 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4258 SV * const sv = sv_newmortal();
4259 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4260 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4261 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4262 aname = SvPVX_const(sv);
4267 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4268 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4269 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4270 : gv_fetchpv(aname ? aname
4271 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4272 gv_fetch_flags, SVt_PVCV);
4281 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4282 maximum a prototype before. */
4283 if (SvTYPE(gv) > SVt_NULL) {
4284 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4285 && ckWARN_d(WARN_PROTOTYPE))
4287 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4289 cv_ckproto((CV*)gv, NULL, ps);
4292 sv_setpvn((SV*)gv, ps, ps_len);
4294 sv_setiv((SV*)gv, -1);
4295 SvREFCNT_dec(PL_compcv);
4296 cv = PL_compcv = NULL;
4297 PL_sub_generation++;
4301 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4303 #ifdef GV_UNIQUE_CHECK
4304 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4305 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4309 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4312 const_sv = op_const_sv(block, Nullcv);
4315 const bool exists = CvROOT(cv) || CvXSUB(cv);
4317 #ifdef GV_UNIQUE_CHECK
4318 if (exists && GvUNIQUE(gv)) {
4319 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4323 /* if the subroutine doesn't exist and wasn't pre-declared
4324 * with a prototype, assume it will be AUTOLOADed,
4325 * skipping the prototype check
4327 if (exists || SvPOK(cv))
4328 cv_ckproto(cv, gv, ps);
4329 /* already defined (or promised)? */
4330 if (exists || GvASSUMECV(gv)) {
4331 if (!block && !attrs) {
4332 if (CvFLAGS(PL_compcv)) {
4333 /* might have had built-in attrs applied */
4334 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4336 /* just a "sub foo;" when &foo is already defined */
4337 SAVEFREESV(PL_compcv);
4341 if (ckWARN(WARN_REDEFINE)
4343 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4345 const line_t oldline = CopLINE(PL_curcop);
4346 if (PL_copline != NOLINE)
4347 CopLINE_set(PL_curcop, PL_copline);
4348 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4349 CvCONST(cv) ? "Constant subroutine %s redefined"
4350 : "Subroutine %s redefined", name);
4351 CopLINE_set(PL_curcop, oldline);
4359 (void)SvREFCNT_inc(const_sv);
4361 assert(!CvROOT(cv) && !CvCONST(cv));
4362 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4363 CvXSUBANY(cv).any_ptr = const_sv;
4364 CvXSUB(cv) = const_sv_xsub;
4369 cv = newCONSTSUB(NULL, name, const_sv);
4372 SvREFCNT_dec(PL_compcv);
4374 PL_sub_generation++;
4381 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4382 * before we clobber PL_compcv.
4386 /* Might have had built-in attributes applied -- propagate them. */
4387 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4388 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4389 stash = GvSTASH(CvGV(cv));
4390 else if (CvSTASH(cv))
4391 stash = CvSTASH(cv);
4393 stash = PL_curstash;
4396 /* possibly about to re-define existing subr -- ignore old cv */
4397 rcv = (SV*)PL_compcv;
4398 if (name && GvSTASH(gv))
4399 stash = GvSTASH(gv);
4401 stash = PL_curstash;
4403 apply_attrs(stash, rcv, attrs, FALSE);
4405 if (cv) { /* must reuse cv if autoloaded */
4407 /* got here with just attrs -- work done, so bug out */
4408 SAVEFREESV(PL_compcv);
4411 /* transfer PL_compcv to cv */
4413 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4414 if (!CvWEAKOUTSIDE(cv))
4415 SvREFCNT_dec(CvOUTSIDE(cv));
4416 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4417 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4418 CvOUTSIDE(PL_compcv) = 0;
4419 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4420 CvPADLIST(PL_compcv) = 0;
4421 /* inner references to PL_compcv must be fixed up ... */
4422 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4423 /* ... before we throw it away */
4424 SvREFCNT_dec(PL_compcv);
4426 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4427 ++PL_sub_generation;
4434 PL_sub_generation++;
4438 CvFILE_set_from_cop(cv, PL_curcop);
4439 CvSTASH(cv) = PL_curstash;
4442 sv_setpvn((SV*)cv, ps, ps_len);
4444 if (PL_error_count) {
4448 const char *s = strrchr(name, ':');
4450 if (strEQ(s, "BEGIN")) {
4451 const char not_safe[] =
4452 "BEGIN not safe after errors--compilation aborted";
4453 if (PL_in_eval & EVAL_KEEPERR)
4454 Perl_croak(aTHX_ not_safe);
4456 /* force display of errors found but not reported */
4457 sv_catpv(ERRSV, not_safe);
4458 Perl_croak(aTHX_ "%"SVf, ERRSV);
4467 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4468 mod(scalarseq(block), OP_LEAVESUBLV));
4471 /* This makes sub {}; work as expected. */
4472 if (block->op_type == OP_STUB) {
4474 block = newSTATEOP(0, Nullch, 0);
4476 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4478 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4479 OpREFCNT_set(CvROOT(cv), 1);
4480 CvSTART(cv) = LINKLIST(CvROOT(cv));
4481 CvROOT(cv)->op_next = 0;
4482 CALL_PEEP(CvSTART(cv));
4484 /* now that optimizer has done its work, adjust pad values */
4486 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4489 assert(!CvCONST(cv));
4490 if (ps && !*ps && op_const_sv(block, cv))
4494 if (name || aname) {
4496 const char *tname = (name ? name : aname);
4498 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4499 SV * const sv = NEWSV(0,0);
4500 SV * const tmpstr = sv_newmortal();
4501 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4504 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4506 (long)PL_subline, (long)CopLINE(PL_curcop));
4507 gv_efullname3(tmpstr, gv, Nullch);
4508 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4509 hv = GvHVn(db_postponed);
4510 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4511 CV * const pcv = GvCV(db_postponed);
4517 call_sv((SV*)pcv, G_DISCARD);
4522 if ((s = strrchr(tname,':')))
4527 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4530 if (strEQ(s, "BEGIN") && !PL_error_count) {
4531 const I32 oldscope = PL_scopestack_ix;
4533 SAVECOPFILE(&PL_compiling);
4534 SAVECOPLINE(&PL_compiling);
4537 PL_beginav = newAV();
4538 DEBUG_x( dump_sub(gv) );
4539 av_push(PL_beginav, (SV*)cv);
4540 GvCV(gv) = 0; /* cv has been hijacked */
4541 call_list(oldscope, PL_beginav);
4543 PL_curcop = &PL_compiling;
4544 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4547 else if (strEQ(s, "END") && !PL_error_count) {
4550 DEBUG_x( dump_sub(gv) );
4551 av_unshift(PL_endav, 1);
4552 av_store(PL_endav, 0, (SV*)cv);
4553 GvCV(gv) = 0; /* cv has been hijacked */
4555 else if (strEQ(s, "CHECK") && !PL_error_count) {
4557 PL_checkav = newAV();
4558 DEBUG_x( dump_sub(gv) );
4559 if (PL_main_start && ckWARN(WARN_VOID))
4560 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4561 av_unshift(PL_checkav, 1);
4562 av_store(PL_checkav, 0, (SV*)cv);
4563 GvCV(gv) = 0; /* cv has been hijacked */
4565 else if (strEQ(s, "INIT") && !PL_error_count) {
4567 PL_initav = newAV();
4568 DEBUG_x( dump_sub(gv) );
4569 if (PL_main_start && ckWARN(WARN_VOID))
4570 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4571 av_push(PL_initav, (SV*)cv);
4572 GvCV(gv) = 0; /* cv has been hijacked */
4577 PL_copline = NOLINE;
4582 /* XXX unsafe for threads if eval_owner isn't held */
4584 =for apidoc newCONSTSUB
4586 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4587 eligible for inlining at compile-time.
4593 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4600 SAVECOPLINE(PL_curcop);
4601 CopLINE_set(PL_curcop, PL_copline);
4604 PL_hints &= ~HINT_BLOCK_SCOPE;
4607 SAVESPTR(PL_curstash);
4608 SAVECOPSTASH(PL_curcop);
4609 PL_curstash = stash;
4610 CopSTASH_set(PL_curcop,stash);
4613 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4614 CvXSUBANY(cv).any_ptr = sv;
4616 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4620 CopSTASH_free(PL_curcop);
4628 =for apidoc U||newXS
4630 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4636 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4638 GV * const gv = gv_fetchpv(name ? name :
4639 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4640 GV_ADDMULTI, SVt_PVCV);
4644 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4646 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4648 /* just a cached method */
4652 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4653 /* already defined (or promised) */
4654 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4655 if (ckWARN(WARN_REDEFINE)) {
4656 GV * const gvcv = CvGV(cv);
4658 HV * const stash = GvSTASH(gvcv);
4660 const char *name = HvNAME_get(stash);
4661 if ( strEQ(name,"autouse") ) {
4662 const line_t oldline = CopLINE(PL_curcop);
4663 if (PL_copline != NOLINE)
4664 CopLINE_set(PL_curcop, PL_copline);
4665 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4666 CvCONST(cv) ? "Constant subroutine %s redefined"
4667 : "Subroutine %s redefined"
4669 CopLINE_set(PL_curcop, oldline);
4679 if (cv) /* must reuse cv if autoloaded */
4682 cv = (CV*)NEWSV(1105,0);
4683 sv_upgrade((SV *)cv, SVt_PVCV);
4687 PL_sub_generation++;
4691 (void)gv_fetchfile(filename);
4692 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4693 an external constant string */
4694 CvXSUB(cv) = subaddr;
4697 const char *s = strrchr(name,':');
4703 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4706 if (strEQ(s, "BEGIN")) {
4708 PL_beginav = newAV();
4709 av_push(PL_beginav, (SV*)cv);
4710 GvCV(gv) = 0; /* cv has been hijacked */
4712 else if (strEQ(s, "END")) {
4715 av_unshift(PL_endav, 1);
4716 av_store(PL_endav, 0, (SV*)cv);
4717 GvCV(gv) = 0; /* cv has been hijacked */
4719 else if (strEQ(s, "CHECK")) {
4721 PL_checkav = newAV();
4722 if (PL_main_start && ckWARN(WARN_VOID))
4723 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4724 av_unshift(PL_checkav, 1);
4725 av_store(PL_checkav, 0, (SV*)cv);
4726 GvCV(gv) = 0; /* cv has been hijacked */
4728 else if (strEQ(s, "INIT")) {
4730 PL_initav = newAV();
4731 if (PL_main_start && ckWARN(WARN_VOID))
4732 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4733 av_push(PL_initav, (SV*)cv);
4734 GvCV(gv) = 0; /* cv has been hijacked */
4745 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4751 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4753 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4755 #ifdef GV_UNIQUE_CHECK
4757 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4761 if ((cv = GvFORM(gv))) {
4762 if (ckWARN(WARN_REDEFINE)) {
4763 const line_t oldline = CopLINE(PL_curcop);
4764 if (PL_copline != NOLINE)
4765 CopLINE_set(PL_curcop, PL_copline);
4766 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4767 o ? "Format %"SVf" redefined"
4768 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4769 CopLINE_set(PL_curcop, oldline);
4776 CvFILE_set_from_cop(cv, PL_curcop);
4779 pad_tidy(padtidy_FORMAT);
4780 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4781 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4782 OpREFCNT_set(CvROOT(cv), 1);
4783 CvSTART(cv) = LINKLIST(CvROOT(cv));
4784 CvROOT(cv)->op_next = 0;
4785 CALL_PEEP(CvSTART(cv));
4787 PL_copline = NOLINE;
4792 Perl_newANONLIST(pTHX_ OP *o)
4794 return newUNOP(OP_REFGEN, 0,
4795 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4799 Perl_newANONHASH(pTHX_ OP *o)
4801 return newUNOP(OP_REFGEN, 0,
4802 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4806 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4808 return newANONATTRSUB(floor, proto, Nullop, block);
4812 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4814 return newUNOP(OP_REFGEN, 0,
4815 newSVOP(OP_ANONCODE, 0,
4816 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4820 Perl_oopsAV(pTHX_ OP *o)
4823 switch (o->op_type) {
4825 o->op_type = OP_PADAV;
4826 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4827 return ref(o, OP_RV2AV);
4830 o->op_type = OP_RV2AV;
4831 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4836 if (ckWARN_d(WARN_INTERNAL))
4837 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4844 Perl_oopsHV(pTHX_ OP *o)
4847 switch (o->op_type) {
4850 o->op_type = OP_PADHV;
4851 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4852 return ref(o, OP_RV2HV);
4856 o->op_type = OP_RV2HV;
4857 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4862 if (ckWARN_d(WARN_INTERNAL))
4863 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4870 Perl_newAVREF(pTHX_ OP *o)
4873 if (o->op_type == OP_PADANY) {
4874 o->op_type = OP_PADAV;
4875 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4878 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4879 && ckWARN(WARN_DEPRECATED)) {
4880 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4881 "Using an array as a reference is deprecated");
4883 return newUNOP(OP_RV2AV, 0, scalar(o));
4887 Perl_newGVREF(pTHX_ I32 type, OP *o)
4889 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4890 return newUNOP(OP_NULL, 0, o);
4891 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4895 Perl_newHVREF(pTHX_ OP *o)
4898 if (o->op_type == OP_PADANY) {
4899 o->op_type = OP_PADHV;
4900 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4903 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4904 && ckWARN(WARN_DEPRECATED)) {
4905 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4906 "Using a hash as a reference is deprecated");
4908 return newUNOP(OP_RV2HV, 0, scalar(o));
4912 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4914 return newUNOP(OP_RV2CV, flags, scalar(o));
4918 Perl_newSVREF(pTHX_ OP *o)
4921 if (o->op_type == OP_PADANY) {
4922 o->op_type = OP_PADSV;
4923 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4926 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4927 o->op_flags |= OPpDONE_SVREF;
4930 return newUNOP(OP_RV2SV, 0, scalar(o));
4933 /* Check routines. See the comments at the top of this file for details
4934 * on when these are called */
4937 Perl_ck_anoncode(pTHX_ OP *o)
4939 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4940 cSVOPo->op_sv = Nullsv;
4945 Perl_ck_bitop(pTHX_ OP *o)
4947 #define OP_IS_NUMCOMPARE(op) \
4948 ((op) == OP_LT || (op) == OP_I_LT || \
4949 (op) == OP_GT || (op) == OP_I_GT || \
4950 (op) == OP_LE || (op) == OP_I_LE || \
4951 (op) == OP_GE || (op) == OP_I_GE || \
4952 (op) == OP_EQ || (op) == OP_I_EQ || \
4953 (op) == OP_NE || (op) == OP_I_NE || \
4954 (op) == OP_NCMP || (op) == OP_I_NCMP)
4955 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4956 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4957 && (o->op_type == OP_BIT_OR
4958 || o->op_type == OP_BIT_AND
4959 || o->op_type == OP_BIT_XOR))
4961 const OP * const left = cBINOPo->op_first;
4962 const OP * const right = left->op_sibling;
4963 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4964 (left->op_flags & OPf_PARENS) == 0) ||
4965 (OP_IS_NUMCOMPARE(right->op_type) &&
4966 (right->op_flags & OPf_PARENS) == 0))
4967 if (ckWARN(WARN_PRECEDENCE))
4968 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4969 "Possible precedence problem on bitwise %c operator",
4970 o->op_type == OP_BIT_OR ? '|'
4971 : o->op_type == OP_BIT_AND ? '&' : '^'
4978 Perl_ck_concat(pTHX_ OP *o)
4980 const OP *kid = cUNOPo->op_first;
4981 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4982 !(kUNOP->op_first->op_flags & OPf_MOD))
4983 o->op_flags |= OPf_STACKED;
4988 Perl_ck_spair(pTHX_ OP *o)
4991 if (o->op_flags & OPf_KIDS) {
4994 const OPCODE type = o->op_type;
4995 o = modkids(ck_fun(o), type);
4996 kid = cUNOPo->op_first;
4997 newop = kUNOP->op_first->op_sibling;
4999 (newop->op_sibling ||
5000 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5001 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5002 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5006 op_free(kUNOP->op_first);
5007 kUNOP->op_first = newop;
5009 o->op_ppaddr = PL_ppaddr[++o->op_type];
5014 Perl_ck_delete(pTHX_ OP *o)
5018 if (o->op_flags & OPf_KIDS) {
5019 OP * const kid = cUNOPo->op_first;
5020 switch (kid->op_type) {
5022 o->op_flags |= OPf_SPECIAL;
5025 o->op_private |= OPpSLICE;
5028 o->op_flags |= OPf_SPECIAL;
5033 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5042 Perl_ck_die(pTHX_ OP *o)
5045 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5051 Perl_ck_eof(pTHX_ OP *o)
5053 const I32 type = o->op_type;
5055 if (o->op_flags & OPf_KIDS) {
5056 if (cLISTOPo->op_first->op_type == OP_STUB) {
5058 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5066 Perl_ck_eval(pTHX_ OP *o)
5069 PL_hints |= HINT_BLOCK_SCOPE;
5070 if (o->op_flags & OPf_KIDS) {
5071 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5074 o->op_flags &= ~OPf_KIDS;
5077 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5080 cUNOPo->op_first = 0;
5083 NewOp(1101, enter, 1, LOGOP);
5084 enter->op_type = OP_ENTERTRY;
5085 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5086 enter->op_private = 0;
5088 /* establish postfix order */
5089 enter->op_next = (OP*)enter;
5091 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5092 o->op_type = OP_LEAVETRY;
5093 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5094 enter->op_other = o;
5104 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5106 o->op_targ = (PADOFFSET)PL_hints;
5111 Perl_ck_exit(pTHX_ OP *o)
5114 HV * const table = GvHV(PL_hintgv);
5116 SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5117 if (svp && *svp && SvTRUE(*svp))
5118 o->op_private |= OPpEXIT_VMSISH;
5120 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5126 Perl_ck_exec(pTHX_ OP *o)
5128 if (o->op_flags & OPf_STACKED) {
5131 kid = cUNOPo->op_first->op_sibling;
5132 if (kid->op_type == OP_RV2GV)
5141 Perl_ck_exists(pTHX_ OP *o)
5144 if (o->op_flags & OPf_KIDS) {
5145 OP * const kid = cUNOPo->op_first;
5146 if (kid->op_type == OP_ENTERSUB) {
5147 (void) ref(kid, o->op_type);
5148 if (kid->op_type != OP_RV2CV && !PL_error_count)
5149 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5151 o->op_private |= OPpEXISTS_SUB;
5153 else if (kid->op_type == OP_AELEM)
5154 o->op_flags |= OPf_SPECIAL;
5155 else if (kid->op_type != OP_HELEM)
5156 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5164 Perl_ck_rvconst(pTHX_ register OP *o)
5167 SVOP *kid = (SVOP*)cUNOPo->op_first;
5169 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5170 if (kid->op_type == OP_CONST) {
5173 SV * const kidsv = kid->op_sv;
5175 /* Is it a constant from cv_const_sv()? */
5176 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5177 SV *rsv = SvRV(kidsv);
5178 const int svtype = SvTYPE(rsv);
5179 const char *badtype = Nullch;
5181 switch (o->op_type) {
5183 if (svtype > SVt_PVMG)
5184 badtype = "a SCALAR";
5187 if (svtype != SVt_PVAV)
5188 badtype = "an ARRAY";
5191 if (svtype != SVt_PVHV)
5195 if (svtype != SVt_PVCV)
5200 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5203 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5204 const char *badthing = Nullch;
5205 switch (o->op_type) {
5207 badthing = "a SCALAR";
5210 badthing = "an ARRAY";
5213 badthing = "a HASH";
5218 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5222 * This is a little tricky. We only want to add the symbol if we
5223 * didn't add it in the lexer. Otherwise we get duplicate strict
5224 * warnings. But if we didn't add it in the lexer, we must at
5225 * least pretend like we wanted to add it even if it existed before,
5226 * or we get possible typo warnings. OPpCONST_ENTERED says
5227 * whether the lexer already added THIS instance of this symbol.
5229 iscv = (o->op_type == OP_RV2CV) * 2;
5231 gv = gv_fetchsv(kidsv,
5232 iscv | !(kid->op_private & OPpCONST_ENTERED),
5235 : o->op_type == OP_RV2SV
5237 : o->op_type == OP_RV2AV
5239 : o->op_type == OP_RV2HV
5242 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5244 kid->op_type = OP_GV;
5245 SvREFCNT_dec(kid->op_sv);
5247 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5248 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5249 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5251 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5253 kid->op_sv = SvREFCNT_inc(gv);
5255 kid->op_private = 0;
5256 kid->op_ppaddr = PL_ppaddr[OP_GV];
5263 Perl_ck_ftst(pTHX_ OP *o)
5266 const I32 type = o->op_type;
5268 if (o->op_flags & OPf_REF) {
5271 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5272 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5274 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5275 OP * const newop = newGVOP(type, OPf_REF,
5276 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5282 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5283 OP_IS_FILETEST_ACCESS(o))
5284 o->op_private |= OPpFT_ACCESS;
5286 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5287 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5288 o->op_private |= OPpFT_STACKED;
5292 if (type == OP_FTTTY)
5293 o = newGVOP(type, OPf_REF, PL_stdingv);
5295 o = newUNOP(type, 0, newDEFSVOP());
5301 Perl_ck_fun(pTHX_ OP *o)
5303 const int type = o->op_type;
5304 register I32 oa = PL_opargs[type] >> OASHIFT;
5306 if (o->op_flags & OPf_STACKED) {
5307 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5310 return no_fh_allowed(o);
5313 if (o->op_flags & OPf_KIDS) {
5314 OP **tokid = &cLISTOPo->op_first;
5315 register OP *kid = cLISTOPo->op_first;
5319 if (kid->op_type == OP_PUSHMARK ||
5320 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5322 tokid = &kid->op_sibling;
5323 kid = kid->op_sibling;
5325 if (!kid && PL_opargs[type] & OA_DEFGV)
5326 *tokid = kid = newDEFSVOP();
5330 sibl = kid->op_sibling;
5333 /* list seen where single (scalar) arg expected? */
5334 if (numargs == 1 && !(oa >> 4)
5335 && kid->op_type == OP_LIST && type != OP_SCALAR)
5337 return too_many_arguments(o,PL_op_desc[type]);
5350 if ((type == OP_PUSH || type == OP_UNSHIFT)
5351 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5352 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5353 "Useless use of %s with no values",
5356 if (kid->op_type == OP_CONST &&
5357 (kid->op_private & OPpCONST_BARE))
5359 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5360 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5361 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5362 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5363 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5364 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5367 kid->op_sibling = sibl;
5370 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5371 bad_type(numargs, "array", PL_op_desc[type], kid);
5375 if (kid->op_type == OP_CONST &&
5376 (kid->op_private & OPpCONST_BARE))
5378 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5379 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5380 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5381 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5382 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5383 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5386 kid->op_sibling = sibl;
5389 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5390 bad_type(numargs, "hash", PL_op_desc[type], kid);
5395 OP * const newop = newUNOP(OP_NULL, 0, kid);
5396 kid->op_sibling = 0;
5398 newop->op_next = newop;
5400 kid->op_sibling = sibl;
5405 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5406 if (kid->op_type == OP_CONST &&
5407 (kid->op_private & OPpCONST_BARE))
5409 OP *newop = newGVOP(OP_GV, 0,
5410 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5411 if (!(o->op_private & 1) && /* if not unop */
5412 kid == cLISTOPo->op_last)
5413 cLISTOPo->op_last = newop;
5417 else if (kid->op_type == OP_READLINE) {
5418 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5419 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5422 I32 flags = OPf_SPECIAL;
5426 /* is this op a FH constructor? */
5427 if (is_handle_constructor(o,numargs)) {
5428 const char *name = Nullch;
5432 /* Set a flag to tell rv2gv to vivify
5433 * need to "prove" flag does not mean something
5434 * else already - NI-S 1999/05/07
5437 if (kid->op_type == OP_PADSV) {
5438 name = PAD_COMPNAME_PV(kid->op_targ);
5439 /* SvCUR of a pad namesv can't be trusted
5440 * (see PL_generation), so calc its length
5446 else if (kid->op_type == OP_RV2SV
5447 && kUNOP->op_first->op_type == OP_GV)
5449 GV *gv = cGVOPx_gv(kUNOP->op_first);
5451 len = GvNAMELEN(gv);
5453 else if (kid->op_type == OP_AELEM
5454 || kid->op_type == OP_HELEM)
5456 OP *op = ((BINOP*)kid)->op_first;
5459 SV *tmpstr = Nullsv;
5460 const char * const a =
5461 kid->op_type == OP_AELEM ?
5463 if (((op->op_type == OP_RV2AV) ||
5464 (op->op_type == OP_RV2HV)) &&
5465 (op = ((UNOP*)op)->op_first) &&
5466 (op->op_type == OP_GV)) {
5467 /* packagevar $a[] or $h{} */
5468 GV * const gv = cGVOPx_gv(op);
5476 else if (op->op_type == OP_PADAV
5477 || op->op_type == OP_PADHV) {
5478 /* lexicalvar $a[] or $h{} */
5479 const char * const padname =
5480 PAD_COMPNAME_PV(op->op_targ);
5489 name = SvPV_const(tmpstr, len);
5494 name = "__ANONIO__";
5501 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5502 namesv = PAD_SVl(targ);
5503 SvUPGRADE(namesv, SVt_PV);
5505 sv_setpvn(namesv, "$", 1);
5506 sv_catpvn(namesv, name, len);
5509 kid->op_sibling = 0;
5510 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5511 kid->op_targ = targ;
5512 kid->op_private |= priv;
5514 kid->op_sibling = sibl;
5520 mod(scalar(kid), type);
5524 tokid = &kid->op_sibling;
5525 kid = kid->op_sibling;
5527 o->op_private |= numargs;
5529 return too_many_arguments(o,OP_DESC(o));
5532 else if (PL_opargs[type] & OA_DEFGV) {
5534 return newUNOP(type, 0, newDEFSVOP());
5538 while (oa & OA_OPTIONAL)
5540 if (oa && oa != OA_LIST)
5541 return too_few_arguments(o,OP_DESC(o));
5547 Perl_ck_glob(pTHX_ OP *o)
5553 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5554 append_elem(OP_GLOB, o, newDEFSVOP());
5556 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5557 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5559 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5562 #if !defined(PERL_EXTERNAL_GLOB)
5563 /* XXX this can be tightened up and made more failsafe. */
5564 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5567 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5568 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5569 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5570 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5571 GvCV(gv) = GvCV(glob_gv);
5572 (void)SvREFCNT_inc((SV*)GvCV(gv));
5573 GvIMPORTED_CV_on(gv);
5576 #endif /* PERL_EXTERNAL_GLOB */
5578 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5579 append_elem(OP_GLOB, o,
5580 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5581 o->op_type = OP_LIST;
5582 o->op_ppaddr = PL_ppaddr[OP_LIST];
5583 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5584 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5585 cLISTOPo->op_first->op_targ = 0;
5586 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5587 append_elem(OP_LIST, o,
5588 scalar(newUNOP(OP_RV2CV, 0,
5589 newGVOP(OP_GV, 0, gv)))));
5590 o = newUNOP(OP_NULL, 0, ck_subr(o));
5591 o->op_targ = OP_GLOB; /* hint at what it used to be */
5594 gv = newGVgen("main");
5596 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5602 Perl_ck_grep(pTHX_ OP *o)
5607 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5610 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5611 NewOp(1101, gwop, 1, LOGOP);
5613 if (o->op_flags & OPf_STACKED) {
5616 kid = cLISTOPo->op_first->op_sibling;
5617 if (!cUNOPx(kid)->op_next)
5618 Perl_croak(aTHX_ "panic: ck_grep");
5619 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5622 kid->op_next = (OP*)gwop;
5623 o->op_flags &= ~OPf_STACKED;
5625 kid = cLISTOPo->op_first->op_sibling;
5626 if (type == OP_MAPWHILE)
5633 kid = cLISTOPo->op_first->op_sibling;
5634 if (kid->op_type != OP_NULL)
5635 Perl_croak(aTHX_ "panic: ck_grep");
5636 kid = kUNOP->op_first;
5638 gwop->op_type = type;
5639 gwop->op_ppaddr = PL_ppaddr[type];
5640 gwop->op_first = listkids(o);
5641 gwop->op_flags |= OPf_KIDS;
5642 gwop->op_other = LINKLIST(kid);
5643 kid->op_next = (OP*)gwop;
5644 offset = pad_findmy("$_");
5645 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5646 o->op_private = gwop->op_private = 0;
5647 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5650 o->op_private = gwop->op_private = OPpGREP_LEX;
5651 gwop->op_targ = o->op_targ = offset;
5654 kid = cLISTOPo->op_first->op_sibling;
5655 if (!kid || !kid->op_sibling)
5656 return too_few_arguments(o,OP_DESC(o));
5657 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5658 mod(kid, OP_GREPSTART);
5664 Perl_ck_index(pTHX_ OP *o)
5666 if (o->op_flags & OPf_KIDS) {
5667 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5669 kid = kid->op_sibling; /* get past "big" */
5670 if (kid && kid->op_type == OP_CONST)
5671 fbm_compile(((SVOP*)kid)->op_sv, 0);
5677 Perl_ck_lengthconst(pTHX_ OP *o)
5679 /* XXX length optimization goes here */
5684 Perl_ck_lfun(pTHX_ OP *o)
5686 const OPCODE type = o->op_type;
5687 return modkids(ck_fun(o), type);
5691 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5693 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5694 switch (cUNOPo->op_first->op_type) {
5696 /* This is needed for
5697 if (defined %stash::)
5698 to work. Do not break Tk.
5700 break; /* Globals via GV can be undef */
5702 case OP_AASSIGN: /* Is this a good idea? */
5703 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5704 "defined(@array) is deprecated");
5705 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5706 "\t(Maybe you should just omit the defined()?)\n");
5709 /* This is needed for
5710 if (defined %stash::)
5711 to work. Do not break Tk.
5713 break; /* Globals via GV can be undef */
5715 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5716 "defined(%%hash) is deprecated");
5717 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5718 "\t(Maybe you should just omit the defined()?)\n");
5729 Perl_ck_rfun(pTHX_ OP *o)
5731 const OPCODE type = o->op_type;
5732 return refkids(ck_fun(o), type);
5736 Perl_ck_listiob(pTHX_ OP *o)
5740 kid = cLISTOPo->op_first;
5743 kid = cLISTOPo->op_first;
5745 if (kid->op_type == OP_PUSHMARK)
5746 kid = kid->op_sibling;
5747 if (kid && o->op_flags & OPf_STACKED)
5748 kid = kid->op_sibling;
5749 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5750 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5751 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5752 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5753 cLISTOPo->op_first->op_sibling = kid;
5754 cLISTOPo->op_last = kid;
5755 kid = kid->op_sibling;
5760 append_elem(o->op_type, o, newDEFSVOP());
5766 Perl_ck_sassign(pTHX_ OP *o)
5768 OP *kid = cLISTOPo->op_first;
5769 /* has a disposable target? */
5770 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5771 && !(kid->op_flags & OPf_STACKED)
5772 /* Cannot steal the second time! */
5773 && !(kid->op_private & OPpTARGET_MY))
5775 OP * const kkid = kid->op_sibling;
5777 /* Can just relocate the target. */
5778 if (kkid && kkid->op_type == OP_PADSV
5779 && !(kkid->op_private & OPpLVAL_INTRO))
5781 kid->op_targ = kkid->op_targ;
5783 /* Now we do not need PADSV and SASSIGN. */
5784 kid->op_sibling = o->op_sibling; /* NULL */
5785 cLISTOPo->op_first = NULL;
5788 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5796 Perl_ck_match(pTHX_ OP *o)
5798 if (o->op_type != OP_QR) {
5799 const I32 offset = pad_findmy("$_");
5800 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5801 o->op_targ = offset;
5802 o->op_private |= OPpTARGET_MY;
5805 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5806 o->op_private |= OPpRUNTIME;
5811 Perl_ck_method(pTHX_ OP *o)
5813 OP * const kid = cUNOPo->op_first;
5814 if (kid->op_type == OP_CONST) {
5815 SV* sv = kSVOP->op_sv;
5816 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5818 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5819 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5822 kSVOP->op_sv = Nullsv;
5824 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5833 Perl_ck_null(pTHX_ OP *o)
5839 Perl_ck_open(pTHX_ OP *o)
5841 HV * const table = GvHV(PL_hintgv);
5843 SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
5845 const I32 mode = mode_from_discipline(*svp);
5846 if (mode & O_BINARY)
5847 o->op_private |= OPpOPEN_IN_RAW;
5848 else if (mode & O_TEXT)
5849 o->op_private |= OPpOPEN_IN_CRLF;
5852 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5854 const I32 mode = mode_from_discipline(*svp);
5855 if (mode & O_BINARY)
5856 o->op_private |= OPpOPEN_OUT_RAW;
5857 else if (mode & O_TEXT)
5858 o->op_private |= OPpOPEN_OUT_CRLF;
5861 if (o->op_type == OP_BACKTICK)
5864 /* In case of three-arg dup open remove strictness
5865 * from the last arg if it is a bareword. */
5866 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
5867 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
5871 if ((last->op_type == OP_CONST) && /* The bareword. */
5872 (last->op_private & OPpCONST_BARE) &&
5873 (last->op_private & OPpCONST_STRICT) &&
5874 (oa = first->op_sibling) && /* The fh. */
5875 (oa = oa->op_sibling) && /* The mode. */
5876 (oa->op_type == OP_CONST) &&
5877 SvPOK(((SVOP*)oa)->op_sv) &&
5878 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5879 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5880 (last == oa->op_sibling)) /* The bareword. */
5881 last->op_private &= ~OPpCONST_STRICT;
5887 Perl_ck_repeat(pTHX_ OP *o)
5889 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5890 o->op_private |= OPpREPEAT_DOLIST;
5891 cBINOPo->op_first = force_list(cBINOPo->op_first);
5899 Perl_ck_require(pTHX_ OP *o)
5903 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5904 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5906 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5907 SV * const sv = kid->op_sv;
5908 U32 was_readonly = SvREADONLY(sv);
5913 sv_force_normal_flags(sv, 0);
5914 assert(!SvREADONLY(sv));
5921 for (s = SvPVX(sv); *s; s++) {
5922 if (*s == ':' && s[1] == ':') {
5923 const STRLEN len = strlen(s+2)+1;
5925 Move(s+2, s+1, len, char);
5926 SvCUR_set(sv, SvCUR(sv) - 1);
5929 sv_catpvn(sv, ".pm", 3);
5930 SvFLAGS(sv) |= was_readonly;
5934 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
5935 /* handle override, if any */
5936 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5937 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5938 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
5939 gv = gvp ? *gvp : Nullgv;
5943 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5944 OP * const kid = cUNOPo->op_first;
5945 cUNOPo->op_first = 0;
5947 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5948 append_elem(OP_LIST, kid,
5949 scalar(newUNOP(OP_RV2CV, 0,
5958 Perl_ck_return(pTHX_ OP *o)
5960 if (CvLVALUE(PL_compcv)) {
5962 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5963 mod(kid, OP_LEAVESUBLV);
5969 Perl_ck_select(pTHX_ OP *o)
5973 if (o->op_flags & OPf_KIDS) {
5974 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5975 if (kid && kid->op_sibling) {
5976 o->op_type = OP_SSELECT;
5977 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5979 return fold_constants(o);
5983 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5984 if (kid && kid->op_type == OP_RV2GV)
5985 kid->op_private &= ~HINT_STRICT_REFS;
5990 Perl_ck_shift(pTHX_ OP *o)
5992 const I32 type = o->op_type;
5994 if (!(o->op_flags & OPf_KIDS)) {
5998 argop = newUNOP(OP_RV2AV, 0,
5999 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6000 return newUNOP(type, 0, scalar(argop));
6002 return scalar(modkids(ck_fun(o), type));
6006 Perl_ck_sort(pTHX_ OP *o)
6010 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6012 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6013 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6015 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6017 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6019 if (kid->op_type == OP_SCOPE) {
6023 else if (kid->op_type == OP_LEAVE) {
6024 if (o->op_type == OP_SORT) {
6025 op_null(kid); /* wipe out leave */
6028 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6029 if (k->op_next == kid)
6031 /* don't descend into loops */
6032 else if (k->op_type == OP_ENTERLOOP
6033 || k->op_type == OP_ENTERITER)
6035 k = cLOOPx(k)->op_lastop;
6040 kid->op_next = 0; /* just disconnect the leave */
6041 k = kLISTOP->op_first;
6046 if (o->op_type == OP_SORT) {
6047 /* provide scalar context for comparison function/block */
6053 o->op_flags |= OPf_SPECIAL;
6055 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6058 firstkid = firstkid->op_sibling;
6061 /* provide list context for arguments */
6062 if (o->op_type == OP_SORT)
6069 S_simplify_sort(pTHX_ OP *o)
6071 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6076 if (!(o->op_flags & OPf_STACKED))
6078 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6079 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6080 kid = kUNOP->op_first; /* get past null */
6081 if (kid->op_type != OP_SCOPE)
6083 kid = kLISTOP->op_last; /* get past scope */
6084 switch(kid->op_type) {
6092 k = kid; /* remember this node*/
6093 if (kBINOP->op_first->op_type != OP_RV2SV)
6095 kid = kBINOP->op_first; /* get past cmp */
6096 if (kUNOP->op_first->op_type != OP_GV)
6098 kid = kUNOP->op_first; /* get past rv2sv */
6100 if (GvSTASH(gv) != PL_curstash)
6102 gvname = GvNAME(gv);
6103 if (*gvname == 'a' && gvname[1] == '\0')
6105 else if (*gvname == 'b' && gvname[1] == '\0')
6110 kid = k; /* back to cmp */
6111 if (kBINOP->op_last->op_type != OP_RV2SV)
6113 kid = kBINOP->op_last; /* down to 2nd arg */
6114 if (kUNOP->op_first->op_type != OP_GV)
6116 kid = kUNOP->op_first; /* get past rv2sv */
6118 if (GvSTASH(gv) != PL_curstash)
6120 gvname = GvNAME(gv);
6122 ? !(*gvname == 'a' && gvname[1] == '\0')
6123 : !(*gvname == 'b' && gvname[1] == '\0'))
6125 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6127 o->op_private |= OPpSORT_DESCEND;
6128 if (k->op_type == OP_NCMP)
6129 o->op_private |= OPpSORT_NUMERIC;
6130 if (k->op_type == OP_I_NCMP)
6131 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6132 kid = cLISTOPo->op_first->op_sibling;
6133 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6134 op_free(kid); /* then delete it */
6138 Perl_ck_split(pTHX_ OP *o)
6143 if (o->op_flags & OPf_STACKED)
6144 return no_fh_allowed(o);
6146 kid = cLISTOPo->op_first;
6147 if (kid->op_type != OP_NULL)
6148 Perl_croak(aTHX_ "panic: ck_split");
6149 kid = kid->op_sibling;
6150 op_free(cLISTOPo->op_first);
6151 cLISTOPo->op_first = kid;
6153 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6154 cLISTOPo->op_last = kid; /* There was only one element previously */
6157 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6158 OP * const sibl = kid->op_sibling;
6159 kid->op_sibling = 0;
6160 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6161 if (cLISTOPo->op_first == cLISTOPo->op_last)
6162 cLISTOPo->op_last = kid;
6163 cLISTOPo->op_first = kid;
6164 kid->op_sibling = sibl;
6167 kid->op_type = OP_PUSHRE;
6168 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6170 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6171 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6172 "Use of /g modifier is meaningless in split");
6175 if (!kid->op_sibling)
6176 append_elem(OP_SPLIT, o, newDEFSVOP());
6178 kid = kid->op_sibling;
6181 if (!kid->op_sibling)
6182 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6184 kid = kid->op_sibling;
6187 if (kid->op_sibling)
6188 return too_many_arguments(o,OP_DESC(o));
6194 Perl_ck_join(pTHX_ OP *o)
6196 const OP * const kid = cLISTOPo->op_first->op_sibling;
6197 if (kid && kid->op_type == OP_MATCH) {
6198 if (ckWARN(WARN_SYNTAX)) {
6199 const REGEXP *re = PM_GETRE(kPMOP);
6200 const char *pmstr = re ? re->precomp : "STRING";
6201 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6202 "/%s/ should probably be written as \"%s\"",
6210 Perl_ck_subr(pTHX_ OP *o)
6212 OP *prev = ((cUNOPo->op_first->op_sibling)
6213 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6214 OP *o2 = prev->op_sibling;
6221 I32 contextclass = 0;
6225 o->op_private |= OPpENTERSUB_HASTARG;
6226 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6227 if (cvop->op_type == OP_RV2CV) {
6229 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6230 op_null(cvop); /* disable rv2cv */
6231 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6232 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6233 GV *gv = cGVOPx_gv(tmpop);
6236 tmpop->op_private |= OPpEARLY_CV;
6239 namegv = CvANON(cv) ? gv : CvGV(cv);
6240 proto = SvPV_nolen((SV*)cv);
6242 if (CvASSERTION(cv)) {
6243 if (PL_hints & HINT_ASSERTING) {
6244 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6245 o->op_private |= OPpENTERSUB_DB;
6249 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6250 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6251 "Impossible to activate assertion call");
6258 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6259 if (o2->op_type == OP_CONST)
6260 o2->op_private &= ~OPpCONST_STRICT;
6261 else if (o2->op_type == OP_LIST) {
6262 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6263 if (o && o->op_type == OP_CONST)
6264 o->op_private &= ~OPpCONST_STRICT;
6267 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6268 if (PERLDB_SUB && PL_curstash != PL_debstash)
6269 o->op_private |= OPpENTERSUB_DB;
6270 while (o2 != cvop) {
6274 return too_many_arguments(o, gv_ename(namegv));
6292 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6294 arg == 1 ? "block or sub {}" : "sub {}",
6295 gv_ename(namegv), o2);
6298 /* '*' allows any scalar type, including bareword */
6301 if (o2->op_type == OP_RV2GV)
6302 goto wrapref; /* autoconvert GLOB -> GLOBref */
6303 else if (o2->op_type == OP_CONST)
6304 o2->op_private &= ~OPpCONST_STRICT;
6305 else if (o2->op_type == OP_ENTERSUB) {
6306 /* accidental subroutine, revert to bareword */
6307 OP *gvop = ((UNOP*)o2)->op_first;
6308 if (gvop && gvop->op_type == OP_NULL) {
6309 gvop = ((UNOP*)gvop)->op_first;
6311 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6314 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6315 (gvop = ((UNOP*)gvop)->op_first) &&
6316 gvop->op_type == OP_GV)
6318 GV * const gv = cGVOPx_gv(gvop);
6319 OP * const sibling = o2->op_sibling;
6320 SV * const n = newSVpvn("",0);
6322 gv_fullname4(n, gv, "", FALSE);
6323 o2 = newSVOP(OP_CONST, 0, n);
6324 prev->op_sibling = o2;
6325 o2->op_sibling = sibling;
6341 if (contextclass++ == 0) {
6342 e = strchr(proto, ']');
6343 if (!e || e == proto)
6356 while (*--p != '[');
6357 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6358 gv_ename(namegv), o2);
6364 if (o2->op_type == OP_RV2GV)
6367 bad_type(arg, "symbol", gv_ename(namegv), o2);
6370 if (o2->op_type == OP_ENTERSUB)
6373 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6376 if (o2->op_type == OP_RV2SV ||
6377 o2->op_type == OP_PADSV ||
6378 o2->op_type == OP_HELEM ||
6379 o2->op_type == OP_AELEM ||
6380 o2->op_type == OP_THREADSV)
6383 bad_type(arg, "scalar", gv_ename(namegv), o2);
6386 if (o2->op_type == OP_RV2AV ||
6387 o2->op_type == OP_PADAV)
6390 bad_type(arg, "array", gv_ename(namegv), o2);
6393 if (o2->op_type == OP_RV2HV ||
6394 o2->op_type == OP_PADHV)
6397 bad_type(arg, "hash", gv_ename(namegv), o2);
6402 OP* const sib = kid->op_sibling;
6403 kid->op_sibling = 0;
6404 o2 = newUNOP(OP_REFGEN, 0, kid);
6405 o2->op_sibling = sib;
6406 prev->op_sibling = o2;
6408 if (contextclass && e) {
6423 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6424 gv_ename(namegv), cv);
6429 mod(o2, OP_ENTERSUB);
6431 o2 = o2->op_sibling;
6433 if (proto && !optional &&
6434 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6435 return too_few_arguments(o, gv_ename(namegv));
6438 o=newSVOP(OP_CONST, 0, newSViv(0));
6444 Perl_ck_svconst(pTHX_ OP *o)
6446 SvREADONLY_on(cSVOPo->op_sv);
6451 Perl_ck_trunc(pTHX_ OP *o)
6453 if (o->op_flags & OPf_KIDS) {
6454 SVOP *kid = (SVOP*)cUNOPo->op_first;
6456 if (kid->op_type == OP_NULL)
6457 kid = (SVOP*)kid->op_sibling;
6458 if (kid && kid->op_type == OP_CONST &&
6459 (kid->op_private & OPpCONST_BARE))
6461 o->op_flags |= OPf_SPECIAL;
6462 kid->op_private &= ~OPpCONST_STRICT;
6469 Perl_ck_unpack(pTHX_ OP *o)
6471 OP *kid = cLISTOPo->op_first;
6472 if (kid->op_sibling) {
6473 kid = kid->op_sibling;
6474 if (!kid->op_sibling)
6475 kid->op_sibling = newDEFSVOP();
6481 Perl_ck_substr(pTHX_ OP *o)
6484 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6485 OP *kid = cLISTOPo->op_first;
6487 if (kid->op_type == OP_NULL)
6488 kid = kid->op_sibling;
6490 kid->op_flags |= OPf_MOD;
6496 /* A peephole optimizer. We visit the ops in the order they're to execute.
6497 * See the comments at the top of this file for more details about when
6498 * peep() is called */
6501 Perl_peep(pTHX_ register OP *o)
6504 register OP* oldop = 0;
6506 if (!o || o->op_opt)
6510 SAVEVPTR(PL_curcop);
6511 for (; o; o = o->op_next) {
6515 switch (o->op_type) {
6519 PL_curcop = ((COP*)o); /* for warnings */
6524 if (cSVOPo->op_private & OPpCONST_STRICT)
6525 no_bareword_allowed(o);
6527 case OP_METHOD_NAMED:
6528 /* Relocate sv to the pad for thread safety.
6529 * Despite being a "constant", the SV is written to,
6530 * for reference counts, sv_upgrade() etc. */
6532 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6533 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6534 /* If op_sv is already a PADTMP then it is being used by
6535 * some pad, so make a copy. */
6536 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6537 SvREADONLY_on(PAD_SVl(ix));
6538 SvREFCNT_dec(cSVOPo->op_sv);
6541 SvREFCNT_dec(PAD_SVl(ix));
6542 SvPADTMP_on(cSVOPo->op_sv);
6543 PAD_SETSV(ix, cSVOPo->op_sv);
6544 /* XXX I don't know how this isn't readonly already. */
6545 SvREADONLY_on(PAD_SVl(ix));
6547 cSVOPo->op_sv = Nullsv;
6555 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6556 if (o->op_next->op_private & OPpTARGET_MY) {
6557 if (o->op_flags & OPf_STACKED) /* chained concats */
6558 goto ignore_optimization;
6560 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6561 o->op_targ = o->op_next->op_targ;
6562 o->op_next->op_targ = 0;
6563 o->op_private |= OPpTARGET_MY;
6566 op_null(o->op_next);
6568 ignore_optimization:
6572 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6574 break; /* Scalar stub must produce undef. List stub is noop */
6578 if (o->op_targ == OP_NEXTSTATE
6579 || o->op_targ == OP_DBSTATE
6580 || o->op_targ == OP_SETSTATE)
6582 PL_curcop = ((COP*)o);
6584 /* XXX: We avoid setting op_seq here to prevent later calls
6585 to peep() from mistakenly concluding that optimisation
6586 has already occurred. This doesn't fix the real problem,
6587 though (See 20010220.007). AMS 20010719 */
6588 /* op_seq functionality is now replaced by op_opt */
6589 if (oldop && o->op_next) {
6590 oldop->op_next = o->op_next;
6598 if (oldop && o->op_next) {
6599 oldop->op_next = o->op_next;
6607 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6608 OP* pop = (o->op_type == OP_PADAV) ?
6609 o->op_next : o->op_next->op_next;
6611 if (pop && pop->op_type == OP_CONST &&
6612 ((PL_op = pop->op_next)) &&
6613 pop->op_next->op_type == OP_AELEM &&
6614 !(pop->op_next->op_private &
6615 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6616 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6621 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6622 no_bareword_allowed(pop);
6623 if (o->op_type == OP_GV)
6624 op_null(o->op_next);
6625 op_null(pop->op_next);
6627 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6628 o->op_next = pop->op_next->op_next;
6629 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6630 o->op_private = (U8)i;
6631 if (o->op_type == OP_GV) {
6636 o->op_flags |= OPf_SPECIAL;
6637 o->op_type = OP_AELEMFAST;
6643 if (o->op_next->op_type == OP_RV2SV) {
6644 if (!(o->op_next->op_private & OPpDEREF)) {
6645 op_null(o->op_next);
6646 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6648 o->op_next = o->op_next->op_next;
6649 o->op_type = OP_GVSV;
6650 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6653 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6654 GV * const gv = cGVOPo_gv;
6655 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6656 /* XXX could check prototype here instead of just carping */
6657 SV * const sv = sv_newmortal();
6658 gv_efullname3(sv, gv, Nullch);
6659 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6660 "%"SVf"() called too early to check prototype",
6664 else if (o->op_next->op_type == OP_READLINE
6665 && o->op_next->op_next->op_type == OP_CONCAT
6666 && (o->op_next->op_next->op_flags & OPf_STACKED))
6668 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6669 o->op_type = OP_RCATLINE;
6670 o->op_flags |= OPf_STACKED;
6671 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6672 op_null(o->op_next->op_next);
6673 op_null(o->op_next);
6690 while (cLOGOP->op_other->op_type == OP_NULL)
6691 cLOGOP->op_other = cLOGOP->op_other->op_next;
6692 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6698 while (cLOOP->op_redoop->op_type == OP_NULL)
6699 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6700 peep(cLOOP->op_redoop);
6701 while (cLOOP->op_nextop->op_type == OP_NULL)
6702 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6703 peep(cLOOP->op_nextop);
6704 while (cLOOP->op_lastop->op_type == OP_NULL)
6705 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6706 peep(cLOOP->op_lastop);
6713 while (cPMOP->op_pmreplstart &&
6714 cPMOP->op_pmreplstart->op_type == OP_NULL)
6715 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6716 peep(cPMOP->op_pmreplstart);
6721 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6722 && ckWARN(WARN_SYNTAX))
6724 if (o->op_next->op_sibling &&
6725 o->op_next->op_sibling->op_type != OP_EXIT &&
6726 o->op_next->op_sibling->op_type != OP_WARN &&
6727 o->op_next->op_sibling->op_type != OP_DIE) {
6728 const line_t oldline = CopLINE(PL_curcop);
6730 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6731 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6732 "Statement unlikely to be reached");
6733 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6734 "\t(Maybe you meant system() when you said exec()?)\n");
6735 CopLINE_set(PL_curcop, oldline);
6745 const char *key = NULL;
6750 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6753 /* Make the CONST have a shared SV */
6754 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6755 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6756 key = SvPV_const(sv, keylen);
6757 lexname = newSVpvn_share(key,
6758 SvUTF8(sv) ? -(I32)keylen : keylen,
6764 if ((o->op_private & (OPpLVAL_INTRO)))
6767 rop = (UNOP*)((BINOP*)o)->op_first;
6768 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6770 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6771 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6773 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6774 if (!fields || !GvHV(*fields))
6776 key = SvPV_const(*svp, keylen);
6777 if (!hv_fetch(GvHV(*fields), key,
6778 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6780 Perl_croak(aTHX_ "No such class field \"%s\" "
6781 "in variable %s of type %s",
6782 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
6795 SVOP *first_key_op, *key_op;
6797 if ((o->op_private & (OPpLVAL_INTRO))
6798 /* I bet there's always a pushmark... */
6799 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6800 /* hmmm, no optimization if list contains only one key. */
6802 rop = (UNOP*)((LISTOP*)o)->op_last;
6803 if (rop->op_type != OP_RV2HV)
6805 if (rop->op_first->op_type == OP_PADSV)
6806 /* @$hash{qw(keys here)} */
6807 rop = (UNOP*)rop->op_first;
6809 /* @{$hash}{qw(keys here)} */
6810 if (rop->op_first->op_type == OP_SCOPE
6811 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6813 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6819 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6820 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6822 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6823 if (!fields || !GvHV(*fields))
6825 /* Again guessing that the pushmark can be jumped over.... */
6826 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6827 ->op_first->op_sibling;
6828 for (key_op = first_key_op; key_op;
6829 key_op = (SVOP*)key_op->op_sibling) {
6830 if (key_op->op_type != OP_CONST)
6832 svp = cSVOPx_svp(key_op);
6833 key = SvPV_const(*svp, keylen);
6834 if (!hv_fetch(GvHV(*fields), key,
6835 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6837 Perl_croak(aTHX_ "No such class field \"%s\" "
6838 "in variable %s of type %s",
6839 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6846 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6850 /* check that RHS of sort is a single plain array */
6851 OP *oright = cUNOPo->op_first;
6852 if (!oright || oright->op_type != OP_PUSHMARK)
6855 /* reverse sort ... can be optimised. */
6856 if (!cUNOPo->op_sibling) {
6857 /* Nothing follows us on the list. */
6858 OP * const reverse = o->op_next;
6860 if (reverse->op_type == OP_REVERSE &&
6861 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6862 OP * const pushmark = cUNOPx(reverse)->op_first;
6863 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6864 && (cUNOPx(pushmark)->op_sibling == o)) {
6865 /* reverse -> pushmark -> sort */
6866 o->op_private |= OPpSORT_REVERSE;
6868 pushmark->op_next = oright->op_next;
6874 /* make @a = sort @a act in-place */
6878 oright = cUNOPx(oright)->op_sibling;
6881 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6882 oright = cUNOPx(oright)->op_sibling;
6886 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6887 || oright->op_next != o
6888 || (oright->op_private & OPpLVAL_INTRO)
6892 /* o2 follows the chain of op_nexts through the LHS of the
6893 * assign (if any) to the aassign op itself */
6895 if (!o2 || o2->op_type != OP_NULL)
6898 if (!o2 || o2->op_type != OP_PUSHMARK)
6901 if (o2 && o2->op_type == OP_GV)
6904 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6905 || (o2->op_private & OPpLVAL_INTRO)
6910 if (!o2 || o2->op_type != OP_NULL)
6913 if (!o2 || o2->op_type != OP_AASSIGN
6914 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6917 /* check that the sort is the first arg on RHS of assign */
6919 o2 = cUNOPx(o2)->op_first;
6920 if (!o2 || o2->op_type != OP_NULL)
6922 o2 = cUNOPx(o2)->op_first;
6923 if (!o2 || o2->op_type != OP_PUSHMARK)
6925 if (o2->op_sibling != o)
6928 /* check the array is the same on both sides */
6929 if (oleft->op_type == OP_RV2AV) {
6930 if (oright->op_type != OP_RV2AV
6931 || !cUNOPx(oright)->op_first
6932 || cUNOPx(oright)->op_first->op_type != OP_GV
6933 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6934 cGVOPx_gv(cUNOPx(oright)->op_first)
6938 else if (oright->op_type != OP_PADAV
6939 || oright->op_targ != oleft->op_targ
6943 /* transfer MODishness etc from LHS arg to RHS arg */
6944 oright->op_flags = oleft->op_flags;
6945 o->op_private |= OPpSORT_INPLACE;
6947 /* excise push->gv->rv2av->null->aassign */
6948 o2 = o->op_next->op_next;
6949 op_null(o2); /* PUSHMARK */
6951 if (o2->op_type == OP_GV) {
6952 op_null(o2); /* GV */
6955 op_null(o2); /* RV2AV or PADAV */
6956 o2 = o2->op_next->op_next;
6957 op_null(o2); /* AASSIGN */
6959 o->op_next = o2->op_next;
6965 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6967 LISTOP *enter, *exlist;
6970 enter = (LISTOP *) o->op_next;
6973 if (enter->op_type == OP_NULL) {
6974 enter = (LISTOP *) enter->op_next;
6978 /* for $a (...) will have OP_GV then OP_RV2GV here.
6979 for (...) just has an OP_GV. */
6980 if (enter->op_type == OP_GV) {
6981 gvop = (OP *) enter;
6982 enter = (LISTOP *) enter->op_next;
6985 if (enter->op_type == OP_RV2GV) {
6986 enter = (LISTOP *) enter->op_next;
6992 if (enter->op_type != OP_ENTERITER)
6995 iter = enter->op_next;
6996 if (!iter || iter->op_type != OP_ITER)
6999 expushmark = enter->op_first;
7000 if (!expushmark || expushmark->op_type != OP_NULL
7001 || expushmark->op_targ != OP_PUSHMARK)
7004 exlist = (LISTOP *) expushmark->op_sibling;
7005 if (!exlist || exlist->op_type != OP_NULL
7006 || exlist->op_targ != OP_LIST)
7009 if (exlist->op_last != o) {
7010 /* Mmm. Was expecting to point back to this op. */
7013 theirmark = exlist->op_first;
7014 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7017 if (theirmark->op_sibling != o) {
7018 /* There's something between the mark and the reverse, eg
7019 for (1, reverse (...))
7024 ourmark = ((LISTOP *)o)->op_first;
7025 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7028 ourlast = ((LISTOP *)o)->op_last;
7029 if (!ourlast || ourlast->op_next != o)
7032 rv2av = ourmark->op_sibling;
7033 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7034 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7035 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7036 /* We're just reversing a single array. */
7037 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7038 enter->op_flags |= OPf_STACKED;
7041 /* We don't have control over who points to theirmark, so sacrifice
7043 theirmark->op_next = ourmark->op_next;
7044 theirmark->op_flags = ourmark->op_flags;
7045 ourlast->op_next = gvop ? gvop : (OP *) enter;
7048 enter->op_private |= OPpITER_REVERSED;
7049 iter->op_private |= OPpITER_REVERSED;
7064 Perl_custom_op_name(pTHX_ const OP* o)
7066 const IV index = PTR2IV(o->op_ppaddr);
7070 if (!PL_custom_op_names) /* This probably shouldn't happen */
7071 return (char *)PL_op_name[OP_CUSTOM];
7073 keysv = sv_2mortal(newSViv(index));
7075 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7077 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7079 return SvPV_nolen(HeVAL(he));
7083 Perl_custom_op_desc(pTHX_ const OP* o)
7085 const IV index = PTR2IV(o->op_ppaddr);
7089 if (!PL_custom_op_descs)
7090 return (char *)PL_op_desc[OP_CUSTOM];
7092 keysv = sv_2mortal(newSViv(index));
7094 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7096 return (char *)PL_op_desc[OP_CUSTOM];
7098 return SvPV_nolen(HeVAL(he));
7103 /* Efficient sub that returns a constant scalar value. */
7105 const_sv_xsub(pTHX_ CV* cv)
7110 Perl_croak(aTHX_ "usage: %s::%s()",
7111 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7115 ST(0) = (SV*)XSANY.any_ptr;
7121 * c-indentation-style: bsd
7123 * indent-tabs-mode: t
7126 * ex: set ts=8 sts=4 sw=4 noet: