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 **ptr = (I32 **) op;
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* tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, Nullch);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
201 qerror(Perl_mess(aTHX_
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
206 /* "register" allocation */
209 Perl_allocmy(pTHX_ char *name)
213 /* complain about "my $<special_var>" etc etc */
214 if (!(PL_in_my == KEY_our ||
216 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
217 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
219 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
220 /* 1999-02-27 mjd@plover.com */
222 p = strchr(name, '\0');
223 /* The next block assumes the buffer is at least 205 chars
224 long. At present, it's always at least 256 chars. */
226 strcpy(name+200, "...");
232 /* Move everything else down one character */
233 for (; p-name > 2; p--)
235 name[2] = toCTRL(name[1]);
238 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
241 /* check for duplicate declaration */
243 (bool)(PL_in_my == KEY_our),
244 (PL_curstash ? PL_curstash : PL_defstash)
247 if (PL_in_my_stash && *name != '$') {
248 yyerror(Perl_form(aTHX_
249 "Can't declare class for non-scalar %s in \"%s\"",
250 name, PL_in_my == KEY_our ? "our" : "my"));
253 /* allocate a spare slot and store the name in that slot */
255 off = pad_add_name(name,
258 /* $_ is always in main::, even with our */
259 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
270 Perl_op_free(pTHX_ OP *o)
276 if (!o || o->op_static)
279 if (o->op_private & OPpREFCOUNTED) {
280 switch (o->op_type) {
288 refcnt = OpREFCNT_dec(o);
298 if (o->op_flags & OPf_KIDS) {
299 register OP *kid, *nextkid;
300 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
301 nextkid = kid->op_sibling; /* Get before next freeing kid */
307 type = (OPCODE)o->op_targ;
309 /* COP* is not cleared by op_clear() so that we may track line
310 * numbers etc even after null() */
311 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
316 #ifdef DEBUG_LEAKING_SCALARS
323 Perl_op_clear(pTHX_ OP *o)
327 switch (o->op_type) {
328 case OP_NULL: /* Was holding old type, if any. */
329 case OP_ENTEREVAL: /* Was holding hints. */
333 if (!(o->op_flags & OPf_REF)
334 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
340 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
341 /* not an OP_PADAV replacement */
343 if (cPADOPo->op_padix > 0) {
344 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
345 * may still exist on the pad */
346 pad_swipe(cPADOPo->op_padix, TRUE);
347 cPADOPo->op_padix = 0;
350 SvREFCNT_dec(cSVOPo->op_sv);
351 cSVOPo->op_sv = Nullsv;
355 case OP_METHOD_NAMED:
357 SvREFCNT_dec(cSVOPo->op_sv);
358 cSVOPo->op_sv = Nullsv;
361 Even if op_clear does a pad_free for the target of the op,
362 pad_free doesn't actually remove the sv that exists in the pad;
363 instead it lives on. This results in that it could be reused as
364 a target later on when the pad was reallocated.
367 pad_swipe(o->op_targ,1);
376 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
380 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
381 SvREFCNT_dec(cSVOPo->op_sv);
382 cSVOPo->op_sv = Nullsv;
385 Safefree(cPVOPo->op_pv);
386 cPVOPo->op_pv = Nullch;
390 op_free(cPMOPo->op_pmreplroot);
394 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
395 /* No GvIN_PAD_off here, because other references may still
396 * exist on the pad */
397 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
400 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
407 HV *pmstash = PmopSTASH(cPMOPo);
408 if (pmstash && SvREFCNT(pmstash)) {
409 MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
411 PMOP *pmop = (PMOP*) mg->mg_obj;
412 PMOP *lastpmop = NULL;
414 if (cPMOPo == pmop) {
416 lastpmop->op_pmnext = pmop->op_pmnext;
418 mg->mg_obj = (SV*) pmop->op_pmnext;
422 pmop = pmop->op_pmnext;
426 PmopSTASH_free(cPMOPo);
428 cPMOPo->op_pmreplroot = Nullop;
429 /* we use the "SAFE" version of the PM_ macros here
430 * since sv_clean_all might release some PMOPs
431 * after PL_regex_padav has been cleared
432 * and the clearing of PL_regex_padav needs to
433 * happen before sv_clean_all
435 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
436 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
438 if(PL_regex_pad) { /* We could be in destruction */
439 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
440 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
441 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
448 if (o->op_targ > 0) {
449 pad_free(o->op_targ);
455 S_cop_free(pTHX_ COP* cop)
457 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
460 if (! specialWARN(cop->cop_warnings))
461 SvREFCNT_dec(cop->cop_warnings);
462 if (! specialCopIO(cop->cop_io)) {
466 char *s = SvPV(cop->cop_io,len);
467 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
470 SvREFCNT_dec(cop->cop_io);
476 Perl_op_null(pTHX_ OP *o)
479 if (o->op_type == OP_NULL)
482 o->op_targ = o->op_type;
483 o->op_type = OP_NULL;
484 o->op_ppaddr = PL_ppaddr[OP_NULL];
488 Perl_op_refcnt_lock(pTHX)
495 Perl_op_refcnt_unlock(pTHX)
501 /* Contextualizers */
503 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
506 Perl_linklist(pTHX_ OP *o)
512 /* establish postfix order */
513 if (cUNOPo->op_first) {
515 o->op_next = LINKLIST(cUNOPo->op_first);
516 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
518 kid->op_next = LINKLIST(kid->op_sibling);
530 Perl_scalarkids(pTHX_ OP *o)
532 if (o && o->op_flags & OPf_KIDS) {
534 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
541 S_scalarboolean(pTHX_ OP *o)
543 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
544 if (ckWARN(WARN_SYNTAX)) {
545 const line_t oldline = CopLINE(PL_curcop);
547 if (PL_copline != NOLINE)
548 CopLINE_set(PL_curcop, PL_copline);
549 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
550 CopLINE_set(PL_curcop, oldline);
557 Perl_scalar(pTHX_ OP *o)
562 /* assumes no premature commitment */
563 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
564 || o->op_type == OP_RETURN)
569 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
571 switch (o->op_type) {
573 scalar(cBINOPo->op_first);
578 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
582 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
583 if (!kPMOP->op_pmreplroot)
584 deprecate_old("implicit split to @_");
592 if (o->op_flags & OPf_KIDS) {
593 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
599 kid = cLISTOPo->op_first;
601 while ((kid = kid->op_sibling)) {
607 WITH_THR(PL_curcop = &PL_compiling);
612 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
618 WITH_THR(PL_curcop = &PL_compiling);
621 if (ckWARN(WARN_VOID))
622 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
628 Perl_scalarvoid(pTHX_ OP *o)
632 const char* useless = 0;
636 if (o->op_type == OP_NEXTSTATE
637 || o->op_type == OP_SETSTATE
638 || o->op_type == OP_DBSTATE
639 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
640 || o->op_targ == OP_SETSTATE
641 || o->op_targ == OP_DBSTATE)))
642 PL_curcop = (COP*)o; /* for warning below */
644 /* assumes no premature commitment */
645 want = o->op_flags & OPf_WANT;
646 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
647 || o->op_type == OP_RETURN)
652 if ((o->op_private & OPpTARGET_MY)
653 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
655 return scalar(o); /* As if inside SASSIGN */
658 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
660 switch (o->op_type) {
662 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
666 if (o->op_flags & OPf_STACKED)
670 if (o->op_private == 4)
742 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
743 useless = OP_DESC(o);
747 kid = cUNOPo->op_first;
748 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
749 kid->op_type != OP_TRANS) {
752 useless = "negative pattern binding (!~)";
759 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
760 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
761 useless = "a variable";
766 if (cSVOPo->op_private & OPpCONST_STRICT)
767 no_bareword_allowed(o);
769 if (ckWARN(WARN_VOID)) {
770 useless = "a constant";
771 /* don't warn on optimised away booleans, eg
772 * use constant Foo, 5; Foo || print; */
773 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
775 /* the constants 0 and 1 are permitted as they are
776 conventionally used as dummies in constructs like
777 1 while some_condition_with_side_effects; */
778 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
780 else if (SvPOK(sv)) {
781 /* perl4's way of mixing documentation and code
782 (before the invention of POD) was based on a
783 trick to mix nroff and perl code. The trick was
784 built upon these three nroff macros being used in
785 void context. The pink camel has the details in
786 the script wrapman near page 319. */
787 if (strnEQ(SvPVX_const(sv), "di", 2) ||
788 strnEQ(SvPVX_const(sv), "ds", 2) ||
789 strnEQ(SvPVX_const(sv), "ig", 2))
794 op_null(o); /* don't execute or even remember it */
798 o->op_type = OP_PREINC; /* pre-increment is faster */
799 o->op_ppaddr = PL_ppaddr[OP_PREINC];
803 o->op_type = OP_PREDEC; /* pre-decrement is faster */
804 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
811 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
816 if (o->op_flags & OPf_STACKED)
823 if (!(o->op_flags & OPf_KIDS))
832 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
839 /* all requires must return a boolean value */
840 o->op_flags &= ~OPf_WANT;
845 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
846 if (!kPMOP->op_pmreplroot)
847 deprecate_old("implicit split to @_");
851 if (useless && ckWARN(WARN_VOID))
852 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
857 Perl_listkids(pTHX_ OP *o)
859 if (o && o->op_flags & OPf_KIDS) {
861 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
868 Perl_list(pTHX_ OP *o)
873 /* assumes no premature commitment */
874 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
875 || o->op_type == OP_RETURN)
880 if ((o->op_private & OPpTARGET_MY)
881 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
883 return o; /* As if inside SASSIGN */
886 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
888 switch (o->op_type) {
891 list(cBINOPo->op_first);
896 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
904 if (!(o->op_flags & OPf_KIDS))
906 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
907 list(cBINOPo->op_first);
908 return gen_constant_list(o);
915 kid = cLISTOPo->op_first;
917 while ((kid = kid->op_sibling)) {
923 WITH_THR(PL_curcop = &PL_compiling);
927 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
933 WITH_THR(PL_curcop = &PL_compiling);
936 /* all requires must return a boolean value */
937 o->op_flags &= ~OPf_WANT;
944 Perl_scalarseq(pTHX_ OP *o)
947 if (o->op_type == OP_LINESEQ ||
948 o->op_type == OP_SCOPE ||
949 o->op_type == OP_LEAVE ||
950 o->op_type == OP_LEAVETRY)
953 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
954 if (kid->op_sibling) {
958 PL_curcop = &PL_compiling;
960 o->op_flags &= ~OPf_PARENS;
961 if (PL_hints & HINT_BLOCK_SCOPE)
962 o->op_flags |= OPf_PARENS;
965 o = newOP(OP_STUB, 0);
970 S_modkids(pTHX_ OP *o, I32 type)
972 if (o && o->op_flags & OPf_KIDS) {
974 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
980 /* Propagate lvalue ("modifiable") context to an op and it's children.
981 * 'type' represents the context type, roughly based on the type of op that
982 * would do the modifying, although local() is represented by OP_NULL.
983 * It's responsible for detecting things that can't be modified, flag
984 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
985 * might have to vivify a reference in $x), and so on.
987 * For example, "$a+1 = 2" would cause mod() to be called with o being
988 * OP_ADD and type being OP_SASSIGN, and would output an error.
992 Perl_mod(pTHX_ OP *o, I32 type)
996 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
999 if (!o || PL_error_count)
1002 if ((o->op_private & OPpTARGET_MY)
1003 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1008 switch (o->op_type) {
1014 if (!(o->op_private & (OPpCONST_ARYBASE)))
1016 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1017 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1021 SAVEI32(PL_compiling.cop_arybase);
1022 PL_compiling.cop_arybase = 0;
1024 else if (type == OP_REFGEN)
1027 Perl_croak(aTHX_ "That use of $[ is unsupported");
1030 if (o->op_flags & OPf_PARENS)
1034 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1035 !(o->op_flags & OPf_STACKED)) {
1036 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1037 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1038 assert(cUNOPo->op_first->op_type == OP_NULL);
1039 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1042 else if (o->op_private & OPpENTERSUB_NOMOD)
1044 else { /* lvalue subroutine call */
1045 o->op_private |= OPpLVAL_INTRO;
1046 PL_modcount = RETURN_UNLIMITED_NUMBER;
1047 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1048 /* Backward compatibility mode: */
1049 o->op_private |= OPpENTERSUB_INARGS;
1052 else { /* Compile-time error message: */
1053 OP *kid = cUNOPo->op_first;
1057 if (kid->op_type == OP_PUSHMARK)
1059 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1061 "panic: unexpected lvalue entersub "
1062 "args: type/targ %ld:%"UVuf,
1063 (long)kid->op_type, (UV)kid->op_targ);
1064 kid = kLISTOP->op_first;
1066 while (kid->op_sibling)
1067 kid = kid->op_sibling;
1068 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1070 if (kid->op_type == OP_METHOD_NAMED
1071 || kid->op_type == OP_METHOD)
1075 NewOp(1101, newop, 1, UNOP);
1076 newop->op_type = OP_RV2CV;
1077 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1078 newop->op_first = Nullop;
1079 newop->op_next = (OP*)newop;
1080 kid->op_sibling = (OP*)newop;
1081 newop->op_private |= OPpLVAL_INTRO;
1085 if (kid->op_type != OP_RV2CV)
1087 "panic: unexpected lvalue entersub "
1088 "entry via type/targ %ld:%"UVuf,
1089 (long)kid->op_type, (UV)kid->op_targ);
1090 kid->op_private |= OPpLVAL_INTRO;
1091 break; /* Postpone until runtime */
1095 kid = kUNOP->op_first;
1096 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1097 kid = kUNOP->op_first;
1098 if (kid->op_type == OP_NULL)
1100 "Unexpected constant lvalue entersub "
1101 "entry via type/targ %ld:%"UVuf,
1102 (long)kid->op_type, (UV)kid->op_targ);
1103 if (kid->op_type != OP_GV) {
1104 /* Restore RV2CV to check lvalueness */
1106 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1107 okid->op_next = kid->op_next;
1108 kid->op_next = okid;
1111 okid->op_next = Nullop;
1112 okid->op_type = OP_RV2CV;
1114 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1115 okid->op_private |= OPpLVAL_INTRO;
1119 cv = GvCV(kGVOP_gv);
1129 /* grep, foreach, subcalls, refgen */
1130 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1132 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1133 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1135 : (o->op_type == OP_ENTERSUB
1136 ? "non-lvalue subroutine call"
1138 type ? PL_op_desc[type] : "local"));
1152 case OP_RIGHT_SHIFT:
1161 if (!(o->op_flags & OPf_STACKED))
1168 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1174 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1175 PL_modcount = RETURN_UNLIMITED_NUMBER;
1176 return o; /* Treat \(@foo) like ordinary list. */
1180 if (scalar_mod_type(o, type))
1182 ref(cUNOPo->op_first, o->op_type);
1186 if (type == OP_LEAVESUBLV)
1187 o->op_private |= OPpMAYBE_LVSUB;
1193 PL_modcount = RETURN_UNLIMITED_NUMBER;
1196 ref(cUNOPo->op_first, o->op_type);
1201 PL_hints |= HINT_BLOCK_SCOPE;
1216 PL_modcount = RETURN_UNLIMITED_NUMBER;
1217 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1218 return o; /* Treat \(@foo) like ordinary list. */
1219 if (scalar_mod_type(o, type))
1221 if (type == OP_LEAVESUBLV)
1222 o->op_private |= OPpMAYBE_LVSUB;
1226 if (!type) /* local() */
1227 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1228 PAD_COMPNAME_PV(o->op_targ));
1236 if (type != OP_SASSIGN)
1240 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1245 if (type == OP_LEAVESUBLV)
1246 o->op_private |= OPpMAYBE_LVSUB;
1248 pad_free(o->op_targ);
1249 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1250 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1251 if (o->op_flags & OPf_KIDS)
1252 mod(cBINOPo->op_first->op_sibling, type);
1257 ref(cBINOPo->op_first, o->op_type);
1258 if (type == OP_ENTERSUB &&
1259 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1260 o->op_private |= OPpLVAL_DEFER;
1261 if (type == OP_LEAVESUBLV)
1262 o->op_private |= OPpMAYBE_LVSUB;
1272 if (o->op_flags & OPf_KIDS)
1273 mod(cLISTOPo->op_last, type);
1278 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1280 else if (!(o->op_flags & OPf_KIDS))
1282 if (o->op_targ != OP_LIST) {
1283 mod(cBINOPo->op_first, type);
1289 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1294 if (type != OP_LEAVESUBLV)
1296 break; /* mod()ing was handled by ck_return() */
1299 /* [20011101.069] File test operators interpret OPf_REF to mean that
1300 their argument is a filehandle; thus \stat(".") should not set
1302 if (type == OP_REFGEN &&
1303 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1306 if (type != OP_LEAVESUBLV)
1307 o->op_flags |= OPf_MOD;
1309 if (type == OP_AASSIGN || type == OP_SASSIGN)
1310 o->op_flags |= OPf_SPECIAL|OPf_REF;
1311 else if (!type) { /* local() */
1314 o->op_private |= OPpLVAL_INTRO;
1315 o->op_flags &= ~OPf_SPECIAL;
1316 PL_hints |= HINT_BLOCK_SCOPE;
1321 if (ckWARN(WARN_SYNTAX)) {
1322 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1323 "Useless localization of %s", OP_DESC(o));
1327 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1328 && type != OP_LEAVESUBLV)
1329 o->op_flags |= OPf_REF;
1334 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1338 if (o->op_type == OP_RV2GV)
1362 case OP_RIGHT_SHIFT:
1381 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1383 switch (o->op_type) {
1391 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1404 Perl_refkids(pTHX_ OP *o, I32 type)
1406 if (o && o->op_flags & OPf_KIDS) {
1408 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1415 Perl_ref(pTHX_ OP *o, I32 type)
1420 if (!o || PL_error_count)
1423 switch (o->op_type) {
1425 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1426 !(o->op_flags & OPf_STACKED)) {
1427 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1428 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1429 assert(cUNOPo->op_first->op_type == OP_NULL);
1430 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1431 o->op_flags |= OPf_SPECIAL;
1436 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1440 if (type == OP_DEFINED)
1441 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1442 ref(cUNOPo->op_first, o->op_type);
1445 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1446 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1447 : type == OP_RV2HV ? OPpDEREF_HV
1449 o->op_flags |= OPf_MOD;
1454 o->op_flags |= OPf_MOD; /* XXX ??? */
1459 o->op_flags |= OPf_REF;
1462 if (type == OP_DEFINED)
1463 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1464 ref(cUNOPo->op_first, o->op_type);
1469 o->op_flags |= OPf_REF;
1474 if (!(o->op_flags & OPf_KIDS))
1476 ref(cBINOPo->op_first, type);
1480 ref(cBINOPo->op_first, o->op_type);
1481 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1482 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1483 : type == OP_RV2HV ? OPpDEREF_HV
1485 o->op_flags |= OPf_MOD;
1493 if (!(o->op_flags & OPf_KIDS))
1495 ref(cLISTOPo->op_last, type);
1505 S_dup_attrlist(pTHX_ OP *o)
1509 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1510 * where the first kid is OP_PUSHMARK and the remaining ones
1511 * are OP_CONST. We need to push the OP_CONST values.
1513 if (o->op_type == OP_CONST)
1514 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1516 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1517 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1518 if (o->op_type == OP_CONST)
1519 rop = append_elem(OP_LIST, rop,
1520 newSVOP(OP_CONST, o->op_flags,
1521 SvREFCNT_inc(cSVOPo->op_sv)));
1528 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1533 /* fake up C<use attributes $pkg,$rv,@attrs> */
1534 ENTER; /* need to protect against side-effects of 'use' */
1536 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1538 #define ATTRSMODULE "attributes"
1539 #define ATTRSMODULE_PM "attributes.pm"
1542 /* Don't force the C<use> if we don't need it. */
1543 SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1544 sizeof(ATTRSMODULE_PM)-1, 0);
1545 if (svp && *svp != &PL_sv_undef)
1546 ; /* already in %INC */
1548 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1549 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1553 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1554 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1556 prepend_elem(OP_LIST,
1557 newSVOP(OP_CONST, 0, stashsv),
1558 prepend_elem(OP_LIST,
1559 newSVOP(OP_CONST, 0,
1561 dup_attrlist(attrs))));
1567 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1569 OP *pack, *imop, *arg;
1575 assert(target->op_type == OP_PADSV ||
1576 target->op_type == OP_PADHV ||
1577 target->op_type == OP_PADAV);
1579 /* Ensure that attributes.pm is loaded. */
1580 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1582 /* Need package name for method call. */
1583 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1585 /* Build up the real arg-list. */
1586 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1588 arg = newOP(OP_PADSV, 0);
1589 arg->op_targ = target->op_targ;
1590 arg = prepend_elem(OP_LIST,
1591 newSVOP(OP_CONST, 0, stashsv),
1592 prepend_elem(OP_LIST,
1593 newUNOP(OP_REFGEN, 0,
1594 mod(arg, OP_REFGEN)),
1595 dup_attrlist(attrs)));
1597 /* Fake up a method call to import */
1598 meth = newSVpvn_share("import", 6, 0);
1599 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1600 append_elem(OP_LIST,
1601 prepend_elem(OP_LIST, pack, list(arg)),
1602 newSVOP(OP_METHOD_NAMED, 0, meth)));
1603 imop->op_private |= OPpENTERSUB_NOMOD;
1605 /* Combine the ops. */
1606 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1610 =notfor apidoc apply_attrs_string
1612 Attempts to apply a list of attributes specified by the C<attrstr> and
1613 C<len> arguments to the subroutine identified by the C<cv> argument which
1614 is expected to be associated with the package identified by the C<stashpv>
1615 argument (see L<attributes>). It gets this wrong, though, in that it
1616 does not correctly identify the boundaries of the individual attribute
1617 specifications within C<attrstr>. This is not really intended for the
1618 public API, but has to be listed here for systems such as AIX which
1619 need an explicit export list for symbols. (It's called from XS code
1620 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1621 to respect attribute syntax properly would be welcome.
1627 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1628 const char *attrstr, STRLEN len)
1633 len = strlen(attrstr);
1637 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1639 const char *sstr = attrstr;
1640 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1641 attrs = append_elem(OP_LIST, attrs,
1642 newSVOP(OP_CONST, 0,
1643 newSVpvn(sstr, attrstr-sstr)));
1647 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1648 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1649 Nullsv, prepend_elem(OP_LIST,
1650 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1651 prepend_elem(OP_LIST,
1652 newSVOP(OP_CONST, 0,
1658 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1662 if (!o || PL_error_count)
1666 if (type == OP_LIST) {
1668 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1669 my_kid(kid, attrs, imopsp);
1670 } else if (type == OP_UNDEF) {
1672 } else if (type == OP_RV2SV || /* "our" declaration */
1674 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1675 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1676 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1677 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1679 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1681 PL_in_my_stash = Nullhv;
1682 apply_attrs(GvSTASH(gv),
1683 (type == OP_RV2SV ? GvSV(gv) :
1684 type == OP_RV2AV ? (SV*)GvAV(gv) :
1685 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1688 o->op_private |= OPpOUR_INTRO;
1691 else if (type != OP_PADSV &&
1694 type != OP_PUSHMARK)
1696 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1698 PL_in_my == KEY_our ? "our" : "my"));
1701 else if (attrs && type != OP_PUSHMARK) {
1705 PL_in_my_stash = Nullhv;
1707 /* check for C<my Dog $spot> when deciding package */
1708 stash = PAD_COMPNAME_TYPE(o->op_targ);
1710 stash = PL_curstash;
1711 apply_attrs_my(stash, o, attrs, imopsp);
1713 o->op_flags |= OPf_MOD;
1714 o->op_private |= OPpLVAL_INTRO;
1719 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1722 int maybe_scalar = 0;
1724 /* [perl #17376]: this appears to be premature, and results in code such as
1725 C< our(%x); > executing in list mode rather than void mode */
1727 if (o->op_flags & OPf_PARENS)
1736 o = my_kid(o, attrs, &rops);
1738 if (maybe_scalar && o->op_type == OP_PADSV) {
1739 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1740 o->op_private |= OPpLVAL_INTRO;
1743 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1746 PL_in_my_stash = Nullhv;
1751 Perl_my(pTHX_ OP *o)
1753 return my_attrs(o, Nullop);
1757 Perl_sawparens(pTHX_ OP *o)
1760 o->op_flags |= OPf_PARENS;
1765 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1770 if (ckWARN(WARN_MISC) &&
1771 (left->op_type == OP_RV2AV ||
1772 left->op_type == OP_RV2HV ||
1773 left->op_type == OP_PADAV ||
1774 left->op_type == OP_PADHV)) {
1775 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1776 right->op_type == OP_TRANS)
1777 ? right->op_type : OP_MATCH];
1778 const char *sample = ((left->op_type == OP_RV2AV ||
1779 left->op_type == OP_PADAV)
1780 ? "@array" : "%hash");
1781 Perl_warner(aTHX_ packWARN(WARN_MISC),
1782 "Applying %s to %s will act on scalar(%s)",
1783 desc, sample, sample);
1786 if (right->op_type == OP_CONST &&
1787 cSVOPx(right)->op_private & OPpCONST_BARE &&
1788 cSVOPx(right)->op_private & OPpCONST_STRICT)
1790 no_bareword_allowed(right);
1793 ismatchop = right->op_type == OP_MATCH ||
1794 right->op_type == OP_SUBST ||
1795 right->op_type == OP_TRANS;
1796 if (ismatchop && right->op_private & OPpTARGET_MY) {
1798 right->op_private &= ~OPpTARGET_MY;
1800 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1801 right->op_flags |= OPf_STACKED;
1802 if (right->op_type != OP_MATCH &&
1803 ! (right->op_type == OP_TRANS &&
1804 right->op_private & OPpTRANS_IDENTICAL))
1805 left = mod(left, right->op_type);
1806 if (right->op_type == OP_TRANS)
1807 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1809 o = prepend_elem(right->op_type, scalar(left), right);
1811 return newUNOP(OP_NOT, 0, scalar(o));
1815 return bind_match(type, left,
1816 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1820 Perl_invert(pTHX_ OP *o)
1824 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1825 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1829 Perl_scope(pTHX_ OP *o)
1833 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1834 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1835 o->op_type = OP_LEAVE;
1836 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1838 else if (o->op_type == OP_LINESEQ) {
1840 o->op_type = OP_SCOPE;
1841 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1842 kid = ((LISTOP*)o)->op_first;
1843 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1847 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1852 /* XXX kept for BINCOMPAT only */
1854 Perl_save_hints(pTHX)
1856 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1860 Perl_block_start(pTHX_ int full)
1862 const int retval = PL_savestack_ix;
1863 pad_block_start(full);
1865 PL_hints &= ~HINT_BLOCK_SCOPE;
1866 SAVESPTR(PL_compiling.cop_warnings);
1867 if (! specialWARN(PL_compiling.cop_warnings)) {
1868 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1869 SAVEFREESV(PL_compiling.cop_warnings) ;
1871 SAVESPTR(PL_compiling.cop_io);
1872 if (! specialCopIO(PL_compiling.cop_io)) {
1873 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1874 SAVEFREESV(PL_compiling.cop_io) ;
1880 Perl_block_end(pTHX_ I32 floor, OP *seq)
1882 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1883 OP* retval = scalarseq(seq);
1885 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1887 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1895 const I32 offset = pad_findmy("$_");
1896 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1897 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1900 OP *o = newOP(OP_PADSV, 0);
1901 o->op_targ = offset;
1907 Perl_newPROG(pTHX_ OP *o)
1912 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1913 ((PL_in_eval & EVAL_KEEPERR)
1914 ? OPf_SPECIAL : 0), o);
1915 PL_eval_start = linklist(PL_eval_root);
1916 PL_eval_root->op_private |= OPpREFCOUNTED;
1917 OpREFCNT_set(PL_eval_root, 1);
1918 PL_eval_root->op_next = 0;
1919 CALL_PEEP(PL_eval_start);
1922 if (o->op_type == OP_STUB) {
1923 PL_comppad_name = 0;
1928 PL_main_root = scope(sawparens(scalarvoid(o)));
1929 PL_curcop = &PL_compiling;
1930 PL_main_start = LINKLIST(PL_main_root);
1931 PL_main_root->op_private |= OPpREFCOUNTED;
1932 OpREFCNT_set(PL_main_root, 1);
1933 PL_main_root->op_next = 0;
1934 CALL_PEEP(PL_main_start);
1937 /* Register with debugger */
1939 CV *cv = get_cv("DB::postponed", FALSE);
1943 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1945 call_sv((SV*)cv, G_DISCARD);
1952 Perl_localize(pTHX_ OP *o, I32 lex)
1954 if (o->op_flags & OPf_PARENS)
1955 /* [perl #17376]: this appears to be premature, and results in code such as
1956 C< our(%x); > executing in list mode rather than void mode */
1963 if (ckWARN(WARN_PARENTHESIS)
1964 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1966 char *s = PL_bufptr;
1969 /* some heuristics to detect a potential error */
1970 while (*s && (strchr(", \t\n", *s)))
1974 if (*s && strchr("@$%*", *s) && *++s
1975 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1978 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1980 while (*s && (strchr(", \t\n", *s)))
1986 if (sigil && (*s == ';' || *s == '=')) {
1987 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1988 "Parentheses missing around \"%s\" list",
1989 lex ? (PL_in_my == KEY_our ? "our" : "my")
1997 o = mod(o, OP_NULL); /* a bit kludgey */
1999 PL_in_my_stash = Nullhv;
2004 Perl_jmaybe(pTHX_ OP *o)
2006 if (o->op_type == OP_LIST) {
2008 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2009 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2015 Perl_fold_constants(pTHX_ register OP *o)
2019 I32 type = o->op_type;
2022 if (PL_opargs[type] & OA_RETSCALAR)
2024 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2025 o->op_targ = pad_alloc(type, SVs_PADTMP);
2027 /* integerize op, unless it happens to be C<-foo>.
2028 * XXX should pp_i_negate() do magic string negation instead? */
2029 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2030 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2031 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2033 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2036 if (!(PL_opargs[type] & OA_FOLDCONST))
2041 /* XXX might want a ck_negate() for this */
2042 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2054 /* XXX what about the numeric ops? */
2055 if (PL_hints & HINT_LOCALE)
2060 goto nope; /* Don't try to run w/ errors */
2062 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2063 if ((curop->op_type != OP_CONST ||
2064 (curop->op_private & OPpCONST_BARE)) &&
2065 curop->op_type != OP_LIST &&
2066 curop->op_type != OP_SCALAR &&
2067 curop->op_type != OP_NULL &&
2068 curop->op_type != OP_PUSHMARK)
2074 curop = LINKLIST(o);
2078 sv = *(PL_stack_sp--);
2079 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2080 pad_swipe(o->op_targ, FALSE);
2081 else if (SvTEMP(sv)) { /* grab mortal temp? */
2082 (void)SvREFCNT_inc(sv);
2086 if (type == OP_RV2GV)
2087 return newGVOP(OP_GV, 0, (GV*)sv);
2088 return newSVOP(OP_CONST, 0, sv);
2095 Perl_gen_constant_list(pTHX_ register OP *o)
2099 const I32 oldtmps_floor = PL_tmps_floor;
2103 return o; /* Don't attempt to run with errors */
2105 PL_op = curop = LINKLIST(o);
2112 PL_tmps_floor = oldtmps_floor;
2114 o->op_type = OP_RV2AV;
2115 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2116 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2117 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2118 o->op_opt = 0; /* needs to be revisited in peep() */
2119 curop = ((UNOP*)o)->op_first;
2120 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2127 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2130 if (!o || o->op_type != OP_LIST)
2131 o = newLISTOP(OP_LIST, 0, o, Nullop);
2133 o->op_flags &= ~OPf_WANT;
2135 if (!(PL_opargs[type] & OA_MARK))
2136 op_null(cLISTOPo->op_first);
2138 o->op_type = (OPCODE)type;
2139 o->op_ppaddr = PL_ppaddr[type];
2140 o->op_flags |= flags;
2142 o = CHECKOP(type, o);
2143 if (o->op_type != (unsigned)type)
2146 return fold_constants(o);
2149 /* List constructors */
2152 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2160 if (first->op_type != (unsigned)type
2161 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2163 return newLISTOP(type, 0, first, last);
2166 if (first->op_flags & OPf_KIDS)
2167 ((LISTOP*)first)->op_last->op_sibling = last;
2169 first->op_flags |= OPf_KIDS;
2170 ((LISTOP*)first)->op_first = last;
2172 ((LISTOP*)first)->op_last = last;
2177 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2185 if (first->op_type != (unsigned)type)
2186 return prepend_elem(type, (OP*)first, (OP*)last);
2188 if (last->op_type != (unsigned)type)
2189 return append_elem(type, (OP*)first, (OP*)last);
2191 first->op_last->op_sibling = last->op_first;
2192 first->op_last = last->op_last;
2193 first->op_flags |= (last->op_flags & OPf_KIDS);
2201 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2209 if (last->op_type == (unsigned)type) {
2210 if (type == OP_LIST) { /* already a PUSHMARK there */
2211 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2212 ((LISTOP*)last)->op_first->op_sibling = first;
2213 if (!(first->op_flags & OPf_PARENS))
2214 last->op_flags &= ~OPf_PARENS;
2217 if (!(last->op_flags & OPf_KIDS)) {
2218 ((LISTOP*)last)->op_last = first;
2219 last->op_flags |= OPf_KIDS;
2221 first->op_sibling = ((LISTOP*)last)->op_first;
2222 ((LISTOP*)last)->op_first = first;
2224 last->op_flags |= OPf_KIDS;
2228 return newLISTOP(type, 0, first, last);
2234 Perl_newNULLLIST(pTHX)
2236 return newOP(OP_STUB, 0);
2240 Perl_force_list(pTHX_ OP *o)
2242 if (!o || o->op_type != OP_LIST)
2243 o = newLISTOP(OP_LIST, 0, o, Nullop);
2249 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2254 NewOp(1101, listop, 1, LISTOP);
2256 listop->op_type = (OPCODE)type;
2257 listop->op_ppaddr = PL_ppaddr[type];
2260 listop->op_flags = (U8)flags;
2264 else if (!first && last)
2267 first->op_sibling = last;
2268 listop->op_first = first;
2269 listop->op_last = last;
2270 if (type == OP_LIST) {
2272 pushop = newOP(OP_PUSHMARK, 0);
2273 pushop->op_sibling = first;
2274 listop->op_first = pushop;
2275 listop->op_flags |= OPf_KIDS;
2277 listop->op_last = pushop;
2280 return CHECKOP(type, listop);
2284 Perl_newOP(pTHX_ I32 type, I32 flags)
2288 NewOp(1101, o, 1, OP);
2289 o->op_type = (OPCODE)type;
2290 o->op_ppaddr = PL_ppaddr[type];
2291 o->op_flags = (U8)flags;
2294 o->op_private = (U8)(0 | (flags >> 8));
2295 if (PL_opargs[type] & OA_RETSCALAR)
2297 if (PL_opargs[type] & OA_TARGET)
2298 o->op_targ = pad_alloc(type, SVs_PADTMP);
2299 return CHECKOP(type, o);
2303 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2309 first = newOP(OP_STUB, 0);
2310 if (PL_opargs[type] & OA_MARK)
2311 first = force_list(first);
2313 NewOp(1101, unop, 1, UNOP);
2314 unop->op_type = (OPCODE)type;
2315 unop->op_ppaddr = PL_ppaddr[type];
2316 unop->op_first = first;
2317 unop->op_flags = flags | OPf_KIDS;
2318 unop->op_private = (U8)(1 | (flags >> 8));
2319 unop = (UNOP*) CHECKOP(type, unop);
2323 return fold_constants((OP *) unop);
2327 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2331 NewOp(1101, binop, 1, BINOP);
2334 first = newOP(OP_NULL, 0);
2336 binop->op_type = (OPCODE)type;
2337 binop->op_ppaddr = PL_ppaddr[type];
2338 binop->op_first = first;
2339 binop->op_flags = flags | OPf_KIDS;
2342 binop->op_private = (U8)(1 | (flags >> 8));
2345 binop->op_private = (U8)(2 | (flags >> 8));
2346 first->op_sibling = last;
2349 binop = (BINOP*)CHECKOP(type, binop);
2350 if (binop->op_next || binop->op_type != (OPCODE)type)
2353 binop->op_last = binop->op_first->op_sibling;
2355 return fold_constants((OP *)binop);
2358 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2359 static int uvcompare(const void *a, const void *b)
2361 if (*((const UV *)a) < (*(const UV *)b))
2363 if (*((const UV *)a) > (*(const UV *)b))
2365 if (*((const UV *)a+1) < (*(const UV *)b+1))
2367 if (*((const UV *)a+1) > (*(const UV *)b+1))
2373 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2375 SV *tstr = ((SVOP*)expr)->op_sv;
2376 SV *rstr = ((SVOP*)repl)->op_sv;
2379 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2380 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2387 register short *tbl;
2389 PL_hints |= HINT_BLOCK_SCOPE;
2390 complement = o->op_private & OPpTRANS_COMPLEMENT;
2391 del = o->op_private & OPpTRANS_DELETE;
2392 squash = o->op_private & OPpTRANS_SQUASH;
2395 o->op_private |= OPpTRANS_FROM_UTF;
2398 o->op_private |= OPpTRANS_TO_UTF;
2400 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2401 SV* listsv = newSVpvn("# comment\n",10);
2403 const U8* tend = t + tlen;
2404 const U8* rend = r + rlen;
2418 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2419 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2425 t = tsave = bytes_to_utf8(t, &len);
2428 if (!to_utf && rlen) {
2430 r = rsave = bytes_to_utf8(r, &len);
2434 /* There are several snags with this code on EBCDIC:
2435 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2436 2. scan_const() in toke.c has encoded chars in native encoding which makes
2437 ranges at least in EBCDIC 0..255 range the bottom odd.
2441 U8 tmpbuf[UTF8_MAXBYTES+1];
2444 New(1109, cp, 2*tlen, UV);
2446 transv = newSVpvn("",0);
2448 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2450 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2452 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2456 cp[2*i+1] = cp[2*i];
2460 qsort(cp, i, 2*sizeof(UV), uvcompare);
2461 for (j = 0; j < i; j++) {
2463 diff = val - nextmin;
2465 t = uvuni_to_utf8(tmpbuf,nextmin);
2466 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2468 U8 range_mark = UTF_TO_NATIVE(0xff);
2469 t = uvuni_to_utf8(tmpbuf, val - 1);
2470 sv_catpvn(transv, (char *)&range_mark, 1);
2471 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2478 t = uvuni_to_utf8(tmpbuf,nextmin);
2479 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2481 U8 range_mark = UTF_TO_NATIVE(0xff);
2482 sv_catpvn(transv, (char *)&range_mark, 1);
2484 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2485 UNICODE_ALLOW_SUPER);
2486 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2487 t = (const U8*)SvPVX_const(transv);
2488 tlen = SvCUR(transv);
2492 else if (!rlen && !del) {
2493 r = t; rlen = tlen; rend = tend;
2496 if ((!rlen && !del) || t == r ||
2497 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2499 o->op_private |= OPpTRANS_IDENTICAL;
2503 while (t < tend || tfirst <= tlast) {
2504 /* see if we need more "t" chars */
2505 if (tfirst > tlast) {
2506 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2508 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2510 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2517 /* now see if we need more "r" chars */
2518 if (rfirst > rlast) {
2520 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2522 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2524 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2533 rfirst = rlast = 0xffffffff;
2537 /* now see which range will peter our first, if either. */
2538 tdiff = tlast - tfirst;
2539 rdiff = rlast - rfirst;
2546 if (rfirst == 0xffffffff) {
2547 diff = tdiff; /* oops, pretend rdiff is infinite */
2549 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2550 (long)tfirst, (long)tlast);
2552 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2556 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2557 (long)tfirst, (long)(tfirst + diff),
2560 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2561 (long)tfirst, (long)rfirst);
2563 if (rfirst + diff > max)
2564 max = rfirst + diff;
2566 grows = (tfirst < rfirst &&
2567 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2579 else if (max > 0xff)
2584 Safefree(cPVOPo->op_pv);
2585 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2586 SvREFCNT_dec(listsv);
2588 SvREFCNT_dec(transv);
2590 if (!del && havefinal && rlen)
2591 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2592 newSVuv((UV)final), 0);
2595 o->op_private |= OPpTRANS_GROWS;
2607 tbl = (short*)cPVOPo->op_pv;
2609 Zero(tbl, 256, short);
2610 for (i = 0; i < (I32)tlen; i++)
2612 for (i = 0, j = 0; i < 256; i++) {
2614 if (j >= (I32)rlen) {
2623 if (i < 128 && r[j] >= 128)
2633 o->op_private |= OPpTRANS_IDENTICAL;
2635 else if (j >= (I32)rlen)
2638 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2639 tbl[0x100] = rlen - j;
2640 for (i=0; i < (I32)rlen - j; i++)
2641 tbl[0x101+i] = r[j+i];
2645 if (!rlen && !del) {
2648 o->op_private |= OPpTRANS_IDENTICAL;
2650 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2651 o->op_private |= OPpTRANS_IDENTICAL;
2653 for (i = 0; i < 256; i++)
2655 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2656 if (j >= (I32)rlen) {
2658 if (tbl[t[i]] == -1)
2664 if (tbl[t[i]] == -1) {
2665 if (t[i] < 128 && r[j] >= 128)
2672 o->op_private |= OPpTRANS_GROWS;
2680 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2685 NewOp(1101, pmop, 1, PMOP);
2686 pmop->op_type = (OPCODE)type;
2687 pmop->op_ppaddr = PL_ppaddr[type];
2688 pmop->op_flags = (U8)flags;
2689 pmop->op_private = (U8)(0 | (flags >> 8));
2691 if (PL_hints & HINT_RE_TAINT)
2692 pmop->op_pmpermflags |= PMf_RETAINT;
2693 if (PL_hints & HINT_LOCALE)
2694 pmop->op_pmpermflags |= PMf_LOCALE;
2695 pmop->op_pmflags = pmop->op_pmpermflags;
2700 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2701 repointer = av_pop((AV*)PL_regex_pad[0]);
2702 pmop->op_pmoffset = SvIV(repointer);
2703 SvREPADTMP_off(repointer);
2704 sv_setiv(repointer,0);
2706 repointer = newSViv(0);
2707 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2708 pmop->op_pmoffset = av_len(PL_regex_padav);
2709 PL_regex_pad = AvARRAY(PL_regex_padav);
2714 /* link into pm list */
2715 if (type != OP_TRANS && PL_curstash) {
2716 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2719 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2721 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2722 mg->mg_obj = (SV*)pmop;
2723 PmopSTASH_set(pmop,PL_curstash);
2726 return CHECKOP(type, pmop);
2729 /* Given some sort of match op o, and an expression expr containing a
2730 * pattern, either compile expr into a regex and attach it to o (if it's
2731 * constant), or convert expr into a runtime regcomp op sequence (if it's
2734 * isreg indicates that the pattern is part of a regex construct, eg
2735 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2736 * split "pattern", which aren't. In the former case, expr will be a list
2737 * if the pattern contains more than one term (eg /a$b/) or if it contains
2738 * a replacement, ie s/// or tr///.
2742 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2747 I32 repl_has_vars = 0;
2751 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2752 /* last element in list is the replacement; pop it */
2754 repl = cLISTOPx(expr)->op_last;
2755 kid = cLISTOPx(expr)->op_first;
2756 while (kid->op_sibling != repl)
2757 kid = kid->op_sibling;
2758 kid->op_sibling = Nullop;
2759 cLISTOPx(expr)->op_last = kid;
2762 if (isreg && expr->op_type == OP_LIST &&
2763 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2765 /* convert single element list to element */
2767 expr = cLISTOPx(oe)->op_first->op_sibling;
2768 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2769 cLISTOPx(oe)->op_last = Nullop;
2773 if (o->op_type == OP_TRANS) {
2774 return pmtrans(o, expr, repl);
2777 reglist = isreg && expr->op_type == OP_LIST;
2781 PL_hints |= HINT_BLOCK_SCOPE;
2784 if (expr->op_type == OP_CONST) {
2786 SV *pat = ((SVOP*)expr)->op_sv;
2787 const char *p = SvPV_const(pat, plen);
2788 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2789 U32 was_readonly = SvREADONLY(pat);
2793 sv_force_normal_flags(pat, 0);
2794 assert(!SvREADONLY(pat));
2797 SvREADONLY_off(pat);
2801 sv_setpvn(pat, "\\s+", 3);
2803 SvFLAGS(pat) |= was_readonly;
2805 p = SvPV_const(pat, plen);
2806 pm->op_pmflags |= PMf_SKIPWHITE;
2809 pm->op_pmdynflags |= PMdf_UTF8;
2810 /* FIXME - can we make this function take const char * args? */
2811 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2812 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2813 pm->op_pmflags |= PMf_WHITE;
2817 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2818 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2820 : OP_REGCMAYBE),0,expr);
2822 NewOp(1101, rcop, 1, LOGOP);
2823 rcop->op_type = OP_REGCOMP;
2824 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2825 rcop->op_first = scalar(expr);
2826 rcop->op_flags |= OPf_KIDS
2827 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2828 | (reglist ? OPf_STACKED : 0);
2829 rcop->op_private = 1;
2832 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2834 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2837 /* establish postfix order */
2838 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2840 rcop->op_next = expr;
2841 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2844 rcop->op_next = LINKLIST(expr);
2845 expr->op_next = (OP*)rcop;
2848 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2853 if (pm->op_pmflags & PMf_EVAL) {
2855 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2856 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2858 else if (repl->op_type == OP_CONST)
2862 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2863 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2864 if (curop->op_type == OP_GV) {
2865 GV *gv = cGVOPx_gv(curop);
2867 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2870 else if (curop->op_type == OP_RV2CV)
2872 else if (curop->op_type == OP_RV2SV ||
2873 curop->op_type == OP_RV2AV ||
2874 curop->op_type == OP_RV2HV ||
2875 curop->op_type == OP_RV2GV) {
2876 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2879 else if (curop->op_type == OP_PADSV ||
2880 curop->op_type == OP_PADAV ||
2881 curop->op_type == OP_PADHV ||
2882 curop->op_type == OP_PADANY) {
2885 else if (curop->op_type == OP_PUSHRE)
2886 ; /* Okay here, dangerous in newASSIGNOP */
2896 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2897 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2898 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2899 prepend_elem(o->op_type, scalar(repl), o);
2902 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2903 pm->op_pmflags |= PMf_MAYBE_CONST;
2904 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2906 NewOp(1101, rcop, 1, LOGOP);
2907 rcop->op_type = OP_SUBSTCONT;
2908 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2909 rcop->op_first = scalar(repl);
2910 rcop->op_flags |= OPf_KIDS;
2911 rcop->op_private = 1;
2914 /* establish postfix order */
2915 rcop->op_next = LINKLIST(repl);
2916 repl->op_next = (OP*)rcop;
2918 pm->op_pmreplroot = scalar((OP*)rcop);
2919 pm->op_pmreplstart = LINKLIST(rcop);
2928 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2932 NewOp(1101, svop, 1, SVOP);
2933 svop->op_type = (OPCODE)type;
2934 svop->op_ppaddr = PL_ppaddr[type];
2936 svop->op_next = (OP*)svop;
2937 svop->op_flags = (U8)flags;
2938 if (PL_opargs[type] & OA_RETSCALAR)
2940 if (PL_opargs[type] & OA_TARGET)
2941 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2942 return CHECKOP(type, svop);
2946 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2950 NewOp(1101, padop, 1, PADOP);
2951 padop->op_type = (OPCODE)type;
2952 padop->op_ppaddr = PL_ppaddr[type];
2953 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2954 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2955 PAD_SETSV(padop->op_padix, sv);
2958 padop->op_next = (OP*)padop;
2959 padop->op_flags = (U8)flags;
2960 if (PL_opargs[type] & OA_RETSCALAR)
2962 if (PL_opargs[type] & OA_TARGET)
2963 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2964 return CHECKOP(type, padop);
2968 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2974 return newPADOP(type, flags, SvREFCNT_inc(gv));
2976 return newSVOP(type, flags, SvREFCNT_inc(gv));
2981 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2985 NewOp(1101, pvop, 1, PVOP);
2986 pvop->op_type = (OPCODE)type;
2987 pvop->op_ppaddr = PL_ppaddr[type];
2989 pvop->op_next = (OP*)pvop;
2990 pvop->op_flags = (U8)flags;
2991 if (PL_opargs[type] & OA_RETSCALAR)
2993 if (PL_opargs[type] & OA_TARGET)
2994 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2995 return CHECKOP(type, pvop);
2999 Perl_package(pTHX_ OP *o)
3004 save_hptr(&PL_curstash);
3005 save_item(PL_curstname);
3007 name = SvPV_const(cSVOPo->op_sv, len);
3008 PL_curstash = gv_stashpvn(name, len, TRUE);
3009 sv_setpvn(PL_curstname, name, len);
3012 PL_hints |= HINT_BLOCK_SCOPE;
3013 PL_copline = NOLINE;
3018 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3024 if (idop->op_type != OP_CONST)
3025 Perl_croak(aTHX_ "Module name must be constant");
3029 if (version != Nullop) {
3030 SV *vesv = ((SVOP*)version)->op_sv;
3032 if (arg == Nullop && !SvNIOKp(vesv)) {
3039 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3040 Perl_croak(aTHX_ "Version number must be constant number");
3042 /* Make copy of idop so we don't free it twice */
3043 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3045 /* Fake up a method call to VERSION */
3046 meth = newSVpvn_share("VERSION", 7, 0);
3047 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3048 append_elem(OP_LIST,
3049 prepend_elem(OP_LIST, pack, list(version)),
3050 newSVOP(OP_METHOD_NAMED, 0, meth)));
3054 /* Fake up an import/unimport */
3055 if (arg && arg->op_type == OP_STUB)
3056 imop = arg; /* no import on explicit () */
3057 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3058 imop = Nullop; /* use 5.0; */
3063 /* Make copy of idop so we don't free it twice */
3064 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3066 /* Fake up a method call to import/unimport */
3068 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3069 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3070 append_elem(OP_LIST,
3071 prepend_elem(OP_LIST, pack, list(arg)),
3072 newSVOP(OP_METHOD_NAMED, 0, meth)));
3075 /* Fake up the BEGIN {}, which does its thing immediately. */
3077 newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3080 append_elem(OP_LINESEQ,
3081 append_elem(OP_LINESEQ,
3082 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3083 newSTATEOP(0, Nullch, veop)),
3084 newSTATEOP(0, Nullch, imop) ));
3086 /* The "did you use incorrect case?" warning used to be here.
3087 * The problem is that on case-insensitive filesystems one
3088 * might get false positives for "use" (and "require"):
3089 * "use Strict" or "require CARP" will work. This causes
3090 * portability problems for the script: in case-strict
3091 * filesystems the script will stop working.
3093 * The "incorrect case" warning checked whether "use Foo"
3094 * imported "Foo" to your namespace, but that is wrong, too:
3095 * there is no requirement nor promise in the language that
3096 * a Foo.pm should or would contain anything in package "Foo".
3098 * There is very little Configure-wise that can be done, either:
3099 * the case-sensitivity of the build filesystem of Perl does not
3100 * help in guessing the case-sensitivity of the runtime environment.
3103 PL_hints |= HINT_BLOCK_SCOPE;
3104 PL_copline = NOLINE;
3106 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3110 =head1 Embedding Functions
3112 =for apidoc load_module
3114 Loads the module whose name is pointed to by the string part of name.
3115 Note that the actual module name, not its filename, should be given.
3116 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3117 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3118 (or 0 for no flags). ver, if specified, provides version semantics
3119 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3120 arguments can be used to specify arguments to the module's import()
3121 method, similar to C<use Foo::Bar VERSION LIST>.
3126 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3129 va_start(args, ver);
3130 vload_module(flags, name, ver, &args);
3134 #ifdef PERL_IMPLICIT_CONTEXT
3136 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3140 va_start(args, ver);
3141 vload_module(flags, name, ver, &args);
3147 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3149 OP *modname, *veop, *imop;
3151 modname = newSVOP(OP_CONST, 0, name);
3152 modname->op_private |= OPpCONST_BARE;
3154 veop = newSVOP(OP_CONST, 0, ver);
3158 if (flags & PERL_LOADMOD_NOIMPORT) {
3159 imop = sawparens(newNULLLIST());
3161 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3162 imop = va_arg(*args, OP*);
3167 sv = va_arg(*args, SV*);
3169 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3170 sv = va_arg(*args, SV*);
3174 const line_t ocopline = PL_copline;
3175 COP * const ocurcop = PL_curcop;
3176 const int oexpect = PL_expect;
3178 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3179 veop, modname, imop);
3180 PL_expect = oexpect;
3181 PL_copline = ocopline;
3182 PL_curcop = ocurcop;
3187 Perl_dofile(pTHX_ OP *term)
3192 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3193 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3194 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3196 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3197 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3198 append_elem(OP_LIST, term,
3199 scalar(newUNOP(OP_RV2CV, 0,
3204 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3210 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3212 return newBINOP(OP_LSLICE, flags,
3213 list(force_list(subscript)),
3214 list(force_list(listval)) );
3218 S_is_list_assignment(pTHX_ register const OP *o)
3223 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3224 o = cUNOPo->op_first;
3226 if (o->op_type == OP_COND_EXPR) {
3227 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3228 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3233 yyerror("Assignment to both a list and a scalar");
3237 if (o->op_type == OP_LIST &&
3238 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3239 o->op_private & OPpLVAL_INTRO)
3242 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3243 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3244 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3247 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3250 if (o->op_type == OP_RV2SV)
3257 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3262 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3263 return newLOGOP(optype, 0,
3264 mod(scalar(left), optype),
3265 newUNOP(OP_SASSIGN, 0, scalar(right)));
3268 return newBINOP(optype, OPf_STACKED,
3269 mod(scalar(left), optype), scalar(right));
3273 if (is_list_assignment(left)) {
3277 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3278 left = mod(left, OP_AASSIGN);
3286 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3287 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3288 && right->op_type == OP_STUB
3289 && (left->op_private & OPpLVAL_INTRO))
3292 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3295 curop = list(force_list(left));
3296 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3297 o->op_private = (U8)(0 | (flags >> 8));
3299 /* PL_generation sorcery:
3300 * an assignment like ($a,$b) = ($c,$d) is easier than
3301 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3302 * To detect whether there are common vars, the global var
3303 * PL_generation is incremented for each assign op we compile.
3304 * Then, while compiling the assign op, we run through all the
3305 * variables on both sides of the assignment, setting a spare slot
3306 * in each of them to PL_generation. If any of them already have
3307 * that value, we know we've got commonality. We could use a
3308 * single bit marker, but then we'd have to make 2 passes, first
3309 * to clear the flag, then to test and set it. To find somewhere
3310 * to store these values, evil chicanery is done with SvCUR().
3313 if (!(left->op_private & OPpLVAL_INTRO)) {
3316 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3317 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3318 if (curop->op_type == OP_GV) {
3319 GV *gv = cGVOPx_gv(curop);
3320 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3322 SvCUR_set(gv, PL_generation);
3324 else if (curop->op_type == OP_PADSV ||
3325 curop->op_type == OP_PADAV ||
3326 curop->op_type == OP_PADHV ||
3327 curop->op_type == OP_PADANY)
3329 if (PAD_COMPNAME_GEN(curop->op_targ)
3330 == (STRLEN)PL_generation)
3332 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3335 else if (curop->op_type == OP_RV2CV)
3337 else if (curop->op_type == OP_RV2SV ||
3338 curop->op_type == OP_RV2AV ||
3339 curop->op_type == OP_RV2HV ||
3340 curop->op_type == OP_RV2GV) {
3341 if (lastop->op_type != OP_GV) /* funny deref? */
3344 else if (curop->op_type == OP_PUSHRE) {
3345 if (((PMOP*)curop)->op_pmreplroot) {
3347 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3348 ((PMOP*)curop)->op_pmreplroot));
3350 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3352 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3354 SvCUR_set(gv, PL_generation);
3363 o->op_private |= OPpASSIGN_COMMON;
3365 if (right && right->op_type == OP_SPLIT) {
3367 if ((tmpop = ((LISTOP*)right)->op_first) &&
3368 tmpop->op_type == OP_PUSHRE)
3370 PMOP *pm = (PMOP*)tmpop;
3371 if (left->op_type == OP_RV2AV &&
3372 !(left->op_private & OPpLVAL_INTRO) &&
3373 !(o->op_private & OPpASSIGN_COMMON) )
3375 tmpop = ((UNOP*)left)->op_first;
3376 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3378 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3379 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3381 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3382 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3384 pm->op_pmflags |= PMf_ONCE;
3385 tmpop = cUNOPo->op_first; /* to list (nulled) */
3386 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3387 tmpop->op_sibling = Nullop; /* don't free split */
3388 right->op_next = tmpop->op_next; /* fix starting loc */
3389 op_free(o); /* blow off assign */
3390 right->op_flags &= ~OPf_WANT;
3391 /* "I don't know and I don't care." */
3396 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3397 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3399 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3401 sv_setiv(sv, PL_modcount+1);
3409 right = newOP(OP_UNDEF, 0);
3410 if (right->op_type == OP_READLINE) {
3411 right->op_flags |= OPf_STACKED;
3412 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3415 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3416 o = newBINOP(OP_SASSIGN, flags,
3417 scalar(right), mod(scalar(left), OP_SASSIGN) );
3429 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3432 const U32 seq = intro_my();
3435 NewOp(1101, cop, 1, COP);
3436 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3437 cop->op_type = OP_DBSTATE;
3438 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3441 cop->op_type = OP_NEXTSTATE;
3442 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3444 cop->op_flags = (U8)flags;
3445 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3447 cop->op_private |= NATIVE_HINTS;
3449 PL_compiling.op_private = cop->op_private;
3450 cop->op_next = (OP*)cop;
3453 cop->cop_label = label;
3454 PL_hints |= HINT_BLOCK_SCOPE;
3457 cop->cop_arybase = PL_curcop->cop_arybase;
3458 if (specialWARN(PL_curcop->cop_warnings))
3459 cop->cop_warnings = PL_curcop->cop_warnings ;
3461 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3462 if (specialCopIO(PL_curcop->cop_io))
3463 cop->cop_io = PL_curcop->cop_io;
3465 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3468 if (PL_copline == NOLINE)
3469 CopLINE_set(cop, CopLINE(PL_curcop));
3471 CopLINE_set(cop, PL_copline);
3472 PL_copline = NOLINE;
3475 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3477 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3479 CopSTASH_set(cop, PL_curstash);
3481 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3482 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3483 if (svp && *svp != &PL_sv_undef ) {
3484 (void)SvIOK_on(*svp);
3485 SvIV_set(*svp, PTR2IV(cop));
3489 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3494 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3497 return new_logop(type, flags, &first, &other);
3501 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3506 OP *first = *firstp;
3507 OP *other = *otherp;
3509 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3510 return newBINOP(type, flags, scalar(first), scalar(other));
3512 scalarboolean(first);
3513 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3514 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3515 if (type == OP_AND || type == OP_OR) {
3521 first = *firstp = cUNOPo->op_first;
3523 first->op_next = o->op_next;
3524 cUNOPo->op_first = Nullop;
3528 if (first->op_type == OP_CONST) {
3529 if (first->op_private & OPpCONST_STRICT)
3530 no_bareword_allowed(first);
3531 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3532 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3533 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3534 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3535 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3538 if (other->op_type == OP_CONST)
3539 other->op_private |= OPpCONST_SHORTCIRCUIT;
3543 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3544 const OP *o2 = other;
3545 if ( ! (o2->op_type == OP_LIST
3546 && (( o2 = cUNOPx(o2)->op_first))
3547 && o2->op_type == OP_PUSHMARK
3548 && (( o2 = o2->op_sibling)) )
3551 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3552 || o2->op_type == OP_PADHV)
3553 && o2->op_private & OPpLVAL_INTRO
3554 && ckWARN(WARN_DEPRECATED))
3556 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3557 "Deprecated use of my() in false conditional");
3562 if (first->op_type == OP_CONST)
3563 first->op_private |= OPpCONST_SHORTCIRCUIT;
3567 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3568 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3570 const OP *k1 = ((UNOP*)first)->op_first;
3571 const OP *k2 = k1->op_sibling;
3573 switch (first->op_type)
3576 if (k2 && k2->op_type == OP_READLINE
3577 && (k2->op_flags & OPf_STACKED)
3578 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3580 warnop = k2->op_type;
3585 if (k1->op_type == OP_READDIR
3586 || k1->op_type == OP_GLOB
3587 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3588 || k1->op_type == OP_EACH)
3590 warnop = ((k1->op_type == OP_NULL)
3591 ? (OPCODE)k1->op_targ : k1->op_type);
3596 const line_t oldline = CopLINE(PL_curcop);
3597 CopLINE_set(PL_curcop, PL_copline);
3598 Perl_warner(aTHX_ packWARN(WARN_MISC),
3599 "Value of %s%s can be \"0\"; test with defined()",
3601 ((warnop == OP_READLINE || warnop == OP_GLOB)
3602 ? " construct" : "() operator"));
3603 CopLINE_set(PL_curcop, oldline);
3610 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3611 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3613 NewOp(1101, logop, 1, LOGOP);
3615 logop->op_type = (OPCODE)type;
3616 logop->op_ppaddr = PL_ppaddr[type];
3617 logop->op_first = first;
3618 logop->op_flags = flags | OPf_KIDS;
3619 logop->op_other = LINKLIST(other);
3620 logop->op_private = (U8)(1 | (flags >> 8));
3622 /* establish postfix order */
3623 logop->op_next = LINKLIST(first);
3624 first->op_next = (OP*)logop;
3625 first->op_sibling = other;
3627 CHECKOP(type,logop);
3629 o = newUNOP(OP_NULL, 0, (OP*)logop);
3636 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3644 return newLOGOP(OP_AND, 0, first, trueop);
3646 return newLOGOP(OP_OR, 0, first, falseop);
3648 scalarboolean(first);
3649 if (first->op_type == OP_CONST) {
3650 if (first->op_private & OPpCONST_BARE &&
3651 first->op_private & OPpCONST_STRICT) {
3652 no_bareword_allowed(first);
3654 if (SvTRUE(((SVOP*)first)->op_sv)) {
3665 NewOp(1101, logop, 1, LOGOP);
3666 logop->op_type = OP_COND_EXPR;
3667 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3668 logop->op_first = first;
3669 logop->op_flags = flags | OPf_KIDS;
3670 logop->op_private = (U8)(1 | (flags >> 8));
3671 logop->op_other = LINKLIST(trueop);
3672 logop->op_next = LINKLIST(falseop);
3674 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3677 /* establish postfix order */
3678 start = LINKLIST(first);
3679 first->op_next = (OP*)logop;
3681 first->op_sibling = trueop;
3682 trueop->op_sibling = falseop;
3683 o = newUNOP(OP_NULL, 0, (OP*)logop);
3685 trueop->op_next = falseop->op_next = o;
3692 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3701 NewOp(1101, range, 1, LOGOP);
3703 range->op_type = OP_RANGE;
3704 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3705 range->op_first = left;
3706 range->op_flags = OPf_KIDS;
3707 leftstart = LINKLIST(left);
3708 range->op_other = LINKLIST(right);
3709 range->op_private = (U8)(1 | (flags >> 8));
3711 left->op_sibling = right;
3713 range->op_next = (OP*)range;
3714 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3715 flop = newUNOP(OP_FLOP, 0, flip);
3716 o = newUNOP(OP_NULL, 0, flop);
3718 range->op_next = leftstart;
3720 left->op_next = flip;
3721 right->op_next = flop;
3723 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3724 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3725 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3726 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3728 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3729 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3732 if (!flip->op_private || !flop->op_private)
3733 linklist(o); /* blow off optimizer unless constant */
3739 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3743 const bool once = block && block->op_flags & OPf_SPECIAL &&
3744 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3748 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3749 return block; /* do {} while 0 does once */
3750 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3751 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3752 expr = newUNOP(OP_DEFINED, 0,
3753 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3754 } else if (expr->op_flags & OPf_KIDS) {
3755 const OP *k1 = ((UNOP*)expr)->op_first;
3756 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3757 switch (expr->op_type) {
3759 if (k2 && k2->op_type == OP_READLINE
3760 && (k2->op_flags & OPf_STACKED)
3761 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3762 expr = newUNOP(OP_DEFINED, 0, expr);
3766 if (k1->op_type == OP_READDIR
3767 || k1->op_type == OP_GLOB
3768 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3769 || k1->op_type == OP_EACH)
3770 expr = newUNOP(OP_DEFINED, 0, expr);
3776 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3777 * op, in listop. This is wrong. [perl #27024] */
3779 block = newOP(OP_NULL, 0);
3780 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3781 o = new_logop(OP_AND, 0, &expr, &listop);
3784 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3786 if (once && o != listop)
3787 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3790 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3792 o->op_flags |= flags;
3794 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3799 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3800 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3810 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3811 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3812 expr = newUNOP(OP_DEFINED, 0,
3813 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3814 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3815 const OP *k1 = ((UNOP*)expr)->op_first;
3816 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3817 switch (expr->op_type) {
3819 if (k2 && k2->op_type == OP_READLINE
3820 && (k2->op_flags & OPf_STACKED)
3821 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3822 expr = newUNOP(OP_DEFINED, 0, expr);
3826 if (k1->op_type == OP_READDIR
3827 || k1->op_type == OP_GLOB
3828 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3829 || k1->op_type == OP_EACH)
3830 expr = newUNOP(OP_DEFINED, 0, expr);
3836 block = newOP(OP_NULL, 0);
3837 else if (cont || has_my) {
3838 block = scope(block);
3842 next = LINKLIST(cont);
3845 OP *unstack = newOP(OP_UNSTACK, 0);
3848 cont = append_elem(OP_LINESEQ, cont, unstack);
3851 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3852 redo = LINKLIST(listop);
3855 PL_copline = (line_t)whileline;
3857 o = new_logop(OP_AND, 0, &expr, &listop);
3858 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3859 op_free(expr); /* oops, it's a while (0) */
3861 return Nullop; /* listop already freed by new_logop */
3864 ((LISTOP*)listop)->op_last->op_next =
3865 (o == listop ? redo : LINKLIST(o));
3871 NewOp(1101,loop,1,LOOP);
3872 loop->op_type = OP_ENTERLOOP;
3873 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3874 loop->op_private = 0;
3875 loop->op_next = (OP*)loop;
3878 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3880 loop->op_redoop = redo;
3881 loop->op_lastop = o;
3882 o->op_private |= loopflags;
3885 loop->op_nextop = next;
3887 loop->op_nextop = o;
3889 o->op_flags |= flags;
3890 o->op_private |= (flags >> 8);
3895 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3900 PADOFFSET padoff = 0;
3905 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3906 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3907 sv->op_type = OP_RV2GV;
3908 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3910 else if (sv->op_type == OP_PADSV) { /* private variable */
3911 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3912 padoff = sv->op_targ;
3917 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3918 padoff = sv->op_targ;
3920 iterflags |= OPf_SPECIAL;
3925 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3928 const I32 offset = pad_findmy("$_");
3929 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3930 sv = newGVOP(OP_GV, 0, PL_defgv);
3936 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3937 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3938 iterflags |= OPf_STACKED;
3940 else if (expr->op_type == OP_NULL &&
3941 (expr->op_flags & OPf_KIDS) &&
3942 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3944 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3945 * set the STACKED flag to indicate that these values are to be
3946 * treated as min/max values by 'pp_iterinit'.
3948 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3949 LOGOP* range = (LOGOP*) flip->op_first;
3950 OP* const left = range->op_first;
3951 OP* const right = left->op_sibling;
3954 range->op_flags &= ~OPf_KIDS;
3955 range->op_first = Nullop;
3957 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3958 listop->op_first->op_next = range->op_next;
3959 left->op_next = range->op_other;
3960 right->op_next = (OP*)listop;
3961 listop->op_next = listop->op_first;
3964 expr = (OP*)(listop);
3966 iterflags |= OPf_STACKED;
3969 expr = mod(force_list(expr), OP_GREPSTART);
3972 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3973 append_elem(OP_LIST, expr, scalar(sv))));
3974 assert(!loop->op_next);
3975 /* for my $x () sets OPpLVAL_INTRO;
3976 * for our $x () sets OPpOUR_INTRO */
3977 loop->op_private = (U8)iterpflags;
3978 #ifdef PL_OP_SLAB_ALLOC
3981 NewOp(1234,tmp,1,LOOP);
3982 Copy(loop,tmp,1,LISTOP);
3987 Renew(loop, 1, LOOP);
3989 loop->op_targ = padoff;
3990 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
3991 PL_copline = forline;
3992 return newSTATEOP(0, label, wop);
3996 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4000 if (type != OP_GOTO || label->op_type == OP_CONST) {
4001 /* "last()" means "last" */
4002 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4003 o = newOP(type, OPf_SPECIAL);
4005 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4006 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4012 /* Check whether it's going to be a goto &function */
4013 if (label->op_type == OP_ENTERSUB
4014 && !(label->op_flags & OPf_STACKED))
4015 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4016 o = newUNOP(type, OPf_STACKED, label);
4018 PL_hints |= HINT_BLOCK_SCOPE;
4023 =for apidoc cv_undef
4025 Clear out all the active components of a CV. This can happen either
4026 by an explicit C<undef &foo>, or by the reference count going to zero.
4027 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4028 children can still follow the full lexical scope chain.
4034 Perl_cv_undef(pTHX_ CV *cv)
4038 if (CvFILE(cv) && !CvXSUB(cv)) {
4039 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4040 Safefree(CvFILE(cv));
4045 if (!CvXSUB(cv) && CvROOT(cv)) {
4047 Perl_croak(aTHX_ "Can't undef active subroutine");
4050 PAD_SAVE_SETNULLPAD();
4052 op_free(CvROOT(cv));
4053 CvROOT(cv) = Nullop;
4054 CvSTART(cv) = Nullop;
4057 SvPOK_off((SV*)cv); /* forget prototype */
4062 /* remove CvOUTSIDE unless this is an undef rather than a free */
4063 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4064 if (!CvWEAKOUTSIDE(cv))
4065 SvREFCNT_dec(CvOUTSIDE(cv));
4066 CvOUTSIDE(cv) = Nullcv;
4069 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4075 /* delete all flags except WEAKOUTSIDE */
4076 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4080 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4082 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4083 SV* msg = sv_newmortal();
4087 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4088 sv_setpv(msg, "Prototype mismatch:");
4090 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4092 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4094 Perl_sv_catpv(aTHX_ msg, ": none");
4095 sv_catpv(msg, " vs ");
4097 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4099 sv_catpv(msg, "none");
4100 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4104 static void const_sv_xsub(pTHX_ CV* cv);
4108 =head1 Optree Manipulation Functions
4110 =for apidoc cv_const_sv
4112 If C<cv> is a constant sub eligible for inlining. returns the constant
4113 value returned by the sub. Otherwise, returns NULL.
4115 Constant subs can be created with C<newCONSTSUB> or as described in
4116 L<perlsub/"Constant Functions">.
4121 Perl_cv_const_sv(pTHX_ CV *cv)
4123 if (!cv || !CvCONST(cv))
4125 return (SV*)CvXSUBANY(cv).any_ptr;
4128 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4129 * Can be called in 3 ways:
4132 * look for a single OP_CONST with attached value: return the value
4134 * cv && CvCLONE(cv) && !CvCONST(cv)
4136 * examine the clone prototype, and if contains only a single
4137 * OP_CONST referencing a pad const, or a single PADSV referencing
4138 * an outer lexical, return a non-zero value to indicate the CV is
4139 * a candidate for "constizing" at clone time
4143 * We have just cloned an anon prototype that was marked as a const
4144 * candidiate. Try to grab the current value, and in the case of
4145 * PADSV, ignore it if it has multiple references. Return the value.
4149 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4156 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4157 o = cLISTOPo->op_first->op_sibling;
4159 for (; o; o = o->op_next) {
4160 OPCODE type = o->op_type;
4162 if (sv && o->op_next == o)
4164 if (o->op_next != o) {
4165 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4167 if (type == OP_DBSTATE)
4170 if (type == OP_LEAVESUB || type == OP_RETURN)
4174 if (type == OP_CONST && cSVOPo->op_sv)
4176 else if (cv && type == OP_CONST) {
4177 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4181 else if (cv && type == OP_PADSV) {
4182 if (CvCONST(cv)) { /* newly cloned anon */
4183 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4184 /* the candidate should have 1 ref from this pad and 1 ref
4185 * from the parent */
4186 if (!sv || SvREFCNT(sv) != 2)
4193 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4194 sv = &PL_sv_undef; /* an arbitrary non-null value */
4205 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4216 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4220 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4222 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4226 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4237 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4240 assert(proto->op_type == OP_CONST);
4241 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4246 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4247 SV *sv = sv_newmortal();
4248 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4249 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4250 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4251 aname = SvPVX_const(sv);
4256 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4257 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4258 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4259 : gv_fetchpv(aname ? aname
4260 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4261 gv_fetch_flags, SVt_PVCV);
4270 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4271 maximum a prototype before. */
4272 if (SvTYPE(gv) > SVt_NULL) {
4273 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4274 && ckWARN_d(WARN_PROTOTYPE))
4276 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4278 cv_ckproto((CV*)gv, NULL, ps);
4281 sv_setpvn((SV*)gv, ps, ps_len);
4283 sv_setiv((SV*)gv, -1);
4284 SvREFCNT_dec(PL_compcv);
4285 cv = PL_compcv = NULL;
4286 PL_sub_generation++;
4290 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4292 #ifdef GV_UNIQUE_CHECK
4293 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4294 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4298 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4301 const_sv = op_const_sv(block, Nullcv);
4304 const bool exists = CvROOT(cv) || CvXSUB(cv);
4306 #ifdef GV_UNIQUE_CHECK
4307 if (exists && GvUNIQUE(gv)) {
4308 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4312 /* if the subroutine doesn't exist and wasn't pre-declared
4313 * with a prototype, assume it will be AUTOLOADed,
4314 * skipping the prototype check
4316 if (exists || SvPOK(cv))
4317 cv_ckproto(cv, gv, ps);
4318 /* already defined (or promised)? */
4319 if (exists || GvASSUMECV(gv)) {
4320 if (!block && !attrs) {
4321 if (CvFLAGS(PL_compcv)) {
4322 /* might have had built-in attrs applied */
4323 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4325 /* just a "sub foo;" when &foo is already defined */
4326 SAVEFREESV(PL_compcv);
4329 /* ahem, death to those who redefine active sort subs */
4330 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4331 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4333 if (ckWARN(WARN_REDEFINE)
4335 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4337 const line_t oldline = CopLINE(PL_curcop);
4338 if (PL_copline != NOLINE)
4339 CopLINE_set(PL_curcop, PL_copline);
4340 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4341 CvCONST(cv) ? "Constant subroutine %s redefined"
4342 : "Subroutine %s redefined", name);
4343 CopLINE_set(PL_curcop, oldline);
4351 (void)SvREFCNT_inc(const_sv);
4353 assert(!CvROOT(cv) && !CvCONST(cv));
4354 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4355 CvXSUBANY(cv).any_ptr = const_sv;
4356 CvXSUB(cv) = const_sv_xsub;
4361 cv = newCONSTSUB(NULL, name, const_sv);
4364 SvREFCNT_dec(PL_compcv);
4366 PL_sub_generation++;
4373 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4374 * before we clobber PL_compcv.
4378 /* Might have had built-in attributes applied -- propagate them. */
4379 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4380 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4381 stash = GvSTASH(CvGV(cv));
4382 else if (CvSTASH(cv))
4383 stash = CvSTASH(cv);
4385 stash = PL_curstash;
4388 /* possibly about to re-define existing subr -- ignore old cv */
4389 rcv = (SV*)PL_compcv;
4390 if (name && GvSTASH(gv))
4391 stash = GvSTASH(gv);
4393 stash = PL_curstash;
4395 apply_attrs(stash, rcv, attrs, FALSE);
4397 if (cv) { /* must reuse cv if autoloaded */
4399 /* got here with just attrs -- work done, so bug out */
4400 SAVEFREESV(PL_compcv);
4403 /* transfer PL_compcv to cv */
4405 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4406 if (!CvWEAKOUTSIDE(cv))
4407 SvREFCNT_dec(CvOUTSIDE(cv));
4408 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4409 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4410 CvOUTSIDE(PL_compcv) = 0;
4411 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4412 CvPADLIST(PL_compcv) = 0;
4413 /* inner references to PL_compcv must be fixed up ... */
4414 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4415 /* ... before we throw it away */
4416 SvREFCNT_dec(PL_compcv);
4418 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4419 ++PL_sub_generation;
4426 PL_sub_generation++;
4430 CvFILE_set_from_cop(cv, PL_curcop);
4431 CvSTASH(cv) = PL_curstash;
4434 sv_setpvn((SV*)cv, ps, ps_len);
4436 if (PL_error_count) {
4440 const char *s = strrchr(name, ':');
4442 if (strEQ(s, "BEGIN")) {
4443 const char not_safe[] =
4444 "BEGIN not safe after errors--compilation aborted";
4445 if (PL_in_eval & EVAL_KEEPERR)
4446 Perl_croak(aTHX_ not_safe);
4448 /* force display of errors found but not reported */
4449 sv_catpv(ERRSV, not_safe);
4450 Perl_croak(aTHX_ "%"SVf, ERRSV);
4459 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4460 mod(scalarseq(block), OP_LEAVESUBLV));
4463 /* This makes sub {}; work as expected. */
4464 if (block->op_type == OP_STUB) {
4466 block = newSTATEOP(0, Nullch, 0);
4468 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4470 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4471 OpREFCNT_set(CvROOT(cv), 1);
4472 CvSTART(cv) = LINKLIST(CvROOT(cv));
4473 CvROOT(cv)->op_next = 0;
4474 CALL_PEEP(CvSTART(cv));
4476 /* now that optimizer has done its work, adjust pad values */
4478 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4481 assert(!CvCONST(cv));
4482 if (ps && !*ps && op_const_sv(block, cv))
4486 if (name || aname) {
4488 const char *tname = (name ? name : aname);
4490 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4491 SV *sv = NEWSV(0,0);
4492 SV *tmpstr = sv_newmortal();
4493 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4497 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4499 (long)PL_subline, (long)CopLINE(PL_curcop));
4500 gv_efullname3(tmpstr, gv, Nullch);
4501 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4502 hv = GvHVn(db_postponed);
4503 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
4504 && (pcv = GvCV(db_postponed)))
4510 call_sv((SV*)pcv, G_DISCARD);
4514 if ((s = strrchr(tname,':')))
4519 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4522 if (strEQ(s, "BEGIN") && !PL_error_count) {
4523 const I32 oldscope = PL_scopestack_ix;
4525 SAVECOPFILE(&PL_compiling);
4526 SAVECOPLINE(&PL_compiling);
4529 PL_beginav = newAV();
4530 DEBUG_x( dump_sub(gv) );
4531 av_push(PL_beginav, (SV*)cv);
4532 GvCV(gv) = 0; /* cv has been hijacked */
4533 call_list(oldscope, PL_beginav);
4535 PL_curcop = &PL_compiling;
4536 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4539 else if (strEQ(s, "END") && !PL_error_count) {
4542 DEBUG_x( dump_sub(gv) );
4543 av_unshift(PL_endav, 1);
4544 av_store(PL_endav, 0, (SV*)cv);
4545 GvCV(gv) = 0; /* cv has been hijacked */
4547 else if (strEQ(s, "CHECK") && !PL_error_count) {
4549 PL_checkav = newAV();
4550 DEBUG_x( dump_sub(gv) );
4551 if (PL_main_start && ckWARN(WARN_VOID))
4552 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4553 av_unshift(PL_checkav, 1);
4554 av_store(PL_checkav, 0, (SV*)cv);
4555 GvCV(gv) = 0; /* cv has been hijacked */
4557 else if (strEQ(s, "INIT") && !PL_error_count) {
4559 PL_initav = 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 INIT block");
4563 av_push(PL_initav, (SV*)cv);
4564 GvCV(gv) = 0; /* cv has been hijacked */
4569 PL_copline = NOLINE;
4574 /* XXX unsafe for threads if eval_owner isn't held */
4576 =for apidoc newCONSTSUB
4578 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4579 eligible for inlining at compile-time.
4585 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4592 SAVECOPLINE(PL_curcop);
4593 CopLINE_set(PL_curcop, PL_copline);
4596 PL_hints &= ~HINT_BLOCK_SCOPE;
4599 SAVESPTR(PL_curstash);
4600 SAVECOPSTASH(PL_curcop);
4601 PL_curstash = stash;
4602 CopSTASH_set(PL_curcop,stash);
4605 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4606 CvXSUBANY(cv).any_ptr = sv;
4608 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4611 CopSTASH_free(PL_curcop);
4619 =for apidoc U||newXS
4621 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4627 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4629 GV *gv = gv_fetchpv(name ? name :
4630 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4631 GV_ADDMULTI, SVt_PVCV);
4635 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4637 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4639 /* just a cached method */
4643 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4644 /* already defined (or promised) */
4645 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4646 if (ckWARN(WARN_REDEFINE)) {
4647 GV * const gvcv = CvGV(cv);
4649 HV * const stash = GvSTASH(gvcv);
4651 const char *name = HvNAME_get(stash);
4652 if ( strEQ(name,"autouse") ) {
4653 const line_t oldline = CopLINE(PL_curcop);
4654 if (PL_copline != NOLINE)
4655 CopLINE_set(PL_curcop, PL_copline);
4656 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4657 CvCONST(cv) ? "Constant subroutine %s redefined"
4658 : "Subroutine %s redefined"
4660 CopLINE_set(PL_curcop, oldline);
4670 if (cv) /* must reuse cv if autoloaded */
4673 cv = (CV*)NEWSV(1105,0);
4674 sv_upgrade((SV *)cv, SVt_PVCV);
4678 PL_sub_generation++;
4682 (void)gv_fetchfile(filename);
4683 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4684 an external constant string */
4685 CvXSUB(cv) = subaddr;
4688 const char *s = strrchr(name,':');
4694 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4697 if (strEQ(s, "BEGIN")) {
4699 PL_beginav = newAV();
4700 av_push(PL_beginav, (SV*)cv);
4701 GvCV(gv) = 0; /* cv has been hijacked */
4703 else if (strEQ(s, "END")) {
4706 av_unshift(PL_endav, 1);
4707 av_store(PL_endav, 0, (SV*)cv);
4708 GvCV(gv) = 0; /* cv has been hijacked */
4710 else if (strEQ(s, "CHECK")) {
4712 PL_checkav = newAV();
4713 if (PL_main_start && ckWARN(WARN_VOID))
4714 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4715 av_unshift(PL_checkav, 1);
4716 av_store(PL_checkav, 0, (SV*)cv);
4717 GvCV(gv) = 0; /* cv has been hijacked */
4719 else if (strEQ(s, "INIT")) {
4721 PL_initav = newAV();
4722 if (PL_main_start && ckWARN(WARN_VOID))
4723 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4724 av_push(PL_initav, (SV*)cv);
4725 GvCV(gv) = 0; /* cv has been hijacked */
4736 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4742 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4744 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4746 #ifdef GV_UNIQUE_CHECK
4748 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4752 if ((cv = GvFORM(gv))) {
4753 if (ckWARN(WARN_REDEFINE)) {
4754 const line_t oldline = CopLINE(PL_curcop);
4755 if (PL_copline != NOLINE)
4756 CopLINE_set(PL_curcop, PL_copline);
4757 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4758 o ? "Format %"SVf" redefined"
4759 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4760 CopLINE_set(PL_curcop, oldline);
4767 CvFILE_set_from_cop(cv, PL_curcop);
4770 pad_tidy(padtidy_FORMAT);
4771 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4772 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4773 OpREFCNT_set(CvROOT(cv), 1);
4774 CvSTART(cv) = LINKLIST(CvROOT(cv));
4775 CvROOT(cv)->op_next = 0;
4776 CALL_PEEP(CvSTART(cv));
4778 PL_copline = NOLINE;
4783 Perl_newANONLIST(pTHX_ OP *o)
4785 return newUNOP(OP_REFGEN, 0,
4786 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4790 Perl_newANONHASH(pTHX_ OP *o)
4792 return newUNOP(OP_REFGEN, 0,
4793 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4797 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4799 return newANONATTRSUB(floor, proto, Nullop, block);
4803 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4805 return newUNOP(OP_REFGEN, 0,
4806 newSVOP(OP_ANONCODE, 0,
4807 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4811 Perl_oopsAV(pTHX_ OP *o)
4814 switch (o->op_type) {
4816 o->op_type = OP_PADAV;
4817 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4818 return ref(o, OP_RV2AV);
4821 o->op_type = OP_RV2AV;
4822 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4827 if (ckWARN_d(WARN_INTERNAL))
4828 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4835 Perl_oopsHV(pTHX_ OP *o)
4838 switch (o->op_type) {
4841 o->op_type = OP_PADHV;
4842 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4843 return ref(o, OP_RV2HV);
4847 o->op_type = OP_RV2HV;
4848 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4853 if (ckWARN_d(WARN_INTERNAL))
4854 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4861 Perl_newAVREF(pTHX_ OP *o)
4864 if (o->op_type == OP_PADANY) {
4865 o->op_type = OP_PADAV;
4866 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4869 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4870 && ckWARN(WARN_DEPRECATED)) {
4871 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4872 "Using an array as a reference is deprecated");
4874 return newUNOP(OP_RV2AV, 0, scalar(o));
4878 Perl_newGVREF(pTHX_ I32 type, OP *o)
4880 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4881 return newUNOP(OP_NULL, 0, o);
4882 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4886 Perl_newHVREF(pTHX_ OP *o)
4889 if (o->op_type == OP_PADANY) {
4890 o->op_type = OP_PADHV;
4891 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4894 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4895 && ckWARN(WARN_DEPRECATED)) {
4896 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4897 "Using a hash as a reference is deprecated");
4899 return newUNOP(OP_RV2HV, 0, scalar(o));
4903 Perl_oopsCV(pTHX_ OP *o)
4905 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4908 NORETURN_FUNCTION_END;
4912 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4914 return newUNOP(OP_RV2CV, flags, scalar(o));
4918 Perl_newSVREF(pTHX_ OP *o)
4921 if (o->op_type == OP_PADANY) {
4922 o->op_type = OP_PADSV;
4923 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4926 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4927 o->op_flags |= OPpDONE_SVREF;
4930 return newUNOP(OP_RV2SV, 0, scalar(o));
4933 /* Check routines. See the comments at the top of this file for details
4934 * on when these are called */
4937 Perl_ck_anoncode(pTHX_ OP *o)
4939 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4940 cSVOPo->op_sv = Nullsv;
4945 Perl_ck_bitop(pTHX_ OP *o)
4947 #define OP_IS_NUMCOMPARE(op) \
4948 ((op) == OP_LT || (op) == OP_I_LT || \
4949 (op) == OP_GT || (op) == OP_I_GT || \
4950 (op) == OP_LE || (op) == OP_I_LE || \
4951 (op) == OP_GE || (op) == OP_I_GE || \
4952 (op) == OP_EQ || (op) == OP_I_EQ || \
4953 (op) == OP_NE || (op) == OP_I_NE || \
4954 (op) == OP_NCMP || (op) == OP_I_NCMP)
4955 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4956 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4957 && (o->op_type == OP_BIT_OR
4958 || o->op_type == OP_BIT_AND
4959 || o->op_type == OP_BIT_XOR))
4961 const OP * const left = cBINOPo->op_first;
4962 const OP * const right = left->op_sibling;
4963 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4964 (left->op_flags & OPf_PARENS) == 0) ||
4965 (OP_IS_NUMCOMPARE(right->op_type) &&
4966 (right->op_flags & OPf_PARENS) == 0))
4967 if (ckWARN(WARN_PRECEDENCE))
4968 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4969 "Possible precedence problem on bitwise %c operator",
4970 o->op_type == OP_BIT_OR ? '|'
4971 : o->op_type == OP_BIT_AND ? '&' : '^'
4978 Perl_ck_concat(pTHX_ OP *o)
4980 const OP *kid = cUNOPo->op_first;
4981 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4982 !(kUNOP->op_first->op_flags & OPf_MOD))
4983 o->op_flags |= OPf_STACKED;
4988 Perl_ck_spair(pTHX_ OP *o)
4991 if (o->op_flags & OPf_KIDS) {
4994 const OPCODE type = o->op_type;
4995 o = modkids(ck_fun(o), type);
4996 kid = cUNOPo->op_first;
4997 newop = kUNOP->op_first->op_sibling;
4999 (newop->op_sibling ||
5000 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5001 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5002 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5006 op_free(kUNOP->op_first);
5007 kUNOP->op_first = newop;
5009 o->op_ppaddr = PL_ppaddr[++o->op_type];
5014 Perl_ck_delete(pTHX_ OP *o)
5018 if (o->op_flags & OPf_KIDS) {
5019 OP *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 *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 *table = GvHV(PL_hintgv);
5116 SV **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 *kid = cUNOPo->op_first;
5146 if (kid->op_type == OP_ENTERSUB) {
5147 (void) ref(kid, o->op_type);
5148 if (kid->op_type != OP_RV2CV && !PL_error_count)
5149 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5151 o->op_private |= OPpEXISTS_SUB;
5153 else if (kid->op_type == OP_AELEM)
5154 o->op_flags |= OPf_SPECIAL;
5155 else if (kid->op_type != OP_HELEM)
5156 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5164 Perl_ck_rvconst(pTHX_ register OP *o)
5167 SVOP *kid = (SVOP*)cUNOPo->op_first;
5169 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5170 if (kid->op_type == OP_CONST) {
5173 SV * const kidsv = kid->op_sv;
5175 /* Is it a constant from cv_const_sv()? */
5176 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5177 SV *rsv = SvRV(kidsv);
5178 const int svtype = SvTYPE(rsv);
5179 const char *badtype = Nullch;
5181 switch (o->op_type) {
5183 if (svtype > SVt_PVMG)
5184 badtype = "a SCALAR";
5187 if (svtype != SVt_PVAV)
5188 badtype = "an ARRAY";
5191 if (svtype != SVt_PVHV)
5195 if (svtype != SVt_PVCV)
5200 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5203 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5204 const char *badthing = Nullch;
5205 switch (o->op_type) {
5207 badthing = "a SCALAR";
5210 badthing = "an ARRAY";
5213 badthing = "a HASH";
5218 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5222 * This is a little tricky. We only want to add the symbol if we
5223 * didn't add it in the lexer. Otherwise we get duplicate strict
5224 * warnings. But if we didn't add it in the lexer, we must at
5225 * least pretend like we wanted to add it even if it existed before,
5226 * or we get possible typo warnings. OPpCONST_ENTERED says
5227 * whether the lexer already added THIS instance of this symbol.
5229 iscv = (o->op_type == OP_RV2CV) * 2;
5231 gv = gv_fetchsv(kidsv,
5232 iscv | !(kid->op_private & OPpCONST_ENTERED),
5235 : o->op_type == OP_RV2SV
5237 : o->op_type == OP_RV2AV
5239 : o->op_type == OP_RV2HV
5242 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5244 kid->op_type = OP_GV;
5245 SvREFCNT_dec(kid->op_sv);
5247 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5248 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5249 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5251 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5253 kid->op_sv = SvREFCNT_inc(gv);
5255 kid->op_private = 0;
5256 kid->op_ppaddr = PL_ppaddr[OP_GV];
5263 Perl_ck_ftst(pTHX_ OP *o)
5266 const I32 type = o->op_type;
5268 if (o->op_flags & OPf_REF) {
5271 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5272 SVOP *kid = (SVOP*)cUNOPo->op_first;
5274 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5275 OP *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 *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 *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 *newop = newUNOP(OP_NULL, 0, kid);
5396 kid->op_sibling = 0;
5398 newop->op_next = newop;
5400 kid->op_sibling = sibl;
5405 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5406 if (kid->op_type == OP_CONST &&
5407 (kid->op_private & OPpCONST_BARE))
5409 OP *newop = newGVOP(OP_GV, 0,
5410 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5411 if (!(o->op_private & 1) && /* if not unop */
5412 kid == cLISTOPo->op_last)
5413 cLISTOPo->op_last = newop;
5417 else if (kid->op_type == OP_READLINE) {
5418 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5419 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5422 I32 flags = OPf_SPECIAL;
5426 /* is this op a FH constructor? */
5427 if (is_handle_constructor(o,numargs)) {
5428 const char *name = Nullch;
5432 /* Set a flag to tell rv2gv to vivify
5433 * need to "prove" flag does not mean something
5434 * else already - NI-S 1999/05/07
5437 if (kid->op_type == OP_PADSV) {
5438 name = PAD_COMPNAME_PV(kid->op_targ);
5439 /* SvCUR of a pad namesv can't be trusted
5440 * (see PL_generation), so calc its length
5446 else if (kid->op_type == OP_RV2SV
5447 && kUNOP->op_first->op_type == OP_GV)
5449 GV *gv = cGVOPx_gv(kUNOP->op_first);
5451 len = GvNAMELEN(gv);
5453 else if (kid->op_type == OP_AELEM
5454 || kid->op_type == OP_HELEM)
5459 if ((op = ((BINOP*)kid)->op_first)) {
5460 SV *tmpstr = Nullsv;
5462 kid->op_type == OP_AELEM ?
5464 if (((op->op_type == OP_RV2AV) ||
5465 (op->op_type == OP_RV2HV)) &&
5466 (op = ((UNOP*)op)->op_first) &&
5467 (op->op_type == OP_GV)) {
5468 /* packagevar $a[] or $h{} */
5469 GV *gv = cGVOPx_gv(op);
5477 else if (op->op_type == OP_PADAV
5478 || op->op_type == OP_PADHV) {
5479 /* lexicalvar $a[] or $h{} */
5480 const char *padname =
5481 PAD_COMPNAME_PV(op->op_targ);
5491 name = SvPV_const(tmpstr, len);
5496 name = "__ANONIO__";
5503 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5504 namesv = PAD_SVl(targ);
5505 SvUPGRADE(namesv, SVt_PV);
5507 sv_setpvn(namesv, "$", 1);
5508 sv_catpvn(namesv, name, len);
5511 kid->op_sibling = 0;
5512 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5513 kid->op_targ = targ;
5514 kid->op_private |= priv;
5516 kid->op_sibling = sibl;
5522 mod(scalar(kid), type);
5526 tokid = &kid->op_sibling;
5527 kid = kid->op_sibling;
5529 o->op_private |= numargs;
5531 return too_many_arguments(o,OP_DESC(o));
5534 else if (PL_opargs[type] & OA_DEFGV) {
5536 return newUNOP(type, 0, newDEFSVOP());
5540 while (oa & OA_OPTIONAL)
5542 if (oa && oa != OA_LIST)
5543 return too_few_arguments(o,OP_DESC(o));
5549 Perl_ck_glob(pTHX_ OP *o)
5555 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5556 append_elem(OP_GLOB, o, newDEFSVOP());
5558 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5559 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5561 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5564 #if !defined(PERL_EXTERNAL_GLOB)
5565 /* XXX this can be tightened up and made more failsafe. */
5566 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5569 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5570 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5571 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5572 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5573 GvCV(gv) = GvCV(glob_gv);
5574 (void)SvREFCNT_inc((SV*)GvCV(gv));
5575 GvIMPORTED_CV_on(gv);
5578 #endif /* PERL_EXTERNAL_GLOB */
5580 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5581 append_elem(OP_GLOB, o,
5582 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5583 o->op_type = OP_LIST;
5584 o->op_ppaddr = PL_ppaddr[OP_LIST];
5585 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5586 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5587 cLISTOPo->op_first->op_targ = 0;
5588 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5589 append_elem(OP_LIST, o,
5590 scalar(newUNOP(OP_RV2CV, 0,
5591 newGVOP(OP_GV, 0, gv)))));
5592 o = newUNOP(OP_NULL, 0, ck_subr(o));
5593 o->op_targ = OP_GLOB; /* hint at what it used to be */
5596 gv = newGVgen("main");
5598 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5604 Perl_ck_grep(pTHX_ OP *o)
5609 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5612 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5613 NewOp(1101, gwop, 1, LOGOP);
5615 if (o->op_flags & OPf_STACKED) {
5618 kid = cLISTOPo->op_first->op_sibling;
5619 if (!cUNOPx(kid)->op_next)
5620 Perl_croak(aTHX_ "panic: ck_grep");
5621 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5624 kid->op_next = (OP*)gwop;
5625 o->op_flags &= ~OPf_STACKED;
5627 kid = cLISTOPo->op_first->op_sibling;
5628 if (type == OP_MAPWHILE)
5635 kid = cLISTOPo->op_first->op_sibling;
5636 if (kid->op_type != OP_NULL)
5637 Perl_croak(aTHX_ "panic: ck_grep");
5638 kid = kUNOP->op_first;
5640 gwop->op_type = type;
5641 gwop->op_ppaddr = PL_ppaddr[type];
5642 gwop->op_first = listkids(o);
5643 gwop->op_flags |= OPf_KIDS;
5644 gwop->op_other = LINKLIST(kid);
5645 kid->op_next = (OP*)gwop;
5646 offset = pad_findmy("$_");
5647 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5648 o->op_private = gwop->op_private = 0;
5649 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5652 o->op_private = gwop->op_private = OPpGREP_LEX;
5653 gwop->op_targ = o->op_targ = offset;
5656 kid = cLISTOPo->op_first->op_sibling;
5657 if (!kid || !kid->op_sibling)
5658 return too_few_arguments(o,OP_DESC(o));
5659 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5660 mod(kid, OP_GREPSTART);
5666 Perl_ck_index(pTHX_ OP *o)
5668 if (o->op_flags & OPf_KIDS) {
5669 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5671 kid = kid->op_sibling; /* get past "big" */
5672 if (kid && kid->op_type == OP_CONST)
5673 fbm_compile(((SVOP*)kid)->op_sv, 0);
5679 Perl_ck_lengthconst(pTHX_ OP *o)
5681 /* XXX length optimization goes here */
5686 Perl_ck_lfun(pTHX_ OP *o)
5688 const OPCODE type = o->op_type;
5689 return modkids(ck_fun(o), type);
5693 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5695 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5696 switch (cUNOPo->op_first->op_type) {
5698 /* This is needed for
5699 if (defined %stash::)
5700 to work. Do not break Tk.
5702 break; /* Globals via GV can be undef */
5704 case OP_AASSIGN: /* Is this a good idea? */
5705 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5706 "defined(@array) is deprecated");
5707 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5708 "\t(Maybe you should just omit the defined()?)\n");
5711 /* This is needed for
5712 if (defined %stash::)
5713 to work. Do not break Tk.
5715 break; /* Globals via GV can be undef */
5717 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5718 "defined(%%hash) is deprecated");
5719 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5720 "\t(Maybe you should just omit the defined()?)\n");
5731 Perl_ck_rfun(pTHX_ OP *o)
5733 const OPCODE type = o->op_type;
5734 return refkids(ck_fun(o), type);
5738 Perl_ck_listiob(pTHX_ OP *o)
5742 kid = cLISTOPo->op_first;
5745 kid = cLISTOPo->op_first;
5747 if (kid->op_type == OP_PUSHMARK)
5748 kid = kid->op_sibling;
5749 if (kid && o->op_flags & OPf_STACKED)
5750 kid = kid->op_sibling;
5751 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5752 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5753 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5754 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5755 cLISTOPo->op_first->op_sibling = kid;
5756 cLISTOPo->op_last = kid;
5757 kid = kid->op_sibling;
5762 append_elem(o->op_type, o, newDEFSVOP());
5768 Perl_ck_sassign(pTHX_ OP *o)
5770 OP *kid = cLISTOPo->op_first;
5771 /* has a disposable target? */
5772 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5773 && !(kid->op_flags & OPf_STACKED)
5774 /* Cannot steal the second time! */
5775 && !(kid->op_private & OPpTARGET_MY))
5777 OP *kkid = kid->op_sibling;
5779 /* Can just relocate the target. */
5780 if (kkid && kkid->op_type == OP_PADSV
5781 && !(kkid->op_private & OPpLVAL_INTRO))
5783 kid->op_targ = kkid->op_targ;
5785 /* Now we do not need PADSV and SASSIGN. */
5786 kid->op_sibling = o->op_sibling; /* NULL */
5787 cLISTOPo->op_first = NULL;
5790 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5794 /* optimise C<my $x = undef> to C<my $x> */
5795 if (kid->op_type == OP_UNDEF) {
5796 OP *kkid = kid->op_sibling;
5797 if (kkid && kkid->op_type == OP_PADSV
5798 && (kkid->op_private & OPpLVAL_INTRO))
5800 cLISTOPo->op_first = NULL;
5801 kid->op_sibling = NULL;
5811 Perl_ck_match(pTHX_ OP *o)
5813 if (o->op_type != OP_QR) {
5814 const I32 offset = pad_findmy("$_");
5815 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5816 o->op_targ = offset;
5817 o->op_private |= OPpTARGET_MY;
5820 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5821 o->op_private |= OPpRUNTIME;
5826 Perl_ck_method(pTHX_ OP *o)
5828 OP *kid = cUNOPo->op_first;
5829 if (kid->op_type == OP_CONST) {
5830 SV* sv = kSVOP->op_sv;
5831 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5833 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5834 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5837 kSVOP->op_sv = Nullsv;
5839 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5848 Perl_ck_null(pTHX_ OP *o)
5854 Perl_ck_open(pTHX_ OP *o)
5856 HV *table = GvHV(PL_hintgv);
5860 svp = hv_fetch(table, "open_IN", 7, FALSE);
5862 mode = mode_from_discipline(*svp);
5863 if (mode & O_BINARY)
5864 o->op_private |= OPpOPEN_IN_RAW;
5865 else if (mode & O_TEXT)
5866 o->op_private |= OPpOPEN_IN_CRLF;
5869 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5871 mode = mode_from_discipline(*svp);
5872 if (mode & O_BINARY)
5873 o->op_private |= OPpOPEN_OUT_RAW;
5874 else if (mode & O_TEXT)
5875 o->op_private |= OPpOPEN_OUT_CRLF;
5878 if (o->op_type == OP_BACKTICK)
5881 /* In case of three-arg dup open remove strictness
5882 * from the last arg if it is a bareword. */
5883 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5884 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5888 if ((last->op_type == OP_CONST) && /* The bareword. */
5889 (last->op_private & OPpCONST_BARE) &&
5890 (last->op_private & OPpCONST_STRICT) &&
5891 (oa = first->op_sibling) && /* The fh. */
5892 (oa = oa->op_sibling) && /* The mode. */
5893 SvPOK(((SVOP*)oa)->op_sv) &&
5894 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5895 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5896 (last == oa->op_sibling)) /* The bareword. */
5897 last->op_private &= ~OPpCONST_STRICT;
5903 Perl_ck_repeat(pTHX_ OP *o)
5905 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5906 o->op_private |= OPpREPEAT_DOLIST;
5907 cBINOPo->op_first = force_list(cBINOPo->op_first);
5915 Perl_ck_require(pTHX_ OP *o)
5919 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5920 SVOP *kid = (SVOP*)cUNOPo->op_first;
5922 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5923 SV *sv = kid->op_sv;
5924 U32 was_readonly = SvREADONLY(sv);
5929 sv_force_normal_flags(sv, 0);
5930 assert(!SvREADONLY(sv));
5937 for (s = SvPVX(sv); *s; s++) {
5938 if (*s == ':' && s[1] == ':') {
5940 Move(s+2, s+1, strlen(s+2)+1, char);
5941 SvCUR_set(sv, SvCUR(sv) - 1);
5944 sv_catpvn(sv, ".pm", 3);
5945 SvFLAGS(sv) |= was_readonly;
5949 /* handle override, if any */
5950 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5951 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5952 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5954 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5955 OP *kid = cUNOPo->op_first;
5956 cUNOPo->op_first = 0;
5958 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5959 append_elem(OP_LIST, kid,
5960 scalar(newUNOP(OP_RV2CV, 0,
5969 Perl_ck_return(pTHX_ OP *o)
5971 if (CvLVALUE(PL_compcv)) {
5973 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5974 mod(kid, OP_LEAVESUBLV);
5981 Perl_ck_retarget(pTHX_ OP *o)
5983 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5990 Perl_ck_select(pTHX_ OP *o)
5994 if (o->op_flags & OPf_KIDS) {
5995 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5996 if (kid && kid->op_sibling) {
5997 o->op_type = OP_SSELECT;
5998 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6000 return fold_constants(o);
6004 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6005 if (kid && kid->op_type == OP_RV2GV)
6006 kid->op_private &= ~HINT_STRICT_REFS;
6011 Perl_ck_shift(pTHX_ OP *o)
6013 const I32 type = o->op_type;
6015 if (!(o->op_flags & OPf_KIDS)) {
6019 argop = newUNOP(OP_RV2AV, 0,
6020 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6021 return newUNOP(type, 0, scalar(argop));
6023 return scalar(modkids(ck_fun(o), type));
6027 Perl_ck_sort(pTHX_ OP *o)
6031 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6033 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6034 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6036 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6038 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6040 if (kid->op_type == OP_SCOPE) {
6044 else if (kid->op_type == OP_LEAVE) {
6045 if (o->op_type == OP_SORT) {
6046 op_null(kid); /* wipe out leave */
6049 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6050 if (k->op_next == kid)
6052 /* don't descend into loops */
6053 else if (k->op_type == OP_ENTERLOOP
6054 || k->op_type == OP_ENTERITER)
6056 k = cLOOPx(k)->op_lastop;
6061 kid->op_next = 0; /* just disconnect the leave */
6062 k = kLISTOP->op_first;
6067 if (o->op_type == OP_SORT) {
6068 /* provide scalar context for comparison function/block */
6074 o->op_flags |= OPf_SPECIAL;
6076 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6079 firstkid = firstkid->op_sibling;
6082 /* provide list context for arguments */
6083 if (o->op_type == OP_SORT)
6090 S_simplify_sort(pTHX_ OP *o)
6092 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6097 if (!(o->op_flags & OPf_STACKED))
6099 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6100 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6101 kid = kUNOP->op_first; /* get past null */
6102 if (kid->op_type != OP_SCOPE)
6104 kid = kLISTOP->op_last; /* get past scope */
6105 switch(kid->op_type) {
6113 k = kid; /* remember this node*/
6114 if (kBINOP->op_first->op_type != OP_RV2SV)
6116 kid = kBINOP->op_first; /* get past cmp */
6117 if (kUNOP->op_first->op_type != OP_GV)
6119 kid = kUNOP->op_first; /* get past rv2sv */
6121 if (GvSTASH(gv) != PL_curstash)
6123 gvname = GvNAME(gv);
6124 if (*gvname == 'a' && gvname[1] == '\0')
6126 else if (*gvname == 'b' && gvname[1] == '\0')
6131 kid = k; /* back to cmp */
6132 if (kBINOP->op_last->op_type != OP_RV2SV)
6134 kid = kBINOP->op_last; /* down to 2nd arg */
6135 if (kUNOP->op_first->op_type != OP_GV)
6137 kid = kUNOP->op_first; /* get past rv2sv */
6139 if (GvSTASH(gv) != PL_curstash)
6141 gvname = GvNAME(gv);
6143 ? !(*gvname == 'a' && gvname[1] == '\0')
6144 : !(*gvname == 'b' && gvname[1] == '\0'))
6146 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6148 o->op_private |= OPpSORT_DESCEND;
6149 if (k->op_type == OP_NCMP)
6150 o->op_private |= OPpSORT_NUMERIC;
6151 if (k->op_type == OP_I_NCMP)
6152 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6153 kid = cLISTOPo->op_first->op_sibling;
6154 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6155 op_free(kid); /* then delete it */
6159 Perl_ck_split(pTHX_ OP *o)
6164 if (o->op_flags & OPf_STACKED)
6165 return no_fh_allowed(o);
6167 kid = cLISTOPo->op_first;
6168 if (kid->op_type != OP_NULL)
6169 Perl_croak(aTHX_ "panic: ck_split");
6170 kid = kid->op_sibling;
6171 op_free(cLISTOPo->op_first);
6172 cLISTOPo->op_first = kid;
6174 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6175 cLISTOPo->op_last = kid; /* There was only one element previously */
6178 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6179 OP *sibl = kid->op_sibling;
6180 kid->op_sibling = 0;
6181 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6182 if (cLISTOPo->op_first == cLISTOPo->op_last)
6183 cLISTOPo->op_last = kid;
6184 cLISTOPo->op_first = kid;
6185 kid->op_sibling = sibl;
6188 kid->op_type = OP_PUSHRE;
6189 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6191 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6192 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6193 "Use of /g modifier is meaningless in split");
6196 if (!kid->op_sibling)
6197 append_elem(OP_SPLIT, o, newDEFSVOP());
6199 kid = kid->op_sibling;
6202 if (!kid->op_sibling)
6203 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6205 kid = kid->op_sibling;
6208 if (kid->op_sibling)
6209 return too_many_arguments(o,OP_DESC(o));
6215 Perl_ck_join(pTHX_ OP *o)
6217 if (ckWARN(WARN_SYNTAX)) {
6218 const OP *kid = cLISTOPo->op_first->op_sibling;
6219 if (kid && kid->op_type == OP_MATCH) {
6220 const REGEXP *re = PM_GETRE(kPMOP);
6221 const char *pmstr = re ? re->precomp : "STRING";
6222 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6223 "/%s/ should probably be written as \"%s\"",
6231 Perl_ck_subr(pTHX_ OP *o)
6233 OP *prev = ((cUNOPo->op_first->op_sibling)
6234 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6235 OP *o2 = prev->op_sibling;
6242 I32 contextclass = 0;
6246 o->op_private |= OPpENTERSUB_HASTARG;
6247 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6248 if (cvop->op_type == OP_RV2CV) {
6250 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6251 op_null(cvop); /* disable rv2cv */
6252 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6253 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6254 GV *gv = cGVOPx_gv(tmpop);
6257 tmpop->op_private |= OPpEARLY_CV;
6260 namegv = CvANON(cv) ? gv : CvGV(cv);
6261 proto = SvPV_nolen((SV*)cv);
6263 if (CvASSERTION(cv)) {
6264 if (PL_hints & HINT_ASSERTING) {
6265 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6266 o->op_private |= OPpENTERSUB_DB;
6270 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6271 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6272 "Impossible to activate assertion call");
6279 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6280 if (o2->op_type == OP_CONST)
6281 o2->op_private &= ~OPpCONST_STRICT;
6282 else if (o2->op_type == OP_LIST) {
6283 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6284 if (o && o->op_type == OP_CONST)
6285 o->op_private &= ~OPpCONST_STRICT;
6288 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6289 if (PERLDB_SUB && PL_curstash != PL_debstash)
6290 o->op_private |= OPpENTERSUB_DB;
6291 while (o2 != cvop) {
6295 return too_many_arguments(o, gv_ename(namegv));
6313 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6315 arg == 1 ? "block or sub {}" : "sub {}",
6316 gv_ename(namegv), o2);
6319 /* '*' allows any scalar type, including bareword */
6322 if (o2->op_type == OP_RV2GV)
6323 goto wrapref; /* autoconvert GLOB -> GLOBref */
6324 else if (o2->op_type == OP_CONST)
6325 o2->op_private &= ~OPpCONST_STRICT;
6326 else if (o2->op_type == OP_ENTERSUB) {
6327 /* accidental subroutine, revert to bareword */
6328 OP *gvop = ((UNOP*)o2)->op_first;
6329 if (gvop && gvop->op_type == OP_NULL) {
6330 gvop = ((UNOP*)gvop)->op_first;
6332 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6335 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6336 (gvop = ((UNOP*)gvop)->op_first) &&
6337 gvop->op_type == OP_GV)
6339 GV *gv = cGVOPx_gv(gvop);
6340 OP *sibling = o2->op_sibling;
6341 SV *n = newSVpvn("",0);
6343 gv_fullname4(n, gv, "", FALSE);
6344 o2 = newSVOP(OP_CONST, 0, n);
6345 prev->op_sibling = o2;
6346 o2->op_sibling = sibling;
6362 if (contextclass++ == 0) {
6363 e = strchr(proto, ']');
6364 if (!e || e == proto)
6377 while (*--p != '[');
6378 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6379 gv_ename(namegv), o2);
6385 if (o2->op_type == OP_RV2GV)
6388 bad_type(arg, "symbol", gv_ename(namegv), o2);
6391 if (o2->op_type == OP_ENTERSUB)
6394 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6397 if (o2->op_type == OP_RV2SV ||
6398 o2->op_type == OP_PADSV ||
6399 o2->op_type == OP_HELEM ||
6400 o2->op_type == OP_AELEM ||
6401 o2->op_type == OP_THREADSV)
6404 bad_type(arg, "scalar", gv_ename(namegv), o2);
6407 if (o2->op_type == OP_RV2AV ||
6408 o2->op_type == OP_PADAV)
6411 bad_type(arg, "array", gv_ename(namegv), o2);
6414 if (o2->op_type == OP_RV2HV ||
6415 o2->op_type == OP_PADHV)
6418 bad_type(arg, "hash", gv_ename(namegv), o2);
6423 OP* sib = kid->op_sibling;
6424 kid->op_sibling = 0;
6425 o2 = newUNOP(OP_REFGEN, 0, kid);
6426 o2->op_sibling = sib;
6427 prev->op_sibling = o2;
6429 if (contextclass && e) {
6444 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6445 gv_ename(namegv), cv);
6450 mod(o2, OP_ENTERSUB);
6452 o2 = o2->op_sibling;
6454 if (proto && !optional &&
6455 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6456 return too_few_arguments(o, gv_ename(namegv));
6459 o=newSVOP(OP_CONST, 0, newSViv(0));
6465 Perl_ck_svconst(pTHX_ OP *o)
6467 SvREADONLY_on(cSVOPo->op_sv);
6472 Perl_ck_trunc(pTHX_ OP *o)
6474 if (o->op_flags & OPf_KIDS) {
6475 SVOP *kid = (SVOP*)cUNOPo->op_first;
6477 if (kid->op_type == OP_NULL)
6478 kid = (SVOP*)kid->op_sibling;
6479 if (kid && kid->op_type == OP_CONST &&
6480 (kid->op_private & OPpCONST_BARE))
6482 o->op_flags |= OPf_SPECIAL;
6483 kid->op_private &= ~OPpCONST_STRICT;
6490 Perl_ck_unpack(pTHX_ OP *o)
6492 OP *kid = cLISTOPo->op_first;
6493 if (kid->op_sibling) {
6494 kid = kid->op_sibling;
6495 if (!kid->op_sibling)
6496 kid->op_sibling = newDEFSVOP();
6502 Perl_ck_substr(pTHX_ OP *o)
6505 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6506 OP *kid = cLISTOPo->op_first;
6508 if (kid->op_type == OP_NULL)
6509 kid = kid->op_sibling;
6511 kid->op_flags |= OPf_MOD;
6517 /* A peephole optimizer. We visit the ops in the order they're to execute.
6518 * See the comments at the top of this file for more details about when
6519 * peep() is called */
6522 Perl_peep(pTHX_ register OP *o)
6525 register OP* oldop = 0;
6527 if (!o || o->op_opt)
6531 SAVEVPTR(PL_curcop);
6532 for (; o; o = o->op_next) {
6536 switch (o->op_type) {
6540 PL_curcop = ((COP*)o); /* for warnings */
6545 if (cSVOPo->op_private & OPpCONST_STRICT)
6546 no_bareword_allowed(o);
6548 case OP_METHOD_NAMED:
6549 /* Relocate sv to the pad for thread safety.
6550 * Despite being a "constant", the SV is written to,
6551 * for reference counts, sv_upgrade() etc. */
6553 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6554 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6555 /* If op_sv is already a PADTMP then it is being used by
6556 * some pad, so make a copy. */
6557 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6558 SvREADONLY_on(PAD_SVl(ix));
6559 SvREFCNT_dec(cSVOPo->op_sv);
6562 SvREFCNT_dec(PAD_SVl(ix));
6563 SvPADTMP_on(cSVOPo->op_sv);
6564 PAD_SETSV(ix, cSVOPo->op_sv);
6565 /* XXX I don't know how this isn't readonly already. */
6566 SvREADONLY_on(PAD_SVl(ix));
6568 cSVOPo->op_sv = Nullsv;
6576 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6577 if (o->op_next->op_private & OPpTARGET_MY) {
6578 if (o->op_flags & OPf_STACKED) /* chained concats */
6579 goto ignore_optimization;
6581 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6582 o->op_targ = o->op_next->op_targ;
6583 o->op_next->op_targ = 0;
6584 o->op_private |= OPpTARGET_MY;
6587 op_null(o->op_next);
6589 ignore_optimization:
6593 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6595 break; /* Scalar stub must produce undef. List stub is noop */
6599 if (o->op_targ == OP_NEXTSTATE
6600 || o->op_targ == OP_DBSTATE
6601 || o->op_targ == OP_SETSTATE)
6603 PL_curcop = ((COP*)o);
6605 /* XXX: We avoid setting op_seq here to prevent later calls
6606 to peep() from mistakenly concluding that optimisation
6607 has already occurred. This doesn't fix the real problem,
6608 though (See 20010220.007). AMS 20010719 */
6609 /* op_seq functionality is now replaced by op_opt */
6610 if (oldop && o->op_next) {
6611 oldop->op_next = o->op_next;
6619 if (oldop && o->op_next) {
6620 oldop->op_next = o->op_next;
6628 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6629 OP* pop = (o->op_type == OP_PADAV) ?
6630 o->op_next : o->op_next->op_next;
6632 if (pop && pop->op_type == OP_CONST &&
6633 ((PL_op = pop->op_next)) &&
6634 pop->op_next->op_type == OP_AELEM &&
6635 !(pop->op_next->op_private &
6636 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6637 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6642 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6643 no_bareword_allowed(pop);
6644 if (o->op_type == OP_GV)
6645 op_null(o->op_next);
6646 op_null(pop->op_next);
6648 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6649 o->op_next = pop->op_next->op_next;
6650 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6651 o->op_private = (U8)i;
6652 if (o->op_type == OP_GV) {
6657 o->op_flags |= OPf_SPECIAL;
6658 o->op_type = OP_AELEMFAST;
6664 if (o->op_next->op_type == OP_RV2SV) {
6665 if (!(o->op_next->op_private & OPpDEREF)) {
6666 op_null(o->op_next);
6667 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6669 o->op_next = o->op_next->op_next;
6670 o->op_type = OP_GVSV;
6671 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6674 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6676 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6677 /* XXX could check prototype here instead of just carping */
6678 SV *sv = sv_newmortal();
6679 gv_efullname3(sv, gv, Nullch);
6680 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6681 "%"SVf"() called too early to check prototype",
6685 else if (o->op_next->op_type == OP_READLINE
6686 && o->op_next->op_next->op_type == OP_CONCAT
6687 && (o->op_next->op_next->op_flags & OPf_STACKED))
6689 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6690 o->op_type = OP_RCATLINE;
6691 o->op_flags |= OPf_STACKED;
6692 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6693 op_null(o->op_next->op_next);
6694 op_null(o->op_next);
6711 while (cLOGOP->op_other->op_type == OP_NULL)
6712 cLOGOP->op_other = cLOGOP->op_other->op_next;
6713 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6719 while (cLOOP->op_redoop->op_type == OP_NULL)
6720 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6721 peep(cLOOP->op_redoop);
6722 while (cLOOP->op_nextop->op_type == OP_NULL)
6723 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6724 peep(cLOOP->op_nextop);
6725 while (cLOOP->op_lastop->op_type == OP_NULL)
6726 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6727 peep(cLOOP->op_lastop);
6734 while (cPMOP->op_pmreplstart &&
6735 cPMOP->op_pmreplstart->op_type == OP_NULL)
6736 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6737 peep(cPMOP->op_pmreplstart);
6742 if (ckWARN(WARN_SYNTAX) && o->op_next
6743 && o->op_next->op_type == OP_NEXTSTATE) {
6744 if (o->op_next->op_sibling &&
6745 o->op_next->op_sibling->op_type != OP_EXIT &&
6746 o->op_next->op_sibling->op_type != OP_WARN &&
6747 o->op_next->op_sibling->op_type != OP_DIE) {
6748 const line_t oldline = CopLINE(PL_curcop);
6750 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6751 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6752 "Statement unlikely to be reached");
6753 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6754 "\t(Maybe you meant system() when you said exec()?)\n");
6755 CopLINE_set(PL_curcop, oldline);
6765 const char *key = NULL;
6770 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6773 /* Make the CONST have a shared SV */
6774 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6775 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6776 key = SvPV_const(sv, keylen);
6777 lexname = newSVpvn_share(key,
6778 SvUTF8(sv) ? -(I32)keylen : keylen,
6784 if ((o->op_private & (OPpLVAL_INTRO)))
6787 rop = (UNOP*)((BINOP*)o)->op_first;
6788 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6790 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6791 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6793 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6794 if (!fields || !GvHV(*fields))
6796 key = SvPV_const(*svp, keylen);
6797 if (!hv_fetch(GvHV(*fields), key,
6798 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6800 Perl_croak(aTHX_ "No such class field \"%s\" "
6801 "in variable %s of type %s",
6802 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
6815 SVOP *first_key_op, *key_op;
6817 if ((o->op_private & (OPpLVAL_INTRO))
6818 /* I bet there's always a pushmark... */
6819 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6820 /* hmmm, no optimization if list contains only one key. */
6822 rop = (UNOP*)((LISTOP*)o)->op_last;
6823 if (rop->op_type != OP_RV2HV)
6825 if (rop->op_first->op_type == OP_PADSV)
6826 /* @$hash{qw(keys here)} */
6827 rop = (UNOP*)rop->op_first;
6829 /* @{$hash}{qw(keys here)} */
6830 if (rop->op_first->op_type == OP_SCOPE
6831 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6833 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6839 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6840 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6842 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6843 if (!fields || !GvHV(*fields))
6845 /* Again guessing that the pushmark can be jumped over.... */
6846 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6847 ->op_first->op_sibling;
6848 for (key_op = first_key_op; key_op;
6849 key_op = (SVOP*)key_op->op_sibling) {
6850 if (key_op->op_type != OP_CONST)
6852 svp = cSVOPx_svp(key_op);
6853 key = SvPV_const(*svp, keylen);
6854 if (!hv_fetch(GvHV(*fields), key,
6855 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6857 Perl_croak(aTHX_ "No such class field \"%s\" "
6858 "in variable %s of type %s",
6859 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6866 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6870 /* check that RHS of sort is a single plain array */
6871 oright = cUNOPo->op_first;
6872 if (!oright || oright->op_type != OP_PUSHMARK)
6875 /* reverse sort ... can be optimised. */
6876 if (!cUNOPo->op_sibling) {
6877 /* Nothing follows us on the list. */
6878 OP *reverse = o->op_next;
6880 if (reverse->op_type == OP_REVERSE &&
6881 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6882 OP *pushmark = cUNOPx(reverse)->op_first;
6883 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6884 && (cUNOPx(pushmark)->op_sibling == o)) {
6885 /* reverse -> pushmark -> sort */
6886 o->op_private |= OPpSORT_REVERSE;
6888 pushmark->op_next = oright->op_next;
6894 /* make @a = sort @a act in-place */
6898 oright = cUNOPx(oright)->op_sibling;
6901 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6902 oright = cUNOPx(oright)->op_sibling;
6906 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6907 || oright->op_next != o
6908 || (oright->op_private & OPpLVAL_INTRO)
6912 /* o2 follows the chain of op_nexts through the LHS of the
6913 * assign (if any) to the aassign op itself */
6915 if (!o2 || o2->op_type != OP_NULL)
6918 if (!o2 || o2->op_type != OP_PUSHMARK)
6921 if (o2 && o2->op_type == OP_GV)
6924 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6925 || (o2->op_private & OPpLVAL_INTRO)
6930 if (!o2 || o2->op_type != OP_NULL)
6933 if (!o2 || o2->op_type != OP_AASSIGN
6934 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6937 /* check that the sort is the first arg on RHS of assign */
6939 o2 = cUNOPx(o2)->op_first;
6940 if (!o2 || o2->op_type != OP_NULL)
6942 o2 = cUNOPx(o2)->op_first;
6943 if (!o2 || o2->op_type != OP_PUSHMARK)
6945 if (o2->op_sibling != o)
6948 /* check the array is the same on both sides */
6949 if (oleft->op_type == OP_RV2AV) {
6950 if (oright->op_type != OP_RV2AV
6951 || !cUNOPx(oright)->op_first
6952 || cUNOPx(oright)->op_first->op_type != OP_GV
6953 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6954 cGVOPx_gv(cUNOPx(oright)->op_first)
6958 else if (oright->op_type != OP_PADAV
6959 || oright->op_targ != oleft->op_targ
6963 /* transfer MODishness etc from LHS arg to RHS arg */
6964 oright->op_flags = oleft->op_flags;
6965 o->op_private |= OPpSORT_INPLACE;
6967 /* excise push->gv->rv2av->null->aassign */
6968 o2 = o->op_next->op_next;
6969 op_null(o2); /* PUSHMARK */
6971 if (o2->op_type == OP_GV) {
6972 op_null(o2); /* GV */
6975 op_null(o2); /* RV2AV or PADAV */
6976 o2 = o2->op_next->op_next;
6977 op_null(o2); /* AASSIGN */
6979 o->op_next = o2->op_next;
6985 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6987 LISTOP *enter, *exlist;
6990 enter = (LISTOP *) o->op_next;
6993 if (enter->op_type == OP_NULL) {
6994 enter = (LISTOP *) enter->op_next;
6998 /* for $a (...) will have OP_GV then OP_RV2GV here.
6999 for (...) just has an OP_GV. */
7000 if (enter->op_type == OP_GV) {
7001 gvop = (OP *) enter;
7002 enter = (LISTOP *) enter->op_next;
7005 if (enter->op_type == OP_RV2GV) {
7006 enter = (LISTOP *) enter->op_next;
7012 if (enter->op_type != OP_ENTERITER)
7015 iter = enter->op_next;
7016 if (!iter || iter->op_type != OP_ITER)
7019 expushmark = enter->op_first;
7020 if (!expushmark || expushmark->op_type != OP_NULL
7021 || expushmark->op_targ != OP_PUSHMARK)
7024 exlist = (LISTOP *) expushmark->op_sibling;
7025 if (!exlist || exlist->op_type != OP_NULL
7026 || exlist->op_targ != OP_LIST)
7029 if (exlist->op_last != o) {
7030 /* Mmm. Was expecting to point back to this op. */
7033 theirmark = exlist->op_first;
7034 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7037 if (theirmark->op_sibling != o) {
7038 /* There's something between the mark and the reverse, eg
7039 for (1, reverse (...))
7044 ourmark = ((LISTOP *)o)->op_first;
7045 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7048 ourlast = ((LISTOP *)o)->op_last;
7049 if (!ourlast || ourlast->op_next != o)
7052 rv2av = ourmark->op_sibling;
7053 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7054 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7055 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7056 /* We're just reversing a single array. */
7057 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7058 enter->op_flags |= OPf_STACKED;
7061 /* We don't have control over who points to theirmark, so sacrifice
7063 theirmark->op_next = ourmark->op_next;
7064 theirmark->op_flags = ourmark->op_flags;
7065 ourlast->op_next = gvop ? gvop : (OP *) enter;
7068 enter->op_private |= OPpITER_REVERSED;
7069 iter->op_private |= OPpITER_REVERSED;
7084 Perl_custom_op_name(pTHX_ const OP* o)
7086 const IV index = PTR2IV(o->op_ppaddr);
7090 if (!PL_custom_op_names) /* This probably shouldn't happen */
7091 return (char *)PL_op_name[OP_CUSTOM];
7093 keysv = sv_2mortal(newSViv(index));
7095 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7097 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7099 return SvPV_nolen(HeVAL(he));
7103 Perl_custom_op_desc(pTHX_ const OP* o)
7105 const IV index = PTR2IV(o->op_ppaddr);
7109 if (!PL_custom_op_descs)
7110 return (char *)PL_op_desc[OP_CUSTOM];
7112 keysv = sv_2mortal(newSViv(index));
7114 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7116 return (char *)PL_op_desc[OP_CUSTOM];
7118 return SvPV_nolen(HeVAL(he));
7123 /* Efficient sub that returns a constant scalar value. */
7125 const_sv_xsub(pTHX_ CV* cv)
7130 Perl_croak(aTHX_ "usage: %s::%s()",
7131 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7135 ST(0) = (SV*)XSANY.any_ptr;
7141 * c-indentation-style: bsd
7143 * indent-tabs-mode: t
7146 * ex: set ts=8 sts=4 sw=4 noet: