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));
1534 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1535 if (o->op_type == OP_CONST)
1536 rop = append_elem(OP_LIST, rop,
1537 newSVOP(OP_CONST, o->op_flags,
1538 SvREFCNT_inc(cSVOPo->op_sv)));
1545 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1550 /* fake up C<use attributes $pkg,$rv,@attrs> */
1551 ENTER; /* need to protect against side-effects of 'use' */
1553 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1555 #define ATTRSMODULE "attributes"
1556 #define ATTRSMODULE_PM "attributes.pm"
1559 /* Don't force the C<use> if we don't need it. */
1560 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1561 sizeof(ATTRSMODULE_PM)-1, 0);
1562 if (svp && *svp != &PL_sv_undef)
1563 ; /* already in %INC */
1565 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1566 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1570 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1571 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1573 prepend_elem(OP_LIST,
1574 newSVOP(OP_CONST, 0, stashsv),
1575 prepend_elem(OP_LIST,
1576 newSVOP(OP_CONST, 0,
1578 dup_attrlist(attrs))));
1584 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1586 OP *pack, *imop, *arg;
1592 assert(target->op_type == OP_PADSV ||
1593 target->op_type == OP_PADHV ||
1594 target->op_type == OP_PADAV);
1596 /* Ensure that attributes.pm is loaded. */
1597 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1599 /* Need package name for method call. */
1600 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1602 /* Build up the real arg-list. */
1603 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1605 arg = newOP(OP_PADSV, 0);
1606 arg->op_targ = target->op_targ;
1607 arg = prepend_elem(OP_LIST,
1608 newSVOP(OP_CONST, 0, stashsv),
1609 prepend_elem(OP_LIST,
1610 newUNOP(OP_REFGEN, 0,
1611 mod(arg, OP_REFGEN)),
1612 dup_attrlist(attrs)));
1614 /* Fake up a method call to import */
1615 meth = newSVpvn_share("import", 6, 0);
1616 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1617 append_elem(OP_LIST,
1618 prepend_elem(OP_LIST, pack, list(arg)),
1619 newSVOP(OP_METHOD_NAMED, 0, meth)));
1620 imop->op_private |= OPpENTERSUB_NOMOD;
1622 /* Combine the ops. */
1623 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1627 =notfor apidoc apply_attrs_string
1629 Attempts to apply a list of attributes specified by the C<attrstr> and
1630 C<len> arguments to the subroutine identified by the C<cv> argument which
1631 is expected to be associated with the package identified by the C<stashpv>
1632 argument (see L<attributes>). It gets this wrong, though, in that it
1633 does not correctly identify the boundaries of the individual attribute
1634 specifications within C<attrstr>. This is not really intended for the
1635 public API, but has to be listed here for systems such as AIX which
1636 need an explicit export list for symbols. (It's called from XS code
1637 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1638 to respect attribute syntax properly would be welcome.
1644 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1645 const char *attrstr, STRLEN len)
1650 len = strlen(attrstr);
1654 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1656 const char * const sstr = attrstr;
1657 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1658 attrs = append_elem(OP_LIST, attrs,
1659 newSVOP(OP_CONST, 0,
1660 newSVpvn(sstr, attrstr-sstr)));
1664 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1665 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1666 Nullsv, prepend_elem(OP_LIST,
1667 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1668 prepend_elem(OP_LIST,
1669 newSVOP(OP_CONST, 0,
1675 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1679 if (!o || PL_error_count)
1683 if (type == OP_LIST) {
1685 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1686 my_kid(kid, attrs, imopsp);
1687 } else if (type == OP_UNDEF) {
1689 } else if (type == OP_RV2SV || /* "our" declaration */
1691 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1692 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1693 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1694 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1696 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1698 PL_in_my_stash = NULL;
1699 apply_attrs(GvSTASH(gv),
1700 (type == OP_RV2SV ? GvSV(gv) :
1701 type == OP_RV2AV ? (SV*)GvAV(gv) :
1702 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1705 o->op_private |= OPpOUR_INTRO;
1708 else if (type != OP_PADSV &&
1711 type != OP_PUSHMARK)
1713 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1715 PL_in_my == KEY_our ? "our" : "my"));
1718 else if (attrs && type != OP_PUSHMARK) {
1722 PL_in_my_stash = NULL;
1724 /* check for C<my Dog $spot> when deciding package */
1725 stash = PAD_COMPNAME_TYPE(o->op_targ);
1727 stash = PL_curstash;
1728 apply_attrs_my(stash, o, attrs, imopsp);
1730 o->op_flags |= OPf_MOD;
1731 o->op_private |= OPpLVAL_INTRO;
1736 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1739 int maybe_scalar = 0;
1741 /* [perl #17376]: this appears to be premature, and results in code such as
1742 C< our(%x); > executing in list mode rather than void mode */
1744 if (o->op_flags & OPf_PARENS)
1754 o = my_kid(o, attrs, &rops);
1756 if (maybe_scalar && o->op_type == OP_PADSV) {
1757 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1758 o->op_private |= OPpLVAL_INTRO;
1761 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1764 PL_in_my_stash = NULL;
1769 Perl_my(pTHX_ OP *o)
1771 return my_attrs(o, Nullop);
1775 Perl_sawparens(pTHX_ OP *o)
1778 o->op_flags |= OPf_PARENS;
1783 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1788 if ( (left->op_type == OP_RV2AV ||
1789 left->op_type == OP_RV2HV ||
1790 left->op_type == OP_PADAV ||
1791 left->op_type == OP_PADHV)
1792 && ckWARN(WARN_MISC))
1794 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1795 right->op_type == OP_TRANS)
1796 ? right->op_type : OP_MATCH];
1797 const char * const sample = ((left->op_type == OP_RV2AV ||
1798 left->op_type == OP_PADAV)
1799 ? "@array" : "%hash");
1800 Perl_warner(aTHX_ packWARN(WARN_MISC),
1801 "Applying %s to %s will act on scalar(%s)",
1802 desc, sample, sample);
1805 if (right->op_type == OP_CONST &&
1806 cSVOPx(right)->op_private & OPpCONST_BARE &&
1807 cSVOPx(right)->op_private & OPpCONST_STRICT)
1809 no_bareword_allowed(right);
1812 ismatchop = right->op_type == OP_MATCH ||
1813 right->op_type == OP_SUBST ||
1814 right->op_type == OP_TRANS;
1815 if (ismatchop && right->op_private & OPpTARGET_MY) {
1817 right->op_private &= ~OPpTARGET_MY;
1819 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1820 right->op_flags |= OPf_STACKED;
1821 if (right->op_type != OP_MATCH &&
1822 ! (right->op_type == OP_TRANS &&
1823 right->op_private & OPpTRANS_IDENTICAL))
1824 left = mod(left, right->op_type);
1825 if (right->op_type == OP_TRANS)
1826 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1828 o = prepend_elem(right->op_type, scalar(left), right);
1830 return newUNOP(OP_NOT, 0, scalar(o));
1834 return bind_match(type, left,
1835 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1839 Perl_invert(pTHX_ OP *o)
1843 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1844 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1848 Perl_scope(pTHX_ OP *o)
1852 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1853 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1854 o->op_type = OP_LEAVE;
1855 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1857 else if (o->op_type == OP_LINESEQ) {
1859 o->op_type = OP_SCOPE;
1860 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1861 kid = ((LISTOP*)o)->op_first;
1862 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1865 /* The following deals with things like 'do {1 for 1}' */
1866 kid = kid->op_sibling;
1868 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1873 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1879 Perl_block_start(pTHX_ int full)
1881 const int retval = PL_savestack_ix;
1882 pad_block_start(full);
1884 PL_hints &= ~HINT_BLOCK_SCOPE;
1885 SAVESPTR(PL_compiling.cop_warnings);
1886 if (! specialWARN(PL_compiling.cop_warnings)) {
1887 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1888 SAVEFREESV(PL_compiling.cop_warnings) ;
1890 SAVESPTR(PL_compiling.cop_io);
1891 if (! specialCopIO(PL_compiling.cop_io)) {
1892 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1893 SAVEFREESV(PL_compiling.cop_io) ;
1899 Perl_block_end(pTHX_ I32 floor, OP *seq)
1901 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1902 OP* const retval = scalarseq(seq);
1904 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1906 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1914 const I32 offset = pad_findmy("$_");
1915 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1916 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1919 OP * const o = newOP(OP_PADSV, 0);
1920 o->op_targ = offset;
1926 Perl_newPROG(pTHX_ OP *o)
1931 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1932 ((PL_in_eval & EVAL_KEEPERR)
1933 ? OPf_SPECIAL : 0), o);
1934 PL_eval_start = linklist(PL_eval_root);
1935 PL_eval_root->op_private |= OPpREFCOUNTED;
1936 OpREFCNT_set(PL_eval_root, 1);
1937 PL_eval_root->op_next = 0;
1938 CALL_PEEP(PL_eval_start);
1941 if (o->op_type == OP_STUB) {
1942 PL_comppad_name = 0;
1947 PL_main_root = scope(sawparens(scalarvoid(o)));
1948 PL_curcop = &PL_compiling;
1949 PL_main_start = LINKLIST(PL_main_root);
1950 PL_main_root->op_private |= OPpREFCOUNTED;
1951 OpREFCNT_set(PL_main_root, 1);
1952 PL_main_root->op_next = 0;
1953 CALL_PEEP(PL_main_start);
1956 /* Register with debugger */
1958 CV * const cv = get_cv("DB::postponed", FALSE);
1962 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1964 call_sv((SV*)cv, G_DISCARD);
1971 Perl_localize(pTHX_ OP *o, I32 lex)
1973 if (o->op_flags & OPf_PARENS)
1974 /* [perl #17376]: this appears to be premature, and results in code such as
1975 C< our(%x); > executing in list mode rather than void mode */
1982 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
1983 && ckWARN(WARN_PARENTHESIS))
1985 char *s = PL_bufptr;
1988 /* some heuristics to detect a potential error */
1989 while (*s && (strchr(", \t\n", *s)))
1993 if (*s && strchr("@$%*", *s) && *++s
1994 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1997 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1999 while (*s && (strchr(", \t\n", *s)))
2005 if (sigil && (*s == ';' || *s == '=')) {
2006 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2007 "Parentheses missing around \"%s\" list",
2008 lex ? (PL_in_my == KEY_our ? "our" : "my")
2016 o = mod(o, OP_NULL); /* a bit kludgey */
2018 PL_in_my_stash = NULL;
2023 Perl_jmaybe(pTHX_ OP *o)
2025 if (o->op_type == OP_LIST) {
2027 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2028 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2034 Perl_fold_constants(pTHX_ register OP *o)
2038 I32 type = o->op_type;
2041 if (PL_opargs[type] & OA_RETSCALAR)
2043 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2044 o->op_targ = pad_alloc(type, SVs_PADTMP);
2046 /* integerize op, unless it happens to be C<-foo>.
2047 * XXX should pp_i_negate() do magic string negation instead? */
2048 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2049 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2050 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2052 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2055 if (!(PL_opargs[type] & OA_FOLDCONST))
2060 /* XXX might want a ck_negate() for this */
2061 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2072 /* XXX what about the numeric ops? */
2073 if (PL_hints & HINT_LOCALE)
2078 goto nope; /* Don't try to run w/ errors */
2080 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2081 if ((curop->op_type != OP_CONST ||
2082 (curop->op_private & OPpCONST_BARE)) &&
2083 curop->op_type != OP_LIST &&
2084 curop->op_type != OP_SCALAR &&
2085 curop->op_type != OP_NULL &&
2086 curop->op_type != OP_PUSHMARK)
2092 curop = LINKLIST(o);
2096 sv = *(PL_stack_sp--);
2097 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2098 pad_swipe(o->op_targ, FALSE);
2099 else if (SvTEMP(sv)) { /* grab mortal temp? */
2100 (void)SvREFCNT_inc(sv);
2104 if (type == OP_RV2GV)
2105 return newGVOP(OP_GV, 0, (GV*)sv);
2106 return newSVOP(OP_CONST, 0, sv);
2113 Perl_gen_constant_list(pTHX_ register OP *o)
2117 const I32 oldtmps_floor = PL_tmps_floor;
2121 return o; /* Don't attempt to run with errors */
2123 PL_op = curop = LINKLIST(o);
2130 PL_tmps_floor = oldtmps_floor;
2132 o->op_type = OP_RV2AV;
2133 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2134 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2135 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2136 o->op_opt = 0; /* needs to be revisited in peep() */
2137 curop = ((UNOP*)o)->op_first;
2138 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2145 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2148 if (!o || o->op_type != OP_LIST)
2149 o = newLISTOP(OP_LIST, 0, o, Nullop);
2151 o->op_flags &= ~OPf_WANT;
2153 if (!(PL_opargs[type] & OA_MARK))
2154 op_null(cLISTOPo->op_first);
2156 o->op_type = (OPCODE)type;
2157 o->op_ppaddr = PL_ppaddr[type];
2158 o->op_flags |= flags;
2160 o = CHECKOP(type, o);
2161 if (o->op_type != (unsigned)type)
2164 return fold_constants(o);
2167 /* List constructors */
2170 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2178 if (first->op_type != (unsigned)type
2179 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2181 return newLISTOP(type, 0, first, last);
2184 if (first->op_flags & OPf_KIDS)
2185 ((LISTOP*)first)->op_last->op_sibling = last;
2187 first->op_flags |= OPf_KIDS;
2188 ((LISTOP*)first)->op_first = last;
2190 ((LISTOP*)first)->op_last = last;
2195 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2203 if (first->op_type != (unsigned)type)
2204 return prepend_elem(type, (OP*)first, (OP*)last);
2206 if (last->op_type != (unsigned)type)
2207 return append_elem(type, (OP*)first, (OP*)last);
2209 first->op_last->op_sibling = last->op_first;
2210 first->op_last = last->op_last;
2211 first->op_flags |= (last->op_flags & OPf_KIDS);
2219 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2227 if (last->op_type == (unsigned)type) {
2228 if (type == OP_LIST) { /* already a PUSHMARK there */
2229 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2230 ((LISTOP*)last)->op_first->op_sibling = first;
2231 if (!(first->op_flags & OPf_PARENS))
2232 last->op_flags &= ~OPf_PARENS;
2235 if (!(last->op_flags & OPf_KIDS)) {
2236 ((LISTOP*)last)->op_last = first;
2237 last->op_flags |= OPf_KIDS;
2239 first->op_sibling = ((LISTOP*)last)->op_first;
2240 ((LISTOP*)last)->op_first = first;
2242 last->op_flags |= OPf_KIDS;
2246 return newLISTOP(type, 0, first, last);
2252 Perl_newNULLLIST(pTHX)
2254 return newOP(OP_STUB, 0);
2258 Perl_force_list(pTHX_ OP *o)
2260 if (!o || o->op_type != OP_LIST)
2261 o = newLISTOP(OP_LIST, 0, o, Nullop);
2267 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2272 NewOp(1101, listop, 1, LISTOP);
2274 listop->op_type = (OPCODE)type;
2275 listop->op_ppaddr = PL_ppaddr[type];
2278 listop->op_flags = (U8)flags;
2282 else if (!first && last)
2285 first->op_sibling = last;
2286 listop->op_first = first;
2287 listop->op_last = last;
2288 if (type == OP_LIST) {
2289 OP* const pushop = newOP(OP_PUSHMARK, 0);
2290 pushop->op_sibling = first;
2291 listop->op_first = pushop;
2292 listop->op_flags |= OPf_KIDS;
2294 listop->op_last = pushop;
2297 return CHECKOP(type, listop);
2301 Perl_newOP(pTHX_ I32 type, I32 flags)
2305 NewOp(1101, o, 1, OP);
2306 o->op_type = (OPCODE)type;
2307 o->op_ppaddr = PL_ppaddr[type];
2308 o->op_flags = (U8)flags;
2311 o->op_private = (U8)(0 | (flags >> 8));
2312 if (PL_opargs[type] & OA_RETSCALAR)
2314 if (PL_opargs[type] & OA_TARGET)
2315 o->op_targ = pad_alloc(type, SVs_PADTMP);
2316 return CHECKOP(type, o);
2320 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2326 first = newOP(OP_STUB, 0);
2327 if (PL_opargs[type] & OA_MARK)
2328 first = force_list(first);
2330 NewOp(1101, unop, 1, UNOP);
2331 unop->op_type = (OPCODE)type;
2332 unop->op_ppaddr = PL_ppaddr[type];
2333 unop->op_first = first;
2334 unop->op_flags = (U8)(flags | OPf_KIDS);
2335 unop->op_private = (U8)(1 | (flags >> 8));
2336 unop = (UNOP*) CHECKOP(type, unop);
2340 return fold_constants((OP *) unop);
2344 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2348 NewOp(1101, binop, 1, BINOP);
2351 first = newOP(OP_NULL, 0);
2353 binop->op_type = (OPCODE)type;
2354 binop->op_ppaddr = PL_ppaddr[type];
2355 binop->op_first = first;
2356 binop->op_flags = (U8)(flags | OPf_KIDS);
2359 binop->op_private = (U8)(1 | (flags >> 8));
2362 binop->op_private = (U8)(2 | (flags >> 8));
2363 first->op_sibling = last;
2366 binop = (BINOP*)CHECKOP(type, binop);
2367 if (binop->op_next || binop->op_type != (OPCODE)type)
2370 binop->op_last = binop->op_first->op_sibling;
2372 return fold_constants((OP *)binop);
2375 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2376 static int uvcompare(const void *a, const void *b)
2378 if (*((const UV *)a) < (*(const UV *)b))
2380 if (*((const UV *)a) > (*(const UV *)b))
2382 if (*((const UV *)a+1) < (*(const UV *)b+1))
2384 if (*((const UV *)a+1) > (*(const UV *)b+1))
2390 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2392 SV * const tstr = ((SVOP*)expr)->op_sv;
2393 SV * const rstr = ((SVOP*)repl)->op_sv;
2396 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2397 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2401 register short *tbl;
2403 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2404 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2405 I32 del = o->op_private & OPpTRANS_DELETE;
2406 PL_hints |= HINT_BLOCK_SCOPE;
2409 o->op_private |= OPpTRANS_FROM_UTF;
2412 o->op_private |= OPpTRANS_TO_UTF;
2414 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2415 SV* const listsv = newSVpvn("# comment\n",10);
2417 const U8* tend = t + tlen;
2418 const U8* rend = r + rlen;
2432 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2433 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2439 t = tsave = bytes_to_utf8(t, &len);
2442 if (!to_utf && rlen) {
2444 r = rsave = bytes_to_utf8(r, &len);
2448 /* There are several snags with this code on EBCDIC:
2449 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2450 2. scan_const() in toke.c has encoded chars in native encoding which makes
2451 ranges at least in EBCDIC 0..255 range the bottom odd.
2455 U8 tmpbuf[UTF8_MAXBYTES+1];
2458 Newx(cp, 2*tlen, UV);
2460 transv = newSVpvn("",0);
2462 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2464 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2466 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2470 cp[2*i+1] = cp[2*i];
2474 qsort(cp, i, 2*sizeof(UV), uvcompare);
2475 for (j = 0; j < i; j++) {
2477 diff = val - nextmin;
2479 t = uvuni_to_utf8(tmpbuf,nextmin);
2480 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2482 U8 range_mark = UTF_TO_NATIVE(0xff);
2483 t = uvuni_to_utf8(tmpbuf, val - 1);
2484 sv_catpvn(transv, (char *)&range_mark, 1);
2485 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2492 t = uvuni_to_utf8(tmpbuf,nextmin);
2493 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2495 U8 range_mark = UTF_TO_NATIVE(0xff);
2496 sv_catpvn(transv, (char *)&range_mark, 1);
2498 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2499 UNICODE_ALLOW_SUPER);
2500 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2501 t = (const U8*)SvPVX_const(transv);
2502 tlen = SvCUR(transv);
2506 else if (!rlen && !del) {
2507 r = t; rlen = tlen; rend = tend;
2510 if ((!rlen && !del) || t == r ||
2511 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2513 o->op_private |= OPpTRANS_IDENTICAL;
2517 while (t < tend || tfirst <= tlast) {
2518 /* see if we need more "t" chars */
2519 if (tfirst > tlast) {
2520 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2522 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2524 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2531 /* now see if we need more "r" chars */
2532 if (rfirst > rlast) {
2534 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2536 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2538 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2547 rfirst = rlast = 0xffffffff;
2551 /* now see which range will peter our first, if either. */
2552 tdiff = tlast - tfirst;
2553 rdiff = rlast - rfirst;
2560 if (rfirst == 0xffffffff) {
2561 diff = tdiff; /* oops, pretend rdiff is infinite */
2563 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2564 (long)tfirst, (long)tlast);
2566 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2570 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2571 (long)tfirst, (long)(tfirst + diff),
2574 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2575 (long)tfirst, (long)rfirst);
2577 if (rfirst + diff > max)
2578 max = rfirst + diff;
2580 grows = (tfirst < rfirst &&
2581 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2593 else if (max > 0xff)
2598 Safefree(cPVOPo->op_pv);
2599 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2600 SvREFCNT_dec(listsv);
2602 SvREFCNT_dec(transv);
2604 if (!del && havefinal && rlen)
2605 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2606 newSVuv((UV)final), 0);
2609 o->op_private |= OPpTRANS_GROWS;
2621 tbl = (short*)cPVOPo->op_pv;
2623 Zero(tbl, 256, short);
2624 for (i = 0; i < (I32)tlen; i++)
2626 for (i = 0, j = 0; i < 256; i++) {
2628 if (j >= (I32)rlen) {
2637 if (i < 128 && r[j] >= 128)
2647 o->op_private |= OPpTRANS_IDENTICAL;
2649 else if (j >= (I32)rlen)
2652 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2653 tbl[0x100] = (short)(rlen - j);
2654 for (i=0; i < (I32)rlen - j; i++)
2655 tbl[0x101+i] = r[j+i];
2659 if (!rlen && !del) {
2662 o->op_private |= OPpTRANS_IDENTICAL;
2664 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2665 o->op_private |= OPpTRANS_IDENTICAL;
2667 for (i = 0; i < 256; i++)
2669 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2670 if (j >= (I32)rlen) {
2672 if (tbl[t[i]] == -1)
2678 if (tbl[t[i]] == -1) {
2679 if (t[i] < 128 && r[j] >= 128)
2686 o->op_private |= OPpTRANS_GROWS;
2694 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2699 NewOp(1101, pmop, 1, PMOP);
2700 pmop->op_type = (OPCODE)type;
2701 pmop->op_ppaddr = PL_ppaddr[type];
2702 pmop->op_flags = (U8)flags;
2703 pmop->op_private = (U8)(0 | (flags >> 8));
2705 if (PL_hints & HINT_RE_TAINT)
2706 pmop->op_pmpermflags |= PMf_RETAINT;
2707 if (PL_hints & HINT_LOCALE)
2708 pmop->op_pmpermflags |= PMf_LOCALE;
2709 pmop->op_pmflags = pmop->op_pmpermflags;
2712 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2713 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2714 pmop->op_pmoffset = SvIV(repointer);
2715 SvREPADTMP_off(repointer);
2716 sv_setiv(repointer,0);
2718 SV * const repointer = newSViv(0);
2719 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2720 pmop->op_pmoffset = av_len(PL_regex_padav);
2721 PL_regex_pad = AvARRAY(PL_regex_padav);
2725 /* link into pm list */
2726 if (type != OP_TRANS && PL_curstash) {
2727 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2730 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2732 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2733 mg->mg_obj = (SV*)pmop;
2734 PmopSTASH_set(pmop,PL_curstash);
2737 return CHECKOP(type, pmop);
2740 /* Given some sort of match op o, and an expression expr containing a
2741 * pattern, either compile expr into a regex and attach it to o (if it's
2742 * constant), or convert expr into a runtime regcomp op sequence (if it's
2745 * isreg indicates that the pattern is part of a regex construct, eg
2746 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2747 * split "pattern", which aren't. In the former case, expr will be a list
2748 * if the pattern contains more than one term (eg /a$b/) or if it contains
2749 * a replacement, ie s/// or tr///.
2753 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2758 I32 repl_has_vars = 0;
2762 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2763 /* last element in list is the replacement; pop it */
2765 repl = cLISTOPx(expr)->op_last;
2766 kid = cLISTOPx(expr)->op_first;
2767 while (kid->op_sibling != repl)
2768 kid = kid->op_sibling;
2769 kid->op_sibling = Nullop;
2770 cLISTOPx(expr)->op_last = kid;
2773 if (isreg && expr->op_type == OP_LIST &&
2774 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2776 /* convert single element list to element */
2777 OP* const oe = expr;
2778 expr = cLISTOPx(oe)->op_first->op_sibling;
2779 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2780 cLISTOPx(oe)->op_last = Nullop;
2784 if (o->op_type == OP_TRANS) {
2785 return pmtrans(o, expr, repl);
2788 reglist = isreg && expr->op_type == OP_LIST;
2792 PL_hints |= HINT_BLOCK_SCOPE;
2795 if (expr->op_type == OP_CONST) {
2797 SV *pat = ((SVOP*)expr)->op_sv;
2798 const char *p = SvPV_const(pat, plen);
2799 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2800 U32 was_readonly = SvREADONLY(pat);
2804 sv_force_normal_flags(pat, 0);
2805 assert(!SvREADONLY(pat));
2808 SvREADONLY_off(pat);
2812 sv_setpvn(pat, "\\s+", 3);
2814 SvFLAGS(pat) |= was_readonly;
2816 p = SvPV_const(pat, plen);
2817 pm->op_pmflags |= PMf_SKIPWHITE;
2820 pm->op_pmdynflags |= PMdf_UTF8;
2821 /* FIXME - can we make this function take const char * args? */
2822 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2823 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2824 pm->op_pmflags |= PMf_WHITE;
2828 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2829 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2831 : OP_REGCMAYBE),0,expr);
2833 NewOp(1101, rcop, 1, LOGOP);
2834 rcop->op_type = OP_REGCOMP;
2835 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2836 rcop->op_first = scalar(expr);
2837 rcop->op_flags |= OPf_KIDS
2838 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2839 | (reglist ? OPf_STACKED : 0);
2840 rcop->op_private = 1;
2843 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2845 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2848 /* establish postfix order */
2849 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2851 rcop->op_next = expr;
2852 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2855 rcop->op_next = LINKLIST(expr);
2856 expr->op_next = (OP*)rcop;
2859 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2864 if (pm->op_pmflags & PMf_EVAL) {
2866 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2867 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2869 else if (repl->op_type == OP_CONST)
2873 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2874 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2875 if (curop->op_type == OP_GV) {
2876 GV *gv = cGVOPx_gv(curop);
2878 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2881 else if (curop->op_type == OP_RV2CV)
2883 else if (curop->op_type == OP_RV2SV ||
2884 curop->op_type == OP_RV2AV ||
2885 curop->op_type == OP_RV2HV ||
2886 curop->op_type == OP_RV2GV) {
2887 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2890 else if (curop->op_type == OP_PADSV ||
2891 curop->op_type == OP_PADAV ||
2892 curop->op_type == OP_PADHV ||
2893 curop->op_type == OP_PADANY) {
2896 else if (curop->op_type == OP_PUSHRE)
2897 ; /* Okay here, dangerous in newASSIGNOP */
2907 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2908 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2909 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2910 prepend_elem(o->op_type, scalar(repl), o);
2913 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2914 pm->op_pmflags |= PMf_MAYBE_CONST;
2915 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2917 NewOp(1101, rcop, 1, LOGOP);
2918 rcop->op_type = OP_SUBSTCONT;
2919 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2920 rcop->op_first = scalar(repl);
2921 rcop->op_flags |= OPf_KIDS;
2922 rcop->op_private = 1;
2925 /* establish postfix order */
2926 rcop->op_next = LINKLIST(repl);
2927 repl->op_next = (OP*)rcop;
2929 pm->op_pmreplroot = scalar((OP*)rcop);
2930 pm->op_pmreplstart = LINKLIST(rcop);
2939 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2943 NewOp(1101, svop, 1, SVOP);
2944 svop->op_type = (OPCODE)type;
2945 svop->op_ppaddr = PL_ppaddr[type];
2947 svop->op_next = (OP*)svop;
2948 svop->op_flags = (U8)flags;
2949 if (PL_opargs[type] & OA_RETSCALAR)
2951 if (PL_opargs[type] & OA_TARGET)
2952 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2953 return CHECKOP(type, svop);
2957 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2961 NewOp(1101, padop, 1, PADOP);
2962 padop->op_type = (OPCODE)type;
2963 padop->op_ppaddr = PL_ppaddr[type];
2964 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2965 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2966 PAD_SETSV(padop->op_padix, sv);
2969 padop->op_next = (OP*)padop;
2970 padop->op_flags = (U8)flags;
2971 if (PL_opargs[type] & OA_RETSCALAR)
2973 if (PL_opargs[type] & OA_TARGET)
2974 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2975 return CHECKOP(type, padop);
2979 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2985 return newPADOP(type, flags, SvREFCNT_inc(gv));
2987 return newSVOP(type, flags, SvREFCNT_inc(gv));
2992 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2996 NewOp(1101, pvop, 1, PVOP);
2997 pvop->op_type = (OPCODE)type;
2998 pvop->op_ppaddr = PL_ppaddr[type];
3000 pvop->op_next = (OP*)pvop;
3001 pvop->op_flags = (U8)flags;
3002 if (PL_opargs[type] & OA_RETSCALAR)
3004 if (PL_opargs[type] & OA_TARGET)
3005 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3006 return CHECKOP(type, pvop);
3010 Perl_package(pTHX_ OP *o)
3015 save_hptr(&PL_curstash);
3016 save_item(PL_curstname);
3018 name = SvPV_const(cSVOPo->op_sv, len);
3019 PL_curstash = gv_stashpvn(name, len, TRUE);
3020 sv_setpvn(PL_curstname, name, len);
3023 PL_hints |= HINT_BLOCK_SCOPE;
3024 PL_copline = NOLINE;
3029 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3035 if (idop->op_type != OP_CONST)
3036 Perl_croak(aTHX_ "Module name must be constant");
3041 SV * const vesv = ((SVOP*)version)->op_sv;
3043 if (!arg && !SvNIOKp(vesv)) {
3050 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3051 Perl_croak(aTHX_ "Version number must be constant number");
3053 /* Make copy of idop so we don't free it twice */
3054 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3056 /* Fake up a method call to VERSION */
3057 meth = newSVpvn_share("VERSION", 7, 0);
3058 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3059 append_elem(OP_LIST,
3060 prepend_elem(OP_LIST, pack, list(version)),
3061 newSVOP(OP_METHOD_NAMED, 0, meth)));
3065 /* Fake up an import/unimport */
3066 if (arg && arg->op_type == OP_STUB)
3067 imop = arg; /* no import on explicit () */
3068 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3069 imop = Nullop; /* use 5.0; */
3071 idop->op_private |= OPpCONST_NOVER;
3076 /* Make copy of idop so we don't free it twice */
3077 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3079 /* Fake up a method call to import/unimport */
3081 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3082 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3083 append_elem(OP_LIST,
3084 prepend_elem(OP_LIST, pack, list(arg)),
3085 newSVOP(OP_METHOD_NAMED, 0, meth)));
3088 /* Fake up the BEGIN {}, which does its thing immediately. */
3090 newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3093 append_elem(OP_LINESEQ,
3094 append_elem(OP_LINESEQ,
3095 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3096 newSTATEOP(0, Nullch, veop)),
3097 newSTATEOP(0, Nullch, imop) ));
3099 /* The "did you use incorrect case?" warning used to be here.
3100 * The problem is that on case-insensitive filesystems one
3101 * might get false positives for "use" (and "require"):
3102 * "use Strict" or "require CARP" will work. This causes
3103 * portability problems for the script: in case-strict
3104 * filesystems the script will stop working.
3106 * The "incorrect case" warning checked whether "use Foo"
3107 * imported "Foo" to your namespace, but that is wrong, too:
3108 * there is no requirement nor promise in the language that
3109 * a Foo.pm should or would contain anything in package "Foo".
3111 * There is very little Configure-wise that can be done, either:
3112 * the case-sensitivity of the build filesystem of Perl does not
3113 * help in guessing the case-sensitivity of the runtime environment.
3116 PL_hints |= HINT_BLOCK_SCOPE;
3117 PL_copline = NOLINE;
3119 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3123 =head1 Embedding Functions
3125 =for apidoc load_module
3127 Loads the module whose name is pointed to by the string part of name.
3128 Note that the actual module name, not its filename, should be given.
3129 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3130 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3131 (or 0 for no flags). ver, if specified, provides version semantics
3132 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3133 arguments can be used to specify arguments to the module's import()
3134 method, similar to C<use Foo::Bar VERSION LIST>.
3139 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3142 va_start(args, ver);
3143 vload_module(flags, name, ver, &args);
3147 #ifdef PERL_IMPLICIT_CONTEXT
3149 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3153 va_start(args, ver);
3154 vload_module(flags, name, ver, &args);
3160 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3164 OP * const modname = newSVOP(OP_CONST, 0, name);
3165 modname->op_private |= OPpCONST_BARE;
3167 veop = newSVOP(OP_CONST, 0, ver);
3171 if (flags & PERL_LOADMOD_NOIMPORT) {
3172 imop = sawparens(newNULLLIST());
3174 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3175 imop = va_arg(*args, OP*);
3180 sv = va_arg(*args, SV*);
3182 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3183 sv = va_arg(*args, SV*);
3187 const line_t ocopline = PL_copline;
3188 COP * const ocurcop = PL_curcop;
3189 const int oexpect = PL_expect;
3191 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3192 veop, modname, imop);
3193 PL_expect = oexpect;
3194 PL_copline = ocopline;
3195 PL_curcop = ocurcop;
3200 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3205 if (!force_builtin) {
3206 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3207 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3208 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3209 gv = gvp ? *gvp : Nullgv;
3213 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3214 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3215 append_elem(OP_LIST, term,
3216 scalar(newUNOP(OP_RV2CV, 0,
3221 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3227 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3229 return newBINOP(OP_LSLICE, flags,
3230 list(force_list(subscript)),
3231 list(force_list(listval)) );
3235 S_is_list_assignment(pTHX_ register const OP *o)
3240 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3241 o = cUNOPo->op_first;
3243 if (o->op_type == OP_COND_EXPR) {
3244 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3245 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3250 yyerror("Assignment to both a list and a scalar");
3254 if (o->op_type == OP_LIST &&
3255 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3256 o->op_private & OPpLVAL_INTRO)
3259 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3260 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3261 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3264 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3267 if (o->op_type == OP_RV2SV)
3274 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3279 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3280 return newLOGOP(optype, 0,
3281 mod(scalar(left), optype),
3282 newUNOP(OP_SASSIGN, 0, scalar(right)));
3285 return newBINOP(optype, OPf_STACKED,
3286 mod(scalar(left), optype), scalar(right));
3290 if (is_list_assignment(left)) {
3294 /* Grandfathering $[ assignment here. Bletch.*/
3295 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3296 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3297 left = mod(left, OP_AASSIGN);
3300 else if (left->op_type == OP_CONST) {
3301 /* Result of assignment is always 1 (or we'd be dead already) */
3302 return newSVOP(OP_CONST, 0, newSViv(1));
3304 curop = list(force_list(left));
3305 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3306 o->op_private = (U8)(0 | (flags >> 8));
3308 /* PL_generation sorcery:
3309 * an assignment like ($a,$b) = ($c,$d) is easier than
3310 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3311 * To detect whether there are common vars, the global var
3312 * PL_generation is incremented for each assign op we compile.
3313 * Then, while compiling the assign op, we run through all the
3314 * variables on both sides of the assignment, setting a spare slot
3315 * in each of them to PL_generation. If any of them already have
3316 * that value, we know we've got commonality. We could use a
3317 * single bit marker, but then we'd have to make 2 passes, first
3318 * to clear the flag, then to test and set it. To find somewhere
3319 * to store these values, evil chicanery is done with SvCUR().
3322 if (!(left->op_private & OPpLVAL_INTRO)) {
3325 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3326 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3327 if (curop->op_type == OP_GV) {
3328 GV *gv = cGVOPx_gv(curop);
3329 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3331 SvCUR_set(gv, PL_generation);
3333 else if (curop->op_type == OP_PADSV ||
3334 curop->op_type == OP_PADAV ||
3335 curop->op_type == OP_PADHV ||
3336 curop->op_type == OP_PADANY)
3338 if (PAD_COMPNAME_GEN(curop->op_targ)
3339 == (STRLEN)PL_generation)
3341 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3344 else if (curop->op_type == OP_RV2CV)
3346 else if (curop->op_type == OP_RV2SV ||
3347 curop->op_type == OP_RV2AV ||
3348 curop->op_type == OP_RV2HV ||
3349 curop->op_type == OP_RV2GV) {
3350 if (lastop->op_type != OP_GV) /* funny deref? */
3353 else if (curop->op_type == OP_PUSHRE) {
3354 if (((PMOP*)curop)->op_pmreplroot) {
3356 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3357 ((PMOP*)curop)->op_pmreplroot));
3359 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3361 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3363 SvCUR_set(gv, PL_generation);
3372 o->op_private |= OPpASSIGN_COMMON;
3374 if (right && right->op_type == OP_SPLIT) {
3376 if ((tmpop = ((LISTOP*)right)->op_first) &&
3377 tmpop->op_type == OP_PUSHRE)
3379 PMOP * const pm = (PMOP*)tmpop;
3380 if (left->op_type == OP_RV2AV &&
3381 !(left->op_private & OPpLVAL_INTRO) &&
3382 !(o->op_private & OPpASSIGN_COMMON) )
3384 tmpop = ((UNOP*)left)->op_first;
3385 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3387 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3388 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3390 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3391 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3393 pm->op_pmflags |= PMf_ONCE;
3394 tmpop = cUNOPo->op_first; /* to list (nulled) */
3395 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3396 tmpop->op_sibling = Nullop; /* don't free split */
3397 right->op_next = tmpop->op_next; /* fix starting loc */
3398 op_free(o); /* blow off assign */
3399 right->op_flags &= ~OPf_WANT;
3400 /* "I don't know and I don't care." */
3405 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3406 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3408 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3410 sv_setiv(sv, PL_modcount+1);
3418 right = newOP(OP_UNDEF, 0);
3419 if (right->op_type == OP_READLINE) {
3420 right->op_flags |= OPf_STACKED;
3421 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3424 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3425 o = newBINOP(OP_SASSIGN, flags,
3426 scalar(right), mod(scalar(left), OP_SASSIGN) );
3430 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3437 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3440 const U32 seq = intro_my();
3443 NewOp(1101, cop, 1, COP);
3444 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3445 cop->op_type = OP_DBSTATE;
3446 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3449 cop->op_type = OP_NEXTSTATE;
3450 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3452 cop->op_flags = (U8)flags;
3453 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3455 cop->op_private |= NATIVE_HINTS;
3457 PL_compiling.op_private = cop->op_private;
3458 cop->op_next = (OP*)cop;
3461 cop->cop_label = label;
3462 PL_hints |= HINT_BLOCK_SCOPE;
3465 cop->cop_arybase = PL_curcop->cop_arybase;
3466 if (specialWARN(PL_curcop->cop_warnings))
3467 cop->cop_warnings = PL_curcop->cop_warnings ;
3469 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3470 if (specialCopIO(PL_curcop->cop_io))
3471 cop->cop_io = PL_curcop->cop_io;
3473 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3476 if (PL_copline == NOLINE)
3477 CopLINE_set(cop, CopLINE(PL_curcop));
3479 CopLINE_set(cop, PL_copline);
3480 PL_copline = NOLINE;
3483 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3485 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3487 CopSTASH_set(cop, PL_curstash);
3489 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3490 SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3491 if (svp && *svp != &PL_sv_undef ) {
3492 (void)SvIOK_on(*svp);
3493 SvIV_set(*svp, PTR2IV(cop));
3497 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3502 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3505 return new_logop(type, flags, &first, &other);
3509 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3514 OP *first = *firstp;
3515 OP * const other = *otherp;
3517 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3518 return newBINOP(type, flags, scalar(first), scalar(other));
3520 scalarboolean(first);
3521 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3522 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3523 if (type == OP_AND || type == OP_OR) {
3529 first = *firstp = cUNOPo->op_first;
3531 first->op_next = o->op_next;
3532 cUNOPo->op_first = Nullop;
3536 if (first->op_type == OP_CONST) {
3537 if (first->op_private & OPpCONST_STRICT)
3538 no_bareword_allowed(first);
3539 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3540 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3541 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3542 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3543 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3546 if (other->op_type == OP_CONST)
3547 other->op_private |= OPpCONST_SHORTCIRCUIT;
3551 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3552 const OP *o2 = other;
3553 if ( ! (o2->op_type == OP_LIST
3554 && (( o2 = cUNOPx(o2)->op_first))
3555 && o2->op_type == OP_PUSHMARK
3556 && (( o2 = o2->op_sibling)) )
3559 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3560 || o2->op_type == OP_PADHV)
3561 && o2->op_private & OPpLVAL_INTRO
3562 && ckWARN(WARN_DEPRECATED))
3564 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3565 "Deprecated use of my() in false conditional");
3570 if (first->op_type == OP_CONST)
3571 first->op_private |= OPpCONST_SHORTCIRCUIT;
3575 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3576 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3578 const OP * const k1 = ((UNOP*)first)->op_first;
3579 const OP * const k2 = k1->op_sibling;
3581 switch (first->op_type)
3584 if (k2 && k2->op_type == OP_READLINE
3585 && (k2->op_flags & OPf_STACKED)
3586 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3588 warnop = k2->op_type;
3593 if (k1->op_type == OP_READDIR
3594 || k1->op_type == OP_GLOB
3595 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3596 || k1->op_type == OP_EACH)
3598 warnop = ((k1->op_type == OP_NULL)
3599 ? (OPCODE)k1->op_targ : k1->op_type);
3604 const line_t oldline = CopLINE(PL_curcop);
3605 CopLINE_set(PL_curcop, PL_copline);
3606 Perl_warner(aTHX_ packWARN(WARN_MISC),
3607 "Value of %s%s can be \"0\"; test with defined()",
3609 ((warnop == OP_READLINE || warnop == OP_GLOB)
3610 ? " construct" : "() operator"));
3611 CopLINE_set(PL_curcop, oldline);
3618 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3619 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3621 NewOp(1101, logop, 1, LOGOP);
3623 logop->op_type = (OPCODE)type;
3624 logop->op_ppaddr = PL_ppaddr[type];
3625 logop->op_first = first;
3626 logop->op_flags = (U8)(flags | OPf_KIDS);
3627 logop->op_other = LINKLIST(other);
3628 logop->op_private = (U8)(1 | (flags >> 8));
3630 /* establish postfix order */
3631 logop->op_next = LINKLIST(first);
3632 first->op_next = (OP*)logop;
3633 first->op_sibling = other;
3635 CHECKOP(type,logop);
3637 o = newUNOP(OP_NULL, 0, (OP*)logop);
3644 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3652 return newLOGOP(OP_AND, 0, first, trueop);
3654 return newLOGOP(OP_OR, 0, first, falseop);
3656 scalarboolean(first);
3657 if (first->op_type == OP_CONST) {
3658 if (first->op_private & OPpCONST_BARE &&
3659 first->op_private & OPpCONST_STRICT) {
3660 no_bareword_allowed(first);
3662 if (SvTRUE(((SVOP*)first)->op_sv)) {
3673 NewOp(1101, logop, 1, LOGOP);
3674 logop->op_type = OP_COND_EXPR;
3675 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3676 logop->op_first = first;
3677 logop->op_flags = (U8)(flags | OPf_KIDS);
3678 logop->op_private = (U8)(1 | (flags >> 8));
3679 logop->op_other = LINKLIST(trueop);
3680 logop->op_next = LINKLIST(falseop);
3682 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3685 /* establish postfix order */
3686 start = LINKLIST(first);
3687 first->op_next = (OP*)logop;
3689 first->op_sibling = trueop;
3690 trueop->op_sibling = falseop;
3691 o = newUNOP(OP_NULL, 0, (OP*)logop);
3693 trueop->op_next = falseop->op_next = o;
3700 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3709 NewOp(1101, range, 1, LOGOP);
3711 range->op_type = OP_RANGE;
3712 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3713 range->op_first = left;
3714 range->op_flags = OPf_KIDS;
3715 leftstart = LINKLIST(left);
3716 range->op_other = LINKLIST(right);
3717 range->op_private = (U8)(1 | (flags >> 8));
3719 left->op_sibling = right;
3721 range->op_next = (OP*)range;
3722 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3723 flop = newUNOP(OP_FLOP, 0, flip);
3724 o = newUNOP(OP_NULL, 0, flop);
3726 range->op_next = leftstart;
3728 left->op_next = flip;
3729 right->op_next = flop;
3731 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3732 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3733 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3734 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3736 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3737 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3740 if (!flip->op_private || !flop->op_private)
3741 linklist(o); /* blow off optimizer unless constant */
3747 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3751 const bool once = block && block->op_flags & OPf_SPECIAL &&
3752 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3754 PERL_UNUSED_ARG(debuggable);
3757 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3758 return block; /* do {} while 0 does once */
3759 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3760 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3761 expr = newUNOP(OP_DEFINED, 0,
3762 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3763 } else if (expr->op_flags & OPf_KIDS) {
3764 const OP * const k1 = ((UNOP*)expr)->op_first;
3765 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3766 switch (expr->op_type) {
3768 if (k2 && k2->op_type == OP_READLINE
3769 && (k2->op_flags & OPf_STACKED)
3770 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3771 expr = newUNOP(OP_DEFINED, 0, expr);
3775 if (k1->op_type == OP_READDIR
3776 || k1->op_type == OP_GLOB
3777 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3778 || k1->op_type == OP_EACH)
3779 expr = newUNOP(OP_DEFINED, 0, expr);
3785 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3786 * op, in listop. This is wrong. [perl #27024] */
3788 block = newOP(OP_NULL, 0);
3789 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3790 o = new_logop(OP_AND, 0, &expr, &listop);
3793 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3795 if (once && o != listop)
3796 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3799 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3801 o->op_flags |= flags;
3803 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3808 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3809 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3818 PERL_UNUSED_ARG(debuggable);
3821 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3822 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3823 expr = newUNOP(OP_DEFINED, 0,
3824 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3825 } else if (expr->op_flags & OPf_KIDS) {
3826 const OP * const k1 = ((UNOP*)expr)->op_first;
3827 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3828 switch (expr->op_type) {
3830 if (k2 && k2->op_type == OP_READLINE
3831 && (k2->op_flags & OPf_STACKED)
3832 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3833 expr = newUNOP(OP_DEFINED, 0, expr);
3837 if (k1->op_type == OP_READDIR
3838 || k1->op_type == OP_GLOB
3839 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3840 || k1->op_type == OP_EACH)
3841 expr = newUNOP(OP_DEFINED, 0, expr);
3848 block = newOP(OP_NULL, 0);
3849 else if (cont || has_my) {
3850 block = scope(block);
3854 next = LINKLIST(cont);
3857 OP * const unstack = newOP(OP_UNSTACK, 0);
3860 cont = append_elem(OP_LINESEQ, cont, unstack);
3863 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3864 redo = LINKLIST(listop);
3867 PL_copline = (line_t)whileline;
3869 o = new_logop(OP_AND, 0, &expr, &listop);
3870 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3871 op_free(expr); /* oops, it's a while (0) */
3873 return Nullop; /* listop already freed by new_logop */
3876 ((LISTOP*)listop)->op_last->op_next =
3877 (o == listop ? redo : LINKLIST(o));
3883 NewOp(1101,loop,1,LOOP);
3884 loop->op_type = OP_ENTERLOOP;
3885 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3886 loop->op_private = 0;
3887 loop->op_next = (OP*)loop;
3890 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3892 loop->op_redoop = redo;
3893 loop->op_lastop = o;
3894 o->op_private |= loopflags;
3897 loop->op_nextop = next;
3899 loop->op_nextop = o;
3901 o->op_flags |= flags;
3902 o->op_private |= (flags >> 8);
3907 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3912 PADOFFSET padoff = 0;
3917 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3918 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3919 sv->op_type = OP_RV2GV;
3920 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3922 else if (sv->op_type == OP_PADSV) { /* private variable */
3923 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3924 padoff = sv->op_targ;
3929 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3930 padoff = sv->op_targ;
3932 iterflags |= OPf_SPECIAL;
3937 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3940 const I32 offset = pad_findmy("$_");
3941 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3942 sv = newGVOP(OP_GV, 0, PL_defgv);
3948 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3949 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3950 iterflags |= OPf_STACKED;
3952 else if (expr->op_type == OP_NULL &&
3953 (expr->op_flags & OPf_KIDS) &&
3954 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3956 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3957 * set the STACKED flag to indicate that these values are to be
3958 * treated as min/max values by 'pp_iterinit'.
3960 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3961 LOGOP* const range = (LOGOP*) flip->op_first;
3962 OP* const left = range->op_first;
3963 OP* const right = left->op_sibling;
3966 range->op_flags &= ~OPf_KIDS;
3967 range->op_first = Nullop;
3969 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3970 listop->op_first->op_next = range->op_next;
3971 left->op_next = range->op_other;
3972 right->op_next = (OP*)listop;
3973 listop->op_next = listop->op_first;
3976 expr = (OP*)(listop);
3978 iterflags |= OPf_STACKED;
3981 expr = mod(force_list(expr), OP_GREPSTART);
3984 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3985 append_elem(OP_LIST, expr, scalar(sv))));
3986 assert(!loop->op_next);
3987 /* for my $x () sets OPpLVAL_INTRO;
3988 * for our $x () sets OPpOUR_INTRO */
3989 loop->op_private = (U8)iterpflags;
3990 #ifdef PL_OP_SLAB_ALLOC
3993 NewOp(1234,tmp,1,LOOP);
3994 Copy(loop,tmp,1,LISTOP);
3999 Renew(loop, 1, LOOP);
4001 loop->op_targ = padoff;
4002 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4003 PL_copline = forline;
4004 return newSTATEOP(0, label, wop);
4008 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4012 if (type != OP_GOTO || label->op_type == OP_CONST) {
4013 /* "last()" means "last" */
4014 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4015 o = newOP(type, OPf_SPECIAL);
4017 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4018 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4024 /* Check whether it's going to be a goto &function */
4025 if (label->op_type == OP_ENTERSUB
4026 && !(label->op_flags & OPf_STACKED))
4027 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4028 o = newUNOP(type, OPf_STACKED, label);
4030 PL_hints |= HINT_BLOCK_SCOPE;
4035 =for apidoc cv_undef
4037 Clear out all the active components of a CV. This can happen either
4038 by an explicit C<undef &foo>, or by the reference count going to zero.
4039 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4040 children can still follow the full lexical scope chain.
4046 Perl_cv_undef(pTHX_ CV *cv)
4050 if (CvFILE(cv) && !CvXSUB(cv)) {
4051 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4052 Safefree(CvFILE(cv));
4057 if (!CvXSUB(cv) && CvROOT(cv)) {
4059 Perl_croak(aTHX_ "Can't undef active subroutine");
4062 PAD_SAVE_SETNULLPAD();
4064 op_free(CvROOT(cv));
4065 CvROOT(cv) = Nullop;
4066 CvSTART(cv) = Nullop;
4069 SvPOK_off((SV*)cv); /* forget prototype */
4074 /* remove CvOUTSIDE unless this is an undef rather than a free */
4075 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4076 if (!CvWEAKOUTSIDE(cv))
4077 SvREFCNT_dec(CvOUTSIDE(cv));
4078 CvOUTSIDE(cv) = Nullcv;
4081 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4087 /* delete all flags except WEAKOUTSIDE */
4088 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4092 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4094 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4095 SV* const msg = sv_newmortal();
4099 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4100 sv_setpv(msg, "Prototype mismatch:");
4102 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4104 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4106 Perl_sv_catpv(aTHX_ msg, ": none");
4107 sv_catpv(msg, " vs ");
4109 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4111 sv_catpv(msg, "none");
4112 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4116 static void const_sv_xsub(pTHX_ CV* cv);
4120 =head1 Optree Manipulation Functions
4122 =for apidoc cv_const_sv
4124 If C<cv> is a constant sub eligible for inlining. returns the constant
4125 value returned by the sub. Otherwise, returns NULL.
4127 Constant subs can be created with C<newCONSTSUB> or as described in
4128 L<perlsub/"Constant Functions">.
4133 Perl_cv_const_sv(pTHX_ CV *cv)
4135 if (!cv || !CvCONST(cv))
4137 return (SV*)CvXSUBANY(cv).any_ptr;
4140 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4141 * Can be called in 3 ways:
4144 * look for a single OP_CONST with attached value: return the value
4146 * cv && CvCLONE(cv) && !CvCONST(cv)
4148 * examine the clone prototype, and if contains only a single
4149 * OP_CONST referencing a pad const, or a single PADSV referencing
4150 * an outer lexical, return a non-zero value to indicate the CV is
4151 * a candidate for "constizing" at clone time
4155 * We have just cloned an anon prototype that was marked as a const
4156 * candidiate. Try to grab the current value, and in the case of
4157 * PADSV, ignore it if it has multiple references. Return the value.
4161 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4168 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4169 o = cLISTOPo->op_first->op_sibling;
4171 for (; o; o = o->op_next) {
4172 const OPCODE type = o->op_type;
4174 if (sv && o->op_next == o)
4176 if (o->op_next != o) {
4177 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4179 if (type == OP_DBSTATE)
4182 if (type == OP_LEAVESUB || type == OP_RETURN)
4186 if (type == OP_CONST && cSVOPo->op_sv)
4188 else if (cv && type == OP_CONST) {
4189 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4193 else if (cv && type == OP_PADSV) {
4194 if (CvCONST(cv)) { /* newly cloned anon */
4195 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4196 /* the candidate should have 1 ref from this pad and 1 ref
4197 * from the parent */
4198 if (!sv || SvREFCNT(sv) != 2)
4205 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4206 sv = &PL_sv_undef; /* an arbitrary non-null value */
4217 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4219 PERL_UNUSED_ARG(floor);
4229 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4233 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4235 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4239 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4250 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4253 assert(proto->op_type == OP_CONST);
4254 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4259 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4260 SV * const sv = sv_newmortal();
4261 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4262 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4263 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4264 aname = SvPVX_const(sv);
4269 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4270 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4271 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4272 : gv_fetchpv(aname ? aname
4273 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4274 gv_fetch_flags, SVt_PVCV);
4283 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4284 maximum a prototype before. */
4285 if (SvTYPE(gv) > SVt_NULL) {
4286 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4287 && ckWARN_d(WARN_PROTOTYPE))
4289 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4291 cv_ckproto((CV*)gv, NULL, ps);
4294 sv_setpvn((SV*)gv, ps, ps_len);
4296 sv_setiv((SV*)gv, -1);
4297 SvREFCNT_dec(PL_compcv);
4298 cv = PL_compcv = NULL;
4299 PL_sub_generation++;
4303 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4305 #ifdef GV_UNIQUE_CHECK
4306 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4307 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4311 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4314 const_sv = op_const_sv(block, Nullcv);
4317 const bool exists = CvROOT(cv) || CvXSUB(cv);
4319 #ifdef GV_UNIQUE_CHECK
4320 if (exists && GvUNIQUE(gv)) {
4321 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4325 /* if the subroutine doesn't exist and wasn't pre-declared
4326 * with a prototype, assume it will be AUTOLOADed,
4327 * skipping the prototype check
4329 if (exists || SvPOK(cv))
4330 cv_ckproto(cv, gv, ps);
4331 /* already defined (or promised)? */
4332 if (exists || GvASSUMECV(gv)) {
4333 if (!block && !attrs) {
4334 if (CvFLAGS(PL_compcv)) {
4335 /* might have had built-in attrs applied */
4336 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4338 /* just a "sub foo;" when &foo is already defined */
4339 SAVEFREESV(PL_compcv);
4343 if (ckWARN(WARN_REDEFINE)
4345 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4347 const line_t oldline = CopLINE(PL_curcop);
4348 if (PL_copline != NOLINE)
4349 CopLINE_set(PL_curcop, PL_copline);
4350 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4351 CvCONST(cv) ? "Constant subroutine %s redefined"
4352 : "Subroutine %s redefined", name);
4353 CopLINE_set(PL_curcop, oldline);
4361 (void)SvREFCNT_inc(const_sv);
4363 assert(!CvROOT(cv) && !CvCONST(cv));
4364 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4365 CvXSUBANY(cv).any_ptr = const_sv;
4366 CvXSUB(cv) = const_sv_xsub;
4371 cv = newCONSTSUB(NULL, name, const_sv);
4374 SvREFCNT_dec(PL_compcv);
4376 PL_sub_generation++;
4383 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4384 * before we clobber PL_compcv.
4388 /* Might have had built-in attributes applied -- propagate them. */
4389 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4390 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4391 stash = GvSTASH(CvGV(cv));
4392 else if (CvSTASH(cv))
4393 stash = CvSTASH(cv);
4395 stash = PL_curstash;
4398 /* possibly about to re-define existing subr -- ignore old cv */
4399 rcv = (SV*)PL_compcv;
4400 if (name && GvSTASH(gv))
4401 stash = GvSTASH(gv);
4403 stash = PL_curstash;
4405 apply_attrs(stash, rcv, attrs, FALSE);
4407 if (cv) { /* must reuse cv if autoloaded */
4409 /* got here with just attrs -- work done, so bug out */
4410 SAVEFREESV(PL_compcv);
4413 /* transfer PL_compcv to cv */
4415 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4416 if (!CvWEAKOUTSIDE(cv))
4417 SvREFCNT_dec(CvOUTSIDE(cv));
4418 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4419 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4420 CvOUTSIDE(PL_compcv) = 0;
4421 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4422 CvPADLIST(PL_compcv) = 0;
4423 /* inner references to PL_compcv must be fixed up ... */
4424 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4425 /* ... before we throw it away */
4426 SvREFCNT_dec(PL_compcv);
4428 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4429 ++PL_sub_generation;
4436 PL_sub_generation++;
4440 CvFILE_set_from_cop(cv, PL_curcop);
4441 CvSTASH(cv) = PL_curstash;
4444 sv_setpvn((SV*)cv, ps, ps_len);
4446 if (PL_error_count) {
4450 const char *s = strrchr(name, ':');
4452 if (strEQ(s, "BEGIN")) {
4453 const char not_safe[] =
4454 "BEGIN not safe after errors--compilation aborted";
4455 if (PL_in_eval & EVAL_KEEPERR)
4456 Perl_croak(aTHX_ not_safe);
4458 /* force display of errors found but not reported */
4459 sv_catpv(ERRSV, not_safe);
4460 Perl_croak(aTHX_ "%"SVf, ERRSV);
4469 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4470 mod(scalarseq(block), OP_LEAVESUBLV));
4473 /* This makes sub {}; work as expected. */
4474 if (block->op_type == OP_STUB) {
4476 block = newSTATEOP(0, Nullch, 0);
4478 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4480 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4481 OpREFCNT_set(CvROOT(cv), 1);
4482 CvSTART(cv) = LINKLIST(CvROOT(cv));
4483 CvROOT(cv)->op_next = 0;
4484 CALL_PEEP(CvSTART(cv));
4486 /* now that optimizer has done its work, adjust pad values */
4488 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4491 assert(!CvCONST(cv));
4492 if (ps && !*ps && op_const_sv(block, cv))
4496 if (name || aname) {
4498 const char * const tname = (name ? name : aname);
4500 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4501 SV * const sv = NEWSV(0,0);
4502 SV * const tmpstr = sv_newmortal();
4503 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4506 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4508 (long)PL_subline, (long)CopLINE(PL_curcop));
4509 gv_efullname3(tmpstr, gv, Nullch);
4510 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4511 hv = GvHVn(db_postponed);
4512 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4513 CV * const pcv = GvCV(db_postponed);
4519 call_sv((SV*)pcv, G_DISCARD);
4524 if ((s = strrchr(tname,':')))
4529 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4532 if (strEQ(s, "BEGIN") && !PL_error_count) {
4533 const I32 oldscope = PL_scopestack_ix;
4535 SAVECOPFILE(&PL_compiling);
4536 SAVECOPLINE(&PL_compiling);
4539 PL_beginav = newAV();
4540 DEBUG_x( dump_sub(gv) );
4541 av_push(PL_beginav, (SV*)cv);
4542 GvCV(gv) = 0; /* cv has been hijacked */
4543 call_list(oldscope, PL_beginav);
4545 PL_curcop = &PL_compiling;
4546 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4549 else if (strEQ(s, "END") && !PL_error_count) {
4552 DEBUG_x( dump_sub(gv) );
4553 av_unshift(PL_endav, 1);
4554 av_store(PL_endav, 0, (SV*)cv);
4555 GvCV(gv) = 0; /* cv has been hijacked */
4557 else if (strEQ(s, "CHECK") && !PL_error_count) {
4559 PL_checkav = newAV();
4560 DEBUG_x( dump_sub(gv) );
4561 if (PL_main_start && ckWARN(WARN_VOID))
4562 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4563 av_unshift(PL_checkav, 1);
4564 av_store(PL_checkav, 0, (SV*)cv);
4565 GvCV(gv) = 0; /* cv has been hijacked */
4567 else if (strEQ(s, "INIT") && !PL_error_count) {
4569 PL_initav = newAV();
4570 DEBUG_x( dump_sub(gv) );
4571 if (PL_main_start && ckWARN(WARN_VOID))
4572 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4573 av_push(PL_initav, (SV*)cv);
4574 GvCV(gv) = 0; /* cv has been hijacked */
4579 PL_copline = NOLINE;
4584 /* XXX unsafe for threads if eval_owner isn't held */
4586 =for apidoc newCONSTSUB
4588 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4589 eligible for inlining at compile-time.
4595 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4602 SAVECOPLINE(PL_curcop);
4603 CopLINE_set(PL_curcop, PL_copline);
4606 PL_hints &= ~HINT_BLOCK_SCOPE;
4609 SAVESPTR(PL_curstash);
4610 SAVECOPSTASH(PL_curcop);
4611 PL_curstash = stash;
4612 CopSTASH_set(PL_curcop,stash);
4615 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4616 CvXSUBANY(cv).any_ptr = sv;
4618 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4622 CopSTASH_free(PL_curcop);
4630 =for apidoc U||newXS
4632 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4638 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4640 GV * const gv = gv_fetchpv(name ? name :
4641 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4642 GV_ADDMULTI, SVt_PVCV);
4646 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4648 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4650 /* just a cached method */
4654 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4655 /* already defined (or promised) */
4656 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4657 if (ckWARN(WARN_REDEFINE)) {
4658 GV * const gvcv = CvGV(cv);
4660 HV * const stash = GvSTASH(gvcv);
4662 const char *name = HvNAME_get(stash);
4663 if ( strEQ(name,"autouse") ) {
4664 const line_t oldline = CopLINE(PL_curcop);
4665 if (PL_copline != NOLINE)
4666 CopLINE_set(PL_curcop, PL_copline);
4667 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4668 CvCONST(cv) ? "Constant subroutine %s redefined"
4669 : "Subroutine %s redefined"
4671 CopLINE_set(PL_curcop, oldline);
4681 if (cv) /* must reuse cv if autoloaded */
4684 cv = (CV*)NEWSV(1105,0);
4685 sv_upgrade((SV *)cv, SVt_PVCV);
4689 PL_sub_generation++;
4693 (void)gv_fetchfile(filename);
4694 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4695 an external constant string */
4696 CvXSUB(cv) = subaddr;
4699 const char *s = strrchr(name,':');
4705 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4708 if (strEQ(s, "BEGIN")) {
4710 PL_beginav = newAV();
4711 av_push(PL_beginav, (SV*)cv);
4712 GvCV(gv) = 0; /* cv has been hijacked */
4714 else if (strEQ(s, "END")) {
4717 av_unshift(PL_endav, 1);
4718 av_store(PL_endav, 0, (SV*)cv);
4719 GvCV(gv) = 0; /* cv has been hijacked */
4721 else if (strEQ(s, "CHECK")) {
4723 PL_checkav = newAV();
4724 if (PL_main_start && ckWARN(WARN_VOID))
4725 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4726 av_unshift(PL_checkav, 1);
4727 av_store(PL_checkav, 0, (SV*)cv);
4728 GvCV(gv) = 0; /* cv has been hijacked */
4730 else if (strEQ(s, "INIT")) {
4732 PL_initav = newAV();
4733 if (PL_main_start && ckWARN(WARN_VOID))
4734 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4735 av_push(PL_initav, (SV*)cv);
4736 GvCV(gv) = 0; /* cv has been hijacked */
4747 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4752 ? gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM)
4753 : 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 * const 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 * const 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 * const 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 * const 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 * const 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)
6352 /* XXX We shouldn't be modifying proto, so we can const proto */
6357 while (*--p != '[');
6358 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6359 gv_ename(namegv), o2);
6365 if (o2->op_type == OP_RV2GV)
6368 bad_type(arg, "symbol", gv_ename(namegv), o2);
6371 if (o2->op_type == OP_ENTERSUB)
6374 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6377 if (o2->op_type == OP_RV2SV ||
6378 o2->op_type == OP_PADSV ||
6379 o2->op_type == OP_HELEM ||
6380 o2->op_type == OP_AELEM ||
6381 o2->op_type == OP_THREADSV)
6384 bad_type(arg, "scalar", gv_ename(namegv), o2);
6387 if (o2->op_type == OP_RV2AV ||
6388 o2->op_type == OP_PADAV)
6391 bad_type(arg, "array", gv_ename(namegv), o2);
6394 if (o2->op_type == OP_RV2HV ||
6395 o2->op_type == OP_PADHV)
6398 bad_type(arg, "hash", gv_ename(namegv), o2);
6403 OP* const sib = kid->op_sibling;
6404 kid->op_sibling = 0;
6405 o2 = newUNOP(OP_REFGEN, 0, kid);
6406 o2->op_sibling = sib;
6407 prev->op_sibling = o2;
6409 if (contextclass && e) {
6424 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6425 gv_ename(namegv), cv);
6430 mod(o2, OP_ENTERSUB);
6432 o2 = o2->op_sibling;
6434 if (proto && !optional &&
6435 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6436 return too_few_arguments(o, gv_ename(namegv));
6439 o=newSVOP(OP_CONST, 0, newSViv(0));
6445 Perl_ck_svconst(pTHX_ OP *o)
6447 SvREADONLY_on(cSVOPo->op_sv);
6452 Perl_ck_trunc(pTHX_ OP *o)
6454 if (o->op_flags & OPf_KIDS) {
6455 SVOP *kid = (SVOP*)cUNOPo->op_first;
6457 if (kid->op_type == OP_NULL)
6458 kid = (SVOP*)kid->op_sibling;
6459 if (kid && kid->op_type == OP_CONST &&
6460 (kid->op_private & OPpCONST_BARE))
6462 o->op_flags |= OPf_SPECIAL;
6463 kid->op_private &= ~OPpCONST_STRICT;
6470 Perl_ck_unpack(pTHX_ OP *o)
6472 OP *kid = cLISTOPo->op_first;
6473 if (kid->op_sibling) {
6474 kid = kid->op_sibling;
6475 if (!kid->op_sibling)
6476 kid->op_sibling = newDEFSVOP();
6482 Perl_ck_substr(pTHX_ OP *o)
6485 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6486 OP *kid = cLISTOPo->op_first;
6488 if (kid->op_type == OP_NULL)
6489 kid = kid->op_sibling;
6491 kid->op_flags |= OPf_MOD;
6497 /* A peephole optimizer. We visit the ops in the order they're to execute.
6498 * See the comments at the top of this file for more details about when
6499 * peep() is called */
6502 Perl_peep(pTHX_ register OP *o)
6505 register OP* oldop = 0;
6507 if (!o || o->op_opt)
6511 SAVEVPTR(PL_curcop);
6512 for (; o; o = o->op_next) {
6516 switch (o->op_type) {
6520 PL_curcop = ((COP*)o); /* for warnings */
6525 if (cSVOPo->op_private & OPpCONST_STRICT)
6526 no_bareword_allowed(o);
6528 case OP_METHOD_NAMED:
6529 /* Relocate sv to the pad for thread safety.
6530 * Despite being a "constant", the SV is written to,
6531 * for reference counts, sv_upgrade() etc. */
6533 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6534 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6535 /* If op_sv is already a PADTMP then it is being used by
6536 * some pad, so make a copy. */
6537 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6538 SvREADONLY_on(PAD_SVl(ix));
6539 SvREFCNT_dec(cSVOPo->op_sv);
6542 SvREFCNT_dec(PAD_SVl(ix));
6543 SvPADTMP_on(cSVOPo->op_sv);
6544 PAD_SETSV(ix, cSVOPo->op_sv);
6545 /* XXX I don't know how this isn't readonly already. */
6546 SvREADONLY_on(PAD_SVl(ix));
6548 cSVOPo->op_sv = Nullsv;
6556 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6557 if (o->op_next->op_private & OPpTARGET_MY) {
6558 if (o->op_flags & OPf_STACKED) /* chained concats */
6559 goto ignore_optimization;
6561 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6562 o->op_targ = o->op_next->op_targ;
6563 o->op_next->op_targ = 0;
6564 o->op_private |= OPpTARGET_MY;
6567 op_null(o->op_next);
6569 ignore_optimization:
6573 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6575 break; /* Scalar stub must produce undef. List stub is noop */
6579 if (o->op_targ == OP_NEXTSTATE
6580 || o->op_targ == OP_DBSTATE
6581 || o->op_targ == OP_SETSTATE)
6583 PL_curcop = ((COP*)o);
6585 /* XXX: We avoid setting op_seq here to prevent later calls
6586 to peep() from mistakenly concluding that optimisation
6587 has already occurred. This doesn't fix the real problem,
6588 though (See 20010220.007). AMS 20010719 */
6589 /* op_seq functionality is now replaced by op_opt */
6590 if (oldop && o->op_next) {
6591 oldop->op_next = o->op_next;
6599 if (oldop && o->op_next) {
6600 oldop->op_next = o->op_next;
6608 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6609 OP* const pop = (o->op_type == OP_PADAV) ?
6610 o->op_next : o->op_next->op_next;
6612 if (pop && pop->op_type == OP_CONST &&
6613 ((PL_op = pop->op_next)) &&
6614 pop->op_next->op_type == OP_AELEM &&
6615 !(pop->op_next->op_private &
6616 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6617 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6622 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6623 no_bareword_allowed(pop);
6624 if (o->op_type == OP_GV)
6625 op_null(o->op_next);
6626 op_null(pop->op_next);
6628 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6629 o->op_next = pop->op_next->op_next;
6630 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6631 o->op_private = (U8)i;
6632 if (o->op_type == OP_GV) {
6637 o->op_flags |= OPf_SPECIAL;
6638 o->op_type = OP_AELEMFAST;
6644 if (o->op_next->op_type == OP_RV2SV) {
6645 if (!(o->op_next->op_private & OPpDEREF)) {
6646 op_null(o->op_next);
6647 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6649 o->op_next = o->op_next->op_next;
6650 o->op_type = OP_GVSV;
6651 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6654 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6655 GV * const gv = cGVOPo_gv;
6656 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6657 /* XXX could check prototype here instead of just carping */
6658 SV * const sv = sv_newmortal();
6659 gv_efullname3(sv, gv, Nullch);
6660 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6661 "%"SVf"() called too early to check prototype",
6665 else if (o->op_next->op_type == OP_READLINE
6666 && o->op_next->op_next->op_type == OP_CONCAT
6667 && (o->op_next->op_next->op_flags & OPf_STACKED))
6669 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6670 o->op_type = OP_RCATLINE;
6671 o->op_flags |= OPf_STACKED;
6672 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6673 op_null(o->op_next->op_next);
6674 op_null(o->op_next);
6691 while (cLOGOP->op_other->op_type == OP_NULL)
6692 cLOGOP->op_other = cLOGOP->op_other->op_next;
6693 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6699 while (cLOOP->op_redoop->op_type == OP_NULL)
6700 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6701 peep(cLOOP->op_redoop);
6702 while (cLOOP->op_nextop->op_type == OP_NULL)
6703 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6704 peep(cLOOP->op_nextop);
6705 while (cLOOP->op_lastop->op_type == OP_NULL)
6706 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6707 peep(cLOOP->op_lastop);
6714 while (cPMOP->op_pmreplstart &&
6715 cPMOP->op_pmreplstart->op_type == OP_NULL)
6716 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6717 peep(cPMOP->op_pmreplstart);
6722 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6723 && ckWARN(WARN_SYNTAX))
6725 if (o->op_next->op_sibling &&
6726 o->op_next->op_sibling->op_type != OP_EXIT &&
6727 o->op_next->op_sibling->op_type != OP_WARN &&
6728 o->op_next->op_sibling->op_type != OP_DIE) {
6729 const line_t oldline = CopLINE(PL_curcop);
6731 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6732 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6733 "Statement unlikely to be reached");
6734 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6735 "\t(Maybe you meant system() when you said exec()?)\n");
6736 CopLINE_set(PL_curcop, oldline);
6746 const char *key = NULL;
6751 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6754 /* Make the CONST have a shared SV */
6755 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6756 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6757 key = SvPV_const(sv, keylen);
6758 lexname = newSVpvn_share(key,
6759 SvUTF8(sv) ? -(I32)keylen : keylen,
6765 if ((o->op_private & (OPpLVAL_INTRO)))
6768 rop = (UNOP*)((BINOP*)o)->op_first;
6769 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6771 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6772 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6774 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6775 if (!fields || !GvHV(*fields))
6777 key = SvPV_const(*svp, keylen);
6778 if (!hv_fetch(GvHV(*fields), key,
6779 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6781 Perl_croak(aTHX_ "No such class field \"%s\" "
6782 "in variable %s of type %s",
6783 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
6796 SVOP *first_key_op, *key_op;
6798 if ((o->op_private & (OPpLVAL_INTRO))
6799 /* I bet there's always a pushmark... */
6800 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6801 /* hmmm, no optimization if list contains only one key. */
6803 rop = (UNOP*)((LISTOP*)o)->op_last;
6804 if (rop->op_type != OP_RV2HV)
6806 if (rop->op_first->op_type == OP_PADSV)
6807 /* @$hash{qw(keys here)} */
6808 rop = (UNOP*)rop->op_first;
6810 /* @{$hash}{qw(keys here)} */
6811 if (rop->op_first->op_type == OP_SCOPE
6812 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6814 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6820 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6821 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6823 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6824 if (!fields || !GvHV(*fields))
6826 /* Again guessing that the pushmark can be jumped over.... */
6827 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6828 ->op_first->op_sibling;
6829 for (key_op = first_key_op; key_op;
6830 key_op = (SVOP*)key_op->op_sibling) {
6831 if (key_op->op_type != OP_CONST)
6833 svp = cSVOPx_svp(key_op);
6834 key = SvPV_const(*svp, keylen);
6835 if (!hv_fetch(GvHV(*fields), key,
6836 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6838 Perl_croak(aTHX_ "No such class field \"%s\" "
6839 "in variable %s of type %s",
6840 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6847 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6851 /* check that RHS of sort is a single plain array */
6852 OP *oright = cUNOPo->op_first;
6853 if (!oright || oright->op_type != OP_PUSHMARK)
6856 /* reverse sort ... can be optimised. */
6857 if (!cUNOPo->op_sibling) {
6858 /* Nothing follows us on the list. */
6859 OP * const reverse = o->op_next;
6861 if (reverse->op_type == OP_REVERSE &&
6862 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6863 OP * const pushmark = cUNOPx(reverse)->op_first;
6864 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6865 && (cUNOPx(pushmark)->op_sibling == o)) {
6866 /* reverse -> pushmark -> sort */
6867 o->op_private |= OPpSORT_REVERSE;
6869 pushmark->op_next = oright->op_next;
6875 /* make @a = sort @a act in-place */
6879 oright = cUNOPx(oright)->op_sibling;
6882 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6883 oright = cUNOPx(oright)->op_sibling;
6887 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6888 || oright->op_next != o
6889 || (oright->op_private & OPpLVAL_INTRO)
6893 /* o2 follows the chain of op_nexts through the LHS of the
6894 * assign (if any) to the aassign op itself */
6896 if (!o2 || o2->op_type != OP_NULL)
6899 if (!o2 || o2->op_type != OP_PUSHMARK)
6902 if (o2 && o2->op_type == OP_GV)
6905 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6906 || (o2->op_private & OPpLVAL_INTRO)
6911 if (!o2 || o2->op_type != OP_NULL)
6914 if (!o2 || o2->op_type != OP_AASSIGN
6915 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6918 /* check that the sort is the first arg on RHS of assign */
6920 o2 = cUNOPx(o2)->op_first;
6921 if (!o2 || o2->op_type != OP_NULL)
6923 o2 = cUNOPx(o2)->op_first;
6924 if (!o2 || o2->op_type != OP_PUSHMARK)
6926 if (o2->op_sibling != o)
6929 /* check the array is the same on both sides */
6930 if (oleft->op_type == OP_RV2AV) {
6931 if (oright->op_type != OP_RV2AV
6932 || !cUNOPx(oright)->op_first
6933 || cUNOPx(oright)->op_first->op_type != OP_GV
6934 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6935 cGVOPx_gv(cUNOPx(oright)->op_first)
6939 else if (oright->op_type != OP_PADAV
6940 || oright->op_targ != oleft->op_targ
6944 /* transfer MODishness etc from LHS arg to RHS arg */
6945 oright->op_flags = oleft->op_flags;
6946 o->op_private |= OPpSORT_INPLACE;
6948 /* excise push->gv->rv2av->null->aassign */
6949 o2 = o->op_next->op_next;
6950 op_null(o2); /* PUSHMARK */
6952 if (o2->op_type == OP_GV) {
6953 op_null(o2); /* GV */
6956 op_null(o2); /* RV2AV or PADAV */
6957 o2 = o2->op_next->op_next;
6958 op_null(o2); /* AASSIGN */
6960 o->op_next = o2->op_next;
6966 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6968 LISTOP *enter, *exlist;
6971 enter = (LISTOP *) o->op_next;
6974 if (enter->op_type == OP_NULL) {
6975 enter = (LISTOP *) enter->op_next;
6979 /* for $a (...) will have OP_GV then OP_RV2GV here.
6980 for (...) just has an OP_GV. */
6981 if (enter->op_type == OP_GV) {
6982 gvop = (OP *) enter;
6983 enter = (LISTOP *) enter->op_next;
6986 if (enter->op_type == OP_RV2GV) {
6987 enter = (LISTOP *) enter->op_next;
6993 if (enter->op_type != OP_ENTERITER)
6996 iter = enter->op_next;
6997 if (!iter || iter->op_type != OP_ITER)
7000 expushmark = enter->op_first;
7001 if (!expushmark || expushmark->op_type != OP_NULL
7002 || expushmark->op_targ != OP_PUSHMARK)
7005 exlist = (LISTOP *) expushmark->op_sibling;
7006 if (!exlist || exlist->op_type != OP_NULL
7007 || exlist->op_targ != OP_LIST)
7010 if (exlist->op_last != o) {
7011 /* Mmm. Was expecting to point back to this op. */
7014 theirmark = exlist->op_first;
7015 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7018 if (theirmark->op_sibling != o) {
7019 /* There's something between the mark and the reverse, eg
7020 for (1, reverse (...))
7025 ourmark = ((LISTOP *)o)->op_first;
7026 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7029 ourlast = ((LISTOP *)o)->op_last;
7030 if (!ourlast || ourlast->op_next != o)
7033 rv2av = ourmark->op_sibling;
7034 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7035 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7036 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7037 /* We're just reversing a single array. */
7038 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7039 enter->op_flags |= OPf_STACKED;
7042 /* We don't have control over who points to theirmark, so sacrifice
7044 theirmark->op_next = ourmark->op_next;
7045 theirmark->op_flags = ourmark->op_flags;
7046 ourlast->op_next = gvop ? gvop : (OP *) enter;
7049 enter->op_private |= OPpITER_REVERSED;
7050 iter->op_private |= OPpITER_REVERSED;
7065 Perl_custom_op_name(pTHX_ const OP* o)
7067 const IV index = PTR2IV(o->op_ppaddr);
7071 if (!PL_custom_op_names) /* This probably shouldn't happen */
7072 return (char *)PL_op_name[OP_CUSTOM];
7074 keysv = sv_2mortal(newSViv(index));
7076 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7078 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7080 return SvPV_nolen(HeVAL(he));
7084 Perl_custom_op_desc(pTHX_ const OP* o)
7086 const IV index = PTR2IV(o->op_ppaddr);
7090 if (!PL_custom_op_descs)
7091 return (char *)PL_op_desc[OP_CUSTOM];
7093 keysv = sv_2mortal(newSViv(index));
7095 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7097 return (char *)PL_op_desc[OP_CUSTOM];
7099 return SvPV_nolen(HeVAL(he));
7104 /* Efficient sub that returns a constant scalar value. */
7106 const_sv_xsub(pTHX_ CV* cv)
7111 Perl_croak(aTHX_ "usage: %s::%s()",
7112 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7116 ST(0) = (SV*)XSANY.any_ptr;
7122 * c-indentation-style: bsd
7124 * indent-tabs-mode: t
7127 * ex: set ts=8 sts=4 sw=4 noet: