3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 **ptr = (I32 **) op;
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, Nullch);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
201 qerror(Perl_mess(aTHX_
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
206 /* "register" allocation */
209 Perl_allocmy(pTHX_ char *name)
213 /* complain about "my $<special_var>" etc etc */
214 if (!(PL_in_my == KEY_our ||
216 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
217 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
219 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
220 /* 1999-02-27 mjd@plover.com */
222 p = strchr(name, '\0');
223 /* The next block assumes the buffer is at least 205 chars
224 long. At present, it's always at least 256 chars. */
226 strcpy(name+200, "...");
232 /* Move everything else down one character */
233 for (; p-name > 2; p--)
235 name[2] = toCTRL(name[1]);
238 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
241 /* check for duplicate declaration */
243 (bool)(PL_in_my == KEY_our),
244 (PL_curstash ? PL_curstash : PL_defstash)
247 if (PL_in_my_stash && *name != '$') {
248 yyerror(Perl_form(aTHX_
249 "Can't declare class for non-scalar %s in \"%s\"",
250 name, PL_in_my == KEY_our ? "our" : "my"));
253 /* allocate a spare slot and store the name in that slot */
255 off = pad_add_name(name,
258 /* $_ is always in main::, even with our */
259 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
270 Perl_op_free(pTHX_ OP *o)
276 if (!o || o->op_static)
279 if (o->op_private & OPpREFCOUNTED) {
280 switch (o->op_type) {
288 refcnt = OpREFCNT_dec(o);
298 if (o->op_flags & OPf_KIDS) {
299 register OP *kid, *nextkid;
300 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
301 nextkid = kid->op_sibling; /* Get before next freeing kid */
307 type = (OPCODE)o->op_targ;
309 /* COP* is not cleared by op_clear() so that we may track line
310 * numbers etc even after null() */
311 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
316 #ifdef DEBUG_LEAKING_SCALARS
323 Perl_op_clear(pTHX_ OP *o)
327 switch (o->op_type) {
328 case OP_NULL: /* Was holding old type, if any. */
329 case OP_ENTEREVAL: /* Was holding hints. */
333 if (!(o->op_flags & OPf_REF)
334 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
340 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
341 /* not an OP_PADAV replacement */
343 if (cPADOPo->op_padix > 0) {
344 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
345 * may still exist on the pad */
346 pad_swipe(cPADOPo->op_padix, TRUE);
347 cPADOPo->op_padix = 0;
350 SvREFCNT_dec(cSVOPo->op_sv);
351 cSVOPo->op_sv = Nullsv;
355 case OP_METHOD_NAMED:
357 SvREFCNT_dec(cSVOPo->op_sv);
358 cSVOPo->op_sv = Nullsv;
361 Even if op_clear does a pad_free for the target of the op,
362 pad_free doesn't actually remove the sv that exists in the pad;
363 instead it lives on. This results in that it could be reused as
364 a target later on when the pad was reallocated.
367 pad_swipe(o->op_targ,1);
376 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
380 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
381 SvREFCNT_dec(cSVOPo->op_sv);
382 cSVOPo->op_sv = Nullsv;
385 Safefree(cPVOPo->op_pv);
386 cPVOPo->op_pv = Nullch;
390 op_free(cPMOPo->op_pmreplroot);
394 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
395 /* No GvIN_PAD_off here, because other references may still
396 * exist on the pad */
397 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
400 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
407 HV *pmstash = PmopSTASH(cPMOPo);
408 if (pmstash && SvREFCNT(pmstash)) {
409 MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
411 PMOP *pmop = (PMOP*) mg->mg_obj;
412 PMOP *lastpmop = NULL;
414 if (cPMOPo == pmop) {
416 lastpmop->op_pmnext = pmop->op_pmnext;
418 mg->mg_obj = (SV*) pmop->op_pmnext;
422 pmop = pmop->op_pmnext;
426 PmopSTASH_free(cPMOPo);
428 cPMOPo->op_pmreplroot = Nullop;
429 /* we use the "SAFE" version of the PM_ macros here
430 * since sv_clean_all might release some PMOPs
431 * after PL_regex_padav has been cleared
432 * and the clearing of PL_regex_padav needs to
433 * happen before sv_clean_all
435 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
436 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
438 if(PL_regex_pad) { /* We could be in destruction */
439 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
440 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
441 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
448 if (o->op_targ > 0) {
449 pad_free(o->op_targ);
455 S_cop_free(pTHX_ COP* cop)
457 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
460 if (! specialWARN(cop->cop_warnings))
461 SvREFCNT_dec(cop->cop_warnings);
462 if (! specialCopIO(cop->cop_io)) {
466 char *s = SvPV(cop->cop_io,len);
467 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
470 SvREFCNT_dec(cop->cop_io);
476 Perl_op_null(pTHX_ OP *o)
479 if (o->op_type == OP_NULL)
482 o->op_targ = o->op_type;
483 o->op_type = OP_NULL;
484 o->op_ppaddr = PL_ppaddr[OP_NULL];
488 Perl_op_refcnt_lock(pTHX)
495 Perl_op_refcnt_unlock(pTHX)
501 /* Contextualizers */
503 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
506 Perl_linklist(pTHX_ OP *o)
512 /* establish postfix order */
513 if (cUNOPo->op_first) {
515 o->op_next = LINKLIST(cUNOPo->op_first);
516 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
518 kid->op_next = LINKLIST(kid->op_sibling);
530 Perl_scalarkids(pTHX_ OP *o)
532 if (o && o->op_flags & OPf_KIDS) {
534 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
541 S_scalarboolean(pTHX_ OP *o)
543 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
544 if (ckWARN(WARN_SYNTAX)) {
545 const line_t oldline = CopLINE(PL_curcop);
547 if (PL_copline != NOLINE)
548 CopLINE_set(PL_curcop, PL_copline);
549 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
550 CopLINE_set(PL_curcop, oldline);
557 Perl_scalar(pTHX_ OP *o)
562 /* assumes no premature commitment */
563 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
564 || o->op_type == OP_RETURN)
569 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
571 switch (o->op_type) {
573 scalar(cBINOPo->op_first);
578 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
582 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
583 if (!kPMOP->op_pmreplroot)
584 deprecate_old("implicit split to @_");
592 if (o->op_flags & OPf_KIDS) {
593 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
599 kid = cLISTOPo->op_first;
601 while ((kid = kid->op_sibling)) {
607 WITH_THR(PL_curcop = &PL_compiling);
612 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
618 WITH_THR(PL_curcop = &PL_compiling);
621 if (ckWARN(WARN_VOID))
622 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
628 Perl_scalarvoid(pTHX_ OP *o)
632 const char* useless = 0;
636 if (o->op_type == OP_NEXTSTATE
637 || o->op_type == OP_SETSTATE
638 || o->op_type == OP_DBSTATE
639 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
640 || o->op_targ == OP_SETSTATE
641 || o->op_targ == OP_DBSTATE)))
642 PL_curcop = (COP*)o; /* for warning below */
644 /* assumes no premature commitment */
645 want = o->op_flags & OPf_WANT;
646 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
647 || o->op_type == OP_RETURN)
652 if ((o->op_private & OPpTARGET_MY)
653 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
655 return scalar(o); /* As if inside SASSIGN */
658 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
660 switch (o->op_type) {
662 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
666 if (o->op_flags & OPf_STACKED)
670 if (o->op_private == 4)
742 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
743 useless = OP_DESC(o);
747 kid = cUNOPo->op_first;
748 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
749 kid->op_type != OP_TRANS) {
752 useless = "negative pattern binding (!~)";
759 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
760 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
761 useless = "a variable";
766 if (cSVOPo->op_private & OPpCONST_STRICT)
767 no_bareword_allowed(o);
769 if (ckWARN(WARN_VOID)) {
770 useless = "a constant";
771 /* don't warn on optimised away booleans, eg
772 * use constant Foo, 5; Foo || print; */
773 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
775 /* the constants 0 and 1 are permitted as they are
776 conventionally used as dummies in constructs like
777 1 while some_condition_with_side_effects; */
778 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
780 else if (SvPOK(sv)) {
781 /* perl4's way of mixing documentation and code
782 (before the invention of POD) was based on a
783 trick to mix nroff and perl code. The trick was
784 built upon these three nroff macros being used in
785 void context. The pink camel has the details in
786 the script wrapman near page 319. */
787 if (strnEQ(SvPVX_const(sv), "di", 2) ||
788 strnEQ(SvPVX_const(sv), "ds", 2) ||
789 strnEQ(SvPVX_const(sv), "ig", 2))
794 op_null(o); /* don't execute or even remember it */
798 o->op_type = OP_PREINC; /* pre-increment is faster */
799 o->op_ppaddr = PL_ppaddr[OP_PREINC];
803 o->op_type = OP_PREDEC; /* pre-decrement is faster */
804 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
811 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
816 if (o->op_flags & OPf_STACKED)
823 if (!(o->op_flags & OPf_KIDS))
832 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
839 /* all requires must return a boolean value */
840 o->op_flags &= ~OPf_WANT;
845 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
846 if (!kPMOP->op_pmreplroot)
847 deprecate_old("implicit split to @_");
851 if (useless && ckWARN(WARN_VOID))
852 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
857 Perl_listkids(pTHX_ OP *o)
859 if (o && o->op_flags & OPf_KIDS) {
861 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
868 Perl_list(pTHX_ OP *o)
873 /* assumes no premature commitment */
874 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
875 || o->op_type == OP_RETURN)
880 if ((o->op_private & OPpTARGET_MY)
881 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
883 return o; /* As if inside SASSIGN */
886 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
888 switch (o->op_type) {
891 list(cBINOPo->op_first);
896 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
904 if (!(o->op_flags & OPf_KIDS))
906 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
907 list(cBINOPo->op_first);
908 return gen_constant_list(o);
915 kid = cLISTOPo->op_first;
917 while ((kid = kid->op_sibling)) {
923 WITH_THR(PL_curcop = &PL_compiling);
927 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
933 WITH_THR(PL_curcop = &PL_compiling);
936 /* all requires must return a boolean value */
937 o->op_flags &= ~OPf_WANT;
944 Perl_scalarseq(pTHX_ OP *o)
947 if (o->op_type == OP_LINESEQ ||
948 o->op_type == OP_SCOPE ||
949 o->op_type == OP_LEAVE ||
950 o->op_type == OP_LEAVETRY)
953 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
954 if (kid->op_sibling) {
958 PL_curcop = &PL_compiling;
960 o->op_flags &= ~OPf_PARENS;
961 if (PL_hints & HINT_BLOCK_SCOPE)
962 o->op_flags |= OPf_PARENS;
965 o = newOP(OP_STUB, 0);
970 S_modkids(pTHX_ OP *o, I32 type)
972 if (o && o->op_flags & OPf_KIDS) {
974 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
980 /* Propagate lvalue ("modifiable") context to an op and it's children.
981 * 'type' represents the context type, roughly based on the type of op that
982 * would do the modifying, although local() is represented by OP_NULL.
983 * It's responsible for detecting things that can't be modified, flag
984 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
985 * might have to vivify a reference in $x), and so on.
987 * For example, "$a+1 = 2" would cause mod() to be called with o being
988 * OP_ADD and type being OP_SASSIGN, and would output an error.
992 Perl_mod(pTHX_ OP *o, I32 type)
996 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
999 if (!o || PL_error_count)
1002 if ((o->op_private & OPpTARGET_MY)
1003 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1008 switch (o->op_type) {
1014 if (!(o->op_private & (OPpCONST_ARYBASE)))
1016 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1017 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1021 SAVEI32(PL_compiling.cop_arybase);
1022 PL_compiling.cop_arybase = 0;
1024 else if (type == OP_REFGEN)
1027 Perl_croak(aTHX_ "That use of $[ is unsupported");
1030 if (o->op_flags & OPf_PARENS)
1034 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1035 !(o->op_flags & OPf_STACKED)) {
1036 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1037 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1038 assert(cUNOPo->op_first->op_type == OP_NULL);
1039 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1042 else if (o->op_private & OPpENTERSUB_NOMOD)
1044 else { /* lvalue subroutine call */
1045 o->op_private |= OPpLVAL_INTRO;
1046 PL_modcount = RETURN_UNLIMITED_NUMBER;
1047 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1048 /* Backward compatibility mode: */
1049 o->op_private |= OPpENTERSUB_INARGS;
1052 else { /* Compile-time error message: */
1053 OP *kid = cUNOPo->op_first;
1057 if (kid->op_type == OP_PUSHMARK)
1059 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1061 "panic: unexpected lvalue entersub "
1062 "args: type/targ %ld:%"UVuf,
1063 (long)kid->op_type, (UV)kid->op_targ);
1064 kid = kLISTOP->op_first;
1066 while (kid->op_sibling)
1067 kid = kid->op_sibling;
1068 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1070 if (kid->op_type == OP_METHOD_NAMED
1071 || kid->op_type == OP_METHOD)
1075 NewOp(1101, newop, 1, UNOP);
1076 newop->op_type = OP_RV2CV;
1077 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1078 newop->op_first = Nullop;
1079 newop->op_next = (OP*)newop;
1080 kid->op_sibling = (OP*)newop;
1081 newop->op_private |= OPpLVAL_INTRO;
1085 if (kid->op_type != OP_RV2CV)
1087 "panic: unexpected lvalue entersub "
1088 "entry via type/targ %ld:%"UVuf,
1089 (long)kid->op_type, (UV)kid->op_targ);
1090 kid->op_private |= OPpLVAL_INTRO;
1091 break; /* Postpone until runtime */
1095 kid = kUNOP->op_first;
1096 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1097 kid = kUNOP->op_first;
1098 if (kid->op_type == OP_NULL)
1100 "Unexpected constant lvalue entersub "
1101 "entry via type/targ %ld:%"UVuf,
1102 (long)kid->op_type, (UV)kid->op_targ);
1103 if (kid->op_type != OP_GV) {
1104 /* Restore RV2CV to check lvalueness */
1106 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1107 okid->op_next = kid->op_next;
1108 kid->op_next = okid;
1111 okid->op_next = Nullop;
1112 okid->op_type = OP_RV2CV;
1114 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1115 okid->op_private |= OPpLVAL_INTRO;
1119 cv = GvCV(kGVOP_gv);
1129 /* grep, foreach, subcalls, refgen */
1130 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1132 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1133 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1135 : (o->op_type == OP_ENTERSUB
1136 ? "non-lvalue subroutine call"
1138 type ? PL_op_desc[type] : "local"));
1152 case OP_RIGHT_SHIFT:
1161 if (!(o->op_flags & OPf_STACKED))
1168 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1174 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1175 PL_modcount = RETURN_UNLIMITED_NUMBER;
1176 return o; /* Treat \(@foo) like ordinary list. */
1180 if (scalar_mod_type(o, type))
1182 ref(cUNOPo->op_first, o->op_type);
1186 if (type == OP_LEAVESUBLV)
1187 o->op_private |= OPpMAYBE_LVSUB;
1193 PL_modcount = RETURN_UNLIMITED_NUMBER;
1196 ref(cUNOPo->op_first, o->op_type);
1201 PL_hints |= HINT_BLOCK_SCOPE;
1216 PL_modcount = RETURN_UNLIMITED_NUMBER;
1217 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1218 return o; /* Treat \(@foo) like ordinary list. */
1219 if (scalar_mod_type(o, type))
1221 if (type == OP_LEAVESUBLV)
1222 o->op_private |= OPpMAYBE_LVSUB;
1226 if (!type) /* local() */
1227 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1228 PAD_COMPNAME_PV(o->op_targ));
1236 if (type != OP_SASSIGN)
1240 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1245 if (type == OP_LEAVESUBLV)
1246 o->op_private |= OPpMAYBE_LVSUB;
1248 pad_free(o->op_targ);
1249 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1250 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1251 if (o->op_flags & OPf_KIDS)
1252 mod(cBINOPo->op_first->op_sibling, type);
1257 ref(cBINOPo->op_first, o->op_type);
1258 if (type == OP_ENTERSUB &&
1259 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1260 o->op_private |= OPpLVAL_DEFER;
1261 if (type == OP_LEAVESUBLV)
1262 o->op_private |= OPpMAYBE_LVSUB;
1272 if (o->op_flags & OPf_KIDS)
1273 mod(cLISTOPo->op_last, type);
1278 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1280 else if (!(o->op_flags & OPf_KIDS))
1282 if (o->op_targ != OP_LIST) {
1283 mod(cBINOPo->op_first, type);
1289 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1294 if (type != OP_LEAVESUBLV)
1296 break; /* mod()ing was handled by ck_return() */
1299 /* [20011101.069] File test operators interpret OPf_REF to mean that
1300 their argument is a filehandle; thus \stat(".") should not set
1302 if (type == OP_REFGEN &&
1303 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1306 if (type != OP_LEAVESUBLV)
1307 o->op_flags |= OPf_MOD;
1309 if (type == OP_AASSIGN || type == OP_SASSIGN)
1310 o->op_flags |= OPf_SPECIAL|OPf_REF;
1311 else if (!type) { /* local() */
1314 o->op_private |= OPpLVAL_INTRO;
1315 o->op_flags &= ~OPf_SPECIAL;
1316 PL_hints |= HINT_BLOCK_SCOPE;
1321 if (ckWARN(WARN_SYNTAX)) {
1322 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1323 "Useless localization of %s", OP_DESC(o));
1327 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1328 && type != OP_LEAVESUBLV)
1329 o->op_flags |= OPf_REF;
1334 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1338 if (o->op_type == OP_RV2GV)
1362 case OP_RIGHT_SHIFT:
1381 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1383 switch (o->op_type) {
1391 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1404 Perl_refkids(pTHX_ OP *o, I32 type)
1406 if (o && o->op_flags & OPf_KIDS) {
1408 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1415 Perl_ref(pTHX_ OP *o, I32 type)
1420 if (!o || PL_error_count)
1423 switch (o->op_type) {
1425 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1426 !(o->op_flags & OPf_STACKED)) {
1427 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1428 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1429 assert(cUNOPo->op_first->op_type == OP_NULL);
1430 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1431 o->op_flags |= OPf_SPECIAL;
1436 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1440 if (type == OP_DEFINED)
1441 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1442 ref(cUNOPo->op_first, o->op_type);
1445 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1446 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1447 : type == OP_RV2HV ? OPpDEREF_HV
1449 o->op_flags |= OPf_MOD;
1454 o->op_flags |= OPf_MOD; /* XXX ??? */
1459 o->op_flags |= OPf_REF;
1462 if (type == OP_DEFINED)
1463 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1464 ref(cUNOPo->op_first, o->op_type);
1469 o->op_flags |= OPf_REF;
1474 if (!(o->op_flags & OPf_KIDS))
1476 ref(cBINOPo->op_first, type);
1480 ref(cBINOPo->op_first, o->op_type);
1481 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1482 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1483 : type == OP_RV2HV ? OPpDEREF_HV
1485 o->op_flags |= OPf_MOD;
1493 if (!(o->op_flags & OPf_KIDS))
1495 ref(cLISTOPo->op_last, type);
1505 S_dup_attrlist(pTHX_ OP *o)
1509 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1510 * where the first kid is OP_PUSHMARK and the remaining ones
1511 * are OP_CONST. We need to push the OP_CONST values.
1513 if (o->op_type == OP_CONST)
1514 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1516 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1517 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1518 if (o->op_type == OP_CONST)
1519 rop = append_elem(OP_LIST, rop,
1520 newSVOP(OP_CONST, o->op_flags,
1521 SvREFCNT_inc(cSVOPo->op_sv)));
1528 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1533 /* fake up C<use attributes $pkg,$rv,@attrs> */
1534 ENTER; /* need to protect against side-effects of 'use' */
1536 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1538 #define ATTRSMODULE "attributes"
1539 #define ATTRSMODULE_PM "attributes.pm"
1542 /* Don't force the C<use> if we don't need it. */
1543 SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1544 sizeof(ATTRSMODULE_PM)-1, 0);
1545 if (svp && *svp != &PL_sv_undef)
1546 ; /* already in %INC */
1548 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1549 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1553 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1554 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1556 prepend_elem(OP_LIST,
1557 newSVOP(OP_CONST, 0, stashsv),
1558 prepend_elem(OP_LIST,
1559 newSVOP(OP_CONST, 0,
1561 dup_attrlist(attrs))));
1567 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1569 OP *pack, *imop, *arg;
1575 assert(target->op_type == OP_PADSV ||
1576 target->op_type == OP_PADHV ||
1577 target->op_type == OP_PADAV);
1579 /* Ensure that attributes.pm is loaded. */
1580 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1582 /* Need package name for method call. */
1583 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1585 /* Build up the real arg-list. */
1586 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1588 arg = newOP(OP_PADSV, 0);
1589 arg->op_targ = target->op_targ;
1590 arg = prepend_elem(OP_LIST,
1591 newSVOP(OP_CONST, 0, stashsv),
1592 prepend_elem(OP_LIST,
1593 newUNOP(OP_REFGEN, 0,
1594 mod(arg, OP_REFGEN)),
1595 dup_attrlist(attrs)));
1597 /* Fake up a method call to import */
1598 meth = newSVpvn("import", 6);
1599 SvUPGRADE(meth, SVt_PVIV);
1600 (void)SvIOK_on(meth);
1603 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
1604 SvUV_set(meth, hash);
1606 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1607 append_elem(OP_LIST,
1608 prepend_elem(OP_LIST, pack, list(arg)),
1609 newSVOP(OP_METHOD_NAMED, 0, meth)));
1610 imop->op_private |= OPpENTERSUB_NOMOD;
1612 /* Combine the ops. */
1613 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1617 =notfor apidoc apply_attrs_string
1619 Attempts to apply a list of attributes specified by the C<attrstr> and
1620 C<len> arguments to the subroutine identified by the C<cv> argument which
1621 is expected to be associated with the package identified by the C<stashpv>
1622 argument (see L<attributes>). It gets this wrong, though, in that it
1623 does not correctly identify the boundaries of the individual attribute
1624 specifications within C<attrstr>. This is not really intended for the
1625 public API, but has to be listed here for systems such as AIX which
1626 need an explicit export list for symbols. (It's called from XS code
1627 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1628 to respect attribute syntax properly would be welcome.
1634 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1635 const char *attrstr, STRLEN len)
1640 len = strlen(attrstr);
1644 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1646 const char *sstr = attrstr;
1647 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1648 attrs = append_elem(OP_LIST, attrs,
1649 newSVOP(OP_CONST, 0,
1650 newSVpvn(sstr, attrstr-sstr)));
1654 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1655 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1656 Nullsv, prepend_elem(OP_LIST,
1657 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1658 prepend_elem(OP_LIST,
1659 newSVOP(OP_CONST, 0,
1665 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1669 if (!o || PL_error_count)
1673 if (type == OP_LIST) {
1675 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1676 my_kid(kid, attrs, imopsp);
1677 } else if (type == OP_UNDEF) {
1679 } else if (type == OP_RV2SV || /* "our" declaration */
1681 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1682 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1683 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1684 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1686 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1688 PL_in_my_stash = Nullhv;
1689 apply_attrs(GvSTASH(gv),
1690 (type == OP_RV2SV ? GvSV(gv) :
1691 type == OP_RV2AV ? (SV*)GvAV(gv) :
1692 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1695 o->op_private |= OPpOUR_INTRO;
1698 else if (type != OP_PADSV &&
1701 type != OP_PUSHMARK)
1703 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1705 PL_in_my == KEY_our ? "our" : "my"));
1708 else if (attrs && type != OP_PUSHMARK) {
1712 PL_in_my_stash = Nullhv;
1714 /* check for C<my Dog $spot> when deciding package */
1715 stash = PAD_COMPNAME_TYPE(o->op_targ);
1717 stash = PL_curstash;
1718 apply_attrs_my(stash, o, attrs, imopsp);
1720 o->op_flags |= OPf_MOD;
1721 o->op_private |= OPpLVAL_INTRO;
1726 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1729 int maybe_scalar = 0;
1731 /* [perl #17376]: this appears to be premature, and results in code such as
1732 C< our(%x); > executing in list mode rather than void mode */
1734 if (o->op_flags & OPf_PARENS)
1743 o = my_kid(o, attrs, &rops);
1745 if (maybe_scalar && o->op_type == OP_PADSV) {
1746 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1747 o->op_private |= OPpLVAL_INTRO;
1750 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1753 PL_in_my_stash = Nullhv;
1758 Perl_my(pTHX_ OP *o)
1760 return my_attrs(o, Nullop);
1764 Perl_sawparens(pTHX_ OP *o)
1767 o->op_flags |= OPf_PARENS;
1772 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1777 if (ckWARN(WARN_MISC) &&
1778 (left->op_type == OP_RV2AV ||
1779 left->op_type == OP_RV2HV ||
1780 left->op_type == OP_PADAV ||
1781 left->op_type == OP_PADHV)) {
1782 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1783 right->op_type == OP_TRANS)
1784 ? right->op_type : OP_MATCH];
1785 const char *sample = ((left->op_type == OP_RV2AV ||
1786 left->op_type == OP_PADAV)
1787 ? "@array" : "%hash");
1788 Perl_warner(aTHX_ packWARN(WARN_MISC),
1789 "Applying %s to %s will act on scalar(%s)",
1790 desc, sample, sample);
1793 if (right->op_type == OP_CONST &&
1794 cSVOPx(right)->op_private & OPpCONST_BARE &&
1795 cSVOPx(right)->op_private & OPpCONST_STRICT)
1797 no_bareword_allowed(right);
1800 ismatchop = right->op_type == OP_MATCH ||
1801 right->op_type == OP_SUBST ||
1802 right->op_type == OP_TRANS;
1803 if (ismatchop && right->op_private & OPpTARGET_MY) {
1805 right->op_private &= ~OPpTARGET_MY;
1807 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1808 right->op_flags |= OPf_STACKED;
1809 if (right->op_type != OP_MATCH &&
1810 ! (right->op_type == OP_TRANS &&
1811 right->op_private & OPpTRANS_IDENTICAL))
1812 left = mod(left, right->op_type);
1813 if (right->op_type == OP_TRANS)
1814 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1816 o = prepend_elem(right->op_type, scalar(left), right);
1818 return newUNOP(OP_NOT, 0, scalar(o));
1822 return bind_match(type, left,
1823 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1827 Perl_invert(pTHX_ OP *o)
1831 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1832 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1836 Perl_scope(pTHX_ OP *o)
1840 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1841 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1842 o->op_type = OP_LEAVE;
1843 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1845 else if (o->op_type == OP_LINESEQ) {
1847 o->op_type = OP_SCOPE;
1848 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1849 kid = ((LISTOP*)o)->op_first;
1850 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1854 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1859 /* XXX kept for BINCOMPAT only */
1861 Perl_save_hints(pTHX)
1863 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1867 Perl_block_start(pTHX_ int full)
1869 const int retval = PL_savestack_ix;
1870 pad_block_start(full);
1872 PL_hints &= ~HINT_BLOCK_SCOPE;
1873 SAVESPTR(PL_compiling.cop_warnings);
1874 if (! specialWARN(PL_compiling.cop_warnings)) {
1875 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1876 SAVEFREESV(PL_compiling.cop_warnings) ;
1878 SAVESPTR(PL_compiling.cop_io);
1879 if (! specialCopIO(PL_compiling.cop_io)) {
1880 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1881 SAVEFREESV(PL_compiling.cop_io) ;
1887 Perl_block_end(pTHX_ I32 floor, OP *seq)
1889 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1890 OP* retval = scalarseq(seq);
1892 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1894 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1902 const I32 offset = pad_findmy("$_");
1903 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1904 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1907 OP *o = newOP(OP_PADSV, 0);
1908 o->op_targ = offset;
1914 Perl_newPROG(pTHX_ OP *o)
1919 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1920 ((PL_in_eval & EVAL_KEEPERR)
1921 ? OPf_SPECIAL : 0), o);
1922 PL_eval_start = linklist(PL_eval_root);
1923 PL_eval_root->op_private |= OPpREFCOUNTED;
1924 OpREFCNT_set(PL_eval_root, 1);
1925 PL_eval_root->op_next = 0;
1926 CALL_PEEP(PL_eval_start);
1929 if (o->op_type == OP_STUB) {
1930 PL_comppad_name = 0;
1935 PL_main_root = scope(sawparens(scalarvoid(o)));
1936 PL_curcop = &PL_compiling;
1937 PL_main_start = LINKLIST(PL_main_root);
1938 PL_main_root->op_private |= OPpREFCOUNTED;
1939 OpREFCNT_set(PL_main_root, 1);
1940 PL_main_root->op_next = 0;
1941 CALL_PEEP(PL_main_start);
1944 /* Register with debugger */
1946 CV *cv = get_cv("DB::postponed", FALSE);
1950 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1952 call_sv((SV*)cv, G_DISCARD);
1959 Perl_localize(pTHX_ OP *o, I32 lex)
1961 if (o->op_flags & OPf_PARENS)
1962 /* [perl #17376]: this appears to be premature, and results in code such as
1963 C< our(%x); > executing in list mode rather than void mode */
1970 if (ckWARN(WARN_PARENTHESIS)
1971 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1973 char *s = PL_bufptr;
1976 /* some heuristics to detect a potential error */
1977 while (*s && (strchr(", \t\n", *s)))
1981 if (*s && strchr("@$%*", *s) && *++s
1982 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1985 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1987 while (*s && (strchr(", \t\n", *s)))
1993 if (sigil && (*s == ';' || *s == '=')) {
1994 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1995 "Parentheses missing around \"%s\" list",
1996 lex ? (PL_in_my == KEY_our ? "our" : "my")
2004 o = mod(o, OP_NULL); /* a bit kludgey */
2006 PL_in_my_stash = Nullhv;
2011 Perl_jmaybe(pTHX_ OP *o)
2013 if (o->op_type == OP_LIST) {
2015 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2016 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2022 Perl_fold_constants(pTHX_ register OP *o)
2026 I32 type = o->op_type;
2029 if (PL_opargs[type] & OA_RETSCALAR)
2031 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2032 o->op_targ = pad_alloc(type, SVs_PADTMP);
2034 /* integerize op, unless it happens to be C<-foo>.
2035 * XXX should pp_i_negate() do magic string negation instead? */
2036 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2037 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2038 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2040 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2043 if (!(PL_opargs[type] & OA_FOLDCONST))
2048 /* XXX might want a ck_negate() for this */
2049 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2061 /* XXX what about the numeric ops? */
2062 if (PL_hints & HINT_LOCALE)
2067 goto nope; /* Don't try to run w/ errors */
2069 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2070 if ((curop->op_type != OP_CONST ||
2071 (curop->op_private & OPpCONST_BARE)) &&
2072 curop->op_type != OP_LIST &&
2073 curop->op_type != OP_SCALAR &&
2074 curop->op_type != OP_NULL &&
2075 curop->op_type != OP_PUSHMARK)
2081 curop = LINKLIST(o);
2085 sv = *(PL_stack_sp--);
2086 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2087 pad_swipe(o->op_targ, FALSE);
2088 else if (SvTEMP(sv)) { /* grab mortal temp? */
2089 (void)SvREFCNT_inc(sv);
2093 if (type == OP_RV2GV)
2094 return newGVOP(OP_GV, 0, (GV*)sv);
2095 return newSVOP(OP_CONST, 0, sv);
2102 Perl_gen_constant_list(pTHX_ register OP *o)
2106 const I32 oldtmps_floor = PL_tmps_floor;
2110 return o; /* Don't attempt to run with errors */
2112 PL_op = curop = LINKLIST(o);
2119 PL_tmps_floor = oldtmps_floor;
2121 o->op_type = OP_RV2AV;
2122 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2123 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2124 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2125 o->op_opt = 0; /* needs to be revisited in peep() */
2126 curop = ((UNOP*)o)->op_first;
2127 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2134 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2137 if (!o || o->op_type != OP_LIST)
2138 o = newLISTOP(OP_LIST, 0, o, Nullop);
2140 o->op_flags &= ~OPf_WANT;
2142 if (!(PL_opargs[type] & OA_MARK))
2143 op_null(cLISTOPo->op_first);
2145 o->op_type = (OPCODE)type;
2146 o->op_ppaddr = PL_ppaddr[type];
2147 o->op_flags |= flags;
2149 o = CHECKOP(type, o);
2150 if (o->op_type != (unsigned)type)
2153 return fold_constants(o);
2156 /* List constructors */
2159 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2167 if (first->op_type != (unsigned)type
2168 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2170 return newLISTOP(type, 0, first, last);
2173 if (first->op_flags & OPf_KIDS)
2174 ((LISTOP*)first)->op_last->op_sibling = last;
2176 first->op_flags |= OPf_KIDS;
2177 ((LISTOP*)first)->op_first = last;
2179 ((LISTOP*)first)->op_last = last;
2184 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2192 if (first->op_type != (unsigned)type)
2193 return prepend_elem(type, (OP*)first, (OP*)last);
2195 if (last->op_type != (unsigned)type)
2196 return append_elem(type, (OP*)first, (OP*)last);
2198 first->op_last->op_sibling = last->op_first;
2199 first->op_last = last->op_last;
2200 first->op_flags |= (last->op_flags & OPf_KIDS);
2208 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2216 if (last->op_type == (unsigned)type) {
2217 if (type == OP_LIST) { /* already a PUSHMARK there */
2218 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2219 ((LISTOP*)last)->op_first->op_sibling = first;
2220 if (!(first->op_flags & OPf_PARENS))
2221 last->op_flags &= ~OPf_PARENS;
2224 if (!(last->op_flags & OPf_KIDS)) {
2225 ((LISTOP*)last)->op_last = first;
2226 last->op_flags |= OPf_KIDS;
2228 first->op_sibling = ((LISTOP*)last)->op_first;
2229 ((LISTOP*)last)->op_first = first;
2231 last->op_flags |= OPf_KIDS;
2235 return newLISTOP(type, 0, first, last);
2241 Perl_newNULLLIST(pTHX)
2243 return newOP(OP_STUB, 0);
2247 Perl_force_list(pTHX_ OP *o)
2249 if (!o || o->op_type != OP_LIST)
2250 o = newLISTOP(OP_LIST, 0, o, Nullop);
2256 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2261 NewOp(1101, listop, 1, LISTOP);
2263 listop->op_type = (OPCODE)type;
2264 listop->op_ppaddr = PL_ppaddr[type];
2267 listop->op_flags = (U8)flags;
2271 else if (!first && last)
2274 first->op_sibling = last;
2275 listop->op_first = first;
2276 listop->op_last = last;
2277 if (type == OP_LIST) {
2279 pushop = newOP(OP_PUSHMARK, 0);
2280 pushop->op_sibling = first;
2281 listop->op_first = pushop;
2282 listop->op_flags |= OPf_KIDS;
2284 listop->op_last = pushop;
2287 return CHECKOP(type, listop);
2291 Perl_newOP(pTHX_ I32 type, I32 flags)
2295 NewOp(1101, o, 1, OP);
2296 o->op_type = (OPCODE)type;
2297 o->op_ppaddr = PL_ppaddr[type];
2298 o->op_flags = (U8)flags;
2301 o->op_private = (U8)(0 | (flags >> 8));
2302 if (PL_opargs[type] & OA_RETSCALAR)
2304 if (PL_opargs[type] & OA_TARGET)
2305 o->op_targ = pad_alloc(type, SVs_PADTMP);
2306 return CHECKOP(type, o);
2310 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2316 first = newOP(OP_STUB, 0);
2317 if (PL_opargs[type] & OA_MARK)
2318 first = force_list(first);
2320 NewOp(1101, unop, 1, UNOP);
2321 unop->op_type = (OPCODE)type;
2322 unop->op_ppaddr = PL_ppaddr[type];
2323 unop->op_first = first;
2324 unop->op_flags = flags | OPf_KIDS;
2325 unop->op_private = (U8)(1 | (flags >> 8));
2326 unop = (UNOP*) CHECKOP(type, unop);
2330 return fold_constants((OP *) unop);
2334 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2338 NewOp(1101, binop, 1, BINOP);
2341 first = newOP(OP_NULL, 0);
2343 binop->op_type = (OPCODE)type;
2344 binop->op_ppaddr = PL_ppaddr[type];
2345 binop->op_first = first;
2346 binop->op_flags = flags | OPf_KIDS;
2349 binop->op_private = (U8)(1 | (flags >> 8));
2352 binop->op_private = (U8)(2 | (flags >> 8));
2353 first->op_sibling = last;
2356 binop = (BINOP*)CHECKOP(type, binop);
2357 if (binop->op_next || binop->op_type != (OPCODE)type)
2360 binop->op_last = binop->op_first->op_sibling;
2362 return fold_constants((OP *)binop);
2365 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2366 static int uvcompare(const void *a, const void *b)
2368 if (*((const UV *)a) < (*(const UV *)b))
2370 if (*((const UV *)a) > (*(const UV *)b))
2372 if (*((const UV *)a+1) < (*(const UV *)b+1))
2374 if (*((const UV *)a+1) > (*(const UV *)b+1))
2380 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2382 SV *tstr = ((SVOP*)expr)->op_sv;
2383 SV *rstr = ((SVOP*)repl)->op_sv;
2386 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2387 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2394 register short *tbl;
2396 PL_hints |= HINT_BLOCK_SCOPE;
2397 complement = o->op_private & OPpTRANS_COMPLEMENT;
2398 del = o->op_private & OPpTRANS_DELETE;
2399 squash = o->op_private & OPpTRANS_SQUASH;
2402 o->op_private |= OPpTRANS_FROM_UTF;
2405 o->op_private |= OPpTRANS_TO_UTF;
2407 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2408 SV* listsv = newSVpvn("# comment\n",10);
2410 const U8* tend = t + tlen;
2411 const U8* rend = r + rlen;
2425 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2426 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2432 t = tsave = bytes_to_utf8(t, &len);
2435 if (!to_utf && rlen) {
2437 r = rsave = bytes_to_utf8(r, &len);
2441 /* There are several snags with this code on EBCDIC:
2442 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2443 2. scan_const() in toke.c has encoded chars in native encoding which makes
2444 ranges at least in EBCDIC 0..255 range the bottom odd.
2448 U8 tmpbuf[UTF8_MAXBYTES+1];
2451 New(1109, cp, 2*tlen, UV);
2453 transv = newSVpvn("",0);
2455 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2457 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2459 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2463 cp[2*i+1] = cp[2*i];
2467 qsort(cp, i, 2*sizeof(UV), uvcompare);
2468 for (j = 0; j < i; j++) {
2470 diff = val - nextmin;
2472 t = uvuni_to_utf8(tmpbuf,nextmin);
2473 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2475 U8 range_mark = UTF_TO_NATIVE(0xff);
2476 t = uvuni_to_utf8(tmpbuf, val - 1);
2477 sv_catpvn(transv, (char *)&range_mark, 1);
2478 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2485 t = uvuni_to_utf8(tmpbuf,nextmin);
2486 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2488 U8 range_mark = UTF_TO_NATIVE(0xff);
2489 sv_catpvn(transv, (char *)&range_mark, 1);
2491 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2492 UNICODE_ALLOW_SUPER);
2493 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2494 t = (U8*)SvPVX(transv);
2495 tlen = SvCUR(transv);
2499 else if (!rlen && !del) {
2500 r = t; rlen = tlen; rend = tend;
2503 if ((!rlen && !del) || t == r ||
2504 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2506 o->op_private |= OPpTRANS_IDENTICAL;
2510 while (t < tend || tfirst <= tlast) {
2511 /* see if we need more "t" chars */
2512 if (tfirst > tlast) {
2513 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2515 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2517 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2524 /* now see if we need more "r" chars */
2525 if (rfirst > rlast) {
2527 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2529 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2531 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2540 rfirst = rlast = 0xffffffff;
2544 /* now see which range will peter our first, if either. */
2545 tdiff = tlast - tfirst;
2546 rdiff = rlast - rfirst;
2553 if (rfirst == 0xffffffff) {
2554 diff = tdiff; /* oops, pretend rdiff is infinite */
2556 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2557 (long)tfirst, (long)tlast);
2559 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2563 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2564 (long)tfirst, (long)(tfirst + diff),
2567 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2568 (long)tfirst, (long)rfirst);
2570 if (rfirst + diff > max)
2571 max = rfirst + diff;
2573 grows = (tfirst < rfirst &&
2574 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2586 else if (max > 0xff)
2591 Safefree(cPVOPo->op_pv);
2592 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2593 SvREFCNT_dec(listsv);
2595 SvREFCNT_dec(transv);
2597 if (!del && havefinal && rlen)
2598 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2599 newSVuv((UV)final), 0);
2602 o->op_private |= OPpTRANS_GROWS;
2614 tbl = (short*)cPVOPo->op_pv;
2616 Zero(tbl, 256, short);
2617 for (i = 0; i < (I32)tlen; i++)
2619 for (i = 0, j = 0; i < 256; i++) {
2621 if (j >= (I32)rlen) {
2630 if (i < 128 && r[j] >= 128)
2640 o->op_private |= OPpTRANS_IDENTICAL;
2642 else if (j >= (I32)rlen)
2645 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2646 tbl[0x100] = rlen - j;
2647 for (i=0; i < (I32)rlen - j; i++)
2648 tbl[0x101+i] = r[j+i];
2652 if (!rlen && !del) {
2655 o->op_private |= OPpTRANS_IDENTICAL;
2657 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2658 o->op_private |= OPpTRANS_IDENTICAL;
2660 for (i = 0; i < 256; i++)
2662 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2663 if (j >= (I32)rlen) {
2665 if (tbl[t[i]] == -1)
2671 if (tbl[t[i]] == -1) {
2672 if (t[i] < 128 && r[j] >= 128)
2679 o->op_private |= OPpTRANS_GROWS;
2687 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2692 NewOp(1101, pmop, 1, PMOP);
2693 pmop->op_type = (OPCODE)type;
2694 pmop->op_ppaddr = PL_ppaddr[type];
2695 pmop->op_flags = (U8)flags;
2696 pmop->op_private = (U8)(0 | (flags >> 8));
2698 if (PL_hints & HINT_RE_TAINT)
2699 pmop->op_pmpermflags |= PMf_RETAINT;
2700 if (PL_hints & HINT_LOCALE)
2701 pmop->op_pmpermflags |= PMf_LOCALE;
2702 pmop->op_pmflags = pmop->op_pmpermflags;
2707 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2708 repointer = av_pop((AV*)PL_regex_pad[0]);
2709 pmop->op_pmoffset = SvIV(repointer);
2710 SvREPADTMP_off(repointer);
2711 sv_setiv(repointer,0);
2713 repointer = newSViv(0);
2714 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2715 pmop->op_pmoffset = av_len(PL_regex_padav);
2716 PL_regex_pad = AvARRAY(PL_regex_padav);
2721 /* link into pm list */
2722 if (type != OP_TRANS && PL_curstash) {
2723 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2726 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2728 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2729 mg->mg_obj = (SV*)pmop;
2730 PmopSTASH_set(pmop,PL_curstash);
2733 return CHECKOP(type, pmop);
2736 /* Given some sort of match op o, and an expression expr containing a
2737 * pattern, either compile expr into a regex and attach it to o (if it's
2738 * constant), or convert expr into a runtime regcomp op sequence (if it's
2741 * isreg indicates that the pattern is part of a regex construct, eg
2742 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2743 * split "pattern", which aren't. In the former case, expr will be a list
2744 * if the pattern contains more than one term (eg /a$b/) or if it contains
2745 * a replacement, ie s/// or tr///.
2749 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2754 I32 repl_has_vars = 0;
2758 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2759 /* last element in list is the replacement; pop it */
2761 repl = cLISTOPx(expr)->op_last;
2762 kid = cLISTOPx(expr)->op_first;
2763 while (kid->op_sibling != repl)
2764 kid = kid->op_sibling;
2765 kid->op_sibling = Nullop;
2766 cLISTOPx(expr)->op_last = kid;
2769 if (isreg && expr->op_type == OP_LIST &&
2770 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2772 /* convert single element list to element */
2774 expr = cLISTOPx(oe)->op_first->op_sibling;
2775 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2776 cLISTOPx(oe)->op_last = Nullop;
2780 if (o->op_type == OP_TRANS) {
2781 return pmtrans(o, expr, repl);
2784 reglist = isreg && expr->op_type == OP_LIST;
2788 PL_hints |= HINT_BLOCK_SCOPE;
2791 if (expr->op_type == OP_CONST) {
2793 SV *pat = ((SVOP*)expr)->op_sv;
2794 const char *p = SvPV_const(pat, plen);
2795 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2796 U32 was_readonly = SvREADONLY(pat);
2800 sv_force_normal_flags(pat, 0);
2801 assert(!SvREADONLY(pat));
2804 SvREADONLY_off(pat);
2808 sv_setpvn(pat, "\\s+", 3);
2810 SvFLAGS(pat) |= was_readonly;
2812 p = SvPV_const(pat, plen);
2813 pm->op_pmflags |= PMf_SKIPWHITE;
2816 pm->op_pmdynflags |= PMdf_UTF8;
2817 /* FIXME - can we make this function take const char * args? */
2818 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2819 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2820 pm->op_pmflags |= PMf_WHITE;
2824 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2825 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2827 : OP_REGCMAYBE),0,expr);
2829 NewOp(1101, rcop, 1, LOGOP);
2830 rcop->op_type = OP_REGCOMP;
2831 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2832 rcop->op_first = scalar(expr);
2833 rcop->op_flags |= OPf_KIDS
2834 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2835 | (reglist ? OPf_STACKED : 0);
2836 rcop->op_private = 1;
2839 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2841 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2844 /* establish postfix order */
2845 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2847 rcop->op_next = expr;
2848 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2851 rcop->op_next = LINKLIST(expr);
2852 expr->op_next = (OP*)rcop;
2855 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2860 if (pm->op_pmflags & PMf_EVAL) {
2862 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2863 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2865 else if (repl->op_type == OP_CONST)
2869 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2870 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2871 if (curop->op_type == OP_GV) {
2872 GV *gv = cGVOPx_gv(curop);
2874 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2877 else if (curop->op_type == OP_RV2CV)
2879 else if (curop->op_type == OP_RV2SV ||
2880 curop->op_type == OP_RV2AV ||
2881 curop->op_type == OP_RV2HV ||
2882 curop->op_type == OP_RV2GV) {
2883 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2886 else if (curop->op_type == OP_PADSV ||
2887 curop->op_type == OP_PADAV ||
2888 curop->op_type == OP_PADHV ||
2889 curop->op_type == OP_PADANY) {
2892 else if (curop->op_type == OP_PUSHRE)
2893 ; /* Okay here, dangerous in newASSIGNOP */
2903 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2904 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2905 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2906 prepend_elem(o->op_type, scalar(repl), o);
2909 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2910 pm->op_pmflags |= PMf_MAYBE_CONST;
2911 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2913 NewOp(1101, rcop, 1, LOGOP);
2914 rcop->op_type = OP_SUBSTCONT;
2915 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2916 rcop->op_first = scalar(repl);
2917 rcop->op_flags |= OPf_KIDS;
2918 rcop->op_private = 1;
2921 /* establish postfix order */
2922 rcop->op_next = LINKLIST(repl);
2923 repl->op_next = (OP*)rcop;
2925 pm->op_pmreplroot = scalar((OP*)rcop);
2926 pm->op_pmreplstart = LINKLIST(rcop);
2935 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2939 NewOp(1101, svop, 1, SVOP);
2940 svop->op_type = (OPCODE)type;
2941 svop->op_ppaddr = PL_ppaddr[type];
2943 svop->op_next = (OP*)svop;
2944 svop->op_flags = (U8)flags;
2945 if (PL_opargs[type] & OA_RETSCALAR)
2947 if (PL_opargs[type] & OA_TARGET)
2948 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2949 return CHECKOP(type, svop);
2953 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2957 NewOp(1101, padop, 1, PADOP);
2958 padop->op_type = (OPCODE)type;
2959 padop->op_ppaddr = PL_ppaddr[type];
2960 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2961 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2962 PAD_SETSV(padop->op_padix, sv);
2965 padop->op_next = (OP*)padop;
2966 padop->op_flags = (U8)flags;
2967 if (PL_opargs[type] & OA_RETSCALAR)
2969 if (PL_opargs[type] & OA_TARGET)
2970 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2971 return CHECKOP(type, padop);
2975 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2981 return newPADOP(type, flags, SvREFCNT_inc(gv));
2983 return newSVOP(type, flags, SvREFCNT_inc(gv));
2988 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2992 NewOp(1101, pvop, 1, PVOP);
2993 pvop->op_type = (OPCODE)type;
2994 pvop->op_ppaddr = PL_ppaddr[type];
2996 pvop->op_next = (OP*)pvop;
2997 pvop->op_flags = (U8)flags;
2998 if (PL_opargs[type] & OA_RETSCALAR)
3000 if (PL_opargs[type] & OA_TARGET)
3001 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3002 return CHECKOP(type, pvop);
3006 Perl_package(pTHX_ OP *o)
3011 save_hptr(&PL_curstash);
3012 save_item(PL_curstname);
3014 name = SvPV_const(cSVOPo->op_sv, len);
3015 PL_curstash = gv_stashpvn(name, len, TRUE);
3016 sv_setpvn(PL_curstname, name, len);
3019 PL_hints |= HINT_BLOCK_SCOPE;
3020 PL_copline = NOLINE;
3025 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3031 if (idop->op_type != OP_CONST)
3032 Perl_croak(aTHX_ "Module name must be constant");
3036 if (version != Nullop) {
3037 SV *vesv = ((SVOP*)version)->op_sv;
3039 if (arg == Nullop && !SvNIOKp(vesv)) {
3046 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3047 Perl_croak(aTHX_ "Version number must be constant number");
3049 /* Make copy of idop so we don't free it twice */
3050 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3052 /* Fake up a method call to VERSION */
3053 meth = newSVpvn("VERSION",7);
3054 sv_upgrade(meth, SVt_PVIV);
3055 (void)SvIOK_on(meth);
3058 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
3059 SvUV_set(meth, hash);
3061 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3062 append_elem(OP_LIST,
3063 prepend_elem(OP_LIST, pack, list(version)),
3064 newSVOP(OP_METHOD_NAMED, 0, meth)));
3068 /* Fake up an import/unimport */
3069 if (arg && arg->op_type == OP_STUB)
3070 imop = arg; /* no import on explicit () */
3071 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3072 imop = Nullop; /* use 5.0; */
3077 /* Make copy of idop so we don't free it twice */
3078 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3080 /* Fake up a method call to import/unimport */
3081 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3082 SvUPGRADE(meth, SVt_PVIV);
3083 (void)SvIOK_on(meth);
3086 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
3087 SvUV_set(meth, hash);
3089 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3090 append_elem(OP_LIST,
3091 prepend_elem(OP_LIST, pack, list(arg)),
3092 newSVOP(OP_METHOD_NAMED, 0, meth)));
3095 /* Fake up the BEGIN {}, which does its thing immediately. */
3097 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3100 append_elem(OP_LINESEQ,
3101 append_elem(OP_LINESEQ,
3102 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3103 newSTATEOP(0, Nullch, veop)),
3104 newSTATEOP(0, Nullch, imop) ));
3106 /* The "did you use incorrect case?" warning used to be here.
3107 * The problem is that on case-insensitive filesystems one
3108 * might get false positives for "use" (and "require"):
3109 * "use Strict" or "require CARP" will work. This causes
3110 * portability problems for the script: in case-strict
3111 * filesystems the script will stop working.
3113 * The "incorrect case" warning checked whether "use Foo"
3114 * imported "Foo" to your namespace, but that is wrong, too:
3115 * there is no requirement nor promise in the language that
3116 * a Foo.pm should or would contain anything in package "Foo".
3118 * There is very little Configure-wise that can be done, either:
3119 * the case-sensitivity of the build filesystem of Perl does not
3120 * help in guessing the case-sensitivity of the runtime environment.
3123 PL_hints |= HINT_BLOCK_SCOPE;
3124 PL_copline = NOLINE;
3126 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3130 =head1 Embedding Functions
3132 =for apidoc load_module
3134 Loads the module whose name is pointed to by the string part of name.
3135 Note that the actual module name, not its filename, should be given.
3136 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3137 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3138 (or 0 for no flags). ver, if specified, provides version semantics
3139 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3140 arguments can be used to specify arguments to the module's import()
3141 method, similar to C<use Foo::Bar VERSION LIST>.
3146 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3149 va_start(args, ver);
3150 vload_module(flags, name, ver, &args);
3154 #ifdef PERL_IMPLICIT_CONTEXT
3156 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3160 va_start(args, ver);
3161 vload_module(flags, name, ver, &args);
3167 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3169 OP *modname, *veop, *imop;
3171 modname = newSVOP(OP_CONST, 0, name);
3172 modname->op_private |= OPpCONST_BARE;
3174 veop = newSVOP(OP_CONST, 0, ver);
3178 if (flags & PERL_LOADMOD_NOIMPORT) {
3179 imop = sawparens(newNULLLIST());
3181 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3182 imop = va_arg(*args, OP*);
3187 sv = va_arg(*args, SV*);
3189 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3190 sv = va_arg(*args, SV*);
3194 const line_t ocopline = PL_copline;
3195 COP * const ocurcop = PL_curcop;
3196 const int oexpect = PL_expect;
3198 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3199 veop, modname, imop);
3200 PL_expect = oexpect;
3201 PL_copline = ocopline;
3202 PL_curcop = ocurcop;
3207 Perl_dofile(pTHX_ OP *term)
3212 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3213 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3214 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3216 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3217 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3218 append_elem(OP_LIST, term,
3219 scalar(newUNOP(OP_RV2CV, 0,
3224 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3230 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3232 return newBINOP(OP_LSLICE, flags,
3233 list(force_list(subscript)),
3234 list(force_list(listval)) );
3238 S_is_list_assignment(pTHX_ register const OP *o)
3243 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3244 o = cUNOPo->op_first;
3246 if (o->op_type == OP_COND_EXPR) {
3247 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3248 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3253 yyerror("Assignment to both a list and a scalar");
3257 if (o->op_type == OP_LIST &&
3258 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3259 o->op_private & OPpLVAL_INTRO)
3262 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3263 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3264 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3267 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3270 if (o->op_type == OP_RV2SV)
3277 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3282 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3283 return newLOGOP(optype, 0,
3284 mod(scalar(left), optype),
3285 newUNOP(OP_SASSIGN, 0, scalar(right)));
3288 return newBINOP(optype, OPf_STACKED,
3289 mod(scalar(left), optype), scalar(right));
3293 if (is_list_assignment(left)) {
3297 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3298 left = mod(left, OP_AASSIGN);
3306 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3307 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3308 && right->op_type == OP_STUB
3309 && (left->op_private & OPpLVAL_INTRO))
3312 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3315 curop = list(force_list(left));
3316 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3317 o->op_private = (U8)(0 | (flags >> 8));
3319 /* PL_generation sorcery:
3320 * an assignment like ($a,$b) = ($c,$d) is easier than
3321 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3322 * To detect whether there are common vars, the global var
3323 * PL_generation is incremented for each assign op we compile.
3324 * Then, while compiling the assign op, we run through all the
3325 * variables on both sides of the assignment, setting a spare slot
3326 * in each of them to PL_generation. If any of them already have
3327 * that value, we know we've got commonality. We could use a
3328 * single bit marker, but then we'd have to make 2 passes, first
3329 * to clear the flag, then to test and set it. To find somewhere
3330 * to store these values, evil chicanery is done with SvCUR().
3333 if (!(left->op_private & OPpLVAL_INTRO)) {
3336 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3337 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3338 if (curop->op_type == OP_GV) {
3339 GV *gv = cGVOPx_gv(curop);
3340 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3342 SvCUR_set(gv, PL_generation);
3344 else if (curop->op_type == OP_PADSV ||
3345 curop->op_type == OP_PADAV ||
3346 curop->op_type == OP_PADHV ||
3347 curop->op_type == OP_PADANY)
3349 if (PAD_COMPNAME_GEN(curop->op_targ)
3350 == (STRLEN)PL_generation)
3352 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3355 else if (curop->op_type == OP_RV2CV)
3357 else if (curop->op_type == OP_RV2SV ||
3358 curop->op_type == OP_RV2AV ||
3359 curop->op_type == OP_RV2HV ||
3360 curop->op_type == OP_RV2GV) {
3361 if (lastop->op_type != OP_GV) /* funny deref? */
3364 else if (curop->op_type == OP_PUSHRE) {
3365 if (((PMOP*)curop)->op_pmreplroot) {
3367 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3368 ((PMOP*)curop)->op_pmreplroot));
3370 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3372 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3374 SvCUR_set(gv, PL_generation);
3383 o->op_private |= OPpASSIGN_COMMON;
3385 if (right && right->op_type == OP_SPLIT) {
3387 if ((tmpop = ((LISTOP*)right)->op_first) &&
3388 tmpop->op_type == OP_PUSHRE)
3390 PMOP *pm = (PMOP*)tmpop;
3391 if (left->op_type == OP_RV2AV &&
3392 !(left->op_private & OPpLVAL_INTRO) &&
3393 !(o->op_private & OPpASSIGN_COMMON) )
3395 tmpop = ((UNOP*)left)->op_first;
3396 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3398 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3399 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3401 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3402 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3404 pm->op_pmflags |= PMf_ONCE;
3405 tmpop = cUNOPo->op_first; /* to list (nulled) */
3406 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3407 tmpop->op_sibling = Nullop; /* don't free split */
3408 right->op_next = tmpop->op_next; /* fix starting loc */
3409 op_free(o); /* blow off assign */
3410 right->op_flags &= ~OPf_WANT;
3411 /* "I don't know and I don't care." */
3416 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3417 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3419 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3421 sv_setiv(sv, PL_modcount+1);
3429 right = newOP(OP_UNDEF, 0);
3430 if (right->op_type == OP_READLINE) {
3431 right->op_flags |= OPf_STACKED;
3432 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3435 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3436 o = newBINOP(OP_SASSIGN, flags,
3437 scalar(right), mod(scalar(left), OP_SASSIGN) );
3449 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3452 const U32 seq = intro_my();
3455 NewOp(1101, cop, 1, COP);
3456 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3457 cop->op_type = OP_DBSTATE;
3458 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3461 cop->op_type = OP_NEXTSTATE;
3462 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3464 cop->op_flags = (U8)flags;
3465 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3467 cop->op_private |= NATIVE_HINTS;
3469 PL_compiling.op_private = cop->op_private;
3470 cop->op_next = (OP*)cop;
3473 cop->cop_label = label;
3474 PL_hints |= HINT_BLOCK_SCOPE;
3477 cop->cop_arybase = PL_curcop->cop_arybase;
3478 if (specialWARN(PL_curcop->cop_warnings))
3479 cop->cop_warnings = PL_curcop->cop_warnings ;
3481 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3482 if (specialCopIO(PL_curcop->cop_io))
3483 cop->cop_io = PL_curcop->cop_io;
3485 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3488 if (PL_copline == NOLINE)
3489 CopLINE_set(cop, CopLINE(PL_curcop));
3491 CopLINE_set(cop, PL_copline);
3492 PL_copline = NOLINE;
3495 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3497 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3499 CopSTASH_set(cop, PL_curstash);
3501 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3502 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3503 if (svp && *svp != &PL_sv_undef ) {
3504 (void)SvIOK_on(*svp);
3505 SvIV_set(*svp, PTR2IV(cop));
3509 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3514 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3517 return new_logop(type, flags, &first, &other);
3521 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3526 OP *first = *firstp;
3527 OP *other = *otherp;
3529 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3530 return newBINOP(type, flags, scalar(first), scalar(other));
3532 scalarboolean(first);
3533 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3534 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3535 if (type == OP_AND || type == OP_OR) {
3541 first = *firstp = cUNOPo->op_first;
3543 first->op_next = o->op_next;
3544 cUNOPo->op_first = Nullop;
3548 if (first->op_type == OP_CONST) {
3549 if (first->op_private & OPpCONST_STRICT)
3550 no_bareword_allowed(first);
3551 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3552 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3553 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3554 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3555 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3558 if (other->op_type == OP_CONST)
3559 other->op_private |= OPpCONST_SHORTCIRCUIT;
3563 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3564 const OP *o2 = other;
3565 if ( ! (o2->op_type == OP_LIST
3566 && (( o2 = cUNOPx(o2)->op_first))
3567 && o2->op_type == OP_PUSHMARK
3568 && (( o2 = o2->op_sibling)) )
3571 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3572 || o2->op_type == OP_PADHV)
3573 && o2->op_private & OPpLVAL_INTRO
3574 && ckWARN(WARN_DEPRECATED))
3576 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3577 "Deprecated use of my() in false conditional");
3582 if (first->op_type == OP_CONST)
3583 first->op_private |= OPpCONST_SHORTCIRCUIT;
3587 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3588 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3590 const OP *k1 = ((UNOP*)first)->op_first;
3591 const OP *k2 = k1->op_sibling;
3593 switch (first->op_type)
3596 if (k2 && k2->op_type == OP_READLINE
3597 && (k2->op_flags & OPf_STACKED)
3598 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3600 warnop = k2->op_type;
3605 if (k1->op_type == OP_READDIR
3606 || k1->op_type == OP_GLOB
3607 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3608 || k1->op_type == OP_EACH)
3610 warnop = ((k1->op_type == OP_NULL)
3611 ? (OPCODE)k1->op_targ : k1->op_type);
3616 const line_t oldline = CopLINE(PL_curcop);
3617 CopLINE_set(PL_curcop, PL_copline);
3618 Perl_warner(aTHX_ packWARN(WARN_MISC),
3619 "Value of %s%s can be \"0\"; test with defined()",
3621 ((warnop == OP_READLINE || warnop == OP_GLOB)
3622 ? " construct" : "() operator"));
3623 CopLINE_set(PL_curcop, oldline);
3630 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3631 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3633 NewOp(1101, logop, 1, LOGOP);
3635 logop->op_type = (OPCODE)type;
3636 logop->op_ppaddr = PL_ppaddr[type];
3637 logop->op_first = first;
3638 logop->op_flags = flags | OPf_KIDS;
3639 logop->op_other = LINKLIST(other);
3640 logop->op_private = (U8)(1 | (flags >> 8));
3642 /* establish postfix order */
3643 logop->op_next = LINKLIST(first);
3644 first->op_next = (OP*)logop;
3645 first->op_sibling = other;
3647 CHECKOP(type,logop);
3649 o = newUNOP(OP_NULL, 0, (OP*)logop);
3656 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3664 return newLOGOP(OP_AND, 0, first, trueop);
3666 return newLOGOP(OP_OR, 0, first, falseop);
3668 scalarboolean(first);
3669 if (first->op_type == OP_CONST) {
3670 if (first->op_private & OPpCONST_BARE &&
3671 first->op_private & OPpCONST_STRICT) {
3672 no_bareword_allowed(first);
3674 if (SvTRUE(((SVOP*)first)->op_sv)) {
3685 NewOp(1101, logop, 1, LOGOP);
3686 logop->op_type = OP_COND_EXPR;
3687 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3688 logop->op_first = first;
3689 logop->op_flags = flags | OPf_KIDS;
3690 logop->op_private = (U8)(1 | (flags >> 8));
3691 logop->op_other = LINKLIST(trueop);
3692 logop->op_next = LINKLIST(falseop);
3694 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3697 /* establish postfix order */
3698 start = LINKLIST(first);
3699 first->op_next = (OP*)logop;
3701 first->op_sibling = trueop;
3702 trueop->op_sibling = falseop;
3703 o = newUNOP(OP_NULL, 0, (OP*)logop);
3705 trueop->op_next = falseop->op_next = o;
3712 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3721 NewOp(1101, range, 1, LOGOP);
3723 range->op_type = OP_RANGE;
3724 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3725 range->op_first = left;
3726 range->op_flags = OPf_KIDS;
3727 leftstart = LINKLIST(left);
3728 range->op_other = LINKLIST(right);
3729 range->op_private = (U8)(1 | (flags >> 8));
3731 left->op_sibling = right;
3733 range->op_next = (OP*)range;
3734 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3735 flop = newUNOP(OP_FLOP, 0, flip);
3736 o = newUNOP(OP_NULL, 0, flop);
3738 range->op_next = leftstart;
3740 left->op_next = flip;
3741 right->op_next = flop;
3743 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3744 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3745 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3746 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3748 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3749 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3752 if (!flip->op_private || !flop->op_private)
3753 linklist(o); /* blow off optimizer unless constant */
3759 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3763 const bool once = block && block->op_flags & OPf_SPECIAL &&
3764 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3768 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3769 return block; /* do {} while 0 does once */
3770 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3771 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3772 expr = newUNOP(OP_DEFINED, 0,
3773 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3774 } else if (expr->op_flags & OPf_KIDS) {
3775 const OP *k1 = ((UNOP*)expr)->op_first;
3776 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3777 switch (expr->op_type) {
3779 if (k2 && k2->op_type == OP_READLINE
3780 && (k2->op_flags & OPf_STACKED)
3781 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3782 expr = newUNOP(OP_DEFINED, 0, expr);
3786 if (k1->op_type == OP_READDIR
3787 || k1->op_type == OP_GLOB
3788 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3789 || k1->op_type == OP_EACH)
3790 expr = newUNOP(OP_DEFINED, 0, expr);
3796 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3797 * op, in listop. This is wrong. [perl #27024] */
3799 block = newOP(OP_NULL, 0);
3800 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3801 o = new_logop(OP_AND, 0, &expr, &listop);
3804 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3806 if (once && o != listop)
3807 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3810 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3812 o->op_flags |= flags;
3814 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3819 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3820 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3830 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3831 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3832 expr = newUNOP(OP_DEFINED, 0,
3833 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3834 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3835 const OP *k1 = ((UNOP*)expr)->op_first;
3836 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3837 switch (expr->op_type) {
3839 if (k2 && k2->op_type == OP_READLINE
3840 && (k2->op_flags & OPf_STACKED)
3841 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3842 expr = newUNOP(OP_DEFINED, 0, expr);
3846 if (k1->op_type == OP_READDIR
3847 || k1->op_type == OP_GLOB
3848 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3849 || k1->op_type == OP_EACH)
3850 expr = newUNOP(OP_DEFINED, 0, expr);
3856 block = newOP(OP_NULL, 0);
3857 else if (cont || has_my) {
3858 block = scope(block);
3862 next = LINKLIST(cont);
3865 OP *unstack = newOP(OP_UNSTACK, 0);
3868 cont = append_elem(OP_LINESEQ, cont, unstack);
3871 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3872 redo = LINKLIST(listop);
3875 PL_copline = (line_t)whileline;
3877 o = new_logop(OP_AND, 0, &expr, &listop);
3878 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3879 op_free(expr); /* oops, it's a while (0) */
3881 return Nullop; /* listop already freed by new_logop */
3884 ((LISTOP*)listop)->op_last->op_next =
3885 (o == listop ? redo : LINKLIST(o));
3891 NewOp(1101,loop,1,LOOP);
3892 loop->op_type = OP_ENTERLOOP;
3893 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3894 loop->op_private = 0;
3895 loop->op_next = (OP*)loop;
3898 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3900 loop->op_redoop = redo;
3901 loop->op_lastop = o;
3902 o->op_private |= loopflags;
3905 loop->op_nextop = next;
3907 loop->op_nextop = o;
3909 o->op_flags |= flags;
3910 o->op_private |= (flags >> 8);
3915 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3920 PADOFFSET padoff = 0;
3925 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3926 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3927 sv->op_type = OP_RV2GV;
3928 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3930 else if (sv->op_type == OP_PADSV) { /* private variable */
3931 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3932 padoff = sv->op_targ;
3937 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3938 padoff = sv->op_targ;
3940 iterflags |= OPf_SPECIAL;
3945 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3948 const I32 offset = pad_findmy("$_");
3949 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3950 sv = newGVOP(OP_GV, 0, PL_defgv);
3956 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3957 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3958 iterflags |= OPf_STACKED;
3960 else if (expr->op_type == OP_NULL &&
3961 (expr->op_flags & OPf_KIDS) &&
3962 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3964 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3965 * set the STACKED flag to indicate that these values are to be
3966 * treated as min/max values by 'pp_iterinit'.
3968 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3969 LOGOP* range = (LOGOP*) flip->op_first;
3970 OP* const left = range->op_first;
3971 OP* const right = left->op_sibling;
3974 range->op_flags &= ~OPf_KIDS;
3975 range->op_first = Nullop;
3977 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3978 listop->op_first->op_next = range->op_next;
3979 left->op_next = range->op_other;
3980 right->op_next = (OP*)listop;
3981 listop->op_next = listop->op_first;
3984 expr = (OP*)(listop);
3986 iterflags |= OPf_STACKED;
3989 expr = mod(force_list(expr), OP_GREPSTART);
3992 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3993 append_elem(OP_LIST, expr, scalar(sv))));
3994 assert(!loop->op_next);
3995 /* for my $x () sets OPpLVAL_INTRO;
3996 * for our $x () sets OPpOUR_INTRO */
3997 loop->op_private = (U8)iterpflags;
3998 #ifdef PL_OP_SLAB_ALLOC
4001 NewOp(1234,tmp,1,LOOP);
4002 Copy(loop,tmp,1,LISTOP);
4007 Renew(loop, 1, LOOP);
4009 loop->op_targ = padoff;
4010 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4011 PL_copline = forline;
4012 return newSTATEOP(0, label, wop);
4016 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4020 if (type != OP_GOTO || label->op_type == OP_CONST) {
4021 /* "last()" means "last" */
4022 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4023 o = newOP(type, OPf_SPECIAL);
4025 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4026 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4032 /* Check whether it's going to be a goto &function */
4033 if (label->op_type == OP_ENTERSUB
4034 && !(label->op_flags & OPf_STACKED))
4035 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4036 o = newUNOP(type, OPf_STACKED, label);
4038 PL_hints |= HINT_BLOCK_SCOPE;
4043 =for apidoc cv_undef
4045 Clear out all the active components of a CV. This can happen either
4046 by an explicit C<undef &foo>, or by the reference count going to zero.
4047 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4048 children can still follow the full lexical scope chain.
4054 Perl_cv_undef(pTHX_ CV *cv)
4058 if (CvFILE(cv) && !CvXSUB(cv)) {
4059 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4060 Safefree(CvFILE(cv));
4065 if (!CvXSUB(cv) && CvROOT(cv)) {
4067 Perl_croak(aTHX_ "Can't undef active subroutine");
4070 PAD_SAVE_SETNULLPAD();
4072 op_free(CvROOT(cv));
4073 CvROOT(cv) = Nullop;
4074 CvSTART(cv) = Nullop;
4077 SvPOK_off((SV*)cv); /* forget prototype */
4082 /* remove CvOUTSIDE unless this is an undef rather than a free */
4083 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4084 if (!CvWEAKOUTSIDE(cv))
4085 SvREFCNT_dec(CvOUTSIDE(cv));
4086 CvOUTSIDE(cv) = Nullcv;
4089 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4095 /* delete all flags except WEAKOUTSIDE */
4096 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4100 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4102 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4103 SV* msg = sv_newmortal();
4107 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4108 sv_setpv(msg, "Prototype mismatch:");
4110 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4112 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4114 Perl_sv_catpv(aTHX_ msg, ": none");
4115 sv_catpv(msg, " vs ");
4117 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4119 sv_catpv(msg, "none");
4120 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4124 static void const_sv_xsub(pTHX_ CV* cv);
4128 =head1 Optree Manipulation Functions
4130 =for apidoc cv_const_sv
4132 If C<cv> is a constant sub eligible for inlining. returns the constant
4133 value returned by the sub. Otherwise, returns NULL.
4135 Constant subs can be created with C<newCONSTSUB> or as described in
4136 L<perlsub/"Constant Functions">.
4141 Perl_cv_const_sv(pTHX_ CV *cv)
4143 if (!cv || !CvCONST(cv))
4145 return (SV*)CvXSUBANY(cv).any_ptr;
4148 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4149 * Can be called in 3 ways:
4152 * look for a single OP_CONST with attached value: return the value
4154 * cv && CvCLONE(cv) && !CvCONST(cv)
4156 * examine the clone prototype, and if contains only a single
4157 * OP_CONST referencing a pad const, or a single PADSV referencing
4158 * an outer lexical, return a non-zero value to indicate the CV is
4159 * a candidate for "constizing" at clone time
4163 * We have just cloned an anon prototype that was marked as a const
4164 * candidiate. Try to grab the current value, and in the case of
4165 * PADSV, ignore it if it has multiple references. Return the value.
4169 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4176 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4177 o = cLISTOPo->op_first->op_sibling;
4179 for (; o; o = o->op_next) {
4180 OPCODE type = o->op_type;
4182 if (sv && o->op_next == o)
4184 if (o->op_next != o) {
4185 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4187 if (type == OP_DBSTATE)
4190 if (type == OP_LEAVESUB || type == OP_RETURN)
4194 if (type == OP_CONST && cSVOPo->op_sv)
4196 else if (cv && type == OP_CONST) {
4197 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4201 else if (cv && type == OP_PADSV) {
4202 if (CvCONST(cv)) { /* newly cloned anon */
4203 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4204 /* the candidate should have 1 ref from this pad and 1 ref
4205 * from the parent */
4206 if (!sv || SvREFCNT(sv) != 2)
4213 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4214 sv = &PL_sv_undef; /* an arbitrary non-null value */
4225 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4236 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4240 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4242 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4246 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4256 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4259 assert(proto->op_type == OP_CONST);
4260 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4265 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4266 SV *sv = sv_newmortal();
4267 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4268 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4269 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4270 aname = SvPVX_const(sv);
4274 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4275 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4277 : gv_fetchpv(aname ? aname
4278 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4279 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4289 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4290 maximum a prototype before. */
4291 if (SvTYPE(gv) > SVt_NULL) {
4292 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4293 && ckWARN_d(WARN_PROTOTYPE))
4295 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4297 cv_ckproto((CV*)gv, NULL, ps);
4300 sv_setpvn((SV*)gv, ps, ps_len);
4302 sv_setiv((SV*)gv, -1);
4303 SvREFCNT_dec(PL_compcv);
4304 cv = PL_compcv = NULL;
4305 PL_sub_generation++;
4309 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4311 #ifdef GV_UNIQUE_CHECK
4312 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4313 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4317 if (!block || !ps || *ps || attrs)
4320 const_sv = op_const_sv(block, Nullcv);
4323 const bool exists = CvROOT(cv) || CvXSUB(cv);
4325 #ifdef GV_UNIQUE_CHECK
4326 if (exists && GvUNIQUE(gv)) {
4327 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4331 /* if the subroutine doesn't exist and wasn't pre-declared
4332 * with a prototype, assume it will be AUTOLOADed,
4333 * skipping the prototype check
4335 if (exists || SvPOK(cv))
4336 cv_ckproto(cv, gv, ps);
4337 /* already defined (or promised)? */
4338 if (exists || GvASSUMECV(gv)) {
4339 if (!block && !attrs) {
4340 if (CvFLAGS(PL_compcv)) {
4341 /* might have had built-in attrs applied */
4342 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4344 /* just a "sub foo;" when &foo is already defined */
4345 SAVEFREESV(PL_compcv);
4348 /* ahem, death to those who redefine active sort subs */
4349 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4350 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4352 if (ckWARN(WARN_REDEFINE)
4354 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4356 const line_t oldline = CopLINE(PL_curcop);
4357 if (PL_copline != NOLINE)
4358 CopLINE_set(PL_curcop, PL_copline);
4359 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4360 CvCONST(cv) ? "Constant subroutine %s redefined"
4361 : "Subroutine %s redefined", name);
4362 CopLINE_set(PL_curcop, oldline);
4370 (void)SvREFCNT_inc(const_sv);
4372 assert(!CvROOT(cv) && !CvCONST(cv));
4373 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4374 CvXSUBANY(cv).any_ptr = const_sv;
4375 CvXSUB(cv) = const_sv_xsub;
4380 cv = newCONSTSUB(NULL, name, const_sv);
4383 SvREFCNT_dec(PL_compcv);
4385 PL_sub_generation++;
4392 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4393 * before we clobber PL_compcv.
4397 /* Might have had built-in attributes applied -- propagate them. */
4398 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4399 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4400 stash = GvSTASH(CvGV(cv));
4401 else if (CvSTASH(cv))
4402 stash = CvSTASH(cv);
4404 stash = PL_curstash;
4407 /* possibly about to re-define existing subr -- ignore old cv */
4408 rcv = (SV*)PL_compcv;
4409 if (name && GvSTASH(gv))
4410 stash = GvSTASH(gv);
4412 stash = PL_curstash;
4414 apply_attrs(stash, rcv, attrs, FALSE);
4416 if (cv) { /* must reuse cv if autoloaded */
4418 /* got here with just attrs -- work done, so bug out */
4419 SAVEFREESV(PL_compcv);
4422 /* transfer PL_compcv to cv */
4424 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4425 if (!CvWEAKOUTSIDE(cv))
4426 SvREFCNT_dec(CvOUTSIDE(cv));
4427 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4428 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4429 CvOUTSIDE(PL_compcv) = 0;
4430 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4431 CvPADLIST(PL_compcv) = 0;
4432 /* inner references to PL_compcv must be fixed up ... */
4433 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4434 /* ... before we throw it away */
4435 SvREFCNT_dec(PL_compcv);
4437 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4438 ++PL_sub_generation;
4445 PL_sub_generation++;
4449 CvFILE_set_from_cop(cv, PL_curcop);
4450 CvSTASH(cv) = PL_curstash;
4453 sv_setpvn((SV*)cv, ps, ps_len);
4455 if (PL_error_count) {
4459 const char *s = strrchr(name, ':');
4461 if (strEQ(s, "BEGIN")) {
4462 const char not_safe[] =
4463 "BEGIN not safe after errors--compilation aborted";
4464 if (PL_in_eval & EVAL_KEEPERR)
4465 Perl_croak(aTHX_ not_safe);
4467 /* force display of errors found but not reported */
4468 sv_catpv(ERRSV, not_safe);
4469 Perl_croak(aTHX_ "%"SVf, ERRSV);
4478 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4479 mod(scalarseq(block), OP_LEAVESUBLV));
4482 /* This makes sub {}; work as expected. */
4483 if (block->op_type == OP_STUB) {
4485 block = newSTATEOP(0, Nullch, 0);
4487 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4489 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4490 OpREFCNT_set(CvROOT(cv), 1);
4491 CvSTART(cv) = LINKLIST(CvROOT(cv));
4492 CvROOT(cv)->op_next = 0;
4493 CALL_PEEP(CvSTART(cv));
4495 /* now that optimizer has done its work, adjust pad values */
4497 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4500 assert(!CvCONST(cv));
4501 if (ps && !*ps && op_const_sv(block, cv))
4505 if (name || aname) {
4507 const char *tname = (name ? name : aname);
4509 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4510 SV *sv = NEWSV(0,0);
4511 SV *tmpstr = sv_newmortal();
4512 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4516 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4518 (long)PL_subline, (long)CopLINE(PL_curcop));
4519 gv_efullname3(tmpstr, gv, Nullch);
4520 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4521 hv = GvHVn(db_postponed);
4522 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
4523 && (pcv = GvCV(db_postponed)))
4529 call_sv((SV*)pcv, G_DISCARD);
4533 if ((s = strrchr(tname,':')))
4538 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4541 if (strEQ(s, "BEGIN") && !PL_error_count) {
4542 const I32 oldscope = PL_scopestack_ix;
4544 SAVECOPFILE(&PL_compiling);
4545 SAVECOPLINE(&PL_compiling);
4548 PL_beginav = newAV();
4549 DEBUG_x( dump_sub(gv) );
4550 av_push(PL_beginav, (SV*)cv);
4551 GvCV(gv) = 0; /* cv has been hijacked */
4552 call_list(oldscope, PL_beginav);
4554 PL_curcop = &PL_compiling;
4555 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4558 else if (strEQ(s, "END") && !PL_error_count) {
4561 DEBUG_x( dump_sub(gv) );
4562 av_unshift(PL_endav, 1);
4563 av_store(PL_endav, 0, (SV*)cv);
4564 GvCV(gv) = 0; /* cv has been hijacked */
4566 else if (strEQ(s, "CHECK") && !PL_error_count) {
4568 PL_checkav = newAV();
4569 DEBUG_x( dump_sub(gv) );
4570 if (PL_main_start && ckWARN(WARN_VOID))
4571 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4572 av_unshift(PL_checkav, 1);
4573 av_store(PL_checkav, 0, (SV*)cv);
4574 GvCV(gv) = 0; /* cv has been hijacked */
4576 else if (strEQ(s, "INIT") && !PL_error_count) {
4578 PL_initav = newAV();
4579 DEBUG_x( dump_sub(gv) );
4580 if (PL_main_start && ckWARN(WARN_VOID))
4581 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4582 av_push(PL_initav, (SV*)cv);
4583 GvCV(gv) = 0; /* cv has been hijacked */
4588 PL_copline = NOLINE;
4593 /* XXX unsafe for threads if eval_owner isn't held */
4595 =for apidoc newCONSTSUB
4597 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4598 eligible for inlining at compile-time.
4604 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4611 SAVECOPLINE(PL_curcop);
4612 CopLINE_set(PL_curcop, PL_copline);
4615 PL_hints &= ~HINT_BLOCK_SCOPE;
4618 SAVESPTR(PL_curstash);
4619 SAVECOPSTASH(PL_curcop);
4620 PL_curstash = stash;
4621 CopSTASH_set(PL_curcop,stash);
4624 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4625 CvXSUBANY(cv).any_ptr = sv;
4627 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4630 CopSTASH_free(PL_curcop);
4638 =for apidoc U||newXS
4640 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4646 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4648 GV *gv = gv_fetchpv(name ? name :
4649 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4650 GV_ADDMULTI, SVt_PVCV);
4654 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4656 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4658 /* just a cached method */
4662 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4663 /* already defined (or promised) */
4664 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4665 if (ckWARN(WARN_REDEFINE)) {
4666 GV * const gvcv = CvGV(cv);
4668 HV * const stash = GvSTASH(gvcv);
4670 const char *name = HvNAME_get(stash);
4671 if ( strEQ(name,"autouse") ) {
4672 const line_t oldline = CopLINE(PL_curcop);
4673 if (PL_copline != NOLINE)
4674 CopLINE_set(PL_curcop, PL_copline);
4675 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4676 CvCONST(cv) ? "Constant subroutine %s redefined"
4677 : "Subroutine %s redefined"
4679 CopLINE_set(PL_curcop, oldline);
4689 if (cv) /* must reuse cv if autoloaded */
4692 cv = (CV*)NEWSV(1105,0);
4693 sv_upgrade((SV *)cv, SVt_PVCV);
4697 PL_sub_generation++;
4701 (void)gv_fetchfile(filename);
4702 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4703 an external constant string */
4704 CvXSUB(cv) = subaddr;
4707 const char *s = strrchr(name,':');
4713 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4716 if (strEQ(s, "BEGIN")) {
4718 PL_beginav = newAV();
4719 av_push(PL_beginav, (SV*)cv);
4720 GvCV(gv) = 0; /* cv has been hijacked */
4722 else if (strEQ(s, "END")) {
4725 av_unshift(PL_endav, 1);
4726 av_store(PL_endav, 0, (SV*)cv);
4727 GvCV(gv) = 0; /* cv has been hijacked */
4729 else if (strEQ(s, "CHECK")) {
4731 PL_checkav = newAV();
4732 if (PL_main_start && ckWARN(WARN_VOID))
4733 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4734 av_unshift(PL_checkav, 1);
4735 av_store(PL_checkav, 0, (SV*)cv);
4736 GvCV(gv) = 0; /* cv has been hijacked */
4738 else if (strEQ(s, "INIT")) {
4740 PL_initav = newAV();
4741 if (PL_main_start && ckWARN(WARN_VOID))
4742 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4743 av_push(PL_initav, (SV*)cv);
4744 GvCV(gv) = 0; /* cv has been hijacked */
4755 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4761 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4763 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4765 #ifdef GV_UNIQUE_CHECK
4767 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4771 if ((cv = GvFORM(gv))) {
4772 if (ckWARN(WARN_REDEFINE)) {
4773 const line_t oldline = CopLINE(PL_curcop);
4774 if (PL_copline != NOLINE)
4775 CopLINE_set(PL_curcop, PL_copline);
4776 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4777 o ? "Format %"SVf" redefined"
4778 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4779 CopLINE_set(PL_curcop, oldline);
4786 CvFILE_set_from_cop(cv, PL_curcop);
4789 pad_tidy(padtidy_FORMAT);
4790 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4791 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4792 OpREFCNT_set(CvROOT(cv), 1);
4793 CvSTART(cv) = LINKLIST(CvROOT(cv));
4794 CvROOT(cv)->op_next = 0;
4795 CALL_PEEP(CvSTART(cv));
4797 PL_copline = NOLINE;
4802 Perl_newANONLIST(pTHX_ OP *o)
4804 return newUNOP(OP_REFGEN, 0,
4805 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4809 Perl_newANONHASH(pTHX_ OP *o)
4811 return newUNOP(OP_REFGEN, 0,
4812 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4816 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4818 return newANONATTRSUB(floor, proto, Nullop, block);
4822 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4824 return newUNOP(OP_REFGEN, 0,
4825 newSVOP(OP_ANONCODE, 0,
4826 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4830 Perl_oopsAV(pTHX_ OP *o)
4833 switch (o->op_type) {
4835 o->op_type = OP_PADAV;
4836 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4837 return ref(o, OP_RV2AV);
4840 o->op_type = OP_RV2AV;
4841 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4846 if (ckWARN_d(WARN_INTERNAL))
4847 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4854 Perl_oopsHV(pTHX_ OP *o)
4857 switch (o->op_type) {
4860 o->op_type = OP_PADHV;
4861 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4862 return ref(o, OP_RV2HV);
4866 o->op_type = OP_RV2HV;
4867 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4872 if (ckWARN_d(WARN_INTERNAL))
4873 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4880 Perl_newAVREF(pTHX_ OP *o)
4883 if (o->op_type == OP_PADANY) {
4884 o->op_type = OP_PADAV;
4885 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4888 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4889 && ckWARN(WARN_DEPRECATED)) {
4890 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4891 "Using an array as a reference is deprecated");
4893 return newUNOP(OP_RV2AV, 0, scalar(o));
4897 Perl_newGVREF(pTHX_ I32 type, OP *o)
4899 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4900 return newUNOP(OP_NULL, 0, o);
4901 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4905 Perl_newHVREF(pTHX_ OP *o)
4908 if (o->op_type == OP_PADANY) {
4909 o->op_type = OP_PADHV;
4910 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4913 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4914 && ckWARN(WARN_DEPRECATED)) {
4915 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4916 "Using a hash as a reference is deprecated");
4918 return newUNOP(OP_RV2HV, 0, scalar(o));
4922 Perl_oopsCV(pTHX_ OP *o)
4924 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4927 NORETURN_FUNCTION_END;
4931 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4933 return newUNOP(OP_RV2CV, flags, scalar(o));
4937 Perl_newSVREF(pTHX_ OP *o)
4940 if (o->op_type == OP_PADANY) {
4941 o->op_type = OP_PADSV;
4942 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4945 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4946 o->op_flags |= OPpDONE_SVREF;
4949 return newUNOP(OP_RV2SV, 0, scalar(o));
4952 /* Check routines. See the comments at the top of this file for details
4953 * on when these are called */
4956 Perl_ck_anoncode(pTHX_ OP *o)
4958 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4959 cSVOPo->op_sv = Nullsv;
4964 Perl_ck_bitop(pTHX_ OP *o)
4966 #define OP_IS_NUMCOMPARE(op) \
4967 ((op) == OP_LT || (op) == OP_I_LT || \
4968 (op) == OP_GT || (op) == OP_I_GT || \
4969 (op) == OP_LE || (op) == OP_I_LE || \
4970 (op) == OP_GE || (op) == OP_I_GE || \
4971 (op) == OP_EQ || (op) == OP_I_EQ || \
4972 (op) == OP_NE || (op) == OP_I_NE || \
4973 (op) == OP_NCMP || (op) == OP_I_NCMP)
4974 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4975 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4976 && (o->op_type == OP_BIT_OR
4977 || o->op_type == OP_BIT_AND
4978 || o->op_type == OP_BIT_XOR))
4980 const OP * const left = cBINOPo->op_first;
4981 const OP * const right = left->op_sibling;
4982 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4983 (left->op_flags & OPf_PARENS) == 0) ||
4984 (OP_IS_NUMCOMPARE(right->op_type) &&
4985 (right->op_flags & OPf_PARENS) == 0))
4986 if (ckWARN(WARN_PRECEDENCE))
4987 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4988 "Possible precedence problem on bitwise %c operator",
4989 o->op_type == OP_BIT_OR ? '|'
4990 : o->op_type == OP_BIT_AND ? '&' : '^'
4997 Perl_ck_concat(pTHX_ OP *o)
4999 const OP *kid = cUNOPo->op_first;
5000 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5001 !(kUNOP->op_first->op_flags & OPf_MOD))
5002 o->op_flags |= OPf_STACKED;
5007 Perl_ck_spair(pTHX_ OP *o)
5010 if (o->op_flags & OPf_KIDS) {
5013 const OPCODE type = o->op_type;
5014 o = modkids(ck_fun(o), type);
5015 kid = cUNOPo->op_first;
5016 newop = kUNOP->op_first->op_sibling;
5018 (newop->op_sibling ||
5019 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5020 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5021 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5025 op_free(kUNOP->op_first);
5026 kUNOP->op_first = newop;
5028 o->op_ppaddr = PL_ppaddr[++o->op_type];
5033 Perl_ck_delete(pTHX_ OP *o)
5037 if (o->op_flags & OPf_KIDS) {
5038 OP *kid = cUNOPo->op_first;
5039 switch (kid->op_type) {
5041 o->op_flags |= OPf_SPECIAL;
5044 o->op_private |= OPpSLICE;
5047 o->op_flags |= OPf_SPECIAL;
5052 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5061 Perl_ck_die(pTHX_ OP *o)
5064 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5070 Perl_ck_eof(pTHX_ OP *o)
5072 const I32 type = o->op_type;
5074 if (o->op_flags & OPf_KIDS) {
5075 if (cLISTOPo->op_first->op_type == OP_STUB) {
5077 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5085 Perl_ck_eval(pTHX_ OP *o)
5088 PL_hints |= HINT_BLOCK_SCOPE;
5089 if (o->op_flags & OPf_KIDS) {
5090 SVOP *kid = (SVOP*)cUNOPo->op_first;
5093 o->op_flags &= ~OPf_KIDS;
5096 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5099 cUNOPo->op_first = 0;
5102 NewOp(1101, enter, 1, LOGOP);
5103 enter->op_type = OP_ENTERTRY;
5104 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5105 enter->op_private = 0;
5107 /* establish postfix order */
5108 enter->op_next = (OP*)enter;
5110 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5111 o->op_type = OP_LEAVETRY;
5112 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5113 enter->op_other = o;
5123 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5125 o->op_targ = (PADOFFSET)PL_hints;
5130 Perl_ck_exit(pTHX_ OP *o)
5133 HV *table = GvHV(PL_hintgv);
5135 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5136 if (svp && *svp && SvTRUE(*svp))
5137 o->op_private |= OPpEXIT_VMSISH;
5139 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5145 Perl_ck_exec(pTHX_ OP *o)
5147 if (o->op_flags & OPf_STACKED) {
5150 kid = cUNOPo->op_first->op_sibling;
5151 if (kid->op_type == OP_RV2GV)
5160 Perl_ck_exists(pTHX_ OP *o)
5163 if (o->op_flags & OPf_KIDS) {
5164 OP *kid = cUNOPo->op_first;
5165 if (kid->op_type == OP_ENTERSUB) {
5166 (void) ref(kid, o->op_type);
5167 if (kid->op_type != OP_RV2CV && !PL_error_count)
5168 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5170 o->op_private |= OPpEXISTS_SUB;
5172 else if (kid->op_type == OP_AELEM)
5173 o->op_flags |= OPf_SPECIAL;
5174 else if (kid->op_type != OP_HELEM)
5175 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5183 Perl_ck_rvconst(pTHX_ register OP *o)
5186 SVOP *kid = (SVOP*)cUNOPo->op_first;
5188 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5189 if (kid->op_type == OP_CONST) {
5192 SV * const kidsv = kid->op_sv;
5194 /* Is it a constant from cv_const_sv()? */
5195 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5196 SV *rsv = SvRV(kidsv);
5197 const int svtype = SvTYPE(rsv);
5198 const char *badtype = Nullch;
5200 switch (o->op_type) {
5202 if (svtype > SVt_PVMG)
5203 badtype = "a SCALAR";
5206 if (svtype != SVt_PVAV)
5207 badtype = "an ARRAY";
5210 if (svtype != SVt_PVHV)
5214 if (svtype != SVt_PVCV)
5219 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5222 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5223 const char *badthing = Nullch;
5224 switch (o->op_type) {
5226 badthing = "a SCALAR";
5229 badthing = "an ARRAY";
5232 badthing = "a HASH";
5237 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5241 * This is a little tricky. We only want to add the symbol if we
5242 * didn't add it in the lexer. Otherwise we get duplicate strict
5243 * warnings. But if we didn't add it in the lexer, we must at
5244 * least pretend like we wanted to add it even if it existed before,
5245 * or we get possible typo warnings. OPpCONST_ENTERED says
5246 * whether the lexer already added THIS instance of this symbol.
5248 iscv = (o->op_type == OP_RV2CV) * 2;
5250 gv = gv_fetchsv(kidsv,
5251 iscv | !(kid->op_private & OPpCONST_ENTERED),
5254 : o->op_type == OP_RV2SV
5256 : o->op_type == OP_RV2AV
5258 : o->op_type == OP_RV2HV
5261 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5263 kid->op_type = OP_GV;
5264 SvREFCNT_dec(kid->op_sv);
5266 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5267 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5268 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5270 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5272 kid->op_sv = SvREFCNT_inc(gv);
5274 kid->op_private = 0;
5275 kid->op_ppaddr = PL_ppaddr[OP_GV];
5282 Perl_ck_ftst(pTHX_ OP *o)
5285 const I32 type = o->op_type;
5287 if (o->op_flags & OPf_REF) {
5290 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5291 SVOP *kid = (SVOP*)cUNOPo->op_first;
5293 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5294 OP *newop = newGVOP(type, OPf_REF,
5295 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5301 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5302 OP_IS_FILETEST_ACCESS(o))
5303 o->op_private |= OPpFT_ACCESS;
5305 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5306 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5307 o->op_private |= OPpFT_STACKED;
5311 if (type == OP_FTTTY)
5312 o = newGVOP(type, OPf_REF, PL_stdingv);
5314 o = newUNOP(type, 0, newDEFSVOP());
5320 Perl_ck_fun(pTHX_ OP *o)
5322 const int type = o->op_type;
5323 register I32 oa = PL_opargs[type] >> OASHIFT;
5325 if (o->op_flags & OPf_STACKED) {
5326 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5329 return no_fh_allowed(o);
5332 if (o->op_flags & OPf_KIDS) {
5333 OP **tokid = &cLISTOPo->op_first;
5334 register OP *kid = cLISTOPo->op_first;
5338 if (kid->op_type == OP_PUSHMARK ||
5339 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5341 tokid = &kid->op_sibling;
5342 kid = kid->op_sibling;
5344 if (!kid && PL_opargs[type] & OA_DEFGV)
5345 *tokid = kid = newDEFSVOP();
5349 sibl = kid->op_sibling;
5352 /* list seen where single (scalar) arg expected? */
5353 if (numargs == 1 && !(oa >> 4)
5354 && kid->op_type == OP_LIST && type != OP_SCALAR)
5356 return too_many_arguments(o,PL_op_desc[type]);
5369 if ((type == OP_PUSH || type == OP_UNSHIFT)
5370 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5371 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5372 "Useless use of %s with no values",
5375 if (kid->op_type == OP_CONST &&
5376 (kid->op_private & OPpCONST_BARE))
5378 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5379 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5380 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5381 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5382 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5383 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5386 kid->op_sibling = sibl;
5389 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5390 bad_type(numargs, "array", PL_op_desc[type], kid);
5394 if (kid->op_type == OP_CONST &&
5395 (kid->op_private & OPpCONST_BARE))
5397 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5398 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5399 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5400 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5401 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5402 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5405 kid->op_sibling = sibl;
5408 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5409 bad_type(numargs, "hash", PL_op_desc[type], kid);
5414 OP *newop = newUNOP(OP_NULL, 0, kid);
5415 kid->op_sibling = 0;
5417 newop->op_next = newop;
5419 kid->op_sibling = sibl;
5424 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5425 if (kid->op_type == OP_CONST &&
5426 (kid->op_private & OPpCONST_BARE))
5428 OP *newop = newGVOP(OP_GV, 0,
5429 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5430 if (!(o->op_private & 1) && /* if not unop */
5431 kid == cLISTOPo->op_last)
5432 cLISTOPo->op_last = newop;
5436 else if (kid->op_type == OP_READLINE) {
5437 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5438 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5441 I32 flags = OPf_SPECIAL;
5445 /* is this op a FH constructor? */
5446 if (is_handle_constructor(o,numargs)) {
5447 const char *name = Nullch;
5451 /* Set a flag to tell rv2gv to vivify
5452 * need to "prove" flag does not mean something
5453 * else already - NI-S 1999/05/07
5456 if (kid->op_type == OP_PADSV) {
5457 name = PAD_COMPNAME_PV(kid->op_targ);
5458 /* SvCUR of a pad namesv can't be trusted
5459 * (see PL_generation), so calc its length
5465 else if (kid->op_type == OP_RV2SV
5466 && kUNOP->op_first->op_type == OP_GV)
5468 GV *gv = cGVOPx_gv(kUNOP->op_first);
5470 len = GvNAMELEN(gv);
5472 else if (kid->op_type == OP_AELEM
5473 || kid->op_type == OP_HELEM)
5478 if ((op = ((BINOP*)kid)->op_first)) {
5479 SV *tmpstr = Nullsv;
5481 kid->op_type == OP_AELEM ?
5483 if (((op->op_type == OP_RV2AV) ||
5484 (op->op_type == OP_RV2HV)) &&
5485 (op = ((UNOP*)op)->op_first) &&
5486 (op->op_type == OP_GV)) {
5487 /* packagevar $a[] or $h{} */
5488 GV *gv = cGVOPx_gv(op);
5496 else if (op->op_type == OP_PADAV
5497 || op->op_type == OP_PADHV) {
5498 /* lexicalvar $a[] or $h{} */
5499 const char *padname =
5500 PAD_COMPNAME_PV(op->op_targ);
5510 name = SvPV(tmpstr, len);
5515 name = "__ANONIO__";
5522 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5523 namesv = PAD_SVl(targ);
5524 SvUPGRADE(namesv, SVt_PV);
5526 sv_setpvn(namesv, "$", 1);
5527 sv_catpvn(namesv, name, len);
5530 kid->op_sibling = 0;
5531 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5532 kid->op_targ = targ;
5533 kid->op_private |= priv;
5535 kid->op_sibling = sibl;
5541 mod(scalar(kid), type);
5545 tokid = &kid->op_sibling;
5546 kid = kid->op_sibling;
5548 o->op_private |= numargs;
5550 return too_many_arguments(o,OP_DESC(o));
5553 else if (PL_opargs[type] & OA_DEFGV) {
5555 return newUNOP(type, 0, newDEFSVOP());
5559 while (oa & OA_OPTIONAL)
5561 if (oa && oa != OA_LIST)
5562 return too_few_arguments(o,OP_DESC(o));
5568 Perl_ck_glob(pTHX_ OP *o)
5574 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5575 append_elem(OP_GLOB, o, newDEFSVOP());
5577 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5578 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5580 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5583 #if !defined(PERL_EXTERNAL_GLOB)
5584 /* XXX this can be tightened up and made more failsafe. */
5585 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5588 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5589 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5590 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5591 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5592 GvCV(gv) = GvCV(glob_gv);
5593 (void)SvREFCNT_inc((SV*)GvCV(gv));
5594 GvIMPORTED_CV_on(gv);
5597 #endif /* PERL_EXTERNAL_GLOB */
5599 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5600 append_elem(OP_GLOB, o,
5601 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5602 o->op_type = OP_LIST;
5603 o->op_ppaddr = PL_ppaddr[OP_LIST];
5604 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5605 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5606 cLISTOPo->op_first->op_targ = 0;
5607 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5608 append_elem(OP_LIST, o,
5609 scalar(newUNOP(OP_RV2CV, 0,
5610 newGVOP(OP_GV, 0, gv)))));
5611 o = newUNOP(OP_NULL, 0, ck_subr(o));
5612 o->op_targ = OP_GLOB; /* hint at what it used to be */
5615 gv = newGVgen("main");
5617 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5623 Perl_ck_grep(pTHX_ OP *o)
5628 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5631 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5632 NewOp(1101, gwop, 1, LOGOP);
5634 if (o->op_flags & OPf_STACKED) {
5637 kid = cLISTOPo->op_first->op_sibling;
5638 if (!cUNOPx(kid)->op_next)
5639 Perl_croak(aTHX_ "panic: ck_grep");
5640 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5643 kid->op_next = (OP*)gwop;
5644 o->op_flags &= ~OPf_STACKED;
5646 kid = cLISTOPo->op_first->op_sibling;
5647 if (type == OP_MAPWHILE)
5654 kid = cLISTOPo->op_first->op_sibling;
5655 if (kid->op_type != OP_NULL)
5656 Perl_croak(aTHX_ "panic: ck_grep");
5657 kid = kUNOP->op_first;
5659 gwop->op_type = type;
5660 gwop->op_ppaddr = PL_ppaddr[type];
5661 gwop->op_first = listkids(o);
5662 gwop->op_flags |= OPf_KIDS;
5663 gwop->op_other = LINKLIST(kid);
5664 kid->op_next = (OP*)gwop;
5665 offset = pad_findmy("$_");
5666 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5667 o->op_private = gwop->op_private = 0;
5668 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5671 o->op_private = gwop->op_private = OPpGREP_LEX;
5672 gwop->op_targ = o->op_targ = offset;
5675 kid = cLISTOPo->op_first->op_sibling;
5676 if (!kid || !kid->op_sibling)
5677 return too_few_arguments(o,OP_DESC(o));
5678 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5679 mod(kid, OP_GREPSTART);
5685 Perl_ck_index(pTHX_ OP *o)
5687 if (o->op_flags & OPf_KIDS) {
5688 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5690 kid = kid->op_sibling; /* get past "big" */
5691 if (kid && kid->op_type == OP_CONST)
5692 fbm_compile(((SVOP*)kid)->op_sv, 0);
5698 Perl_ck_lengthconst(pTHX_ OP *o)
5700 /* XXX length optimization goes here */
5705 Perl_ck_lfun(pTHX_ OP *o)
5707 const OPCODE type = o->op_type;
5708 return modkids(ck_fun(o), type);
5712 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5714 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5715 switch (cUNOPo->op_first->op_type) {
5717 /* This is needed for
5718 if (defined %stash::)
5719 to work. Do not break Tk.
5721 break; /* Globals via GV can be undef */
5723 case OP_AASSIGN: /* Is this a good idea? */
5724 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5725 "defined(@array) is deprecated");
5726 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5727 "\t(Maybe you should just omit the defined()?)\n");
5730 /* This is needed for
5731 if (defined %stash::)
5732 to work. Do not break Tk.
5734 break; /* Globals via GV can be undef */
5736 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5737 "defined(%%hash) is deprecated");
5738 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5739 "\t(Maybe you should just omit the defined()?)\n");
5750 Perl_ck_rfun(pTHX_ OP *o)
5752 const OPCODE type = o->op_type;
5753 return refkids(ck_fun(o), type);
5757 Perl_ck_listiob(pTHX_ OP *o)
5761 kid = cLISTOPo->op_first;
5764 kid = cLISTOPo->op_first;
5766 if (kid->op_type == OP_PUSHMARK)
5767 kid = kid->op_sibling;
5768 if (kid && o->op_flags & OPf_STACKED)
5769 kid = kid->op_sibling;
5770 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5771 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5772 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5773 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5774 cLISTOPo->op_first->op_sibling = kid;
5775 cLISTOPo->op_last = kid;
5776 kid = kid->op_sibling;
5781 append_elem(o->op_type, o, newDEFSVOP());
5787 Perl_ck_sassign(pTHX_ OP *o)
5789 OP *kid = cLISTOPo->op_first;
5790 /* has a disposable target? */
5791 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5792 && !(kid->op_flags & OPf_STACKED)
5793 /* Cannot steal the second time! */
5794 && !(kid->op_private & OPpTARGET_MY))
5796 OP *kkid = kid->op_sibling;
5798 /* Can just relocate the target. */
5799 if (kkid && kkid->op_type == OP_PADSV
5800 && !(kkid->op_private & OPpLVAL_INTRO))
5802 kid->op_targ = kkid->op_targ;
5804 /* Now we do not need PADSV and SASSIGN. */
5805 kid->op_sibling = o->op_sibling; /* NULL */
5806 cLISTOPo->op_first = NULL;
5809 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5813 /* optimise C<my $x = undef> to C<my $x> */
5814 if (kid->op_type == OP_UNDEF) {
5815 OP *kkid = kid->op_sibling;
5816 if (kkid && kkid->op_type == OP_PADSV
5817 && (kkid->op_private & OPpLVAL_INTRO))
5819 cLISTOPo->op_first = NULL;
5820 kid->op_sibling = NULL;
5830 Perl_ck_match(pTHX_ OP *o)
5832 if (o->op_type != OP_QR) {
5833 const I32 offset = pad_findmy("$_");
5834 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5835 o->op_targ = offset;
5836 o->op_private |= OPpTARGET_MY;
5839 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5840 o->op_private |= OPpRUNTIME;
5845 Perl_ck_method(pTHX_ OP *o)
5847 OP *kid = cUNOPo->op_first;
5848 if (kid->op_type == OP_CONST) {
5849 SV* sv = kSVOP->op_sv;
5850 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5852 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5853 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5856 kSVOP->op_sv = Nullsv;
5858 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5867 Perl_ck_null(pTHX_ OP *o)
5873 Perl_ck_open(pTHX_ OP *o)
5875 HV *table = GvHV(PL_hintgv);
5879 svp = hv_fetch(table, "open_IN", 7, FALSE);
5881 mode = mode_from_discipline(*svp);
5882 if (mode & O_BINARY)
5883 o->op_private |= OPpOPEN_IN_RAW;
5884 else if (mode & O_TEXT)
5885 o->op_private |= OPpOPEN_IN_CRLF;
5888 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5890 mode = mode_from_discipline(*svp);
5891 if (mode & O_BINARY)
5892 o->op_private |= OPpOPEN_OUT_RAW;
5893 else if (mode & O_TEXT)
5894 o->op_private |= OPpOPEN_OUT_CRLF;
5897 if (o->op_type == OP_BACKTICK)
5900 /* In case of three-arg dup open remove strictness
5901 * from the last arg if it is a bareword. */
5902 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5903 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5907 if ((last->op_type == OP_CONST) && /* The bareword. */
5908 (last->op_private & OPpCONST_BARE) &&
5909 (last->op_private & OPpCONST_STRICT) &&
5910 (oa = first->op_sibling) && /* The fh. */
5911 (oa = oa->op_sibling) && /* The mode. */
5912 SvPOK(((SVOP*)oa)->op_sv) &&
5913 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5914 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5915 (last == oa->op_sibling)) /* The bareword. */
5916 last->op_private &= ~OPpCONST_STRICT;
5922 Perl_ck_repeat(pTHX_ OP *o)
5924 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5925 o->op_private |= OPpREPEAT_DOLIST;
5926 cBINOPo->op_first = force_list(cBINOPo->op_first);
5934 Perl_ck_require(pTHX_ OP *o)
5938 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5939 SVOP *kid = (SVOP*)cUNOPo->op_first;
5941 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5942 SV *sv = kid->op_sv;
5943 U32 was_readonly = SvREADONLY(sv);
5948 sv_force_normal_flags(sv, 0);
5949 assert(!SvREADONLY(sv));
5956 for (s = SvPVX(sv); *s; s++) {
5957 if (*s == ':' && s[1] == ':') {
5959 Move(s+2, s+1, strlen(s+2)+1, char);
5960 SvCUR_set(sv, SvCUR(sv) - 1);
5963 sv_catpvn(sv, ".pm", 3);
5964 SvFLAGS(sv) |= was_readonly;
5968 /* handle override, if any */
5969 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5970 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5971 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5973 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5974 OP *kid = cUNOPo->op_first;
5975 cUNOPo->op_first = 0;
5977 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5978 append_elem(OP_LIST, kid,
5979 scalar(newUNOP(OP_RV2CV, 0,
5988 Perl_ck_return(pTHX_ OP *o)
5990 if (CvLVALUE(PL_compcv)) {
5992 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5993 mod(kid, OP_LEAVESUBLV);
6000 Perl_ck_retarget(pTHX_ OP *o)
6002 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6009 Perl_ck_select(pTHX_ OP *o)
6013 if (o->op_flags & OPf_KIDS) {
6014 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6015 if (kid && kid->op_sibling) {
6016 o->op_type = OP_SSELECT;
6017 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6019 return fold_constants(o);
6023 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6024 if (kid && kid->op_type == OP_RV2GV)
6025 kid->op_private &= ~HINT_STRICT_REFS;
6030 Perl_ck_shift(pTHX_ OP *o)
6032 const I32 type = o->op_type;
6034 if (!(o->op_flags & OPf_KIDS)) {
6038 argop = newUNOP(OP_RV2AV, 0,
6039 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6040 return newUNOP(type, 0, scalar(argop));
6042 return scalar(modkids(ck_fun(o), type));
6046 Perl_ck_sort(pTHX_ OP *o)
6050 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6052 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6053 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6055 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6057 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6059 if (kid->op_type == OP_SCOPE) {
6063 else if (kid->op_type == OP_LEAVE) {
6064 if (o->op_type == OP_SORT) {
6065 op_null(kid); /* wipe out leave */
6068 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6069 if (k->op_next == kid)
6071 /* don't descend into loops */
6072 else if (k->op_type == OP_ENTERLOOP
6073 || k->op_type == OP_ENTERITER)
6075 k = cLOOPx(k)->op_lastop;
6080 kid->op_next = 0; /* just disconnect the leave */
6081 k = kLISTOP->op_first;
6086 if (o->op_type == OP_SORT) {
6087 /* provide scalar context for comparison function/block */
6093 o->op_flags |= OPf_SPECIAL;
6095 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6098 firstkid = firstkid->op_sibling;
6101 /* provide list context for arguments */
6102 if (o->op_type == OP_SORT)
6109 S_simplify_sort(pTHX_ OP *o)
6111 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6116 if (!(o->op_flags & OPf_STACKED))
6118 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6119 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6120 kid = kUNOP->op_first; /* get past null */
6121 if (kid->op_type != OP_SCOPE)
6123 kid = kLISTOP->op_last; /* get past scope */
6124 switch(kid->op_type) {
6132 k = kid; /* remember this node*/
6133 if (kBINOP->op_first->op_type != OP_RV2SV)
6135 kid = kBINOP->op_first; /* get past cmp */
6136 if (kUNOP->op_first->op_type != OP_GV)
6138 kid = kUNOP->op_first; /* get past rv2sv */
6140 if (GvSTASH(gv) != PL_curstash)
6142 gvname = GvNAME(gv);
6143 if (*gvname == 'a' && gvname[1] == '\0')
6145 else if (*gvname == 'b' && gvname[1] == '\0')
6150 kid = k; /* back to cmp */
6151 if (kBINOP->op_last->op_type != OP_RV2SV)
6153 kid = kBINOP->op_last; /* down to 2nd arg */
6154 if (kUNOP->op_first->op_type != OP_GV)
6156 kid = kUNOP->op_first; /* get past rv2sv */
6158 if (GvSTASH(gv) != PL_curstash)
6160 gvname = GvNAME(gv);
6162 ? !(*gvname == 'a' && gvname[1] == '\0')
6163 : !(*gvname == 'b' && gvname[1] == '\0'))
6165 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6167 o->op_private |= OPpSORT_DESCEND;
6168 if (k->op_type == OP_NCMP)
6169 o->op_private |= OPpSORT_NUMERIC;
6170 if (k->op_type == OP_I_NCMP)
6171 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6172 kid = cLISTOPo->op_first->op_sibling;
6173 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6174 op_free(kid); /* then delete it */
6178 Perl_ck_split(pTHX_ OP *o)
6183 if (o->op_flags & OPf_STACKED)
6184 return no_fh_allowed(o);
6186 kid = cLISTOPo->op_first;
6187 if (kid->op_type != OP_NULL)
6188 Perl_croak(aTHX_ "panic: ck_split");
6189 kid = kid->op_sibling;
6190 op_free(cLISTOPo->op_first);
6191 cLISTOPo->op_first = kid;
6193 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6194 cLISTOPo->op_last = kid; /* There was only one element previously */
6197 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6198 OP *sibl = kid->op_sibling;
6199 kid->op_sibling = 0;
6200 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6201 if (cLISTOPo->op_first == cLISTOPo->op_last)
6202 cLISTOPo->op_last = kid;
6203 cLISTOPo->op_first = kid;
6204 kid->op_sibling = sibl;
6207 kid->op_type = OP_PUSHRE;
6208 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6210 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6211 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6212 "Use of /g modifier is meaningless in split");
6215 if (!kid->op_sibling)
6216 append_elem(OP_SPLIT, o, newDEFSVOP());
6218 kid = kid->op_sibling;
6221 if (!kid->op_sibling)
6222 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6224 kid = kid->op_sibling;
6227 if (kid->op_sibling)
6228 return too_many_arguments(o,OP_DESC(o));
6234 Perl_ck_join(pTHX_ OP *o)
6236 if (ckWARN(WARN_SYNTAX)) {
6237 const OP *kid = cLISTOPo->op_first->op_sibling;
6238 if (kid && kid->op_type == OP_MATCH) {
6239 const REGEXP *re = PM_GETRE(kPMOP);
6240 const char *pmstr = re ? re->precomp : "STRING";
6241 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6242 "/%s/ should probably be written as \"%s\"",
6250 Perl_ck_subr(pTHX_ OP *o)
6252 OP *prev = ((cUNOPo->op_first->op_sibling)
6253 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6254 OP *o2 = prev->op_sibling;
6261 I32 contextclass = 0;
6265 o->op_private |= OPpENTERSUB_HASTARG;
6266 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6267 if (cvop->op_type == OP_RV2CV) {
6269 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6270 op_null(cvop); /* disable rv2cv */
6271 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6272 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6273 GV *gv = cGVOPx_gv(tmpop);
6276 tmpop->op_private |= OPpEARLY_CV;
6279 namegv = CvANON(cv) ? gv : CvGV(cv);
6280 proto = SvPV_nolen((SV*)cv);
6282 if (CvASSERTION(cv)) {
6283 if (PL_hints & HINT_ASSERTING) {
6284 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6285 o->op_private |= OPpENTERSUB_DB;
6289 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6290 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6291 "Impossible to activate assertion call");
6298 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6299 if (o2->op_type == OP_CONST)
6300 o2->op_private &= ~OPpCONST_STRICT;
6301 else if (o2->op_type == OP_LIST) {
6302 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6303 if (o && o->op_type == OP_CONST)
6304 o->op_private &= ~OPpCONST_STRICT;
6307 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6308 if (PERLDB_SUB && PL_curstash != PL_debstash)
6309 o->op_private |= OPpENTERSUB_DB;
6310 while (o2 != cvop) {
6314 return too_many_arguments(o, gv_ename(namegv));
6332 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6334 arg == 1 ? "block or sub {}" : "sub {}",
6335 gv_ename(namegv), o2);
6338 /* '*' allows any scalar type, including bareword */
6341 if (o2->op_type == OP_RV2GV)
6342 goto wrapref; /* autoconvert GLOB -> GLOBref */
6343 else if (o2->op_type == OP_CONST)
6344 o2->op_private &= ~OPpCONST_STRICT;
6345 else if (o2->op_type == OP_ENTERSUB) {
6346 /* accidental subroutine, revert to bareword */
6347 OP *gvop = ((UNOP*)o2)->op_first;
6348 if (gvop && gvop->op_type == OP_NULL) {
6349 gvop = ((UNOP*)gvop)->op_first;
6351 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6354 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6355 (gvop = ((UNOP*)gvop)->op_first) &&
6356 gvop->op_type == OP_GV)
6358 GV *gv = cGVOPx_gv(gvop);
6359 OP *sibling = o2->op_sibling;
6360 SV *n = newSVpvn("",0);
6362 gv_fullname4(n, gv, "", FALSE);
6363 o2 = newSVOP(OP_CONST, 0, n);
6364 prev->op_sibling = o2;
6365 o2->op_sibling = sibling;
6381 if (contextclass++ == 0) {
6382 e = strchr(proto, ']');
6383 if (!e || e == proto)
6396 while (*--p != '[');
6397 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6398 gv_ename(namegv), o2);
6404 if (o2->op_type == OP_RV2GV)
6407 bad_type(arg, "symbol", gv_ename(namegv), o2);
6410 if (o2->op_type == OP_ENTERSUB)
6413 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6416 if (o2->op_type == OP_RV2SV ||
6417 o2->op_type == OP_PADSV ||
6418 o2->op_type == OP_HELEM ||
6419 o2->op_type == OP_AELEM ||
6420 o2->op_type == OP_THREADSV)
6423 bad_type(arg, "scalar", gv_ename(namegv), o2);
6426 if (o2->op_type == OP_RV2AV ||
6427 o2->op_type == OP_PADAV)
6430 bad_type(arg, "array", gv_ename(namegv), o2);
6433 if (o2->op_type == OP_RV2HV ||
6434 o2->op_type == OP_PADHV)
6437 bad_type(arg, "hash", gv_ename(namegv), o2);
6442 OP* sib = kid->op_sibling;
6443 kid->op_sibling = 0;
6444 o2 = newUNOP(OP_REFGEN, 0, kid);
6445 o2->op_sibling = sib;
6446 prev->op_sibling = o2;
6448 if (contextclass && e) {
6463 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6464 gv_ename(namegv), cv);
6469 mod(o2, OP_ENTERSUB);
6471 o2 = o2->op_sibling;
6473 if (proto && !optional &&
6474 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6475 return too_few_arguments(o, gv_ename(namegv));
6478 o=newSVOP(OP_CONST, 0, newSViv(0));
6484 Perl_ck_svconst(pTHX_ OP *o)
6486 SvREADONLY_on(cSVOPo->op_sv);
6491 Perl_ck_trunc(pTHX_ OP *o)
6493 if (o->op_flags & OPf_KIDS) {
6494 SVOP *kid = (SVOP*)cUNOPo->op_first;
6496 if (kid->op_type == OP_NULL)
6497 kid = (SVOP*)kid->op_sibling;
6498 if (kid && kid->op_type == OP_CONST &&
6499 (kid->op_private & OPpCONST_BARE))
6501 o->op_flags |= OPf_SPECIAL;
6502 kid->op_private &= ~OPpCONST_STRICT;
6509 Perl_ck_unpack(pTHX_ OP *o)
6511 OP *kid = cLISTOPo->op_first;
6512 if (kid->op_sibling) {
6513 kid = kid->op_sibling;
6514 if (!kid->op_sibling)
6515 kid->op_sibling = newDEFSVOP();
6521 Perl_ck_substr(pTHX_ OP *o)
6524 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6525 OP *kid = cLISTOPo->op_first;
6527 if (kid->op_type == OP_NULL)
6528 kid = kid->op_sibling;
6530 kid->op_flags |= OPf_MOD;
6536 /* A peephole optimizer. We visit the ops in the order they're to execute.
6537 * See the comments at the top of this file for more details about when
6538 * peep() is called */
6541 Perl_peep(pTHX_ register OP *o)
6544 register OP* oldop = 0;
6546 if (!o || o->op_opt)
6550 SAVEVPTR(PL_curcop);
6551 for (; o; o = o->op_next) {
6555 switch (o->op_type) {
6559 PL_curcop = ((COP*)o); /* for warnings */
6564 if (cSVOPo->op_private & OPpCONST_STRICT)
6565 no_bareword_allowed(o);
6567 case OP_METHOD_NAMED:
6568 /* Relocate sv to the pad for thread safety.
6569 * Despite being a "constant", the SV is written to,
6570 * for reference counts, sv_upgrade() etc. */
6572 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6573 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6574 /* If op_sv is already a PADTMP then it is being used by
6575 * some pad, so make a copy. */
6576 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6577 SvREADONLY_on(PAD_SVl(ix));
6578 SvREFCNT_dec(cSVOPo->op_sv);
6581 SvREFCNT_dec(PAD_SVl(ix));
6582 SvPADTMP_on(cSVOPo->op_sv);
6583 PAD_SETSV(ix, cSVOPo->op_sv);
6584 /* XXX I don't know how this isn't readonly already. */
6585 SvREADONLY_on(PAD_SVl(ix));
6587 cSVOPo->op_sv = Nullsv;
6595 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6596 if (o->op_next->op_private & OPpTARGET_MY) {
6597 if (o->op_flags & OPf_STACKED) /* chained concats */
6598 goto ignore_optimization;
6600 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6601 o->op_targ = o->op_next->op_targ;
6602 o->op_next->op_targ = 0;
6603 o->op_private |= OPpTARGET_MY;
6606 op_null(o->op_next);
6608 ignore_optimization:
6612 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6614 break; /* Scalar stub must produce undef. List stub is noop */
6618 if (o->op_targ == OP_NEXTSTATE
6619 || o->op_targ == OP_DBSTATE
6620 || o->op_targ == OP_SETSTATE)
6622 PL_curcop = ((COP*)o);
6624 /* XXX: We avoid setting op_seq here to prevent later calls
6625 to peep() from mistakenly concluding that optimisation
6626 has already occurred. This doesn't fix the real problem,
6627 though (See 20010220.007). AMS 20010719 */
6628 /* op_seq functionality is now replaced by op_opt */
6629 if (oldop && o->op_next) {
6630 oldop->op_next = o->op_next;
6638 if (oldop && o->op_next) {
6639 oldop->op_next = o->op_next;
6647 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6648 OP* pop = (o->op_type == OP_PADAV) ?
6649 o->op_next : o->op_next->op_next;
6651 if (pop && pop->op_type == OP_CONST &&
6652 ((PL_op = pop->op_next)) &&
6653 pop->op_next->op_type == OP_AELEM &&
6654 !(pop->op_next->op_private &
6655 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6656 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6661 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6662 no_bareword_allowed(pop);
6663 if (o->op_type == OP_GV)
6664 op_null(o->op_next);
6665 op_null(pop->op_next);
6667 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6668 o->op_next = pop->op_next->op_next;
6669 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6670 o->op_private = (U8)i;
6671 if (o->op_type == OP_GV) {
6676 o->op_flags |= OPf_SPECIAL;
6677 o->op_type = OP_AELEMFAST;
6683 if (o->op_next->op_type == OP_RV2SV) {
6684 if (!(o->op_next->op_private & OPpDEREF)) {
6685 op_null(o->op_next);
6686 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6688 o->op_next = o->op_next->op_next;
6689 o->op_type = OP_GVSV;
6690 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6693 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6695 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6696 /* XXX could check prototype here instead of just carping */
6697 SV *sv = sv_newmortal();
6698 gv_efullname3(sv, gv, Nullch);
6699 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6700 "%"SVf"() called too early to check prototype",
6704 else if (o->op_next->op_type == OP_READLINE
6705 && o->op_next->op_next->op_type == OP_CONCAT
6706 && (o->op_next->op_next->op_flags & OPf_STACKED))
6708 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6709 o->op_type = OP_RCATLINE;
6710 o->op_flags |= OPf_STACKED;
6711 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6712 op_null(o->op_next->op_next);
6713 op_null(o->op_next);
6730 while (cLOGOP->op_other->op_type == OP_NULL)
6731 cLOGOP->op_other = cLOGOP->op_other->op_next;
6732 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6738 while (cLOOP->op_redoop->op_type == OP_NULL)
6739 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6740 peep(cLOOP->op_redoop);
6741 while (cLOOP->op_nextop->op_type == OP_NULL)
6742 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6743 peep(cLOOP->op_nextop);
6744 while (cLOOP->op_lastop->op_type == OP_NULL)
6745 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6746 peep(cLOOP->op_lastop);
6753 while (cPMOP->op_pmreplstart &&
6754 cPMOP->op_pmreplstart->op_type == OP_NULL)
6755 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6756 peep(cPMOP->op_pmreplstart);
6761 if (ckWARN(WARN_SYNTAX) && o->op_next
6762 && o->op_next->op_type == OP_NEXTSTATE) {
6763 if (o->op_next->op_sibling &&
6764 o->op_next->op_sibling->op_type != OP_EXIT &&
6765 o->op_next->op_sibling->op_type != OP_WARN &&
6766 o->op_next->op_sibling->op_type != OP_DIE) {
6767 const line_t oldline = CopLINE(PL_curcop);
6769 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6770 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6771 "Statement unlikely to be reached");
6772 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6773 "\t(Maybe you meant system() when you said exec()?)\n");
6774 CopLINE_set(PL_curcop, oldline);
6789 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6792 /* Make the CONST have a shared SV */
6793 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6794 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6795 key = SvPV(sv, keylen);
6796 lexname = newSVpvn_share(key,
6797 SvUTF8(sv) ? -(I32)keylen : keylen,
6803 if ((o->op_private & (OPpLVAL_INTRO)))
6806 rop = (UNOP*)((BINOP*)o)->op_first;
6807 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6809 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6810 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6812 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6813 if (!fields || !GvHV(*fields))
6815 key = SvPV(*svp, keylen);
6816 if (!hv_fetch(GvHV(*fields), key,
6817 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6819 Perl_croak(aTHX_ "No such class field \"%s\" "
6820 "in variable %s of type %s",
6821 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6834 SVOP *first_key_op, *key_op;
6836 if ((o->op_private & (OPpLVAL_INTRO))
6837 /* I bet there's always a pushmark... */
6838 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6839 /* hmmm, no optimization if list contains only one key. */
6841 rop = (UNOP*)((LISTOP*)o)->op_last;
6842 if (rop->op_type != OP_RV2HV)
6844 if (rop->op_first->op_type == OP_PADSV)
6845 /* @$hash{qw(keys here)} */
6846 rop = (UNOP*)rop->op_first;
6848 /* @{$hash}{qw(keys here)} */
6849 if (rop->op_first->op_type == OP_SCOPE
6850 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6852 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6858 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6859 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6861 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6862 if (!fields || !GvHV(*fields))
6864 /* Again guessing that the pushmark can be jumped over.... */
6865 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6866 ->op_first->op_sibling;
6867 for (key_op = first_key_op; key_op;
6868 key_op = (SVOP*)key_op->op_sibling) {
6869 if (key_op->op_type != OP_CONST)
6871 svp = cSVOPx_svp(key_op);
6872 key = SvPV(*svp, keylen);
6873 if (!hv_fetch(GvHV(*fields), key,
6874 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6876 Perl_croak(aTHX_ "No such class field \"%s\" "
6877 "in variable %s of type %s",
6878 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6885 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6889 /* check that RHS of sort is a single plain array */
6890 oright = cUNOPo->op_first;
6891 if (!oright || oright->op_type != OP_PUSHMARK)
6894 /* reverse sort ... can be optimised. */
6895 if (!cUNOPo->op_sibling) {
6896 /* Nothing follows us on the list. */
6897 OP *reverse = o->op_next;
6899 if (reverse->op_type == OP_REVERSE &&
6900 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6901 OP *pushmark = cUNOPx(reverse)->op_first;
6902 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6903 && (cUNOPx(pushmark)->op_sibling == o)) {
6904 /* reverse -> pushmark -> sort */
6905 o->op_private |= OPpSORT_REVERSE;
6907 pushmark->op_next = oright->op_next;
6913 /* make @a = sort @a act in-place */
6917 oright = cUNOPx(oright)->op_sibling;
6920 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6921 oright = cUNOPx(oright)->op_sibling;
6925 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6926 || oright->op_next != o
6927 || (oright->op_private & OPpLVAL_INTRO)
6931 /* o2 follows the chain of op_nexts through the LHS of the
6932 * assign (if any) to the aassign op itself */
6934 if (!o2 || o2->op_type != OP_NULL)
6937 if (!o2 || o2->op_type != OP_PUSHMARK)
6940 if (o2 && o2->op_type == OP_GV)
6943 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6944 || (o2->op_private & OPpLVAL_INTRO)
6949 if (!o2 || o2->op_type != OP_NULL)
6952 if (!o2 || o2->op_type != OP_AASSIGN
6953 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6956 /* check that the sort is the first arg on RHS of assign */
6958 o2 = cUNOPx(o2)->op_first;
6959 if (!o2 || o2->op_type != OP_NULL)
6961 o2 = cUNOPx(o2)->op_first;
6962 if (!o2 || o2->op_type != OP_PUSHMARK)
6964 if (o2->op_sibling != o)
6967 /* check the array is the same on both sides */
6968 if (oleft->op_type == OP_RV2AV) {
6969 if (oright->op_type != OP_RV2AV
6970 || !cUNOPx(oright)->op_first
6971 || cUNOPx(oright)->op_first->op_type != OP_GV
6972 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6973 cGVOPx_gv(cUNOPx(oright)->op_first)
6977 else if (oright->op_type != OP_PADAV
6978 || oright->op_targ != oleft->op_targ
6982 /* transfer MODishness etc from LHS arg to RHS arg */
6983 oright->op_flags = oleft->op_flags;
6984 o->op_private |= OPpSORT_INPLACE;
6986 /* excise push->gv->rv2av->null->aassign */
6987 o2 = o->op_next->op_next;
6988 op_null(o2); /* PUSHMARK */
6990 if (o2->op_type == OP_GV) {
6991 op_null(o2); /* GV */
6994 op_null(o2); /* RV2AV or PADAV */
6995 o2 = o2->op_next->op_next;
6996 op_null(o2); /* AASSIGN */
6998 o->op_next = o2->op_next;
7004 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7006 LISTOP *enter, *exlist;
7009 enter = (LISTOP *) o->op_next;
7012 if (enter->op_type == OP_NULL) {
7013 enter = (LISTOP *) enter->op_next;
7017 /* for $a (...) will have OP_GV then OP_RV2GV here.
7018 for (...) just has an OP_GV. */
7019 if (enter->op_type == OP_GV) {
7020 gvop = (OP *) enter;
7021 enter = (LISTOP *) enter->op_next;
7024 if (enter->op_type == OP_RV2GV) {
7025 enter = (LISTOP *) enter->op_next;
7031 if (enter->op_type != OP_ENTERITER)
7034 iter = enter->op_next;
7035 if (!iter || iter->op_type != OP_ITER)
7038 expushmark = enter->op_first;
7039 if (!expushmark || expushmark->op_type != OP_NULL
7040 || expushmark->op_targ != OP_PUSHMARK)
7043 exlist = (LISTOP *) expushmark->op_sibling;
7044 if (!exlist || exlist->op_type != OP_NULL
7045 || exlist->op_targ != OP_LIST)
7048 if (exlist->op_last != o) {
7049 /* Mmm. Was expecting to point back to this op. */
7052 theirmark = exlist->op_first;
7053 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7056 if (theirmark->op_sibling != o) {
7057 /* There's something between the mark and the reverse, eg
7058 for (1, reverse (...))
7063 ourmark = ((LISTOP *)o)->op_first;
7064 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7067 ourlast = ((LISTOP *)o)->op_last;
7068 if (!ourlast || ourlast->op_next != o)
7071 rv2av = ourmark->op_sibling;
7072 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7073 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7074 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7075 /* We're just reversing a single array. */
7076 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7077 enter->op_flags |= OPf_STACKED;
7080 /* We don't have control over who points to theirmark, so sacrifice
7082 theirmark->op_next = ourmark->op_next;
7083 theirmark->op_flags = ourmark->op_flags;
7084 ourlast->op_next = gvop ? gvop : (OP *) enter;
7087 enter->op_private |= OPpITER_REVERSED;
7088 iter->op_private |= OPpITER_REVERSED;
7103 Perl_custom_op_name(pTHX_ const OP* o)
7105 const IV index = PTR2IV(o->op_ppaddr);
7109 if (!PL_custom_op_names) /* This probably shouldn't happen */
7110 return (char *)PL_op_name[OP_CUSTOM];
7112 keysv = sv_2mortal(newSViv(index));
7114 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7116 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7118 return SvPV_nolen(HeVAL(he));
7122 Perl_custom_op_desc(pTHX_ const OP* o)
7124 const IV index = PTR2IV(o->op_ppaddr);
7128 if (!PL_custom_op_descs)
7129 return (char *)PL_op_desc[OP_CUSTOM];
7131 keysv = sv_2mortal(newSViv(index));
7133 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7135 return (char *)PL_op_desc[OP_CUSTOM];
7137 return SvPV_nolen(HeVAL(he));
7142 /* Efficient sub that returns a constant scalar value. */
7144 const_sv_xsub(pTHX_ CV* cv)
7149 Perl_croak(aTHX_ "usage: %s::%s()",
7150 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7154 ST(0) = (SV*)XSANY.any_ptr;
7160 * c-indentation-style: bsd
7162 * indent-tabs-mode: t
7165 * ex: set ts=8 sts=4 sw=4 noet: