3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 ** const ptr = (I32 **) op;
132 I32 * const slab = ptr[-1];
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, Nullch);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
201 qerror(Perl_mess(aTHX_
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
206 /* "register" allocation */
209 Perl_allocmy(pTHX_ char *name)
213 /* complain about "my $<special_var>" etc etc */
214 if (!(PL_in_my == KEY_our ||
216 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
217 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
219 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
220 /* 1999-02-27 mjd@plover.com */
222 p = strchr(name, '\0');
223 /* The next block assumes the buffer is at least 205 chars
224 long. At present, it's always at least 256 chars. */
226 strcpy(name+200, "...");
232 /* Move everything else down one character */
233 for (; p-name > 2; p--)
235 name[2] = toCTRL(name[1]);
238 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
241 /* check for duplicate declaration */
243 (bool)(PL_in_my == KEY_our),
244 (PL_curstash ? PL_curstash : PL_defstash)
247 if (PL_in_my_stash && *name != '$') {
248 yyerror(Perl_form(aTHX_
249 "Can't declare class for non-scalar %s in \"%s\"",
250 name, PL_in_my == KEY_our ? "our" : "my"));
253 /* allocate a spare slot and store the name in that slot */
255 off = pad_add_name(name,
258 /* $_ is always in main::, even with our */
259 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
270 Perl_op_free(pTHX_ OP *o)
276 if (!o || o->op_static)
279 if (o->op_private & OPpREFCOUNTED) {
280 switch (o->op_type) {
288 refcnt = OpREFCNT_dec(o);
298 if (o->op_flags & OPf_KIDS) {
299 register OP *kid, *nextkid;
300 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
301 nextkid = kid->op_sibling; /* Get before next freeing kid */
307 type = (OPCODE)o->op_targ;
309 /* COP* is not cleared by op_clear() so that we may track line
310 * numbers etc even after null() */
311 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
316 #ifdef DEBUG_LEAKING_SCALARS
323 Perl_op_clear(pTHX_ OP *o)
327 switch (o->op_type) {
328 case OP_NULL: /* Was holding old type, if any. */
329 case OP_ENTEREVAL: /* Was holding hints. */
333 if (!(o->op_flags & OPf_REF)
334 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
340 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
341 /* not an OP_PADAV replacement */
343 if (cPADOPo->op_padix > 0) {
344 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
345 * may still exist on the pad */
346 pad_swipe(cPADOPo->op_padix, TRUE);
347 cPADOPo->op_padix = 0;
350 SvREFCNT_dec(cSVOPo->op_sv);
351 cSVOPo->op_sv = Nullsv;
355 case OP_METHOD_NAMED:
357 SvREFCNT_dec(cSVOPo->op_sv);
358 cSVOPo->op_sv = Nullsv;
361 Even if op_clear does a pad_free for the target of the op,
362 pad_free doesn't actually remove the sv that exists in the pad;
363 instead it lives on. This results in that it could be reused as
364 a target later on when the pad was reallocated.
367 pad_swipe(o->op_targ,1);
376 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
380 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
381 SvREFCNT_dec(cSVOPo->op_sv);
382 cSVOPo->op_sv = Nullsv;
385 Safefree(cPVOPo->op_pv);
386 cPVOPo->op_pv = Nullch;
390 op_free(cPMOPo->op_pmreplroot);
394 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
395 /* No GvIN_PAD_off here, because other references may still
396 * exist on the pad */
397 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
400 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
407 HV *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 * const 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 ( (left->op_type == OP_RV2AV ||
1771 left->op_type == OP_RV2HV ||
1772 left->op_type == OP_PADAV ||
1773 left->op_type == OP_PADHV)
1774 && ckWARN(WARN_MISC))
1776 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1777 right->op_type == OP_TRANS)
1778 ? right->op_type : OP_MATCH];
1779 const char *sample = ((left->op_type == OP_RV2AV ||
1780 left->op_type == OP_PADAV)
1781 ? "@array" : "%hash");
1782 Perl_warner(aTHX_ packWARN(WARN_MISC),
1783 "Applying %s to %s will act on scalar(%s)",
1784 desc, sample, sample);
1787 if (right->op_type == OP_CONST &&
1788 cSVOPx(right)->op_private & OPpCONST_BARE &&
1789 cSVOPx(right)->op_private & OPpCONST_STRICT)
1791 no_bareword_allowed(right);
1794 ismatchop = right->op_type == OP_MATCH ||
1795 right->op_type == OP_SUBST ||
1796 right->op_type == OP_TRANS;
1797 if (ismatchop && right->op_private & OPpTARGET_MY) {
1799 right->op_private &= ~OPpTARGET_MY;
1801 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1802 right->op_flags |= OPf_STACKED;
1803 if (right->op_type != OP_MATCH &&
1804 ! (right->op_type == OP_TRANS &&
1805 right->op_private & OPpTRANS_IDENTICAL))
1806 left = mod(left, right->op_type);
1807 if (right->op_type == OP_TRANS)
1808 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1810 o = prepend_elem(right->op_type, scalar(left), right);
1812 return newUNOP(OP_NOT, 0, scalar(o));
1816 return bind_match(type, left,
1817 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1821 Perl_invert(pTHX_ OP *o)
1825 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1826 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1830 Perl_scope(pTHX_ OP *o)
1834 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1835 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1836 o->op_type = OP_LEAVE;
1837 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1839 else if (o->op_type == OP_LINESEQ) {
1841 o->op_type = OP_SCOPE;
1842 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1843 kid = ((LISTOP*)o)->op_first;
1844 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1848 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1853 /* XXX kept for BINCOMPAT only */
1855 Perl_save_hints(pTHX)
1857 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1861 Perl_block_start(pTHX_ int full)
1863 const int retval = PL_savestack_ix;
1864 pad_block_start(full);
1866 PL_hints &= ~HINT_BLOCK_SCOPE;
1867 SAVESPTR(PL_compiling.cop_warnings);
1868 if (! specialWARN(PL_compiling.cop_warnings)) {
1869 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1870 SAVEFREESV(PL_compiling.cop_warnings) ;
1872 SAVESPTR(PL_compiling.cop_io);
1873 if (! specialCopIO(PL_compiling.cop_io)) {
1874 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1875 SAVEFREESV(PL_compiling.cop_io) ;
1881 Perl_block_end(pTHX_ I32 floor, OP *seq)
1883 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1884 OP* retval = scalarseq(seq);
1886 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1888 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1896 const I32 offset = pad_findmy("$_");
1897 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1898 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1901 OP *o = newOP(OP_PADSV, 0);
1902 o->op_targ = offset;
1908 Perl_newPROG(pTHX_ OP *o)
1913 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1914 ((PL_in_eval & EVAL_KEEPERR)
1915 ? OPf_SPECIAL : 0), o);
1916 PL_eval_start = linklist(PL_eval_root);
1917 PL_eval_root->op_private |= OPpREFCOUNTED;
1918 OpREFCNT_set(PL_eval_root, 1);
1919 PL_eval_root->op_next = 0;
1920 CALL_PEEP(PL_eval_start);
1923 if (o->op_type == OP_STUB) {
1924 PL_comppad_name = 0;
1929 PL_main_root = scope(sawparens(scalarvoid(o)));
1930 PL_curcop = &PL_compiling;
1931 PL_main_start = LINKLIST(PL_main_root);
1932 PL_main_root->op_private |= OPpREFCOUNTED;
1933 OpREFCNT_set(PL_main_root, 1);
1934 PL_main_root->op_next = 0;
1935 CALL_PEEP(PL_main_start);
1938 /* Register with debugger */
1940 CV *cv = get_cv("DB::postponed", FALSE);
1944 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1946 call_sv((SV*)cv, G_DISCARD);
1953 Perl_localize(pTHX_ OP *o, I32 lex)
1955 if (o->op_flags & OPf_PARENS)
1956 /* [perl #17376]: this appears to be premature, and results in code such as
1957 C< our(%x); > executing in list mode rather than void mode */
1964 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
1965 && ckWARN(WARN_PARENTHESIS))
1967 char *s = PL_bufptr;
1970 /* some heuristics to detect a potential error */
1971 while (*s && (strchr(", \t\n", *s)))
1975 if (*s && strchr("@$%*", *s) && *++s
1976 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1979 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1981 while (*s && (strchr(", \t\n", *s)))
1987 if (sigil && (*s == ';' || *s == '=')) {
1988 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1989 "Parentheses missing around \"%s\" list",
1990 lex ? (PL_in_my == KEY_our ? "our" : "my")
1998 o = mod(o, OP_NULL); /* a bit kludgey */
2000 PL_in_my_stash = Nullhv;
2005 Perl_jmaybe(pTHX_ OP *o)
2007 if (o->op_type == OP_LIST) {
2009 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2010 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2016 Perl_fold_constants(pTHX_ register OP *o)
2020 I32 type = o->op_type;
2023 if (PL_opargs[type] & OA_RETSCALAR)
2025 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2026 o->op_targ = pad_alloc(type, SVs_PADTMP);
2028 /* integerize op, unless it happens to be C<-foo>.
2029 * XXX should pp_i_negate() do magic string negation instead? */
2030 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2031 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2032 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2034 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2037 if (!(PL_opargs[type] & OA_FOLDCONST))
2042 /* XXX might want a ck_negate() for this */
2043 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2055 /* XXX what about the numeric ops? */
2056 if (PL_hints & HINT_LOCALE)
2061 goto nope; /* Don't try to run w/ errors */
2063 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2064 if ((curop->op_type != OP_CONST ||
2065 (curop->op_private & OPpCONST_BARE)) &&
2066 curop->op_type != OP_LIST &&
2067 curop->op_type != OP_SCALAR &&
2068 curop->op_type != OP_NULL &&
2069 curop->op_type != OP_PUSHMARK)
2075 curop = LINKLIST(o);
2079 sv = *(PL_stack_sp--);
2080 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2081 pad_swipe(o->op_targ, FALSE);
2082 else if (SvTEMP(sv)) { /* grab mortal temp? */
2083 (void)SvREFCNT_inc(sv);
2087 if (type == OP_RV2GV)
2088 return newGVOP(OP_GV, 0, (GV*)sv);
2089 return newSVOP(OP_CONST, 0, sv);
2096 Perl_gen_constant_list(pTHX_ register OP *o)
2100 const I32 oldtmps_floor = PL_tmps_floor;
2104 return o; /* Don't attempt to run with errors */
2106 PL_op = curop = LINKLIST(o);
2113 PL_tmps_floor = oldtmps_floor;
2115 o->op_type = OP_RV2AV;
2116 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2117 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2118 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2119 o->op_opt = 0; /* needs to be revisited in peep() */
2120 curop = ((UNOP*)o)->op_first;
2121 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2128 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2131 if (!o || o->op_type != OP_LIST)
2132 o = newLISTOP(OP_LIST, 0, o, Nullop);
2134 o->op_flags &= ~OPf_WANT;
2136 if (!(PL_opargs[type] & OA_MARK))
2137 op_null(cLISTOPo->op_first);
2139 o->op_type = (OPCODE)type;
2140 o->op_ppaddr = PL_ppaddr[type];
2141 o->op_flags |= flags;
2143 o = CHECKOP(type, o);
2144 if (o->op_type != (unsigned)type)
2147 return fold_constants(o);
2150 /* List constructors */
2153 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2161 if (first->op_type != (unsigned)type
2162 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2164 return newLISTOP(type, 0, first, last);
2167 if (first->op_flags & OPf_KIDS)
2168 ((LISTOP*)first)->op_last->op_sibling = last;
2170 first->op_flags |= OPf_KIDS;
2171 ((LISTOP*)first)->op_first = last;
2173 ((LISTOP*)first)->op_last = last;
2178 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2186 if (first->op_type != (unsigned)type)
2187 return prepend_elem(type, (OP*)first, (OP*)last);
2189 if (last->op_type != (unsigned)type)
2190 return append_elem(type, (OP*)first, (OP*)last);
2192 first->op_last->op_sibling = last->op_first;
2193 first->op_last = last->op_last;
2194 first->op_flags |= (last->op_flags & OPf_KIDS);
2202 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2210 if (last->op_type == (unsigned)type) {
2211 if (type == OP_LIST) { /* already a PUSHMARK there */
2212 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2213 ((LISTOP*)last)->op_first->op_sibling = first;
2214 if (!(first->op_flags & OPf_PARENS))
2215 last->op_flags &= ~OPf_PARENS;
2218 if (!(last->op_flags & OPf_KIDS)) {
2219 ((LISTOP*)last)->op_last = first;
2220 last->op_flags |= OPf_KIDS;
2222 first->op_sibling = ((LISTOP*)last)->op_first;
2223 ((LISTOP*)last)->op_first = first;
2225 last->op_flags |= OPf_KIDS;
2229 return newLISTOP(type, 0, first, last);
2235 Perl_newNULLLIST(pTHX)
2237 return newOP(OP_STUB, 0);
2241 Perl_force_list(pTHX_ OP *o)
2243 if (!o || o->op_type != OP_LIST)
2244 o = newLISTOP(OP_LIST, 0, o, Nullop);
2250 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2255 NewOp(1101, listop, 1, LISTOP);
2257 listop->op_type = (OPCODE)type;
2258 listop->op_ppaddr = PL_ppaddr[type];
2261 listop->op_flags = (U8)flags;
2265 else if (!first && last)
2268 first->op_sibling = last;
2269 listop->op_first = first;
2270 listop->op_last = last;
2271 if (type == OP_LIST) {
2273 pushop = newOP(OP_PUSHMARK, 0);
2274 pushop->op_sibling = first;
2275 listop->op_first = pushop;
2276 listop->op_flags |= OPf_KIDS;
2278 listop->op_last = pushop;
2281 return CHECKOP(type, listop);
2285 Perl_newOP(pTHX_ I32 type, I32 flags)
2289 NewOp(1101, o, 1, OP);
2290 o->op_type = (OPCODE)type;
2291 o->op_ppaddr = PL_ppaddr[type];
2292 o->op_flags = (U8)flags;
2295 o->op_private = (U8)(0 | (flags >> 8));
2296 if (PL_opargs[type] & OA_RETSCALAR)
2298 if (PL_opargs[type] & OA_TARGET)
2299 o->op_targ = pad_alloc(type, SVs_PADTMP);
2300 return CHECKOP(type, o);
2304 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2310 first = newOP(OP_STUB, 0);
2311 if (PL_opargs[type] & OA_MARK)
2312 first = force_list(first);
2314 NewOp(1101, unop, 1, UNOP);
2315 unop->op_type = (OPCODE)type;
2316 unop->op_ppaddr = PL_ppaddr[type];
2317 unop->op_first = first;
2318 unop->op_flags = flags | OPf_KIDS;
2319 unop->op_private = (U8)(1 | (flags >> 8));
2320 unop = (UNOP*) CHECKOP(type, unop);
2324 return fold_constants((OP *) unop);
2328 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2332 NewOp(1101, binop, 1, BINOP);
2335 first = newOP(OP_NULL, 0);
2337 binop->op_type = (OPCODE)type;
2338 binop->op_ppaddr = PL_ppaddr[type];
2339 binop->op_first = first;
2340 binop->op_flags = flags | OPf_KIDS;
2343 binop->op_private = (U8)(1 | (flags >> 8));
2346 binop->op_private = (U8)(2 | (flags >> 8));
2347 first->op_sibling = last;
2350 binop = (BINOP*)CHECKOP(type, binop);
2351 if (binop->op_next || binop->op_type != (OPCODE)type)
2354 binop->op_last = binop->op_first->op_sibling;
2356 return fold_constants((OP *)binop);
2359 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2360 static int uvcompare(const void *a, const void *b)
2362 if (*((const UV *)a) < (*(const UV *)b))
2364 if (*((const UV *)a) > (*(const UV *)b))
2366 if (*((const UV *)a+1) < (*(const UV *)b+1))
2368 if (*((const UV *)a+1) > (*(const UV *)b+1))
2374 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2376 SV * const tstr = ((SVOP*)expr)->op_sv;
2377 SV * const rstr = ((SVOP*)repl)->op_sv;
2380 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2381 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2388 register short *tbl;
2390 PL_hints |= HINT_BLOCK_SCOPE;
2391 complement = o->op_private & OPpTRANS_COMPLEMENT;
2392 del = o->op_private & OPpTRANS_DELETE;
2393 squash = o->op_private & OPpTRANS_SQUASH;
2396 o->op_private |= OPpTRANS_FROM_UTF;
2399 o->op_private |= OPpTRANS_TO_UTF;
2401 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2402 SV* listsv = newSVpvn("# comment\n",10);
2404 const U8* tend = t + tlen;
2405 const U8* rend = r + rlen;
2419 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2420 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2426 t = tsave = bytes_to_utf8(t, &len);
2429 if (!to_utf && rlen) {
2431 r = rsave = bytes_to_utf8(r, &len);
2435 /* There are several snags with this code on EBCDIC:
2436 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2437 2. scan_const() in toke.c has encoded chars in native encoding which makes
2438 ranges at least in EBCDIC 0..255 range the bottom odd.
2442 U8 tmpbuf[UTF8_MAXBYTES+1];
2445 Newx(cp, 2*tlen, UV);
2447 transv = newSVpvn("",0);
2449 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2451 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2453 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2457 cp[2*i+1] = cp[2*i];
2461 qsort(cp, i, 2*sizeof(UV), uvcompare);
2462 for (j = 0; j < i; j++) {
2464 diff = val - nextmin;
2466 t = uvuni_to_utf8(tmpbuf,nextmin);
2467 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2469 U8 range_mark = UTF_TO_NATIVE(0xff);
2470 t = uvuni_to_utf8(tmpbuf, val - 1);
2471 sv_catpvn(transv, (char *)&range_mark, 1);
2472 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2479 t = uvuni_to_utf8(tmpbuf,nextmin);
2480 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2482 U8 range_mark = UTF_TO_NATIVE(0xff);
2483 sv_catpvn(transv, (char *)&range_mark, 1);
2485 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2486 UNICODE_ALLOW_SUPER);
2487 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2488 t = (const U8*)SvPVX_const(transv);
2489 tlen = SvCUR(transv);
2493 else if (!rlen && !del) {
2494 r = t; rlen = tlen; rend = tend;
2497 if ((!rlen && !del) || t == r ||
2498 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2500 o->op_private |= OPpTRANS_IDENTICAL;
2504 while (t < tend || tfirst <= tlast) {
2505 /* see if we need more "t" chars */
2506 if (tfirst > tlast) {
2507 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2509 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2511 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2518 /* now see if we need more "r" chars */
2519 if (rfirst > rlast) {
2521 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2523 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2525 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2534 rfirst = rlast = 0xffffffff;
2538 /* now see which range will peter our first, if either. */
2539 tdiff = tlast - tfirst;
2540 rdiff = rlast - rfirst;
2547 if (rfirst == 0xffffffff) {
2548 diff = tdiff; /* oops, pretend rdiff is infinite */
2550 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2551 (long)tfirst, (long)tlast);
2553 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2557 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2558 (long)tfirst, (long)(tfirst + diff),
2561 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2562 (long)tfirst, (long)rfirst);
2564 if (rfirst + diff > max)
2565 max = rfirst + diff;
2567 grows = (tfirst < rfirst &&
2568 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2580 else if (max > 0xff)
2585 Safefree(cPVOPo->op_pv);
2586 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2587 SvREFCNT_dec(listsv);
2589 SvREFCNT_dec(transv);
2591 if (!del && havefinal && rlen)
2592 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2593 newSVuv((UV)final), 0);
2596 o->op_private |= OPpTRANS_GROWS;
2608 tbl = (short*)cPVOPo->op_pv;
2610 Zero(tbl, 256, short);
2611 for (i = 0; i < (I32)tlen; i++)
2613 for (i = 0, j = 0; i < 256; i++) {
2615 if (j >= (I32)rlen) {
2624 if (i < 128 && r[j] >= 128)
2634 o->op_private |= OPpTRANS_IDENTICAL;
2636 else if (j >= (I32)rlen)
2639 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2640 tbl[0x100] = rlen - j;
2641 for (i=0; i < (I32)rlen - j; i++)
2642 tbl[0x101+i] = r[j+i];
2646 if (!rlen && !del) {
2649 o->op_private |= OPpTRANS_IDENTICAL;
2651 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2652 o->op_private |= OPpTRANS_IDENTICAL;
2654 for (i = 0; i < 256; i++)
2656 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2657 if (j >= (I32)rlen) {
2659 if (tbl[t[i]] == -1)
2665 if (tbl[t[i]] == -1) {
2666 if (t[i] < 128 && r[j] >= 128)
2673 o->op_private |= OPpTRANS_GROWS;
2681 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2686 NewOp(1101, pmop, 1, PMOP);
2687 pmop->op_type = (OPCODE)type;
2688 pmop->op_ppaddr = PL_ppaddr[type];
2689 pmop->op_flags = (U8)flags;
2690 pmop->op_private = (U8)(0 | (flags >> 8));
2692 if (PL_hints & HINT_RE_TAINT)
2693 pmop->op_pmpermflags |= PMf_RETAINT;
2694 if (PL_hints & HINT_LOCALE)
2695 pmop->op_pmpermflags |= PMf_LOCALE;
2696 pmop->op_pmflags = pmop->op_pmpermflags;
2701 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2702 repointer = av_pop((AV*)PL_regex_pad[0]);
2703 pmop->op_pmoffset = SvIV(repointer);
2704 SvREPADTMP_off(repointer);
2705 sv_setiv(repointer,0);
2707 repointer = newSViv(0);
2708 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2709 pmop->op_pmoffset = av_len(PL_regex_padav);
2710 PL_regex_pad = AvARRAY(PL_regex_padav);
2715 /* link into pm list */
2716 if (type != OP_TRANS && PL_curstash) {
2717 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2720 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2722 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2723 mg->mg_obj = (SV*)pmop;
2724 PmopSTASH_set(pmop,PL_curstash);
2727 return CHECKOP(type, pmop);
2730 /* Given some sort of match op o, and an expression expr containing a
2731 * pattern, either compile expr into a regex and attach it to o (if it's
2732 * constant), or convert expr into a runtime regcomp op sequence (if it's
2735 * isreg indicates that the pattern is part of a regex construct, eg
2736 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2737 * split "pattern", which aren't. In the former case, expr will be a list
2738 * if the pattern contains more than one term (eg /a$b/) or if it contains
2739 * a replacement, ie s/// or tr///.
2743 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2748 I32 repl_has_vars = 0;
2752 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2753 /* last element in list is the replacement; pop it */
2755 repl = cLISTOPx(expr)->op_last;
2756 kid = cLISTOPx(expr)->op_first;
2757 while (kid->op_sibling != repl)
2758 kid = kid->op_sibling;
2759 kid->op_sibling = Nullop;
2760 cLISTOPx(expr)->op_last = kid;
2763 if (isreg && expr->op_type == OP_LIST &&
2764 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2766 /* convert single element list to element */
2768 expr = cLISTOPx(oe)->op_first->op_sibling;
2769 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2770 cLISTOPx(oe)->op_last = Nullop;
2774 if (o->op_type == OP_TRANS) {
2775 return pmtrans(o, expr, repl);
2778 reglist = isreg && expr->op_type == OP_LIST;
2782 PL_hints |= HINT_BLOCK_SCOPE;
2785 if (expr->op_type == OP_CONST) {
2787 SV *pat = ((SVOP*)expr)->op_sv;
2788 const char *p = SvPV_const(pat, plen);
2789 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2790 U32 was_readonly = SvREADONLY(pat);
2794 sv_force_normal_flags(pat, 0);
2795 assert(!SvREADONLY(pat));
2798 SvREADONLY_off(pat);
2802 sv_setpvn(pat, "\\s+", 3);
2804 SvFLAGS(pat) |= was_readonly;
2806 p = SvPV_const(pat, plen);
2807 pm->op_pmflags |= PMf_SKIPWHITE;
2810 pm->op_pmdynflags |= PMdf_UTF8;
2811 /* FIXME - can we make this function take const char * args? */
2812 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2813 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2814 pm->op_pmflags |= PMf_WHITE;
2818 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2819 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2821 : OP_REGCMAYBE),0,expr);
2823 NewOp(1101, rcop, 1, LOGOP);
2824 rcop->op_type = OP_REGCOMP;
2825 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2826 rcop->op_first = scalar(expr);
2827 rcop->op_flags |= OPf_KIDS
2828 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2829 | (reglist ? OPf_STACKED : 0);
2830 rcop->op_private = 1;
2833 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2835 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2838 /* establish postfix order */
2839 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2841 rcop->op_next = expr;
2842 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2845 rcop->op_next = LINKLIST(expr);
2846 expr->op_next = (OP*)rcop;
2849 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2854 if (pm->op_pmflags & PMf_EVAL) {
2856 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2857 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2859 else if (repl->op_type == OP_CONST)
2863 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2864 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2865 if (curop->op_type == OP_GV) {
2866 GV *gv = cGVOPx_gv(curop);
2868 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2871 else if (curop->op_type == OP_RV2CV)
2873 else if (curop->op_type == OP_RV2SV ||
2874 curop->op_type == OP_RV2AV ||
2875 curop->op_type == OP_RV2HV ||
2876 curop->op_type == OP_RV2GV) {
2877 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2880 else if (curop->op_type == OP_PADSV ||
2881 curop->op_type == OP_PADAV ||
2882 curop->op_type == OP_PADHV ||
2883 curop->op_type == OP_PADANY) {
2886 else if (curop->op_type == OP_PUSHRE)
2887 ; /* Okay here, dangerous in newASSIGNOP */
2897 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2898 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2899 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2900 prepend_elem(o->op_type, scalar(repl), o);
2903 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2904 pm->op_pmflags |= PMf_MAYBE_CONST;
2905 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2907 NewOp(1101, rcop, 1, LOGOP);
2908 rcop->op_type = OP_SUBSTCONT;
2909 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2910 rcop->op_first = scalar(repl);
2911 rcop->op_flags |= OPf_KIDS;
2912 rcop->op_private = 1;
2915 /* establish postfix order */
2916 rcop->op_next = LINKLIST(repl);
2917 repl->op_next = (OP*)rcop;
2919 pm->op_pmreplroot = scalar((OP*)rcop);
2920 pm->op_pmreplstart = LINKLIST(rcop);
2929 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2933 NewOp(1101, svop, 1, SVOP);
2934 svop->op_type = (OPCODE)type;
2935 svop->op_ppaddr = PL_ppaddr[type];
2937 svop->op_next = (OP*)svop;
2938 svop->op_flags = (U8)flags;
2939 if (PL_opargs[type] & OA_RETSCALAR)
2941 if (PL_opargs[type] & OA_TARGET)
2942 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2943 return CHECKOP(type, svop);
2947 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2951 NewOp(1101, padop, 1, PADOP);
2952 padop->op_type = (OPCODE)type;
2953 padop->op_ppaddr = PL_ppaddr[type];
2954 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2955 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2956 PAD_SETSV(padop->op_padix, sv);
2959 padop->op_next = (OP*)padop;
2960 padop->op_flags = (U8)flags;
2961 if (PL_opargs[type] & OA_RETSCALAR)
2963 if (PL_opargs[type] & OA_TARGET)
2964 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2965 return CHECKOP(type, padop);
2969 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2975 return newPADOP(type, flags, SvREFCNT_inc(gv));
2977 return newSVOP(type, flags, SvREFCNT_inc(gv));
2982 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2986 NewOp(1101, pvop, 1, PVOP);
2987 pvop->op_type = (OPCODE)type;
2988 pvop->op_ppaddr = PL_ppaddr[type];
2990 pvop->op_next = (OP*)pvop;
2991 pvop->op_flags = (U8)flags;
2992 if (PL_opargs[type] & OA_RETSCALAR)
2994 if (PL_opargs[type] & OA_TARGET)
2995 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2996 return CHECKOP(type, pvop);
3000 Perl_package(pTHX_ OP *o)
3005 save_hptr(&PL_curstash);
3006 save_item(PL_curstname);
3008 name = SvPV_const(cSVOPo->op_sv, len);
3009 PL_curstash = gv_stashpvn(name, len, TRUE);
3010 sv_setpvn(PL_curstname, name, len);
3013 PL_hints |= HINT_BLOCK_SCOPE;
3014 PL_copline = NOLINE;
3019 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3025 if (idop->op_type != OP_CONST)
3026 Perl_croak(aTHX_ "Module name must be constant");
3031 SV *vesv = ((SVOP*)version)->op_sv;
3033 if (!arg && !SvNIOKp(vesv)) {
3040 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3041 Perl_croak(aTHX_ "Version number must be constant number");
3043 /* Make copy of idop so we don't free it twice */
3044 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3046 /* Fake up a method call to VERSION */
3047 meth = newSVpvn_share("VERSION", 7, 0);
3048 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3049 append_elem(OP_LIST,
3050 prepend_elem(OP_LIST, pack, list(version)),
3051 newSVOP(OP_METHOD_NAMED, 0, meth)));
3055 /* Fake up an import/unimport */
3056 if (arg && arg->op_type == OP_STUB)
3057 imop = arg; /* no import on explicit () */
3058 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3059 imop = Nullop; /* use 5.0; */
3061 idop->op_private |= OPpCONST_NOVER;
3066 /* Make copy of idop so we don't free it twice */
3067 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3069 /* Fake up a method call to import/unimport */
3071 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3072 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3073 append_elem(OP_LIST,
3074 prepend_elem(OP_LIST, pack, list(arg)),
3075 newSVOP(OP_METHOD_NAMED, 0, meth)));
3078 /* Fake up the BEGIN {}, which does its thing immediately. */
3080 newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3083 append_elem(OP_LINESEQ,
3084 append_elem(OP_LINESEQ,
3085 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3086 newSTATEOP(0, Nullch, veop)),
3087 newSTATEOP(0, Nullch, imop) ));
3089 /* The "did you use incorrect case?" warning used to be here.
3090 * The problem is that on case-insensitive filesystems one
3091 * might get false positives for "use" (and "require"):
3092 * "use Strict" or "require CARP" will work. This causes
3093 * portability problems for the script: in case-strict
3094 * filesystems the script will stop working.
3096 * The "incorrect case" warning checked whether "use Foo"
3097 * imported "Foo" to your namespace, but that is wrong, too:
3098 * there is no requirement nor promise in the language that
3099 * a Foo.pm should or would contain anything in package "Foo".
3101 * There is very little Configure-wise that can be done, either:
3102 * the case-sensitivity of the build filesystem of Perl does not
3103 * help in guessing the case-sensitivity of the runtime environment.
3106 PL_hints |= HINT_BLOCK_SCOPE;
3107 PL_copline = NOLINE;
3109 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3113 =head1 Embedding Functions
3115 =for apidoc load_module
3117 Loads the module whose name is pointed to by the string part of name.
3118 Note that the actual module name, not its filename, should be given.
3119 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3120 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3121 (or 0 for no flags). ver, if specified, provides version semantics
3122 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3123 arguments can be used to specify arguments to the module's import()
3124 method, similar to C<use Foo::Bar VERSION LIST>.
3129 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3132 va_start(args, ver);
3133 vload_module(flags, name, ver, &args);
3137 #ifdef PERL_IMPLICIT_CONTEXT
3139 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3143 va_start(args, ver);
3144 vload_module(flags, name, ver, &args);
3150 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3152 OP *modname, *veop, *imop;
3154 modname = newSVOP(OP_CONST, 0, name);
3155 modname->op_private |= OPpCONST_BARE;
3157 veop = newSVOP(OP_CONST, 0, ver);
3161 if (flags & PERL_LOADMOD_NOIMPORT) {
3162 imop = sawparens(newNULLLIST());
3164 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3165 imop = va_arg(*args, OP*);
3170 sv = va_arg(*args, SV*);
3172 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3173 sv = va_arg(*args, SV*);
3177 const line_t ocopline = PL_copline;
3178 COP * const ocurcop = PL_curcop;
3179 const int oexpect = PL_expect;
3181 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3182 veop, modname, imop);
3183 PL_expect = oexpect;
3184 PL_copline = ocopline;
3185 PL_curcop = ocurcop;
3190 Perl_dofile(pTHX_ OP *term)
3195 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3196 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3197 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3199 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3200 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3201 append_elem(OP_LIST, term,
3202 scalar(newUNOP(OP_RV2CV, 0,
3207 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3213 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3215 return newBINOP(OP_LSLICE, flags,
3216 list(force_list(subscript)),
3217 list(force_list(listval)) );
3221 S_is_list_assignment(pTHX_ register const OP *o)
3226 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3227 o = cUNOPo->op_first;
3229 if (o->op_type == OP_COND_EXPR) {
3230 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3231 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3236 yyerror("Assignment to both a list and a scalar");
3240 if (o->op_type == OP_LIST &&
3241 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3242 o->op_private & OPpLVAL_INTRO)
3245 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3246 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3247 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3250 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3253 if (o->op_type == OP_RV2SV)
3260 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3265 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3266 return newLOGOP(optype, 0,
3267 mod(scalar(left), optype),
3268 newUNOP(OP_SASSIGN, 0, scalar(right)));
3271 return newBINOP(optype, OPf_STACKED,
3272 mod(scalar(left), optype), scalar(right));
3276 if (is_list_assignment(left)) {
3280 /* Grandfathering $[ assignment here. Bletch.*/
3281 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3282 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3283 left = mod(left, OP_AASSIGN);
3286 else if (left->op_type == OP_CONST) {
3287 /* Result of assignment is always 1 (or we'd be dead already) */
3288 return newSVOP(OP_CONST, 0, newSViv(1));
3290 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3291 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3292 && right->op_type == OP_STUB
3293 && (left->op_private & OPpLVAL_INTRO))
3296 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3299 curop = list(force_list(left));
3300 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3301 o->op_private = (U8)(0 | (flags >> 8));
3303 /* PL_generation sorcery:
3304 * an assignment like ($a,$b) = ($c,$d) is easier than
3305 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3306 * To detect whether there are common vars, the global var
3307 * PL_generation is incremented for each assign op we compile.
3308 * Then, while compiling the assign op, we run through all the
3309 * variables on both sides of the assignment, setting a spare slot
3310 * in each of them to PL_generation. If any of them already have
3311 * that value, we know we've got commonality. We could use a
3312 * single bit marker, but then we'd have to make 2 passes, first
3313 * to clear the flag, then to test and set it. To find somewhere
3314 * to store these values, evil chicanery is done with SvCUR().
3317 if (!(left->op_private & OPpLVAL_INTRO)) {
3320 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3321 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3322 if (curop->op_type == OP_GV) {
3323 GV *gv = cGVOPx_gv(curop);
3324 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3326 SvCUR_set(gv, PL_generation);
3328 else if (curop->op_type == OP_PADSV ||
3329 curop->op_type == OP_PADAV ||
3330 curop->op_type == OP_PADHV ||
3331 curop->op_type == OP_PADANY)
3333 if (PAD_COMPNAME_GEN(curop->op_targ)
3334 == (STRLEN)PL_generation)
3336 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3339 else if (curop->op_type == OP_RV2CV)
3341 else if (curop->op_type == OP_RV2SV ||
3342 curop->op_type == OP_RV2AV ||
3343 curop->op_type == OP_RV2HV ||
3344 curop->op_type == OP_RV2GV) {
3345 if (lastop->op_type != OP_GV) /* funny deref? */
3348 else if (curop->op_type == OP_PUSHRE) {
3349 if (((PMOP*)curop)->op_pmreplroot) {
3351 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3352 ((PMOP*)curop)->op_pmreplroot));
3354 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3356 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3358 SvCUR_set(gv, PL_generation);
3367 o->op_private |= OPpASSIGN_COMMON;
3369 if (right && right->op_type == OP_SPLIT) {
3371 if ((tmpop = ((LISTOP*)right)->op_first) &&
3372 tmpop->op_type == OP_PUSHRE)
3374 PMOP *pm = (PMOP*)tmpop;
3375 if (left->op_type == OP_RV2AV &&
3376 !(left->op_private & OPpLVAL_INTRO) &&
3377 !(o->op_private & OPpASSIGN_COMMON) )
3379 tmpop = ((UNOP*)left)->op_first;
3380 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3382 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3383 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3385 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3386 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3388 pm->op_pmflags |= PMf_ONCE;
3389 tmpop = cUNOPo->op_first; /* to list (nulled) */
3390 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3391 tmpop->op_sibling = Nullop; /* don't free split */
3392 right->op_next = tmpop->op_next; /* fix starting loc */
3393 op_free(o); /* blow off assign */
3394 right->op_flags &= ~OPf_WANT;
3395 /* "I don't know and I don't care." */
3400 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3401 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3403 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3405 sv_setiv(sv, PL_modcount+1);
3413 right = newOP(OP_UNDEF, 0);
3414 if (right->op_type == OP_READLINE) {
3415 right->op_flags |= OPf_STACKED;
3416 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3419 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3420 o = newBINOP(OP_SASSIGN, flags,
3421 scalar(right), mod(scalar(left), OP_SASSIGN) );
3425 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3432 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3435 const U32 seq = intro_my();
3438 NewOp(1101, cop, 1, COP);
3439 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3440 cop->op_type = OP_DBSTATE;
3441 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3444 cop->op_type = OP_NEXTSTATE;
3445 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3447 cop->op_flags = (U8)flags;
3448 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3450 cop->op_private |= NATIVE_HINTS;
3452 PL_compiling.op_private = cop->op_private;
3453 cop->op_next = (OP*)cop;
3456 cop->cop_label = label;
3457 PL_hints |= HINT_BLOCK_SCOPE;
3460 cop->cop_arybase = PL_curcop->cop_arybase;
3461 if (specialWARN(PL_curcop->cop_warnings))
3462 cop->cop_warnings = PL_curcop->cop_warnings ;
3464 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3465 if (specialCopIO(PL_curcop->cop_io))
3466 cop->cop_io = PL_curcop->cop_io;
3468 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3471 if (PL_copline == NOLINE)
3472 CopLINE_set(cop, CopLINE(PL_curcop));
3474 CopLINE_set(cop, PL_copline);
3475 PL_copline = NOLINE;
3478 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3480 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3482 CopSTASH_set(cop, PL_curstash);
3484 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3485 SV ** const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3486 if (svp && *svp != &PL_sv_undef ) {
3487 (void)SvIOK_on(*svp);
3488 SvIV_set(*svp, PTR2IV(cop));
3492 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3497 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3500 return new_logop(type, flags, &first, &other);
3504 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3509 OP *first = *firstp;
3510 OP * const other = *otherp;
3512 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3513 return newBINOP(type, flags, scalar(first), scalar(other));
3515 scalarboolean(first);
3516 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3517 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3518 if (type == OP_AND || type == OP_OR) {
3524 first = *firstp = cUNOPo->op_first;
3526 first->op_next = o->op_next;
3527 cUNOPo->op_first = Nullop;
3531 if (first->op_type == OP_CONST) {
3532 if (first->op_private & OPpCONST_STRICT)
3533 no_bareword_allowed(first);
3534 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3535 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3536 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3537 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3538 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3541 if (other->op_type == OP_CONST)
3542 other->op_private |= OPpCONST_SHORTCIRCUIT;
3546 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3547 const OP *o2 = other;
3548 if ( ! (o2->op_type == OP_LIST
3549 && (( o2 = cUNOPx(o2)->op_first))
3550 && o2->op_type == OP_PUSHMARK
3551 && (( o2 = o2->op_sibling)) )
3554 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3555 || o2->op_type == OP_PADHV)
3556 && o2->op_private & OPpLVAL_INTRO
3557 && ckWARN(WARN_DEPRECATED))
3559 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3560 "Deprecated use of my() in false conditional");
3565 if (first->op_type == OP_CONST)
3566 first->op_private |= OPpCONST_SHORTCIRCUIT;
3570 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3571 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3573 const OP * const k1 = ((UNOP*)first)->op_first;
3574 const OP * const k2 = k1->op_sibling;
3576 switch (first->op_type)
3579 if (k2 && k2->op_type == OP_READLINE
3580 && (k2->op_flags & OPf_STACKED)
3581 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3583 warnop = k2->op_type;
3588 if (k1->op_type == OP_READDIR
3589 || k1->op_type == OP_GLOB
3590 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3591 || k1->op_type == OP_EACH)
3593 warnop = ((k1->op_type == OP_NULL)
3594 ? (OPCODE)k1->op_targ : k1->op_type);
3599 const line_t oldline = CopLINE(PL_curcop);
3600 CopLINE_set(PL_curcop, PL_copline);
3601 Perl_warner(aTHX_ packWARN(WARN_MISC),
3602 "Value of %s%s can be \"0\"; test with defined()",
3604 ((warnop == OP_READLINE || warnop == OP_GLOB)
3605 ? " construct" : "() operator"));
3606 CopLINE_set(PL_curcop, oldline);
3613 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3614 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3616 NewOp(1101, logop, 1, LOGOP);
3618 logop->op_type = (OPCODE)type;
3619 logop->op_ppaddr = PL_ppaddr[type];
3620 logop->op_first = first;
3621 logop->op_flags = flags | OPf_KIDS;
3622 logop->op_other = LINKLIST(other);
3623 logop->op_private = (U8)(1 | (flags >> 8));
3625 /* establish postfix order */
3626 logop->op_next = LINKLIST(first);
3627 first->op_next = (OP*)logop;
3628 first->op_sibling = other;
3630 CHECKOP(type,logop);
3632 o = newUNOP(OP_NULL, 0, (OP*)logop);
3639 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3647 return newLOGOP(OP_AND, 0, first, trueop);
3649 return newLOGOP(OP_OR, 0, first, falseop);
3651 scalarboolean(first);
3652 if (first->op_type == OP_CONST) {
3653 if (first->op_private & OPpCONST_BARE &&
3654 first->op_private & OPpCONST_STRICT) {
3655 no_bareword_allowed(first);
3657 if (SvTRUE(((SVOP*)first)->op_sv)) {
3668 NewOp(1101, logop, 1, LOGOP);
3669 logop->op_type = OP_COND_EXPR;
3670 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3671 logop->op_first = first;
3672 logop->op_flags = flags | OPf_KIDS;
3673 logop->op_private = (U8)(1 | (flags >> 8));
3674 logop->op_other = LINKLIST(trueop);
3675 logop->op_next = LINKLIST(falseop);
3677 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3680 /* establish postfix order */
3681 start = LINKLIST(first);
3682 first->op_next = (OP*)logop;
3684 first->op_sibling = trueop;
3685 trueop->op_sibling = falseop;
3686 o = newUNOP(OP_NULL, 0, (OP*)logop);
3688 trueop->op_next = falseop->op_next = o;
3695 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3704 NewOp(1101, range, 1, LOGOP);
3706 range->op_type = OP_RANGE;
3707 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3708 range->op_first = left;
3709 range->op_flags = OPf_KIDS;
3710 leftstart = LINKLIST(left);
3711 range->op_other = LINKLIST(right);
3712 range->op_private = (U8)(1 | (flags >> 8));
3714 left->op_sibling = right;
3716 range->op_next = (OP*)range;
3717 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3718 flop = newUNOP(OP_FLOP, 0, flip);
3719 o = newUNOP(OP_NULL, 0, flop);
3721 range->op_next = leftstart;
3723 left->op_next = flip;
3724 right->op_next = flop;
3726 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3727 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3728 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3729 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3731 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3732 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3735 if (!flip->op_private || !flop->op_private)
3736 linklist(o); /* blow off optimizer unless constant */
3742 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3746 const bool once = block && block->op_flags & OPf_SPECIAL &&
3747 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3749 PERL_UNUSED_ARG(debuggable);
3752 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3753 return block; /* do {} while 0 does once */
3754 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3755 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3756 expr = newUNOP(OP_DEFINED, 0,
3757 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3758 } else if (expr->op_flags & OPf_KIDS) {
3759 const OP * const k1 = ((UNOP*)expr)->op_first;
3760 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3761 switch (expr->op_type) {
3763 if (k2 && k2->op_type == OP_READLINE
3764 && (k2->op_flags & OPf_STACKED)
3765 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3766 expr = newUNOP(OP_DEFINED, 0, expr);
3770 if (k1->op_type == OP_READDIR
3771 || k1->op_type == OP_GLOB
3772 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3773 || k1->op_type == OP_EACH)
3774 expr = newUNOP(OP_DEFINED, 0, expr);
3780 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3781 * op, in listop. This is wrong. [perl #27024] */
3783 block = newOP(OP_NULL, 0);
3784 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3785 o = new_logop(OP_AND, 0, &expr, &listop);
3788 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3790 if (once && o != listop)
3791 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3794 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3796 o->op_flags |= flags;
3798 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3803 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3804 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3813 PERL_UNUSED_ARG(debuggable);
3816 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3817 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3818 expr = newUNOP(OP_DEFINED, 0,
3819 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3820 } else if (expr->op_flags & OPf_KIDS) {
3821 const OP * const k1 = ((UNOP*)expr)->op_first;
3822 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3823 switch (expr->op_type) {
3825 if (k2 && k2->op_type == OP_READLINE
3826 && (k2->op_flags & OPf_STACKED)
3827 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3828 expr = newUNOP(OP_DEFINED, 0, expr);
3832 if (k1->op_type == OP_READDIR
3833 || k1->op_type == OP_GLOB
3834 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3835 || k1->op_type == OP_EACH)
3836 expr = newUNOP(OP_DEFINED, 0, expr);
3843 block = newOP(OP_NULL, 0);
3844 else if (cont || has_my) {
3845 block = scope(block);
3849 next = LINKLIST(cont);
3852 OP *unstack = newOP(OP_UNSTACK, 0);
3855 cont = append_elem(OP_LINESEQ, cont, unstack);
3858 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3859 redo = LINKLIST(listop);
3862 PL_copline = (line_t)whileline;
3864 o = new_logop(OP_AND, 0, &expr, &listop);
3865 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3866 op_free(expr); /* oops, it's a while (0) */
3868 return Nullop; /* listop already freed by new_logop */
3871 ((LISTOP*)listop)->op_last->op_next =
3872 (o == listop ? redo : LINKLIST(o));
3878 NewOp(1101,loop,1,LOOP);
3879 loop->op_type = OP_ENTERLOOP;
3880 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3881 loop->op_private = 0;
3882 loop->op_next = (OP*)loop;
3885 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3887 loop->op_redoop = redo;
3888 loop->op_lastop = o;
3889 o->op_private |= loopflags;
3892 loop->op_nextop = next;
3894 loop->op_nextop = o;
3896 o->op_flags |= flags;
3897 o->op_private |= (flags >> 8);
3902 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3907 PADOFFSET padoff = 0;
3912 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3913 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3914 sv->op_type = OP_RV2GV;
3915 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3917 else if (sv->op_type == OP_PADSV) { /* private variable */
3918 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3919 padoff = sv->op_targ;
3924 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3925 padoff = sv->op_targ;
3927 iterflags |= OPf_SPECIAL;
3932 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3935 const I32 offset = pad_findmy("$_");
3936 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3937 sv = newGVOP(OP_GV, 0, PL_defgv);
3943 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3944 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3945 iterflags |= OPf_STACKED;
3947 else if (expr->op_type == OP_NULL &&
3948 (expr->op_flags & OPf_KIDS) &&
3949 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3951 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3952 * set the STACKED flag to indicate that these values are to be
3953 * treated as min/max values by 'pp_iterinit'.
3955 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3956 LOGOP* range = (LOGOP*) flip->op_first;
3957 OP* const left = range->op_first;
3958 OP* const right = left->op_sibling;
3961 range->op_flags &= ~OPf_KIDS;
3962 range->op_first = Nullop;
3964 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3965 listop->op_first->op_next = range->op_next;
3966 left->op_next = range->op_other;
3967 right->op_next = (OP*)listop;
3968 listop->op_next = listop->op_first;
3971 expr = (OP*)(listop);
3973 iterflags |= OPf_STACKED;
3976 expr = mod(force_list(expr), OP_GREPSTART);
3979 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3980 append_elem(OP_LIST, expr, scalar(sv))));
3981 assert(!loop->op_next);
3982 /* for my $x () sets OPpLVAL_INTRO;
3983 * for our $x () sets OPpOUR_INTRO */
3984 loop->op_private = (U8)iterpflags;
3985 #ifdef PL_OP_SLAB_ALLOC
3988 NewOp(1234,tmp,1,LOOP);
3989 Copy(loop,tmp,1,LISTOP);
3994 Renew(loop, 1, LOOP);
3996 loop->op_targ = padoff;
3997 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
3998 PL_copline = forline;
3999 return newSTATEOP(0, label, wop);
4003 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4007 if (type != OP_GOTO || label->op_type == OP_CONST) {
4008 /* "last()" means "last" */
4009 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4010 o = newOP(type, OPf_SPECIAL);
4012 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4013 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4019 /* Check whether it's going to be a goto &function */
4020 if (label->op_type == OP_ENTERSUB
4021 && !(label->op_flags & OPf_STACKED))
4022 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4023 o = newUNOP(type, OPf_STACKED, label);
4025 PL_hints |= HINT_BLOCK_SCOPE;
4030 =for apidoc cv_undef
4032 Clear out all the active components of a CV. This can happen either
4033 by an explicit C<undef &foo>, or by the reference count going to zero.
4034 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4035 children can still follow the full lexical scope chain.
4041 Perl_cv_undef(pTHX_ CV *cv)
4045 if (CvFILE(cv) && !CvXSUB(cv)) {
4046 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4047 Safefree(CvFILE(cv));
4052 if (!CvXSUB(cv) && CvROOT(cv)) {
4054 Perl_croak(aTHX_ "Can't undef active subroutine");
4057 PAD_SAVE_SETNULLPAD();
4059 op_free(CvROOT(cv));
4060 CvROOT(cv) = Nullop;
4061 CvSTART(cv) = Nullop;
4064 SvPOK_off((SV*)cv); /* forget prototype */
4069 /* remove CvOUTSIDE unless this is an undef rather than a free */
4070 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4071 if (!CvWEAKOUTSIDE(cv))
4072 SvREFCNT_dec(CvOUTSIDE(cv));
4073 CvOUTSIDE(cv) = Nullcv;
4076 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4082 /* delete all flags except WEAKOUTSIDE */
4083 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4087 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4089 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4090 SV* const msg = sv_newmortal();
4094 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4095 sv_setpv(msg, "Prototype mismatch:");
4097 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4099 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4101 Perl_sv_catpv(aTHX_ msg, ": none");
4102 sv_catpv(msg, " vs ");
4104 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4106 sv_catpv(msg, "none");
4107 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4111 static void const_sv_xsub(pTHX_ CV* cv);
4115 =head1 Optree Manipulation Functions
4117 =for apidoc cv_const_sv
4119 If C<cv> is a constant sub eligible for inlining. returns the constant
4120 value returned by the sub. Otherwise, returns NULL.
4122 Constant subs can be created with C<newCONSTSUB> or as described in
4123 L<perlsub/"Constant Functions">.
4128 Perl_cv_const_sv(pTHX_ CV *cv)
4130 if (!cv || !CvCONST(cv))
4132 return (SV*)CvXSUBANY(cv).any_ptr;
4135 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4136 * Can be called in 3 ways:
4139 * look for a single OP_CONST with attached value: return the value
4141 * cv && CvCLONE(cv) && !CvCONST(cv)
4143 * examine the clone prototype, and if contains only a single
4144 * OP_CONST referencing a pad const, or a single PADSV referencing
4145 * an outer lexical, return a non-zero value to indicate the CV is
4146 * a candidate for "constizing" at clone time
4150 * We have just cloned an anon prototype that was marked as a const
4151 * candidiate. Try to grab the current value, and in the case of
4152 * PADSV, ignore it if it has multiple references. Return the value.
4156 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4163 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4164 o = cLISTOPo->op_first->op_sibling;
4166 for (; o; o = o->op_next) {
4167 const OPCODE type = o->op_type;
4169 if (sv && o->op_next == o)
4171 if (o->op_next != o) {
4172 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4174 if (type == OP_DBSTATE)
4177 if (type == OP_LEAVESUB || type == OP_RETURN)
4181 if (type == OP_CONST && cSVOPo->op_sv)
4183 else if (cv && type == OP_CONST) {
4184 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4188 else if (cv && type == OP_PADSV) {
4189 if (CvCONST(cv)) { /* newly cloned anon */
4190 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4191 /* the candidate should have 1 ref from this pad and 1 ref
4192 * from the parent */
4193 if (!sv || SvREFCNT(sv) != 2)
4200 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4201 sv = &PL_sv_undef; /* an arbitrary non-null value */
4212 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4214 PERL_UNUSED_ARG(floor);
4224 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4228 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4230 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4234 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4245 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4248 assert(proto->op_type == OP_CONST);
4249 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4254 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4255 SV * const sv = sv_newmortal();
4256 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4257 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4258 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4259 aname = SvPVX_const(sv);
4264 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4265 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4266 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4267 : gv_fetchpv(aname ? aname
4268 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4269 gv_fetch_flags, SVt_PVCV);
4278 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4279 maximum a prototype before. */
4280 if (SvTYPE(gv) > SVt_NULL) {
4281 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4282 && ckWARN_d(WARN_PROTOTYPE))
4284 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4286 cv_ckproto((CV*)gv, NULL, ps);
4289 sv_setpvn((SV*)gv, ps, ps_len);
4291 sv_setiv((SV*)gv, -1);
4292 SvREFCNT_dec(PL_compcv);
4293 cv = PL_compcv = NULL;
4294 PL_sub_generation++;
4298 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4300 #ifdef GV_UNIQUE_CHECK
4301 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4302 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4306 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4309 const_sv = op_const_sv(block, Nullcv);
4312 const bool exists = CvROOT(cv) || CvXSUB(cv);
4314 #ifdef GV_UNIQUE_CHECK
4315 if (exists && GvUNIQUE(gv)) {
4316 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4320 /* if the subroutine doesn't exist and wasn't pre-declared
4321 * with a prototype, assume it will be AUTOLOADed,
4322 * skipping the prototype check
4324 if (exists || SvPOK(cv))
4325 cv_ckproto(cv, gv, ps);
4326 /* already defined (or promised)? */
4327 if (exists || GvASSUMECV(gv)) {
4328 if (!block && !attrs) {
4329 if (CvFLAGS(PL_compcv)) {
4330 /* might have had built-in attrs applied */
4331 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4333 /* just a "sub foo;" when &foo is already defined */
4334 SAVEFREESV(PL_compcv);
4337 /* ahem, death to those who redefine active sort subs */
4338 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4339 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4341 if (ckWARN(WARN_REDEFINE)
4343 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4345 const line_t oldline = CopLINE(PL_curcop);
4346 if (PL_copline != NOLINE)
4347 CopLINE_set(PL_curcop, PL_copline);
4348 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4349 CvCONST(cv) ? "Constant subroutine %s redefined"
4350 : "Subroutine %s redefined", name);
4351 CopLINE_set(PL_curcop, oldline);
4359 (void)SvREFCNT_inc(const_sv);
4361 assert(!CvROOT(cv) && !CvCONST(cv));
4362 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4363 CvXSUBANY(cv).any_ptr = const_sv;
4364 CvXSUB(cv) = const_sv_xsub;
4369 cv = newCONSTSUB(NULL, name, const_sv);
4372 SvREFCNT_dec(PL_compcv);
4374 PL_sub_generation++;
4381 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4382 * before we clobber PL_compcv.
4386 /* Might have had built-in attributes applied -- propagate them. */
4387 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4388 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4389 stash = GvSTASH(CvGV(cv));
4390 else if (CvSTASH(cv))
4391 stash = CvSTASH(cv);
4393 stash = PL_curstash;
4396 /* possibly about to re-define existing subr -- ignore old cv */
4397 rcv = (SV*)PL_compcv;
4398 if (name && GvSTASH(gv))
4399 stash = GvSTASH(gv);
4401 stash = PL_curstash;
4403 apply_attrs(stash, rcv, attrs, FALSE);
4405 if (cv) { /* must reuse cv if autoloaded */
4407 /* got here with just attrs -- work done, so bug out */
4408 SAVEFREESV(PL_compcv);
4411 /* transfer PL_compcv to cv */
4413 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4414 if (!CvWEAKOUTSIDE(cv))
4415 SvREFCNT_dec(CvOUTSIDE(cv));
4416 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4417 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4418 CvOUTSIDE(PL_compcv) = 0;
4419 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4420 CvPADLIST(PL_compcv) = 0;
4421 /* inner references to PL_compcv must be fixed up ... */
4422 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4423 /* ... before we throw it away */
4424 SvREFCNT_dec(PL_compcv);
4426 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4427 ++PL_sub_generation;
4434 PL_sub_generation++;
4438 CvFILE_set_from_cop(cv, PL_curcop);
4439 CvSTASH(cv) = PL_curstash;
4442 sv_setpvn((SV*)cv, ps, ps_len);
4444 if (PL_error_count) {
4448 const char *s = strrchr(name, ':');
4450 if (strEQ(s, "BEGIN")) {
4451 const char not_safe[] =
4452 "BEGIN not safe after errors--compilation aborted";
4453 if (PL_in_eval & EVAL_KEEPERR)
4454 Perl_croak(aTHX_ not_safe);
4456 /* force display of errors found but not reported */
4457 sv_catpv(ERRSV, not_safe);
4458 Perl_croak(aTHX_ "%"SVf, ERRSV);
4467 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4468 mod(scalarseq(block), OP_LEAVESUBLV));
4471 /* This makes sub {}; work as expected. */
4472 if (block->op_type == OP_STUB) {
4474 block = newSTATEOP(0, Nullch, 0);
4476 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4478 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4479 OpREFCNT_set(CvROOT(cv), 1);
4480 CvSTART(cv) = LINKLIST(CvROOT(cv));
4481 CvROOT(cv)->op_next = 0;
4482 CALL_PEEP(CvSTART(cv));
4484 /* now that optimizer has done its work, adjust pad values */
4486 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4489 assert(!CvCONST(cv));
4490 if (ps && !*ps && op_const_sv(block, cv))
4494 if (name || aname) {
4496 const char *tname = (name ? name : aname);
4498 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4499 SV *sv = NEWSV(0,0);
4500 SV *tmpstr = sv_newmortal();
4501 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4505 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4507 (long)PL_subline, (long)CopLINE(PL_curcop));
4508 gv_efullname3(tmpstr, gv, Nullch);
4509 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4510 hv = GvHVn(db_postponed);
4511 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
4512 && (pcv = GvCV(db_postponed)))
4518 call_sv((SV*)pcv, G_DISCARD);
4522 if ((s = strrchr(tname,':')))
4527 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4530 if (strEQ(s, "BEGIN") && !PL_error_count) {
4531 const I32 oldscope = PL_scopestack_ix;
4533 SAVECOPFILE(&PL_compiling);
4534 SAVECOPLINE(&PL_compiling);
4537 PL_beginav = newAV();
4538 DEBUG_x( dump_sub(gv) );
4539 av_push(PL_beginav, (SV*)cv);
4540 GvCV(gv) = 0; /* cv has been hijacked */
4541 call_list(oldscope, PL_beginav);
4543 PL_curcop = &PL_compiling;
4544 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4547 else if (strEQ(s, "END") && !PL_error_count) {
4550 DEBUG_x( dump_sub(gv) );
4551 av_unshift(PL_endav, 1);
4552 av_store(PL_endav, 0, (SV*)cv);
4553 GvCV(gv) = 0; /* cv has been hijacked */
4555 else if (strEQ(s, "CHECK") && !PL_error_count) {
4557 PL_checkav = newAV();
4558 DEBUG_x( dump_sub(gv) );
4559 if (PL_main_start && ckWARN(WARN_VOID))
4560 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4561 av_unshift(PL_checkav, 1);
4562 av_store(PL_checkav, 0, (SV*)cv);
4563 GvCV(gv) = 0; /* cv has been hijacked */
4565 else if (strEQ(s, "INIT") && !PL_error_count) {
4567 PL_initav = newAV();
4568 DEBUG_x( dump_sub(gv) );
4569 if (PL_main_start && ckWARN(WARN_VOID))
4570 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4571 av_push(PL_initav, (SV*)cv);
4572 GvCV(gv) = 0; /* cv has been hijacked */
4577 PL_copline = NOLINE;
4582 /* XXX unsafe for threads if eval_owner isn't held */
4584 =for apidoc newCONSTSUB
4586 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4587 eligible for inlining at compile-time.
4593 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4600 SAVECOPLINE(PL_curcop);
4601 CopLINE_set(PL_curcop, PL_copline);
4604 PL_hints &= ~HINT_BLOCK_SCOPE;
4607 SAVESPTR(PL_curstash);
4608 SAVECOPSTASH(PL_curcop);
4609 PL_curstash = stash;
4610 CopSTASH_set(PL_curcop,stash);
4613 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4614 CvXSUBANY(cv).any_ptr = sv;
4616 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4619 CopSTASH_free(PL_curcop);
4627 =for apidoc U||newXS
4629 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4635 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4637 GV * const gv = gv_fetchpv(name ? name :
4638 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4639 GV_ADDMULTI, SVt_PVCV);
4643 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4645 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4647 /* just a cached method */
4651 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4652 /* already defined (or promised) */
4653 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4654 if (ckWARN(WARN_REDEFINE)) {
4655 GV * const gvcv = CvGV(cv);
4657 HV * const stash = GvSTASH(gvcv);
4659 const char *name = HvNAME_get(stash);
4660 if ( strEQ(name,"autouse") ) {
4661 const line_t oldline = CopLINE(PL_curcop);
4662 if (PL_copline != NOLINE)
4663 CopLINE_set(PL_curcop, PL_copline);
4664 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4665 CvCONST(cv) ? "Constant subroutine %s redefined"
4666 : "Subroutine %s redefined"
4668 CopLINE_set(PL_curcop, oldline);
4678 if (cv) /* must reuse cv if autoloaded */
4681 cv = (CV*)NEWSV(1105,0);
4682 sv_upgrade((SV *)cv, SVt_PVCV);
4686 PL_sub_generation++;
4690 (void)gv_fetchfile(filename);
4691 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4692 an external constant string */
4693 CvXSUB(cv) = subaddr;
4696 const char *s = strrchr(name,':');
4702 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4705 if (strEQ(s, "BEGIN")) {
4707 PL_beginav = newAV();
4708 av_push(PL_beginav, (SV*)cv);
4709 GvCV(gv) = 0; /* cv has been hijacked */
4711 else if (strEQ(s, "END")) {
4714 av_unshift(PL_endav, 1);
4715 av_store(PL_endav, 0, (SV*)cv);
4716 GvCV(gv) = 0; /* cv has been hijacked */
4718 else if (strEQ(s, "CHECK")) {
4720 PL_checkav = newAV();
4721 if (PL_main_start && ckWARN(WARN_VOID))
4722 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4723 av_unshift(PL_checkav, 1);
4724 av_store(PL_checkav, 0, (SV*)cv);
4725 GvCV(gv) = 0; /* cv has been hijacked */
4727 else if (strEQ(s, "INIT")) {
4729 PL_initav = newAV();
4730 if (PL_main_start && ckWARN(WARN_VOID))
4731 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4732 av_push(PL_initav, (SV*)cv);
4733 GvCV(gv) = 0; /* cv has been hijacked */
4744 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4750 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4752 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4754 #ifdef GV_UNIQUE_CHECK
4756 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4760 if ((cv = GvFORM(gv))) {
4761 if (ckWARN(WARN_REDEFINE)) {
4762 const line_t oldline = CopLINE(PL_curcop);
4763 if (PL_copline != NOLINE)
4764 CopLINE_set(PL_curcop, PL_copline);
4765 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4766 o ? "Format %"SVf" redefined"
4767 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4768 CopLINE_set(PL_curcop, oldline);
4775 CvFILE_set_from_cop(cv, PL_curcop);
4778 pad_tidy(padtidy_FORMAT);
4779 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4780 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4781 OpREFCNT_set(CvROOT(cv), 1);
4782 CvSTART(cv) = LINKLIST(CvROOT(cv));
4783 CvROOT(cv)->op_next = 0;
4784 CALL_PEEP(CvSTART(cv));
4786 PL_copline = NOLINE;
4791 Perl_newANONLIST(pTHX_ OP *o)
4793 return newUNOP(OP_REFGEN, 0,
4794 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4798 Perl_newANONHASH(pTHX_ OP *o)
4800 return newUNOP(OP_REFGEN, 0,
4801 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4805 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4807 return newANONATTRSUB(floor, proto, Nullop, block);
4811 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4813 return newUNOP(OP_REFGEN, 0,
4814 newSVOP(OP_ANONCODE, 0,
4815 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4819 Perl_oopsAV(pTHX_ OP *o)
4822 switch (o->op_type) {
4824 o->op_type = OP_PADAV;
4825 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4826 return ref(o, OP_RV2AV);
4829 o->op_type = OP_RV2AV;
4830 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4835 if (ckWARN_d(WARN_INTERNAL))
4836 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4843 Perl_oopsHV(pTHX_ OP *o)
4846 switch (o->op_type) {
4849 o->op_type = OP_PADHV;
4850 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4851 return ref(o, OP_RV2HV);
4855 o->op_type = OP_RV2HV;
4856 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4861 if (ckWARN_d(WARN_INTERNAL))
4862 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4869 Perl_newAVREF(pTHX_ OP *o)
4872 if (o->op_type == OP_PADANY) {
4873 o->op_type = OP_PADAV;
4874 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4877 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4878 && ckWARN(WARN_DEPRECATED)) {
4879 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4880 "Using an array as a reference is deprecated");
4882 return newUNOP(OP_RV2AV, 0, scalar(o));
4886 Perl_newGVREF(pTHX_ I32 type, OP *o)
4888 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4889 return newUNOP(OP_NULL, 0, o);
4890 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4894 Perl_newHVREF(pTHX_ OP *o)
4897 if (o->op_type == OP_PADANY) {
4898 o->op_type = OP_PADHV;
4899 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4902 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4903 && ckWARN(WARN_DEPRECATED)) {
4904 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4905 "Using a hash as a reference is deprecated");
4907 return newUNOP(OP_RV2HV, 0, scalar(o));
4911 Perl_oopsCV(pTHX_ OP *o)
4913 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4916 NORETURN_FUNCTION_END;
4920 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4922 return newUNOP(OP_RV2CV, flags, scalar(o));
4926 Perl_newSVREF(pTHX_ OP *o)
4929 if (o->op_type == OP_PADANY) {
4930 o->op_type = OP_PADSV;
4931 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4934 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4935 o->op_flags |= OPpDONE_SVREF;
4938 return newUNOP(OP_RV2SV, 0, scalar(o));
4941 /* Check routines. See the comments at the top of this file for details
4942 * on when these are called */
4945 Perl_ck_anoncode(pTHX_ OP *o)
4947 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4948 cSVOPo->op_sv = Nullsv;
4953 Perl_ck_bitop(pTHX_ OP *o)
4955 #define OP_IS_NUMCOMPARE(op) \
4956 ((op) == OP_LT || (op) == OP_I_LT || \
4957 (op) == OP_GT || (op) == OP_I_GT || \
4958 (op) == OP_LE || (op) == OP_I_LE || \
4959 (op) == OP_GE || (op) == OP_I_GE || \
4960 (op) == OP_EQ || (op) == OP_I_EQ || \
4961 (op) == OP_NE || (op) == OP_I_NE || \
4962 (op) == OP_NCMP || (op) == OP_I_NCMP)
4963 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4964 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4965 && (o->op_type == OP_BIT_OR
4966 || o->op_type == OP_BIT_AND
4967 || o->op_type == OP_BIT_XOR))
4969 const OP * const left = cBINOPo->op_first;
4970 const OP * const right = left->op_sibling;
4971 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4972 (left->op_flags & OPf_PARENS) == 0) ||
4973 (OP_IS_NUMCOMPARE(right->op_type) &&
4974 (right->op_flags & OPf_PARENS) == 0))
4975 if (ckWARN(WARN_PRECEDENCE))
4976 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4977 "Possible precedence problem on bitwise %c operator",
4978 o->op_type == OP_BIT_OR ? '|'
4979 : o->op_type == OP_BIT_AND ? '&' : '^'
4986 Perl_ck_concat(pTHX_ OP *o)
4988 const OP *kid = cUNOPo->op_first;
4989 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4990 !(kUNOP->op_first->op_flags & OPf_MOD))
4991 o->op_flags |= OPf_STACKED;
4996 Perl_ck_spair(pTHX_ OP *o)
4999 if (o->op_flags & OPf_KIDS) {
5002 const OPCODE type = o->op_type;
5003 o = modkids(ck_fun(o), type);
5004 kid = cUNOPo->op_first;
5005 newop = kUNOP->op_first->op_sibling;
5007 (newop->op_sibling ||
5008 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5009 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5010 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5014 op_free(kUNOP->op_first);
5015 kUNOP->op_first = newop;
5017 o->op_ppaddr = PL_ppaddr[++o->op_type];
5022 Perl_ck_delete(pTHX_ OP *o)
5026 if (o->op_flags & OPf_KIDS) {
5027 OP *kid = cUNOPo->op_first;
5028 switch (kid->op_type) {
5030 o->op_flags |= OPf_SPECIAL;
5033 o->op_private |= OPpSLICE;
5036 o->op_flags |= OPf_SPECIAL;
5041 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5050 Perl_ck_die(pTHX_ OP *o)
5053 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5059 Perl_ck_eof(pTHX_ OP *o)
5061 const I32 type = o->op_type;
5063 if (o->op_flags & OPf_KIDS) {
5064 if (cLISTOPo->op_first->op_type == OP_STUB) {
5066 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5074 Perl_ck_eval(pTHX_ OP *o)
5077 PL_hints |= HINT_BLOCK_SCOPE;
5078 if (o->op_flags & OPf_KIDS) {
5079 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5082 o->op_flags &= ~OPf_KIDS;
5085 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5088 cUNOPo->op_first = 0;
5091 NewOp(1101, enter, 1, LOGOP);
5092 enter->op_type = OP_ENTERTRY;
5093 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5094 enter->op_private = 0;
5096 /* establish postfix order */
5097 enter->op_next = (OP*)enter;
5099 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5100 o->op_type = OP_LEAVETRY;
5101 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5102 enter->op_other = o;
5112 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5114 o->op_targ = (PADOFFSET)PL_hints;
5119 Perl_ck_exit(pTHX_ OP *o)
5122 HV *table = GvHV(PL_hintgv);
5124 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5125 if (svp && *svp && SvTRUE(*svp))
5126 o->op_private |= OPpEXIT_VMSISH;
5128 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5134 Perl_ck_exec(pTHX_ OP *o)
5136 if (o->op_flags & OPf_STACKED) {
5139 kid = cUNOPo->op_first->op_sibling;
5140 if (kid->op_type == OP_RV2GV)
5149 Perl_ck_exists(pTHX_ OP *o)
5152 if (o->op_flags & OPf_KIDS) {
5153 OP * const kid = cUNOPo->op_first;
5154 if (kid->op_type == OP_ENTERSUB) {
5155 (void) ref(kid, o->op_type);
5156 if (kid->op_type != OP_RV2CV && !PL_error_count)
5157 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5159 o->op_private |= OPpEXISTS_SUB;
5161 else if (kid->op_type == OP_AELEM)
5162 o->op_flags |= OPf_SPECIAL;
5163 else if (kid->op_type != OP_HELEM)
5164 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5172 Perl_ck_rvconst(pTHX_ register OP *o)
5175 SVOP *kid = (SVOP*)cUNOPo->op_first;
5177 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5178 if (kid->op_type == OP_CONST) {
5181 SV * const kidsv = kid->op_sv;
5183 /* Is it a constant from cv_const_sv()? */
5184 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5185 SV *rsv = SvRV(kidsv);
5186 const int svtype = SvTYPE(rsv);
5187 const char *badtype = Nullch;
5189 switch (o->op_type) {
5191 if (svtype > SVt_PVMG)
5192 badtype = "a SCALAR";
5195 if (svtype != SVt_PVAV)
5196 badtype = "an ARRAY";
5199 if (svtype != SVt_PVHV)
5203 if (svtype != SVt_PVCV)
5208 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5211 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5212 const char *badthing = Nullch;
5213 switch (o->op_type) {
5215 badthing = "a SCALAR";
5218 badthing = "an ARRAY";
5221 badthing = "a HASH";
5226 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5230 * This is a little tricky. We only want to add the symbol if we
5231 * didn't add it in the lexer. Otherwise we get duplicate strict
5232 * warnings. But if we didn't add it in the lexer, we must at
5233 * least pretend like we wanted to add it even if it existed before,
5234 * or we get possible typo warnings. OPpCONST_ENTERED says
5235 * whether the lexer already added THIS instance of this symbol.
5237 iscv = (o->op_type == OP_RV2CV) * 2;
5239 gv = gv_fetchsv(kidsv,
5240 iscv | !(kid->op_private & OPpCONST_ENTERED),
5243 : o->op_type == OP_RV2SV
5245 : o->op_type == OP_RV2AV
5247 : o->op_type == OP_RV2HV
5250 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5252 kid->op_type = OP_GV;
5253 SvREFCNT_dec(kid->op_sv);
5255 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5256 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5257 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5259 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5261 kid->op_sv = SvREFCNT_inc(gv);
5263 kid->op_private = 0;
5264 kid->op_ppaddr = PL_ppaddr[OP_GV];
5271 Perl_ck_ftst(pTHX_ OP *o)
5274 const I32 type = o->op_type;
5276 if (o->op_flags & OPf_REF) {
5279 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5280 SVOP *kid = (SVOP*)cUNOPo->op_first;
5282 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5283 OP *newop = newGVOP(type, OPf_REF,
5284 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5290 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5291 OP_IS_FILETEST_ACCESS(o))
5292 o->op_private |= OPpFT_ACCESS;
5294 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5295 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5296 o->op_private |= OPpFT_STACKED;
5300 if (type == OP_FTTTY)
5301 o = newGVOP(type, OPf_REF, PL_stdingv);
5303 o = newUNOP(type, 0, newDEFSVOP());
5309 Perl_ck_fun(pTHX_ OP *o)
5311 const int type = o->op_type;
5312 register I32 oa = PL_opargs[type] >> OASHIFT;
5314 if (o->op_flags & OPf_STACKED) {
5315 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5318 return no_fh_allowed(o);
5321 if (o->op_flags & OPf_KIDS) {
5322 OP **tokid = &cLISTOPo->op_first;
5323 register OP *kid = cLISTOPo->op_first;
5327 if (kid->op_type == OP_PUSHMARK ||
5328 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5330 tokid = &kid->op_sibling;
5331 kid = kid->op_sibling;
5333 if (!kid && PL_opargs[type] & OA_DEFGV)
5334 *tokid = kid = newDEFSVOP();
5338 sibl = kid->op_sibling;
5341 /* list seen where single (scalar) arg expected? */
5342 if (numargs == 1 && !(oa >> 4)
5343 && kid->op_type == OP_LIST && type != OP_SCALAR)
5345 return too_many_arguments(o,PL_op_desc[type]);
5358 if ((type == OP_PUSH || type == OP_UNSHIFT)
5359 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5360 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5361 "Useless use of %s with no values",
5364 if (kid->op_type == OP_CONST &&
5365 (kid->op_private & OPpCONST_BARE))
5367 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5368 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5369 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5370 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5371 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5372 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5375 kid->op_sibling = sibl;
5378 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5379 bad_type(numargs, "array", PL_op_desc[type], kid);
5383 if (kid->op_type == OP_CONST &&
5384 (kid->op_private & OPpCONST_BARE))
5386 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5387 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5388 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5389 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5390 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5391 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5394 kid->op_sibling = sibl;
5397 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5398 bad_type(numargs, "hash", PL_op_desc[type], kid);
5403 OP *newop = newUNOP(OP_NULL, 0, kid);
5404 kid->op_sibling = 0;
5406 newop->op_next = newop;
5408 kid->op_sibling = sibl;
5413 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5414 if (kid->op_type == OP_CONST &&
5415 (kid->op_private & OPpCONST_BARE))
5417 OP *newop = newGVOP(OP_GV, 0,
5418 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5419 if (!(o->op_private & 1) && /* if not unop */
5420 kid == cLISTOPo->op_last)
5421 cLISTOPo->op_last = newop;
5425 else if (kid->op_type == OP_READLINE) {
5426 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5427 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5430 I32 flags = OPf_SPECIAL;
5434 /* is this op a FH constructor? */
5435 if (is_handle_constructor(o,numargs)) {
5436 const char *name = Nullch;
5440 /* Set a flag to tell rv2gv to vivify
5441 * need to "prove" flag does not mean something
5442 * else already - NI-S 1999/05/07
5445 if (kid->op_type == OP_PADSV) {
5446 name = PAD_COMPNAME_PV(kid->op_targ);
5447 /* SvCUR of a pad namesv can't be trusted
5448 * (see PL_generation), so calc its length
5454 else if (kid->op_type == OP_RV2SV
5455 && kUNOP->op_first->op_type == OP_GV)
5457 GV *gv = cGVOPx_gv(kUNOP->op_first);
5459 len = GvNAMELEN(gv);
5461 else if (kid->op_type == OP_AELEM
5462 || kid->op_type == OP_HELEM)
5467 if ((op = ((BINOP*)kid)->op_first)) {
5468 SV *tmpstr = Nullsv;
5470 kid->op_type == OP_AELEM ?
5472 if (((op->op_type == OP_RV2AV) ||
5473 (op->op_type == OP_RV2HV)) &&
5474 (op = ((UNOP*)op)->op_first) &&
5475 (op->op_type == OP_GV)) {
5476 /* packagevar $a[] or $h{} */
5477 GV *gv = cGVOPx_gv(op);
5485 else if (op->op_type == OP_PADAV
5486 || op->op_type == OP_PADHV) {
5487 /* lexicalvar $a[] or $h{} */
5488 const char *padname =
5489 PAD_COMPNAME_PV(op->op_targ);
5499 name = SvPV_const(tmpstr, len);
5504 name = "__ANONIO__";
5511 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5512 namesv = PAD_SVl(targ);
5513 SvUPGRADE(namesv, SVt_PV);
5515 sv_setpvn(namesv, "$", 1);
5516 sv_catpvn(namesv, name, len);
5519 kid->op_sibling = 0;
5520 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5521 kid->op_targ = targ;
5522 kid->op_private |= priv;
5524 kid->op_sibling = sibl;
5530 mod(scalar(kid), type);
5534 tokid = &kid->op_sibling;
5535 kid = kid->op_sibling;
5537 o->op_private |= numargs;
5539 return too_many_arguments(o,OP_DESC(o));
5542 else if (PL_opargs[type] & OA_DEFGV) {
5544 return newUNOP(type, 0, newDEFSVOP());
5548 while (oa & OA_OPTIONAL)
5550 if (oa && oa != OA_LIST)
5551 return too_few_arguments(o,OP_DESC(o));
5557 Perl_ck_glob(pTHX_ OP *o)
5563 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5564 append_elem(OP_GLOB, o, newDEFSVOP());
5566 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5567 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5569 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5572 #if !defined(PERL_EXTERNAL_GLOB)
5573 /* XXX this can be tightened up and made more failsafe. */
5574 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5577 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5578 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5579 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5580 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5581 GvCV(gv) = GvCV(glob_gv);
5582 (void)SvREFCNT_inc((SV*)GvCV(gv));
5583 GvIMPORTED_CV_on(gv);
5586 #endif /* PERL_EXTERNAL_GLOB */
5588 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5589 append_elem(OP_GLOB, o,
5590 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5591 o->op_type = OP_LIST;
5592 o->op_ppaddr = PL_ppaddr[OP_LIST];
5593 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5594 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5595 cLISTOPo->op_first->op_targ = 0;
5596 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5597 append_elem(OP_LIST, o,
5598 scalar(newUNOP(OP_RV2CV, 0,
5599 newGVOP(OP_GV, 0, gv)))));
5600 o = newUNOP(OP_NULL, 0, ck_subr(o));
5601 o->op_targ = OP_GLOB; /* hint at what it used to be */
5604 gv = newGVgen("main");
5606 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5612 Perl_ck_grep(pTHX_ OP *o)
5617 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5620 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5621 NewOp(1101, gwop, 1, LOGOP);
5623 if (o->op_flags & OPf_STACKED) {
5626 kid = cLISTOPo->op_first->op_sibling;
5627 if (!cUNOPx(kid)->op_next)
5628 Perl_croak(aTHX_ "panic: ck_grep");
5629 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5632 kid->op_next = (OP*)gwop;
5633 o->op_flags &= ~OPf_STACKED;
5635 kid = cLISTOPo->op_first->op_sibling;
5636 if (type == OP_MAPWHILE)
5643 kid = cLISTOPo->op_first->op_sibling;
5644 if (kid->op_type != OP_NULL)
5645 Perl_croak(aTHX_ "panic: ck_grep");
5646 kid = kUNOP->op_first;
5648 gwop->op_type = type;
5649 gwop->op_ppaddr = PL_ppaddr[type];
5650 gwop->op_first = listkids(o);
5651 gwop->op_flags |= OPf_KIDS;
5652 gwop->op_other = LINKLIST(kid);
5653 kid->op_next = (OP*)gwop;
5654 offset = pad_findmy("$_");
5655 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5656 o->op_private = gwop->op_private = 0;
5657 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5660 o->op_private = gwop->op_private = OPpGREP_LEX;
5661 gwop->op_targ = o->op_targ = offset;
5664 kid = cLISTOPo->op_first->op_sibling;
5665 if (!kid || !kid->op_sibling)
5666 return too_few_arguments(o,OP_DESC(o));
5667 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5668 mod(kid, OP_GREPSTART);
5674 Perl_ck_index(pTHX_ OP *o)
5676 if (o->op_flags & OPf_KIDS) {
5677 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5679 kid = kid->op_sibling; /* get past "big" */
5680 if (kid && kid->op_type == OP_CONST)
5681 fbm_compile(((SVOP*)kid)->op_sv, 0);
5687 Perl_ck_lengthconst(pTHX_ OP *o)
5689 /* XXX length optimization goes here */
5694 Perl_ck_lfun(pTHX_ OP *o)
5696 const OPCODE type = o->op_type;
5697 return modkids(ck_fun(o), type);
5701 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5703 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5704 switch (cUNOPo->op_first->op_type) {
5706 /* This is needed for
5707 if (defined %stash::)
5708 to work. Do not break Tk.
5710 break; /* Globals via GV can be undef */
5712 case OP_AASSIGN: /* Is this a good idea? */
5713 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5714 "defined(@array) is deprecated");
5715 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5716 "\t(Maybe you should just omit the defined()?)\n");
5719 /* This is needed for
5720 if (defined %stash::)
5721 to work. Do not break Tk.
5723 break; /* Globals via GV can be undef */
5725 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5726 "defined(%%hash) is deprecated");
5727 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5728 "\t(Maybe you should just omit the defined()?)\n");
5739 Perl_ck_rfun(pTHX_ OP *o)
5741 const OPCODE type = o->op_type;
5742 return refkids(ck_fun(o), type);
5746 Perl_ck_listiob(pTHX_ OP *o)
5750 kid = cLISTOPo->op_first;
5753 kid = cLISTOPo->op_first;
5755 if (kid->op_type == OP_PUSHMARK)
5756 kid = kid->op_sibling;
5757 if (kid && o->op_flags & OPf_STACKED)
5758 kid = kid->op_sibling;
5759 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5760 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5761 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5762 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5763 cLISTOPo->op_first->op_sibling = kid;
5764 cLISTOPo->op_last = kid;
5765 kid = kid->op_sibling;
5770 append_elem(o->op_type, o, newDEFSVOP());
5776 Perl_ck_sassign(pTHX_ OP *o)
5778 OP *kid = cLISTOPo->op_first;
5779 /* has a disposable target? */
5780 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5781 && !(kid->op_flags & OPf_STACKED)
5782 /* Cannot steal the second time! */
5783 && !(kid->op_private & OPpTARGET_MY))
5785 OP *kkid = kid->op_sibling;
5787 /* Can just relocate the target. */
5788 if (kkid && kkid->op_type == OP_PADSV
5789 && !(kkid->op_private & OPpLVAL_INTRO))
5791 kid->op_targ = kkid->op_targ;
5793 /* Now we do not need PADSV and SASSIGN. */
5794 kid->op_sibling = o->op_sibling; /* NULL */
5795 cLISTOPo->op_first = NULL;
5798 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5802 /* optimise C<my $x = undef> to C<my $x> */
5803 if (kid->op_type == OP_UNDEF) {
5804 OP *kkid = kid->op_sibling;
5805 if (kkid && kkid->op_type == OP_PADSV
5806 && (kkid->op_private & OPpLVAL_INTRO))
5808 cLISTOPo->op_first = NULL;
5809 kid->op_sibling = NULL;
5819 Perl_ck_match(pTHX_ OP *o)
5821 if (o->op_type != OP_QR) {
5822 const I32 offset = pad_findmy("$_");
5823 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5824 o->op_targ = offset;
5825 o->op_private |= OPpTARGET_MY;
5828 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5829 o->op_private |= OPpRUNTIME;
5834 Perl_ck_method(pTHX_ OP *o)
5836 OP *kid = cUNOPo->op_first;
5837 if (kid->op_type == OP_CONST) {
5838 SV* sv = kSVOP->op_sv;
5839 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5841 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5842 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5845 kSVOP->op_sv = Nullsv;
5847 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5856 Perl_ck_null(pTHX_ OP *o)
5862 Perl_ck_open(pTHX_ OP *o)
5864 HV *table = GvHV(PL_hintgv);
5868 svp = hv_fetch(table, "open_IN", 7, FALSE);
5870 mode = mode_from_discipline(*svp);
5871 if (mode & O_BINARY)
5872 o->op_private |= OPpOPEN_IN_RAW;
5873 else if (mode & O_TEXT)
5874 o->op_private |= OPpOPEN_IN_CRLF;
5877 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5879 mode = mode_from_discipline(*svp);
5880 if (mode & O_BINARY)
5881 o->op_private |= OPpOPEN_OUT_RAW;
5882 else if (mode & O_TEXT)
5883 o->op_private |= OPpOPEN_OUT_CRLF;
5886 if (o->op_type == OP_BACKTICK)
5889 /* In case of three-arg dup open remove strictness
5890 * from the last arg if it is a bareword. */
5891 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5892 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5896 if ((last->op_type == OP_CONST) && /* The bareword. */
5897 (last->op_private & OPpCONST_BARE) &&
5898 (last->op_private & OPpCONST_STRICT) &&
5899 (oa = first->op_sibling) && /* The fh. */
5900 (oa = oa->op_sibling) && /* The mode. */
5901 (oa->op_type == OP_CONST) &&
5902 SvPOK(((SVOP*)oa)->op_sv) &&
5903 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5904 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5905 (last == oa->op_sibling)) /* The bareword. */
5906 last->op_private &= ~OPpCONST_STRICT;
5912 Perl_ck_repeat(pTHX_ OP *o)
5914 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5915 o->op_private |= OPpREPEAT_DOLIST;
5916 cBINOPo->op_first = force_list(cBINOPo->op_first);
5924 Perl_ck_require(pTHX_ OP *o)
5928 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5929 SVOP *kid = (SVOP*)cUNOPo->op_first;
5931 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5932 SV *sv = kid->op_sv;
5933 U32 was_readonly = SvREADONLY(sv);
5938 sv_force_normal_flags(sv, 0);
5939 assert(!SvREADONLY(sv));
5946 for (s = SvPVX(sv); *s; s++) {
5947 if (*s == ':' && s[1] == ':') {
5949 Move(s+2, s+1, strlen(s+2)+1, char);
5950 SvCUR_set(sv, SvCUR(sv) - 1);
5953 sv_catpvn(sv, ".pm", 3);
5954 SvFLAGS(sv) |= was_readonly;
5958 /* handle override, if any */
5959 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5960 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5961 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5963 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5964 OP *kid = cUNOPo->op_first;
5965 cUNOPo->op_first = 0;
5967 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5968 append_elem(OP_LIST, kid,
5969 scalar(newUNOP(OP_RV2CV, 0,
5978 Perl_ck_return(pTHX_ OP *o)
5980 if (CvLVALUE(PL_compcv)) {
5982 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5983 mod(kid, OP_LEAVESUBLV);
5990 Perl_ck_retarget(pTHX_ OP *o)
5992 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5999 Perl_ck_select(pTHX_ OP *o)
6003 if (o->op_flags & OPf_KIDS) {
6004 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6005 if (kid && kid->op_sibling) {
6006 o->op_type = OP_SSELECT;
6007 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6009 return fold_constants(o);
6013 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6014 if (kid && kid->op_type == OP_RV2GV)
6015 kid->op_private &= ~HINT_STRICT_REFS;
6020 Perl_ck_shift(pTHX_ OP *o)
6022 const I32 type = o->op_type;
6024 if (!(o->op_flags & OPf_KIDS)) {
6028 argop = newUNOP(OP_RV2AV, 0,
6029 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6030 return newUNOP(type, 0, scalar(argop));
6032 return scalar(modkids(ck_fun(o), type));
6036 Perl_ck_sort(pTHX_ OP *o)
6040 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6042 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6043 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6045 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6047 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6049 if (kid->op_type == OP_SCOPE) {
6053 else if (kid->op_type == OP_LEAVE) {
6054 if (o->op_type == OP_SORT) {
6055 op_null(kid); /* wipe out leave */
6058 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6059 if (k->op_next == kid)
6061 /* don't descend into loops */
6062 else if (k->op_type == OP_ENTERLOOP
6063 || k->op_type == OP_ENTERITER)
6065 k = cLOOPx(k)->op_lastop;
6070 kid->op_next = 0; /* just disconnect the leave */
6071 k = kLISTOP->op_first;
6076 if (o->op_type == OP_SORT) {
6077 /* provide scalar context for comparison function/block */
6083 o->op_flags |= OPf_SPECIAL;
6085 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6088 firstkid = firstkid->op_sibling;
6091 /* provide list context for arguments */
6092 if (o->op_type == OP_SORT)
6099 S_simplify_sort(pTHX_ OP *o)
6101 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6106 if (!(o->op_flags & OPf_STACKED))
6108 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6109 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6110 kid = kUNOP->op_first; /* get past null */
6111 if (kid->op_type != OP_SCOPE)
6113 kid = kLISTOP->op_last; /* get past scope */
6114 switch(kid->op_type) {
6122 k = kid; /* remember this node*/
6123 if (kBINOP->op_first->op_type != OP_RV2SV)
6125 kid = kBINOP->op_first; /* get past cmp */
6126 if (kUNOP->op_first->op_type != OP_GV)
6128 kid = kUNOP->op_first; /* get past rv2sv */
6130 if (GvSTASH(gv) != PL_curstash)
6132 gvname = GvNAME(gv);
6133 if (*gvname == 'a' && gvname[1] == '\0')
6135 else if (*gvname == 'b' && gvname[1] == '\0')
6140 kid = k; /* back to cmp */
6141 if (kBINOP->op_last->op_type != OP_RV2SV)
6143 kid = kBINOP->op_last; /* down to 2nd arg */
6144 if (kUNOP->op_first->op_type != OP_GV)
6146 kid = kUNOP->op_first; /* get past rv2sv */
6148 if (GvSTASH(gv) != PL_curstash)
6150 gvname = GvNAME(gv);
6152 ? !(*gvname == 'a' && gvname[1] == '\0')
6153 : !(*gvname == 'b' && gvname[1] == '\0'))
6155 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6157 o->op_private |= OPpSORT_DESCEND;
6158 if (k->op_type == OP_NCMP)
6159 o->op_private |= OPpSORT_NUMERIC;
6160 if (k->op_type == OP_I_NCMP)
6161 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6162 kid = cLISTOPo->op_first->op_sibling;
6163 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6164 op_free(kid); /* then delete it */
6168 Perl_ck_split(pTHX_ OP *o)
6173 if (o->op_flags & OPf_STACKED)
6174 return no_fh_allowed(o);
6176 kid = cLISTOPo->op_first;
6177 if (kid->op_type != OP_NULL)
6178 Perl_croak(aTHX_ "panic: ck_split");
6179 kid = kid->op_sibling;
6180 op_free(cLISTOPo->op_first);
6181 cLISTOPo->op_first = kid;
6183 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6184 cLISTOPo->op_last = kid; /* There was only one element previously */
6187 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6188 OP *sibl = kid->op_sibling;
6189 kid->op_sibling = 0;
6190 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6191 if (cLISTOPo->op_first == cLISTOPo->op_last)
6192 cLISTOPo->op_last = kid;
6193 cLISTOPo->op_first = kid;
6194 kid->op_sibling = sibl;
6197 kid->op_type = OP_PUSHRE;
6198 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6200 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6201 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6202 "Use of /g modifier is meaningless in split");
6205 if (!kid->op_sibling)
6206 append_elem(OP_SPLIT, o, newDEFSVOP());
6208 kid = kid->op_sibling;
6211 if (!kid->op_sibling)
6212 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6214 kid = kid->op_sibling;
6217 if (kid->op_sibling)
6218 return too_many_arguments(o,OP_DESC(o));
6224 Perl_ck_join(pTHX_ OP *o)
6226 const OP *kid = cLISTOPo->op_first->op_sibling;
6227 if (kid && kid->op_type == OP_MATCH) {
6228 if (ckWARN(WARN_SYNTAX)) {
6229 const REGEXP *re = PM_GETRE(kPMOP);
6230 const char *pmstr = re ? re->precomp : "STRING";
6231 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6232 "/%s/ should probably be written as \"%s\"",
6240 Perl_ck_subr(pTHX_ OP *o)
6242 OP *prev = ((cUNOPo->op_first->op_sibling)
6243 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6244 OP *o2 = prev->op_sibling;
6251 I32 contextclass = 0;
6255 o->op_private |= OPpENTERSUB_HASTARG;
6256 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6257 if (cvop->op_type == OP_RV2CV) {
6259 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6260 op_null(cvop); /* disable rv2cv */
6261 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6262 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6263 GV *gv = cGVOPx_gv(tmpop);
6266 tmpop->op_private |= OPpEARLY_CV;
6269 namegv = CvANON(cv) ? gv : CvGV(cv);
6270 proto = SvPV_nolen((SV*)cv);
6272 if (CvASSERTION(cv)) {
6273 if (PL_hints & HINT_ASSERTING) {
6274 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6275 o->op_private |= OPpENTERSUB_DB;
6279 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6280 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6281 "Impossible to activate assertion call");
6288 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6289 if (o2->op_type == OP_CONST)
6290 o2->op_private &= ~OPpCONST_STRICT;
6291 else if (o2->op_type == OP_LIST) {
6292 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6293 if (o && o->op_type == OP_CONST)
6294 o->op_private &= ~OPpCONST_STRICT;
6297 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6298 if (PERLDB_SUB && PL_curstash != PL_debstash)
6299 o->op_private |= OPpENTERSUB_DB;
6300 while (o2 != cvop) {
6304 return too_many_arguments(o, gv_ename(namegv));
6322 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6324 arg == 1 ? "block or sub {}" : "sub {}",
6325 gv_ename(namegv), o2);
6328 /* '*' allows any scalar type, including bareword */
6331 if (o2->op_type == OP_RV2GV)
6332 goto wrapref; /* autoconvert GLOB -> GLOBref */
6333 else if (o2->op_type == OP_CONST)
6334 o2->op_private &= ~OPpCONST_STRICT;
6335 else if (o2->op_type == OP_ENTERSUB) {
6336 /* accidental subroutine, revert to bareword */
6337 OP *gvop = ((UNOP*)o2)->op_first;
6338 if (gvop && gvop->op_type == OP_NULL) {
6339 gvop = ((UNOP*)gvop)->op_first;
6341 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6344 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6345 (gvop = ((UNOP*)gvop)->op_first) &&
6346 gvop->op_type == OP_GV)
6348 GV *gv = cGVOPx_gv(gvop);
6349 OP *sibling = o2->op_sibling;
6350 SV *n = newSVpvn("",0);
6352 gv_fullname4(n, gv, "", FALSE);
6353 o2 = newSVOP(OP_CONST, 0, n);
6354 prev->op_sibling = o2;
6355 o2->op_sibling = sibling;
6371 if (contextclass++ == 0) {
6372 e = strchr(proto, ']');
6373 if (!e || e == proto)
6386 while (*--p != '[');
6387 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6388 gv_ename(namegv), o2);
6394 if (o2->op_type == OP_RV2GV)
6397 bad_type(arg, "symbol", gv_ename(namegv), o2);
6400 if (o2->op_type == OP_ENTERSUB)
6403 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6406 if (o2->op_type == OP_RV2SV ||
6407 o2->op_type == OP_PADSV ||
6408 o2->op_type == OP_HELEM ||
6409 o2->op_type == OP_AELEM ||
6410 o2->op_type == OP_THREADSV)
6413 bad_type(arg, "scalar", gv_ename(namegv), o2);
6416 if (o2->op_type == OP_RV2AV ||
6417 o2->op_type == OP_PADAV)
6420 bad_type(arg, "array", gv_ename(namegv), o2);
6423 if (o2->op_type == OP_RV2HV ||
6424 o2->op_type == OP_PADHV)
6427 bad_type(arg, "hash", gv_ename(namegv), o2);
6432 OP* sib = kid->op_sibling;
6433 kid->op_sibling = 0;
6434 o2 = newUNOP(OP_REFGEN, 0, kid);
6435 o2->op_sibling = sib;
6436 prev->op_sibling = o2;
6438 if (contextclass && e) {
6453 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6454 gv_ename(namegv), cv);
6459 mod(o2, OP_ENTERSUB);
6461 o2 = o2->op_sibling;
6463 if (proto && !optional &&
6464 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6465 return too_few_arguments(o, gv_ename(namegv));
6468 o=newSVOP(OP_CONST, 0, newSViv(0));
6474 Perl_ck_svconst(pTHX_ OP *o)
6476 SvREADONLY_on(cSVOPo->op_sv);
6481 Perl_ck_trunc(pTHX_ OP *o)
6483 if (o->op_flags & OPf_KIDS) {
6484 SVOP *kid = (SVOP*)cUNOPo->op_first;
6486 if (kid->op_type == OP_NULL)
6487 kid = (SVOP*)kid->op_sibling;
6488 if (kid && kid->op_type == OP_CONST &&
6489 (kid->op_private & OPpCONST_BARE))
6491 o->op_flags |= OPf_SPECIAL;
6492 kid->op_private &= ~OPpCONST_STRICT;
6499 Perl_ck_unpack(pTHX_ OP *o)
6501 OP *kid = cLISTOPo->op_first;
6502 if (kid->op_sibling) {
6503 kid = kid->op_sibling;
6504 if (!kid->op_sibling)
6505 kid->op_sibling = newDEFSVOP();
6511 Perl_ck_substr(pTHX_ OP *o)
6514 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6515 OP *kid = cLISTOPo->op_first;
6517 if (kid->op_type == OP_NULL)
6518 kid = kid->op_sibling;
6520 kid->op_flags |= OPf_MOD;
6526 /* A peephole optimizer. We visit the ops in the order they're to execute.
6527 * See the comments at the top of this file for more details about when
6528 * peep() is called */
6531 Perl_peep(pTHX_ register OP *o)
6534 register OP* oldop = 0;
6536 if (!o || o->op_opt)
6540 SAVEVPTR(PL_curcop);
6541 for (; o; o = o->op_next) {
6545 switch (o->op_type) {
6549 PL_curcop = ((COP*)o); /* for warnings */
6554 if (cSVOPo->op_private & OPpCONST_STRICT)
6555 no_bareword_allowed(o);
6557 case OP_METHOD_NAMED:
6558 /* Relocate sv to the pad for thread safety.
6559 * Despite being a "constant", the SV is written to,
6560 * for reference counts, sv_upgrade() etc. */
6562 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6563 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6564 /* If op_sv is already a PADTMP then it is being used by
6565 * some pad, so make a copy. */
6566 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6567 SvREADONLY_on(PAD_SVl(ix));
6568 SvREFCNT_dec(cSVOPo->op_sv);
6571 SvREFCNT_dec(PAD_SVl(ix));
6572 SvPADTMP_on(cSVOPo->op_sv);
6573 PAD_SETSV(ix, cSVOPo->op_sv);
6574 /* XXX I don't know how this isn't readonly already. */
6575 SvREADONLY_on(PAD_SVl(ix));
6577 cSVOPo->op_sv = Nullsv;
6585 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6586 if (o->op_next->op_private & OPpTARGET_MY) {
6587 if (o->op_flags & OPf_STACKED) /* chained concats */
6588 goto ignore_optimization;
6590 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6591 o->op_targ = o->op_next->op_targ;
6592 o->op_next->op_targ = 0;
6593 o->op_private |= OPpTARGET_MY;
6596 op_null(o->op_next);
6598 ignore_optimization:
6602 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6604 break; /* Scalar stub must produce undef. List stub is noop */
6608 if (o->op_targ == OP_NEXTSTATE
6609 || o->op_targ == OP_DBSTATE
6610 || o->op_targ == OP_SETSTATE)
6612 PL_curcop = ((COP*)o);
6614 /* XXX: We avoid setting op_seq here to prevent later calls
6615 to peep() from mistakenly concluding that optimisation
6616 has already occurred. This doesn't fix the real problem,
6617 though (See 20010220.007). AMS 20010719 */
6618 /* op_seq functionality is now replaced by op_opt */
6619 if (oldop && o->op_next) {
6620 oldop->op_next = o->op_next;
6628 if (oldop && o->op_next) {
6629 oldop->op_next = o->op_next;
6637 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6638 OP* pop = (o->op_type == OP_PADAV) ?
6639 o->op_next : o->op_next->op_next;
6641 if (pop && pop->op_type == OP_CONST &&
6642 ((PL_op = pop->op_next)) &&
6643 pop->op_next->op_type == OP_AELEM &&
6644 !(pop->op_next->op_private &
6645 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6646 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6651 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6652 no_bareword_allowed(pop);
6653 if (o->op_type == OP_GV)
6654 op_null(o->op_next);
6655 op_null(pop->op_next);
6657 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6658 o->op_next = pop->op_next->op_next;
6659 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6660 o->op_private = (U8)i;
6661 if (o->op_type == OP_GV) {
6666 o->op_flags |= OPf_SPECIAL;
6667 o->op_type = OP_AELEMFAST;
6673 if (o->op_next->op_type == OP_RV2SV) {
6674 if (!(o->op_next->op_private & OPpDEREF)) {
6675 op_null(o->op_next);
6676 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6678 o->op_next = o->op_next->op_next;
6679 o->op_type = OP_GVSV;
6680 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6683 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6685 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6686 /* XXX could check prototype here instead of just carping */
6687 SV *sv = sv_newmortal();
6688 gv_efullname3(sv, gv, Nullch);
6689 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6690 "%"SVf"() called too early to check prototype",
6694 else if (o->op_next->op_type == OP_READLINE
6695 && o->op_next->op_next->op_type == OP_CONCAT
6696 && (o->op_next->op_next->op_flags & OPf_STACKED))
6698 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6699 o->op_type = OP_RCATLINE;
6700 o->op_flags |= OPf_STACKED;
6701 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6702 op_null(o->op_next->op_next);
6703 op_null(o->op_next);
6720 while (cLOGOP->op_other->op_type == OP_NULL)
6721 cLOGOP->op_other = cLOGOP->op_other->op_next;
6722 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6728 while (cLOOP->op_redoop->op_type == OP_NULL)
6729 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6730 peep(cLOOP->op_redoop);
6731 while (cLOOP->op_nextop->op_type == OP_NULL)
6732 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6733 peep(cLOOP->op_nextop);
6734 while (cLOOP->op_lastop->op_type == OP_NULL)
6735 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6736 peep(cLOOP->op_lastop);
6743 while (cPMOP->op_pmreplstart &&
6744 cPMOP->op_pmreplstart->op_type == OP_NULL)
6745 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6746 peep(cPMOP->op_pmreplstart);
6751 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6752 && ckWARN(WARN_SYNTAX))
6754 if (o->op_next->op_sibling &&
6755 o->op_next->op_sibling->op_type != OP_EXIT &&
6756 o->op_next->op_sibling->op_type != OP_WARN &&
6757 o->op_next->op_sibling->op_type != OP_DIE) {
6758 const line_t oldline = CopLINE(PL_curcop);
6760 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6761 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6762 "Statement unlikely to be reached");
6763 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6764 "\t(Maybe you meant system() when you said exec()?)\n");
6765 CopLINE_set(PL_curcop, oldline);
6775 const char *key = NULL;
6780 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6783 /* Make the CONST have a shared SV */
6784 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6785 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6786 key = SvPV_const(sv, keylen);
6787 lexname = newSVpvn_share(key,
6788 SvUTF8(sv) ? -(I32)keylen : keylen,
6794 if ((o->op_private & (OPpLVAL_INTRO)))
6797 rop = (UNOP*)((BINOP*)o)->op_first;
6798 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6800 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6801 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6803 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6804 if (!fields || !GvHV(*fields))
6806 key = SvPV_const(*svp, keylen);
6807 if (!hv_fetch(GvHV(*fields), key,
6808 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6810 Perl_croak(aTHX_ "No such class field \"%s\" "
6811 "in variable %s of type %s",
6812 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
6825 SVOP *first_key_op, *key_op;
6827 if ((o->op_private & (OPpLVAL_INTRO))
6828 /* I bet there's always a pushmark... */
6829 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6830 /* hmmm, no optimization if list contains only one key. */
6832 rop = (UNOP*)((LISTOP*)o)->op_last;
6833 if (rop->op_type != OP_RV2HV)
6835 if (rop->op_first->op_type == OP_PADSV)
6836 /* @$hash{qw(keys here)} */
6837 rop = (UNOP*)rop->op_first;
6839 /* @{$hash}{qw(keys here)} */
6840 if (rop->op_first->op_type == OP_SCOPE
6841 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6843 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6849 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6850 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6852 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6853 if (!fields || !GvHV(*fields))
6855 /* Again guessing that the pushmark can be jumped over.... */
6856 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6857 ->op_first->op_sibling;
6858 for (key_op = first_key_op; key_op;
6859 key_op = (SVOP*)key_op->op_sibling) {
6860 if (key_op->op_type != OP_CONST)
6862 svp = cSVOPx_svp(key_op);
6863 key = SvPV_const(*svp, keylen);
6864 if (!hv_fetch(GvHV(*fields), key,
6865 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6867 Perl_croak(aTHX_ "No such class field \"%s\" "
6868 "in variable %s of type %s",
6869 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6876 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6880 /* check that RHS of sort is a single plain array */
6881 oright = cUNOPo->op_first;
6882 if (!oright || oright->op_type != OP_PUSHMARK)
6885 /* reverse sort ... can be optimised. */
6886 if (!cUNOPo->op_sibling) {
6887 /* Nothing follows us on the list. */
6888 OP *reverse = o->op_next;
6890 if (reverse->op_type == OP_REVERSE &&
6891 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6892 OP *pushmark = cUNOPx(reverse)->op_first;
6893 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6894 && (cUNOPx(pushmark)->op_sibling == o)) {
6895 /* reverse -> pushmark -> sort */
6896 o->op_private |= OPpSORT_REVERSE;
6898 pushmark->op_next = oright->op_next;
6904 /* make @a = sort @a act in-place */
6908 oright = cUNOPx(oright)->op_sibling;
6911 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6912 oright = cUNOPx(oright)->op_sibling;
6916 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6917 || oright->op_next != o
6918 || (oright->op_private & OPpLVAL_INTRO)
6922 /* o2 follows the chain of op_nexts through the LHS of the
6923 * assign (if any) to the aassign op itself */
6925 if (!o2 || o2->op_type != OP_NULL)
6928 if (!o2 || o2->op_type != OP_PUSHMARK)
6931 if (o2 && o2->op_type == OP_GV)
6934 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6935 || (o2->op_private & OPpLVAL_INTRO)
6940 if (!o2 || o2->op_type != OP_NULL)
6943 if (!o2 || o2->op_type != OP_AASSIGN
6944 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6947 /* check that the sort is the first arg on RHS of assign */
6949 o2 = cUNOPx(o2)->op_first;
6950 if (!o2 || o2->op_type != OP_NULL)
6952 o2 = cUNOPx(o2)->op_first;
6953 if (!o2 || o2->op_type != OP_PUSHMARK)
6955 if (o2->op_sibling != o)
6958 /* check the array is the same on both sides */
6959 if (oleft->op_type == OP_RV2AV) {
6960 if (oright->op_type != OP_RV2AV
6961 || !cUNOPx(oright)->op_first
6962 || cUNOPx(oright)->op_first->op_type != OP_GV
6963 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6964 cGVOPx_gv(cUNOPx(oright)->op_first)
6968 else if (oright->op_type != OP_PADAV
6969 || oright->op_targ != oleft->op_targ
6973 /* transfer MODishness etc from LHS arg to RHS arg */
6974 oright->op_flags = oleft->op_flags;
6975 o->op_private |= OPpSORT_INPLACE;
6977 /* excise push->gv->rv2av->null->aassign */
6978 o2 = o->op_next->op_next;
6979 op_null(o2); /* PUSHMARK */
6981 if (o2->op_type == OP_GV) {
6982 op_null(o2); /* GV */
6985 op_null(o2); /* RV2AV or PADAV */
6986 o2 = o2->op_next->op_next;
6987 op_null(o2); /* AASSIGN */
6989 o->op_next = o2->op_next;
6995 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6997 LISTOP *enter, *exlist;
7000 enter = (LISTOP *) o->op_next;
7003 if (enter->op_type == OP_NULL) {
7004 enter = (LISTOP *) enter->op_next;
7008 /* for $a (...) will have OP_GV then OP_RV2GV here.
7009 for (...) just has an OP_GV. */
7010 if (enter->op_type == OP_GV) {
7011 gvop = (OP *) enter;
7012 enter = (LISTOP *) enter->op_next;
7015 if (enter->op_type == OP_RV2GV) {
7016 enter = (LISTOP *) enter->op_next;
7022 if (enter->op_type != OP_ENTERITER)
7025 iter = enter->op_next;
7026 if (!iter || iter->op_type != OP_ITER)
7029 expushmark = enter->op_first;
7030 if (!expushmark || expushmark->op_type != OP_NULL
7031 || expushmark->op_targ != OP_PUSHMARK)
7034 exlist = (LISTOP *) expushmark->op_sibling;
7035 if (!exlist || exlist->op_type != OP_NULL
7036 || exlist->op_targ != OP_LIST)
7039 if (exlist->op_last != o) {
7040 /* Mmm. Was expecting to point back to this op. */
7043 theirmark = exlist->op_first;
7044 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7047 if (theirmark->op_sibling != o) {
7048 /* There's something between the mark and the reverse, eg
7049 for (1, reverse (...))
7054 ourmark = ((LISTOP *)o)->op_first;
7055 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7058 ourlast = ((LISTOP *)o)->op_last;
7059 if (!ourlast || ourlast->op_next != o)
7062 rv2av = ourmark->op_sibling;
7063 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7064 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7065 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7066 /* We're just reversing a single array. */
7067 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7068 enter->op_flags |= OPf_STACKED;
7071 /* We don't have control over who points to theirmark, so sacrifice
7073 theirmark->op_next = ourmark->op_next;
7074 theirmark->op_flags = ourmark->op_flags;
7075 ourlast->op_next = gvop ? gvop : (OP *) enter;
7078 enter->op_private |= OPpITER_REVERSED;
7079 iter->op_private |= OPpITER_REVERSED;
7094 Perl_custom_op_name(pTHX_ const OP* o)
7096 const IV index = PTR2IV(o->op_ppaddr);
7100 if (!PL_custom_op_names) /* This probably shouldn't happen */
7101 return (char *)PL_op_name[OP_CUSTOM];
7103 keysv = sv_2mortal(newSViv(index));
7105 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7107 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7109 return SvPV_nolen(HeVAL(he));
7113 Perl_custom_op_desc(pTHX_ const OP* o)
7115 const IV index = PTR2IV(o->op_ppaddr);
7119 if (!PL_custom_op_descs)
7120 return (char *)PL_op_desc[OP_CUSTOM];
7122 keysv = sv_2mortal(newSViv(index));
7124 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7126 return (char *)PL_op_desc[OP_CUSTOM];
7128 return SvPV_nolen(HeVAL(he));
7133 /* Efficient sub that returns a constant scalar value. */
7135 const_sv_xsub(pTHX_ CV* cv)
7140 Perl_croak(aTHX_ "usage: %s::%s()",
7141 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7145 ST(0) = (SV*)XSANY.any_ptr;
7151 * c-indentation-style: bsd
7153 * indent-tabs-mode: t
7156 * ex: set ts=8 sts=4 sw=4 noet: